diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/channels.scm | 94 | ||||
| -rw-r--r-- | guix/discovery.scm | 6 | ||||
| -rw-r--r-- | guix/lint.scm | 25 | ||||
| -rw-r--r-- | guix/scripts/archive.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 7 | ||||
| -rw-r--r-- | guix/swh.scm | 10 | ||||
| -rw-r--r-- | guix/ui.scm | 41 |
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 |