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, 2018, 2019, 2020 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>
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.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/>.

;; 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 lint)
  #:use-module (guix ui)
  #:use-module (guix swh)
  #:use-module (gnu packages)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages python-xyz)
  #:use-module (web uri)
  #:use-module (web server)
  #:use-module (web server http)
  #:use-module (web response)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 pretty-print)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-26)
  #: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))

(define (string-match-or-error pattern str)
  (or (string-match pattern str)
      (error str "did not match" pattern)))

(define single-lint-warning-message
  (match-lambda
    (((and (? lint-warning?) warning))
     (lint-warning-message warning))))

(define (warning-contains? str warnings)
  "Return true if WARNINGS is a singleton with a warning that contains STR."
  (match warnings
    (((? lint-warning? warning))
     (string-contains (lint-warning-message warning) str))))

(test-begin "lint")

(test-equal "description: not a string"
  "invalid description: foobar"
  (single-lint-warning-message
   (check-description-style
    (dummy-package "x" (description 'foobar)))))

(test-equal "description: not empty"
  "description should not be empty"
  (single-lint-warning-message
   (check-description-style
    (dummy-package "x" (description "")))))

(test-equal "description: invalid Texinfo markup"
  "Texinfo markup in description is invalid"
  (single-lint-warning-message
   (check-description-style
    (dummy-package "x" (description "f{oo}b@r")))))

(test-equal "description: does not start with an upper-case letter"
  "description should start with an upper-case letter or digit"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (description "bad description."))))
     (check-description-style pkg))))

(test-equal "description: may start with a digit"
  '()
  (let ((pkg (dummy-package "x"
                            (description "2-component library."))))
    (check-description-style pkg)))

(test-equal "description: may start with lower-case package name"
  '()
  (let ((pkg (dummy-package "x"
                            (description "x is a dummy package."))))
    (check-description-style pkg)))

(test-equal "description: two spaces after end of sentence"
  "sentences in description should be followed by two spaces; possible infraction at 3"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (description "Bad. Quite bad."))))
     (check-description-style pkg))))

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

(test-equal "description: may not contain trademark signs: ™"
  "description should not contain trademark sign '™' at 20"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (description "Does The Right Thing™"))))
     (check-description-style pkg))))

(test-equal "description: may not contain trademark signs: ®"
  "description should not contain trademark sign '®' at 17"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (description "Works with Format®"))))
     (check-description-style pkg))))

(test-equal "description: suggest ornament instead of quotes"
  "use @code or similar ornament instead of quotes"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (description "This is a 'quoted' thing."))))
     (check-description-style pkg))))

(test-equal "synopsis: not a string"
  "invalid synopsis: #f"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (synopsis #f))))
     (check-synopsis-style pkg))))

(test-equal "synopsis: not empty"
  "synopsis should not be empty"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (synopsis ""))))
     (check-synopsis-style pkg))))

(test-equal "synopsis: valid Texinfo markup"
  "Texinfo markup in synopsis is invalid"
  (single-lint-warning-message
   (check-synopsis-style
    (dummy-package "x" (synopsis "Bad $@ texinfo")))))

(test-equal "synopsis: does not start with an upper-case letter"
  "synopsis should start with an upper-case letter or digit"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (synopsis "bad synopsis"))))
     (check-synopsis-style pkg))))

(test-equal "synopsis: may start with a digit"
  '()
  (let ((pkg (dummy-package "x"
                            (synopsis "5-dimensional frobnicator"))))
    (check-synopsis-style pkg)))

(test-equal "synopsis: ends with a period"
  "no period allowed at the end of the synopsis"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (synopsis "Bad synopsis."))))
     (check-synopsis-style pkg))))

(test-equal "synopsis: ends with 'etc.'"
  '()
  (let ((pkg (dummy-package "x"
                            (synopsis "Foo, bar, etc."))))
    (check-synopsis-style pkg)))

(test-equal "synopsis: starts with 'A'"
  "no article allowed at the beginning of the synopsis"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (synopsis "A bad synopŝis"))))
     (check-synopsis-style pkg))))

(test-equal "synopsis: starts with 'An'"
  "no article allowed at the beginning of the synopsis"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (synopsis "An awful synopsis"))))
     (check-synopsis-style pkg))))

(test-equal "synopsis: starts with 'a'"
  '("no article allowed at the beginning of the synopsis"
    "synopsis should start with an upper-case letter or digit")
  (sort
   (map
    lint-warning-message
    (let ((pkg (dummy-package "x"
                              (synopsis "a bad synopsis"))))
      (check-synopsis-style pkg)))
   string<?))

(test-equal "synopsis: starts with 'an'"
  '("no article allowed at the beginning of the synopsis"
    "synopsis should start with an upper-case letter or digit")
  (sort
   (map
    lint-warning-message
    (let ((pkg (dummy-package "x"
                              (synopsis "an awful synopsis"))))
      (check-synopsis-style pkg)))
   string<?))

(test-equal "synopsis: too long"
  "synopsis should be less than 80 characters long"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (synopsis (make-string 80 #\X)))))
     (check-synopsis-style pkg))))

(test-equal "synopsis: start with package name"
  "synopsis should not start with the package name"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (name "Foo")
                             (synopsis "Foo, a nice package"))))
     (check-synopsis-style pkg))))

(test-equal "synopsis: start with package name prefix"
  '()
  (let ((pkg (dummy-package "arb"
                            (synopsis "Arbitrary precision"))))
    (check-synopsis-style pkg)))

(test-equal "synopsis: start with abbreviation"
  '()
  (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-equal "inputs: pkg-config is probably a native input"
  "'pkg-config' should probably be a native input"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (inputs `(("pkg-config" ,pkg-config))))))
     (check-inputs-should-be-native pkg))))

(test-equal "inputs: glib:bin is probably a native input"
  "'glib:bin' should probably be a native input"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (inputs `(("glib" ,glib "bin"))))))
     (check-inputs-should-be-native pkg))))

(test-equal
    "inputs: python-setuptools should not be an input at all (input)"
  "'python-setuptools' should probably not be an input at all"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (inputs `(("python-setuptools"
                                        ,python-setuptools))))))
     (check-inputs-should-not-be-an-input-at-all pkg))))

(test-equal
    "inputs: python-setuptools should not be an input at all (native-input)"
  "'python-setuptools' should probably not be an input at all"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (native-inputs
                              `(("python-setuptools"
                                 ,python-setuptools))))))
     (check-inputs-should-not-be-an-input-at-all pkg))))

