[jackhill/guix/guix.git] / tests / lint.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-lint)
  #:use-module (guix tests)
  #:use-module (guix download)
  #:use-module (guix build-system gnu)
  #:use-module (guix packages)
  #:use-module (guix scripts lint)
  #:use-module (guix ui)
  #:use-module (gnu packages)
  #:use-module (gnu packages pkg-config)
  #:use-module (web server)
  #:use-module (web server http)
  #:use-module (web response)
  #:use-module (ice-9 threads)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-64))

;; Test the linter.

(define %http-server-port
  ;; TCP port to use for the stub HTTP server.
  9999)

(define %local-url
  ;; URL to use for 'home-page' tests.
  (string-append "http://localhost:" (number->string %http-server-port)
                 "/foo/bar"))

(define %null-sha256
  ;; SHA256 of the empty string.
  (base32
   "0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))

(define %http-server-socket
  ;; Socket used by the Web server.
  (catch 'system-error
    (lambda ()
      (let ((sock (socket PF_INET SOCK_STREAM 0)))
        (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
        (bind sock
              (make-socket-address AF_INET INADDR_LOOPBACK
                                   %http-server-port))
        sock))
    (lambda args
      (let ((err (system-error-errno args)))
        (format (current-error-port)
                "warning: cannot run Web server for tests: ~a~%"
                (strerror err))
        #f))))

(define (http-write server client response body)
  "Write RESPONSE."
  (let* ((response (write-response response client))
         (port     (response-port response)))
    (cond
     ((not body))                                 ;pass
     (else
      (write-response-body response body)))
    (close-port port)
    (quit #t)                                     ;exit the server thread
    (values)))

;; Mutex and condition variable to synchronize with the HTTP server.
(define %http-server-lock (make-mutex))
(define %http-server-ready (make-condition-variable))

(define (http-open . args)
  "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
  (with-mutex %http-server-lock
    (let ((result (apply (@@ (web server http) http-open) args)))
      (signal-condition-variable %http-server-ready)
      result)))

(define-server-impl stub-http-server
  ;; Stripped-down version of Guile's built-in HTTP server.
  http-open
  (@@ (web server http) http-read)
  http-write
  (@@ (web server http) http-close))

(define (call-with-http-server code thunk)
  "Call THUNK with an HTTP server running and returning CODE on HTTP
requests."
  (define (server-body)
    (define (handle request body)
      (values (build-response #:code code
                              #:reason-phrase "Such is life")
              "Hello, world."))

    (catch 'quit
      (lambda ()
        (run-server handle stub-http-server
                    `(#:socket ,%http-server-socket)))
      (const #t)))

  (with-mutex %http-server-lock
    (let ((server (make-thread server-body)))
      (wait-condition-variable %http-server-ready %http-server-lock)
      ;; Normally SERVER exits automatically once it has received a request.
      (thunk))))

(define-syntax-rule (with-http-server code body ...)
  (call-with-http-server code (lambda () body ...)))

\f
(test-begin "lint")

(define (call-with-warnings thunk)
  (let ((port (open-output-string)))
    (parameterize ((guix-warning-port port))
      (thunk))
    (get-output-string port)))

(define-syntax-rule (with-warnings body ...)
  (call-with-warnings (lambda () body ...)))

(test-assert "description: not empty"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (description ""))))
                        (check-description-style pkg)))
                    "description should not be empty")))

(test-assert "description: does not start with an upper-case letter"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (description "bad description."))))
                        (check-description-style pkg)))
                    "description should start with an upper-case letter")))

(test-assert "description: may start with a digit"
  (string-null?
   (with-warnings
     (let ((pkg (dummy-package "x"
                  (description "2-component library."))))
       (check-description-style pkg)))))

(test-assert "description: may start with lower-case package name"
  (string-null?
   (with-warnings
     (let ((pkg (dummy-package "x"
                  (description "x is a dummy package."))))
       (check-description-style pkg)))))

(test-assert "description: two spaces after end of sentence"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (description "Bad. Quite bad."))))
                        (check-description-style pkg)))
                    "sentences in description should be followed by two spaces")))

(test-assert "description: end-of-sentence detection with abbreviations"
  (string-null?
   (with-warnings
     (let ((pkg (dummy-package "x"
                  (description
                   "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD)."))))
       (check-description-style pkg)))))

(test-assert "synopsis: not empty"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis ""))))
                        (check-synopsis-style pkg)))
                    "synopsis should not be empty")))

(test-assert "synopsis: does not start with an upper-case letter"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis "bad synopsis."))))
                        (check-synopsis-style pkg)))
                    "synopsis should start with an upper-case letter")))

(test-assert "synopsis: may start with a digit"
  (string-null?
   (with-warnings
     (let ((pkg (dummy-package "x"
                  (synopsis "5-dimensional frobnicator"))))
       (check-synopsis-style pkg)))))

(test-assert "synopsis: ends with a period"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis "Bad synopsis."))))
                        (check-synopsis-style pkg)))
                    "no period allowed at the end of the synopsis")))

(test-assert "synopsis: ends with 'etc.'"
  (string-null? (with-warnings
                  (let ((pkg (dummy-package "x"
                               (synopsis "Foo, bar, etc."))))
                    (check-synopsis-style pkg)))))

(test-assert "synopsis: starts with 'A'"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis "A bad synopŝis"))))
                        (check-synopsis-style pkg)))
                    "no article allowed at the beginning of the synopsis")))

(test-assert "synopsis: starts with 'An'"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis "An awful synopsis"))))
                        (check-synopsis-style pkg)))
                    "no article allowed at the beginning of the synopsis")))

(test-assert "synopsis: starts with 'a'"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis "a bad synopsis"))))
                        (check-synopsis-style pkg)))
                    "no article allowed at the beginning of the synopsis")))

(test-assert "synopsis: starts with 'an'"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis "an awful synopsis"))))
                        (check-synopsis-style pkg)))
                    "no article allowed at the beginning of the synopsis")))

(test-assert "synopsis: too long"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis (make-string 80 #\x)))))
                        (check-synopsis-style pkg)))
                    "synopsis should be less than 80 characters long")))

(test-assert "synopsis: start with package name"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (name "foo")
                                   (synopsis "foo, a nice package"))))
                        (check-synopsis-style pkg)))
                    "synopsis should not start with the package name")))

(test-assert "synopsis: start with package name prefix"
  (string-null?
   (with-warnings
     (let ((pkg (dummy-package "arb"
                  (synopsis "Arbitrary precision"))))
       (check-synopsis-style pkg)))))

(test-assert "synopsis: start with abbreviation"
  (string-null?
   (with-warnings
     (let ((pkg (dummy-package "uucp"
                  ;; Same problem with "APL interpreter", etc.
                  (synopsis "UUCP implementation")
                  (description "Imagine this is Taylor UUCP."))))
       (check-synopsis-style pkg)))))

(test-assert "inputs: pkg-config is probably a native input"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (inputs `(("pkg-config" ,pkg-config))))))
         (check-inputs-should-be-native pkg)))
         "pkg-config should probably be a native input")))

(test-assert "patches: file names"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (source
                     (origin
                       (method url-fetch)
                       (uri "someurl")
                       (sha256 "somesha")
                       (patches (list "/path/to/y.patch")))))))
         (check-patch-file-names pkg)))
     "file names of patches should start with the package name")))

