summary refs log tree commit diff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/gnu-maintenance.scm19
-rw-r--r--tests/go.scm139
-rw-r--r--tests/grafts.scm83
-rw-r--r--tests/ipfs.scm55
-rw-r--r--tests/publish.scm4
-rw-r--r--tests/substitute.scm4
6 files changed, 230 insertions, 74 deletions
diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm
index a3e48a0933..837b80063a 100644
--- a/tests/gnu-maintenance.scm
+++ b/tests/gnu-maintenance.scm
@@ -19,7 +19,8 @@
 (define-module (test-gnu-maintenance)
   #:use-module (guix gnu-maintenance)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-64))
+  #:use-module (srfi srfi-64)
+  #:use-module (ice-9 match))
 
 (test-begin "gnu-maintenance")
 
@@ -30,7 +31,10 @@
                 ("texmacs" "TeXmacs-1.0.7.9-src.tar.gz")
                 ("icecat" "icecat-38.4.0-gnu1.tar.bz2")
                 ("mit-scheme" "mit-scheme-9.2.tar.gz")
-                ("mediainfo" "mediainfo_20.09.tar.xz")))
+                ("mediainfo" "mediainfo_20.09.tar.xz")
+                ("exiv2" "exiv2-0.27.3-Source.tar.gz")
+                ("mpg321" "mpg321_0.3.2.orig.tar.gz")
+                ("bvi" "bvi-1.4.1.src.tar.gz")))
        (every (lambda (project+file)
                 (not (apply release-file? project+file)))
               '(("guile" "guile-www-1.1.1.tar.gz")
@@ -39,4 +43,15 @@
                 ("mit-scheme" "mit-scheme-9.2-doc-pdf.tar.gz")
                 ("gnutls" "gnutls-3.2.18-w32.zip")))))
 
+(test-assert "tarball->version"
+  (let ((tarball->version (@@ (guix gnu-maintenance) tarball->version)))
+    (every (match-lambda
+             ((file version)
+              (equal? (tarball->version file) version)))
+           '(("coreutils-8.32.tar.gz" "8.32")
+             ("mediainfo_20.09.tar.xz" "20.09")
+             ("exiv2-0.27.3-Source.tar.gz" "0.27.3")
+             ("mpg321_0.3.2.orig.tar.gz" "0.3.2")
+             ("bvi-1.4.1.src.tar.gz" "1.4.1")))))
+
 (test-end)
diff --git a/tests/go.scm b/tests/go.scm
index 6ab99f508a..e5780e68b0 100644
--- a/tests/go.scm
+++ b/tests/go.scm
@@ -19,7 +19,7 @@
 ;;; Summary
 ;; Tests for guix/import/go.scm
 
-(define-module (test-import-go)
+(define-module (tests-import-go)
   #:use-module (guix base32)
   #:use-module (guix build-system go)
   #:use-module (guix import go)
@@ -147,7 +147,8 @@ require github.com/kr/pretty v0.2.1
       ("https://pkg.go.dev/github.com/go-check/check"
        . ,pkg.go.dev)
       ("https://pkg.go.dev/github.com/go-check/check?tab=licenses"
-       . ,pkg.go.dev-licence))))
+       . ,pkg.go.dev-licence)
+      ("https://proxy.golang.org/github.com/go-check/check/@v/list" . ""))))
 
 (test-begin "go")
 
@@ -169,6 +170,12 @@ require github.com/kr/pretty v0.2.1
   "daa7c04131f5"
   (go-version->git-ref "v1.2.4-0.20191109021931-daa7c04131f5"))
 
+(test-assert "go-pseudo-version? multi-digit version number"
+  (go-pseudo-version? "v1.23.1-0.20200526195155-81db48ad09cc"))
+
+(test-assert "go-pseudo-version? semantic version with rc"
+  (go-pseudo-version? "v1.4.0-rc.4.0.20200313231945-b860323f09d0"))
+
 ;;; Unit tests for (guix import go)
 
 (test-equal "go-path-escape"
@@ -180,46 +187,43 @@ require github.com/kr/pretty v0.2.1
 (define (testing-parse-mod name expected input)
   (define (inf? p1 p2)
     (string<? (car p1) (car p2)))
-  (let ((input-port (open-input-string input)))
-    (test-equal name
-      (sort expected inf?)
-      (sort
-       ( (@@ (guix import go) parse-go.mod)
-         input-port)
-       inf?))))
+  (test-equal name
+    (sort expected inf?)
+    (sort ((@@ (guix import go) parse-go.mod) input) inf?)))
 
 (testing-parse-mod "parse-go.mod-simple"
-                   '(("good/thing" . "v1.4.5")
-                     ("new/thing/v2" . "v2.3.4")
-                     ("other/thing" . "v1.0.2"))
+                   '(("good/thing" "v1.4.5")
+                     ("new/thing/v2" "v2.3.4")
+                     ("other/thing" "v1.0.2"))
                    fixture-go-mod-simple)
 
 (testing-parse-mod "parse-go.mod-with-block"
-                   '(("A" . "v1")
-                     ("B" . "v1.0.0")
-                     ("C" . "v1.0.0")
-                     ("D" . "v1.2.3")
-                     ("E" . "dev"))
+                   '(("A" "v1")
+                     ("B" "v1.0.0")
+                     ("C" "v1.0.0")
+                     ("D" "v1.2.3")
+                     ("E" "dev"))
                    fixture-go-mod-with-block)
 
-(testing-parse-mod "parse-go.mod-complete"
-                   '(("github.com/corp/arbitrary-repo" . "v0.0.2")
-                     ("quoted.example.com/abitrary/repo" . "v0.0.2")
-                     ("one.example.com/abitrary/repo" . "v1.1.111")
-                     ("hub.jazz.net/git/user/project/sub/directory" . "v1.1.19")
-                     ("hub.jazz.net/git/user/project" . "v1.1.18")
-                     ("launchpad.net/~user/project/branch/sub/directory" . "v1.1.17")
-                     ("launchpad.net/~user/project/branch" . "v1.1.16")
-                     ("launchpad.net/project/series/sub/directory" . "v1.1.15")
-                     ("launchpad.net/project/series" . "v1.1.14")
-                     ("launchpad.net/project" . "v1.1.13")
-                     ("bitbucket.org/user/project/sub/directory" . "v1.11.21")
-                     ("bitbucket.org/user/project" . "v1.11.20")
-                     ("k8s.io/kubernetes/subproject" . "v1.1.101")
-                     ("github.com/user/project/sub/directory" . "v1.1.12")
-                     ("github.com/user/project" . "v1.1.11")
-                     ("github.com/go-check/check" . "v0.0.0-20140225173054-eb6ee6f84d0a"))
-                   fixture-go-mod-complete)
+(testing-parse-mod
+ "parse-go.mod-complete"
+ '(("github.com/corp/arbitrary-repo" "v0.0.2")
+   ("quoted.example.com/abitrary/repo" "v0.0.2")
+   ("one.example.com/abitrary/repo" "v1.1.111")
+   ("hub.jazz.net/git/user/project/sub/directory" "v1.1.19")
+   ("hub.jazz.net/git/user/project" "v1.1.18")
+   ("launchpad.net/~user/project/branch/sub/directory" "v1.1.17")
+   ("launchpad.net/~user/project/branch" "v1.1.16")
+   ("launchpad.net/project/series/sub/directory" "v1.1.15")
+   ("launchpad.net/project/series" "v1.1.14")
+   ("launchpad.net/project" "v1.1.13")
+   ("bitbucket.org/user/project/sub/directory" "v1.11.21")
+   ("bitbucket.org/user/project" "v1.11.20")
+   ("k8s.io/kubernetes/subproject" "v1.1.101")
+   ("github.com/user/project/sub/directory" "v1.1.12")
+   ("github.com/user/project" "v1.1.11")
+   ("github.com/go-check/check" "v0.0.0-20140225173054-eb6ee6f84d0a"))
+ fixture-go-mod-complete)
 
 ;;; End-to-end tests for (guix import go)
 (define (mock-http-fetch testcase)
@@ -249,44 +253,43 @@ require github.com/kr/pretty v0.2.1
 
 (test-equal "go-module->guix-package"
   '(package
-    (name "go-github-com-go-check-check")
-    (version "0.0.0-20201130134442-10cb98267c6c")
-    (source
-     (origin
-       (method git-fetch)
-       (uri (git-reference
-             (url "https://github.com/go-check/check.git")
-             (commit (go-version->git-ref version))))
-       (file-name (git-file-name name version))
-       (sha256
-        (base32
-         "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5"))))
-    (build-system go-build-system)
-    (arguments
-     (quote (#:import-path "github.com/go-check/check")))
-    (inputs
-     (quasiquote (("go-github-com-kr-pretty"
-                   (unquote go-github-com-kr-pretty)))))
-    (home-page "https://github.com/go-check/check")
-    (synopsis "Instructions")
-    (description #f)
-    (license license:bsd-2))
+     (name "go-github-com-go-check-check")
+     (version "0.0.0-20201130134442-10cb98267c6c")
+     (source
+      (origin
+        (method git-fetch)
+        (uri (git-reference
+              (url "https://github.com/go-check/check")
+              (commit (go-version->git-ref version))))
+        (file-name (git-file-name name version))
+        (sha256
+         (base32
+          "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5"))))
+     (build-system go-build-system)
+     (arguments
+      '(#:import-path "github.com/go-check/check"))
+     (propagated-inputs
+      `(("go-github-com-kr-pretty" ,go-github-com-kr-pretty)))
+     (home-page "https://github.com/go-check/check")
+     (synopsis "Instructions")
+     (description "Package check is a rich testing extension for Go's testing \
+package.")
+     (license license:bsd-2))
 
   ;; Replace network resources with sample data.
   (call-with-temporary-directory
    (lambda (checkout)
      (mock ((web client) http-get
             (mock-http-get fixtures-go-check-test))
-           (mock ((guix http-client) http-fetch
-                  (mock-http-fetch fixtures-go-check-test))
-                 (mock ((guix git) update-cached-checkout
-                        (lambda* (url #:key ref)
-                          ;; Return an empty directory and its hash.
-                          (values checkout
-                                  (nix-base32-string->bytevector
-                                   "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5")
-                                  #f)))
-                       (go-module->guix-package "github.com/go-check/check")))))))
+         (mock ((guix http-client) http-fetch
+                (mock-http-fetch fixtures-go-check-test))
+             (mock ((guix git) update-cached-checkout
+                    (lambda* (url #:key ref)
+                      ;; Return an empty directory and its hash.
+                      (values checkout
+                              (nix-base32-string->bytevector
+                               "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5")
+                              #f)))
+                 (go-module->guix-package "github.com/go-check/check")))))))
 
 (test-end "go")
-
diff --git a/tests/grafts.scm b/tests/grafts.scm
index a12c6a5911..7e1959e4a7 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -468,4 +469,86 @@
          replacement
          "/gnu/store")))))
 
+(define (insert-nuls char-size str)
+  (string-join (map string (string->list str))
+               (make-string (- char-size 1) #\nul)))
+
+(define (nuls-to-underscores s)
+  (string-replace-substring s "\0" "_"))
+
+(define (annotate-buffer-boundary s)
+  (string-append (string-take s buffer-size)
+                 "|"
+                 (string-drop s buffer-size)))
+
+(define (abbreviate-leading-fill s)
+  (let ((s* (string-trim s #\=)))
+    (format #f "[~a =s]~a"
+            (- (string-length s)
+               (string-length s*))
+            s*)))
+
+(define (prettify-for-display s)
+  (abbreviate-leading-fill
+   (annotate-buffer-boundary
+    (nuls-to-underscores s))))
+
+(define (two-sample-refs-with-gap char-size1 char-size2 gap offset
+                                  char1 name1 char2 name2)
+  (string-append
+   (make-string (- buffer-size offset) #\=)
+   (insert-nuls char-size1
+                (string-append "/gnu/store/" (make-string 32 char1) name1))
+   gap
+   (insert-nuls char-size2
+                (string-append "/gnu/store/" (make-string 32 char2) name2))
+   (list->string (map integer->char (iota 77 33)))))
+
+(define (sample-map-entry old-char new-char new-name)
+  (cons (make-string 32 old-char)
+        (string->utf8 (string-append (make-string 32 new-char)
+                                     new-name))))
+
+(define (test-two-refs-with-gap char-size1 char-size2 gap offset)
+  (test-equal
+      (format #f "test-two-refs-with-gap, char-sizes ~a ~a, gap ~s, offset ~a"
+              char-size1 char-size2 gap offset)
+    (prettify-for-display
+     (two-sample-refs-with-gap char-size1 char-size2 gap offset
+                               #\6 "-BlahBlaH"
+                               #\8"-SoMeTHiNG"))
+    (prettify-for-display
+     (let* ((content (two-sample-refs-with-gap char-size1 char-size2 gap offset
+                                               #\5 "-blahblah"
+                                               #\7 "-something"))
+            (replacement (alist->vhash
+                          (list (sample-map-entry #\5 #\6 "-BlahBlaH")
+                                (sample-map-entry #\7 #\8 "-SoMeTHiNG")))))
+       (call-with-output-string
+         (lambda (output)
+           ((@@ (guix build graft) replace-store-references)
+            (open-input-string content) output
+            replacement
+            "/gnu/store")))))))
+
+(for-each (lambda (char-size1)
+            (for-each (lambda (char-size2)
+                        (for-each (lambda (gap)
+                                    (for-each (lambda (offset)
+                                                (test-two-refs-with-gap char-size1
+                                                                        char-size2
+                                                                        gap
+                                                                        offset))
+                                              ;; offsets to test
+                                              (map (lambda (i)
+                                                     (+ i (* 40 char-size1)))
+                                                   (iota 30))))
+                                  ;; gaps
+                                  '("" "-" " " "a")))
+                      ;; char-size2 values to test
+                      '(1 2)))
+          ;; char-size1 values to test
+          '(1 2 4))
+
+
 (test-end)
diff --git a/tests/ipfs.scm b/tests/ipfs.scm
new file mode 100644
index 0000000000..3b662b22bd
--- /dev/null
+++ b/tests/ipfs.scm
@@ -0,0 +1,55 @@
+;;; 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-ipfs)
+  #:use-module (guix ipfs)
+  #:use-module ((guix utils) #:select (call-with-temporary-directory))
+  #:use-module (guix tests)
+  #:use-module (web uri)
+  #:use-module (srfi srfi-64))
+
+;; Test the (guix ipfs) module.
+
+(define (ipfs-gateway-running?)
+  "Return true if the IPFS gateway is running at %IPFS-BASE-URL."
+  (let* ((uri    (string->uri (%ipfs-base-url)))
+         (socket (socket AF_INET SOCK_STREAM 0)))
+    (define connected?
+      (catch 'system-error
+        (lambda ()
+          (format (current-error-port)
+                  "probing IPFS gateway at localhost:~a...~%"
+                  (uri-port uri))
+          (connect socket AF_INET INADDR_LOOPBACK (uri-port uri))
+          #t)
+        (const #f)))
+
+    (close-port socket)
+    connected?))
+
+(unless (ipfs-gateway-running?)
+  (test-skip 1))
+
+(test-assert "add-file-tree + restore-file-tree"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (let* ((source  (dirname (search-path %load-path "guix/base32.scm")))
+            (target  (string-append directory "/r"))
+            (content (pk 'content (add-file-tree source))))
+       (restore-file-tree (content-name content) target)
+       (file=? source target)))))
diff --git a/tests/publish.scm b/tests/publish.scm
index 52101876b5..3e67c435ac 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -452,8 +452,8 @@ References: ~%"
               (wait-for-file cached)
 
               ;; Both the narinfo and nar should be world-readable.
-              (= #o644 (stat:perms (lstat cached)))
-              (= #o644 (stat:perms (lstat nar)))
+              (= #o444 (logand #o444 (stat:perms (lstat cached))))
+              (= #o444 (logand #o444 (stat:perms (lstat nar))))
 
               (let* ((body         (http-get-port url))
                      (compressed   (http-get nar-url))
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 697abc4684..21b513e1d8 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, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -198,7 +198,7 @@ a file for NARINFO."
 
 ;; Never use file descriptor 4, unlike what happens when invoked by the
 ;; daemon.
-(%error-to-file-descriptor-4? #f)
+(%reply-file-descriptor #f)
 
 
 (test-equal "query narinfo without signature"