(test-equal
    "inputs: python-setuptools should not be an input at all (propagated-input)"
  "'python-setuptools' should probably not be an input at all"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (propagated-inputs
                              `(("python-setuptools" ,python-setuptools))))))
     (check-inputs-should-not-be-an-input-at-all pkg))))

(test-equal "patches: file names"
  "file names of patches should start with the package name"
  (single-lint-warning-message
   (let ((pkg (dummy-package "x"
                             (source
                              (dummy-origin
                               (patches (list "/path/to/y.patch")))))))
     (check-patch-file-names pkg))))

(test-equal "patches: file name too long"
  (string-append "x-"
                 (make-string 100 #\a)
                 ".patch: file name is too long")
  (single-lint-warning-message
   (let ((pkg (dummy-package
               "x"
               (source
                (dummy-origin
                 (patches (list (string-append "x-"
                                               (make-string 100 #\a)
                                               ".patch"))))))))
     (check-patch-file-names pkg))))

(test-equal "patches: not found"
  "this-patch-does-not-exist!: patch not found\n"
  (single-lint-warning-message
   (let ((pkg (dummy-package
               "x"
               (source
                (dummy-origin
                 (patches
                  (list (search-patch "this-patch-does-not-exist!"))))))))
     (check-patch-file-names pkg))))

(test-equal "derivation: invalid arguments"
  "failed to create x86_64-linux derivation: (wrong-type-arg \"map\" \"Wrong type argument: ~S\" (invalid-module) ())"
  (match (let ((pkg (dummy-package "x"
                                   (arguments
                                    '(#:imported-modules (invalid-module))))))
           (check-derivation pkg))
    (((and (? lint-warning?) first-warning) others ...)
     (lint-warning-message first-warning))))

(test-equal "profile-collisions: no warnings"
  '()
  (check-profile-collisions (dummy-package "x")))

(test-equal "profile-collisions: propagated inputs collide"
  "propagated inputs p0@1 and p0@2 collide"
  (let* ((p0  (dummy-package "p0" (version "1")))
         (p0* (dummy-package "p0" (version "2")))
         (p1  (dummy-package "p1" (propagated-inputs `(("p0" ,p0)))))
         (p2  (dummy-package "p2" (propagated-inputs `(("p1" ,p1)))))
         (p3  (dummy-package "p3" (propagated-inputs `(("p0" ,p0*)))))
         (p4  (dummy-package "p4" (propagated-inputs
                                   `(("p2" ,p2) ("p3", p3))))))
    (single-lint-warning-message
     (check-profile-collisions p4))))

(test-assert "profile-collisions: propagated inputs collide, store items"
  (string-match-or-error
   "propagated inputs /[[:graph:]]+-p0-1 and /[[:graph:]]+-p0-1 collide"
   (let* ((p0  (dummy-package "p0" (version "1")))
          (p0* (dummy-package "p0" (version "1")
                              (inputs `(("x" ,(dummy-package "x"))))))
          (p1  (dummy-package "p1" (propagated-inputs `(("p0" ,p0)))))
          (p2  (dummy-package "p2" (propagated-inputs `(("p1" ,p1)))))
          (p3  (dummy-package "p3" (propagated-inputs `(("p0" ,p0*)))))
          (p4  (dummy-package "p4" (propagated-inputs
                                    `(("p2" ,p2) ("p3", p3))))))
     (single-lint-warning-message
      (check-profile-collisions p4)))))

(test-equal "license: invalid license"
  "invalid license field"
  (single-lint-warning-message
   (check-license (dummy-package "x" (license #f)))))

(test-equal "home-page: wrong home-page"
  "invalid value for home page"
  (let ((pkg (package
               (inherit (dummy-package "x"))
               (home-page #f))))
    (single-lint-warning-message
     (check-home-page pkg))))

(test-equal "home-page: invalid URI"
  "invalid home page URL: \"foobar\""
  (let ((pkg (package
               (inherit (dummy-package "x"))
               (home-page "foobar"))))
    (single-lint-warning-message
     (check-home-page pkg))))

(test-assert "home-page: host not found"
  (let ((pkg (package
               (inherit (dummy-package "x"))
               (home-page "http://does-not-exist"))))
    (warning-contains? "domain not found" (check-home-page pkg))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: Connection refused"
  "URI http://localhost:9999/foo/bar unreachable: Connection refused"
  (let ((pkg (package
               (inherit (dummy-package "x"))
               (home-page (%local-url)))))
    (single-lint-warning-message
     (check-home-page pkg))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 200"
  '()
  (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-equal "home-page: 200 but short length"
  "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)"
  (with-http-server `((200 "This is too small."))
    (let ((pkg (package
                 (inherit (dummy-package "x"))
                 (home-page (%local-url)))))

      (single-lint-warning-message
       (check-home-page pkg)))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 404"
  "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")"
  (with-http-server `((404 ,%long-string))
    (let ((pkg (package
                 (inherit (dummy-package "x"))
                 (home-page (%local-url)))))
      (single-lint-warning-message
       (check-home-page pkg)))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 301, invalid"
  "invalid permanent redirect from http://localhost:9999/foo/bar"
  (with-http-server `((301 ,%long-string))
    (let ((pkg (package
                 (inherit (dummy-package "x"))
                 (home-page (%local-url)))))
      (single-lint-warning-message
       (check-home-page pkg)))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 301 -> 200"
  "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
  (with-http-server `((200 ,%long-string))
    (let* ((initial-url (%local-url))
           (redirect    (build-response #:code 301
                                        #:headers
                                        `((location
                                           . ,(string->uri initial-url))))))
      (parameterize ((%http-server-port (+ 1 (%http-server-port))))
        (with-http-server `((,redirect ""))
          (let ((pkg (package
                       (inherit (dummy-package "x"))
                       (home-page (%local-url)))))
            (single-lint-warning-message
             (check-home-page pkg))))))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 301 -> 404"
  "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
  (with-http-server '((404 "booh!"))
    (let* ((initial-url (%local-url))
           (redirect    (build-response #:code 301
                                        #:headers
                                        `((location
                                           . ,(string->uri initial-url))))))
      (parameterize ((%http-server-port (+ 1 (%http-server-port))))
        (with-http-server `((,redirect ""))
          (let ((pkg (package
                       (inherit (dummy-package "x"))
                       (home-page (%local-url)))))
            (single-lint-warning-message
             (check-home-page pkg))))))))

(test-equal "source-file-name"
  "the source file name should contain the package name"
  (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))))))
    (single-lint-warning-message
     (check-source-file-name pkg))))

(test-equal "source-file-name: v prefix"
  "the source file name should contain the package name"
  (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))))))
    (single-lint-warning-message
     (check-source-file-name pkg))))

(test-equal "source-file-name: bad checkout"
  "the source file name should contain the package name"
  (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))))))
    (single-lint-warning-message
     (check-source-file-name pkg))))

(test-equal "source-file-name: good checkout"
  '()
  (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)))

(test-equal "source-file-name: valid"
  '()
  (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)))

(test-equal "source-unstable-tarball"
  "the source URI should not be an autogenerated tarball"
  (let ((pkg (dummy-package "x"
                            (source
                             (origin
                               (method url-fetch)
                               (uri "https://github.com/example/example/archive/v0.0.tar.gz")
                               (sha256 %null-sha256))))))
    (single-lint-warning-message
     (check-source-unstable-tarball pkg))))

(test-equal "source-unstable-tarball: source #f"
  '()
  (let ((pkg (dummy-package "x"
                            (source #f))))
    (check-source-unstable-tarball pkg)))

(test-equal "source-unstable-tarball: valid"
  '()
  (let ((pkg (dummy-package "x"
                            (source
                             (origin
                               (method url-fetch)
                               (uri "https://github.com/example/example/releases/download/x-0.0/x-0.0.tar.gz")
                               (sha256 %null-sha256))))))
    (check-source-unstable-tarball pkg)))

(test-equal "source-unstable-tarball: package named archive"
  '()
  (let ((pkg (dummy-package "x"
                            (source
                             (origin
                               (method url-fetch)
                               (uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz")
                               (sha256 %null-sha256))))))
    (check-source-unstable-tarball pkg)))

(test-equal "source-unstable-tarball: not-github"
  '()
  (let ((pkg (dummy-package "x"
                            (source
                             (origin
                               (method url-fetch)
                               (uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz")
                               (sha256 %null-sha256))))))
    (check-source-unstable-tarball pkg)))

(test-equal "source-unstable-tarball: git-fetch"
  '()
  (let ((pkg (dummy-package "x"
                            (source
                             (origin
                               (method git-fetch)
                               (uri (git-reference
                                     (url "https://github.com/archive/example")
                                     (commit "0")))
                               (sha256 %null-sha256))))))
    (check-source-unstable-tarball pkg)))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 200"
  '()
  (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-equal "source: 200 but short length"
  "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)"
  (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))))))
      (match (check-source pkg)
        ((first-warning ; All source URIs are unreachable
          (and (? lint-warning?) second-warning))
         (lint-warning-message second-warning))))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 404"
  "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")"
  (with-http-server `((404 ,%long-string))
    (let ((pkg (package
                 (inherit (dummy-package "x"))
                 (source (origin
                           (method url-fetch)
                           (uri (%local-url))
                           (sha256 %null-sha256))))))
      (match (check-source pkg)
        ((first-warning ; All source URIs are unreachable
          (and (? lint-warning?) second-warning))
         (lint-warning-message second-warning))))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 404 and 200"
  '()
  (with-http-server `((404 ,%long-string))
    (let ((bad-url (%local-url)))
      (parameterize ((%http-server-port (+ 1 (%http-server-port))))
        (with-http-server `((200 ,%long-string))
          (let ((pkg (package
                       (inherit (dummy-package "x"))
                       (source (origin
                                 (method url-fetch)
                                 (uri (list bad-url (%local-url)))
                                 (sha256 %null-sha256))))))
            ;; Since one of the two URLs is good, this should return the empty
            ;; list.
            (check-source pkg)))))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 301 -> 200"
  "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
  (with-http-server `((200 ,%long-string))
    (let* ((initial-url (%local-url))
           (redirect    (build-response #:code 301
                                        #:headers
                                        `((location
                                           . ,(string->uri initial-url))))))
      (parameterize ((%http-server-port (+ 1 (%http-server-port))))
        (with-http-server `((,redirect ""))
          (let ((pkg (package
                       (inherit (dummy-package "x"))
                       (source (origin
                                 (method url-fetch)
                                 (uri (%local-url))
                                 (sha256 %null-sha256))))))
            (match (check-source pkg)
              ((first-warning ; All source URIs are unreachable
                (and (? lint-warning?) second-warning))
               (lint-warning-message second-warning)))))))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source, git-reference: 301 -> 200"
  "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
  (with-http-server `((200 ,%long-string))
    (let* ((initial-url (%local-url))
           (redirect    (build-response #:code 301
                                        #:headers
                                        `((location
                                           . ,(string->uri initial-url))))))
      (parameterize ((%http-server-port (+ 1 (%http-server-port))))
        (with-http-server `((,redirect ""))
          (let ((pkg (dummy-package
                      "x"
                      (source (origin
                                (method git-fetch)
                                (uri (git-reference (url (%local-url))
                                                    (commit "v1.0.0")))
                                (sha256 %null-sha256))))))
            (single-lint-warning-message (check-source pkg))))))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 301 -> 404"
  "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"
  (with-http-server '((404 "booh!"))
    (let* ((initial-url (%local-url))
           (redirect    (build-response #:code 301
                                        #:headers
                                        `((location
                                           . ,(string->uri initial-url))))))
      (parameterize ((%http-server-port (+ 1 (%http-server-port))))
        (with-http-server `((,redirect ""))
          (let ((pkg (package
                       (inherit (dummy-package "x"))
                       (source (origin
                                 (method url-fetch)
                                 (uri (%local-url))
                                 (sha256 %null-sha256))))))
            (match (check-source pkg)
              ((first-warning ; The first warning says that all URI's are
                              ; unreachable
                (and (? lint-warning?) second-warning))
               (lint-warning-message second-warning)))))))))

(test-equal "mirror-url"
  '()
  (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-equal "mirror-url: one suggestion"
  "URL should be 'mirror://gnu/foo/foo.tar.gz'"
  (let ((source (origin
                  (method url-fetch)
                  (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
                  (sha256 %null-sha256))))
    (single-lint-warning-message
     (check-mirror-url (dummy-package "x" (source source))))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "github-url"
  '()
  (with-http-server `((200 ,%long-string))
    (check-github-url
     (dummy-package "x" (source
                         (origin
                           (method url-fetch)
                           (uri (%local-url))
                           (sha256 %null-sha256)))))))

(let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz"))
  (test-skip (if (http-server-can-listen?) 0 1))
  (test-equal "github-url: one suggestion"
    (string-append
     "URL should be '" github-url "'")
    (let ((redirect (build-response #:code 301
                                    #:headers
                                    `((location
                                       . ,(string->uri github-url))))))
      (with-http-server `((,redirect ""))
        (let* ((initial-url (%local-url))
               (redirect    (build-response #:code 302
                                            #:headers
                                            `((location
                                               . ,(string->uri initial-url))))))
          (parameterize ((%http-server-port (+ 1 (%http-server-port))))
            (with-http-server `((,redirect ""))
              (single-lint-warning-message
               (check-github-url
                (dummy-package "x" (source
                                    (origin
                                      (method url-fetch)
                                      (uri (%local-url))
                                      (sha256 %null-sha256))))))))))))

  (test-skip (if (http-server-can-listen?) 0 1))
  (test-equal "github-url: already the correct github url"
    '()
    (check-github-url
     (dummy-package "x" (source
                         (origin
                           (method url-fetch)
                           (uri github-url)
                           (sha256 %null-sha256)))))))

(test-equal "cve"
  '()
  (mock ((guix lint) package-vulnerabilities (const '()))
        (check-vulnerabilities (dummy-package "x"))))

(test-equal "cve: one vulnerability"
  "probably vulnerable to CVE-2015-1234"
  (let ((dummy-vulnerabilities
         (lambda (package)
           (list (make-struct/no-tail
                  (@@ (guix cve) <vulnerability>)
                  "CVE-2015-1234"
                  (list (cons (package-name package)
                              (package-version package))))))))
    (single-lint-warning-message
     (check-vulnerabilities (dummy-package "pi" (version "3.14"))
                            dummy-vulnerabilities))))

(test-equal "cve: one patched vulnerability"
  '()
  (mock ((guix lint) package-vulnerabilities
         (lambda (package)
           (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
                                      "CVE-2015-1234"
                                      (list (cons (package-name package)
                                                  (package-version package)))))))
        (check-vulnerabilities
         (dummy-package "pi"
                        (version "3.14")
                        (source
                         (dummy-origin
                          (patches
                           (list "/a/b/pi-CVE-2015-1234.patch"))))))))

(test-equal "cve: known safe from vulnerability"
  '()
  (mock ((guix lint) package-vulnerabilities
         (lambda (package)
           (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
                                      "CVE-2015-1234"
                                      (list (cons (package-name package)
                                                  (package-version package)))))))
        (check-vulnerabilities
         (dummy-package "pi"
                        (version "3.14")
                        (properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))

(test-equal "cve: vulnerability fixed in replacement version"
  '()
  (mock ((guix lint) package-vulnerabilities
         (lambda (package)
           (match (package-version package)
             ("0"
              (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
                                         "CVE-2015-1234"
                                         (list (cons (package-name package)
                                                     (package-version package))))))
             ("1"
              '()))))
        (check-vulnerabilities
         (dummy-package
          "foo" (version "0")
          (replacement (dummy-package "foo" (version "1")))))))

(test-equal "cve: patched vulnerability in replacement"
  '()
  (mock ((guix lint) package-vulnerabilities
         (lambda (package)
           (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
                                      "CVE-2015-1234"
                                      (list (cons (package-name package)
                                                  (package-version package)))))))
        (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-equal "formatting: lonely parentheses"
  "parentheses feel lonely, move to the previous or next line"
  (single-lint-warning-message
   (check-formatting
    (dummy-package "ugly as hell!"
                   )
    )))

(test-assert "formatting: tabulation"
  (string-match-or-error
   "tabulation on line [0-9]+, column [0-9]+"
   (single-lint-warning-message
    (check-formatting (dummy-package "leave the tab here:	")))))

(test-assert "formatting: trailing white space"
  (string-match-or-error
   "trailing white space .*"
   ;; Leave the trailing white space on the next line!
   (single-lint-warning-message
    (check-formatting (dummy-package "x")))))

(test-assert "formatting: long line"
  (string-match-or-error
   "line [0-9]+ is way too long \\([0-9]+ characters\\)"
   (single-lint-warning-message (check-formatting
           (dummy-package "x"))                                     ;here is a stupid comment just to make a long line
     )))

(test-equal "formatting: alright"
  '()
  (check-formatting (dummy-package "x")))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "archival: missing content"
  (let* ((origin   (origin
                     (method url-fetch)
                     (uri "http://example.org/foo.tgz")
                     (sha256 (make-bytevector 32))))
         (warnings (with-http-server '((404 "Not archived."))
                     (parameterize ((%swh-base-url (%local-url)))
                       (check-archival (dummy-package "x"
                                                      (source origin)))))))
    (warning-contains? "not archived" warnings)))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "archival: content available"
  '()
  (let* ((origin   (origin
                     (method url-fetch)
                     (uri "http://example.org/foo.tgz")
                     (sha256 (make-bytevector 32))))
         ;; https://archive.softwareheritage.org/api/1/content/
         (content  "{ \"checksums\": {}, \"data_url\": \"xyz\",
                      \"length\": 42 }"))
    (with-http-server `((200 ,content))
      (parameterize ((%swh-base-url (%local-url)))
        (check-archival (dummy-package "x" (source origin)))))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "archival: missing revision"
  (let* ((origin   (origin
                     (method git-fetch)
                     (uri (git-reference
                           (url "http://example.org/foo.git")
                           (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
                     (sha256 (make-bytevector 32))))
         ;; https://archive.softwareheritage.org/api/1/origin/save/
         (save     "{ \"origin_url\": \"http://example.org/foo.git\",
                      \"save_request_date\": \"2014-11-17T22:09:38+01:00\",
                      \"save_request_status\": \"accepted\",
                      \"save_task_status\": \"scheduled\" }")
         (warnings (with-http-server `((404 "No revision.") ;lookup-revision
                                       (404 "No origin.")   ;lookup-origin
                                       (200 ,save))         ;save-origin
                     (parameterize ((%swh-base-url (%local-url)))
                       (check-archival (dummy-package "x" (source origin)))))))
    (warning-contains? "scheduled" warnings)))

(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "archival: revision available"
  '()
  (let* ((origin   (origin
                     (method git-fetch)
                     (uri (git-reference
                           (url "http://example.org/foo.git")
                           (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
                     (sha256 (make-bytevector 32))))
         ;; https://archive.softwareheritage.org/api/1/revision/
         (revision "{ \"author\": {}, \"parents\": [],
                      \"date\": \"2014-11-17T22:09:38+01:00\" }"))
    (with-http-server `((200 ,revision))
      (parameterize ((%swh-base-url (%local-url)))
        (check-archival (dummy-package "x" (source origin)))))))

(test-skip (if (http-server-can-listen?) 0 1))
(test-assert "archival: rate limit reached"
  ;; We should get a single warning stating that the rate limit was reached,
  ;; and nothing more, in particular no other HTTP requests.
  (let* ((origin   (origin
                     (method url-fetch)
                     (uri "http://example.org/foo.tgz")
                     (sha256 (make-bytevector 32))))
         (too-many (build-response
                    #:code 429
                    #:reason-phrase "Too many requests"
                    #:headers '((x-ratelimit-remaining . "0")
                                (x-ratelimit-reset . "3000000000"))))
         (warnings (with-http-server `((,too-many "Rate limit reached."))
                     (parameterize ((%swh-base-url (%local-url)))
                       (append-map (lambda (name)
                                     (check-archival
                                      (dummy-package name (source origin))))
                                   '("x" "y" "z"))))))
    (string-contains (single-lint-warning-message warnings)
                     "rate limit reached")))

(test-end "lint")

;; Local Variables:
;; eval: (put 'with-http-server 'scheme-indent-function 1)
;; 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, 2019 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 ((guix build utils)
                #:select (find-files))
  #: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-equal "write-file-tree + fold-archive"
  '(("R" directory #f)
    ("R/dir" directory #f)
    ("R/dir/exe" executable "1234")
    ("R/foo" regular "abcdefg")
    ("R/lnk" symlink "foo"))

  (let ()
    (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 7))
                       ("root/lnk"
                        (values 'symlink 0))
                       ("root/dir"
                        (values 'directory 0))
                       ("root/dir/exe"
                        (values 'executable 4)))
                     #:file-port
                     (match-lambda
                       ("root/foo" (open-input-string "abcdefg"))
                       ("root/dir/exe" (open-input-string "1234")))
                     #:symlink-target
                     (match-lambda
                       ("root/lnk" "foo"))
                     #:directory-entries
                     (match-lambda
                       ("root" '("foo" "dir" "lnk"))
                       ("root/dir" '("exe"))))
    (close-port port)

    (reverse
     (fold-archive (lambda (file type contents result)
                     (let ((contents (if (memq type '(regular executable))
                                         (utf8->string
                                          (get-bytevector-n (car contents)
                                                            (cdr contents)))
                                         contents)))
                       (cons `(,file ,type ,contents)
                             result)))
                   '()
                   (open-bytevector-input-port (get-bytevector))
                   "R"))))

(test-equal "write-file-tree + fold-archive, flat file"
  '(("R" regular "abcdefg"))

  (let ()
    (define-values (port get-bytevector)
      (open-bytevector-output-port))
    (write-file-tree "root" port
                     #:file-type+size
                     (match-lambda
                       ("root" (values 'regular 7)))
                     #:file-port
                     (match-lambda
                       ("root" (open-input-string "abcdefg"))))
    (close-port port)

    (reverse
     (fold-archive (lambda (file type contents result)
                     (let ((contents (utf8->string
                                      (get-bytevector-n (car contents)
                                                        (cdr contents)))))
                       (cons `(,file ,type ,contents) result)))
                   '()
                   (open-bytevector-input-port (get-bytevector))
                   "R"))))

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

(test-eq "restore-file with non-UTF8 locale"     ;<https://bugs.gnu.org/33603>
  'encoding-error
  (let* ((file   (search-path %load-path "guix.scm"))
         (output (string-append %test-dir "/output"))
         (locale (setlocale LC_ALL "C")))
    (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/λ" (values 'regular 0)))
                         #:file-port (const (%make-void-port "r"))
                         #:symlink-target (const #f)
                         #:directory-entries (const '("λ")))
        (close-port port)

        (mkdir %test-dir)
        (catch 'encoding-error
          (lambda ()
            ;; This show throw to 'encoding-error.
            (restore-file (open-bytevector-input-port (get-bytevector))
                          output)
            (scandir output))
          (lambda args
            'encoding-error)))
      (lambda ()
        (false-if-exception (rm-rf %test-dir))
        (setlocale LC_ALL locale)))))

(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))
                  (every canonical-file? files)))))))

(test-assert "restore-file-set with directories (signed, valid)"
  ;; <https://bugs.gnu.org/33361> describes a bug whereby directories
  ;; containing files subject to deduplication were not canonicalized--i.e.,
  ;; their mtime and permissions were not reset.  Ensure that this bug is
  ;; gone.
  (with-store store
    (let* ((text1 (random-text))
           (text2 (random-text))
           (tree  `("tree" directory
                    ("a" regular (data ,text1))
                    ("b" directory
                     ("c" regular (data ,text2))
                     ("d" regular (data ,text1))))) ;duplicate
           (file  (add-file-tree-to-store store tree))
           (dump  (call-with-bytevector-output-port
                   (cute export-paths store (list file) <>))))
      (delete-paths store (list file))
      (and (not (file-exists? file))
           (let* ((source   (open-bytevector-input-port dump))
                  (imported (restore-file-set source)))
             (and (equal? imported (list file))
                  (file-exists? file)
                  (valid-path? store file)
                  (string=? text1
                            (call-with-input-file (string-append file "/a")
                              get-string-all))
                  (string=? text2
                            (call-with-input-file
                                (string-append file "/b/c")
                              get-string-all))
                  (= (stat:ino (stat (string-append file "/a"))) ;deduplication
                     (stat:ino (stat (string-append file "/b/d"))))
                  (every canonical-file?
                         (find-files file #:directories? #t))))))))

(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 © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; 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 (tests networking)
  #:use-module (ice-9 regex)
  #:use-module (gnu services networking)
  #:use-module (srfi srfi-64))

;;; Tests for the (gnu services networking) module.

(test-begin "networking")

;;;
;;; NTP.
;;;

(define ntp-server->string (@@ (gnu services networking) ntp-server->string))

(define %ntp-server-sample
  (ntp-server
   (type 'server)
   (address "some.ntp.server.org")
   ;; Using either strings or symbols for option names is accepted.
   (options `("iburst" (version 3) (maxpoll 16) prefer))))

(test-equal "ntp-server->string"
  "server some.ntp.server.org iburst version 3 maxpoll 16 prefer"
  (ntp-server->string %ntp-server-sample))

(test-equal "ntp configuration servers deprecated form"
  (ntp-configuration-servers
   (ntp-configuration
    (servers (list "example.pool.ntp.org"))))
  (ntp-configuration-servers
   (ntp-configuration
    (servers (list (ntp-server
                    (type 'server)
                    (address "example.pool.ntp.org")
                    (options '())))))))

;;;
;;; OpenNTPD
;;;

(define openntpd-configuration->string (@@ (gnu services networking)
                                           openntpd-configuration->string))

(define %openntpd-conf-sample
  (openntpd-configuration
   (server '("0.guix.pool.ntp.org" "1.guix.pool.ntp.org"))
   (listen-on '("127.0.0.1" "::1"))
   (sensor '("udcf0 correction 70000"))
   (constraint-from '("www.gnu.org"))
   (constraints-from '("https://www.google.com/"))
   (allow-large-adjustment? #t)))

(test-assert "openntpd configuration generation sanity check"

  (begin
    (define (string-match/newline pattern text)
      (regexp-exec (make-regexp pattern regexp/newline) text))

    (define (match-count pattern text)
      (fold-matches (make-regexp pattern regexp/newline) text 0
                    (lambda (match count)
                      (1+ count))))

    (let ((config (openntpd-configuration->string %openntpd-conf-sample)))
      (if (not
           (and (string-match/newline "^listen on 127.0.0.1$" config)
                (string-match/newline "^listen on ::1$" config)
                (string-match/newline "^sensor udcf0 correction 70000$" config)
                (string-match/newline "^constraint from www.gnu.org$" config)
                (string-match/newline "^server 0.guix.pool.ntp.org$" config)
                (string-match/newline
                 "^constraints from \"https://www.google.com/\"$"
                 config)

                ;; Check for issue #3731 (see:
                ;; http://debbugs.gnu.org/cgi/bugreport.cgi?bug=37318).
                (= (match-count "^listen on " config) 2)
                (= (match-count "^sensor " config) 1)
                (= (match-count "^constraint from " config) 1)
                (= (match-count "^server " config) 2)
                (= (match-count "^constraints from " config) 1)))
          (begin
            (format #t "The configuration below failed \
the sanity check:\n~a~%" config)
            #f)
          #t))))

(test-equal "openntpd generated config string ends with a newline"
  "\n"
  (let ((config (openntpd-configuration->string %openntpd-conf-sample)))
    (string-take-right config 1)))

(test-end "networking")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; 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 (tests offload)
  #:use-module (guix scripts offload)
  #:use-module (srfi srfi-64))

(test-begin "offload")

(define-syntax-rule (expose-internal-definitions s1 s2 ...)
  (begin
    (define s1 (@@ (guix scripts offload) s1))
    (define s2 (@@ (guix scripts offload) s2)) ...))

(expose-internal-definitions machine-matches?
                             build-requirements-system
                             build-requirements-features
                             build-machine-system
                             build-machine-systems
                             %build-machine-system
                             %build-machine-systems
                             build-machine-features)

(define (deprecated-build-machine system)
  (build-machine
   (name "m1")
   (user "dummy")
   (host-key "some-key")
   (system system)))

(define (new-build-machine systems)
  (build-machine
   (name "m1")
   (user "dummy")
   (host-key "some-key")
   (systems systems)))

;;; Test that deprecated build-machine definitions still work.
(test-assert (machine-matches? (deprecated-build-machine "i686-linux")
                               (build-requirements
                                (system "i686-linux"))))

(test-assert (machine-matches? (new-build-machine '("i686-linux"))
                               (build-requirements
                                (system "i686-linux"))))

;;; A build machine can act as more than one system type, thanks to QEMU
;;; emulation.
(test-assert (machine-matches? (new-build-machine '("armhf-linux"
                                                    "aarch64-linux"
                                                    "i686-linux"
                                                    "x86_64-linux"))
                               (build-requirements
                                (system "armhf-linux"))))


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 syscalls) #:select (mkdtemp!))
  #:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which))
  #:use-module ((guix utils) #:select (call-with-temporary-output-file))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (web uri)
  #:use-module (ice-9 match)
  #:use-module (ice-9 peg))

(define test-opam-file
"opam-version: \"2.0\"
  version: \"1.0.0\"
maintainer: \"Alice Doe\"
authors: [
  \"Alice Doe\"
  \"John Doe\"
]
homepage: \"https://example.org/\"
bug-reports: \"https://example.org/bugs\"
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\"}
  \"zarith\" {>= \"0.7\"}
]
synopsis: \"Some example package\"
description: \"\"\"
This package is just an example.\"\"\"
url {
  src: \"https://example.org/foo-1.0.0.tar.gz\"
  checksum: \"md5=74c6e897658e820006106f45f736381f\"
}")

(define test-source-hash
  "")

(define test-repo
  (mkdtemp! "/tmp/opam-repo.XXXXXX"))

(test-begin "opam")

(test-assert "opam->guix-package"
  (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)))))
      (let ((my-package (string-append test-repo "/packages/foo/foo.1.0.0")))
        (mkdir-p my-package)
        (with-output-to-file (string-append my-package "/opam")
          (lambda _
            (format #t "~a" test-opam-file))))
      (match (opam->guix-package "foo" #:repository test-repo)
        (('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)
           ('propagated-inputs
            ('quasiquote
             (("ocaml-zarith" ('unquote 'ocaml-zarith)))))
           ('native-inputs
            ('quasiquote
             (("ocaml-alcotest" ('unquote 'ocaml-alcotest))
              ("ocamlbuild" ('unquote 'ocamlbuild)))))
           ('home-page "https://example.org/")
           ('synopsis "Some example package")
           ('description "This package is just an example.")
           ('license #f))
         (string=? (bytevector->nix-base32-string
                    test-source-hash)
                   hash))
        (x
         (pk 'fail x #f)))))

;; Test the opam file parser
;; We fold over some test cases. Each case is a pair of the string to parse and the
;; expected result.
(test-assert "parse-strings"
  (fold (lambda (test acc)
          (display test) (newline)
          (and acc
               (let ((result (peg:tree (match-pattern string-pat (car test)))))
                 (if (equal? result (cdr test))
                   #t
                   (pk 'fail (list (car test) result (cdr test)) #f)))))
    #t '(("" . #f)
         ("\"hello\"" . (string-pat "hello"))
         ("\"hello world\"" . (string-pat "hello world"))
         ("\"The dreaded \\\"é\\\"\"" . (string-pat "The dreaded \"é\""))
         ("\"Have some \\\\\\\\ :)\"" . (string-pat "Have some \\\\ :)"))
         ("\"今日は\"" . (string-pat "今日は")))))

(test-assert "parse-multiline-strings"
  (fold (lambda (test acc)
          (display test) (newline)
          (and acc
               (let ((result (peg:tree (match-pattern multiline-string (car test)))))
                 (if (equal? result (cdr test))
                   #t
                   (pk 'fail (list (car test) result (cdr test)) #f)))))
    #t '(("" . #f)
         ("\"\"\"hello\"\"\"" . (multiline-string "hello"))
         ("\"\"\"hello \"world\"!\"\"\"" . (multiline-string "hello \"world\"!"))
         ("\"\"\"hello \"\"world\"\"!\"\"\"" . (multiline-string "hello \"\"world\"\"!")))))

(test-assert "parse-lists"
  (fold (lambda (test acc)
          (and acc
               (let ((result (peg:tree (match-pattern list-pat (car test)))))
                 (if (equal? result (cdr test))
                   #t
                   (pk 'fail (list (car test) result (cdr test)) #f)))))
    #t '(("" . #f)
         ("[]" . list-pat)
         ("[make]" . (list-pat (var "make")))
         ("[\"make\"]" . (list-pat (string-pat "make")))
         ("[\n  a\n  b\n  c]" . (list-pat (var "a") (var "b") (var "c")))
         ("[a   b     \"c\"]" . (list-pat (var "a") (var "b") (string-pat "c"))))))

(test-assert "parse-dicts"
  (fold (lambda (test acc)
          (and acc
               (let ((result (peg:tree (match-pattern dict (car test)))))
                 (if (equal? result (cdr test))
                   #t
                   (pk 'fail (list (car test) result (cdr test)) #f)))))
    #t '(("" . #f)
         ("{}" . dict)
         ("{a: \"b\"}" . (dict (record "a" (string-pat "b"))))
         ("{a: \"b\"\nc: \"d\"}" . (dict (record "a" (string-pat "b")) (record "c" (string-pat "d")))))))

(test-assert "parse-conditions"
  (fold (lambda (test acc)
          (and acc
               (let ((result (peg:tree (match-pattern condition (car test)))))
                 (if (equal? result (cdr test))
                   #t
                   (pk 'fail (list (car test) result (cdr test)) #f)))))
    #t '(("" . #f)
         ("{}" . #f)
         ("{build}" . (condition-var "build"))
         ("{>= \"0.2.0\"}" . (condition-greater-or-equal
                               (condition-string "0.2.0")))
         ("{>= \"0.2.0\" & test}" . (condition-and
                                      (condition-greater-or-equal
                                        (condition-string "0.2.0"))
                                      (condition-var "test")))
         ("{>= \"0.2.0\" | build}" . (condition-or
                                      (condition-greater-or-equal
                                        (condition-string "0.2.0"))
                                      (condition-var "build")))
         ("{ = \"1.0+beta19\" }" . (condition-eq
                                     (condition-string "1.0+beta19"))))))

(test-end "opam")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 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 (tests-openpgp)
  #:use-module (guix openpgp)
  #:use-module (gcrypt base16)
  #:use-module (gcrypt hash)
  #:use-module (gcrypt pk-crypto)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-64)
  #:use-module (srfi srfi-71))

(define %radix-64-sample
  ;; Example of Radix-64 encoding from Section 6.6 of RFC4880.
  "\
-----BEGIN PGP MESSAGE-----
Version: OpenPrivacy 0.99

yDgBO22WxBHv7O8X7O/jygAEzol56iUKiXmV+XmpCtmpqQUKiQrFqclFqUDBovzS
vBSFjNSiVHsuAA==
=njUN
-----END PGP MESSAGE-----\n")

(define %radix-64-sample/crc-mismatch
  ;; This time with a wrong CRC24 value.
  "\
-----BEGIN PGP MESSAGE-----

yDgBO22WxBHv7O8X7O/jygAEzol56iUKiXmV+XmpCtmpqQUKiQrFqclFqUDBovzS
vBSFjNSiVHsuAA==
=AAAA
-----END PGP MESSAGE-----\n")

(define %civodul-fingerprint
  "3CE4 6455 8A84 FDC6 9DB4  0CFB 090B 1199 3D9A EBB5")

(define %civodul-key-id #x090B11993D9AEBB5)       ;civodul.key

;; Test keys.  They were generated in a container along these lines:
;;    guix environment -CP --ad-hoc gnupg pinentry
;; then, within the container:
;;    mkdir ~/.gnupg
;;    echo pinentry-program ~/.guix-profile/bin/pinentry-tty > ~/.gnupg/gpg-agent.conf
;;    gpg --quick-gen-key '<ludo+test-rsa@chbouib.org>' rsa
;; or similar.
(define %rsa-key-id      #xAE25DA2A70DEED59)      ;rsa.key
(define %dsa-key-id      #x587918047BE8BD2C)      ;dsa.key
(define %ed25519-key-id  #x771F49CBFAAE072D)      ;ed25519.key

(define %rsa-key-fingerprint
  (base16-string->bytevector
   (string-downcase "385F86CFC86B665A5C165E6BAE25DA2A70DEED59")))
(define %dsa-key-fingerprint
  (base16-string->bytevector
   (string-downcase "2884A980422330A4F33DD97F587918047BE8BD2C")))
(define %ed25519-key-fingerprint
  (base16-string->bytevector
   (string-downcase "44D31E21AF7138F9B632280A771F49CBFAAE072D")))

;;; The following are detached signatures created commands like:
;;;    echo 'Hello!' | gpg -sba --digest-algo sha512
;;; They are detached (no PACKET-ONE-PASS-SIGNATURE) and uncompressed.

(define %hello-signature/rsa
  ;; Signature of the ASCII string "Hello!\n".
  "\
-----BEGIN PGP SIGNATURE-----

iQEzBAABCAAdFiEEOF+Gz8hrZlpcFl5rriXaKnDe7VkFAl4SRF0ACgkQriXaKnDe
7VlIyQf/TU5rGUK42/C1ULoWvvm25Mjwh6xxoPPkuBxvos8bE6yKr/vJZePU3aSE
mjbVFcO7DioxHMqLd49j803bUtdllJVU18ex9MkKbKjapkgEGkJsuTTzqyONprgk
7xtZGBWuxkP1M6hJICJkA3Ys+sTdKalux/pzr5OWAe+gxytTF/vr/EyJzdmBxbJv
/fhd1SeVIXSw4c5gf2Wcvcgfy4N5CiLaUb7j4646KBTvDvmUMcDZ+vmKqC/XdQeQ
PrjArGKt40ErVd98fwvNHZnw7VQMx0A3nL3joL5g7/RckDOUb4mqKoqLsLd0wPHP
y32DiDUY9s3sy5OMzX4Y49em8vxvlg==
=ASEm
-----END PGP SIGNATURE-----")

(define %hello-signature/dsa
  "\
-----BEGIN PGP SIGNATURE-----

iHUEABEIAB0WIQQohKmAQiMwpPM92X9YeRgEe+i9LAUCXhJFpQAKCRBYeRgEe+i9
LDAaAQC0lXPQepvZBANAUtRLMZuOwL9NQPkfhIwUXtLEBBzyFQD/So8DcybXpRBi
JKOiyAQQjMs/GJ6qMEQpRAhyyJRAock=
=iAEc
-----END PGP SIGNATURE-----")

(define %hello-signature/ed25519/sha256           ;digest-algo: sha256
  "\
-----BEGIN PGP SIGNATURE-----

iHUEABYIAB0WIQRE0x4hr3E4+bYyKAp3H0nL+q4HLQUCXqRADAAKCRB3H0nL+q4H
LUImAP9/foaSjPFC/MSr52LNV5ROSL9haea4jPpUP+N6ViFGowEA+AE/xpXPIqsz
R6CdxMevURuqUpqQ7rHeiMmdUepeewU=
=tLXy
-----END PGP SIGNATURE-----")

(define %hello-signature/ed25519/sha512           ;digest-algo: sha512
  "\
-----BEGIN PGP SIGNATURE-----

iHUEABYKAB0WIQRE0x4hr3E4+bYyKAp3H0nL+q4HLQUCXqRAGgAKCRB3H0nL+q4H
LTeKAP0S8LiiosJXOARlYNdhfGw9j26lHrbwJh5CORGlaqqIJAEAoMYcmtNa2b6O
inlEwB/KQM88O9RwA8xH7X5a0rodOw4=
=68r/
-----END PGP SIGNATURE-----")

(define %hello-signature/ed25519/sha1             ;digest-algo: sha1
  "\
-----BEGIN PGP SIGNATURE-----

iHUEABYCAB0WIQRE0x4hr3E4+bYyKAp3H0nL+q4HLQUCXqRALQAKCRB3H0nL+q4H
LdhEAQCfkdYhIVRa43oTNw9EL/TDFGQjXSHNRFVU0ktjkWbkQwEAjIXhvj2sqy79
Pz7oopeN72xgggYUNT37ezqN3MeCqw0=
=AE4G
-----END PGP SIGNATURE-----")

(test-begin "openpgp")

(test-equal "read-radix-64"
  '(#t "PGP MESSAGE")
  (let-values (((data type)
                (call-with-input-string %radix-64-sample read-radix-64)))
    (list (bytevector? data) type)))

(test-equal "read-radix-64, CRC mismatch"
  '(#f "PGP MESSAGE")
  (call-with-values
      (lambda ()
        (call-with-input-string %radix-64-sample/crc-mismatch
          read-radix-64))
    list))

(test-assert "get-openpgp-keyring"
  (let* ((key (search-path %load-path "tests/civodul.key"))
         (keyring (get-openpgp-keyring
                   (open-bytevector-input-port
                    (call-with-input-file key read-radix-64)))))
    (let-values (((primary packets)
                  (lookup-key-by-id keyring %civodul-key-id)))
      (let ((fingerprint (openpgp-public-key-fingerprint primary)))
        (and (= (openpgp-public-key-id primary) %civodul-key-id)
             (not (openpgp-public-key-subkey? primary))
             (string=? (openpgp-format-fingerprint fingerprint)
                       %civodul-fingerprint)
             (string=? (openpgp-user-id-value (find openpgp-user-id? packets))
                       "Ludovic Courtès <ludo@gnu.org>")
             (eq? (lookup-key-by-fingerprint keyring fingerprint)
                  primary))))))

(test-equal "get-openpgp-detached-signature/ascii"
  (list `(,%dsa-key-id ,%dsa-key-fingerprint dsa sha256)
        `(,%rsa-key-id ,%rsa-key-fingerprint rsa sha256)
        `(,%ed25519-key-id ,%ed25519-key-fingerprint eddsa sha256)
        `(,%ed25519-key-id ,%ed25519-key-fingerprint eddsa sha512)
        `(,%ed25519-key-id ,%ed25519-key-fingerprint eddsa sha1))
  (map (lambda (str)
         (let ((signature (get-openpgp-detached-signature/ascii
                           (open-input-string str))))
           (list (openpgp-signature-issuer-key-id signature)
                 (openpgp-signature-issuer-fingerprint signature)
                 (openpgp-signature-public-key-algorithm signature)
                 (openpgp-signature-hash-algorithm signature))))
       (list %hello-signature/dsa
             %hello-signature/rsa
             %hello-signature/ed25519/sha256
             %hello-signature/ed25519/sha512
             %hello-signature/ed25519/sha1)))

(test-equal "verify-openpgp-signature, missing key"
  `(missing-key ,%rsa-key-fingerprint)
  (let* ((keyring   (get-openpgp-keyring (%make-void-port "r")))
         (signature (string->openpgp-packet %hello-signature/rsa)))
    (let-values (((status key)
                  (verify-openpgp-signature signature keyring
                                            (open-input-string "Hello!\n"))))
      (list status key))))

(test-equal "verify-openpgp-signature, good signatures"
  `((good-signature ,%rsa-key-id)
    (good-signature ,%dsa-key-id)
    (good-signature ,%ed25519-key-id)
    (good-signature ,%ed25519-key-id)
    (good-signature ,%ed25519-key-id))
  (map (lambda (key signature)
         (let* ((key       (search-path %load-path key))
                (keyring   (get-openpgp-keyring
                            (open-bytevector-input-port
                             (call-with-input-file key read-radix-64))))
                (signature (string->openpgp-packet signature)))
           (let-values (((status key)
                         (verify-openpgp-signature signature keyring
                                                   (open-input-string "Hello!\n"))))
             (list status (openpgp-public-key-id key)))))
       (list "tests/rsa.key" "tests/dsa.key"
             "tests/ed25519.key" "tests/ed25519.key" "tests/ed25519.key")
       (list %hello-signature/rsa %hello-signature/dsa
             %hello-signature/ed25519/sha256
             %hello-signature/ed25519/sha512
             %hello-signature/ed25519/sha1)))

(test-equal "verify-openpgp-signature, bad signature"
  `((bad-signature ,%rsa-key-id)
    (bad-signature ,%dsa-key-id)
    (bad-signature ,%ed25519-key-id)
    (bad-signature ,%ed25519-key-id)
    (bad-signature ,%ed25519-key-id))
  (let ((keyring (fold (lambda (key keyring)
                         (let ((key (search-path %load-path key)))
                           (get-openpgp-keyring
                            (open-bytevector-input-port
                             (call-with-input-file key read-radix-64))
                            keyring)))
                       %empty-keyring
                       '("tests/rsa.key" "tests/dsa.key"
                         "tests/ed25519.key" "tests/ed25519.key"
                         "tests/ed25519.key"))))
    (map (lambda (signature)
           (let ((signature (string->openpgp-packet signature)))
             (let-values (((status key)
                           (verify-openpgp-signature signature keyring
                                                     (open-input-string "What?!"))))
               (list status (openpgp-public-key-id key)))))
         (list %hello-signature/rsa %hello-signature/dsa
               %hello-signature/ed25519/sha256
               %hello-signature/ed25519/sha512
               %hello-signature/ed25519/sha1))))

(test-end "openpgp")