(test-assert "patches: not found"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (source
                     (origin
                       (method url-fetch)
                       (uri "someurl")
                       (sha256 "somesha")
                       (patches
                        (list (search-patch "this-patch-does-not-exist!"))))))))
         (check-patch-file-names pkg)))
     "patch not found")))

(test-assert "derivation: invalid arguments"
  (->bool
   (string-contains
    (with-warnings
      (let ((pkg (dummy-package "x"
                   (arguments
                    '(#:imported-modules (invalid-module))))))
        (check-derivation pkg)))
    "failed to create derivation")))

(test-assert "license: invalid license"
  (string-contains
   (with-warnings
     (check-license (dummy-package "x" (license #f))))
   "invalid license"))

(test-assert "home-page: wrong home-page"
  (->bool
   (string-contains
    (with-warnings
      (let ((pkg (package
                   (inherit (dummy-package "x"))
                   (home-page #f))))
        (check-home-page pkg)))
    "invalid")))

(test-assert "home-page: invalid URI"
  (->bool
   (string-contains
    (with-warnings
      (let ((pkg (package
                   (inherit (dummy-package "x"))
                   (home-page "foobar"))))
        (check-home-page pkg)))
    "invalid home page URL")))

(test-assert "home-page: host not found"
  (->bool
   (string-contains
    (with-warnings
      (let ((pkg (package
                   (inherit (dummy-package "x"))
                   (home-page "http://does-not-exist"))))
        (check-home-page pkg)))
    "domain not found")))

(test-skip (if %http-server-socket 0 1))
(test-assert "home-page: Connection refused"
  (->bool
   (string-contains
    (with-warnings
      (let ((pkg (package
                   (inherit (dummy-package "x"))
                   (home-page %local-url))))
        (check-home-page pkg)))
    "Connection refused")))

(test-skip (if %http-server-socket 0 1))
(test-equal "home-page: 200"
  ""
  (with-warnings
   (with-http-server 200
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (home-page %local-url))))
       (check-home-page pkg)))))

(test-skip (if %http-server-socket 0 1))
(test-assert "home-page: 404"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 404
        (let ((pkg (package
                     (inherit (dummy-package "x"))
                     (home-page %local-url))))
          (check-home-page pkg))))
    "not reachable: 404")))

(test-skip (if %http-server-socket 0 1))
(test-equal "source: 200"
  ""
  (with-warnings
   (with-http-server 200
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (source (origin
                            (method url-fetch)
                            (uri %local-url)
                            (sha256 %null-sha256))))))
       (check-source pkg)))))

