From bacfec8611530dc3e849fb804b51f50b299796f0 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 15 Jul 2019 16:14:31 +0200
Subject: linux-container: Add 'eval/container'.

* gnu/system/linux-container.scm (eval/container): New procedure.
* tests/containers.scm ("eval/container, exit status")
("eval/container, writable user mapping"): New tests.
---
 tests/containers.scm | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 50 insertions(+)

(limited to 'tests')

diff --git a/tests/containers.scm b/tests/containers.scm
index 37408f380d..c6c738f234 100644
--- a/tests/containers.scm
+++ b/tests/containers.scm
@@ -21,7 +21,15 @@
   #:use-module (guix utils)
   #:use-module (guix build syscalls)
   #:use-module (gnu build linux-container)
+  #:use-module ((gnu system linux-container)
+                #:select (eval/container))
   #:use-module (gnu system file-systems)
+  #:use-module (guix store)
+  #:use-module (guix monads)
+  #:use-module (guix gexp)
+  #:use-module (guix derivations)
+  #:use-module (guix tests)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match))
 
@@ -219,4 +227,46 @@
     (lambda ()
       (* 6 7))))
 
+(skip-if-unsupported)
+(test-equal "eval/container, exit status"
+  42
+  (let* ((store  (open-connection-for-tests))
+         (status (run-with-store store
+                   (eval/container #~(exit 42)))))
+    (close-connection store)
+    (status:exit-val status)))
+
+(skip-if-unsupported)
+(test-assert "eval/container, writable user mapping"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (define store
+       (open-connection-for-tests))
+     (define result
+       (string-append directory "/r"))
+     (define requisites*
+       (store-lift requisites))
+
+     (call-with-output-file result (const #t))
+     (run-with-store store
+       (mlet %store-monad ((status (eval/container
+                                    #~(begin
+                                        (use-modules (ice-9 ftw))
+                                        (call-with-output-file "/result"
+                                          (lambda (port)
+                                            (write (scandir #$(%store-prefix))
+                                                   port))))
+                                    #:mappings
+                                    (list (file-system-mapping
+                                           (source result)
+                                           (target "/result")
+                                           (writable? #t)))))
+                           (reqs   (requisites*
+                                    (list (derivation->output-path
+                                           (%guile-for-build))))))
+         (close-connection store)
+         (return (and (zero? (pk 'status status))
+                      (lset= string=? (cons* "." ".." (map basename reqs))
+                             (pk (call-with-input-file result read))))))))))
+
 (test-end)
-- 
cgit v1.2.3


From 45b903323e0fecb7947926d2c14103d47fea624a Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 17 Jul 2019 00:04:41 +0200
Subject: channels: Strictly check the version of '.guix-channel'.

Until now the 'version' field in '.guix-channel' could be omitted, or it
could be any value.

* guix/channels.scm (read-channel-metadata): Rename to...
(channel-instance-metadata): ... this.
(channel-instance-dependencies): Adjust accordingly.
(read-channel-metadata): New procedure.  Use 'match'
to require a 'version' field.  Provide proper error handling when the
channel sexp is malformed or when given an unsupported version number.
(read-channel-metadata-from-source): Use 'catch' and
'system-error-errno' instead of 'file-exists?'.
* tests/channels.scm (instance--unsupported-version): New variable.
(read-channel-metadata): Rename to...
(channel-instance-metadata): ... this.  Rename tests accordingly.
("channel-instance-metadata rejects unsupported version"): New test.
---
 guix/channels.scm  | 71 ++++++++++++++++++++++++++++++++++++------------------
 tests/channels.scm | 29 ++++++++++++++++------
 2 files changed, 68 insertions(+), 32 deletions(-)

(limited to 'tests')

diff --git a/guix/channels.scm b/guix/channels.scm
index bfe6963418..e92148abf2 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -121,32 +121,55 @@
     (#f      `(branch . ,(channel-branch channel)))
     (commit  `(commit . ,(channel-commit channel)))))
 
+(define (read-channel-metadata port)
+  "Read from PORT channel metadata in the format expected for the
+'.guix-channel' file.  Return a <channel-metadata> record, or raise an error
+if valid metadata could not be read from PORT."
+  (match (read port)
+    (('channel ('version 0) properties ...)
+     (let ((directory    (and=> (assoc-ref properties 'directory) first))
+           (dependencies (or (assoc-ref properties 'dependencies) '())))
+       (channel-metadata
+        version
+        directory
+        (map (lambda (item)
+               (let ((get (lambda* (key #:optional default)
+                            (or (and=> (assoc-ref item key) first) default))))
+                 (and-let* ((name (get 'name))
+                            (url (get 'url))
+                            (branch (get 'branch "master")))
+                   (channel
+                    (name name)
+                    (branch branch)
+                    (url url)
+                    (commit (get 'commit))))))
+             dependencies))))
+    ((and ('channel ('version version) _ ...) sexp)
+     (raise (condition
+             (&message (message "unsupported '.guix-channel' version"))
+             (&error-location
+              (location (source-properties->location
+                         (source-properties sexp)))))))
+    (sexp
+     (raise (condition
+             (&message (message "invalid '.guix-channel' file"))
+             (&error-location
+              (location (source-properties->location
+                         (source-properties sexp)))))))))
+
 (define (read-channel-metadata-from-source source)
   "Return a channel-metadata record read from channel's SOURCE/.guix-channel
 description file, or return #F if SOURCE/.guix-channel does not exist."
-  (let ((meta-file (string-append source "/.guix-channel")))
-    (and (file-exists? meta-file)
-         (let* ((raw (call-with-input-file meta-file read))
-                (version (and=> (assoc-ref raw 'version) first))
-                (directory (and=> (assoc-ref raw 'directory) first))
-                (dependencies (or (assoc-ref raw 'dependencies) '())))
-           (channel-metadata
-            version
-            directory
-            (map (lambda (item)
-                   (let ((get (lambda* (key #:optional default)
-                                (or (and=> (assoc-ref item key) first) default))))
-                     (and-let* ((name (get 'name))
-                                (url (get 'url))
-                                (branch (get 'branch "master")))
-                       (channel
-                        (name name)
-                        (branch branch)
-                        (url url)
-                        (commit (get 'commit))))))
-                 dependencies))))))
-
-(define (read-channel-metadata instance)
+  (catch 'system-error
+    (lambda ()
+      (call-with-input-file (string-append source "/.guix-channel")
+        read-channel-metadata))
+    (lambda args
+      (if (= ENOENT (system-error-errno args))
+          #f
+          (apply throw args)))))
+
+(define (channel-instance-metadata instance)
   "Return a channel-metadata record read from the channel INSTANCE's
 description file, or return #F if the channel instance does not include the
 file."
@@ -155,7 +178,7 @@ file."
 (define (channel-instance-dependencies instance)
   "Return the list of channels that are declared as dependencies for the given
 channel INSTANCE."
-  (match (read-channel-metadata instance)
+  (match (channel-instance-metadata instance)
     (#f '())
     (($ <channel-metadata> version directory dependencies)
      dependencies)))
diff --git a/tests/channels.scm b/tests/channels.scm
index 8540aef435..1f1357fca7 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -26,8 +26,12 @@
   #:use-module (guix derivations)
   #:use-module (guix sets)
   #:use-module (guix gexp)
+  #:use-module ((guix utils)
+                #:select (error-location? error-location location-line))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match))
 
@@ -46,6 +50,9 @@
                               #:name name))
 
 (define instance--boring (make-instance))
+(define instance--unsupported-version
+  (make-instance #:spec
+                 '(channel (version 42) (dependencies whatever))))
 (define instance--no-deps
   (make-instance #:spec
                  '(channel
@@ -78,24 +85,30 @@
                      (name test-channel)
                      (url "https://example.com/test-channel-elsewhere"))))))
 
-(define read-channel-metadata
-  (@@ (guix channels) read-channel-metadata))
+(define channel-instance-metadata
+  (@@ (guix channels) channel-instance-metadata))
 
 
-(test-equal "read-channel-metadata returns #f if .guix-channel does not exist"
+(test-equal "channel-instance-metadata returns #f if .guix-channel does not exist"
   #f
-  (read-channel-metadata instance--boring))
+  (channel-instance-metadata instance--boring))
+
+(test-equal "channel-instance-metadata rejects unsupported version"
+  1                              ;line number in the generated '.guix-channel'
+  (guard (c ((and (message-condition? c) (error-location? c))
+             (location-line (error-location c))))
+    (channel-instance-metadata instance--unsupported-version)))
 
-(test-assert "read-channel-metadata returns <channel-metadata>"
+(test-assert "channel-instance-metadata returns <channel-metadata>"
   (every (@@ (guix channels) channel-metadata?)
-         (map read-channel-metadata
+         (map channel-instance-metadata
               (list instance--no-deps
                     instance--simple
                     instance--with-dupes))))
 
-(test-assert "read-channel-metadata dependencies are channels"
+(test-assert "channel-instance-metadata dependencies are channels"
   (let ((deps ((@@ (guix channels) channel-metadata-dependencies)
-               (read-channel-metadata instance--simple))))
+               (channel-instance-metadata instance--simple))))
     (match deps
       (((? channel? dep)) #t)
       (_ #f))))
-- 
cgit v1.2.3


From ce5d9ec875156f3de7479e861731edf48c984c16 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 17 Jul 2019 00:41:10 +0200
Subject: channels: Always provide a <channel-metadata> record.

This simplifies the code since one no longer needs to think about
whether '.guix-channel' was present.

* guix/channels.scm (read-channel-metadata): Always pass a string as the
first argument to 'channel-metadata'.
(read-channel-metadata-from-source): Always return a <channel-metadata>
record.
(channel-instance-dependencies): Remove now unneeded 'match'.
(standard-module-derivation): Assume DIRECTORY is never #f and contains
a leading slash.
* tests/channels.scm (channel-metadata-directory)
(channel-metadata-dependencies): New procedures.
("channel-instance-metadata returns #f if .guix-channel does not
exist"): Remove.
("channel-instance-metadata returns default if .guix-channel does not
exist"): New test.
(make-instance): Use 'write' instead of 'display' when creating
'.guix-channel'.
(instance--no-deps): Remove dependencies.
(instance--sub-directory): New variable.
("channel-instance-metadata and default dependencies")
("channel-instance-metadata and directory"): New tests.
("latest-channel-instances excludes duplicate channel dependencies"):
Expect 'channel-commit' to return a string and adjust accordingly.
---
 guix/channels.scm  | 27 ++++++++++++---------------
 tests/channels.scm | 45 +++++++++++++++++++++++++++++----------------
 2 files changed, 41 insertions(+), 31 deletions(-)

(limited to 'tests')

diff --git a/guix/channels.scm b/guix/channels.scm
index 87ad729a70..415246cbd1 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -110,8 +110,8 @@
 (define-record-type <channel-metadata>
   (channel-metadata directory dependencies)
   channel-metadata?
-  (directory     channel-metadata-directory)
-  (dependencies  channel-metadata-dependencies))
+  (directory     channel-metadata-directory)      ;string with leading slash
+  (dependencies  channel-metadata-dependencies))  ;list of <channel>
 
 (define (channel-reference channel)
   "Return the \"reference\" for CHANNEL, an sexp suitable for
@@ -129,7 +129,9 @@ if valid metadata could not be read from PORT."
      (let ((directory    (and=> (assoc-ref properties 'directory) first))
            (dependencies (or (assoc-ref properties 'dependencies) '())))
        (channel-metadata
-        directory
+        (cond ((not directory) "/")
+              ((string-prefix? "/" directory) directory)
+              (else (string-append "/" directory)))
         (map (lambda (item)
                (let ((get (lambda* (key #:optional default)
                             (or (and=> (assoc-ref item key) first) default))))
@@ -157,29 +159,26 @@ if valid metadata could not be read from PORT."
 
 (define (read-channel-metadata-from-source source)
   "Return a channel-metadata record read from channel's SOURCE/.guix-channel
-description file, or return #F if SOURCE/.guix-channel does not exist."
+description file, or return the default channel-metadata record if that file
+doesn't exist."
   (catch 'system-error
     (lambda ()
       (call-with-input-file (string-append source "/.guix-channel")
         read-channel-metadata))
     (lambda args
       (if (= ENOENT (system-error-errno args))
-          #f
+          (channel-metadata "/" '())
           (apply throw args)))))
 
 (define (channel-instance-metadata instance)
   "Return a channel-metadata record read from the channel INSTANCE's
-description file, or return #F if the channel instance does not include the
-file."
+description file or its default value."
   (read-channel-metadata-from-source (channel-instance-checkout instance)))
 
 (define (channel-instance-dependencies instance)
   "Return the list of channels that are declared as dependencies for the given
 channel INSTANCE."
-  (match (channel-instance-metadata instance)
-    (#f '())
-    (($ <channel-metadata> directory dependencies)
-     dependencies)))
+  (channel-metadata-dependencies (channel-instance-metadata instance)))
 
 (define* (latest-channel-instances store channels #:optional (previous-channels '()))
   "Return a list of channel instances corresponding to the latest checkouts of
@@ -261,7 +260,7 @@ objects.  The assumption is that SOURCE contains package modules to be added
 to '%package-module-path'."
 
   (let* ((metadata (read-channel-metadata-from-source source))
-         (directory (and=> metadata channel-metadata-directory)))
+         (directory (channel-metadata-directory metadata)))
 
     (define build
       ;; This is code that we'll run in CORE, a Guix instance, with its own
@@ -281,9 +280,7 @@ to '%package-module-path'."
               (string-append #$output "/share/guile/site/"
                              (effective-version)))
 
-            (let* ((subdir (if #$directory
-                               (string-append "/" #$directory)
-                               ""))
+            (let* ((subdir #$directory)
                    (source (string-append #$source subdir)))
               (compile-files source go (find-files source "\\.scm$"))
               (mkdir-p (dirname scm))
diff --git a/tests/channels.scm b/tests/channels.scm
index 1f1357fca7..e83b5437d3 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -42,9 +42,9 @@
                         (commit "cafebabe")
                         (spec #f))
   (define instance-dir (mkdtemp! "/tmp/checkout.XXXXXX"))
-  (and spec
-       (with-output-to-file (string-append instance-dir "/.guix-channel")
-         (lambda _ (format #t "~a" spec))))
+  (when spec
+    (call-with-output-file (string-append instance-dir "/.guix-channel")
+      (lambda (port) (write spec port))))
   (checkout->channel-instance instance-dir
                               #:commit commit
                               #:name name))
@@ -55,12 +55,10 @@
                  '(channel (version 42) (dependencies whatever))))
 (define instance--no-deps
   (make-instance #:spec
-                 '(channel
-                   (version 0)
-                   (dependencies
-                    (channel
-                     (name test-channel)
-                     (url "https://example.com/test-channel"))))))
+                 '(channel (version 0))))
+(define instance--sub-directory
+  (make-instance #:spec
+                 '(channel (version 0) (directory "modules"))))
 (define instance--simple
   (make-instance #:spec
                  '(channel
@@ -87,11 +85,26 @@
 
 (define channel-instance-metadata
   (@@ (guix channels) channel-instance-metadata))
+(define channel-metadata-directory
+  (@@ (guix channels) channel-metadata-directory))
+(define channel-metadata-dependencies
+  (@@ (guix channels) channel-metadata-dependencies))
 
 
-(test-equal "channel-instance-metadata returns #f if .guix-channel does not exist"
-  #f
-  (channel-instance-metadata instance--boring))
+(test-equal "channel-instance-metadata returns default if .guix-channel does not exist"
+  '("/" ())
+  (let ((metadata (channel-instance-metadata instance--boring)))
+    (list (channel-metadata-directory metadata)
+          (channel-metadata-dependencies metadata))))
+
+(test-equal "channel-instance-metadata and default dependencies"
+  '()
+  (channel-metadata-dependencies (channel-instance-metadata instance--no-deps)))
+
+(test-equal "channel-instance-metadata and directory"
+  "/modules"
+  (channel-metadata-directory
+   (channel-instance-metadata instance--sub-directory)))
 
 (test-equal "channel-instance-metadata rejects unsupported version"
   1                              ;line number in the generated '.guix-channel'
@@ -141,7 +154,7 @@
                ("test" (values test-dir 'whatever))
                (_ (values "/not-important" 'not-important)))))
           (let ((instances (latest-channel-instances #f (list channel))))
-            (and (eq? 2 (length instances))
+            (and (= 2 (length instances))
                  (lset= eq?
                         '(test test-channel)
                         (map (compose channel-name channel-instance-channel)
@@ -152,9 +165,9 @@
                          (and (eq? (channel-name
                                     (channel-instance-channel instance))
                                    'test-channel)
-                              (eq? (channel-commit
-                                    (channel-instance-channel instance))
-                                   'abc1234)))
+                              (string=? (channel-commit
+                                         (channel-instance-channel instance))
+                                        "abc1234")))
                        instances))))))
 
 (test-assert "channel-instances->manifest"
-- 
cgit v1.2.3


From a2a94b6e58e5120462d6861bdf72efa2170bfd73 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 19 Jul 2019 23:48:09 +0200
Subject: ui: 'warn-about-load-error' warns about file/module name mismatches.

* guix/discovery.scm (scheme-modules): Rename the inner 'file' to
'relative'.  Pass FILE as an addition argument to WARN.
* guix/ui.scm (warn-about-load-error): Add 'module' argument (actually,
what was called 'file' really contained a module name.)  Call
'check-module-matches-file' in the catch-all error case.
(check-module-matches-file): New procedure.
* tests/guix-build.sh: Test it.
---
 guix/discovery.scm  |  6 +++---
 guix/ui.scm         | 39 +++++++++++++++++++++++++++++++++++----
 tests/guix-build.sh | 12 ++++++++++++
 3 files changed, 50 insertions(+), 7 deletions(-)

(limited to 'tests')

diff --git a/guix/discovery.scm b/guix/discovery.scm
index 86f20ec344..468b6c59de 100644
--- a/guix/discovery.scm
+++ b/guix/discovery.scm
@@ -106,14 +106,14 @@ name and the exception key and arguments."
     (string-length directory))
 
   (filter-map (lambda (file)
-                (let* ((file   (substring file prefix-len))
-                       (module (file-name->module-name file)))
+                (let* ((relative (string-drop file prefix-len))
+                       (module   (file-name->module-name relative)))
                   (catch #t
                     (lambda ()
                       (resolve-interface module))
                     (lambda args
                       ;; Report the error, but keep going.
-                      (warn module args)
+                      (warn file module args)
                       #f))))
               (scheme-files (if sub-directory
                                 (string-append directory "/" sub-directory)
diff --git a/guix/ui.scm b/guix/ui.scm
index 76f6fc8eed..1812b01272 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -311,6 +311,36 @@ arguments."
         (display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?")
                               (module-name module))))))))
 
+(define (check-module-matches-file module file)
+  "Check whether FILE starts with 'define-module MODULE' and print a hint if
+it doesn't."
+  ;; This is a common mistake when people start writing their own package
+  ;; definitions and try loading them with 'guix build -L …', so help them
+  ;; diagnose the problem.
+  (define (hint)
+    (display-hint (format #f (G_ "File @file{~a} should probably start with:
+
+@example\n(define-module ~a)\n@end example")
+                          file module)))
+
+  (catch 'system-error
+    (lambda ()
+      (let* ((sexp (call-with-input-file file read))
+             (loc  (and (pair? sexp)
+                        (source-properties->location (source-properties sexp)))))
+        (match sexp
+          (('define-module (names ...) _ ...)
+           (unless (equal? module names)
+             (warning loc
+                      (G_ "module name ~a does not match file name '~a'~%")
+                      names (module->source-file-name module))
+             (hint)))
+          ((? eof-object?)
+           (warning (G_ "~a: file is empty~%") file))
+          (else
+           (hint)))))
+    (const #f)))
+
 (define* (report-load-error file args #:optional frame)
   "Report the failure to load FILE, a user-provided Scheme file.
 ARGS is the list of arguments received by the 'throw' handler."
@@ -352,13 +382,13 @@ ARGS is the list of arguments received by the 'throw' handler."
         ;; above and need to be printed with 'print-exception'.
         (print-exception (current-error-port) frame key args))))))
 
-(define (warn-about-load-error file args)         ;FIXME: factorize with ↑
+(define (warn-about-load-error file module args)  ;FIXME: factorize with ↑
   "Report the failure to load FILE, a user-provided Scheme file, without
 exiting.  ARGS is the list of arguments received by the 'throw' handler."
   (match args
     (('system-error . rest)
      (let ((err (system-error-errno args)))
-       (warning (G_ "failed to load '~a': ~a~%") file (strerror err))))
+       (warning (G_ "failed to load '~a': ~a~%") module (strerror err))))
     (('syntax-error proc message properties form . rest)
      (let ((loc (source-properties->location properties)))
        (warning loc (G_ "~a~%") message)))
@@ -370,8 +400,9 @@ exiting.  ARGS is the list of arguments received by the 'throw' handler."
          (warning (G_ "failed to load '~a': exception thrown: ~s~%")
                   file obj)))
     ((error args ...)
-     (warning (G_ "failed to load '~a':~%") file)
-     (apply display-error #f (current-error-port) args))))
+     (warning (G_ "failed to load '~a':~%") module)
+     (apply display-error #f (current-error-port) args)
+     (check-module-matches-file module file))))
 
 (define (call-with-unbound-variable-handling thunk)
   (define tag
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index 63a9fe68da..d16b92d189 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -164,6 +164,17 @@ grep "unbound" "$module_dir/err"		     # actual error
 grep "forget.*(gnu packages base)" "$module_dir/err" # hint
 rm -f "$module_dir"/*
 
+# Wrong 'define-module' clause reported by 'warn-about-load-error'.
+cat > "$module_dir/foo.scm" <<EOF
+(define-module (something foo)
+  #:use-module (guix)
+  #:use-module (gnu))
+EOF
+guix build guile-bootstrap -n 2> "$module_dir/err"
+grep "does not match file name" "$module_dir/err"
+
+rm "$module_dir"/*
+
 # Should all return valid log files.
 drv="`guix build -d -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`"
 out="`guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`"
@@ -265,6 +276,7 @@ cat > "$module_dir/gexp.scm"<<EOF
 EOF
 guix build --file="$module_dir/gexp.scm" -d
 guix build --file="$module_dir/gexp.scm" -d | grep 'gexp\.drv'
+rm "$module_dir"/*.scm
 
 # Using 'GUIX_BUILD_OPTIONS'.
 GUIX_BUILD_OPTIONS="--dry-run --no-grafts"
-- 
cgit v1.2.3


From 723bdb8ef0175716a2bfa93e96c3fd757d7b2679 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 20 Jul 2019 00:33:50 +0200
Subject: ui: 'warn-about-load-error' provides hints for unbound variables.

* guix/ui.scm (warn-about-load-error): Add 'unbound-variable' clause.
* tests/guix-build.sh: Add test.
---
 guix/ui.scm         |  2 ++
 tests/guix-build.sh | 19 +++++++++++++++++--
 2 files changed, 19 insertions(+), 2 deletions(-)

(limited to 'tests')

diff --git a/guix/ui.scm b/guix/ui.scm
index 1812b01272..7920335928 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -392,6 +392,8 @@ exiting.  ARGS is the list of arguments received by the 'throw' handler."
     (('syntax-error proc message properties form . rest)
      (let ((loc (source-properties->location properties)))
        (warning loc (G_ "~a~%") message)))
+    (('unbound-variable _ ...)
+     (report-unbound-variable-error args))
     (('srfi-34 obj)
      (if (message-condition? obj)
          (warning (G_ "failed to load '~a': ~a~%")
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index d16b92d189..37666ffd01 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -146,8 +146,8 @@ test `guix build -d --sources=transitive foo \
       | wc -l` -eq 3
 
 
-# Unbound variables.
-cat > "$module_dir/foo.scm"<<EOF
+# Unbound variable in thunked field.
+cat > "$module_dir/foo.scm" <<EOF
 (define-module (foo)
   #:use-module (guix tests)
   #:use-module (guix build-system trivial))
@@ -162,6 +162,21 @@ if guix build package-with-something-wrong -n; then false; else true; fi
 guix build package-with-something-wrong -n 2> "$module_dir/err" || true
 grep "unbound" "$module_dir/err"		     # actual error
 grep "forget.*(gnu packages base)" "$module_dir/err" # hint
+
+# Unbound variable at the top level.
+cat > "$module_dir/foo.scm" <<EOF
+(define-module (foo)
+  #:use-module (guix tests))
+
+(define-public foo
+  (dummy-package "package-with-something-wrong"
+    (build-system gnu-build-system)))      ;unbound variable
+EOF
+
+guix build sed -n 2> "$module_dir/err"
+grep "unbound" "$module_dir/err"		     # actual error
+grep "forget.*(guix build-system gnu)" "$module_dir/err" # hint
+
 rm -f "$module_dir"/*
 
 # Wrong 'define-module' clause reported by 'warn-about-load-error'.
-- 
cgit v1.2.3


From 571f6e7f4f75a01746a0880c99e0cc33fbafbe2a Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 20 Jul 2019 01:04:49 +0200
Subject: lint: Update tests to (guix lint) migration.

This is a followup to f363c836e0b4c416dae594af4257459da592b35c.

* tests/lint.scm ("cve")
("cve: one vulnerability")
("cve: one patched vulnerability")
("cve: known safe from vulnerability")
("cve: vulnerability fixed in replacement version")
("cve: patched vulnerability in replacement"): Refer to
'package-vulnerabilities' from (guix lint), not (guix scripts lint).
---
 tests/lint.scm | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

(limited to 'tests')

diff --git a/tests/lint.scm b/tests/lint.scm
index 59be061a99..5127a84c72 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
 ;;; Copyright © 2014, 2015, 2016 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
 ;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
@@ -710,12 +710,12 @@
 
 (test-equal "cve"
   '()
-  (mock ((guix scripts lint) package-vulnerabilities (const '()))
+  (mock ((guix lint) package-vulnerabilities (const '()))
         (check-vulnerabilities (dummy-package "x"))))
 
 (test-equal "cve: one vulnerability"
   "probably vulnerable to CVE-2015-1234"
-  (mock ((guix scripts lint) package-vulnerabilities
+  (mock ((guix lint) package-vulnerabilities
          (lambda (package)
            (list (make-struct (@@ (guix cve) <vulnerability>) 0
                               "CVE-2015-1234"
@@ -726,7 +726,7 @@
 
 (test-equal "cve: one patched vulnerability"
   '()
-  (mock ((guix scripts lint) package-vulnerabilities
+  (mock ((guix lint) package-vulnerabilities
          (lambda (package)
            (list (make-struct (@@ (guix cve) <vulnerability>) 0
                               "CVE-2015-1234"
@@ -742,7 +742,7 @@
 
 (test-equal "cve: known safe from vulnerability"
   '()
-  (mock ((guix scripts lint) package-vulnerabilities
+  (mock ((guix lint) package-vulnerabilities
          (lambda (package)
            (list (make-struct (@@ (guix cve) <vulnerability>) 0
                               "CVE-2015-1234"
@@ -755,7 +755,7 @@
 
 (test-equal "cve: vulnerability fixed in replacement version"
   '()
-  (mock ((guix scripts lint) package-vulnerabilities
+  (mock ((guix lint) package-vulnerabilities
          (lambda (package)
            (match (package-version package)
              ("0"
@@ -772,7 +772,7 @@
 
 (test-equal "cve: patched vulnerability in replacement"
   '()
-  (mock ((guix scripts lint) package-vulnerabilities
+  (mock ((guix lint) package-vulnerabilities
          (lambda (package)
            (list (make-struct (@@ (guix cve) <vulnerability>) 0
                               "CVE-2015-1234"
-- 
cgit v1.2.3


From 99b204281235a2b6a44d949e08bc517188b21e49 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 20 Jul 2019 01:18:11 +0200
Subject: lint: Add test for 'source'.

* tests/lint.scm ("source: 404 and 200"): New test.
---
 tests/lint.scm | 17 +++++++++++++++++
 1 file changed, 17 insertions(+)

(limited to 'tests')

diff --git a/tests/lint.scm b/tests/lint.scm
index 5127a84c72..8a9023a7a3 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -618,6 +618,23 @@
           (and (? lint-warning?) second-warning))
          (lint-warning-message second-warning))))))
 
+(test-skip (if (http-server-can-listen?) 0 1))
+(test-equal "source: 404 and 200"
+  '()
+  (with-http-server 404 %long-string
+    (let ((bad-url (%local-url)))
+      (parameterize ((%http-server-port (+ 1 (%http-server-port))))
+        (with-http-server 200 %long-string
+          (let ((pkg (package
+                       (inherit (dummy-package "x"))
+                       (source (origin
+                                 (method url-fetch)
+                                 (uri (list bad-url (%local-url)))
+                                 (sha256 %null-sha256))))))
+            ;; Since one of the two URLs is good, this should return the empty
+            ;; list.
+            (check-source pkg)))))))
+
 (test-skip (if (http-server-can-listen?) 0 1))
 (test-equal "source: 301 -> 200"
   "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar"
-- 
cgit v1.2.3


From 96f1cbeff84819f9886d15763b4c477cdecd7784 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 20 Jul 2019 20:13:39 +0200
Subject: swh: Add basic tests.

* guix/swh.scm (%swh-base-url): Turn into a parameter and export it.
* tests/swh.scm: New file.
* Makefile.am (SCM_TESTS): Add it.
---
 Makefile.am   |  1 +
 guix/swh.scm  | 10 ++++----
 tests/swh.scm | 76 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 83 insertions(+), 4 deletions(-)
 create mode 100644 tests/swh.scm

(limited to 'tests')

diff --git a/Makefile.am b/Makefile.am
index b63c55d784..e36f2d9f21 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -375,6 +375,7 @@ SCM_TESTS =					\
   tests/modules.scm				\
   tests/gnu-maintenance.scm			\
   tests/substitute.scm				\
+  tests/swh.scm					\
   tests/builders.scm				\
   tests/derivations.scm				\
   tests/glob.scm				\
diff --git a/guix/swh.scm b/guix/swh.scm
index 89cddb2bdd..d692f81806 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -31,7 +31,9 @@
   #:use-module (ice-9 regex)
   #:use-module (ice-9 popen)
   #:use-module ((ice-9 ftw) #:select (scandir))
-  #:export (origin?
+  #:export (%swh-base-url
+
+            origin?
             origin-id
             origin-type
             origin-url
@@ -115,11 +117,11 @@
 
 (define %swh-base-url
   ;; Presumably we won't need to change it.
-  "https://archive.softwareheritage.org")
+  (make-parameter "https://archive.softwareheritage.org"))
 
 (define (swh-url path . rest)
   (define url
-    (string-append %swh-base-url path
+    (string-append (%swh-base-url) path
                    (string-join rest "/" 'prefix)))
 
   ;; Ensure there's a trailing slash or we get a redirect.
diff --git a/tests/swh.scm b/tests/swh.scm
new file mode 100644
index 0000000000..07f0fda37b
--- /dev/null
+++ b/tests/swh.scm
@@ -0,0 +1,76 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-swh)
+  #:use-module (guix swh)
+  #:use-module (guix tests http)
+  #:use-module (srfi srfi-64))
+
+;; Test the JSON mapping machinery used in (guix swh).
+
+(define %origin
+  "{ \"id\": 42,
+     \"visits_url\": \"/visits/42\",
+     \"type\": \"git\",
+     \"url\": \"http://example.org/guix.git\" }")
+
+(define %directory-entries
+  "[ { \"name\": \"one\",
+       \"type\": \"regular\",
+       \"length\": 123,
+       \"dir_id\": 1 }
+     { \"name\": \"two\",
+       \"type\": \"regular\",
+       \"length\": 456,
+       \"dir_id\": 2 } ]")
+
+(define-syntax-rule (with-json-result str exp ...)
+  (with-http-server 200 str
+    (parameterize ((%swh-base-url (%local-url)))
+      exp ...)))
+
+(test-begin "swh")
+
+(test-equal "lookup-origin"
+  (list 42 "git" "http://example.org/guix.git")
+  (with-json-result %origin
+    (let ((origin (lookup-origin "http://example.org/guix.git")))
+      (list (origin-id origin)
+            (origin-type origin)
+            (origin-url origin)))))
+
+(test-equal "lookup-origin, not found"
+  #f
+  (with-http-server 404 "Nope."
+    (parameterize ((%swh-base-url (%local-url)))
+      (lookup-origin "http://example.org/whatever"))))
+
+(test-equal "lookup-directory"
+  '(("one" 123) ("two" 456))
+  (with-json-result %directory-entries
+    (map (lambda (entry)
+           (list (directory-entry-name entry)
+                 (directory-entry-length entry)))
+         (lookup-directory "123"))))
+
+(test-end "swh")
+
+;; Local Variables:
+;; eval: (put 'with-json-result 'scheme-indent-function 1)
+;; End:
+
-- 
cgit v1.2.3