Merge branch 'master' into core-updates

5 files changed, 264 insertions, 78 deletions

diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh
index b44aca099d..30b21028aa 100644
--- a/tests/guix-environment.sh
+++ b/tests/guix-environment.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -118,6 +118,18 @@ fi
 # in its profile (e.g., for 'gzip'), but we have to accept them.
 guix environment guix --bootstrap -n
 
+# Try program transformation options.
+mkdir "$tmpdir/emacs-36.8"
+drv="`guix environment --ad-hoc emacs -n 2>&1 | grep 'emacs.*\.drv'`"
+transformed_drv="`guix environment --ad-hoc emacs --with-source="$tmpdir/emacs-36.8" -n 2>&1 | grep 'emacs.*\.drv'`"
+test -n "$drv"
+test "$drv" != "$transformed_drv"
+case "$transformed_drv" in
+    *-emacs-36.8.drv) true;;
+    *)                false;;
+esac
+rmdir "$tmpdir/emacs-36.8"
+
 if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null
 then
     # Compute the build environment for the initial GNU Make.
diff --git a/tests/opam.scm b/tests/opam.scm
index a1320abfdc..e0ec5ef3d4 100644
--- a/tests/opam.scm
+++ b/tests/opam.scm
@@ -21,98 +21,177 @@
   #:use-module (guix base32)
   #:use-module (gcrypt hash)
   #:use-module (guix tests)
+  #:use-module ((guix build syscalls) #:select (mkdtemp!))
   #:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which))
+  #:use-module ((guix utils) #:select (call-with-temporary-output-file))
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
   #:use-module (web uri)
-  #:use-module (ice-9 match))
-
-(define test-url-file
-  "http: \"https://example.org/foo-1.0.0.tar.gz\"
-checksum: \"ac8920f39a8100b94820659bc2c20817\"")
-
-(define test-source-hash
-  "")
-
-(define test-urls
-  "repo ac8920f39a8100b94820659bc2c20817 0o644
-packages/foo/foo.1.0.0/url ac8920f39a8100b94820659bc2c20817 0o644
-packages/foo/foo.1.0.0/opam ac8920f39a8100b94820659bc2c20817 0o644
-packages/foo/foo.1.0.0/descr ac8920f39a8100b94820659bc2c20817 0o644")
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 peg))
 
 (define test-opam-file
-"opam-version: 1.2
+"opam-version: \"2.0\"
+  version: \"1.0.0\"
 maintainer: \"Alice Doe\"
-authors: \"Alice Doe, John Doe\"
+authors: [
+  \"Alice Doe\"
+  \"John Doe\"
+]
 homepage: \"https://example.org/\"
 bug-reports: \"https://example.org/bugs\"
-license: \"MIT\"
 dev-repo: \"https://example.org/git\"
 build: [
-  \"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\"
+  [\"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\"]
 ]
 build-test: [
-  \"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\" \"--tests\" \"true\"
+  [\"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\" \"--tests\" \"true\"]
 ]
 depends: [
   \"alcotest\" {test & >= \"0.7.2\"}
   \"ocamlbuild\" {build & >= \"0.9.2\"}
-]")
+  \"zarith\" {>= \"0.7\"}
+]
+synopsis: \"Some example package\"
+description: \"\"\"
+This package is just an example.\"\"\"
+url {
+  src: \"https://example.org/foo-1.0.0.tar.gz\"
+  checksum: \"md5=74c6e897658e820006106f45f736381f\"
+}")
+
+(define test-source-hash
+  "")
+
+(define test-repo
+  (mkdtemp! "/tmp/opam-repo.XXXXXX"))
 
 (test-begin "opam")
 
 (test-assert "opam->guix-package"
-  ;; Replace network resources with sample data.
-    (mock ((guix import utils) url-fetch
-           (lambda (url file-name)
-             (match url
-               ("https://example.org/foo-1.0.0.tar.gz"
-                (begin
-                  (mkdir-p "foo-1.0.0")
-                  (system* "tar" "czvf" file-name "foo-1.0.0/")
-                  (delete-file-recursively "foo-1.0.0")
-                  (set! test-source-hash
-                    (call-with-input-file file-name port-sha256))))
-               (_ (error "Unexpected URL: " url)))))
-          (mock ((guix http-client) http-fetch/cached
-                 (lambda (url . rest)
-                   (match (uri->string url)
-                     ("https://opam.ocaml.org/urls.txt"
-                      (values (open-input-string test-urls)
-                              (string-length test-urls)))
-                     (_ (error "Unexpected URL: " url)))))
-                (mock ((guix http-client) http-fetch
-                       (lambda (url . rest)
-                         (match url
-                           ("https://opam.ocaml.org/packages/foo/foo.1.0.0/url"
-                            (values (open-input-string test-url-file)
-                                    (string-length test-url-file)))
-                           ("https://opam.ocaml.org/packages/foo/foo.1.0.0/opam"
-                            (values (open-input-string test-opam-file)
-                                    (string-length test-opam-file)))
-                           (_ (error "Unexpected URL: " url)))))
-                      (match (opam->guix-package "foo")
-                        (('package
-                           ('name "ocaml-foo")
-                           ('version "1.0.0")
-                           ('source ('origin
-                                      ('method 'url-fetch)
-                                      ('uri "https://example.org/foo-1.0.0.tar.gz")
-                                      ('sha256
-                                       ('base32
-                                        (? string? hash)))))
-                           ('build-system 'ocaml-build-system)
-                           ('inputs
-                            ('quasiquote
-                             (("ocamlbuild" ('unquote 'ocamlbuild))
-                              ("ocaml-alcotest" ('unquote 'ocaml-alcotest)))))
-                           ('home-page "https://example.org/")
-                           ('synopsis "")
-                           ('description "")
-                           ('license 'license:expat))
-                         (string=? (bytevector->nix-base32-string
-                                    test-source-hash)
-                                   hash))
-                        (x
-                         (pk 'fail x #f)))))))
+  (mock ((guix import utils) url-fetch
+         (lambda (url file-name)
+           (match url
+             ("https://example.org/foo-1.0.0.tar.gz"
+              (begin
+                (mkdir-p "foo-1.0.0")
+                (system* "tar" "czvf" file-name "foo-1.0.0/")
+                (delete-file-recursively "foo-1.0.0")
+                (set! test-source-hash
+                  (call-with-input-file file-name port-sha256))))
+             (_ (error "Unexpected URL: " url)))))
+      (let ((my-package (string-append test-repo "/packages/foo/foo.1.0.0")))
+        (mkdir-p my-package)
+        (with-output-to-file (string-append my-package "/opam")
+          (lambda _
+            (format #t "~a" test-opam-file))))
+      (mock ((guix import opam) get-opam-repository
+             (lambda _
+               test-repo))
+        (match (opam->guix-package "foo")
+          (('package
+             ('name "ocaml-foo")
+             ('version "1.0.0")
+             ('source ('origin
+                        ('method 'url-fetch)
+                        ('uri "https://example.org/foo-1.0.0.tar.gz")
+                        ('sha256
+                         ('base32
+                          (? string? hash)))))
+             ('build-system 'ocaml-build-system)
+             ('inputs
+              ('quasiquote
+               (("ocaml-zarith" ('unquote 'ocaml-zarith)))))
+             ('native-inputs
+              ('quasiquote
+               (("ocaml-alcotest" ('unquote 'ocaml-alcotest))
+                ("ocamlbuild" ('unquote 'ocamlbuild)))))
+             ('home-page "https://example.org/")
+             ('synopsis "Some example package")
+             ('description "This package is just an example.")
+             ('license #f))
+           (string=? (bytevector->nix-base32-string
+                      test-source-hash)
+                     hash))
+          (x
+           (pk 'fail x #f))))))
+
+;; Test the opam file parser
+;; We fold over some test cases. Each case is a pair of the string to parse and the
+;; expected result.
+(test-assert "parse-strings"
+  (fold (lambda (test acc)
+          (display test) (newline)
+          (and acc
+               (let ((result (peg:tree (match-pattern (@@ (guix import opam) string-pat) (car test)))))
+                 (if (equal? result (cdr test))
+                   #t
+                   (pk 'fail (list (car test) result (cdr test)) #f)))))
+    #t '(("" . #f)
+         ("\"hello\"" . (string-pat "hello"))
+         ("\"hello world\"" . (string-pat "hello world"))
+         ("\"The dreaded \\\"é\\\"\"" . (string-pat "The dreaded \"é\""))
+         ("\"Have some \\\\\\\\ :)\"" . (string-pat "Have some \\\\ :)"))
+         ("\"今日は\"" . (string-pat "今日は")))))
+
+(test-assert "parse-multiline-strings"
+  (fold (lambda (test acc)
+          (display test) (newline)
+          (and acc
+               (let ((result (peg:tree (match-pattern (@@ (guix import opam) multiline-string) (car test)))))
+                 (if (equal? result (cdr test))
+                   #t
+                   (pk 'fail (list (car test) result (cdr test)) #f)))))
+    #t '(("" . #f)
+         ("\"\"\"hello\"\"\"" . (multiline-string "hello"))
+         ("\"\"\"hello \"world\"!\"\"\"" . (multiline-string "hello \"world\"!"))
+         ("\"\"\"hello \"\"world\"\"!\"\"\"" . (multiline-string "hello \"\"world\"\"!")))))
+
+(test-assert "parse-lists"
+  (fold (lambda (test acc)
+          (and acc
+               (let ((result (peg:tree (match-pattern (@@ (guix import opam) list-pat) (car test)))))
+                 (if (equal? result (cdr test))
+                   #t
+                   (pk 'fail (list (car test) result (cdr test)) #f)))))
+    #t '(("" . #f)
+         ("[]" . list-pat)
+         ("[make]" . (list-pat (var "make")))
+         ("[\"make\"]" . (list-pat (string-pat "make")))
+         ("[\n  a\n  b\n  c]" . (list-pat (var "a") (var "b") (var "c")))
+         ("[a   b     \"c\"]" . (list-pat (var "a") (var "b") (string-pat "c"))))))
+
+(test-assert "parse-dicts"
+  (fold (lambda (test acc)
+          (and acc
+               (let ((result (peg:tree (match-pattern (@@ (guix import opam) dict) (car test)))))
+                 (if (equal? result (cdr test))
+                   #t
+                   (pk 'fail (list (car test) result (cdr test)) #f)))))
+    #t '(("" . #f)
+         ("{}" . dict)
+         ("{a: \"b\"}" . (dict (record "a" (string-pat "b"))))
+         ("{a: \"b\"\nc: \"d\"}" . (dict (record "a" (string-pat "b")) (record "c" (string-pat "d")))))))
+
+(test-assert "parse-conditions"
+  (fold (lambda (test acc)
+          (and acc
+               (let ((result (peg:tree (match-pattern (@@ (guix import opam) condition) (car test)))))
+                 (if (equal? result (cdr test))
+                   #t
+                   (pk 'fail (list (car test) result (cdr test)) #f)))))
+    #t '(("" . #f)
+         ("{}" . #f)
+         ("{build}" . (condition-var "build"))
+         ("{>= \"0.2.0\"}" . (condition-greater-or-equal
+                               (condition-string "0.2.0")))
+         ("{>= \"0.2.0\" & test}" . (condition-and
+                                      (condition-greater-or-equal
+                                        (condition-string "0.2.0"))
+                                      (condition-var "test")))
+         ("{>= \"0.2.0\" | build}" . (condition-or
+                                      (condition-greater-or-equal
+                                        (condition-string "0.2.0"))
+                                      (condition-var "build"))))))
 
 (test-end "opam")
diff --git a/tests/publish.scm b/tests/publish.scm
index 0e793c1ee5..79a786e723 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -411,10 +411,12 @@ FileSize: ~a~%"
                                (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/…
@@ -423,7 +425,7 @@ FileSize: ~a~%"
        (let ((thread (with-separate-output-ports
                       (call-with-new-thread
                        (lambda ()
-                         (guix-publish "--port=6796" "-C2"
+                         (guix-publish "--port=6796" "-C2" "--ttl=42h"
                                        (string-append "--cache=" cache)))))))
          (wait-until-ready 6796)
          (let* ((base     "http://localhost:6796/")
@@ -437,13 +439,19 @@ FileSize: ~a~%"
            (and (= 404 (response-code response))
 
                 (wait-for-file cached)
-                (let* ((body         (http-get-port url))
+                (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)
@@ -452,6 +460,11 @@ FileSize: ~a~%"
                                     (_ #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))))))))))
diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm
index e438aa84c6..e2870a363d 100644
--- a/tests/store-deduplication.scm
+++ b/tests/store-deduplication.scm
@@ -48,7 +48,7 @@
                        (put-bytevector port data))))
                  identical)
        ;; Make the parent of IDENTICAL read-only.  This should not prevent
-       ;; deduplication for inserting its hard link.
+       ;; deduplication from inserting its hard link.
        (chmod (dirname (second identical)) #o544)
 
        (call-with-output-file unique
@@ -64,4 +64,46 @@
               (stat:nlink (stat unique))
               (map (compose stat:nlink stat) identical))))))
 
+(test-equal "deduplicate, ENOSPC"
+  (cons* #f                                       ;inode comparison
+         (append (make-list 3 4)
+                 (make-list 7 1)))                ;'nlink' values
+
+  ;; In this scenario the first 3 files are properly deduplicated and then we
+  ;; simulate a full '.links' directory where link(2) gets ENOSPC, thereby
+  ;; preventing deduplication of the subsequent files.
+  (call-with-temporary-directory
+   (lambda (store)
+     (let ((true-link link)
+           (links     0)
+           (data1     (string->utf8 "Hello, world!"))
+           (data2     (string->utf8 "Hi, world!"))
+           (identical (map (lambda (n)
+                             (string-append store "/" (number->string n)
+                                            "/a/b/c"))
+                           (iota 10)))
+           (populate  (lambda (data)
+                        (lambda (file)
+                          (mkdir-p (dirname file))
+                          (call-with-output-file file
+                            (lambda (port)
+                              (put-bytevector port data)))))))
+       (for-each (populate data1) (take identical 5))
+       (for-each (populate data2) (drop identical 5))
+       (dynamic-wind
+         (lambda ()
+           (set! link (lambda (old new)
+                        (set! links (+ links 1))
+                        (if (<= links 3)
+                            (true-link old new)
+                            (throw 'system-error "link" "~A" '("Whaaat?!")
+                                   (list ENOSPC))))))
+         (lambda ()
+           (deduplicate store (nar-sha256 store) #:store store))
+         (lambda ()
+           (set! link true-link)))
+
+       (cons (apply = (map (compose stat:ino stat) identical))
+             (map (compose stat:nlink stat) identical))))))
+
 (test-end "store-deduplication")
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 964a57f30b..f4f2e9512d 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
-;;; Copyright © 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -211,6 +211,46 @@ a file for NARINFO."
            (lambda ()
              (guix-substitute "--query"))))))))
 
+(test-equal "query narinfo with signature over nothing"
+  ;; The signature is computed over the empty string, not over the important
+  ;; parts, so the narinfo must be ignored.
+  ""
+
+  (with-narinfo (string-append "Signature: " (signature-field "") "\n"
+                                %narinfo "\n")
+    (string-trim-both
+     (with-output-to-string
+       (lambda ()
+         (with-input-from-string (string-append "have " (%store-prefix)
+                                                "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+           (lambda ()
+             (guix-substitute "--query"))))))))
+
+(test-equal "query narinfo with signature over irrelevant bits"
+  ;; The signature is valid but it does not cover the
+  ;; StorePath/NarHash/References tuple and is thus irrelevant; the narinfo
+  ;; must be ignored.
+  ""
+
+  (let ((prefix (string-append "StorePath: " (%store-prefix)
+                               "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
+URL: example.nar
+Compression: none\n")))
+    (with-narinfo (string-append prefix
+                                 "Signature: " (signature-field prefix) "
+NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
+NarSize: 42
+References: bar baz
+Deriver: " (%store-prefix) "/foo.drv
+System: mips64el-linux\n")
+      (string-trim-both
+       (with-output-to-string
+         (lambda ()
+           (with-input-from-string (string-append "have " (%store-prefix)
+                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+             (lambda ()
+               (guix-substitute "--query")))))))))
+
 (test-equal "query narinfo signed with authorized key"
   (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")