Merge branch 'master' into core-updates

8 files changed, 125 insertions, 66 deletions

diff --git a/guix/channels.scm b/guix/channels.scm
index bfe6963418..415246cbd1 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -108,11 +108,10 @@
   (checkout  channel-instance-checkout))
 
 (define-record-type <channel-metadata>
-  (channel-metadata version directory dependencies)
+  (channel-metadata directory dependencies)
   channel-metadata?
-  (version       channel-metadata-version)
-  (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
@@ -121,44 +120,65 @@
     (#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
+        (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))))
+                 (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)
+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))
+          (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 (read-channel-metadata instance)
-    (#f '())
-    (($ <channel-metadata> version 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
@@ -240,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
@@ -260,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/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/lint.scm b/guix/lint.scm
index 2542a81a2d..7a2bf5a347 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -43,9 +43,7 @@
   #:use-module (guix scripts)
   #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph))
   #:use-module (guix gnu-maintenance)
-  #:use-module (guix monads)
   #:use-module (guix cve)
-  #:use-module (gnu packages)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
@@ -742,21 +740,28 @@ descriptions maintained upstream."
   "Emit a warning if PACKAGE has an invalid 'source' field, or if that
 'source' is not reachable."
   (define (warnings-for-uris uris)
-    (filter lint-warning?
-            (map
-             (lambda (uri)
-               (validate-uri uri package 'source))
-             (append-map (cut maybe-expand-mirrors <> %mirrors)
-                         uris))))
+    (let loop ((uris uris)
+               (warnings '()))
+      (match uris
+        (()
+         (reverse warnings))
+        ((uri rest ...)
+         (match (validate-uri uri package 'source)
+           (#t
+            ;; We found a working URL, so stop right away.
+            '())
+           ((? lint-warning? warning)
+            (loop rest (cons warning warnings))))))))
 
   (let ((origin (package-source package)))
     (if (and origin
              (eqv? (origin-method origin) url-fetch))
-        (let* ((uris (map string->uri (origin-uris origin)))
+        (let* ((uris     (append-map (cut maybe-expand-mirrors <> %mirrors)
+                                     (map string->uri (origin-uris origin))))
                (warnings (warnings-for-uris uris)))
 
           ;; Just make sure that at least one of the URIs is valid.
-          (if (eq? (length uris) (length warnings))
+          (if (= (length uris) (length warnings))
               ;; When everything fails, report all of WARNINGS, otherwise don't
               ;; report anything.
               ;;
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index d349b5d590..fba0f73826 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -30,6 +30,7 @@
   #:use-module (guix monads)
   #:use-module (guix ui)
   #:use-module (guix pki)
+  #:use-module (gcrypt common)
   #:use-module (gcrypt pk-crypto)
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 98ee469501..ee1c826d2e 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -46,10 +46,9 @@
    (lambda (lint-warning)
      (let ((package (lint-warning-package lint-warning))
            (loc     (lint-warning-location lint-warning)))
-       (format (guix-warning-port) "~a: ~a@~a: ~a~%"
-               (location->string loc)
-               (package-name package) (package-version package)
-               (lint-warning-message lint-warning))))
+       (warning loc (G_ "~a@~a: ~a~%")
+                (package-name package) (package-version package)
+                (lint-warning-message lint-warning))))
    warnings))
 
 (define (run-checkers package checkers)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 1524607623..8d958b550f 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -509,9 +509,10 @@ the image."
                                 #:database #+database
                                 #:system (or #$target (utsname:machine (uname)))
                                 #:environment environment
-                                #:entry-point #$(and entry-point
-                                                     #~(string-append #$profile "/"
-                                                                      #$entry-point))
+                                #:entry-point
+                                #$(and entry-point
+                                       #~(list (string-append #$profile "/"
+                                                              #$entry-point)))
                                 #:symlinks '#$symlinks
                                 #:compressor '#$(compressor-command compressor)
                                 #:creation-time (make-time time-utc 0 1))))))
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/guix/ui.scm b/guix/ui.scm
index 76f6fc8eed..7920335928 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,16 +382,18 @@ 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)))
+    (('unbound-variable _ ...)
+     (report-unbound-variable-error args))
     (('srfi-34 obj)
      (if (message-condition? obj)
          (warning (G_ "failed to load '~a': ~a~%")
@@ -370,8 +402,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