code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Alex Kost <alezost@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 (test-profiles)
  #:use-module (guix tests)
  #:use-module (guix profiles)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix grafts)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix build-system trivial)
  #:use-module (gnu packages bootstrap)
  #:use-module ((gnu packages base) #:prefix packages:)
  #:use-module ((gnu packages guile) #:prefix packages:)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 popen)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64))

;; Test the (guix profiles) module.

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

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

;; Example manifest entries.

(define guile-1.8.8
  (manifest-entry
    (name "guile")
    (version "1.8.8")
    (item "/gnu/store/...")
    (output "out")))

(define guile-2.0.9
  (manifest-entry
    (name "guile")
    (version "2.0.9")
    (item "/gnu/store/...")
    (output "out")))

(define guile-2.0.9:debug
  (manifest-entry (inherit guile-2.0.9)
    (output "debug")))

(define glibc
  (manifest-entry
    (name "glibc")
    (version "2.19")
    (item "/gnu/store/...")
    (output "out")))

(test-begin "profiles")

(test-assert "manifest-installed?"
  (let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug))))
    (and (manifest-installed? m (manifest-pattern (name "guile")))
         (manifest-installed? m (manifest-pattern
                                  (name "guile") (output "debug")))
         (manifest-installed? m (manifest-pattern
                                  (name "guile") (output "out")
                                  (version "2.0.9")))
         (not (manifest-installed?
               m (manifest-pattern (name "guile") (version "1.8.8"))))
         (not (manifest-installed?
               m (manifest-pattern (name "guile") (output "foobar")))))))

(test-assert "manifest-matching-entries"
  (let* ((e (list guile-2.0.9 guile-2.0.9:debug))
         (m (manifest e)))
    (and (equal? e
                 (manifest-matching-entries m
                                            (list (manifest-pattern
                                                    (name "guile")
                                                    (output #f)))))
         (equal? (list guile-2.0.9)
                 (manifest-matching-entries m
                                            (list (manifest-pattern
                                                    (name "guile")
                                                    (version "2.0.9"))))))))

(test-assert "manifest-matching-entries, no match"
  (let ((m (manifest (list guile-2.0.9)))
        (p (manifest-pattern (name "python"))))
    (guard (c ((unmatched-pattern-error? c)
               (and (eq? p (unmatched-pattern-error-pattern c))
                    (eq? m (unmatched-pattern-error-manifest c)))))
      (manifest-matching-entries m (list p))
      #f)))

(test-equal "concatenate-manifests"
  (manifest (list guile-2.0.9 glibc))
  (concatenate-manifests (list (manifest (list guile-2.0.9))
                               (manifest (list glibc)))))

(test-assert "manifest-remove"
  (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
         (m1 (manifest-remove m0
                              (list (manifest-pattern (name "guile")))))
         (m2 (manifest-remove m1
                              (list (manifest-pattern (name "guile"))))) ; same
         (m3 (manifest-remove m2
                              (list (manifest-pattern
                                      (name "guile") (output "debug")))))
         (m4 (manifest-remove m3
                              (list (manifest-pattern (name "guile"))))))
    (match (manifest-entries m2)
      ((($ <manifest-entry> "guile" "2.0.9" "debug"))
       (and (equal? m1 m2)
            (null? (manifest-entries m3))
            (null? (manifest-entries m4)))))))

(test-assert "manifest-add"
  (let* ((m0 (manifest '()))
         (m1 (manifest-add m0 (list guile-1.8.8)))
         (m2 (manifest-add m1 (list guile-2.0.9)))
         (m3 (manifest-add m2 (list guile-2.0.9:debug)))
         (m4 (manifest-add m3 (list guile-2.0.9:debug))))
    (and (match (manifest-entries m1)
           ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
           (_ #f))
         (match (manifest-entries m2)
           ((($ <manifest-entry> "guile" "2.0.9" "out")) #t)
           (_ #f))
         (equal? m3 m4))))

(test-equal "manifest-add removes duplicates"    ;<https://bugs.gnu.org/30569>
  (list guile-2.0.9)
  (manifest-entries (manifest-add (manifest '())
                                  (list guile-2.0.9 guile-2.0.9))))

(test-equal "manifest->code, simple"
  '(begin
     (specifications->manifest (list "guile" "guile:debug" "glibc")))
  (manifest->code (manifest (list guile-2.0.9 guile-2.0.9:debug glibc))))

(test-equal "manifest->code, simple, versions"
  '(begin
     (specifications->manifest (list "guile@2.0.9" "guile@2.0.9:debug"
                                     "glibc@2.19")))
  (manifest->code (manifest (list guile-2.0.9 guile-2.0.9:debug glibc))
                  #:entry-package-version manifest-entry-version))

(test-equal "manifest->code, transformations"
  '(begin
     (use-modules (guix transformations))

     (define transform1
       (options->transformation '((foo . "bar"))))

     (packages->manifest
      (list (transform1 (specification->package "guile"))
            (specification->package "glibc"))))
  (manifest->code (manifest (list (manifest-entry
                                    (inherit guile-2.0.9)
                                    (properties `((transformations
                                                   . ((foo . "bar"))))))
                                  glibc))))

(test-assert "manifest-perform-transaction"
  (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
         (t1 (manifest-transaction
              (install (list guile-1.8.8))
              (remove (list (manifest-pattern (name "guile")
                                              (output "debug"))))))
         (t2 (manifest-transaction
              (remove (list (manifest-pattern (name "guile")
                                              (version "2.0.9")
                                              (output #f))))))
         (m1 (manifest-perform-transaction m0 t1))
         (m2 (manifest-perform-transaction m1 t2))
         (m3 (manifest-perform-transaction m0 t2)))
    (and (match (manifest-entries m1)
           ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
           (_ #f))
         (equal? m1 m2)
         (null? (manifest-entries m3)))))

(test-assert "manifest-transaction-effects"
  (let* ((m0 (manifest (list guile-1.8.8)))
         (t  (manifest-transaction
              (install (list guile-2.0.9 glibc)))))
    (let-values (((remove install upgrade downgrade)
                  (manifest-transaction-effects m0 t)))
      (and (null? remove) (null? downgrade)
           (equal? (list glibc) install)
           (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))

(test-assert "manifest-transaction-effects no double install or upgrades"
  (let* ((m0 (manifest (list guile-1.8.8)))
         (t  (manifest-transaction
              (install (list guile-2.0.9 glibc glibc)))))
    (let-values (((remove install upgrade downgrade)
                  (manifest-transaction-effects m0 t)))
      (and (null? remove) (null? downgrade)
           (equal? (list glibc) install)
           (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))

(test-assert "manifest-transaction-effects and downgrades"
  (let* ((m0 (manifest (list guile-2.0.9)))
         (t  (manifest-transaction (install (list guile-1.8.8)))))
    (let-values (((remove install upgrade downgrade)
                  (manifest-transaction-effects m0 t)))
      (and (null? remove) (null? install) (null? upgrade)
           (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))

(test-assert "manifest-transaction-effects no double downgrade"
  (let* ((m0 (manifest (list guile-2.0.9)))
         (t  (manifest-transaction (install (list guile-1.8.8 guile-1.8.8)))))
    (let-values (((remove install upgrade downgrade)
                  (manifest-transaction-effects m0 t)))
      (and (null? remove) (null? install) (null? upgrade)
           (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))

(test-assert "manifest-transaction-effects and pseudo-upgrades"
  (let* ((m0 (manifest (list guile-2.0.9)))
         (t  (manifest-transaction (install (list guile-2.0.9)))))
    (let-values (((remove install upgrade downgrade)
                  (manifest-transaction-effects m0 t)))
      (and (null? remove) (null? install) (null? downgrade)
           (equal? (list (cons guile-2.0.9 guile-2.0.9)) upgrade)))))

(test-assert "manifest-transaction-null?"
  (manifest-transaction-null? (manifest-transaction)))

(test-assert "manifest-transaction-removal-candidate?"
  (let ((m (manifest (list guile-2.0.9)))
        (t (manifest-transaction
            (remove (list (manifest-pattern (name "guile")))))))
    (and (manifest-transaction-removal-candidate? guile-2.0.9 t)
         (not (manifest-transaction-removal-candidate? glibc t)))))

(test-assert "manifest-transaction-effects no double removal"
  (let* ((m0 (manifest (list guile-2.0.9)))
         (t  (manifest-transaction
              (remove (list (manifest-pattern (name "guile")))))))
    (let-values (((remove install upgrade downgrade)
                  (manifest-transaction-effects m0 t)))
      (and (= 1 (length remove))
           (manifest-transaction-removal-candidate? guile-2.0.9 t)
           (null? install) (null? downgrade) (null? upgrade)))))

(test-assertm "profile-derivation"
  (mlet* %store-monad
      ((entry ->   (package->manifest-entry %bootstrap-guile))
       (guile      (package->derivation %bootstrap-guile))
       (drv        (profile-derivation (manifest (list entry))
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv))
       (bindir ->  (string-append profile "/bin"))
       (_          (built-derivations (list drv))))
    (return (and (file-exists? (string-append bindir "/guile"))
                 (string=? (dirname (readlink bindir))
                           (derivation->output-path guile))))))

(test-assertm "profile-derivation, ordering & collisions"
  ;; ENTRY1 and ENTRY2 both provide 'bin/guile'--a collision.  Make sure
  ;; ENTRY1 "wins" over ENTRY2.  See <https://bugs.gnu.org/49102>.
  (mlet* %store-monad
      ((entry1 ->  (package->manifest-entry %bootstrap-guile))
       (entry2 ->  (manifest-entry
                     (name "fake-guile")
                     (version "0")
                     (item (computed-file
                            "fake-guile"
                            #~(begin
                                (mkdir #$output)
                                (mkdir (string-append #$output "/bin"))
                                (call-with-output-file
                                    (string-append #$output "/bin/guile")
                                  (lambda (port)
                                    (display "Fake!\n" port))))))))
       (guile      (package->derivation %bootstrap-guile))
       (drv        (profile-derivation (manifest (list entry1 entry2))
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv))
       (bindir ->  (string-append profile "/bin"))
       (file ->    (string-append bindir "/guile"))
       (_          (built-derivations (list drv))))
    (return (string=? (readlink file)
                      (string-append
                       (derivation->output-path guile)
                       "/bin/guile")))))

(test-assertm "load-profile"
  (mlet* %store-monad
      ((entry ->   (package->manifest-entry %bootstrap-guile))
       (guile      (package->derivation %bootstrap-guile))
       (drv        (profile-derivation (manifest (list entry))
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv))
       (bindir ->  (string-append profile "/bin"))
       (_          (built-derivations (list drv))))
    (define-syntax-rule (with-environment-excursion exp ...)
      (let ((env (environ)))
        (dynamic-wind
          (const #t)
          (lambda () exp ...)
          (lambda () (environ env)))))

    (return (and (with-environment-excursion
                  (load-profile profile)
                  (and (string-prefix? (string-append bindir ":")
                                       (getenv "PATH"))
                       (getenv "GUILE_LOAD_PATH")))
                 (with-environment-excursion
                  (load-profile profile #:pure? #t #:white-list '())
                  (equal? (list (string-append "PATH=" bindir))
                          (environ)))))))

(test-assertm "<profile>"
  (mlet* %store-monad
      ((entry ->   (package->manifest-entry %bootstrap-guile))
       (profile -> (profile (hooks '()) (locales? #f)
                            (content (manifest (list entry)))))
       (drv        (lower-object profile))
       (profile -> (derivation->output-path drv))
       (bindir ->  (string-append profile "/bin"))
       (_          (built-derivations (list drv))))
    (return (file-exists? (string-append bindir "/guile")))))

(test-assertm "profile-derivation relative symlinks, one entry"
  (mlet* %store-monad
      ((entry ->   (package->manifest-entry %bootstrap-guile))
       (guile      (package->derivation %bootstrap-guile))
       (drv        (profile-derivation (manifest (list entry))
                                       #:relative-symlinks? #t
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv))
       (bindir ->  (string-append profile "/bin"))
       (_          (built-derivations (list drv))))
    (return (and (file-exists? (string-append bindir "/guile"))
                 (string=? (readlink bindir)
                           (string-append "../"
                                          (basename
                                           (derivation->output-path guile))
                                          "/bin"))))))

(unless (network-reachable?) (test-skip 1))
(test-assertm "profile-derivation relative symlinks, two entries"
  (mlet* %store-monad
      ((manifest -> (packages->manifest
                     (list %bootstrap-guile gnu-make-for-tests)))
       (guile       (package->derivation %bootstrap-guile))
       (make        (package->derivation gnu-make-for-tests))
       (drv         (profile-derivation manifest
                                        #:relative-symlinks? #t
                                        #:hooks '()
                                        #:locales? #f))
       (profile ->  (derivation->output-path drv))
       (bindir ->   (string-append profile "/bin"))
       (_           (built-derivations (list drv))))
    (return (and (file-exists? (string-append bindir "/guile"))
                 (file-exists? (string-append bindir "/make"))
                 (string=? (readlink (string-append bindir "/guile"))
                           (string-append "../../"
                                          (basename
                                           (derivation->output-path guile))
                                          "/bin/guile"))
                 (string=? (readlink (string-append bindir "/make"))
                           (string-append "../../"
                                          (basename
                                           (derivation->output-path make))
                                          "/bin/make"))))))

(test-assertm "profile-derivation, inputs"
  (mlet* %store-monad
      ((entry ->   (package->manifest-entry packages:glibc "debug"))
       (drv        (profile-derivation (manifest (list entry))
                                       #:hooks '()
                                       #:locales? #f)))
    (return (derivation-inputs drv))))

(test-assertm "profile-derivation, cross-compilation"
  (mlet* %store-monad
      ((manifest -> (packages->manifest (list packages:sed packages:grep)))
       (target ->   "arm-linux-gnueabihf")
       (grep        (package->cross-derivation packages:grep target))
       (sed         (package->cross-derivation packages:sed target))
       (locales     (package->derivation packages:glibc-utf8-locales))
       (drv         (profile-derivation manifest
                                        #:hooks '()
                                        #:locales? #t
                                        #:target target)))
    (define (find-input package)
      (let ((name (string-append (package-full-name package "-") ".drv")))
        (any (lambda (input)
               (let ((input (derivation-input-path input)))
                 (and (string-suffix? name input) input)))
             (derivation-inputs drv))))

    ;; The inputs for grep and sed should be cross-build derivations, but that
    ;; for the glibc-utf8-locales should be a native build.
    (return (and (string=? (derivation-system drv) (%current-system))
                 (string=? (find-input packages:grep)
                           (derivation-file-name grep))
                 (string=? (find-input packages:sed)
                           (derivation-file-name sed))
                 (string=? (find-input packages:glibc-utf8-locales)
                           (derivation-file-name locales))))))

(test-assert "package->manifest-entry defaults to \"out\""
  (let ((outputs (package-outputs packages:glibc)))
    (equal? (manifest-entry-output
             (package->manifest-entry (package
                                        (inherit packages:glibc)
                                        (outputs (reverse outputs)))))
            (manifest-entry-output
             (package->manifest-entry packages:glibc))
            "out")))

(test-assertm "profile-manifest, search-paths"
  (mlet* %store-monad
      ((guile ->   (package
                     (inherit %bootstrap-guile)
                     (native-search-paths
                      (package-native-search-paths packages:guile-2.0))))
       (entry ->   (package->manifest-entry guile))
       (drv        (profile-derivation (manifest (list entry))
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv)))
    (mbegin %store-monad
      (built-derivations (list drv))

      ;; Read the manifest back and make sure search paths are preserved.
      (let ((manifest (profile-manifest profile)))
        (match (manifest-entries manifest)
          ((result)
           (return (equal? (manifest-entry-search-paths result)
                           (manifest-entry-search-paths entry)
                           (package-native-search-paths
                            packages:guile-2.0)))))))))

(test-assert "package->manifest-entry, search paths"
  ;; See <http://bugs.gnu.org/22073>.
  (let ((mpl (@ (gnu packages python-xyz) python2-matplotlib)))
    (lset= eq?
           (package-transitive-native-search-paths mpl)
           (manifest-entry-search-paths
            (package->manifest-entry mpl)))))

(test-assert "packages->manifest, no duplicates"
  (let ((expected
         (manifest
          (list
           (package->manifest-entry packages:guile-2.2))))
        (manifest (packages->manifest
                   (list packages:guile-2.2 packages:guile-2.2))))
    (every manifest-entry=? (manifest-entries expected)
           (manifest-entries manifest))))

(test-equal "packages->manifest, propagated inputs"
  (map (match-lambda
         ((label package)
          (list (package-name package) (package-version package)
                package)))
       (package-propagated-inputs packages:guile-2.2))
  (map (lambda (entry)
         (list (manifest-entry-name entry)
               (manifest-entry-version entry)
               (manifest-entry-item entry)))
       (manifest-entry-dependencies
        (package->manifest-entry packages:guile-2.2))))

(test-assert "manifest-entry-parent"
  (let ((entry (package->manifest-entry packages:guile-2.2)))
    (match (manifest-entry-dependencies entry)
      ((dependencies ..1)
       (and (every (lambda (parent)
                     (eq? entry (force parent)))
                   (map manifest-entry-parent dependencies))
            (not (force (manifest-entry-parent entry))))))))

(test-assertm "read-manifest"
  (mlet* %store-monad ((manifest -> (packages->manifest
                                     (list (package
                                             (inherit %bootstrap-guile)
                                             (native-search-paths
                                              (package-native-search-paths
                                               packages:guile-2.0))))))
                       (drv (profile-derivation manifest
                                                #:hooks '()
                                                #:locales? #f))
                       (out -> (derivation->output-path drv)))
    (define (entry->sexp entry)
      (list (manifest-entry-name entry)
            (manifest-entry-version entry)
            (manifest-entry-search-paths entry)
            (manifest-entry-dependencies entry)
            (force (manifest-entry-parent entry))))

    (mbegin %store-monad
      (built-derivations (list drv))
      (let ((manifest2 (profile-manifest out)))
        (return (equal? (map entry->sexp (manifest-entries manifest))
                        (map entry->sexp (manifest-entries manifest2))))))))

(test-equal "collision"
  '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
  (guard (c ((profile-collision-error? c)
             (let ((entry1 (profile-collision-error-entry c))
                   (entry2 (profile-collision-error-conflict c)))
               (list (list (manifest-entry-name entry1)
                           (manifest-entry-version entry1))
                     (list (manifest-entry-name entry2)
                           (manifest-entry-version entry2))))))
    (run-with-store %store
      (mlet* %store-monad ((p0 -> (package
                                    (inherit %bootstrap-guile)
                                    (version "42")))
                           (p1 -> (dummy-package "p1"
                                    (propagated-inputs `(("p0" ,p0)))))
                           (manifest -> (packages->manifest
                                         (list %bootstrap-guile p1)))
                           (drv (profile-derivation manifest
                                                    #:hooks '()
                                                    #:locales? #f)))
        (return #f)))))

(test-equal "collision of propagated inputs"
  '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
  (guard (c ((profile-collision-error? c)
             (let ((entry1 (profile-collision-error-entry c))
                   (entry2 (profile-collision-error-conflict c)))
               (list (list (manifest-entry-name entry1)
                           (manifest-entry-version entry1))
                     (list (manifest-entry-name entry2)
                           (manifest-entry-version entry2))))))
    (run-with-store %store
      (mlet* %store-monad ((p0 -> (package
                                    (inherit %bootstrap-guile)
                                    (version "42")))
                           (p1 -> (dummy-package "p1"
                                    (propagated-inputs
                                     `(("guile" ,%bootstrap-guile)))))
                           (p2 -> (dummy-package "p2"
                                    (propagated-inputs
                                     `(("guile" ,p0)))))
                           (manifest -> (packages->manifest (list p1 p2)))
                           (drv (profile-derivation manifest
                                                    #:hooks '()
                                                    #:locales? #f)))
        (return #f)))))

(test-assertm "no collision"
  ;; Here we have an entry that is "lowered" (its 'item' field is a store file
  ;; name) and another entry (its 'item' field is a package) that is
  ;; equivalent.
  (mlet* %store-monad ((p -> (dummy-package "p"
                               (propagated-inputs
                                `(("guile" ,%bootstrap-guile)))))
                       (guile    (package->derivation %bootstrap-guile))
                       (entry -> (manifest-entry
                                   (inherit (package->manifest-entry
                                             %bootstrap-guile))
                                   (item (derivation->output-path guile))))
                       (manifest -> (manifest
                                     (list entry
                                           (package->manifest-entry p))))
                       (drv (profile-derivation manifest)))
    (return (->bool drv))))

(test-assertm "etc/profile"
  ;; Make sure we get an 'etc/profile' file that at least defines $PATH.
  (mlet* %store-monad
      ((guile ->   (package
                     (inherit %bootstrap-guile)
                     (native-search-paths
                      (package-native-search-paths packages:guile-2.0))))
       (entry ->   (package->manifest-entry guile))
       (drv        (profile-derivation (manifest (list entry))
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv)))
    (mbegin %store-monad
      (built-derivations (list drv))
      (let* ((pipe (open-input-pipe
                    (string-append "unset GUIX_PROFILE; "
                                   ;; 'source' is a Bashism; use '.' (dot).
                                   ". " profile "/etc/profile; "
                                   ;; Don't try to parse set(1) output because
                                   ;; it differs among shells; just use echo.
                                   "echo $PATH")))
             (path (get-string-all pipe)))
        (return
         (and (zero? (close-pipe pipe))
              (string-contains path (string-append profile "/bin"))))))))

(test-assertm "etc/profile when etc/ already exists"
  ;; Here 'union-build' makes the profile's etc/ a symlink to the package's
  ;; etc/ directory, which makes it read-only.  Make sure the profile build
  ;; handles that.
  (mlet* %store-monad
      ((thing ->   (dummy-package "dummy"
                     (build-system trivial-build-system)
                     (arguments
                      `(#:guile ,%bootstrap-guile
                        #:builder
                        (let ((out (assoc-ref %outputs "out")))
                          (mkdir out)
                          (mkdir (string-append out "/etc"))
                          (call-with-output-file (string-append out "/etc/foo")
                            (lambda (port)
                              (display "foo!" port)))
                          #t)))))
       (entry ->   (package->manifest-entry thing))
       (drv        (profile-derivation (manifest (list entry))
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv)))
    (mbegin %store-monad
      (built-derivations (list drv))
      (return (and (file-exists? (string-append profile "/etc/profile"))
                   (string=? (call-with-input-file
                                 (string-append profile "/etc/foo")
                               get-string-all)
                             "foo!"))))))

(test-assertm "etc/profile when etc/ is a symlink"
  ;; When etc/ is a symlink, the unsymlink code in 0.8.2 would fail
  ;; gracelessly because 'scandir' would return #f.
  (mlet* %store-monad
      ((thing ->   (dummy-package "dummy"
                     (build-system trivial-build-system)
                     (arguments
                      `(#:guile ,%bootstrap-guile
                        #:builder
                        (let ((out (assoc-ref %outputs "out")))
                          (mkdir out)
                          (mkdir (string-append out "/foo"))
                          (symlink "foo" (string-append out "/etc"))
                          (call-with-output-file (string-append out "/etc/bar")
                            (lambda (port)
                              (display "foo!" port)))
                          #t)))))
       (entry ->   (package->manifest-entry thing))
       (drv        (profile-derivation (manifest (list entry))
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv)))
    (mbegin %store-monad
      (built-derivations (list drv))
      (return (and (file-exists? (string-append profile "/etc/profile"))
                   (string=? (call-with-input-file
                                 (string-append profile "/etc/bar")
                               get-string-all)
                             "foo!"))))))

(test-assertm "profile-derivation when etc/ is a relative symlink"
  ;; See <https://bugs.gnu.org/32686>.
  (mlet* %store-monad
      ((etc        (gexp->derivation
                    "etc"
                    #~(begin
                        (mkdir #$output)
                        (call-with-output-file (string-append #$output "/foo")
                          (lambda (port)
                            (display "Heya!" port))))))
       (thing ->   (dummy-package "dummy"
                     (build-system trivial-build-system)
                     (inputs
                      `(("etc" ,etc)))
                     (arguments
                      `(#:guile ,%bootstrap-guile
                        #:builder
                        (let ((out (assoc-ref %outputs "out"))
                              (etc (assoc-ref %build-inputs "etc")))
                          (mkdir out)
                          (symlink etc (string-append out "/etc"))
                          #t)))))
       (entry ->   (package->manifest-entry thing))
       (drv        (profile-derivation (manifest (list entry))
                                       #:relative-symlinks? #t
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv)))
    (mbegin %store-monad
      (built-derivations (list drv))
      (return (string=? (call-with-input-file
                            (string-append profile "/etc/foo")
                          get-string-all)
                        "Heya!")))))

(test-equalm "union vs. dangling symlink"        ;<https://bugs.gnu.org/26949>
  "does-not-exist"
  (mlet* %store-monad
      ((thing1 ->  (dummy-package "dummy"
                     (build-system trivial-build-system)
                     (arguments
                      `(#:guile ,%bootstrap-guile
                        #:builder
                        (let ((out (assoc-ref %outputs "out")))
                          (mkdir out)
                          (symlink "does-not-exist"
                                   (string-append out "/dangling"))
                          #t)))))
       (thing2 ->  (package (inherit thing1) (name "dummy2")))
       (drv        (profile-derivation (packages->manifest
                                        (list thing1 thing2))
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv)))
    (mbegin %store-monad
      (built-derivations (list drv))
      (return (readlink (readlink (string-append profile "/dangling")))))))

(test-equalm "profile in profile"
  '("foo" "0")

  ;; Make sure we can build a profile that has another profile has one of its
  ;; entries.  The new profile's /manifest and /etc/profile must override the
  ;; other's.
  (mlet* %store-monad
      ((prof0 (profile-derivation
               (manifest
                (list (package->manifest-entry %bootstrap-guile)))
               #:hooks '()
               #:locales? #f))
       (prof1 (profile-derivation
               (manifest (list (manifest-entry
                                 (name "foo")
                                 (version "0")
                                 (item prof0))))
               #:hooks '()
               #:locales? #f)))
    (mbegin %store-monad
      (built-derivations (list prof1))
      (let ((out (derivation->output-path prof1)))
        (return (and (file-exists?
                      (string-append out "/bin/guile"))
                     (let ((manifest (profile-manifest out)))
                       (match (manifest-entries manifest)
                         ((entry)
                          (list (manifest-entry-name entry)
                                (manifest-entry-version entry)))))))))))

(test-end "profiles")

;;; Local Variables:
;;; eval: (put 'dummy-package 'scheme-indent-function 1)
;;; End:


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2020 by Amar M. Singh <nly@disroot.org>
;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 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/>.

;; Avoid interference.
(unsetenv "http_proxy")

(define-module (test-publish)
  #:use-module (guix scripts publish)
  #:use-module (guix tests)
  #:use-module (guix config)
  #:use-module (guix utils)
  #:use-module (gcrypt hash)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (guix base32)
  #:use-module (guix base64)
  #:use-module ((guix records) #:select (recutils->alist))
  #:use-module ((guix serialization) #:select (restore-file))
  #:use-module (gcrypt pk-crypto)
  #:use-module ((guix pki) #:select (%public-key-file %private-key-file))
  #:use-module (zlib)
  #:use-module (lzlib)
  #:autoload   (zstd) (call-with-zstd-input-port)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web response)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 binary-ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim))

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

(define (zstd-supported?)
  (resolve-module '(zstd) #t #f #:ensure #f))

(define %reference (add-text-to-store %store "ref" "foo"))

(define %item (add-text-to-store %store "item" "bar" (list %reference)))

(define (http-get-body uri)
  (call-with-values (lambda () (http-get uri))
    (lambda (response body) body)))

(define (http-get-port uri)
  (let ((socket (open-socket-for-uri uri)))
    ;; Make sure to use an unbuffered port so that we can then peek at the
    ;; underlying file descriptor via 'call-with-gzip-input-port'.
    (setvbuf socket 'none)
    (call-with-values
        (lambda ()
          (http-get uri #:port socket #:streaming? #t))
      (lambda (response port)
        ;; Don't (setvbuf port 'none) because of <http://bugs.gnu.org/19610>
        ;; (PORT might be a custom binary input port).
        port))))

(define (publish-uri route)
  (string-append "http://localhost:6789" route))

(define-syntax-rule (with-separate-output-ports exp ...)
  ;; Since ports aren't thread-safe in Guile 2.0, duplicate the output and
  ;; error ports to make sure the two threads don't end up stepping on each
  ;; other's toes.
  (with-output-to-port (duplicate-port (current-output-port) "w")
    (lambda ()
      (with-error-to-port (duplicate-port (current-error-port) "w")
        (lambda ()
          exp ...)))))

;; Run a local publishing server in a separate thread.
(with-separate-output-ports
 (call-with-new-thread
  (lambda ()
    (guix-publish "--port=6789" "-C0"))))     ;attempt to avoid port collision

(define (wait-until-ready port)
  ;; Wait until the server is accepting connections.
  (let ((conn (socket PF_INET SOCK_STREAM 0)))
    (let loop ()
      (unless (false-if-exception
               (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port))
        (loop)))))

(define (wait-for-file file)
  ;; Wait until FILE shows up.
  (let loop ((i 20))
    (cond ((file-exists? file)
           #t)
          ((zero? i)
           (error "file didn't show up" file))
          (else
           (pk 'wait-for-file file)
           (sleep 1)
           (loop (- i 1))))))

(define %gzip-magic-bytes
  ;; Magic bytes of gzip file.
  #vu8(#x1f #x8b))

;; Wait until the two servers are ready.
(wait-until-ready 6789)

;; Initialize the public/private key SRFI-39 parameters.
(%public-key (read-file-sexp %public-key-file))
(%private-key (read-file-sexp %private-key-file))

(test-begin "publish")

(test-equal "/nix-cache-info"
  (format #f "StoreDir: ~a\nWantMassQuery: 0\nPriority: 100\n"
          %store-directory)
  (http-get-body (publish-uri "/nix-cache-info")))

(test-equal "/*.narinfo"
  (let* ((info (query-path-info %store %item))
         (unsigned-info
          (format #f
                  "StorePath: ~a
URL: nar/~a
Compression: none
FileSize: ~a
NarHash: sha256:~a
NarSize: ~d
References: ~a~%"
                  %item
                  (basename %item)
                  (path-info-nar-size info)
                  (bytevector->nix-base32-string
                   (path-info-hash info))
                  (path-info-nar-size info)
                  (basename (first (path-info-references info)))))
         (signature (base64-encode
                     (string->utf8
                      (canonical-sexp->string
                       (signed-string unsigned-info))))))
    (format #f "~aSignature: 1;~a;~a~%"
            unsigned-info (gethostname) signature))
  (utf8->string
   (http-get-body
    (publish-uri
     (string-append "/" (store-path-hash-part %item) ".narinfo")))))

(test-equal "/*.narinfo with properly encoded '+' sign"
  ;; See <http://bugs.gnu.org/21888>.
  (let* ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))
         (info (query-path-info %store item))
         (unsigned-info
          (format #f
                  "StorePath: ~a
URL: nar/~a
Compression: none
FileSize: ~a
NarHash: sha256:~a
NarSize: ~d
References: ~%"
                  item
                  (uri-encode (basename item))
                  (path-info-nar-size info)
                  (bytevector->nix-base32-string
                   (path-info-hash info))
                  (path-info-nar-size info)))
         (signature (base64-encode
                     (string->utf8
                      (canonical-sexp->string
                       (signed-string unsigned-info))))))
    (format #f "~aSignature: 1;~a;~a~%"
            unsigned-info (gethostname) signature))

  (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
    (utf8->string
     (http-get-body
      (publish-uri
       (string-append "/" (store-path-hash-part item) ".narinfo"))))))

(test-equal "/nar/*"
  "bar"
  (call-with-temporary-output-file
   (lambda (temp port)
     (let ((nar (utf8->string
                 (http-get-body
                  (publish-uri
                   (string-append "/nar/" (basename %item)))))))
       (call-with-input-string nar (cut restore-file <> temp)))
     (call-with-input-file temp read-string))))

(test-equal "/nar/gzip/*"
  "bar"
  (call-with-temporary-output-file
   (lambda (temp port)
     (let ((nar (http-get-port
                 (publish-uri
                  (string-append "/nar/gzip/" (basename %item))))))
       (call-with-gzip-input-port nar
         (cut restore-file <> temp)))
     (call-with-input-file temp read-string))))

(test-equal "/nar/gzip/* is really gzip"
  %gzip-magic-bytes
  ;; Since 'gzdopen' (aka. 'call-with-gzip-input-port') transparently reads
  ;; uncompressed gzip, the test above doesn't check whether it's actually
  ;; gzip.  This is what this test does.  See <https://bugs.gnu.org/30184>.
  (let ((nar (http-get-port
              (publish-uri
               (string-append "/nar/gzip/" (basename %item))))))
    (get-bytevector-n nar (bytevector-length %gzip-magic-bytes))))

(test-equal "/nar/lzip/*"
  "bar"
  (call-with-temporary-output-file
   (lambda (temp port)
     (let ((nar (http-get-port
                 (publish-uri
                  (string-append "/nar/lzip/" (basename %item))))))
       (call-with-lzip-input-port nar
         (cut restore-file <> temp)))
     (call-with-input-file temp read-string))))

(unless (zstd-supported?) (test-skip 1))
(test-equal "/nar/zstd/*"
  "bar"
  (call-with-temporary-output-file
   (lambda (temp port)
     (let ((nar (http-get-port
                 (publish-uri
                  (string-append "/nar/zstd/" (basename %item))))))
       (call-with-zstd-input-port nar
         (cut restore-file <> temp)))
     (call-with-input-file temp read-string))))

(test-equal "/*.narinfo with compression"
  `(("StorePath" . ,%item)
    ("URL" . ,(string-append "nar/gzip/" (basename %item)))
    ("Compression" . "gzip"))
  (let ((thread (with-separate-output-ports
                 (call-with-new-thread
                  (lambda ()
                    (guix-publish "--port=6799" "-C5"))))))
    (wait-until-ready 6799)
    (let* ((url  (string-append "http://localhost:6799/"
                                (store-path-hash-part %item) ".narinfo"))
           (body (http-get-port url)))
      (filter (lambda (item)
                (match item
                  (("Compression" . _) #t)
                  (("StorePath" . _)  #t)
                  (("URL" . _) #t)
                  (_ #f)))
              (recutils->alist body)))))

(test-equal "/*.narinfo with lzip compression"
  `(("StorePath" . ,%item)
    ("URL" . ,(string-append "nar/lzip/" (basename %item)))
    ("Compression" . "lzip"))
  (let ((thread (with-separate-output-ports
                 (call-with-new-thread
                  (lambda ()
                    (guix-publish "--port=6790" "-Clzip"))))))
    (wait-until-ready 6790)
    (let* ((url  (string-append "http://localhost:6790/"
                                (store-path-hash-part %item) ".narinfo"))
           (body (http-get-port url)))
      (filter (lambda (item)
                (match item
                  (("Compression" . _) #t)
                  (("StorePath" . _)  #t)
                  (("URL" . _) #t)
                  (_ #f)))
              (recutils->alist body)))))

(test-equal "/*.narinfo for a compressed file"
  '("none" "nar")          ;compression-less nar
  ;; Assume 'guix publish -C' is already running on port 6799.
  (let* ((item (add-text-to-store %store "fake.tar.gz"
                                  "This is a fake compressed file."))
         (url  (string-append "http://localhost:6799/"
                              (store-path-hash-part item) ".narinfo"))
         (body (http-get-port url))
         (info (recutils->alist body)))
    (list (assoc-ref info "Compression")
          (dirname (assoc-ref info "URL")))))

(test-equal "/*.narinfo with lzip + gzip"
  `((("StorePath" . ,%item)
     ("URL" . ,(string-append "nar/gzip/" (basename %item)))
     ("Compression" . "gzip")
     ("URL" . ,(string-append "nar/lzip/" (basename %item)))
     ("Compression" . "lzip"))
    200
    200)
  (call-with-temporary-directory
   (lambda (cache)
     (let ((thread (with-separate-output-ports
                    (call-with-new-thread
                     (lambda ()
                       (guix-publish "--port=6793" "-Cgzip:2" "-Clzip:2"))))))
       (wait-until-ready 6793)
       (let* ((base "http://localhost:6793/")
              (part (store-path-hash-part %item))
              (url  (string-append base part ".narinfo"))
              (body (http-get-port url)))
         (list (take (recutils->alist body) 5)
               (response-code
                (http-get (string-append base "nar/gzip/"
                                         (basename %item))))
               (response-code
                (http-get (string-append base "nar/lzip/"
                                         (basename %item))))))))))

(test-equal "custom nar path"
  ;; Serve nars at /foo/bar/chbouib instead of /nar.
  (list `(("StorePath" . ,%item)
          ("URL" . ,(string-append "foo/bar/chbouib/" (basename %item)))
          ("Compression" . "none"))
        200
        404)
  (let ((thread (with-separate-output-ports
                 (call-with-new-thread
                  (lambda ()
                    (guix-publish "--port=6798" "-C0"
                                  "--nar-path=///foo/bar//chbouib/"))))))
    (wait-until-ready 6798)
    (let* ((base    "http://localhost:6798/")
           (part    (store-path-hash-part %item))
           (url     (string-append base part ".narinfo"))
           (nar-url (string-append base "foo/bar/chbouib/"
                                   (basename %item)))
           (body    (http-get-port url)))
      (list (filter (lambda (item)
                      (match item
                        (("Compression" . _) #t)
                        (("StorePath" . _)  #t)
                        (("URL" . _) #t)
                        (_ #f)))
                    (recutils->alist body))
            (response-code (http-get nar-url))
            (response-code
             (http-get (string-append base "nar/" (basename %item))))))))

(test-equal "/nar/ with properly encoded '+' sign"
  "Congrats!"
  (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
    (call-with-temporary-output-file
     (lambda (temp port)
       (let ((nar (utf8->string
                   (http-get-body
                    (publish-uri
                     (string-append "/nar/" (uri-encode (basename item))))))))
         (call-with-input-string nar (cut restore-file <> temp)))
       (call-with-input-file temp read-string)))))

(test-equal "/nar/invalid"
  404
  (begin
    (call-with-output-file (string-append (%store-prefix) "/invalid")
      (lambda (port)
        (display "This file is not a valid store item." port)))
    (response-code (http-get (publish-uri (string-append "/nar/invalid"))))))

(test-equal "/file/NAME/sha256/HASH"
  "Hello, Guix world!"
  (let* ((data "Hello, Guix world!")
         (hash (call-with-input-string data port-sha256))
         (drv  (run-with-store %store
                 (gexp->derivation "the-file.txt"
                                   #~(call-with-output-file #$output
                                       (lambda (port)
                                         (display #$data port)))
                                   #:hash-algo 'sha256
                                   #:hash hash)))
         (out  (build-derivations %store (list drv))))
    (utf8->string
     (http-get-body
      (publish-uri
       (string-append "/file/the-file.txt/sha256/"
                      (bytevector->nix-base32-string hash)))))))

(test-equal "/file/NAME/sha256/INVALID-NIX-BASE32-STRING"
  404
  (let ((uri (publish-uri
              "/file/the-file.txt/sha256/not-a-nix-base32-string")))
    (response-code (http-get uri))))

(test-equal "/file/NAME/sha256/INVALID-HASH"
  404
  (let ((uri (publish-uri
              (string-append "/file/the-file.txt/sha256/"
                             (bytevector->nix-base32-string
                              (call-with-input-string "" port-sha256))))))
    (response-code (http-get uri))))

(test-equal "with cache"
  (list #t
        `(("StorePath" . ,%item)
          ("URL" . ,(string-append "nar/gzip/" (basename %item)))
          ("Compression" . "gzip"))
        200                                       ;nar/gzip/…
        #t                                        ;Content-Length
        #t                                        ;FileSize
        404)                                      ;nar/…
  (call-with-temporary-directory
   (lambda (cache)
     (let ((thread (with-separate-output-ports
                    (call-with-new-thread
                     (lambda ()
                       (guix-publish "--port=6797" "-C2"
                                     (string-append "--cache=" cache)
                                     "--cache-bypass-threshold=0"))))))
       (wait-until-ready 6797)
       (let* ((base     "http://localhost:6797/")
              (part     (store-path-hash-part %item))
              (url      (string-append base part ".narinfo"))
              (nar-url  (string-append base "nar/gzip/" (basename %item)))
              (cached   (string-append cache "/gzip/" (basename %item)
                                       ".narinfo"))
              (nar      (string-append cache "/gzip/"
                                       (basename %item) ".nar"))
              (response (http-get url)))
         (and (= 404 (response-code response))

              ;; We should get an explicitly short TTL for 404 in this case
              ;; because it's going to become 200 shortly.
              (match (assq-ref (response-headers response) 'cache-control)
                ((('max-age . ttl))
                 (< ttl 3600)))

              (wait-for-file cached)

              ;; Both the narinfo and nar should be world-readable.
              (= #o444 (logand #o444 (stat:perms (lstat cached))))
              (= #o444 (logand #o444 (stat:perms (lstat nar))))

              (let* ((body         (http-get-port url))
                     (compressed   (http-get nar-url))
                     (uncompressed (http-get (string-append base "nar/"
                                                            (basename %item))))
                     (narinfo      (recutils->alist body)))
                (list (file-exists? nar)
                      (filter (lambda (item)
                                (match item
                                  (("Compression" . _) #t)
                                  (("StorePath" . _)  #t)
                                  (("URL" . _) #t)
                                  (_ #f)))
                              narinfo)
                      (response-code compressed)
                      (= (response-content-length compressed)
                         (stat:size (stat nar)))
                      (= (string->number
                          (assoc-ref narinfo "FileSize"))
                         (stat:size (stat nar)))
                      (response-code uncompressed)))))))))

(test-equal "with cache, lzip + gzip"
  '(200 200 404)
  (call-with-temporary-directory
   (lambda (cache)
     (let ((thread (with-separate-output-ports
                    (call-with-new-thread
                     (lambda ()
                       (guix-publish "--port=6794" "-Cgzip:2" "-Clzip:2"
                                     (string-append "--cache=" cache)
                                     "--cache-bypass-threshold=0"))))))
       (wait-until-ready 6794)
       (let* ((base     "http://localhost:6794/")
              (part     (store-path-hash-part %item))
              (url      (string-append base part ".narinfo"))
              (nar-url  (cute string-append "nar/" <> "/"
                              (basename %item)))
              (cached   (cute string-append cache "/" <> "/"
                              (basename %item) ".narinfo"))
              (nar      (cute string-append cache "/" <> "/"
                              (basename %item) ".nar"))
              (response (http-get url)))
         (wait-for-file (cached "gzip"))
         (let* ((body         (http-get-port url))
                (narinfo      (recutils->alist body))
                (uncompressed (string-append base "nar/"
                                             (basename %item))))
           (and (file-exists? (nar "gzip"))
                (file-exists? (nar "lzip"))
                (equal? (take (pk 'narinfo/gzip+lzip narinfo) 7)
                        `(("StorePath" . ,%item)
                          ("URL" . ,(nar-url "gzip"))
                          ("Compression" . "gzip")
                          ("FileSize" . ,(number->string
                                          (stat:size (stat (nar "gzip")))))
                          ("URL" . ,(nar-url "lzip"))
                          ("Compression" . "lzip")
                          ("FileSize" . ,(number->string
                                          (stat:size (stat (nar "lzip")))))))
                (list (response-code
                       (http-get (string-append base (nar-url "gzip"))))
                      (response-code
                       (http-get (string-append base (nar-url "lzip"))))
                      (response-code
                       (http-get uncompressed))))))))))

(let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz"
                               (random-text))))
  (test-equal "with cache, uncompressed"
    (list #t
          (* 42 3600)                             ;TTL on narinfo
          `(("StorePath" . ,item)
            ("URL" . ,(string-append "nar/" (basename item)))
            ("Compression" . "none"))
          200                                     ;nar/…
          (* 42 3600)                             ;TTL on nar/…
          (path-info-nar-size
           (query-path-info %store item))         ;FileSize
          404)                                    ;nar/gzip/…
    (call-with-temporary-directory
     (lambda (cache)
       (let ((thread (with-separate-output-ports
                      (call-with-new-thread
                       (lambda ()
                         (guix-publish "--port=6796" "-C2" "--ttl=42h"
                                       (string-append "--cache=" cache)
                                       "--cache-bypass-threshold=0"))))))
         (wait-until-ready 6796)
         (let* ((base     "http://localhost:6796/")
                (part     (store-path-hash-part item))
                (url      (string-append base part ".narinfo"))
                (cached   (string-append cache "/none/"
                                         (basename item) ".narinfo"))
                (nar      (string-append cache "/none/"
                                         (basename item) ".nar"))
                (response (http-get url)))
           (and (= 404 (response-code response))

                (wait-for-file cached)
                (let* ((response     (http-get url))
                       (body         (http-get-port url))
                       (compressed   (http-get (string-append base "nar/gzip/"
                                                              (basename item))))
                       (uncompressed (http-get (string-append base "nar/"
                                                              (basename item))))
                       (narinfo      (recutils->alist body)))
                  (list (file-exists? nar)
                        (match (assq-ref (response-headers response)
                                         'cache-control)
                          ((('max-age . ttl)) ttl)
                          (_ #f))

                        (filter (lambda (item)
                                  (match item
                                    (("Compression" . _) #t)
                                    (("StorePath" . _)  #t)
                                    (("URL" . _) #t)
                                    (_ #f)))
                                narinfo)
                        (response-code uncompressed)
                        (match (assq-ref (response-headers uncompressed)
                                         'cache-control)
                          ((('max-age . ttl)) ttl)
                          (_ #f))

                        (string->number
                         (assoc-ref narinfo "FileSize"))
                        (response-code compressed))))))))))

(test-equal "with cache, vanishing item"         ;<https://bugs.gnu.org/33897>
  200
  (call-with-temporary-directory
   (lambda (cache)
     (let ((thread (with-separate-output-ports
                    (call-with-new-thread
                     (lambda ()
                       (guix-publish "--port=6795"
                                     (string-append "--cache=" cache)))))))
       (wait-until-ready 6795)

       ;; Make sure that, even if ITEM disappears, we're still able to fetch
       ;; it.
       (let* ((base     "http://localhost:6795/")
              (item     (add-text-to-store %store "random" (random-text)))
              (part     (store-path-hash-part item))
              (url      (string-append base part ".narinfo"))
              (cached   (string-append cache "/gzip/"
                                       (basename item)
                                       ".narinfo"))
              (response (http-get url)))
         (and (= 200 (response-code response))    ;we're below the threshold
              (wait-for-file cached)
              (begin
                (delete-paths %store (list item))
                (response-code (pk 'response (http-get url))))))))))

(test-equal "with cache, cache bypass"
  200
  (call-with-temporary-directory
   (lambda (cache)
     (let ((thread (with-separate-output-ports
                    (call-with-new-thread
                     (lambda ()
                       (guix-publish "--port=6788" "-C" "gzip"
                                     (string-append "--cache=" cache)))))))
       (wait-until-ready 6788)

       (let* ((base     "http://localhost:6788/")
              (item     (add-text-to-store %store "random" (random-text)))
              (part     (store-path-hash-part item))
              (narinfo  (string-append base part ".narinfo"))
              (nar      (string-append base "nar/gzip/" (basename item)))
              (cached   (string-append cache "/gzip/" (basename item)
                                       ".narinfo")))
         ;; We're below the default cache bypass threshold, so NAR and NARINFO
         ;; should immediately return 200.  The NARINFO request should trigger
         ;; caching, and the next request to NAR should return 200 as well.
         (and (let ((response (pk 'r1 (http-get nar))))
                (and (= 200 (response-code response))
                     (not (response-content-length response)))) ;not known
              (= 200 (response-code (http-get narinfo)))
              (begin
                (wait-for-file cached)
                (let ((response (pk 'r2 (http-get nar))))
                  (and (> (response-content-length response)
                          (stat:size (stat item)))
                       (response-code response))))))))))

(test-equal "with cache, cache bypass, unmapped hash part"
  200

  ;; This test reproduces the bug described in <https://bugs.gnu.org/44442>:
  ;; the daemon connection would be closed as a side effect of a nar request
  ;; for a non-existing file name.
  (call-with-temporary-directory
   (lambda (cache)
     (let ((thread (with-separate-output-ports
                    (call-with-new-thread
                     (lambda ()
                       (guix-publish "--port=6787" "-C" "gzip"
                                     (string-append "--cache=" cache)))))))
       (wait-until-ready 6787)

       (let* ((base     "http://localhost:6787/")
              (item     (add-text-to-store %store "random" (random-text)))
              (part     (store-path-hash-part item))
              (narinfo  (string-append base part ".narinfo"))
              (nar      (string-append base "nar/gzip/" (basename item)))
              (cached   (string-append cache "/gzip/" (basename item)
                                       ".narinfo")))
         ;; The first response used to be 500 and to terminate the daemon
         ;; connection as a side effect.
         (and (= (response-code
                  (http-get (string-append base "nar/gzip/"
                                           (make-string 32 #\e)
                                           "-does-not-exist")))
                 404)
              (= 200 (response-code (http-get nar)))
              (= 200 (response-code (http-get narinfo)))
              (begin
                (wait-for-file cached)
                (response-code (http-get nar)))))))))

(test-equal "/log/NAME"
  `(200 #t application/x-bzip2)
  (let ((drv (run-with-store %store
               (gexp->derivation "with-log"
                                 #~(call-with-output-file #$output
                                     (lambda (port)
                                       (display "Hello, build log!"
                                                (current-error-port))
                                       (display #$(random-text) port)))))))
    (build-derivations %store (list drv))
    (let* ((response (http-get
                      (publish-uri (string-append "/log/"
                                                  (basename (derivation->output-path drv))))
                      #:decode-body? #f))
           (base     (basename (derivation-file-name drv)))
           (log      (string-append (dirname %state-directory)
                                    "/log/guix/drvs/" (string-take base 2)
                                    "/" (string-drop base 2) ".bz2")))
      (list (response-code response)
            (= (response-content-length response) (stat:size (stat log)))
            (first (response-content-type response))))))

(test-equal "negative TTL"
  `(404 42)

  (call-with-temporary-directory
   (lambda (cache)
     (let ((thread (with-separate-output-ports
                    (call-with-new-thread
                     (lambda ()
                       (guix-publish "--port=6786" "-C0"
                                     "--negative-ttl=42s"))))))
       (wait-until-ready 6786)

       (let* ((base     "http://localhost:6786/")
              (url      (string-append base (make-string 32 #\z)
                                       ".narinfo"))
              (response (http-get url)))
         (list (response-code response)
               (match (assq-ref (response-headers response) 'cache-control)
                 ((('max-age . ttl)) ttl)
                 (_ #f))))))))

(test-equal "no negative TTL"
  `(404 #f)
  (let* ((uri      (publish-uri
                    (string-append "/" (make-string 32 #\z)
                                   ".narinfo")))
         (response (http-get uri)))
    (list (response-code response)
          (assq-ref (response-headers response) 'cache-control))))

(test-equal "/log/NAME not found"
  404
  (let ((uri (publish-uri "/log/does-not-exist")))
    (response-code (http-get uri))))

(test-equal "/signing-key.pub"
  200
  (response-code (http-get (publish-uri "/signing-key.pub"))))

(test-equal "non-GET query"
  '(200 404)
  (let ((path (string-append "/" (store-path-hash-part %item)
                             ".narinfo")))
    (map response-code
         (list (http-get (publish-uri path))
               (http-post (publish-uri path))))))

(test-end "publish")

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; 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 (test-pypi)
  #:use-module (guix import pypi)
  #:use-module (guix base32)
  #:use-module (guix memoization)
  #:use-module (gcrypt hash)
  #:use-module (guix tests)
  #:use-module (guix build-system python)
  #:use-module ((guix build utils) #:select (delete-file-recursively which mkdir-p))
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match))

(define test-json
  "{
  \"info\": {
    \"version\": \"1.0.0\",
    \"name\": \"foo\",
    \"license\": \"GNU LGPL\",
    \"summary\": \"summary\",
    \"home_page\": \"http://example.com\",
    \"classifiers\": [],
    \"download_url\": \"\"
  },
  \"urls\": [],
  \"releases\": {
    \"1.0.0\": [
      {
        \"url\": \"https://example.com/foo-1.0.0.egg\",
        \"packagetype\": \"bdist_egg\"
      }, {
        \"url\": \"https://example.com/foo-1.0.0.tar.gz\",
        \"packagetype\": \"sdist\"
      }, {
        \"url\": \"https://example.com/foo-1.0.0-py2.py3-none-any.whl\",
        \"packagetype\": \"bdist_wheel\"
      }
    ]
  }
}")

(define test-source-hash
  "")

(define test-specifications
  '("Fizzy [foo, bar]"
    "PickyThing<1.6,>1.9,!=1.9.6,<2.0a0,==2.4c1"
    "SomethingWithMarker[foo]>1.0;python_version<\"2.7\""
    "requests [security,tests] >= 2.8.1, == 2.8.* ; python_version < \"2.7\""
    "pip @ https://github.com/pypa/pip/archive/1.3.1.zip#\
sha1=da9234ee9982d4bbb3c72346a6de940a148ea686"))

(define test-requires.txt "\
# A comment
 # A comment after a space
foo ~= 3
bar != 2

[test]
pytest (>=2.5.0)
")

;; Beaker contains only optional dependencies.
(define test-requires.txt-beaker "\
[crypto]
pycryptopp>=0.5.12

[cryptography]
cryptography

[testsuite]
Mock
coverage
")

(define test-metadata "\
Classifier: Programming Language :: Python :: 3.7
Requires-Dist: baz ~= 3
Requires-Dist: bar != 2
Provides-Extra: test
Requires-Dist: pytest (>=2.5.0) ; extra == 'test'
")

(define test-metadata-with-extras "
Classifier: Programming Language :: Python :: 3.7
Requires-Python: >=2.7, !=3.0.*, !=3.1.*, !=3.2.*, !=3.3.*
Requires-Dist: wrapt (<2,>=1)
Requires-Dist: bar

Provides-Extra: dev
Requires-Dist: tox ; extra == 'dev'
Requires-Dist: bumpversion (<1) ; extra == 'dev'
")

;;; Provides-Extra can appear before Requires-Dist.
(define test-metadata-with-extras-jedi "\
Requires-Python: >=2.7, !=3.0.*, !=3.1.*, !=3.2.*, !=3.3.*
Provides-Extra: testing
Requires-Dist: parso (>=0.3.0)
Provides-Extra: testing
Requires-Dist: pytest (>=3.1.0); extra == 'testing'
")

(test-begin "pypi")

(test-equal "guix-package->pypi-name, old URL style"
  "psutil"
  (guix-package->pypi-name
   (dummy-package "foo"
                  (source (dummy-origin
                           (uri
                            "https://pypi.org/packages/source/p/psutil/psutil-4.3.0.tar.gz"))))))

(test-equal "guix-package->pypi-name, new URL style"
  "certbot"
  (guix-package->pypi-name
   (dummy-package "foo"
                  (source (dummy-origin
                           (uri
                            "https://pypi.org/packages/a2/3b/4756e6a0ceb14e084042a2a65c615d68d25621c6fd446d0fc10d14c4ce7d/certbot-0.8.1.tar.gz"))))))

(test-equal "guix-package->pypi-name, several URLs"
  "cram"
  (guix-package->pypi-name
   (dummy-package "foo"
                  (source
                   (dummy-origin
                    (uri (list "https://bitheap.org/cram/cram-0.7.tar.gz"
                               (pypi-uri "cram" "0.7"))))))))

(test-equal "specification->requirement-name"
  '("Fizzy" "PickyThing" "SomethingWithMarker" "requests" "pip")
  (map specification->requirement-name test-specifications))

(test-equal "parse-requires.txt"
  (list '("foo" "bar") '("pytest"))
  (mock ((ice-9 ports) call-with-input-file
         call-with-input-string)
        (parse-requires.txt test-requires.txt)))

(test-equal "parse-requires.txt - Beaker"
  (list '() '("Mock" "coverage"))
  (mock ((ice-9 ports) call-with-input-file
         call-with-input-string)
        (parse-requires.txt test-requires.txt-beaker)))

(test-equal "parse-wheel-metadata, with extras"
  (list '("wrapt" "bar") '("tox" "bumpversion"))
  (mock ((ice-9 ports) call-with-input-file
         call-with-input-string)
        (parse-wheel-metadata test-metadata-with-extras)))

(test-equal "parse-wheel-metadata, with extras - Jedi"
  (list '("parso") '("pytest"))
  (mock ((ice-9 ports) call-with-input-file
         call-with-input-string)
        (parse-wheel-metadata test-metadata-with-extras-jedi)))

(test-assert "pypi->guix-package, no wheel"
  ;; Replace network resources with sample data.
    (mock ((guix import utils) url-fetch
           (lambda (url file-name)
             (match url
               ("https://example.com/foo-1.0.0.tar.gz"
                (begin
                  ;; Unusual requires.txt location should still be found.
                  (mkdir-p "foo-1.0.0/src/bizarre.egg-info")
                  (with-output-to-file "foo-1.0.0/src/bizarre.egg-info/requires.txt"
                    (lambda ()
                      (display test-requires.txt)))
                  (parameterize ((current-output-port (%make-void-port "rw+")))
                    (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))))
               ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
               (_ (error "Unexpected URL: " url)))))
          (mock ((guix http-client) http-fetch
                 (lambda (url . rest)
                   (match url
                     ("https://pypi.org/pypi/foo/json"
                      (values (open-input-string test-json)
                              (string-length test-json)))
                     ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
                     (_ (error "Unexpected URL: " url)))))
                (match (pypi->guix-package "foo")
                  (('package
                     ('name "python-foo")
                     ('version "1.0.0")
                     ('source ('origin
                                ('method 'url-fetch)
                                ('uri ('pypi-uri "foo" 'version))
                                ('sha256
                                 ('base32
                                  (? string? hash)))))
                     ('build-system 'python-build-system)
                     ('propagated-inputs
                      ('quasiquote
                       (("python-bar" ('unquote 'python-bar))
                        ("python-foo" ('unquote 'python-foo)))))
                     ('native-inputs
                      ('quasiquote
                       (("python-pytest" ('unquote 'python-pytest)))))
                     ('home-page "http://example.com")
                     ('synopsis "summary")
                     ('description "summary")
                     ('license 'license:lgpl2.0))
                   (string=? (bytevector->nix-base32-string
                              test-source-hash)
                             hash))
                  (x
                   (pk 'fail x #f))))))

(test-skip (if (which "zip") 0 1))
(test-assert "pypi->guix-package, wheels"
  ;; Replace network resources with sample data.
  (mock ((guix import utils) url-fetch
         (lambda (url file-name)
           (match url
             ("https://example.com/foo-1.0.0.tar.gz"
              (begin
                (mkdir-p "foo-1.0.0/foo.egg-info/")
                (with-output-to-file "foo-1.0.0/foo.egg-info/requires.txt"
                  (lambda ()
                    (display "wrong data to make sure we're testing wheels ")))
                (parameterize ((current-output-port (%make-void-port "rw+")))
                  (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))))
             ("https://example.com/foo-1.0.0-py2.py3-none-any.whl"
              (begin
                (mkdir "foo-1.0.0.dist-info")
                (with-output-to-file "foo-1.0.0.dist-info/METADATA"
                  (lambda ()
                    (display test-metadata)))
                (let ((zip-file (string-append file-name ".zip")))
                  ;; zip always adds a "zip" extension to the file it creates,
                  ;; so we need to rename it.
                  (system* "zip" "-q" zip-file "foo-1.0.0.dist-info/METADATA")
                  (rename-file zip-file file-name))
                (delete-file-recursively "foo-1.0.0.dist-info")))
             (_ (error "Unexpected URL: " url)))))
        (mock ((guix http-client) http-fetch
               (lambda (url . rest)
                 (match url
                   ("https://pypi.org/pypi/foo/json"
                    (values (open-input-string test-json)
                            (string-length test-json)))
                   ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
                   (_ (error "Unexpected URL: " url)))))
              ;; Not clearing the memoization cache here would mean returning the value
              ;; computed in the previous test.
              (invalidate-memoization! pypi->guix-package)
              (match (pypi->guix-package "foo")
                (('package
                   ('name "python-foo")
                   ('version "1.0.0")
                   ('source ('origin
                              ('method 'url-fetch)
                              ('uri ('pypi-uri "foo" 'version))
                              ('sha256
                               ('base32
                                (? string? hash)))))
                   ('build-system 'python-build-system)
                   ('propagated-inputs
                    ('quasiquote
                     (("python-bar" ('unquote 'python-bar))
                      ("python-baz" ('unquote 'python-baz)))))
                   ('native-inputs
                    ('quasiquote
                     (("python-pytest" ('unquote 'python-pytest)))))
                   ('home-page "http://example.com")
                   ('synopsis "summary")
                   ('description "summary")
                   ('license 'license:lgpl2.0))
                 (string=? (bytevector->nix-base32-string
                            test-source-hash)
                           hash))
                (x
                 (pk 'fail x #f))))))

(test-assert "pypi->guix-package, no usable requirement file."
  ;; Replace network resources with sample data.
  (mock ((guix import utils) url-fetch
         (lambda (url file-name)
           (match url
             ("https://example.com/foo-1.0.0.tar.gz"
              (mkdir-p "foo-1.0.0/foo.egg-info/")
              (parameterize ((current-output-port (%make-void-port "rw+")))
                (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)))
             ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
             (_ (error "Unexpected URL: " url)))))
        (mock ((guix http-client) http-fetch
               (lambda (url . rest)
                 (match url
                   ("https://pypi.org/pypi/foo/json"
                    (values (open-input-string test-json)
                            (string-length test-json)))
                   ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
                   (_ (error "Unexpected URL: " url)))))
              ;; Not clearing the memoization cache here would mean returning the value
              ;; computed in the previous test.
              (invalidate-memoization! pypi->guix-package)
              (match (pypi->guix-package "foo")
                (('package
                   ('name "python-foo")
                   ('version "1.0.0")
                   ('source ('origin
                              ('method 'url-fetch)
                              ('uri ('pypi-uri "foo" 'version))
                              ('sha256
                               ('base32
                                (? string? hash)))))
                   ('build-system 'python-build-system)
                   ('home-page "http://example.com")
                   ('synopsis "summary")
                   ('description "summary")
                   ('license 'license:lgpl2.0))
                 (string=? (bytevector->nix-base32-string
                            test-source-hash)
                           hash))
                (x
                 (pk 'fail x #f))))))

(test-end "pypi")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020, 2021 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-records)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (guix records))

(define (test-module)
  ;; A module in which to evaluate things that are known to fail.
  (let ((module (make-fresh-user-module)))
    (module-use! module (resolve-interface '(guix records)))
    module))

(define (location-alist loc)
  ;; Return a location alist.  In Guile < 3.0.6, LOC is always an alist, but
  ;; starting with 3.0.6, LOC is a vector (at least when it comes from
  ;; 'syntax-error' exceptions), hence this conversion.
  (match loc
    (#(file line column)
     `((line . ,line) (column . ,column)
       (filename . ,file)))
    (_ loc)))

(test-begin "records")

(test-assert "define-record-type*"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (default (+ 40 2))))
    (and (match (foo (bar 1) (baz 2))
           (($ <foo> 1 2) #t))
         (match (foo (baz 2) (bar 1))
           (($ <foo> 1 2) #t))
         (match (foo (bar 1))
           (($ <foo> 1 42) #t)))))

(test-assert "define-record-type* with let* behavior"
  ;; Make sure field initializers can refer to each other as if they were in
  ;; a 'let*'.
  (begin
    (define-record-type* <bar> bar make-bar
      foo?
      (x bar-x)
      (y bar-y (default (+ 40 2)))
      (z bar-z))
    (and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
           (($ <bar> 1 2 4) #t))
         (match (bar (x 7) (z (* x 3)))
           (($ <bar> 7 42 21) #t))
         (match (bar (z 21) (x (/ z 3)))
           (($ <bar> 7 42 21) #t)))))

(test-assert "define-record-type* & inherit"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (default (+ 40 2))))
    (let* ((a (foo (bar 1)))
           (b (foo (inherit a) (baz 2)))
           (c (foo (inherit b) (bar -2)))
           (d (foo (inherit c)))
           (e (foo (inherit (foo (bar 42))) (baz 77))))
     (and (match a (($ <foo> 1 42) #t))
          (match b (($ <foo> 1 2) #t))
          (match c (($ <foo> -2 2) #t))
          (equal? c d)
          (match e (($ <foo> 42 77) #t))))))

(test-assert "define-record-type* & inherit & let* behavior"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (default (+ 40 2))))
    (let* ((a (foo (bar 77)))
           (b (foo (inherit a) (bar 1) (baz (+ bar 1))))
           (c (foo (inherit b) (baz 2) (bar (- baz 1)))))
     (and (match a (($ <foo> 77 42) #t))
          (match b (($ <foo> 1 2) #t))
          (equal? b c)))))

(test-assert "define-record-type* & inherit & innate"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar (innate) (default 42)))
    (let* ((a (foo (bar 1)))
           (b (foo (inherit a)))
           (c (foo (inherit a) (bar 3)))
           (d (foo)))
      (and (match a (($ <foo> 1) #t))
           (match b (($ <foo> 42) #t))
           (match c (($ <foo> 3) #t))
           (match d (($ <foo> 42) #t))))))

(test-assert "define-record-type* & thunked"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (thunked)))

    (let* ((calls 0)
           (x     (foo (bar 2)
                       (baz (begin (set! calls (1+ calls)) 3)))))
      (and (zero? calls)
           (equal? (foo-bar x) 2)
           (equal? (foo-baz x) 3) (= 1 calls)
           (equal? (foo-baz x) 3) (= 2 calls)))))

(test-assert "define-record-type* & thunked & default"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (thunked) (default 42)))

    (let ((mark (make-parameter #f)))
      (let ((x (foo (bar 2) (baz (mark))))
            (y (foo (bar 2))))
        (and (equal? (foo-bar x) 2)
             (parameterize ((mark (cons 'a 'b)))
               (eq? (foo-baz x) (mark)))
             (equal? (foo-bar y) 2)
             (equal? (foo-baz y) 42))))))

(test-assert "define-record-type* & thunked & inherited"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar (thunked))
      (baz foo-baz (thunked) (default 42)))

    (let ((mark (make-parameter #f)))
      (let* ((x (foo (bar 2) (baz (mark))))
             (y (foo (inherit x) (bar (mark)))))
        (and (equal? (foo-bar x) 2)
             (parameterize ((mark (cons 'a 'b)))
               (eq? (foo-baz x) (mark)))
             (parameterize ((mark (cons 'a 'b)))
               (eq? (foo-bar y) (mark)))
             (parameterize ((mark (cons 'a 'b)))
               (eq? (foo-baz y) (mark))))))))

(test-assert "define-record-type* & thunked & innate"
  (let ((mark (make-parameter #f)))
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar (thunked) (innate) (default (mark)))
      (baz foo-baz (default #f)))

    (let* ((x (foo (bar 42)))
           (y (foo (inherit x) (baz 'unused))))
      (and (procedure? (struct-ref x 0))
           (equal? (foo-bar x) 42)
           (parameterize ((mark (cons 'a 'b)))
             (eq? (foo-bar y) (mark)))
           (parameterize ((mark (cons 'a 'b)))
             (eq? (foo-bar y) (mark)))))))

(test-assert "define-record-type* & thunked & this-record"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (thunked)))

    (let ((x (foo (bar 40)
                  (baz (+ (foo-bar this-record) 2)))))
      (and (= 40 (foo-bar x))
           (= 42 (foo-baz x))))))

(test-assert "define-record-type* & thunked & default & this-record"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (thunked)
           (default (+ (foo-bar this-record) 2))))

    (let ((x (foo (bar 40))))
      (and (= 40 (foo-bar x))
           (= 42 (foo-baz x))))))

(test-assert "define-record-type* & thunked & inherit & this-record"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar)
      (baz foo-baz (thunked)
           (default (+ (foo-bar this-record) 2))))

    (let* ((x (foo (bar 40)))
           (y (foo (inherit x) (bar -2)))
           (z (foo (inherit x) (baz -2))))
      (and (= -2 (foo-bar y))
           (=  0 (foo-baz y))
           (= 40 (foo-bar z))
           (= -2 (foo-baz z))))))

(test-assert "define-record-type* & thunked & inherit & custom this"
  (let ()
    (define-record-type* <foo> foo make-foo
      foo? this-foo
      (thing foo-thing (thunked)))
    (define-record-type* <bar> bar make-bar
      bar? this-bar
      (baz bar-baz (thunked)))

    ;; Nest records and test the two self references.
    (let* ((x (foo (thing (bar (baz (list this-bar this-foo))))))
           (y (foo-thing x)))
      (match (bar-baz y)
        ((first second)
         (and (eq? second x)
              (bar? first)
              (eq? first y)))))))

(test-assert "define-record-type* & delayed"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar (delayed)))

    (let* ((calls 0)
           (x     (foo (bar (begin (set! calls (1+ calls)) 3)))))
      (and (zero? calls)
           (equal? (foo-bar x) 3) (= 1 calls)
           (equal? (foo-bar x) 3) (= 1 calls)
           (equal? (foo-bar x) 3) (= 1 calls)))))

(test-assert "define-record-type* & delayed & default"
  (let ((mark #f))
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar (delayed) (default mark)))

    (let ((x (foo)))
      (set! mark 42)
      (and (equal? (foo-bar x) 42)
           (begin
             (set! mark 7)
             (equal? (foo-bar x) 42))))))

(test-assert "define-record-type* & delayed & inherited"
  (begin
    (define-record-type* <foo> foo make-foo
      foo?
      (bar foo-bar (delayed))
      (baz foo-baz (delayed)))

    (let* ((m 1)
           (n #f)
           (x (foo (bar m) (baz n)))
           (y (foo (inherit x) (baz 'b))))
      (set! n 'a)
      (and (equal? (foo-bar x) 1)
           (eq? (foo-baz x) 'a)
           (begin
             (set! m 777)
             (equal? (foo-bar y) 1))              ;promise was already forced
           (eq? (foo-baz y) 'b)))))

(test-assert "define-record-type* & wrong field specifier"
  (let ((exp '(begin
                (define-record-type* <foo> foo make-foo
                  foo?
                  (bar foo-bar (default 42))
                  (baz foo-baz))

                (foo (baz 1 2 3 4 5))))           ;syntax error
        (loc         (current-source-location)))  ;keep this alignment!
    (catch 'syntax-error
      (lambda ()
        (eval exp (test-module))
        #f)
      (lambda (key proc message location form subform . _)
        (and (eq? proc 'foo)
             (string-match "invalid field" message)
             (equal? subform '(baz 1 2 3 4 5))
             (equal? form '(foo (baz 1 2 3 4 5)))

             ;; Make sure the location is that of the field specifier.
             ;; See <http://bugs.gnu.org/23969>.
             (lset= equal?
                    (pk 'expected-loc
                        `((line . ,(- (assq-ref loc 'line) 1))
                          ,@(alist-delete 'line loc)))
                    (pk 'actual-loc (location-alist location))))))))

(test-assert "define-record-type* & wrong field specifier, identifier"
  (let ((exp '(begin
                (define-record-type* <foo> foo make-foo
                  foo?
                  (bar foo-bar (default 42))
                  (baz foo-baz))

                (foo
                 baz)))                           ;syntax error
        (loc    (current-source-location)))       ;keep this alignment!
    (catch 'syntax-error
      (lambda ()
        (eval exp (test-module))
        #f)
      (lambda (key proc message location form subform . _)
        (and (eq? proc 'foo)
             (string-match "invalid field" message)
             (equal? subform 'baz)
             (equal? form '(foo baz))

             ;; Here the location is that of the parent form.
             (lset= equal?
                    (pk 'expected-loc
                        `((line . ,(- (assq-ref loc 'line) 2))
                          ,@(alist-delete 'line loc)))
                    (pk 'actual-loc (location-alist location))))))))

(test-assert "define-record-type* & missing initializers"
  (catch 'syntax-error
    (lambda ()
      (eval '(begin
               (define-record-type* <foo> foo make-foo
                 foo?
                 (bar foo-bar (default 42))
                 (baz foo-baz))

               (foo))
            (test-module))
      #f)
    (lambda (key proc message location form . args)
      (and (eq? proc 'foo)
           (string-match "missing .*initialize.*baz" message)
           (equal? form '(foo))))))

(test-assert "define-record-type* & extra initializers"
  (catch 'syntax-error
    (lambda ()
      (eval '(begin
               (define-record-type* <foo> foo make-foo
                 foo?
                 (bar foo-bar (default 42)))

               (foo (baz 'what?)))
            (test-module))
      #f)
    (lambda (key proc message location form . args)
      (and (string-match "extra.*initializer.*baz" message)
           (eq? proc 'foo)))))

(test-assert "define-record-type* & inherit & extra initializers"
  (catch 'syntax-error
    (lambda ()
      (eval '(begin
               (define-record-type* <foo> foo make-foo
                 foo?
                 (bar foo-bar (default 42)))

               (foo (inherit (foo)) (baz 'what?)))
            (test-module))
      #f)
    (lambda (key proc message location form . args)
      (and (string-match "extra.*initializer.*baz" message)
           (eq? proc 'foo)))))

(test-assert "define-record-type* & duplicate initializers"
  (let ((exp '(begin
                (define-record-type* <foo> foo make-foo
                  foo?
                  (bar foo-bar (default 42)))

                (foo (bar 1)
                     (bar 2))))
        (loc         (current-source-location)))  ;keep this alignment!
    (catch 'syntax-error
      (lambda ()
        (eval exp (test-module))
        #f)
      (lambda (key proc message location form . args)
        (and (string-match "duplicate.*initializer" message)
             (eq? proc 'foo)

             ;; Make sure the location is that of the field specifier.
             (lset= equal?
                    (pk 'expected-loc
                        `((line . ,(- (assq-ref loc 'line) 1))
                          ,@(alist-delete 'line loc)))
                    (pk 'actual-loc (location-alist location))))))))

(test-assert "ABI checks"
  (let ((module (test-module)))
    (eval '(begin
             (define-record-type* <foo> foo make-foo
               foo?
               (bar foo-bar (default 42)))

             (define (make-me-a-record) (foo)))
          module)
    (unless (eval '(foo? (make-me-a-record)) module)
      (error "what?" (eval '(make-me-a-record) module)))

    ;; Redefine <foo> with an additional field.
    (eval '(define-record-type* <foo> foo make-foo
             foo?
             (baz foo-baz)
             (bar foo-bar (default 42)))
          module)

    ;; Now 'make-me-a-record' is out of sync because it does an
    ;; 'allocate-struct' that corresponds to the previous definition of <foo>.
    (catch 'record-abi-mismatch-error
      (lambda ()
        (eval '(foo? (make-me-a-record)) module)
        #f)
      (match-lambda*
        ((key 'abi-check (? string? message) (rtd) . _)
         (eq? rtd (eval '<foo> module)))))))

(test-equal "recutils->alist"
  '((("Name" . "foo")
     ("Version" . "0.1")
     ("Synopsis" . "foo bar")
     ("Something_else" . "chbouib"))
    (("Name" . "bar")
     ("Version" . "1.5")))
  (let ((p (open-input-string "
# Comment following an empty line, and
# preceding a couple of empty lines, all of
# which should be silently consumed.

Name: foo
Version: 0.1
# Comment right in the middle,
# spanning two lines.
Synopsis: foo bar
Something_else: chbouib

# Comment right before.
Name: bar
Version: 1.5
# Comment at the end.")))
    (list (recutils->alist p)
          (recutils->alist p))))

(test-equal "recutils->alist with + lines"
  '(("Name" . "foo")
    ("Description" . "1st line,\n2nd line,\n 3rd line with extra space,\n4th line without space."))
  (recutils->alist (open-input-string "
Name: foo
Description: 1st line,
+ 2nd line,
+  3rd line with extra space,
+4th line without space.")))

(test-equal "alist->record" '((1 2) b c)
  (alist->record '(("a" . 1) ("b" . b) ("c" . c) ("a" . 2))
                 list
                 '("a" "b" "c")
                 '("a")))

(test-end)


code:
-----BEGIN PGP PUBLIC KEY BLOCK-----

mQENBF4SRCYBCAC6eVyonmey9Lsa1QpWIcumkExZWmAsTNhNNrdhasU4rC0DGRnw
lJtey4h/5NRcGmur4cwwnHUyh9RhQOZgc4MkWfUECfgY98dhjq6+wSavSMwYJyKM
7yGuJgKQBBhdkfjYONP4eHbucifGNhsNRSURUREVCarOYa1AhmH4cmTPe7cUA8mH
EfQ2SOsmAUBNjn/Ba2Us8ydiZWGpJXYdzsXQ3HZl1vV2UtPEepPjAkJZa/7hm06z
9WrlOUxoro/R2R7COMWpzuhmY1Ak2VB4H6OMqPAEOk+/H5Pda1yCI9oRROawC24h
4yZYTpcRKV0EQ4cd4Z/DKA4gJdjufyRrmk0fABEBAAG0GzxsdWRvK3Rlc3QtcnNh
QGNoYm91aWIub3JnPokBVAQTAQgAPhYhBDhfhs/Ia2ZaXBZea64l2ipw3u1ZBQJe
EkQmAhsDBQkDwmcABQsJCAcCBhUKCQgLAgQWAgMBAh4BAheAAAoJEK4l2ipw3u1Z
c70IAI+eBLJzXGXNlugNE5rl5YplrLQem9otL7OKIpR+ye3Wg/DRZvN9x+lvUftq
rG0+wqxo/WQTy6ZLDUI83OY13zLXDKjRgPdqPYBAYxCY8CMayjDUv8axZVEfC7IX
IYgqzZg0E0dfF3m9S+6WUfOYCS5qR2go7TxbrnDyhDiswd5r3TRX5U+asHm0iXTy
Pmb0WY301mm1UPToOHSpweMuCw/n5as15o9CWeUJa/I0J6puM66ZRqGt8+7BSCu6
ata0BYLBCUD8aqhgNQpcMAkTRUSr8LNgfgdxr2Ozr+FF39NXGfLihL18AQEvh3SI
K/5YAnXV2oMRhOQttDJROOXByoY=
=N6XF
-----END PGP PUBLIC KEY BLOCK-----


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 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-scripts)
  #:use-module (guix scripts)
  #:use-module (guix tests)
  #:use-module ((guix scripts build)
                #:select (%standard-build-options))
  #:use-module (srfi srfi-64))

;; Test the (guix scripts) module.

(test-begin "scripts")

(test-equal "parse-command-line"
  '((argument . "bar") (argument . "foo")
    (cores . 10)                                  ;takes precedence
    (substitutes? . #f) (keep-failed? . #t)
    (max-jobs . 77) (cores . 42))

  (with-environment-variable "GUIX_BUILD_OPTIONS" "-c 42 -M 77"
    (parse-command-line '("--keep-failed" "--no-substitutes"
                          "--cores=10" "foo" "bar")
                        %standard-build-options
                        (list '()))))

(test-equal "parse-command-line and --no options"
  '((argument . "foo")
    (substitutes? . #f))                          ;takes precedence

  (with-environment-variable "GUIX_BUILD_OPTIONS" "--no-substitutes"
    (parse-command-line '("foo")
                        %standard-build-options
                        (list '((substitutes? . #t))))))

(test-end "scripts")

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 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-search-paths)
  #:use-module (guix search-paths)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-64))

(define %top-srcdir
  (dirname (search-path %load-path "guix.scm")))

(test-begin "search-paths")

(test-equal "evaluate-search-paths, separator is #f"
  (string-append %top-srcdir
                 "/gnu/packages/aux-files/linux-libre")

  ;; The following search path spec should evaluate to a single item: the
  ;; first directory that matches the "-linux$" pattern in
  ;; gnu/packages/bootstrap.
  (let ((spec (search-path-specification
               (variable "CHBOUIB")
               (files '("gnu/packages/aux-files"))
               (file-type 'directory)
               (separator #f)
               (file-pattern "^linux"))))
    (match (evaluate-search-paths (list spec)
                                  (list %top-srcdir))
      (((spec* . value))
       (and (eq? spec* spec) value)))))

(test-end "search-paths")