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

;; 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 (guix zlib)
  #: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 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim))

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

(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 _IONBF)
    (call-with-values
        (lambda ()
          (http-get uri #:port socket #:streaming? #t))
      (lambda (response port)
        ;; Don't (setvbuf port _IONBF) 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
NarHash: sha256:~a
NarSize: ~d
References: ~a
FileSize: ~a~%"
                  %item
                  (basename %item)
                  (bytevector->nix-base32-string
                   (path-info-hash info))
                  (path-info-nar-size info)
                  (basename (first (path-info-references info)))
                  (path-info-nar-size info)))
         (signature (base64-encode
                     (string->utf8
                      (canonical-sexp->string
                       ((@@ (guix scripts publish) 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
NarHash: sha256:~a
NarSize: ~d
References: ~%\
FileSize: ~a~%"
                  item
                  (uri-encode (basename item))
                  (bytevector->nix-base32-string
                   (path-info-hash info))
                  (path-info-nar-size info)
                  (path-info-nar-size info)))
         (signature (base64-encode
                     (string->utf8
                      (canonical-sexp->string
                       ((@@ (guix scripts publish) 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))))

(unless (zlib-available?)
  (test-skip 1))
(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))))

(unless (zlib-available?)
  (test-skip 1))
(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))))

(unless (zlib-available?)
  (test-skip 1))
(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)))))

(unless (zlib-available?)
  (test-skip 1))
(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 "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))))

(unless (zlib-available?)
  (test-skip 1))
(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)))))))
       (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)
              (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)))))))))

(unless (zlib-available?)
  (test-skip 1))
(let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz"
                               (random-text))))
  (test-equal "with cache, uncompressed"
    (list #t
          `(("StorePath" . ,item)
            ("URL" . ,(string-append "nar/" (basename item)))
            ("Compression" . "none"))
          200                                     ;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"
                                       (string-append "--cache=" cache)))))))
         (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* ((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)
                        (filter (lambda (item)
                                  (match item
                                    (("Compression" . _) #t)
                                    (("StorePath" . _)  #t)
                                    (("URL" . _) #t)
                                    (_ #f)))
                                narinfo)
                        (response-code uncompressed)
                        (string->number
                         (assoc-ref narinfo "FileSize"))
                        (response-code compressed))))))))))

(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 "/log/NAME not found"
  404
  (let ((uri (publish-uri "/log/does-not-exist")))
    (response-code (http-get uri))))

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-pypi)
  #:use-module (guix import pypi)
  #:use-module (guix base32)
  #:use-module (gcrypt hash)
  #:use-module (guix tests)
  #:use-module (guix build-system python)
  #:use-module ((guix build utils) #:select (delete-file-recursively which))
  #: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\",
  },
  \"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-requirements
"# A comment
 # A comment after a space
bar
baz > 13.37")

(define test-metadata
  "{
  \"run_requires\": [
    {
      \"requires\": [
        \"bar\",
        \"baz (>13.37)\"
      ]
    }
  ]
}")

(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.io/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-assert "pypi->guix-package"
  ;; 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 "foo-1.0.0")
                  (with-output-to-file "foo-1.0.0/requirements.txt"
                    (lambda ()
                      (display test-requirements)))
                  (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-baz" ('unquote 'python-baz)))))
                     ('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 "foo-1.0.0")
                 (with-output-to-file "foo-1.0.0/requirements.txt"
                   (lambda ()
                     (display test-requirements)))
                 (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.json"
                   (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" zip-file "foo-1.0.0.dist-info/metadata.json")
                   (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)))))
              (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)))))
                   ('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")

license: mit


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

(define-module (test-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))

(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* & 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 . args)
        (and (eq? proc 'foo)
             (string-match "invalid field" message)
             (equal? form '(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)))))))

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

(define-module (test-scripts-build)
  #:use-module (guix tests)
  #:use-module (guix store)
  #:use-module (guix packages)
  #:use-module (guix scripts build)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (gnu packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages busybox)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-64))

(test-begin "scripts-build")

(test-assert "options->transformation, no transformations"
  (let ((p (dummy-package "foo"))
        (t (options->transformation '())))
    (with-store store
      (eq? (t store p) p))))

(test-assert "options->transformation, with-source"
  ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should
  ;; be applicable.
  (let* ((p (dummy-package "guix.scm"))
         (s (search-path %load-path "guix.scm"))
         (t (options->transformation `((with-source . ,s)))))
    (with-store store
      (let ((new (t store p)))
        (and (not (eq? new p))
             (string=? (package-source new)
                       (add-to-store store "guix.scm" #t
                                     "sha256" s)))))))

(test-assert "options->transformation, with-source, replacement"
  ;; Same, but this time the original package has a 'replacement' field.  We
  ;; expect that replacement to be set to #f in the new package.
  (let* ((p (dummy-package "guix.scm" (replacement coreutils)))
         (s (search-path %load-path "guix.scm"))
         (t (options->transformation `((with-source . ,s)))))
    (with-store store
      (let ((new (t store p)))
        (and (not (eq? new p))
             (string=? (package-source new)
                       (add-to-store store "guix.scm" #t "sha256" s))
             (not (package-replacement new)))))))

(test-assert "options->transformation, with-source, with version"
  ;; Our pseudo-package is called 'guix.scm' so the 'guix.scm-2.0' source
  ;; should be applicable, and its version should be extracted.
  (let ((p (dummy-package "foo"))
        (s (search-path %load-path "guix.scm")))
    (call-with-temporary-directory
     (lambda (directory)
       (let* ((f (string-append directory "/foo-42.0.tar.gz"))
              (t (options->transformation `((with-source . ,f)))))
         (copy-file s f)
         (with-store store
           (let ((new (t store p)))
             (and (not (eq? new p))
                  (string=? (package-name new) (package-name p))
                  (string=? (package-version new) "42.0")
                  (string=? (package-source new)
                            (add-to-store store (basename f) #t
                                          "sha256" f))))))))))

(test-assert "options->transformation, with-source, no matches"
  ;; When a transformation in not applicable, a warning must be raised.
  (let* ((p (dummy-package "foobar"))
         (s (search-path %load-path "guix.scm"))
         (t (options->transformation `((with-source . ,s)))))
    (with-store store
      (let* ((port (open-output-string))
             (new  (parameterize ((guix-warning-port port))
                     (t store p))))
        (and (eq? new p)
             (string-contains (get-output-string port)
                              "had no effect"))))))

(test-assert "options->transformation, with-source, PKG=URI"
  (let* ((p (dummy-package "foo"))
         (s (search-path %load-path "guix.scm"))
         (f (string-append "foo=" s))
         (t (options->transformation `((with-source . ,f)))))
    (with-store store
      (let ((new (t store p)))
        (and (not (eq? new p))
             (string=? (package-name new) (package-name p))
             (string=? (package-version new)
                       (package-version p))
             (string=? (package-source new)
                       (add-to-store store (basename s) #t
                                     "sha256" s)))))))

(test-assert "options->transformation, with-source, PKG@VER=URI"
  (let* ((p (dummy-package "foo"))
         (s (search-path %load-path "guix.scm"))
         (f (string-append "foo@42.0=" s))
         (t (options->transformation `((with-source . ,f)))))
    (with-store store
      (let ((new (t store p)))
        (and (not (eq? new p))
             (string=? (package-name new) (package-name p))
             (string=? (package-version new) "42.0")
             (string=? (package-source new)
                       (add-to-store store (basename s) #t
                                     "sha256" s)))))))

(test-assert "options->transformation, with-input"
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,(specification->package "coreutils"))
                        ("bar" ,(specification->package "grep"))
                        ("baz" ,(dummy-package "chbouib"
                                  (native-inputs `(("x" ,grep)))))))))
         (t (options->transformation '((with-input . "coreutils=busybox")
                                       (with-input . "grep=findutils")))))
    (with-store store
      (let ((new (t store p)))
        (and (not (eq? new p))
             (match (package-inputs new)
               ((("foo" dep1) ("bar" dep2) ("baz" dep3))
                (and (eq? dep1 busybox)
                     (eq? dep2 findutils)
                     (string=? (package-name dep3) "chbouib")
                     (match (package-native-inputs dep3)
                       ((("x" dep))
                        (eq? dep findutils)))))))))))

(test-assert "options->transformation, with-graft"
  (let* ((p (dummy-package "guix.scm"
              (inputs `(("foo" ,grep)
                        ("bar" ,(dummy-package "chbouib"
                                  (native-inputs `(("x" ,grep)))))))))
         (t (options->transformation '((with-graft . "grep=findutils")))))
    (with-store store
      (let ((new (t store p)))
        (and (not (eq? new p))
             (match (package-inputs new)
               ((("foo" dep1) ("bar" dep2))
                (and (string=? (package-full-name dep1)
                               (package-full-name grep))
                     (eq? (package-replacement dep1) findutils)
                     (string=? (package-name dep2) "chbouib")
                     (match (package-native-inputs dep2)
                       ((("x" dep))
                        (eq? (package-replacement dep) findutils)))))))))))

(test-end)


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

(define-module (test-scripts)
  #:use-module (guix scripts)
  #:use-module ((guix scripts build)
                #:select (%standard-build-options))
  #:use-module (srfi srfi-64))

;; Test the (guix scripts) module.

(define-syntax-rule (with-environment-variable variable value body ...)
  "Run BODY with VARIABLE set to VALUE."
  (let ((orig (getenv variable)))
    (dynamic-wind
      (lambda ()
        (setenv variable value))
      (lambda ()
        body ...)
      (lambda ()
        (if orig
            (setenv variable orig)
            (unsetenv variable))))))

(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 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/bootstrap/aarch64-linux")

  ;; 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/bootstrap"))
               (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")


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

(define-module (test-services)
  #:use-module (gnu services)
  #:use-module (gnu services herd)
  #:use-module (gnu services shepherd)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match))

(define live-service
  (@@ (gnu services herd) live-service))

(test-begin "services")

(test-equal "services, default value"
  '(42 123 234 error)
  (let* ((t1 (service-type (name 't1) (extensions '())))
         (t2 (service-type (name 't2) (extensions '())
                           (default-value 42))))
    (list (service-value (service t2))
          (service-value (service t2 123))
          (service-value (service t1 234))
          (guard (c ((missing-value-service-error? c) 'error))
            (service t1)))))

(test-assert "service-back-edges"
  (let* ((t1 (service-type (name 't1) (extensions '())
                           (compose +) (extend *)))
         (t2 (service-type (name 't2)
                           (extensions
                            (list (service-extension t1 (const '()))))
                           (compose +) (extend *)))
         (t3 (service-type (name 't3)
                           (extensions
                            (list (service-extension t2 identity)
                                  (service-extension t1 list)))))
         (s1 (service t1 #t))
         (s2 (service t2 #t))
         (s3 (service t3 #t))
         (e  (service-back-edges (list s1 s2 s3))))
    (and (lset= eq? (e s1) (list s2 s3))
         (lset= eq? (e s2) (list s3))
         (null? (e s3)))))

(test-equal "fold-services"
  ;; Make sure 'fold-services' returns the right result.  The numbers come
  ;; from services of type T3; 'xyz 60' comes from the service of type T2,
  ;; where 60 = 15 × 4 = (1 + 2 + 3 + 4 + 5) × 4.
  '(initial-value 5 4 3 2 1 xyz 60)
  (let* ((t1 (service-type (name 't1) (extensions '())
                           (compose concatenate)
                           (extend cons)))
         (t2 (service-type (name 't2)
                           (extensions
                            (list (service-extension t1
                                                     (cut list 'xyz <>))))
                           (compose (cut reduce + 0 <>))
                           (extend *)))
         (t3 (service-type (name 't3)
                           (extensions
                            (list (service-extension t2 identity)
                                  (service-extension t1 list)))))
         (r  (fold-services (cons* (service t1 'initial-value)
                                   (service t2 4)
                                   (map (lambda (x)
                                          (service t3 x))
                                        (iota 5 1)))
                            #:target-type t1)))
    (and (eq? (service-kind r) t1)
         (service-value r))))

(test-assert "fold-services, ambiguity"
  (let* ((t1 (service-type (name 't1) (extensions '())
                           (compose concatenate)
                           (extend cons)))
         (t2 (service-type (name 't2)
                           (extensions
                            (list (service-extension t1 list)))))
         (s  (service t2 42)))
    (guard (c ((ambiguous-target-service-error? c)
               (and (eq? (ambiguous-target-service-error-target-type c)
                         t1)
                    (eq? (ambiguous-target-service-error-service c)
                         s))))
      (fold-services (list (service t1 'first)
                           (service t1 'second)
                           s)
                     #:target-type t1)
      #f)))

(test-assert "fold-services, missing target"
  (let* ((t1 (service-type (name 't1) (extensions '())))
         (t2 (service-type (name 't2)
                           (extensions
                            (list (service-extension t1 list)))))
         (s  (service t2 42)))
    (guard (c ((missing-target-service-error? c)
               (and (eq? (missing-target-service-error-target-type c)
                         t1)
                    (eq? (missing-target-service-error-service c)
                         s))))
      (fold-services (list s) #:target-type t1)
      #f)))

(test-assert "instantiate-missing-services"
  (let* ((t1 (service-type (name 't1) (extensions '())
                           (default-value 'dflt)
                           (compose concatenate)
                           (extend cons)))
         (t2 (service-type (name 't2)
                           (extensions
                            (list (service-extension t1 list)))))
         (s1 (service t1 'hey!))
         (s2 (service t2 42)))
    (and (lset= equal?
                (list (service t1) s2)
                (instantiate-missing-services (list s2)))
         (equal? (list s1 s2)
                 (instantiate-missing-services (list s1 s2))))))

(test-assert "instantiate-missing-services, indirect"
  (let* ((t1 (service-type (name 't1) (extensions '())
                           (default-value 'dflt)
                           (compose concatenate)
                           (extend cons)))
         (t2 (service-type (name 't2) (extensions '())
                           (default-value 'dflt2)
                           (compose concatenate)
                           (extend cons)
                           (extensions
                            (list (service-extension t1 list)))))
         (t3 (service-type (name 't3)
                           (extensions
                            (list (service-extension t2 list)))))
         (s1 (service t1))
         (s2 (service t2))
         (s3 (service t3 42))
         (== (cut lset= equal? <...>)))
    (and (== (list s1 s2 s3)
             (instantiate-missing-services (list s3)))
         (== (list s1 s2 s3)
             (instantiate-missing-services (list s1 s3)))
         (== (list s1 s2 s3)
             (instantiate-missing-services (list s2 s3))))))

(test-assert "instantiate-missing-services, no default value"
  (let* ((t1 (service-type (name 't1) (extensions '())))
         (t2 (service-type (name 't2)
                           (extensions
                            (list (service-extension t1 list)))))
         (s  (service t2 42)))
    (guard (c ((missing-target-service-error? c)
               (and (eq? (missing-target-service-error-target-type c)
                         t1)
                    (eq? (missing-target-service-error-service c)
                         s))))
      (instantiate-missing-services (list s))
      #f)))

(test-assert "shepherd-service-lookup-procedure"
  (let* ((s1 (shepherd-service (provision '(s1 s1b)) (start #f)))
         (s2 (shepherd-service (provision '(s2 s2b)) (start #f)))
         (s3 (shepherd-service (provision '(s3 s3b s3c)) (start #f)))
         (lookup (shepherd-service-lookup-procedure (list s1 s2 s3))))
    (and (eq? (lookup 's1) (lookup 's1b) s1)
         (eq? (lookup 's2) (lookup 's2b) s2)
         (eq? (lookup 's3) (lookup 's3b) s3))))

(test-assert "shepherd-service-back-edges"
  (let* ((s1 (shepherd-service (provision '(s1)) (start #f)))
         (s2 (shepherd-service (provision '(s2))
                               (requirement '(s1))
                               (start #f)))
         (s3 (shepherd-service (provision '(s3))
                               (requirement '(s1 s2))
                               (start #f)))
         (e  (shepherd-service-back-edges (list s1 s2 s3))))
    (and (lset= eq? (e s1) (list s2 s3))
         (lset= eq? (e s2) (list s3))
         (null? (e s3)))))

(test-equal "shepherd-service-upgrade: nothing to do"
  '(() ())
  (call-with-values
      (lambda ()
        (shepherd-service-upgrade '() '()))
    list))

(test-equal "shepherd-service-upgrade: one unchanged, one upgraded, one new"
  '(()                                            ;unload
    ((foo)))                                      ;restart
  (call-with-values
      (lambda ()
        ;; Here 'foo' is replaced and must be explicitly restarted later
        ;; because it is still running, whereas 'bar' is upgraded right away
        ;; because it is not currently running.  'baz' is loaded because it's
        ;; a new service.
        (shepherd-service-upgrade
         (list (live-service '(foo) '() #t)
               (live-service '(bar) '() #f)
               (live-service '(root) '() #t))     ;essential!
         (list (shepherd-service (provision '(foo))
                                 (start #t))
               (shepherd-service (provision '(bar))
                                 (start #t))
               (shepherd-service (provision '(baz))
                                 (start #t)))))
    (lambda (unload restart)
      (list (map live-service-provision unload)
            (map shepherd-service-provision restart)))))

(test-equal "shepherd-service-upgrade: service depended on is not unloaded"
  '(((baz))                                       ;unload
    ((foo)))                                      ;restart
  (call-with-values
      (lambda ()
        ;; Service 'bar' is not among the target services; yet, it must not be
        ;; unloaded because 'foo' depends on it.  'foo' gets replaced but it
        ;; must be restarted manually.
        (shepherd-service-upgrade
         (list (live-service '(foo) '(bar) #t)
               (live-service '(bar) '() #t)       ;still used!
               (live-service '(baz) '() #t))
         (list (shepherd-service (provision '(foo))
                                 (start #t)))))
    (lambda (unload restart)
      (list (map live-service-provision unload)
            (map shepherd-service-provision restart)))))

(test-equal "shepherd-service-upgrade: obsolete services that depend on each other"
  '(((foo) (bar) (baz))                           ;unload
    ())                                           ;restart
  (call-with-values
      (lambda ()
        ;; 'foo', 'bar', and 'baz' depend on each other, but all of them are
        ;; obsolete, and thus should be unloaded.
        (shepherd-service-upgrade
         (list (live-service '(foo) '(bar) #t)    ;obsolete
               (live-service '(bar) '(baz) #t)    ;obsolete
               (live-service '(baz) '() #t))      ;obsolete
         (list (shepherd-service (provision '(qux))
                                 (start #t)))))
    (lambda (unload restart)
      (list (map live-service-provision unload)
            (map shepherd-service-provision restart)))))

(test-eq "lookup-service-types"
  system-service-type
  (and (null? (lookup-service-types 'does-not-exist-at-all))
       (match (lookup-service-types 'system)
         ((one) one)
         (x x))))

(test-end)


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

(define-module (test-sets)
  #:use-module (guix sets)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64))

(test-begin "sets")

(test-assert "set-contains?"
  (let* ((lst (iota 123))
         (set (list->set lst)))
    (and (every (cut set-contains? set <>)
                lst)
         (not (set-contains? set -1)))))

(test-assert "set->list"
  (let* ((lst (iota 123))
         (set (list->set lst)))
    (lset= = lst (set->list set))))

(test-assert "set-union"
  (let* ((a  (list 'a))
         (b  (list 'b))
         (s1 (setq a))
         (s2 (setq b))
         (s3 (set-union s1 s2)))
    (and (set-contains? s3 a)
         (set-contains? s3 b))))

(test-end)


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

(define-module (test-size)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (guix tests)
  #:use-module (guix scripts size)
  #:use-module (gnu packages)
  #:use-module (gnu packages bootstrap)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64))

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

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

(test-begin "size")

(test-assertm "store-profile"
  (mlet* %store-monad ((file1 (gexp->derivation "file1"
                                                #~(symlink #$%bootstrap-guile
                                                           #$output)))
                       (file2 (text-file* "file2"
                                          "the file => " file1)))
    (define (matching-profile item)
      (lambda (profile)
        (string=? item (profile-file profile))))

    (mbegin %store-monad
      (built-derivations (list file2))
      (mlet %store-monad ((profiles (store-profile
                                     (list (derivation->output-path file2))))
                          (bash     (interned-file
                                     (search-bootstrap-binary
                                      "bash" (%current-system)) "bash"
                                      #:recursive? #t))
                          (guile    (package->derivation %bootstrap-guile)))
        (define (lookup-profile item)
          (find (matching-profile (if (derivation? item)
                                      (derivation->output-path item)
                                      item))
                profiles))

        (letrec-syntax ((match* (syntax-rules (=>)
                                  ((_ ((drv => profile) rest ...) body)
                                   (match (lookup-profile drv)
                                     ((? profile? profile)
                                      (match* (rest ...) body))))
                                  ((_ () body)
                                   body))))
          ;; Make sure we get all three profiles with sensible values.
          (return (and (= (length profiles) 4)
                       (match* ((file1 => profile1)
                                (file2 => profile2)
                                (guile => profile3)
                                (bash  => profile4)) ;dependency of GUILE
                         (and (> (profile-closure-size profile2) 0)
                              (= (profile-closure-size profile2)
                                 (+ (profile-self-size profile1)
                                    (profile-self-size profile2)
                                    (profile-self-size profile3)
                                    (profile-self-size profile4))))))))))))

(test-assertm "store-profile with multiple items"
  (mlet* %store-monad ((file1 (gexp->derivation "file1"
                                                #~(symlink #$%bootstrap-guile
                                                           #$output)))
                       (file2 (text-file* "file2"
                                          "the file => " file1)))
    (mbegin %store-monad
      (built-derivations (list file2))
      (mlet %store-monad ((profiles  (store-profile
                                      (list (derivation->output-path file2)
                                            (derivation->output-path file1))))
                          (reference (store-profile
                                      (list (derivation->output-path file2)))))
        (return (and (= (length profiles) 4)
                     (lset= equal? profiles reference)))))))

(test-end "size")

;;; Local Variables:
;;; eval: (put 'match* 'scheme-indent-function 1)
;;; End:


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

(define-module (test-snix)
  #:use-module (guix import snix)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match))

(define %nixpkgs-directory
  (getenv "NIXPKGS"))

(define factorize-uri
  (@@ (guix import snix) factorize-uri))

(define-syntax-rule (every? proc lists ...)
  (not (not (every proc lists ...))))

(test-begin "snix")

(test-assert "factorize-uri"
  (every? (match-lambda
           ((uri version '-> expected)
            (equal? (factorize-uri uri version)
                    expected)))
          '(("http://example.com/foo.tgz" "1.0"
             -> "http://example.com/foo.tgz")
            ("http://example.com/foo-2.8.tgz" "2.8"
             -> ("http://example.com/foo-" version ".tgz"))
            ("http://example.com/2.8/foo-2.8.tgz" "2.8"
             -> ("http://example.com/" version "/foo-" version ".tgz")))))

(test-skip (if (and %nixpkgs-directory
                    (file-exists? (string-append %nixpkgs-directory
                                                 "/default.nix")))
               0
               1))

(test-assert "nixpkgs->guix-package"
  (match (nixpkgs->guix-package %nixpkgs-directory "guile")
    (('package
       ('name "guile")
       ('version (? string?))
       ('source ('origin _ ...))
       ('build-system _)
       ('inputs ('quasiquote (inputs ...)))
       ('propagated-inputs ('quasiquote (pinputs ...)))
       ('home-page (? string?))
       ('synopsis (? string?))
       ('description (? string?))
       ('license (? symbol?)))
     (and (member '("libffi" ,libffi) inputs)
          (member '("gmp" ,gmp) pinputs)
          #t))
    (x
     (pk 'fail x #f))))

(test-end "snix")


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

(define-module (test-status)
  #:use-module (guix status)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports))

(test-begin "status")

(test-equal "compute-status, no-op"
  (build-status)
  (let-values (((port get-status)
                (build-event-output-port compute-status)))
    (display "foo\nbar\n\baz\n" port)
    (get-status)))

(test-equal "compute-status, builds + substitutes"
  (list (build-status
         (building '("foo.drv"))
         (downloading (list (download "bar" "http://example.org/bar"
                                      #:size 500
                                      #:start 'now))))
        (build-status
         (building '("foo.drv"))
         (downloading (list (download "bar" "http://example.org/bar"
                                      #:size 500
                                      #:transferred 42
                                      #:start 'now))))
        (build-status
         (builds-completed '("foo.drv"))
         (downloads-completed (list (download "bar" "http://example.org/bar"
                                              #:size 500
                                              #:transferred 500
                                              #:start 'now
                                              #:end 'now)))))
  (let-values (((port get-status)
                (build-event-output-port (lambda (event status)
                                           (compute-status event status
                                                           #:current-time
                                                           (const 'now))))))
    (display "@ build-started foo.drv\n" port)
    (display "@ substituter-started bar\n" port)
    (display "@ download-started bar http://example.org/bar 500\n" port)
    (display "various\nthings\nget\nwritten\n" port)
    (let ((first (get-status)))
      (display "@ download-progress bar http://example.org/bar 500 42\n"
               port)
      (let ((second (get-status)))
        (display "@ download-progress bar http://example.org/bar 500 84\n"
                 port)
        (display "@ build-succeeded foo.drv\n" port)
        (display "@ download-succeeded bar http://example.org/bar 500\n" port)
        (display "Almost done!\n" port)
        (display "@ substituter-succeeded bar\n" port)
        (list first second (get-status))))))

(test-equal "compute-status, missing events"
  (list (build-status
         (building '("foo.drv"))
         (downloading (list (download "baz" "http://example.org/baz"
                                      #:size 500
                                      #:transferred 42
                                      #:start 'now)
                            (download "bar" "http://example.org/bar"
                                      #:size 999
                                      #:transferred 0
                                      #:start 'now))))
        (build-status
         (builds-completed '("foo.drv"))
         (downloads-completed (list (download "baz" "http://example.org/baz"
                                              #:size 500
                                              #:transferred 500
                                              #:start 'now
                                              #:end 'now)
                                    (download "bar" "http://example.org/bar"
                                              #:size 999
                                              #:transferred 999
                                              #:start 'now
                                              #:end 'now)))))
  ;; Below we omit 'substituter-started' events and the like.
  (let-values (((port get-status)
                (build-event-output-port (lambda (event status)
                                           (compute-status event status
                                                           #:current-time
                                                           (const 'now))))))
    (display "@ build-started foo.drv\n" port)
    (display "@ download-started bar http://example.org/bar 999\n" port)
    (display "various\nthings\nget\nwritten\n" port)
    (display "@ download-progress baz http://example.org/baz 500 42\n"
             port)
    (let ((first (get-status)))
      (display "@ build-succeeded foo.drv\n" port)
      (display "@ download-succeeded bar http://example.org/bar 999\n" port)
      (display "Almost done!\n" port)
      (display "@ substituter-succeeded baz\n" port)
      (list first (get-status)))))

(test-equal "build-output-port, UTF-8"
  '((build-log "lambda is λ!\n"))
  (let-values (((port get-status) (build-event-output-port cons '()))
               ((bv)              (string->utf8 "lambda is λ!\n")))
    (put-bytevector port bv)
    (force-output port)
    (get-status)))

(test-equal "current-build-output-port, UTF-8 + garbage"
  ;; What about a mixture of UTF-8 + garbage?
  '((build-log "garbage: �lambda: λ\n"))
  (let-values (((port get-status) (build-event-output-port cons '())))
    (display "garbage: " port)
    (put-bytevector port #vu8(128))
    (put-bytevector port (string->utf8 "lambda: λ\n"))
    (force-output port)
    (get-status)))

(test-end "status")


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

(define-module (test-store-database)
  #:use-module (guix tests)
  #:use-module (guix store)
  #:use-module (guix store database)
  #:use-module ((guix utils) #:select (call-with-temporary-output-file))
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64))

;; Test the (guix store database) module.

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

(test-begin "store-database")

(test-equal "register-path"
  '(1 1)
  (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f)
                             "-fake")))
    (when (valid-path? %store file)
      (delete-paths %store (list file)))
    (false-if-exception (delete-file file))

    (let ((ref (add-text-to-store %store "ref-of-fake" (random-text)))
          (drv (string-append file ".drv")))
      (call-with-output-file file
        (cut display "This is a fake store item.\n" <>))
      (register-path file
                     #:references (list ref)
                     #:deriver drv)

      (and (valid-path? %store file)
           (equal? (references %store file) (list ref))
           (null? (valid-derivers %store file))
           (null? (referrers %store file))
           (list (stat:mtime (lstat file))
                 (stat:mtime (lstat ref)))))))

(test-equal "new database"
  (list 1 2)
  (call-with-temporary-output-file
   (lambda (db-file port)
     (delete-file db-file)
     (with-database db-file db
       (sqlite-register db
                        #:path "/gnu/foo"
                        #:references '()
                        #:deriver "/gnu/foo.drv"
                        #:hash (string-append "sha256:" (make-string 64 #\e))
                        #:nar-size 1234)
       (sqlite-register db
                        #:path "/gnu/bar"
                        #:references '("/gnu/foo")
                        #:deriver "/gnu/bar.drv"
                        #:hash (string-append "sha256:" (make-string 64 #\a))
                        #:nar-size 4321)
       (let ((path-id (@@ (guix store database) path-id)))
         (list (path-id db "/gnu/foo")
               (path-id db "/gnu/bar")))))))

(test-assert "register-path with unregistered references"
  ;; Make sure we get a "NOT NULL constraint failed: Refs.reference" error
  ;; when we try to add references that are not registered yet.  Better safe
  ;; than sorry.
  (call-with-temporary-output-file
   (lambda (db-file port)
     (delete-file db-file)
     (catch 'sqlite-error
       (lambda ()
         (with-database db-file db
           (sqlite-register db #:path "/gnu/foo"
                            #:references '("/gnu/bar")
                            #:deriver "/gnu/foo.drv"
                            #:hash (string-append "sha256:" (make-string 64 #\e))
                            #:nar-size 1234))
         #f)
       (lambda args
         (pk 'welcome-exception! args)
         #t)))))

(test-end "store-database")


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

(define-module (test-store-deduplication)
  #:use-module (guix tests)
  #:use-module (guix store deduplication)
  #:use-module (gcrypt hash)
  #:use-module ((guix utils) #:select (call-with-temporary-directory))
  #:use-module (guix build utils)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 binary-ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64))

(test-begin "store-deduplication")

(test-equal "deduplicate"
  (cons* #t #f                                    ;inode comparisons
         2 (make-list 5 6))                       ;'nlink' values

  (call-with-temporary-directory
   (lambda (store)
     (let ((data      (string->utf8 "Hello, world!"))
           (identical (map (lambda (n)
                             (string-append store "/" (number->string n)
                                            "/a/b/c"))
                           (iota 5)))
           (unique    (string-append store "/unique")))
       (for-each (lambda (file)
                   (mkdir-p (dirname file))
                   (call-with-output-file file
                     (lambda (port)
                       (put-bytevector port data))))
                 identical)
       ;; Make the parent of IDENTICAL read-only.  This should not prevent
       ;; deduplication for inserting its hard link.
       (chmod (dirname (second identical)) #o544)

       (call-with-output-file unique
         (lambda (port)
           (put-bytevector port (string->utf8 "This is unique."))))

       (deduplicate store (nar-sha256 store) #:store store)

       ;; (system (string-append "ls -lRia " store))
       (cons* (apply = (map (compose stat:ino stat) identical))
              (= (stat:ino (stat unique))
                 (stat:ino (stat (car identical))))
              (stat:nlink (stat unique))
              (map (compose stat:nlink stat) identical))))))

(test-end "store-deduplication")