(test-skip (if %http-server-socket 0 1))
(test-assert "source: 404"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 404
        (let ((pkg (package
                     (inherit (dummy-package "x"))
                     (source (origin
                               (method url-fetch)
                               (uri %local-url)
                               (sha256 %null-sha256))))))
          (check-source pkg))))
    "not reachable: 404")))

(test-assert "formatting: tabulation"
  (string-contains
   (with-warnings
     (check-formatting (dummy-package "leave the tab here:	")))
   "tabulation"))

(test-assert "formatting: trailing white space"
  (string-contains
   (with-warnings
     ;; Leave the trailing white space on the next line!
     (check-formatting (dummy-package "x")))            
   "trailing white space"))

(test-assert "formatting: long line"
  (string-contains
   (with-warnings
     (check-formatting
      (dummy-package "x"                          ;here is a stupid comment just to make a long line
                     )))
   "too long"))

(test-assert "formatting: alright"
  (string-null?
   (with-warnings
     (check-formatting (dummy-package "x")))))

(test-end "lint")

\f
(exit (= (test-runner-fail-count (test-runner-current)) 0))

;; Local Variables:
;; eval: (put 'with-http-server 'scheme-indent-function 1)
;; eval: (put 'with-warnings 'scheme-indent-function 0)
;; End:
Commit	Line	Data
b4f5e0e8 CR	1	;;; GNU Guix --- Functional package management for GNU
b4f5e0e8 CR	2	;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
574e847b	3	;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
4655005e	4	;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
b4f5e0e8 CR	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
4e7b6b48	21	(define-module (test-lint)
8b385969	22	#:use-module (guix tests)
754e5be2	23	#:use-module (guix download)
b4f5e0e8 CR	24	#:use-module (guix build-system gnu)
	25	#:use-module (guix packages)
	26	#:use-module (guix scripts lint)
	27	#:use-module (guix ui)
	28	#:use-module (gnu packages)
	29	#:use-module (gnu packages pkg-config)
907c98ac LC	30	#:use-module (web server)
	31	#:use-module (web server http)
	32	#:use-module (web response)
	33	#:use-module (ice-9 threads)
	34	#:use-module (srfi srfi-9 gnu)
b4f5e0e8 CR	35	#:use-module (srfi srfi-64))
	36
	37	;; Test the linter.
	38
907c98ac LC	39	(define %http-server-port
	40	;; TCP port to use for the stub HTTP server.
	41	9999)
	42
	43	(define %local-url
	44	;; URL to use for 'home-page' tests.
	45	(string-append "http://localhost:" (number->string %http-server-port)
	46	"/foo/bar"))
	47
950d2ea4 LC	48	(define %null-sha256
	49	;; SHA256 of the empty string.
	50	(base32
	51	"0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))
	52
907c98ac LC	53	(define %http-server-socket
	54	;; Socket used by the Web server.
	55	(catch 'system-error
	56	(lambda ()
	57	(let ((sock (socket PF_INET SOCK_STREAM 0)))
	58	(setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
	59	(bind sock
	60	(make-socket-address AF_INET INADDR_LOOPBACK
	61	%http-server-port))
	62	sock))
	63	(lambda args
	64	(let ((err (system-error-errno args)))
	65	(format (current-error-port)
	66	"warning: cannot run Web server for tests: ~a~%"
	67	(strerror err))
	68	#f))))
	69
	70	(define (http-write server client response body)
	71	"Write RESPONSE."
	72	(let* ((response (write-response response client))
	73	(port (response-port response)))
	74	(cond
	75	((not body)) ;pass
	76	(else
	77	(write-response-body response body)))
	78	(close-port port)
	79	(quit #t) ;exit the server thread
	80	(values)))
	81
4655005e LC	82	;; Mutex and condition variable to synchronize with the HTTP server.
	83	(define %http-server-lock (make-mutex))
	84	(define %http-server-ready (make-condition-variable))
	85
	86	(define (http-open . args)
	87	"Start listening for HTTP requests and signal %HTTP-SERVER-READY."
	88	(with-mutex %http-server-lock
	89	(let ((result (apply (@@ (web server http) http-open) args)))
	90	(signal-condition-variable %http-server-ready)
	91	result)))
	92
907c98ac LC	93	(define-server-impl stub-http-server
907c98ac LC	94	;; Stripped-down version of Guile's built-in HTTP server.
4655005e	95	http-open
907c98ac LC	96	(@@ (web server http) http-read)
	97	http-write
	98	(@@ (web server http) http-close))
	99
	100	(define (call-with-http-server code thunk)
	101	"Call THUNK with an HTTP server running and returning CODE on HTTP
	102	requests."
	103	(define (server-body)
	104	(define (handle request body)
	105	(values (build-response #:code code
	106	#:reason-phrase "Such is life")
	107	"Hello, world."))
	108
	109	(catch 'quit
	110	(lambda ()
	111	(run-server handle stub-http-server
	112	`(#:socket ,%http-server-socket)))
	113	(const #t)))
	114
4655005e LC	115	(with-mutex %http-server-lock
	116	(let ((server (make-thread server-body)))
	117	(wait-condition-variable %http-server-ready %http-server-lock)
	118	;; Normally SERVER exits automatically once it has received a request.
	119	(thunk))))
907c98ac LC	120
	121	(define-syntax-rule (with-http-server code body ...)
	122	(call-with-http-server code (lambda () body ...)))
	123
b4f5e0e8 CR	124	\f
	125	(test-begin "lint")
	126
b4f5e0e8	127	(define (call-with-warnings thunk)
b002e9d0 LC	128	(let ((port (open-output-string)))
	129	(parameterize ((guix-warning-port port))
	130	(thunk))
	131	(get-output-string port)))
b4f5e0e8	132
4fbf4ca5 LC	133	(define-syntax-rule (with-warnings body ...)
	134	(call-with-warnings (lambda () body ...)))
	135
334c43e3 EB	136	(test-assert "description: not empty"
334c43e3 EB	137	(->bool
4fbf4ca5 LC	138	(string-contains (with-warnings
	139	(let ((pkg (dummy-package "x"
	140	(description ""))))
	141	(check-description-style pkg)))
334c43e3 EB	142	"description should not be empty")))
334c43e3 EB	143
8202a513 CR	144	(test-assert "description: does not start with an upper-case letter"
8202a513 CR	145	(->bool
4fbf4ca5 LC	146	(string-contains (with-warnings
	147	(let ((pkg (dummy-package "x"
	148	(description "bad description."))))
	149	(check-description-style pkg)))
8202a513 CR	150	"description should start with an upper-case letter")))
8202a513 CR	151
903581f9	152	(test-assert "description: may start with a digit"
b1e66683	153	(string-null?
4fbf4ca5 LC	154	(with-warnings
	155	(let ((pkg (dummy-package "x"
	156	(description "2-component library."))))
	157	(check-description-style pkg)))))
903581f9	158
3c42965b	159	(test-assert "description: may start with lower-case package name"
b1e66683	160	(string-null?
4fbf4ca5 LC	161	(with-warnings
	162	(let ((pkg (dummy-package "x"
	163	(description "x is a dummy package."))))
	164	(check-description-style pkg)))))
3c42965b	165
574e847b EB	166	(test-assert "description: two spaces after end of sentence"
574e847b EB	167	(->bool
4fbf4ca5 LC	168	(string-contains (with-warnings
	169	(let ((pkg (dummy-package "x"
	170	(description "Bad. Quite bad."))))
	171	(check-description-style pkg)))
574e847b EB	172	"sentences in description should be followed by two spaces")))
	173
	174	(test-assert "description: end-of-sentence detection with abbreviations"
b1e66683	175	(string-null?
4fbf4ca5 LC	176	(with-warnings
	177	(let ((pkg (dummy-package "x"
	178	(description
	179	"E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD)."))))
	180	(check-description-style pkg)))))
574e847b EB	181
	182	(test-assert "synopsis: not empty"
	183	(->bool
4fbf4ca5 LC	184	(string-contains (with-warnings
	185	(let ((pkg (dummy-package "x"
	186	(synopsis ""))))
	187	(check-synopsis-style pkg)))
574e847b EB	188	"synopsis should not be empty")))
574e847b EB	189
8202a513 CR	190	(test-assert "synopsis: does not start with an upper-case letter"
8202a513 CR	191	(->bool
4fbf4ca5 LC	192	(string-contains (with-warnings
	193	(let ((pkg (dummy-package "x"
	194	(synopsis "bad synopsis."))))
	195	(check-synopsis-style pkg)))
8202a513 CR	196	"synopsis should start with an upper-case letter")))
8202a513 CR	197
903581f9	198	(test-assert "synopsis: may start with a digit"
b1e66683	199	(string-null?
4fbf4ca5 LC	200	(with-warnings
	201	(let ((pkg (dummy-package "x"
	202	(synopsis "5-dimensional frobnicator"))))
	203	(check-synopsis-style pkg)))))
903581f9	204
b4f5e0e8 CR	205	(test-assert "synopsis: ends with a period"
b4f5e0e8 CR	206	(->bool
4fbf4ca5 LC	207	(string-contains (with-warnings
	208	(let ((pkg (dummy-package "x"
	209	(synopsis "Bad synopsis."))))
	210	(check-synopsis-style pkg)))
b4f5e0e8 CR	211	"no period allowed at the end of the synopsis")))
	212
	213	(test-assert "synopsis: ends with 'etc.'"
4fbf4ca5 LC	214	(string-null? (with-warnings
	215	(let ((pkg (dummy-package "x"
	216	(synopsis "Foo, bar, etc."))))
	217	(check-synopsis-style pkg)))))
b4f5e0e8 CR	218
	219	(test-assert "synopsis: starts with 'A'"
	220	(->bool
4fbf4ca5 LC	221	(string-contains (with-warnings
	222	(let ((pkg (dummy-package "x"
	223	(synopsis "A bad synopŝis"))))
	224	(check-synopsis-style pkg)))
b4f5e0e8 CR	225	"no article allowed at the beginning of the synopsis")))
	226
	227	(test-assert "synopsis: starts with 'An'"
	228	(->bool
4fbf4ca5 LC	229	(string-contains (with-warnings
	230	(let ((pkg (dummy-package "x"
	231	(synopsis "An awful synopsis"))))
	232	(check-synopsis-style pkg)))
b4f5e0e8 CR	233	"no article allowed at the beginning of the synopsis")))
b4f5e0e8 CR	234
a00ffdaa CR	235	(test-assert "synopsis: starts with 'a'"
a00ffdaa CR	236	(->bool
4fbf4ca5 LC	237	(string-contains (with-warnings
	238	(let ((pkg (dummy-package "x"
	239	(synopsis "a bad synopsis"))))
	240	(check-synopsis-style pkg)))
a00ffdaa CR	241	"no article allowed at the beginning of the synopsis")))
	242
	243	(test-assert "synopsis: starts with 'an'"
	244	(->bool
4fbf4ca5 LC	245	(string-contains (with-warnings
	246	(let ((pkg (dummy-package "x"
	247	(synopsis "an awful synopsis"))))
	248	(check-synopsis-style pkg)))
a00ffdaa CR	249	"no article allowed at the beginning of the synopsis")))
a00ffdaa CR	250
5622953d CR	251	(test-assert "synopsis: too long"
5622953d CR	252	(->bool
4fbf4ca5 LC	253	(string-contains (with-warnings
	254	(let ((pkg (dummy-package "x"
	255	(synopsis (make-string 80 #\x)))))
	256	(check-synopsis-style pkg)))
5622953d CR	257	"synopsis should be less than 80 characters long")))
5622953d CR	258
3c762a13 CR	259	(test-assert "synopsis: start with package name"
3c762a13 CR	260	(->bool
4fbf4ca5 LC	261	(string-contains (with-warnings
	262	(let ((pkg (dummy-package "x"
	263	(name "foo")
	264	(synopsis "foo, a nice package"))))
	265	(check-synopsis-style pkg)))
3c762a13 CR	266	"synopsis should not start with the package name")))
3c762a13 CR	267
17854ef9 LC	268	(test-assert "synopsis: start with package name prefix"
17854ef9 LC	269	(string-null?
4fbf4ca5 LC	270	(with-warnings
	271	(let ((pkg (dummy-package "arb"
	272	(synopsis "Arbitrary precision"))))
	273	(check-synopsis-style pkg)))))
17854ef9	274
15a6d433 LC	275	(test-assert "synopsis: start with abbreviation"
15a6d433 LC	276	(string-null?
4fbf4ca5 LC	277	(with-warnings
	278	(let ((pkg (dummy-package "uucp"
	279	;; Same problem with "APL interpreter", etc.
	280	(synopsis "UUCP implementation")
	281	(description "Imagine this is Taylor UUCP."))))
	282	(check-synopsis-style pkg)))))
15a6d433	283
b4f5e0e8 CR	284	(test-assert "inputs: pkg-config is probably a native input"
	285	(->bool
	286	(string-contains
4fbf4ca5 LC	287	(with-warnings
	288	(let ((pkg (dummy-package "x"
	289	(inputs `(("pkg-config" ,pkg-config))))))
	290	(check-inputs-should-be-native pkg)))
b4f5e0e8 CR	291	"pkg-config should probably be a native input")))
	292
	293	(test-assert "patches: file names"
	294	(->bool
	295	(string-contains
4fbf4ca5 LC	296	(with-warnings
	297	(let ((pkg (dummy-package "x"
	298	(source
	299	(origin
	300	(method url-fetch)
	301	(uri "someurl")
	302	(sha256 "somesha")
	303	(patches (list "/path/to/y.patch")))))))
56b1b74c	304	(check-patch-file-names pkg)))
907c98ac LC	305	"file names of patches should start with the package name")))
907c98ac LC	306
b210b35d LC	307	(test-assert "patches: not found"
	308	(->bool
	309	(string-contains
	310	(with-warnings
	311	(let ((pkg (dummy-package "x"
	312	(source
	313	(origin
	314	(method url-fetch)
	315	(uri "someurl")
	316	(sha256 "somesha")
	317	(patches
	318	(list (search-patch "this-patch-does-not-exist!"))))))))
	319	(check-patch-file-names pkg)))
	320	"patch not found")))
	321
002c57c6 LC	322	(test-assert "derivation: invalid arguments"
	323	(->bool
	324	(string-contains
	325	(with-warnings
	326	(let ((pkg (dummy-package "x"
	327	(arguments
	328	'(#:imported-modules (invalid-module))))))
	329	(check-derivation pkg)))
	330	"failed to create derivation")))
	331
52b9efe3 LC	332	(test-assert "license: invalid license"
	333	(string-contains
	334	(with-warnings
	335	(check-license (dummy-package "x" (license #f))))
	336	"invalid license"))
	337
907c98ac LC	338	(test-assert "home-page: wrong home-page"
	339	(->bool
	340	(string-contains
4fbf4ca5 LC	341	(with-warnings
	342	(let ((pkg (package
	343	(inherit (dummy-package "x"))
	344	(home-page #f))))
	345	(check-home-page pkg)))
907c98ac LC	346	"invalid")))
	347
	348	(test-assert "home-page: invalid URI"
	349	(->bool
	350	(string-contains
4fbf4ca5 LC	351	(with-warnings
	352	(let ((pkg (package
	353	(inherit (dummy-package "x"))
	354	(home-page "foobar"))))
	355	(check-home-page pkg)))
907c98ac LC	356	"invalid home page URL")))
	357
	358	(test-assert "home-page: host not found"
	359	(->bool
	360	(string-contains
4fbf4ca5 LC	361	(with-warnings
	362	(let ((pkg (package
	363	(inherit (dummy-package "x"))
	364	(home-page "http://does-not-exist"))))
	365	(check-home-page pkg)))
907c98ac LC	366	"domain not found")))
	367
	368	(test-skip (if %http-server-socket 0 1))
	369	(test-assert "home-page: Connection refused"
	370	(->bool
	371	(string-contains
4fbf4ca5 LC	372	(with-warnings
	373	(let ((pkg (package
	374	(inherit (dummy-package "x"))
	375	(home-page %local-url))))
	376	(check-home-page pkg)))
907c98ac LC	377	"Connection refused")))
	378
	379	(test-skip (if %http-server-socket 0 1))
	380	(test-equal "home-page: 200"
	381	""
4fbf4ca5 LC	382	(with-warnings
	383	(with-http-server 200
	384	(let ((pkg (package
	385	(inherit (dummy-package "x"))
	386	(home-page %local-url))))
	387	(check-home-page pkg)))))
907c98ac LC	388
	389	(test-skip (if %http-server-socket 0 1))
	390	(test-assert "home-page: 404"
	391	(->bool
	392	(string-contains
4fbf4ca5 LC	393	(with-warnings
	394	(with-http-server 404
	395	(let ((pkg (package
	396	(inherit (dummy-package "x"))
	397	(home-page %local-url))))
	398	(check-home-page pkg))))
907c98ac	399	"not reachable: 404")))
b4f5e0e8	400
950d2ea4 LC	401	(test-skip (if %http-server-socket 0 1))
	402	(test-equal "source: 200"
	403	""
	404	(with-warnings
	405	(with-http-server 200
	406	(let ((pkg (package
	407	(inherit (dummy-package "x"))
	408	(source (origin
	409	(method url-fetch)
	410	(uri %local-url)
	411	(sha256 %null-sha256))))))
	412	(check-source pkg)))))
	413
	414	(test-skip (if %http-server-socket 0 1))
	415	(test-assert "source: 404"
	416	(->bool
	417	(string-contains
	418	(with-warnings
	419	(with-http-server 404
	420	(let ((pkg (package
	421	(inherit (dummy-package "x"))
	422	(source (origin
	423	(method url-fetch)
	424	(uri %local-url)
	425	(sha256 %null-sha256))))))
	426	(check-source pkg))))
	427	"not reachable: 404")))
	428
40a7d4e5 LC	429	(test-assert "formatting: tabulation"
	430	(string-contains
	431	(with-warnings
	432	(check-formatting (dummy-package "leave the tab here: ")))
	433	"tabulation"))
	434
	435	(test-assert "formatting: trailing white space"
	436	(string-contains
	437	(with-warnings
	438	;; Leave the trailing white space on the next line!
	439	(check-formatting (dummy-package "x")))
	440	"trailing white space"))
	441
	442	(test-assert "formatting: long line"
	443	(string-contains
	444	(with-warnings
	445	(check-formatting
	446	(dummy-package "x" ;here is a stupid comment just to make a long line
	447	)))
	448	"too long"))
	449
	450	(test-assert "formatting: alright"
	451	(string-null?
	452	(with-warnings
	453	(check-formatting (dummy-package "x")))))
	454
b4f5e0e8 CR	455	(test-end "lint")
	456
	457	\f
	458	(exit (= (test-runner-fail-count (test-runner-current)) 0))
907c98ac LC	459
	460	;; Local Variables:
	461	;; eval: (put 'with-http-server 'scheme-indent-function 1)
4fbf4ca5	462	;; eval: (put 'with-warnings 'scheme-indent-function 0)
907c98ac	463	;; End: