Mirror of GNU Guix
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

407 lines
14 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
  3. ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
  4. ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
  5. ;;;
  6. ;;; This file is part of GNU Guix.
  7. ;;;
  8. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  9. ;;; under the terms of the GNU General Public License as published by
  10. ;;; the Free Software Foundation; either version 3 of the License, or (at
  11. ;;; your option) any later version.
  12. ;;;
  13. ;;; GNU Guix is distributed in the hope that it will be useful, but
  14. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. ;;; GNU General Public License for more details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License
  19. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  20. (define-module (test-packages)
  21. #:use-module (guix tests)
  22. #:use-module (guix download)
  23. #:use-module (guix build-system gnu)
  24. #:use-module (guix packages)
  25. #:use-module (guix scripts lint)
  26. #:use-module (guix ui)
  27. #:use-module (gnu packages)
  28. #:use-module (gnu packages pkg-config)
  29. #:use-module (web server)
  30. #:use-module (web server http)
  31. #:use-module (web response)
  32. #:use-module (ice-9 threads)
  33. #:use-module (srfi srfi-9 gnu)
  34. #:use-module (srfi srfi-64))
  35. ;; Test the linter.
  36. (define %http-server-port
  37. ;; TCP port to use for the stub HTTP server.
  38. 9999)
  39. (define %local-url
  40. ;; URL to use for 'home-page' tests.
  41. (string-append "http://localhost:" (number->string %http-server-port)
  42. "/foo/bar"))
  43. (define %null-sha256
  44. ;; SHA256 of the empty string.
  45. (base32
  46. "0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))
  47. (define %http-server-socket
  48. ;; Socket used by the Web server.
  49. (catch 'system-error
  50. (lambda ()
  51. (let ((sock (socket PF_INET SOCK_STREAM 0)))
  52. (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
  53. (bind sock
  54. (make-socket-address AF_INET INADDR_LOOPBACK
  55. %http-server-port))
  56. sock))
  57. (lambda args
  58. (let ((err (system-error-errno args)))
  59. (format (current-error-port)
  60. "warning: cannot run Web server for tests: ~a~%"
  61. (strerror err))
  62. #f))))
  63. (define (http-write server client response body)
  64. "Write RESPONSE."
  65. (let* ((response (write-response response client))
  66. (port (response-port response)))
  67. (cond
  68. ((not body)) ;pass
  69. (else
  70. (write-response-body response body)))
  71. (close-port port)
  72. (quit #t) ;exit the server thread
  73. (values)))
  74. ;; Mutex and condition variable to synchronize with the HTTP server.
  75. (define %http-server-lock (make-mutex))
  76. (define %http-server-ready (make-condition-variable))
  77. (define (http-open . args)
  78. "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
  79. (with-mutex %http-server-lock
  80. (let ((result (apply (@@ (web server http) http-open) args)))
  81. (signal-condition-variable %http-server-ready)
  82. result)))
  83. (define-server-impl stub-http-server
  84. ;; Stripped-down version of Guile's built-in HTTP server.
  85. http-open
  86. (@@ (web server http) http-read)
  87. http-write
  88. (@@ (web server http) http-close))
  89. (define (call-with-http-server code thunk)
  90. "Call THUNK with an HTTP server running and returning CODE on HTTP
  91. requests."
  92. (define (server-body)
  93. (define (handle request body)
  94. (values (build-response #:code code
  95. #:reason-phrase "Such is life")
  96. "Hello, world."))
  97. (catch 'quit
  98. (lambda ()
  99. (run-server handle stub-http-server
  100. `(#:socket ,%http-server-socket)))
  101. (const #t)))
  102. (with-mutex %http-server-lock
  103. (let ((server (make-thread server-body)))
  104. (wait-condition-variable %http-server-ready %http-server-lock)
  105. ;; Normally SERVER exits automatically once it has received a request.
  106. (thunk))))
  107. (define-syntax-rule (with-http-server code body ...)
  108. (call-with-http-server code (lambda () body ...)))
  109. (test-begin "lint")
  110. (define (call-with-warnings thunk)
  111. (let ((port (open-output-string)))
  112. (parameterize ((guix-warning-port port))
  113. (thunk))
  114. (get-output-string port)))
  115. (define-syntax-rule (with-warnings body ...)
  116. (call-with-warnings (lambda () body ...)))
  117. (test-assert "description: not empty"
  118. (->bool
  119. (string-contains (with-warnings
  120. (let ((pkg (dummy-package "x"
  121. (description ""))))
  122. (check-description-style pkg)))
  123. "description should not be empty")))
  124. (test-assert "description: does not start with an upper-case letter"
  125. (->bool
  126. (string-contains (with-warnings
  127. (let ((pkg (dummy-package "x"
  128. (description "bad description."))))
  129. (check-description-style pkg)))
  130. "description should start with an upper-case letter")))
  131. (test-assert "description: may start with a digit"
  132. (string-null?
  133. (with-warnings
  134. (let ((pkg (dummy-package "x"
  135. (description "2-component library."))))
  136. (check-description-style pkg)))))
  137. (test-assert "description: may start with lower-case package name"
  138. (string-null?
  139. (with-warnings
  140. (let ((pkg (dummy-package "x"
  141. (description "x is a dummy package."))))
  142. (check-description-style pkg)))))
  143. (test-assert "description: two spaces after end of sentence"
  144. (->bool
  145. (string-contains (with-warnings
  146. (let ((pkg (dummy-package "x"
  147. (description "Bad. Quite bad."))))
  148. (check-description-style pkg)))
  149. "sentences in description should be followed by two spaces")))
  150. (test-assert "description: end-of-sentence detection with abbreviations"
  151. (string-null?
  152. (with-warnings
  153. (let ((pkg (dummy-package "x"
  154. (description
  155. "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD)."))))
  156. (check-description-style pkg)))))
  157. (test-assert "synopsis: not empty"
  158. (->bool
  159. (string-contains (with-warnings
  160. (let ((pkg (dummy-package "x"
  161. (synopsis ""))))
  162. (check-synopsis-style pkg)))
  163. "synopsis should not be empty")))
  164. (test-assert "synopsis: does not start with an upper-case letter"
  165. (->bool
  166. (string-contains (with-warnings
  167. (let ((pkg (dummy-package "x"
  168. (synopsis "bad synopsis."))))
  169. (check-synopsis-style pkg)))
  170. "synopsis should start with an upper-case letter")))
  171. (test-assert "synopsis: may start with a digit"
  172. (string-null?
  173. (with-warnings
  174. (let ((pkg (dummy-package "x"
  175. (synopsis "5-dimensional frobnicator"))))
  176. (check-synopsis-style pkg)))))
  177. (test-assert "synopsis: ends with a period"
  178. (->bool
  179. (string-contains (with-warnings
  180. (let ((pkg (dummy-package "x"
  181. (synopsis "Bad synopsis."))))
  182. (check-synopsis-style pkg)))
  183. "no period allowed at the end of the synopsis")))
  184. (test-assert "synopsis: ends with 'etc.'"
  185. (string-null? (with-warnings
  186. (let ((pkg (dummy-package "x"
  187. (synopsis "Foo, bar, etc."))))
  188. (check-synopsis-style pkg)))))
  189. (test-assert "synopsis: starts with 'A'"
  190. (->bool
  191. (string-contains (with-warnings
  192. (let ((pkg (dummy-package "x"
  193. (synopsis "A bad synopŝis"))))
  194. (check-synopsis-style pkg)))
  195. "no article allowed at the beginning of the synopsis")))
  196. (test-assert "synopsis: starts with 'An'"
  197. (->bool
  198. (string-contains (with-warnings
  199. (let ((pkg (dummy-package "x"
  200. (synopsis "An awful synopsis"))))
  201. (check-synopsis-style pkg)))
  202. "no article allowed at the beginning of the synopsis")))
  203. (test-assert "synopsis: starts with 'a'"
  204. (->bool
  205. (string-contains (with-warnings
  206. (let ((pkg (dummy-package "x"
  207. (synopsis "a bad synopsis"))))
  208. (check-synopsis-style pkg)))
  209. "no article allowed at the beginning of the synopsis")))
  210. (test-assert "synopsis: starts with 'an'"
  211. (->bool
  212. (string-contains (with-warnings
  213. (let ((pkg (dummy-package "x"
  214. (synopsis "an awful synopsis"))))
  215. (check-synopsis-style pkg)))
  216. "no article allowed at the beginning of the synopsis")))
  217. (test-assert "synopsis: too long"
  218. (->bool
  219. (string-contains (with-warnings
  220. (let ((pkg (dummy-package "x"
  221. (synopsis (make-string 80 #\x)))))
  222. (check-synopsis-style pkg)))
  223. "synopsis should be less than 80 characters long")))
  224. (test-assert "synopsis: start with package name"
  225. (->bool
  226. (string-contains (with-warnings
  227. (let ((pkg (dummy-package "x"
  228. (name "foo")
  229. (synopsis "foo, a nice package"))))
  230. (check-synopsis-style pkg)))
  231. "synopsis should not start with the package name")))
  232. (test-assert "synopsis: start with package name prefix"
  233. (string-null?
  234. (with-warnings
  235. (let ((pkg (dummy-package "arb"
  236. (synopsis "Arbitrary precision"))))
  237. (check-synopsis-style pkg)))))
  238. (test-assert "synopsis: start with abbreviation"
  239. (string-null?
  240. (with-warnings
  241. (let ((pkg (dummy-package "uucp"
  242. ;; Same problem with "APL interpreter", etc.
  243. (synopsis "UUCP implementation")
  244. (description "Imagine this is Taylor UUCP."))))
  245. (check-synopsis-style pkg)))))
  246. (test-assert "inputs: pkg-config is probably a native input"
  247. (->bool
  248. (string-contains
  249. (with-warnings
  250. (let ((pkg (dummy-package "x"
  251. (inputs `(("pkg-config" ,pkg-config))))))
  252. (check-inputs-should-be-native pkg)))
  253. "pkg-config should probably be a native input")))
  254. (test-assert "patches: file names"
  255. (->bool
  256. (string-contains
  257. (with-warnings
  258. (let ((pkg (dummy-package "x"
  259. (source
  260. (origin
  261. (method url-fetch)
  262. (uri "someurl")
  263. (sha256 "somesha")
  264. (patches (list "/path/to/y.patch")))))))
  265. (check-patches pkg)))
  266. "file names of patches should start with the package name")))
  267. (test-assert "home-page: wrong home-page"
  268. (->bool
  269. (string-contains
  270. (with-warnings
  271. (let ((pkg (package
  272. (inherit (dummy-package "x"))
  273. (home-page #f))))
  274. (check-home-page pkg)))
  275. "invalid")))
  276. (test-assert "home-page: invalid URI"
  277. (->bool
  278. (string-contains
  279. (with-warnings
  280. (let ((pkg (package
  281. (inherit (dummy-package "x"))
  282. (home-page "foobar"))))
  283. (check-home-page pkg)))
  284. "invalid home page URL")))
  285. (test-assert "home-page: host not found"
  286. (->bool
  287. (string-contains
  288. (with-warnings
  289. (let ((pkg (package
  290. (inherit (dummy-package "x"))
  291. (home-page "http://does-not-exist"))))
  292. (check-home-page pkg)))
  293. "domain not found")))
  294. (test-skip (if %http-server-socket 0 1))
  295. (test-assert "home-page: Connection refused"
  296. (->bool
  297. (string-contains
  298. (with-warnings
  299. (let ((pkg (package
  300. (inherit (dummy-package "x"))
  301. (home-page %local-url))))
  302. (check-home-page pkg)))
  303. "Connection refused")))
  304. (test-skip (if %http-server-socket 0 1))
  305. (test-equal "home-page: 200"
  306. ""
  307. (with-warnings
  308. (with-http-server 200
  309. (let ((pkg (package
  310. (inherit (dummy-package "x"))
  311. (home-page %local-url))))
  312. (check-home-page pkg)))))
  313. (test-skip (if %http-server-socket 0 1))
  314. (test-assert "home-page: 404"
  315. (->bool
  316. (string-contains
  317. (with-warnings
  318. (with-http-server 404
  319. (let ((pkg (package
  320. (inherit (dummy-package "x"))
  321. (home-page %local-url))))
  322. (check-home-page pkg))))
  323. "not reachable: 404")))
  324. (test-skip (if %http-server-socket 0 1))
  325. (test-equal "source: 200"
  326. ""
  327. (with-warnings
  328. (with-http-server 200
  329. (let ((pkg (package
  330. (inherit (dummy-package "x"))
  331. (source (origin
  332. (method url-fetch)
  333. (uri %local-url)
  334. (sha256 %null-sha256))))))
  335. (check-source pkg)))))
  336. (test-skip (if %http-server-socket 0 1))
  337. (test-assert "source: 404"
  338. (->bool
  339. (string-contains
  340. (with-warnings
  341. (with-http-server 404
  342. (let ((pkg (package
  343. (inherit (dummy-package "x"))
  344. (source (origin
  345. (method url-fetch)
  346. (uri %local-url)
  347. (sha256 %null-sha256))))))
  348. (check-source pkg))))
  349. "not reachable: 404")))
  350. (test-end "lint")
  351. (exit (= (test-runner-fail-count (test-runner-current)) 0))
  352. ;; Local Variables:
  353. ;; eval: (put 'with-http-server 'scheme-indent-function 1)
  354. ;; eval: (put 'with-warnings 'scheme-indent-function 0)
  355. ;; End: