code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014, 2015, 2016 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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/>.

;; Avoid interference.
(unsetenv "http_proxy")

(define-module (test-lint)
  #:use-module (guix tests)
  #:use-module (guix tests http)
  #:use-module (guix download)
  #:use-module (guix git-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 glib)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages python)
  #:use-module (web uri)
  #:use-module (web server)
  #:use-module (web server http)
  #:use-module (web response)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-64))

;; Test the linter.

;; Avoid collisions with other tests.
(%http-server-port 9999)

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

(define %long-string
  (make-string 2000 #\a))

(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 a string"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (description 'foobar))))
                        (check-description-style pkg)))
                    "invalid description")))

(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: valid Texinfo markup"
  (->bool
   (string-contains
    (with-warnings
      (check-description-style (dummy-package "x" (description "f{oo}b@r"))))
    "Texinfo markup in description is invalid")))

(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 "description: may not contain trademark signs"
  (and (->bool
        (string-contains (with-warnings
                           (let ((pkg (dummy-package "x"
                                        (description "Does The Right Thing™"))))
                             (check-description-style pkg)))
                         "should not contain trademark sign"))
       (->bool
        (string-contains (with-warnings
                           (let ((pkg (dummy-package "x"
                                        (description "Works with Format®"))))
                             (check-description-style pkg)))
                         "should not contain trademark sign"))))

(test-assert "description: suggest ornament instead of quotes"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (description "This is a 'quoted' thing."))))
                        (check-description-style pkg)))
                    "use @code")))

(test-assert "synopsis: not a string"
  (->bool
   (string-contains (with-warnings
                      (let ((pkg (dummy-package "x"
                                   (synopsis #f))))
                        (check-synopsis-style pkg)))
                    "invalid synopsis")))

(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: valid Texinfo markup"
  (->bool
   (string-contains
    (with-warnings
      (check-synopsis-style (dummy-package "x" (synopsis "Bad $@ texinfo"))))
    "Texinfo markup in synopsis is invalid")))

(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 "inputs: glib:bin is probably a native input"
  (->bool
    (string-contains
      (with-warnings
        (let ((pkg (dummy-package "x"
                     (inputs `(("glib" ,glib "bin"))))))
          (check-inputs-should-be-native pkg)))
          "'glib:bin' should probably be a native input")))

(test-assert
    "inputs: python-setuptools should not be an input at all (input)"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (inputs `(("python-setuptools" ,python-setuptools))))))
         (check-inputs-should-not-be-an-input-at-all pkg)))
         "'python-setuptools' should probably not be an input at all")))

(test-assert
    "inputs: python-setuptools should not be an input at all (native-input)"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (native-inputs
                     `(("python-setuptools" ,python-setuptools))))))
         (check-inputs-should-not-be-an-input-at-all pkg)))
         "'python-setuptools' should probably not be an input at all")))

(test-assert
    "inputs: python-setuptools should not be an input at all (propagated-input)"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (propagated-inputs
                     `(("python-setuptools" ,python-setuptools))))))
         (check-inputs-should-not-be-an-input-at-all pkg)))
         "'python-setuptools' should probably not be an input at all")))

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

(test-assert "patches: file name too long"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (source
                     (dummy-origin
                      (patches (list (string-append "x-"
                                                    (make-string 100 #\a)
                                                    ".patch"))))))))
         (check-patch-file-names pkg)))
     "file name is too long")))

(test-assert "patches: not found"
  (->bool
   (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (source
                     (dummy-origin
                       (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-can-listen?) 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-can-listen?) 0 1))
(test-equal "home-page: 200"
  ""
  (with-warnings
   (with-http-server 200 %long-string
     (let ((pkg (package
                  (inherit (dummy-package "x"))
                  (home-page (%local-url)))))
       (check-home-page pkg)))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "home-page: 200 but short length"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 200 "This is too small."
        (let ((pkg (package
                     (inherit (dummy-package "x"))
                     (home-page (%local-url)))))
          (check-home-page pkg))))
    "suspiciously small")))

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

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "home-page: 301, invalid"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 301 %long-string
        (let ((pkg (package
                     (inherit (dummy-package "x"))
                     (home-page (%local-url)))))
          (check-home-page pkg))))
    "invalid permanent redirect")))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "home-page: 301 -> 200"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 200 %long-string
        (let ((initial-url (%local-url)))
          (parameterize ((%http-server-port (+ 1 (%http-server-port))))
            (with-http-server (301 `((location
                                      . ,(string->uri initial-url))))
                ""
              (let ((pkg (package
                           (inherit (dummy-package "x"))
                           (home-page (%local-url)))))
                (check-home-page pkg)))))))
    "permanent redirect")))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "home-page: 301 -> 404"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 404 "booh!"
        (let ((initial-url (%local-url)))
          (parameterize ((%http-server-port (+ 1 (%http-server-port))))
            (with-http-server (301 `((location
                                      . ,(string->uri initial-url))))
                ""
              (let ((pkg (package
                           (inherit (dummy-package "x"))
                           (home-page (%local-url)))))
                (check-home-page pkg)))))))
    "not reachable: 404")))

(test-assert "source-file-name"
  (->bool
   (string-contains
    (with-warnings
      (let ((pkg (dummy-package "x"
                   (version "3.2.1")
                   (source
                    (origin
                      (method url-fetch)
                      (uri "http://www.example.com/3.2.1.tar.gz")
                      (sha256 %null-sha256))))))
        (check-source-file-name pkg)))
    "file name should contain the package name")))

(test-assert "source-file-name: v prefix"
  (->bool
   (string-contains
    (with-warnings
      (let ((pkg (dummy-package "x"
                   (version "3.2.1")
                   (source
                    (origin
                      (method url-fetch)
                      (uri "http://www.example.com/v3.2.1.tar.gz")
                      (sha256 %null-sha256))))))
        (check-source-file-name pkg)))
    "file name should contain the package name")))

(test-assert "source-file-name: bad checkout"
  (->bool
   (string-contains
    (with-warnings
      (let ((pkg (dummy-package "x"
                   (version "3.2.1")
                   (source
                    (origin
                      (method git-fetch)
                      (uri (git-reference
                            (url "http://www.example.com/x.git")
                            (commit "0")))
                      (sha256 %null-sha256))))))
        (check-source-file-name pkg)))
    "file name should contain the package name")))

(test-assert "source-file-name: good checkout"
  (not
   (->bool
    (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (version "3.2.1")
                    (source
                     (origin
                       (method git-fetch)
                       (uri (git-reference
                             (url "http://git.example.com/x.git")
                             (commit "0")))
                       (file-name (string-append "x-" version))
                       (sha256 %null-sha256))))))
         (check-source-file-name pkg)))
     "file name should contain the package name"))))

(test-assert "source-file-name: valid"
  (not
   (->bool
    (string-contains
     (with-warnings
       (let ((pkg (dummy-package "x"
                    (version "3.2.1")
                    (source
                     (origin
                       (method url-fetch)
                       (uri "http://www.example.com/x-3.2.1.tar.gz")
                       (sha256 %null-sha256))))))
         (check-source-file-name pkg)))
     "file name should contain the package name"))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 200"
  ""
  (with-warnings
   (with-http-server 200 %long-string
     (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-can-listen?) 0 1))
(test-assert "source: 200 but short length"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 200 "This is too small."
        (let ((pkg (package
                     (inherit (dummy-package "x"))
                     (source (origin
                               (method url-fetch)
                               (uri (%local-url))
                               (sha256 %null-sha256))))))
          (check-source pkg))))
    "suspiciously small")))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "source: 404"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 404 %long-string
        (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-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 301 -> 200"
  ""
  (with-warnings
    (with-http-server 200 %long-string
      (let ((initial-url (%local-url)))
        (parameterize ((%http-server-port (+ 1 (%http-server-port))))
          (with-http-server (301 `((location . ,(string->uri initial-url))))
              ""
            (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-can-listen?) 0 1))
(test-assert "source: 301 -> 404"
  (->bool
   (string-contains
    (with-warnings
      (with-http-server 404 "booh!"
        (let ((initial-url (%local-url)))
          (parameterize ((%http-server-port (+ 1 (%http-server-port))))
            (with-http-server (301 `((location . ,(string->uri initial-url))))
                ""
              (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 "mirror-url"
  (string-null?
   (with-warnings
     (let ((source (origin
                     (method url-fetch)
                     (uri "http://example.org/foo/bar.tar.gz")
                     (sha256 %null-sha256))))
       (check-mirror-url (dummy-package "x" (source source)))))))

(test-assert "mirror-url: one suggestion"
  (string-contains
   (with-warnings
     (let ((source (origin
                     (method url-fetch)
                     (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
                     (sha256 %null-sha256))))
       (check-mirror-url (dummy-package "x" (source source)))))
   "mirror://gnu/foo/foo.tar.gz"))

(test-assert "cve"
  (mock ((guix scripts lint) package-vulnerabilities (const '()))
        (string-null?
         (with-warnings (check-vulnerabilities (dummy-package "x"))))))

(test-assert "cve: one vulnerability"
  (mock ((guix scripts lint) package-vulnerabilities
         (lambda (package)
           (list (make-struct (@@ (guix cve) <vulnerability>) 0
                              "CVE-2015-1234"
                              (list (cons (package-name package)
                                          (package-version package)))))))
        (string-contains
         (with-warnings
           (check-vulnerabilities (dummy-package "pi" (version "3.14"))))
         "vulnerable to CVE-2015-1234")))

(test-assert "cve: one patched vulnerability"
  (mock ((guix scripts lint) package-vulnerabilities
         (lambda (package)
           (list (make-struct (@@ (guix cve) <vulnerability>) 0
                              "CVE-2015-1234"
                              (list (cons (package-name package)
                                          (package-version package)))))))
        (string-null?
         (with-warnings
           (check-vulnerabilities
            (dummy-package "pi"
                           (version "3.14")
                           (source
                            (dummy-origin
                             (patches
                              (list "/a/b/pi-CVE-2015-1234.patch"))))))))))

(test-assert "cve: known safe from vulnerability"
  (mock ((guix scripts lint) package-vulnerabilities
         (lambda (package)
           (list (make-struct (@@ (guix cve) <vulnerability>) 0
                              "CVE-2015-1234"
                              (list (cons (package-name package)
                                          (package-version package)))))))
        (string-null?
         (with-warnings
           (check-vulnerabilities
            (dummy-package "pi"
                           (version "3.14")
                           (properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))))

(test-assert "cve: vulnerability fixed in replacement version"
  (mock ((guix scripts lint) package-vulnerabilities
         (lambda (package)
           (match (package-version package)
             ("0"
              (list (make-struct (@@ (guix cve) <vulnerability>) 0
                                 "CVE-2015-1234"
                                 (list (cons (package-name package)
                                             (package-version package))))))
             ("1"
              '()))))
        (and (not (string-null?
                   (with-warnings
                     (check-vulnerabilities
                      (dummy-package "foo" (version "0"))))))
             (string-null?
              (with-warnings
                (check-vulnerabilities
                 (dummy-package
                  "foo" (version "0")
                  (replacement (dummy-package "foo" (version "1"))))))))))

(test-assert "cve: patched vulnerability in replacement"
  (mock ((guix scripts lint) package-vulnerabilities
         (lambda (package)
           (list (make-struct (@@ (guix cve) <vulnerability>) 0
                              "CVE-2015-1234"
                              (list (cons (package-name package)
                                          (package-version package)))))))
        (string-null?
         (with-warnings
           (check-vulnerabilities
            (dummy-package
             "pi" (version "3.14") (source (dummy-origin))
             (replacement (dummy-package
                           "pi" (version "3.14")
                           (source
                            (dummy-origin
                             (patches
                              (list "/a/b/pi-CVE-2015-1234.patch"))))))))))))

(test-assert "formatting: lonely parentheses"
  (string-contains
   (with-warnings
     (check-formatting
      (
       dummy-package "ugly as hell!"
      )
      ))
   "lonely"))

(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")

;; Local Variables:
;; eval: (put 'with-http-server 'scheme-indent-function 2)
;; eval: (put 'with-warnings 'scheme-indent-function 0)
;; End:


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 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-modules)
  #:use-module (guix modules)
  #:use-module ((guix build-system gnu) #:select (%gnu-build-system-modules))
  #:use-module ((guix utils) #:select (call-with-temporary-directory))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64))

(test-begin "modules")

(test-assert "closure of (guix build gnu-build-system)"
  (lset= equal?
         (live-module-closure '((guix build gnu-build-system)))
         (source-module-closure '((guix build gnu-build-system)))
         %gnu-build-system-modules
         (source-module-closure %gnu-build-system-modules)
         (live-module-closure %gnu-build-system-modules)))

(test-assert "closure of (gnu build install)"
  (lset= equal?
         (live-module-closure '((gnu build install)))
         (source-module-closure '((gnu build install)))))

(test-assert "closure of (gnu build vm)"
  (lset= equal?
         (live-module-closure '((gnu build vm)))
         (source-module-closure '((gnu build vm)))))

(test-equal "&missing-dependency-error"
  '(something that does not exist)
  (call-with-temporary-directory
   (lambda (directory)
     (call-with-output-file (string-append directory "/foobar.scm")
       (lambda (port)
         (write '(define-module (foobar)
                   #:use-module (something that does not exist))
                port)))

     (call-with-output-file (string-append directory "/baz.scm")
       (lambda (port)
         (write '(define-module (baz)
                   #:use-module (foobar))
                port)))

     (guard (c ((missing-dependency-error? c)
                (missing-dependency-module c)))
       (source-module-closure '((baz)) (list directory)
                              #:select? (const #t))))))

(test-end)

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016 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-monads)
  #:use-module (guix tests)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix grafts)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (gnu packages)
  #:use-module (gnu packages bootstrap)
  #:use-module ((gnu packages base) #:select (coreutils))
  #:use-module (ice-9 match)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64))

;; Test the (guix monads) module.

(define %store
  (open-connection-for-tests))

;; Globally disable grafts because they can trigger early builds.
(%graft? #f)

(define %monads
  (list %identity-monad %store-monad %state-monad))

(define %monad-run
  (list identity
        (cut run-with-store %store <>)
        (cut run-with-state <> '())))

(define-syntax-rule (values->list exp)
  (call-with-values (lambda () exp)
    list))

(test-begin "monads")

(test-assert "monad?"
  (and (every monad? %monads)
       (every (compose procedure? monad-bind) %monads)
       (every (compose procedure? monad-return) %monads)))

;; The 3 "monad laws": <http://www.haskell.org/haskellwiki/Monad_laws>.

(test-assert "left identity"
  (every (lambda (monad run)
           (let ((number (random 777)))
             (with-monad monad
               (define (f x)
                 (return (* (1+ number) 2)))

               (= (run (>>= (return number) f))
                  (run (f number))))))
         %monads
         %monad-run))

(test-assert "right identity"
  (every (lambda (monad run)
           (with-monad monad
             (let ((number (return (random 777))))
               (= (run (>>= number return))
                  (run number)))))
         %monads
         %monad-run))

(test-assert "associativity"
  (every (lambda (monad run)
           (with-monad monad
             (define (f x)
               (return (+ 1 x)))
             (define (g x)
               (return (* 2 x)))

             (let ((number (return (random 777))))
               (= (run (>>= (>>= number f) g))
                  (run (>>= number (lambda (x) (>>= (f x) g))))))))
         %monads
         %monad-run))

(test-assert "lift"
  (every (lambda (monad run)
           (let ((f (lift1 1+ monad))
                 (g (apply lift1 1+ (list monad))))
             (with-monad monad
               (let ((number (random 777)))
                 (= (run (>>= (return number) f))
                    (run (>>= (return number) g))
                    (1+ number))))))
         %monads
         %monad-run))

(test-assert ">>= with more than two arguments"
  (every (lambda (monad run)
           (let ((1+ (lift1 1+ monad))
                 (2* (lift1 (cut * 2 <>) monad)))
             (with-monad monad
               (let ((number (random 777)))
                 (= (run (>>= (return number)
                              1+ 1+ 1+
                              2* 2* 2*))
                    (* 8 (+ number 3)))))))
         %monads
         %monad-run))

(test-assert "mbegin"
  (every (lambda (monad run)
           (with-monad monad
             (let* ((been-there? #f)
                    (number (mbegin monad
                              (return 1)
                              (begin
                                (set! been-there? #t)
                                (return 2))
                              (return 3))))
               (and (= (run number) 3)
                    been-there?))))
         %monads
         %monad-run))

(test-assert "mlet* + text-file + package-file"
  (run-with-store %store
    (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile"))
                         (file  (text-file "monadic" guile)))
      (return (equal? (call-with-input-file file get-string-all)
                      guile)))
    #:guile-for-build (package-derivation %store %bootstrap-guile)))

(test-assert "package-file, default system"
  ;; The default system should be the one at '>>=' time, not the one at
  ;; invocation time.  See <http://bugs.gnu.org/18002>.
  (run-with-store %store
    (mlet* %store-monad
        ((system -> (%current-system))
         (file   (parameterize ((%current-system "foobar64-linux"))
                   (package-file coreutils "bin/ls")))
         (cu     (package->derivation coreutils)))
      (return (string=? file
                        (string-append (derivation->output-path cu)
                                       "/bin/ls"))))
    #:guile-for-build (package-derivation %store %bootstrap-guile)))

(test-assert "package-file + package->cross-derivation"
  (run-with-store %store
    (mlet* %store-monad ((target -> "mips64el-linux-gnu")
                         (file (package-file coreutils "bin/ls"
                                             #:target target))
                         (xcu  (package->cross-derivation coreutils target)))
      (let ((output (derivation->output-path xcu)))
        (return (string=? file (string-append output "/bin/ls")))))
    #:guile-for-build (package-derivation %store %bootstrap-guile)))

(test-assert "interned-file"
  (run-with-store %store
    (mlet* %store-monad ((file -> (search-path %load-path "guix.scm"))
                         (a       (interned-file file))
                         (b       (interned-file file "b")))
      (return (equal? (call-with-input-file file get-string-all)
                      (call-with-input-file a get-string-all)
                      (call-with-input-file b get-string-all))))
    #:guile-for-build (package-derivation %store %bootstrap-guile)))

(test-assert "mapm"
  (every (lambda (monad run)
           (with-monad monad
             (equal? (run (mapm monad (lift1 1+ monad) (iota 10)))
                     (map 1+ (iota 10)))))
         %monads
         %monad-run))

(test-assert "sequence"
  (every (lambda (monad run)
           (let* ((input (iota 100))
                  (order '()))
             (define (frob i)
               (mlet monad ((foo (return 'foo)))
                 ;; The side effect here is used to keep track of the order in
                 ;; which monadic values are bound.  Perform the side effect
                 ;; within a '>>=' so that it is performed when the return
                 ;; value is actually bound.
                 (set! order (cons i order))
                 (return i)))

             (and (equal? input
                          (run (sequence monad (map frob input))))

                  ;; Make sure this is from left to right.
                  (equal? order (reverse input)))))
         %monads
         %monad-run))

(test-assert "listm"
  (every (lambda (monad run)
           (run (with-monad monad
                  (let ((lst (listm monad
                                    (return 1) (return 2) (return 3))))
                    (mlet monad ((lst lst))
                      (return (equal? '(1 2 3) lst)))))))
         %monads
         %monad-run))

(test-assert "anym"
  (every (lambda (monad run)
           (eq? (run (with-monad monad
                       (anym monad
                             (lift1 (lambda (x)
                                      (and (odd? x) 'odd!))
                                    monad)
                             (append (make-list 1000 0)
                                     (list 1 2)))))
                'odd!))
         %monads
         %monad-run))

(test-equal "set-current-state"
  (list '(a a d) 'd)
  (values->list
   (run-with-state
       (mlet* %state-monad ((init  (current-state))
                            (init2 (set-current-state 'b)))
         (mbegin %state-monad
           (set-current-state 'c)
           (set-current-state 'd)
           (mlet %state-monad ((last (current-state)))
             (return (list init init2 last)))))
     'a)))

(test-equal "state-push etc."
  (list '((z . 2) (p . (1)) (a . (1))) '(2 1))
  (values->list
   (run-with-state
       (mbegin %state-monad
         (state-push 1)    ;(1)
         (state-push 2)    ;(2 1)
         (mlet* %state-monad ((z (state-pop))        ;(1)
                              (p (current-state))
                              (a (state-push z)))    ;(2 1)
           (return `((z . ,z) (p . ,p) (a . ,a)))))
     '())))

(test-end "monads")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 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-nar)
  #:use-module (guix tests)
  #:use-module (guix nar)
  #:use-module (guix serialization)
  #:use-module (guix store)
  #:use-module ((gcrypt hash)
                #:select (open-sha256-port open-sha256-input-port))
  #:use-module ((guix packages)
                #:select (base32))
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 regex)
  #:use-module ((ice-9 control) #:select (let/ec))
  #:use-module (ice-9 match))

;; Test the (guix nar) module.

;;;
;;; File system testing tools, initially contributed to Guile, then libchop.
;;;

(define (random-file-size)
  (define %average (* 1024 512))                  ; 512 KiB
  (define %stddev  (* 1024 64))                   ; 64 KiB
  (inexact->exact
   (max 0 (round (+ %average (* %stddev (random:normal)))))))

(define (make-file-tree dir tree)
  "Make file system TREE at DIR."
  (let loop ((dir  dir)
             (tree tree))
    (define (scope file)
      (string-append dir "/" file))

    (match tree
      (('directory name (body ...))
       (mkdir (scope name))
       (for-each (cute loop (scope name) <>) body))
      (('directory name (? integer? mode) (body ...))
       (mkdir (scope name))
       (for-each (cute loop (scope name) <>) body)
       (chmod (scope name) mode))
      ((file)
       (populate-file (scope file) (random-file-size)))
      ((file (? integer? mode))
       (populate-file (scope file) (random-file-size))
       (chmod (scope file) mode))
      ((from '-> to)
       (symlink to (scope from))))))

(define (delete-file-tree dir tree)
  "Delete file TREE from DIR."
  (let loop ((dir  dir)
             (tree tree))
    (define (scope file)
      (string-append dir "/" file))

    (match tree
      (('directory name (body ...))
       (for-each (cute loop (scope name) <>) body)
       (rmdir (scope name)))
      (('directory name (? integer? mode) (body ...))
       (chmod (scope name) #o755)          ; make sure it can be entered
       (for-each (cute loop (scope name) <>) body)
       (rmdir (scope name)))
      ((from '-> _)
       (delete-file (scope from)))
      ((file _ ...)
       (delete-file (scope file))))))

(define-syntax-rule (with-file-tree dir tree body ...)
  (dynamic-wind
    (lambda ()
      (make-file-tree dir 'tree))
    (lambda ()
      body ...)
    (lambda ()
      (delete-file-tree dir 'tree))))

(define (file-tree-equal? input output)
  "Return #t if the file trees at INPUT and OUTPUT are equal."
  (define strip
    (cute string-drop <> (string-length input)))
  (define sibling
    (compose (cut string-append output <>) strip))

  (file-system-fold (const #t)
                    (lambda (name stat result)    ; leaf
                      (and result
                           (file=? name (sibling name))))
                    (lambda (name stat result)    ; down
                      result)
                    (lambda (name stat result)    ; up
                      result)
                    (const #f)                    ; skip
                    (lambda (name stat errno result)
                      (pk 'error name stat errno)
                      #f)
                    #t                            ; result
                    input
                    lstat))

(define (populate-file file size)
  (call-with-output-file file
    (lambda (p)
      (put-bytevector p (random-bytevector size)))))

(define (rm-rf dir)
  (file-system-fold (const #t)                    ; enter?
                    (lambda (file stat result)    ; leaf
                      (delete-file file))
                    (const #t)                    ; down
                    (lambda (dir stat result)     ; up
                      (rmdir dir))
                    (const #t)                    ; skip
                    (const #t)                    ; error
                    #t
                    dir
                    lstat))

(define %test-dir
  ;; An output directory under $top_builddir.
  (string-append (dirname (search-path %load-path "pre-inst-env"))
                 "/test-nar-" (number->string (getpid))))

(test-begin "nar")

(test-assert "write-file-tree + restore-file"
  (let* ((file1  (search-path %load-path "guix.scm"))
         (file2  (search-path %load-path "guix/base32.scm"))
         (file3  "#!/bin/something")
         (output (string-append %test-dir "/output")))
    (dynamic-wind
      (lambda () #t)
      (lambda ()
        (define-values (port get-bytevector)
          (open-bytevector-output-port))
        (write-file-tree "root" port
                         #:file-type+size
                         (match-lambda
                           ("root"
                            (values 'directory 0))
                           ("root/foo"
                            (values 'regular (stat:size (stat file1))))
                           ("root/lnk"
                            (values 'symlink 0))
                           ("root/dir"
                            (values 'directory 0))
                           ("root/dir/bar"
                            (values 'regular (stat:size (stat file2))))
                           ("root/dir/exe"
                            (values 'executable (string-length file3))))
                         #:file-port
                         (match-lambda
                           ("root/foo" (open-input-file file1))
                           ("root/dir/bar" (open-input-file file2))
                           ("root/dir/exe" (open-input-string file3)))
                         #:symlink-target
                         (match-lambda
                           ("root/lnk" "foo"))
                         #:directory-entries
                         (match-lambda
                           ("root" '("foo" "dir" "lnk"))
                           ("root/dir" '("bar" "exe"))))
        (close-port port)

        (rm-rf %test-dir)
        (mkdir %test-dir)
        (restore-file (open-bytevector-input-port (get-bytevector))
                      output)
        (and (file=? (string-append output "/foo") file1)
             (string=? (readlink (string-append output "/lnk"))
                       "foo")
             (file=? (string-append output "/dir/bar") file2)
             (string=? (call-with-input-file (string-append output "/dir/exe")
                         get-string-all)
                       file3)
             (> (logand (stat:mode (lstat (string-append output "/dir/exe")))
                        #o100)
                0)
             (equal? '("." ".." "bar" "exe")
                     (scandir (string-append output "/dir")))
             (equal? '("." ".." "dir" "foo" "lnk")
                     (scandir output))))
      (lambda ()
        (false-if-exception (rm-rf %test-dir))))))

(test-assert "write-file supports non-file output ports"
  (let ((input  (string-append (dirname (search-path %load-path "guix.scm"))
                               "/guix"))
        (output (%make-void-port "w")))
    (write-file input output)
    #t))

(test-equal "write-file puts file in C locale collation order"
  (base32 "0sfn5r63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3")
  (let ((input (string-append %test-dir ".input")))
    (dynamic-wind
      (lambda ()
        (define (touch file)
          (call-with-output-file (string-append input "/" file)
            (const #t)))

        (mkdir input)
        (touch "B")
        (touch "Z")
        (touch "a")
        (symlink "B" (string-append input "/z")))
      (lambda ()
        (let-values (((port get-hash) (open-sha256-port)))
          (write-file input port)
          (close-port port)
          (get-hash)))
      (lambda ()
        (rm-rf input)))))

(test-equal "restore-file with incomplete input"
  (string-append %test-dir "/foo")
  (let ((port (open-bytevector-input-port #vu8(1 2 3))))
    (guard (c ((nar-error? c)
               (and (eq? port (nar-error-port c))
                    (nar-error-file c))))
      (restore-file port (string-append %test-dir "/foo"))
      #f)))

(test-assert "write-file + restore-file"
  (let* ((input  (string-append (dirname (search-path %load-path "guix.scm"))
                                "/guix"))
         (output %test-dir)
         (nar    (string-append output ".nar")))
    (dynamic-wind
      (lambda () #t)
      (lambda ()
        (call-with-output-file nar
          (cut write-file input <>))
        (call-with-input-file nar
          (cut restore-file <> output))
        (file-tree-equal? input output))
      (lambda ()
        (false-if-exception (delete-file nar))
        (false-if-exception (rm-rf output))))))

(test-assert "write-file + restore-file with symlinks"
  (let ((input (string-append %test-dir ".input")))
    (mkdir input)
    (dynamic-wind
      (const #t)
      (lambda ()
        (with-file-tree input
            (directory "root"
                       (("reg") ("exe" #o777) ("sym" -> "reg")))
          (let* ((output %test-dir)
                 (nar    (string-append output ".nar")))
            (dynamic-wind
              (lambda () #t)
              (lambda ()
                (call-with-output-file nar
                  (cut write-file input <>))
                (call-with-input-file nar
                  (cut restore-file <> output))
                (file-tree-equal? input output))
              (lambda ()
                (false-if-exception (delete-file nar))
                (false-if-exception (rm-rf output)))))))
      (lambda ()
        (rmdir input)))))

(test-assert "write-file #:select? + restore-file"
  (let ((input (string-append %test-dir ".input")))
    (mkdir input)
    (dynamic-wind
      (const #t)
      (lambda ()
        (with-file-tree input
            (directory "root"
                       ((directory "a" (("x") ("y") ("z")))
                        ("b") ("c") ("d" -> "b")))
          (let* ((output %test-dir)
                 (nar    (string-append output ".nar")))
            (dynamic-wind
              (lambda () #t)
              (lambda ()
                (call-with-output-file nar
                  (lambda (port)
                    (write-file input port
                                #:select?
                                (lambda (file stat)
                                  (and (not (string=? (basename file)
                                                      "a"))
                                       (not (eq? (stat:type stat)
                                                 'symlink)))))))
                (call-with-input-file nar
                  (cut restore-file <> output))

                ;; Make sure "a" and "d" have been filtered out.
                (and (not (file-exists? (string-append output "/root/a")))
                     (file=? (string-append output "/root/b")
                             (string-append input "/root/b"))
                     (file=? (string-append output "/root/c")
                             (string-append input "/root/c"))
                     (not (file-exists? (string-append output "/root/d")))))
              (lambda ()
                (false-if-exception (delete-file nar))
                (false-if-exception (rm-rf output)))))))
      (lambda ()
        (rmdir input)))))

;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn
;; relies on a Guile 2.0.10+ feature.
(test-skip (if (false-if-exception
                (open-sha256-input-port (%make-void-port "r")))
               0
               3))

(test-assert "restore-file-set (signed, valid)"
  (with-store store
    (let* ((texts (unfold (cut >= <> 10)
                          (lambda _ (random-text))
                          1+
                          0))
           (files (map (cut add-text-to-store store "text" <>) texts))
           (dump  (call-with-bytevector-output-port
                   (cut export-paths store files <>))))
      (delete-paths store files)
      (and (every (negate file-exists?) files)
           (let* ((source   (open-bytevector-input-port dump))
                  (imported (restore-file-set source)))
             (and (equal? imported files)
                  (every (lambda (file)
                           (and (file-exists? file)
                                (valid-path? store file)))
                         files)
                  (equal? texts
                          (map (lambda (file)
                                 (call-with-input-file file
                                   get-string-all))
                               files))))))))

(test-assert "restore-file-set (missing signature)"
  (let/ec return
    (with-store store
      (let* ((file  (add-text-to-store store "foo" (random-text)))
             (dump  (call-with-bytevector-output-port
                     (cute export-paths store (list file) <>
                           #:sign? #f))))
        (delete-paths store (list file))
        (and (not (file-exists? file))
             (let ((source (open-bytevector-input-port dump)))
               (guard (c ((nar-signature-error? c)
                          (let ((message (condition-message c))
                                (port    (nar-error-port c)))
                            (return
                             (and (string-match "lacks.*signature" message)
                                  (string=? file (nar-error-file c))
                                  (eq? source port))))))
                 (restore-file-set source))
               #f))))))

(test-assert "restore-file-set (corrupt)"
  (let/ec return
    (with-store store
      (let* ((file  (add-text-to-store store "foo"
                                       (random-text)))
             (dump  (call-with-bytevector-output-port
                     (cute export-paths store (list file) <>))))
        (delete-paths store (list file))

        ;; Flip a byte in the file contents.
        (let* ((index 120)
               (byte  (bytevector-u8-ref dump index)))
          (bytevector-u8-set! dump index (logxor #xff byte)))

        (and (not (file-exists? file))
             (let ((source (open-bytevector-input-port dump)))
               (guard (c ((nar-invalid-hash-error? c)
                          (let ((message (condition-message c))
                                (port    (nar-error-port c)))
                            (return
                             (and (string-contains message "hash")
                                  (string=? file (nar-error-file c))
                                  (eq? source port))))))
                 (restore-file-set source))
               #f))))))

(test-end "nar")

;;; Local Variables:
;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
;;; End:


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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-opam)
  #:use-module (guix import opam)
  #:use-module (guix base32)
  #:use-module (gcrypt hash)
  #:use-module (guix tests)
  #:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which))
  #:use-module (srfi srfi-64)
  #:use-module (web uri)
  #:use-module (ice-9 match))

(define test-url-file
  "http: \"https://example.org/foo-1.0.0.tar.gz\"
checksum: \"ac8920f39a8100b94820659bc2c20817\"")

(define test-source-hash
  "")

(define test-urls
  "repo ac8920f39a8100b94820659bc2c20817 0o644
packages/foo/foo.1.0.0/url ac8920f39a8100b94820659bc2c20817 0o644
packages/foo/foo.1.0.0/opam ac8920f39a8100b94820659bc2c20817 0o644
packages/foo/foo.1.0.0/descr ac8920f39a8100b94820659bc2c20817 0o644")

(define test-opam-file
"opam-version: 1.2
maintainer: \"Alice Doe\"
authors: \"Alice Doe, John Doe\"
homepage: \"https://example.org/\"
bug-reports: \"https://example.org/bugs\"
license: \"MIT\"
dev-repo: \"https://example.org/git\"
build: [
  \"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\"
]
build-test: [
  \"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\" \"--tests\" \"true\"
]
depends: [
  \"alcotest\" {test & >= \"0.7.2\"}
  \"ocamlbuild\" {build & >= \"0.9.2\"}
]")

(test-begin "opam")

(test-assert "opam->guix-package"
  ;; Replace network resources with sample data.
    (mock ((guix import utils) url-fetch
           (lambda (url file-name)
             (match url
               ("https://example.org/foo-1.0.0.tar.gz"
                (begin
                  (mkdir-p "foo-1.0.0")
                  (system* "tar" "czvf" file-name "foo-1.0.0/")
                  (delete-file-recursively "foo-1.0.0")
                  (set! test-source-hash
                    (call-with-input-file file-name port-sha256))))
               (_ (error "Unexpected URL: " url)))))
          (mock ((guix http-client) http-fetch/cached
                 (lambda (url . rest)
                   (match (uri->string url)
                     ("https://opam.ocaml.org/urls.txt"
                      (values (open-input-string test-urls)
                              (string-length test-urls)))
                     (_ (error "Unexpected URL: " url)))))
                (mock ((guix http-client) http-fetch
                       (lambda (url . rest)
                         (match url
                           ("https://opam.ocaml.org/packages/foo/foo.1.0.0/url"
                            (values (open-input-string test-url-file)
                                    (string-length test-url-file)))
                           ("https://opam.ocaml.org/packages/foo/foo.1.0.0/opam"
                            (values (open-input-string test-opam-file)
                                    (string-length test-opam-file)))
                           (_ (error "Unexpected URL: " url)))))
                      (match (opam->guix-package "foo")
                        (('package
                           ('name "ocaml-foo")
                           ('version "1.0.0")
                           ('source ('origin
                                      ('method 'url-fetch)
                                      ('uri "https://example.org/foo-1.0.0.tar.gz")
                                      ('sha256
                                       ('base32
                                        (? string? hash)))))
                           ('build-system 'ocaml-build-system)
                           ('inputs
                            ('quasiquote
                             (("ocamlbuild" ('unquote 'ocamlbuild))
                              ("ocaml-alcotest" ('unquote 'ocaml-alcotest)))))
                           ('home-page "https://example.org/")
                           ('synopsis "")
                           ('description "")
                           ('license 'license:expat))
                         (string=? (bytevector->nix-base32-string
                                    test-source-hash)
                                   hash))
                        (x
                         (pk 'fail x #f)))))))

(test-end "opam")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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-pack)
  #:use-module (guix scripts pack)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix profiles)
  #:use-module (guix monads)
  #:use-module (guix grafts)
  #:use-module (guix tests)
  #:use-module (guix gexp)
  #:use-module (gnu packages bootstrap)
  #:use-module (srfi srfi-64))

(define %store
  (open-connection-for-tests))

;; Globally disable grafts because they can trigger early builds.
(%graft? #f)

(define-syntax-rule (test-assertm name exp)
  (test-assert name
    (run-with-store %store exp
                    #:guile-for-build (%guile-for-build))))

(define %gzip-compressor
  ;; Compressor that uses the bootstrap 'gzip'.
  ((@ (guix scripts pack) compressor) "gzip"
   "gz"
   #~(#+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n")))

(define %tar-bootstrap %bootstrap-coreutils&co)

(test-begin "pack")

;; FIXME: The following test would rebuild the world (and likely fail) as a
;; consequence of commit c45477d2a1a651485feede20fe0f3d15aec48b39 (and related
;; changes) that made guile-sqlite3 a dependency of the derivation.
;; See <https://bugs.gnu.org/32184>.
(test-skip 1)

(test-assertm "self-contained-tarball"
  (mlet* %store-monad
      ((profile (profile-derivation (packages->manifest
                                     (list %bootstrap-guile))
                                    #:hooks '()
                                    #:locales? #f))
       (tarball (self-contained-tarball "pack" profile
                                        #:symlinks '(("/bin/Guile"
                                                      -> "bin/guile"))
                                        #:compressor %gzip-compressor
                                        #:archiver %tar-bootstrap))
       (check   (gexp->derivation
                 "check-tarball"
                 #~(let ((bin (string-append "." #$profile "/bin")))
                     (setenv "PATH"
                             (string-append #$%tar-bootstrap "/bin"))
                     (system* "tar" "xvf" #$tarball)
                     (mkdir #$output)
                     (exit
                      (and (file-exists? (string-append bin "/guile"))
                           (string=? (string-append #$%bootstrap-guile "/bin")
                                     (readlink bin))
                           (string=? (string-append ".." #$profile
                                                    "/bin/guile")
                                     (readlink "bin/Guile"))))))))
    (built-derivations (list check))))

(test-end)