diff options
| author | Mark H Weaver <mhw@netris.org> | 2015-06-10 17:50:27 -0400 |
|---|---|---|
| committer | Mark H Weaver <mhw@netris.org> | 2015-06-10 17:50:27 -0400 |
| commit | 14928016556300a6763334d4279c3d117902caaf (patch) | |
| tree | d0dc262b14164b82f97dd6e896ca9e93a1fabeea /guix | |
| parent | 1511e0235525358abb52cf62abeb9457605b5093 (diff) | |
| parent | 57cd353d87d6e9e6e882327be70b4d7b5ce863ba (diff) | |
| download | gnu-guix-14928016556300a6763334d4279c3d117902caaf.tar gnu-guix-14928016556300a6763334d4279c3d117902caaf.tar.gz | |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
40 files changed, 2493 insertions, 1261 deletions
diff --git a/guix/base32.scm b/guix/base32.scm index e0599dc01e..7b2e2a6712 100644 --- a/guix/base32.scm +++ b/guix/base32.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +18,8 @@ (define-module (guix base32) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-60) #:use-module (rnrs bytevectors) #:use-module (ice-9 vlist) @@ -25,7 +27,11 @@ bytevector->base32-string bytevector->nix-base32-string base32-string->bytevector - nix-base32-string->bytevector)) + nix-base32-string->bytevector + &invalid-base32-character + invalid-base32-character? + invalid-base32-character-value + invalid-base32-character-string)) ;;; Commentary: ;;; @@ -264,6 +270,12 @@ starting from the right of S." s) bv)) +;; Invalid base32 character error condition when decoding base32. +(define-condition-type &invalid-base32-character &error + invalid-base32-character? + (character invalid-base32-character-value) + (string invalid-base32-character-string)) + (define (make-base32-string->bytevector base32-string-unfold base32-chars) (let ((char->value (let loop ((i 0) (v vlist-null)) @@ -276,7 +288,10 @@ starting from the right of S." "Return the binary representation of base32 string S as a bytevector." (base32-string-unfold (lambda (chr) (or (and=> (vhash-assv chr char->value) cdr) - (error "invalid base32 character" chr))) + (raise (condition + (&invalid-base32-character + (character chr) + (string s)))))) s)))) (define base32-string->bytevector diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 1bc1879be5..25ac262d5d 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -21,6 +21,7 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm index 954c716893..a1f0a9b8a4 100644 --- a/guix/build-system/glib-or-gtk.scm +++ b/guix/build-system/glib-or-gtk.scm @@ -22,6 +22,7 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 3ccdef1328..da664e5422 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -20,6 +20,7 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix packages) #:use-module (srfi srfi-1) @@ -204,9 +205,10 @@ runs `make distcheck' and whose result is one or more source tarballs." ;; Add autotools & co. as inputs. (let ((ref (lambda (module var) (module-ref (resolve-interface module) var)))) - `(("autoconf" ,(ref '(gnu packages autotools) 'autoconf)) + `(,@(package-native-inputs p) + ("autoconf" ,(ref '(gnu packages autotools) 'autoconf)) ("automake" ,(ref '(gnu packages autotools) 'automake)) - ("libtool" ,(ref '(gnu packages autotools) 'libtool) "bin") + ("libtool" ,(ref '(gnu packages autotools) 'libtool)) ("gettext" ,(ref '(gnu packages gettext) 'gnu-gettext)) ("texinfo" ,(ref '(gnu packages texinfo) 'texinfo)))))))) diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index 0fbf0b8e75..1cb734631c 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -21,6 +21,7 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 7833153676..06af1dd20e 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -20,6 +20,7 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index d498cf618b..e9fffcc62f 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -23,6 +23,7 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index 83bc93d901..e4fda30cf3 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -22,6 +22,7 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) diff --git a/guix/build-system/waf.scm b/guix/build-system/waf.scm index c67f649fa7..044d2a0829 100644 --- a/guix/build-system/waf.scm +++ b/guix/build-system/waf.scm @@ -21,6 +21,7 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module ((guix build-system python) diff --git a/guix/build/download.scm b/guix/build/download.scm index 2e0b019d38..65d18eb839 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -19,7 +19,7 @@ (define-module (guix build download) #:use-module (web uri) - #:use-module (web client) + #:use-module ((web client) #:hide (open-socket-for-uri)) #:use-module (web response) #:use-module (guix ftp-client) #:use-module (guix build utils) @@ -30,7 +30,8 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 format) - #:export (open-connection-for-uri + #:export (open-socket-for-uri + open-connection-for-uri resolve-uri-reference maybe-expand-mirrors url-fetch @@ -195,6 +196,25 @@ host name without trailing dot." (add-weak-reference record port) record))) +(define (open-socket-for-uri uri) + "Return an open port for URI. This variant works around +<http://bugs.gnu.org/15368> which affects Guile's 'open-socket-for-uri' up to +2.0.11 included." + (define rmem-max + ;; The maximum size for a receive buffer on Linux, see socket(7). + "/proc/sys/net/core/rmem_max") + + (define buffer-size + (if (file-exists? rmem-max) + (call-with-input-file rmem-max read) + 126976)) ;the default for Linux, per 'rmem_default' + + (let ((s ((@ (web client) open-socket-for-uri) uri))) + ;; Work around <http://bugs.gnu.org/15368> by restoring a decent + ;; buffer size. + (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size) + s)) + (define (open-connection-for-uri uri) "Like 'open-socket-for-uri', but also handle HTTPS connections." (define https? @@ -218,6 +238,9 @@ host name without trailing dot." (thunk))))))) (with-https-proxy (let ((s (open-socket-for-uri uri))) + ;; Buffer input and output on this port. + (setvbuf s _IOFBF %http-receive-buffer-size) + (if https? (tls-wrap s (uri-host uri)) s))))) diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm new file mode 100644 index 0000000000..6e316d5d2c --- /dev/null +++ b/guix/build/profiles.scm @@ -0,0 +1,149 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 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 (guix build profiles) + #:use-module (guix build union) + #:use-module (guix build utils) + #:use-module (guix search-paths) + #:use-module (srfi srfi-26) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:export (ensure-writable-directory + build-profile)) + +;;; Commentary: +;;; +;;; Build a user profile (essentially the union of all the installed packages) +;;; with its associated meta-data. +;;; +;;; Code: + +(define (abstract-profile profile) + "Return a procedure that replaces PROFILE in VALUE with a reference to the +'GUIX_PROFILE' environment variable. This allows users to specify what the +user-friendly name of the profile is, for instance ~/.guix-profile rather than +/gnu/store/...-profile." + (let ((replacement (string-append "${GUIX_PROFILE:-" profile "}"))) + (match-lambda + ((search-path . value) + (let* ((separator (search-path-specification-separator search-path)) + (items (string-tokenize* value separator)) + (crop (cute string-drop <> (string-length profile)))) + (cons search-path + (string-join (map (lambda (str) + (string-append replacement (crop str))) + items) + separator))))))) + +(define (write-environment-variable-definition port) + "Write the given environment variable definition to PORT." + (match-lambda + ((search-path . value) + (display (search-path-definition search-path value #:kind 'prefix) + port) + (newline port)))) + +(define (build-etc/profile output search-paths) + "Build the 'OUTPUT/etc/profile' shell file containing environment variable +definitions for all the SEARCH-PATHS." + (mkdir-p (string-append output "/etc")) + (call-with-output-file (string-append output "/etc/profile") + (lambda (port) + ;; The use of $GUIX_PROFILE described below is not great. Another + ;; option would have been to use "$1" and have users run: + ;; + ;; source ~/.guix-profile/etc/profile ~/.guix-profile + ;; + ;; However, when 'source' is used with no arguments, $1 refers to the + ;; first positional parameter of the calling scripts, so we can rely on + ;; it. + (display "\ +# Source this file to define all the relevant environment variables in Bash +# for this profile. You may want to define the 'GUIX_PROFILE' environment +# variable to point to the \"visible\" name of the profile, like this: +# +# GUIX_PROFILE=/path/to/profile +# source /path/to/profile/etc/profile +# +# When GUIX_PROFILE is undefined, the various environment variables refer +# to this specific profile generation. +\n" port) + (let ((variables (evaluate-search-paths (cons $PATH search-paths) + (list output)))) + (for-each (write-environment-variable-definition port) + (map (abstract-profile output) variables)))))) + +(define (ensure-writable-directory directory) + "Ensure DIRECTORY exists and is writable. If DIRECTORY is currently a +symlink (to a read-only directory in the store), then delete the symlink and +instead make DIRECTORY a \"real\" directory containing symlinks." + (define (unsymlink link) + (let* ((target (readlink link)) + ;; TARGET might itself be a symlink, so append "/" to make sure + ;; 'scandir' enters it. + (files (scandir (string-append target "/") + (negate (cut member <> '("." "..")))))) + (delete-file link) + (mkdir link) + (for-each (lambda (file) + (symlink (string-append target "/" file) + (string-append link "/" file))) + files))) + + (catch 'system-error + (lambda () + (mkdir directory)) + (lambda args + (let ((errno (system-error-errno args))) + (if (= errno EEXIST) + (let ((stat (lstat directory))) + (case (stat:type stat) + ((symlink) + ;; "Unsymlink" DIRECTORY so that it is writable. + (unsymlink directory)) + ((directory) + #t) + (else + (error "cannot mkdir because a same-named file exists" + directory)))) + (apply throw args)))))) + +(define* (build-profile output inputs + #:key manifest search-paths) + "Build a user profile from INPUTS in directory OUTPUT. Write MANIFEST, an +sexp, to OUTPUT/manifest. Create OUTPUT/etc/profile with Bash definitions for +-all the variables listed in SEARCH-PATHS." + ;; Make the symlinks. + (union-build output inputs + #:log-port (%make-void-port "w")) + + ;; Store meta-data. + (call-with-output-file (string-append output "/manifest") + (lambda (p) + (pretty-print manifest p))) + + ;; Make sure we can write to 'OUTPUT/etc'. 'union-build' above could have + ;; made 'etc' a symlink to a read-only sub-directory in the store so we need + ;; to work around that. + (ensure-writable-directory (string-append output "/etc")) + + ;; Write 'OUTPUT/etc/profile'. + (build-etc/profile output search-paths)) + +;;; profile.scm ends here diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index b62a8cce64..3585bf27a8 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +29,7 @@ MS_REMOUNT MS_BIND MS_MOVE + restart-on-EINTR mount umount mount-points @@ -46,6 +47,7 @@ network-interface-address set-network-interface-flags set-network-interface-address + set-network-interface-up configure-network-interface)) ;;; Commentary: @@ -88,6 +90,19 @@ (ref bv)))) (lambda () 0))) +(define (call-with-restart-on-EINTR thunk) + (let loop () + (catch 'system-error + thunk + (lambda args + (if (= (system-error-errno args) EINTR) + (loop) + (apply throw args)))))) + +(define-syntax-rule (restart-on-EINTR expr) + "Evaluate EXPR and restart upon EINTR. Return the value of EXPR." + (call-with-restart-on-EINTR (lambda () expr))) + (define (augment-mtab source target type options) "Augment /etc/mtab with information about the given mount point." (let ((port (open-file "/etc/mtab" "a"))) @@ -203,7 +218,7 @@ constants from <sys/mount.h>." (let ((ret (proc (string->pointer device))) (err (errno))) (unless (zero? ret) - (throw 'system-error "swapff" "~S: ~A" + (throw 'system-error "swapoff" "~S: ~A" (list device (strerror err)) (list err))))))) @@ -552,4 +567,17 @@ the same type as that returned by 'make-socket-address'." (lambda () (close-port sock))))) +(define* (set-network-interface-up name + #:key (family AF_INET)) + "Turn up the interface NAME." + (let ((sock (socket family SOCK_STREAM 0))) + (dynamic-wind + (const #t) + (lambda () + (let ((flags (network-interface-flags sock name))) + (set-network-interface-flags sock name + (logior flags IFF_UP)))) + (lambda () + (close-port sock))))) + ;;; syscalls.scm ends here diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index ab72405df0..37feb895a5 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -109,11 +109,8 @@ or a TCP port number), and return it." (%ftp-login "anonymous" "guix@example.com" s) (%make-ftp-connection s ai)) (begin - (format (current-error-port) - "FTP to `~a' failed: ~A: ~A~%" - host code message) (close s) - #f)))) + (throw 'ftp-error s "log-in" code message))))) (lambda args ;; Connection failed, so try one of the other addresses. diff --git a/guix/gexp.scm b/guix/gexp.scm index b08a361232..10056e5a1f 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -31,8 +31,17 @@ gexp-input gexp-input? + local-file local-file? + local-file-file + local-file-name + local-file-recursive? + + plain-file + plain-file? + plain-file-name + plain-file-content gexp->derivation gexp->file @@ -137,7 +146,7 @@ cross-compiling.)" ;;; -;;; Local files. +;;; File declarations. ;;; (define-record-type <local-file> @@ -166,6 +175,28 @@ This is the declarative counterpart of the 'interned-file' monadic procedure." (($ <local-file> file name recursive?) (interned-file file name #:recursive? recursive?)))) +(define-record-type <plain-file> + (%plain-file name content references) + plain-file? + (name plain-file-name) ;string + (content plain-file-content) ;string + (references plain-file-references)) ;list (currently unused) + +(define (plain-file name content) + "Return an object representing a text file called NAME with the given +CONTENT (a string) to be added to the store. + +This is the declarative counterpart of 'text-file'." + ;; XXX: For now just ignore 'references' because it's not clear how to use + ;; them in a declarative context. + (%plain-file name content '())) + +(define-gexp-compiler (plain-file-compiler (file plain-file?) system target) + ;; "Compile" FILE by adding it to the store. + (match file + (($ <plain-file> name content references) + (text-file name content references)))) + ;;; ;;; Inputs & outputs. diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 0528e9f253..8d47cee487 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. @@ -179,9 +179,18 @@ network to check in GNU's database." (define (mirror-type url) (let ((uri (string->uri url))) (and (eq? (uri-scheme uri) 'mirror) - (if (member (uri-host uri) '("gnu" "gnupg" "gcc")) - 'gnu - 'non-gnu)))) + (cond + ((member (uri-host uri) + '("gnu" "gnupg" "gcc" "gnome")) + ;; Definitely GNU. + 'gnu) + ((equal? (uri-host uri) "cran") + ;; Possibly GNU: mirror://cran could be either GNU R itself + ;; or a non-GNU package. + #f) + (else + ;; Definitely non-GNU. + 'non-gnu))))) (let ((url (and=> (package-source package) origin-uri)) (name (package-name package))) @@ -348,7 +357,8 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (let-values (((server directory) (ftp-server/directory project))) (define conn (ftp-open server)) - (let loop ((directory directory)) + (let loop ((directory directory) + (result #f)) (let* ((entries (ftp-list conn directory)) ;; Filter out sub-directories that do not contain digits---e.g., @@ -360,32 +370,38 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (((? contains-digit? dir) 'directory . _) dir) (_ #f)) - entries))) - (match subdirs - (() - ;; No sub-directories, so assume that tarballs are here. - (let ((releases (filter-map (match-lambda - ((file 'file . _) - (and (release-file? project file) - (gnu-release - (package project) - (version - (tarball->version file)) - (directory directory) - (files (list file))))) - (_ #f)) - entries))) - (ftp-close conn) - (reduce latest-release #f (coalesce-releases releases)))) - ((subdirs ...) - ;; Assume that SUBDIRS correspond to versions, and jump into the - ;; one with the highest version number. - (let ((target (reduce latest #f subdirs))) - (if target - (loop (string-append directory "/" target)) - (begin - (ftp-close conn) - #f))))))))) + entries)) + + ;; Whether or not SUBDIRS is empty, compute the latest releases + ;; for the current directory. This is necessary for packages + ;; such as 'sharutils' that have a sub-directory that contains + ;; only an older release. + (releases (filter-map (match-lambda + ((file 'file . _) + (and (release-file? project file) + (gnu-release + (package project) + (version + (tarball->version file)) + (directory directory) + (files (list file))))) + (_ #f)) + entries))) + + ;; Assume that SUBDIRS correspond to versions, and jump into the + ;; one with the highest version number. + (let* ((release (reduce latest-release #f + (coalesce-releases releases))) + (result (if (and result release) + (latest-release release result) + (or release result))) + (target (reduce latest #f subdirs))) + (if target + (loop (string-append directory "/" target) + result) + (begin + (ftp-close conn) + result))))))) (define (gnu-release-archive-types release) "Return the available types of archives for RELEASE---a list of strings such diff --git a/guix/http-client.scm b/guix/http-client.scm index 3bffbb1c24..dc8d3298fc 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; @@ -21,7 +21,7 @@ (define-module (guix http-client) #:use-module (guix utils) #:use-module (web uri) - #:use-module (web client) + #:use-module ((web client) #:hide (open-socket-for-uri)) #:use-module (web response) #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) @@ -30,14 +30,15 @@ #:use-module (rnrs bytevectors) #:use-module (guix ui) #:use-module (guix utils) - #:use-module ((guix build download) #:select (resolve-uri-reference)) + #:use-module ((guix build download) + #:select (open-socket-for-uri resolve-uri-reference)) + #:re-export (open-socket-for-uri) #:export (&http-get-error http-get-error? http-get-error-uri http-get-error-code http-get-error-reason - open-socket-for-uri http-fetch)) ;;; Commentary: @@ -174,59 +175,13 @@ closes PORT, unless KEEP-ALIVE? is true." ;; Guile <= 2.0.9 had a bug whereby 'response-body-port' would read more ;; than what 'content-length' says. See Guile commit 802a25b. (module-set! (resolve-module '(web response)) - 'make-delimited-input-port make-delimited-input-port)) - - (define (read-response-body* r) - "Reads the response body from @var{r}, as a bytevector. Returns - @code{#f} if there was no response body." - (define bad-response - (@@ (web response) bad-response)) - - (if (member '(chunked) (response-transfer-encoding r)) - (let ((chunk-port (make-chunked-input-port (response-port r) - #:keep-alive? #t))) - (get-bytevector-all chunk-port)) - (let ((nbytes (response-content-length r))) - ;; Backport of Guile commit 84dfde82ae8f6ec247c1c147c1e2ae50b207bad9 - ;; ("fix response-body-port for responses without content-length"). - (if nbytes - (let ((bv (get-bytevector-n (response-port r) nbytes))) - (if (= (bytevector-length bv) nbytes) - bv - (bad-response "EOF while reading response body: ~a bytes of ~a" - (bytevector-length bv) nbytes))) - (get-bytevector-all (response-port r)))))) - - ;; Install this patch only on Guile 2.0.5. - (unless (guile-version>? "2.0.5") - (module-set! (resolve-module '(web response)) - 'read-response-body read-response-body*))) + 'make-delimited-input-port make-delimited-input-port))) ;; XXX: Work around <http://bugs.gnu.org/13095>, present in Guile ;; up to 2.0.7. (module-define! (resolve-module '(web client)) 'shutdown (const #f)) -(define* (open-socket-for-uri uri #:key (buffered? #t)) - "Return an open port for URI. When BUFFERED? is false, the returned port is -unbuffered." - (define rmem-max - ;; The maximum size for a receive buffer on Linux, see socket(7). - "/proc/sys/net/core/rmem_max") - - (define buffer-size - (if (file-exists? rmem-max) - (call-with-input-file rmem-max read) - 126976)) ; the default for Linux, per 'rmem_default' - - (let ((s ((@ (web client) open-socket-for-uri) uri))) - ;; Work around <http://bugs.gnu.org/15368> by restoring a decent - ;; buffer size. - (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size) - (unless buffered? - (setvbuf s _IONBF)) - s)) - (define* (http-fetch uri #:key port (text? #f) (buffered? #t)) "Return an input port containing the data at URI, and the expected number of bytes available or #f. If TEXT? is true, the data at URI is considered to be @@ -235,44 +190,20 @@ unbuffered port, suitable for use in `filtered-port'. Raise an '&http-get-error' condition if downloading fails." (let loop ((uri uri)) - (let ((port (or port - (open-socket-for-uri uri - #:buffered? buffered?)))) + (let ((port (or port (open-socket-for-uri uri)))) + (unless buffered? + (setvbuf port _IONBF)) (let*-values (((resp data) ;; Try hard to use the API du jour to get an input port. - ;; On Guile 2.0.5 and before, we can only get a string or - ;; bytevector, and not an input port. Work around that. (if (guile-version>? "2.0.7") (http-get uri #:streaming? #t #:port port) ; 2.0.9+ - (if (defined? 'http-get*) - (http-get* uri #:decode-body? text? - #:port port) ; 2.0.7 - (http-get uri #:decode-body? text? - #:port port)))) ; 2.0.5- + (http-get* uri #:decode-body? text? ; 2.0.7 + #:port port))) ((code) (response-code resp))) (case code ((200) - (let ((len (response-content-length resp))) - (cond ((not data) - (begin - ;; Guile 2.0.5 and earlier did not support chunked - ;; transfer encoding, which is required for instance when - ;; fetching %PACKAGE-LIST-URL (see - ;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>). - ;; Normally the `when-guile<=2.0.5' block above fixes - ;; that, but who knows what could happen. - (warning (_ "using Guile ~a, which does not support ~s encoding~%") - (version) - (response-transfer-encoding resp)) - (leave (_ "download failed; use a newer Guile~%") - uri resp))) - ((string? data) ; `http-get' from 2.0.5- - (values (open-input-string data) len)) - ((bytevector? data) ; likewise - (values (open-bytevector-input-port data) len)) - (else ; input port - (values data len))))) + (values data (response-content-length resp))) ((301 ; moved permanently 302) ; found (redirection) (let ((uri (resolve-uri-reference (response-location resp) uri))) diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm new file mode 100644 index 0000000000..dfeba88312 --- /dev/null +++ b/guix/import/cabal.scm @@ -0,0 +1,815 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> +;;; +;;; 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 (guix import cabal) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 receive) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (system base lalr) + #:use-module (rnrs enums) + #:export (read-cabal + eval-cabal + + cabal-package? + cabal-package-name + cabal-package-version + cabal-package-license + cabal-package-home-page + cabal-package-source-repository + cabal-package-synopsis + cabal-package-description + cabal-package-executables + cabal-package-library + cabal-package-test-suites + cabal-package-flags + cabal-package-eval-environment + + cabal-source-repository? + cabal-source-repository-use-case + cabal-source-repository-type + cabal-source-repository-location + + cabal-flag? + cabal-flag-name + cabal-flag-description + cabal-flag-default + cabal-flag-manual + + cabal-dependency? + cabal-dependency-name + cabal-dependency-version + + cabal-executable? + cabal-executable-name + cabal-executable-dependencies + + cabal-library? + cabal-library-dependencies + + cabal-test-suite? + cabal-test-suite-name + cabal-test-suite-dependencies)) + +;; Part 1: +;; +;; Functions used to read a Cabal file. + +;; Comment: +;; +;; The use of virtual closing braces VCCURLY and some lexer functions were +;; inspired from http://hackage.haskell.org/package/haskell-src + +;; Object containing information about the structure of a block: (i) delimited +;; by braces or by indentation, (ii) minimum indentation. +(define-record-type <parse-context> + (make-parse-context mode indentation) + parse-context? + (mode parse-context-mode) ; 'layout or 'no-layout + (indentation parse-context-indentation)) ; #f for 'no-layout + +;; <parse-context> mode set universe +(define-enumeration context (layout no-layout) make-context) + +(define (make-stack) + "Creates a simple stack closure. Actions on the generated stack are +requested by calling it with one of the following symbols as the first +argument: 'empty?, 'push!, 'top, 'pop! and 'clear!. The action 'push! is the +only one requiring a second argument corresponding to the object to be added +to the stack." + (let ((stack '())) + (lambda (msg . args) + (cond ((eqv? msg 'empty?) (null? stack)) + ((eqv? msg 'push!) (set! stack (cons (first args) stack))) + ((eqv? msg 'top) (if (null? stack) '() (first stack))) + ((eqv? msg 'pop!) (match stack + ((e r ...) (set! stack (cdr stack)) e) + (_ #f))) + ((eqv? msg 'clear!) (set! stack '())) + (else #f))))) + +;; Stack to track the structure of nested blocks and simple interface +(define context-stack (make-parameter (make-stack))) + +(define (context-stack-empty?) ((context-stack) 'empty?)) + +(define (context-stack-push! e) ((context-stack) 'push! e)) + +(define (context-stack-top) ((context-stack) 'top)) + +(define (context-stack-pop!) ((context-stack) 'pop!)) + +(define (context-stack-clear!) ((context-stack) 'clear!)) + +;; Indentation of the line being parsed. +(define current-indentation (make-parameter 0)) + +;; Signal to reprocess the beginning of line, in case we need to close more +;; than one indentation level. +(define check-bol? (make-parameter #f)) + +;; Name of the file being parsed. Used in error messages. +(define cabal-file-name (make-parameter "unknowk")) + +;; Specify the grammar of a Cabal file and generate a suitable syntax analyser. +(define (make-cabal-parser) + "Generate a parser for Cabal files." + (lalr-parser + ;; --- token definitions + (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION + (right: IF FLAG EXEC TEST-SUITE SOURCE-REPO BENCHMARK LIB OCURLY) + (left: OR) + (left: PROPERTY AND) + (right: ELSE NOT)) + ;; --- rules + (body (properties sections) : (append $1 $2)) + (sections (sections flags) : (append $1 $2) + (sections source-repo) : (append $1 (list $2)) + (sections executables) : (append $1 $2) + (sections test-suites) : (append $1 $2) + (sections benchmarks) : (append $1 $2) + (sections lib-sec) : (append $1 (list $2)) + () : '()) + (flags (flags flag-sec) : (append $1 (list $2)) + (flag-sec) : (list $1)) + (flag-sec (FLAG OCURLY properties CCURLY) : `(section flag ,$1 ,$3) + (FLAG open properties close) : `(section flag ,$1 ,$3) + (FLAG) : `(section flag ,$1 '())) + (source-repo (SOURCE-REPO OCURLY properties CCURLY) + : `(section source-repository ,$1 ,$3) + (SOURCE-REPO open properties close) + : `(section source-repository ,$1 ,$3)) + (properties (properties PROPERTY) : (append $1 (list $2)) + (PROPERTY) : (list $1)) + (executables (executables exec-sec) : (append $1 (list $2)) + (exec-sec) : (list $1)) + (exec-sec (EXEC OCURLY exprs CCURLY) : `(section executable ,$1 ,$3) + (EXEC open exprs close) : `(section executable ,$1 ,$3)) + (test-suites (test-suites ts-sec) : (append $1 (list $2)) + (ts-sec) : (list $1)) + (ts-sec (TEST-SUITE OCURLY exprs CCURLY) : `(section test-suite ,$1 ,$3) + (TEST-SUITE open exprs close) : `(section test-suite ,$1 ,$3)) + (benchmarks (benchmarks bm-sec) : (append $1 (list $2)) + (bm-sec) : (list $1)) + (bm-sec (BENCHMARK OCURLY exprs CCURLY) : `(section benchmark ,$1 ,$3) + (BENCHMARK open exprs close) : `(section benchmark ,$1 ,$3)) + (lib-sec (LIB OCURLY exprs CCURLY) : `(section library ,$3) + (LIB open exprs close) : `(section library ,$3)) + (exprs (exprs PROPERTY) : (append $1 (list $2)) + (PROPERTY) : (list $1) + (exprs if-then-else) : (append $1 (list $2)) + (if-then-else) : (list $1) + (exprs if-then) : (append $1 (list $2)) + (if-then) : (list $1)) + (if-then-else (IF tests OCURLY exprs CCURLY ELSE OCURLY exprs CCURLY) + : `(if ,$2 ,$4 ,$8) + (IF tests open exprs close ELSE OCURLY exprs CCURLY) + : `(if ,$2 ,$4 ,$8) + ;; The 'open' token after 'tests' is shifted after an 'exprs' + ;; is found. This is because, instead of 'exprs' a 'OCURLY' + ;; token is a valid alternative. For this reason, 'open' + ;; pushes a <parse-context> with a line indentation equal to + ;; the indentation of 'exprs'. + ;; + ;; Differently from this, without the rule above this + ;; comment, when an 'ELSE' token is found, the 'open' token + ;; following the 'ELSE' would be shifted immediately, before + ;; the 'exprs' is found (because there are no other valid + ;; tokens). The 'open' would therefore create a + ;; <parse-context> with the indentation of 'ELSE' and not + ;; 'exprs', creating an inconsistency. We therefore allow + ;; mixed style conditionals. + (IF tests open exprs close ELSE open exprs close) + : `(if ,$2 ,$4 ,$8)) + (if-then (IF tests OCURLY exprs CCURLY) : `(if ,$2 ,$4 ()) + (IF tests open exprs close) : `(if ,$2 ,$4 ())) + (tests (TEST OPAREN ID CPAREN) : `(,$1 ,$3) + (TEST OPAREN ID RELATION VERSION CPAREN) + : `(,$1 ,(string-append $3 " " $4 " " $5)) + (TEST OPAREN ID RELATION VERSION AND RELATION VERSION CPAREN) + : `(and (,$1 ,(string-append $3 " " $4 " " $5)) + (,$1 ,(string-append $3 " " $7 " " $8))) + (NOT tests) : `(not ,$2) + (tests AND tests) : `(and ,$1 ,$3) + (tests OR tests) : `(or ,$1 ,$3) + (OPAREN tests CPAREN) : $2) + (open () : (context-stack-push! + (make-parse-context (context layout) + (current-indentation)))) + (close (VCCURLY)))) + +(define (peek-next-line-indent port) + "This function can be called when the next character on PORT is #\newline +and returns the indentation of the line starting after the #\newline +character. Discard (and consume) empty and comment lines." + (let ((initial-newline (string (read-char port)))) + (let loop ((char (peek-char port)) + (word "")) + (cond ((eqv? char #\newline) (read-char port) + (loop (peek-char port) "")) + ((or (eqv? char #\space) (eqv? char #\tab)) + (let ((c (read-char port))) + (loop (peek-char port) (string-append word (string c))))) + ((comment-line port char) (loop (peek-char port) "")) + (else + (let ((len (string-length word))) + (unread-string (string-append initial-newline word) port) + len)))))) + +(define* (read-value port value min-indent #:optional (separator " ")) + "The next character on PORT must be #\newline. Append to VALUE the +following lines with indentation larger than MIN-INDENT." + (let loop ((val (string-trim-both value)) + (x (peek-next-line-indent port))) + (if (> x min-indent) + (begin + (read-char port) ; consume #\newline + (loop (string-append + val (if (string-null? val) "" separator) + (string-trim-both (read-delimited "\n" port 'peek))) + (peek-next-line-indent port))) + val))) + +(define (lex-white-space port bol) + "Consume white spaces and comment lines on PORT. If a new line is started return #t, +otherwise return BOL (beginning-of-line)." + (let loop ((c (peek-char port)) + (bol bol)) + (cond + ((and (not (eof-object? c)) + (or (char=? c #\space) (char=? c #\tab))) + (read-char port) + (loop (peek-char port) bol)) + ((and (not (eof-object? c)) (char=? c #\newline)) + (read-char port) + (loop (peek-char port) #t)) + ((comment-line port c) + (lex-white-space port bol)) + (else + bol)))) + +(define (lex-bol port) + "Process the beginning of a line on PORT: update current-indentation and +check the end of an indentation based context." + (let ((loc (make-source-location (cabal-file-name) (port-line port) + (port-column port) -1 -1))) + (current-indentation (source-location-column loc)) + (case (get-offside port) + ((less-than) + (check-bol? #t) ; need to check if closing more than 1 indent level. + (unless (context-stack-empty?) (context-stack-pop!)) + (make-lexical-token 'VCCURLY loc #f)) + (else + (lex-token port))))) + +(define (bol? port) (or (check-bol?) (= (port-column port) 0))) + +(define (comment-line port c) + "If PORT starts with a comment line, consume it up to, but not including +#\newline. C is the next character on PORT." + (cond ((and (not (eof-object? c)) (char=? c #\-)) + (read-char port) + (let ((c2 (peek-char port))) + (if (char=? c2 #\-) + (read-delimited "\n" port 'peek) + (begin (unread-char c port) #f)))) + (else #f))) + +(define-enumeration ordering (less-than equal greater-than) make-ordering) + +(define (get-offside port) + "In an indentation based context return the symbol 'greater-than, 'equal or +'less-than to signal if the current column number on PORT is greater-, equal-, +or less-than the indentation of the current context." + (let ((x (port-column port))) + (match (context-stack-top) + (($ <parse-context> 'layout indentation) + (cond + ((> x indentation) (ordering greater-than)) + ((= x indentation) (ordering equal)) + (else (ordering less-than)))) + (_ (ordering greater-than))))) + +;; (Semi-)Predicates for individual tokens. + +(define (is-relation? c) + (and (char? c) (any (cut char=? c <>) '(#\< #\> #\=)))) + +(define (make-rx-matcher pat) + "Compile PAT into a regular expression and creates a function matching a +string against the created regexp." + (let ((rx (make-regexp pat))) (cut regexp-exec rx <>))) + +(define is-property (make-rx-matcher "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$")) + +(define is-flag (make-rx-matcher "^[Ff]lag +([a-zA-Z0-9_-]+)")) + +(define is-src-repo + (make-rx-matcher "^[Ss]ource-[Rr]epository +([a-zA-Z0-9_-]+)")) + +(define is-exec (make-rx-matcher "^[Ee]xecutable +([a-zA-Z0-9_-]+)")) + +(define is-test-suite (make-rx-matcher "^[Tt]est-[Ss]uite +([a-zA-Z0-9_-]+)")) + +(define is-benchmark (make-rx-matcher "^[Bb]enchmark +([a-zA-Z0-9_-]+)")) + +(define is-lib (make-rx-matcher "^[Ll]ibrary *")) + +(define is-else (make-rx-matcher "^else")) + +(define (is-if s) (string=? s "if")) + +(define (is-and s) (string=? s "&&")) + +(define (is-or s) (string=? s "||")) + +(define (is-id s) + (let ((cabal-reserved-words + '("if" "else" "library" "flag" "executable" "test-suite" + "source-repository" "benchmark"))) + (and (every (cut string-ci<> s <>) cabal-reserved-words) + (not (char=? (last (string->list s)) #\:))))) + +(define (is-test s port) + (let ((tests-rx (make-regexp "os|arch|flag|impl")) + (c (peek-char port))) + (and (regexp-exec tests-rx s) (char=? #\( c)))) + +;; Lexers for individual tokens. + +(define (lex-relation loc port) + (make-lexical-token 'RELATION loc (read-while is-relation? port))) + +(define (lex-version loc port) + (make-lexical-token 'VERSION loc + (read-while char-numeric? port + (cut char=? #\. <>) char-numeric?))) + +(define* (read-while is? port #:optional + (is-if-followed-by? (lambda (c) #f)) + (is-allowed-follower? (lambda (c) #f))) + "Read from PORT as long as: (i) either the read character satisfies the +predicate IS?, or (ii) it satisfies the predicate IS-IF-FOLLOWED-BY? and the +character immediately following it satisfies IS-ALLOWED-FOLLOWER?. Returns a +string with the read characters." + (let loop ((c (peek-char port)) + (res '())) + (cond ((and (not (eof-object? c)) (is? c)) + (let ((c (read-char port))) + (loop (peek-char port) (append res (list c))))) + ((and (not (eof-object? c)) (is-if-followed-by? c)) + (let ((c (read-char port)) + (c2 (peek-char port))) + (if (and (not (eof-object? c2)) (is-allowed-follower? c2)) + (loop c2 (append res (list c))) + (begin (unread-char c) (list->string res))))) + (else (list->string res))))) + +(define (lex-property k-v-rx-res loc port) + (let ((key (string-downcase (match:substring k-v-rx-res 1))) + (value (match:substring k-v-rx-res 2))) + (make-lexical-token + 'PROPERTY loc + (list key `(,(read-value port value (current-indentation))))))) + +(define (lex-rx-res rx-res token loc) + (let ((name (string-downcase (match:substring rx-res 1)))) + (make-lexical-token token loc name))) + +(define (lex-flag flag-rx-res loc) (lex-rx-res flag-rx-res 'FLAG loc)) + +(define (lex-src-repo src-repo-rx-res loc) + (lex-rx-res src-repo-rx-res 'SOURCE-REPO loc)) + +(define (lex-exec exec-rx-res loc) (lex-rx-res exec-rx-res 'EXEC loc)) + +(define (lex-test-suite ts-rx-res loc) (lex-rx-res ts-rx-res 'TEST-SUITE loc)) + +(define (lex-benchmark bm-rx-res loc) (lex-rx-res bm-rx-res 'BENCHMARK loc)) + +(define (lex-lib loc) (make-lexical-token 'LIB loc #f)) + +(define (lex-else loc) (make-lexical-token 'ELSE loc #f)) + +(define (lex-if loc) (make-lexical-token 'IF loc #f)) + +(define (lex-and loc) (make-lexical-token 'AND loc #f)) + +(define (lex-or loc) (make-lexical-token 'OR loc #f)) + +(define (lex-id w loc) (make-lexical-token 'ID loc w)) + +(define (lex-test w loc) (make-lexical-token 'TEST loc (string->symbol w))) + +;; Lexer for tokens recognizable by single char. + +(define* (is-ref-char->token ref-char next-char token loc port + #:optional (hook-fn #f)) + "If the next character NEXT-CHAR on PORT is REF-CHAR, then read it, +execute HOOK-FN if it isn't #f and return a lexical token of type TOKEN with +location information LOC." + (cond ((char=? next-char ref-char) + (read-char port) + (when hook-fn (hook-fn)) + (make-lexical-token token loc (string next-char))) + (else #f))) + +(define (is-ocurly->token c loc port) + (is-ref-char->token #\{ c 'OCURLY loc port + (lambda () + (context-stack-push! (make-parse-context + (context no-layout) #f))))) + +(define (is-ccurly->token c loc port) + (is-ref-char->token #\} c 'CCURLY loc port (lambda () (context-stack-pop!)))) + +(define (is-oparen->token c loc port) + (is-ref-char->token #\( c 'OPAREN loc port)) + +(define (is-cparen->token c loc port) + (is-ref-char->token #\) c 'CPAREN loc port)) + +(define (is-not->token c loc port) + (is-ref-char->token #\! c 'NOT loc port)) + +(define (is-version? c) (char-numeric? c)) + +;; Main lexer functions + +(define (lex-single-char port loc) + "Process tokens which can be recognised by peeking the next character on +PORT. If no token can be recognized return #f. LOC is the current port +location." + (let* ((c (peek-char port))) + (cond ((eof-object? c) (read-char port) '*eoi*) + ((is-ocurly->token c loc port)) + ((is-ccurly->token c loc port)) + ((is-oparen->token c loc port)) + ((is-cparen->token c loc port)) + ((is-not->token c loc port)) + ((is-version? c) (lex-version loc port)) + ((is-relation? c) (lex-relation loc port)) + (else + #f)))) + +(define (lex-word port loc) + "Process tokens which can be recognized by reading the next word form PORT. +LOC is the current port location." + (let* ((w (read-delimited " ()\t\n" port 'peek))) + (cond ((is-if w) (lex-if loc)) + ((is-test w port) (lex-test w loc)) + ((is-and w) (lex-and loc)) + ((is-or w) (lex-or loc)) + ((is-id w) (lex-id w loc)) + (else (unread-string w port) #f)))) + +(define (lex-line port loc) + "Process tokens which can be recognised by reading a line from PORT. LOC is +the current port location." + (let* ((s (read-delimited "\n{}" port 'peek))) + (cond + ((is-property s) => (cut lex-property <> loc port)) + ((is-flag s) => (cut lex-flag <> loc)) + ((is-src-repo s) => (cut lex-src-repo <> loc)) + ((is-exec s) => (cut lex-exec <> loc)) + ((is-test-suite s) => (cut lex-test-suite <> loc)) + ((is-benchmark s) => (cut lex-benchmark <> loc)) + ((is-lib s) (lex-lib loc)) + ((is-else s) (lex-else loc)) + (else + #f)))) + +(define (lex-token port) + (let* ((loc (make-source-location (cabal-file-name) (port-line port) + (port-column port) -1 -1))) + (or (lex-single-char port loc) (lex-word port loc) (lex-line port loc)))) + +;; Lexer- and error-function generators + +(define (errorp) + "Generates the lexer error function." + (let ((p (current-error-port))) + (lambda (message . args) + (format p "~a" message) + (if (and (pair? args) (lexical-token? (car args))) + (let* ((token (car args)) + (source (lexical-token-source token)) + (line (source-location-line source)) + (column (source-location-column source))) + (format p "~a " (or (lexical-token-value token) + (lexical-token-category token))) + (when (and (number? line) (number? column)) + (format p "(at line ~a, column ~a)" (1+ line) column))) + (for-each display args)) + (format p "~%")))) + +(define (make-lexer port) + "Generate the Cabal lexical analyser reading from PORT." + (let ((p port)) + (lambda () + (let ((bol (lex-white-space p (bol? p)))) + (check-bol? #f) + (if bol (lex-bol p) (lex-token p)))))) + +(define* (read-cabal #:optional (port (current-input-port)) + (file-name #f)) + "Read a Cabal file from PORT. FILE-NAME is a string used in error messages. +If #f use the function 'port-filename' to obtain it." + (let ((cabal-parser (make-cabal-parser))) + (parameterize ((cabal-file-name + (or file-name (port-filename port) "standard input")) + (current-indentation 0) + (check-bol? #f) + (context-stack (make-stack))) + (cabal-parser (make-lexer port) (errorp))))) + +;; Part 2: +;; +;; Evaluate the S-expression returned by 'read-cabal'. + +;; This defines the object and interface that we provide to access the Cabal +;; file information. Note that this does not include all the pieces of +;; information of the Cabal file, but only the ones we currently are +;; interested in. +(define-record-type <cabal-package> + (make-cabal-package name version license home-page source-repository + synopsis description + executables lib test-suites + flags eval-environment) + cabal-package? + (name cabal-package-name) + (version cabal-package-version) + (license cabal-package-license) + (home-page cabal-package-home-page) + (source-repository cabal-package-source-repository) + (synopsis cabal-package-synopsis) + (description cabal-package-description) + (executables cabal-package-executables) + (lib cabal-package-library) ; 'library' is a Scheme keyword + (test-suites cabal-package-test-suites) + (flags cabal-package-flags) + (eval-environment cabal-package-eval-environment)) ; alist + +(set-record-type-printer! <cabal-package> + (lambda (package port) + (format port "#<cabal-package ~a-~a>" + (cabal-package-name package) + (cabal-package-version package)))) + +(define-record-type <cabal-source-repository> + (make-cabal-source-repository use-case type location) + cabal-source-repository? + (use-case cabal-source-repository-use-case) + (type cabal-source-repository-type) + (location cabal-source-repository-location)) + +;; We need to be able to distinguish the value of a flag from the Scheme #t +;; and #f values. +(define-record-type <cabal-flag> + (make-cabal-flag name description default manual) + cabal-flag? + (name cabal-flag-name) + (description cabal-flag-description) + (default cabal-flag-default) ; 'true or 'false + (manual cabal-flag-manual)) ; 'true or 'false + +(set-record-type-printer! <cabal-flag> + (lambda (package port) + (format port "#<cabal-flag ~a default:~a>" + (cabal-flag-name package) + (cabal-flag-default package)))) + +(define-record-type <cabal-dependency> + (make-cabal-dependency name version) + cabal-dependency? + (name cabal-dependency-name) + (version cabal-dependency-version)) + +(define-record-type <cabal-executable> + (make-cabal-executable name dependencies) + cabal-executable? + (name cabal-executable-name) + (dependencies cabal-executable-dependencies)) ; list of <cabal-dependency> + +(define-record-type <cabal-library> + (make-cabal-library dependencies) + cabal-library? + (dependencies cabal-library-dependencies)) ; list of <cabal-dependency> + +(define-record-type <cabal-test-suite> + (make-cabal-test-suite name dependencies) + cabal-test-suite? + (name cabal-test-suite-name) + (dependencies cabal-test-suite-dependencies)) ; list of <cabal-dependency> + +(define (cabal-flags->alist flag-list) + "Retrun an alist associating the flag name to its default value from a +list of <cabal-flag> objects." + (map (lambda (flag) (cons (cabal-flag-name flag) (cabal-flag-default flag))) + flag-list)) + +(define (eval-cabal cabal-sexp env) + "Given the CABAL-SEXP produced by 'read-cabal', evaluate all conditionals +and return a 'cabal-package' object. The values of all tests can be +overwritten by specifying the desired value in ENV. ENV must be an alist. +The accepted keys are: \"os\", \"arch\", \"impl\" and a name of a flag. The +value associated with a flag has to be either \"true\" or \"false\". The +value associated with other keys has to conform to the Cabal file format +definition." + (define (os name) + (let ((env-os (or (assoc-ref env "os") "linux"))) + (string-match env-os name))) + + (define (arch name) + (let ((env-arch (or (assoc-ref env "arch") "x86_64"))) + (string-match env-arch name))) + + (define (comp-name+version haskell) + "Extract the compiler name and version from the string HASKELL." + (let* ((matcher-fn (make-rx-matcher "([a-zA-Z0-9_]+)-([0-9.]+)")) + (name (or (and=> (matcher-fn haskell) (cut match:substring <> 1)) + haskell)) + (version (and=> (matcher-fn haskell) (cut match:substring <> 2)))) + (values name version))) + + (define (comp-spec-name+op+version spec) + "Extract the compiler specification from SPEC. Return the compiler name, +the ordering operation and the version." + (let* ((with-ver-matcher-fn (make-rx-matcher + "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *")) + (without-ver-matcher-fn (make-rx-matcher "([a-zA-Z0-9_-]+)")) + (name (or (and=> (with-ver-matcher-fn spec) + (cut match:substring <> 1)) + (match:substring (without-ver-matcher-fn spec) 1))) + (operator (and=> (with-ver-matcher-fn spec) + (cut match:substring <> 2))) + (version (and=> (with-ver-matcher-fn spec) + (cut match:substring <> 3)))) + (values name operator version))) + + (define (impl haskell) + (let*-values (((comp-name comp-ver) + (comp-name+version (or (assoc-ref env "impl") "ghc"))) + ((spec-name spec-op spec-ver) + (comp-spec-name+op+version haskell))) + (if (and spec-ver comp-ver) + (eval-string + (string-append "(string" spec-op " \"" comp-name "\"" + " \"" spec-name "-" spec-ver "\")")) + (string-match spec-name comp-name)))) + + (define (cabal-flags) + (make-cabal-section cabal-sexp 'flag)) + + (define (flag name) + (let ((value (or (assoc-ref env name) + (assoc-ref (cabal-flags->alist (cabal-flags)) name)))) + (if (eq? value 'false) #f #t))) + + (define (eval sexp) + (match sexp + (() '()) + ;; nested 'if' + ((('if predicate true-group false-group) rest ...) + (append (if (eval predicate) + (eval true-group) + (eval false-group)) + (eval rest))) + (('if predicate true-group false-group) + (if (eval predicate) + (eval true-group) + (eval false-group))) + (('flag name) (flag name)) + (('os name) (os name)) + (('arch name) (arch name)) + (('impl name) (impl name)) + (('not name) (not (eval name))) + ;; 'and' and 'or' aren't functions, thus we can't use apply + (('and args ...) (fold (lambda (e s) (and e s)) #t (eval args))) + (('or args ...) (fold (lambda (e s) (or e s)) #f (eval args))) + ;; no need to evaluate flag parameters + (('section 'flag name parameters) + (list 'section 'flag name parameters)) + ;; library does not have a name parameter + (('section 'library parameters) + (list 'section 'library (eval parameters))) + (('section type name parameters) + (list 'section type name (eval parameters))) + (((? string? name) values) + (list name values)) + ((element rest ...) + (cons (eval element) (eval rest))) + (_ (raise (condition + (&message (message "Failed to evaluate Cabal file. \ +See the manual for limitations."))))))) + + (define (cabal-evaluated-sexp->package evaluated-sexp) + (let* ((name (lookup-join evaluated-sexp "name")) + (version (lookup-join evaluated-sexp "version")) + (license (lookup-join evaluated-sexp "license")) + (home-page (lookup-join evaluated-sexp "homepage")) + (home-page-or-hackage + (if (string-null? home-page) + (string-append "http://hackage.haskell.org/package/" name) + home-page)) + (source-repository (make-cabal-section evaluated-sexp + 'source-repository)) + (synopsis (lookup-join evaluated-sexp "synopsis")) + (description (lookup-join evaluated-sexp "description")) + (executables (make-cabal-section evaluated-sexp 'executable)) + (lib (make-cabal-section evaluated-sexp 'library)) + (test-suites (make-cabal-section evaluated-sexp 'test-suite)) + (flags (make-cabal-section evaluated-sexp 'flag)) + (eval-environment '())) + (make-cabal-package name version license home-page-or-hackage + source-repository synopsis description executables lib + test-suites flags eval-environment))) + + ((compose cabal-evaluated-sexp->package eval) cabal-sexp)) + +(define (make-cabal-section sexp section-type) + "Given an SEXP as produced by 'read-cabal', produce a list of objects +pertaining to SECTION-TYPE sections. SECTION-TYPE must be one of: +'executable, 'flag, 'test-suite, 'source-repository or 'library." + (filter-map (cut match <> + (('section (? (cut equal? <> section-type)) name parameters) + (case section-type + ((test-suite) (make-cabal-test-suite + name (dependencies parameters))) + ((executable) (make-cabal-executable + name (dependencies parameters))) + ((source-repository) (make-cabal-source-repository + name + (lookup-join parameters "type") + (lookup-join parameters "location"))) + ((flag) + (let* ((default (lookup-join parameters "default")) + (default-true-or-false + (if (and default (string-ci=? "false" default)) + 'false + 'true)) + (description (lookup-join parameters "description")) + (manual (lookup-join parameters "manual")) + (manual-true-or-false + (if (and manual (string-ci=? "true" manual)) + 'true + 'false))) + (make-cabal-flag name description + default-true-or-false + manual-true-or-false))) + (else #f))) + (('section (? (cut equal? <> section-type) lib) parameters) + (make-cabal-library (dependencies parameters))) + (_ #f)) + sexp)) + +(define* (lookup-join key-values-list key #:optional (delimiter " ")) + "Lookup and joint all values pertaining to keys of value KEY in +KEY-VALUES-LIST. The optional DELIMITER is used to specify a delimiter string +to be added between the values found in different key/value pairs." + (string-join + (filter-map (cut match <> + (((? (lambda(x) (equal? x key))) value) + (string-join value delimiter)) + (_ #f)) + key-values-list) + delimiter)) + +(define dependency-name-version-rx + (make-regexp "([a-zA-Z0-9_-]+) *(.*)")) + +(define (dependencies key-values-list) + "Return a list of 'cabal-dependency' objects for the dependencies found in +KEY-VALUES-LIST." + (let ((deps (string-tokenize (lookup-join key-values-list "build-depends" ",") + (char-set-complement (char-set #\,))))) + (map (lambda (d) + (let ((rx-result (regexp-exec dependency-name-version-rx d))) + (make-cabal-dependency + (match:substring rx-result 1) + (match:substring rx-result 2)))) + deps))) + +;;; cabal.scm ends here diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 1b27803dba..b5574a8d9f 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -18,28 +18,19 @@ (define-module (guix import hackage) #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 receive) - #:use-module (ice-9 pretty-print) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module (srfi srfi-11) #:use-module (srfi srfi-1) #:use-module ((guix download) #:select (download-to-store)) #:use-module ((guix utils) #:select (package-name->name+version)) #:use-module (guix import utils) + #:use-module (guix import cabal) #:use-module (guix store) #:use-module (guix hash) #:use-module (guix base32) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (hackage->guix-package)) -;; Part 1: -;; -;; Functions used to read a Cabal file. - (define ghc-standard-libraries ;; List of libraries distributed with ghc (7.8.4). We include GHC itself as ;; some packages list it. @@ -75,588 +66,12 @@ (define package-name-prefix "ghc-") -(define key-value-rx - ;; Regular expression matching "key: value" - (make-regexp "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$")) - -(define sections-rx - ;; Regular expression matching a section "head sub-head ..." - (make-regexp "([a-zA-Z0-9\\(\\)-]+)")) - -(define comment-rx - ;; Regexp matching Cabal comment lines. - (make-regexp "^ *--")) - -(define (has-key? line) - "Check if LINE includes a key." - (regexp-exec key-value-rx line)) - -(define (comment-line? line) - "Check if LINE is a comment line." - (regexp-exec comment-rx line)) - -(define (line-indentation+rest line) - "Returns two results: The number of indentation spaces and the rest of the -line (without indentation)." - (let loop ((line-lst (string->list line)) - (count 0)) - ;; Sometimes values are spread over multiple lines and new lines start - ;; with a comma ',' with the wrong indentation. See e.g. haddock-api. - (if (or (null? line-lst) - (not (or - (eqv? (first line-lst) #\space) - (eqv? (first line-lst) #\,) ; see, e.g., haddock-api.cabal - (eqv? (first line-lst) #\tab)))) - (values count (list->string line-lst)) - (loop (cdr line-lst) (+ count 1))))) - -(define (multi-line-value lines seed) - "Function to read a value split across multiple lines. LINES are the -remaining input lines to be read. SEED is the value read on the same line as -the key. Return two values: A list with values and the remaining lines to be -processed." - (define (multi-line-value-with-min-indent lines seed min-indent) - (if (null? lines) - (values '() '()) - (let-values (((current-indent value) (line-indentation+rest (first lines))) - ((next-line-indent next-line-value) - (if (null? (cdr lines)) - (values #f "") - (line-indentation+rest (second lines))))) - (if (or (not next-line-indent) (< next-line-indent min-indent) - (regexp-exec condition-rx next-line-value)) - (values (reverse (cons value seed)) (cdr lines)) - (multi-line-value-with-min-indent (cdr lines) (cons value seed) - min-indent))))) - - (let-values (((current-indent value) (line-indentation+rest (first lines)))) - (multi-line-value-with-min-indent lines seed current-indent))) - -(define (read-cabal port) - "Parses a Cabal file from PORT. Return a list of list pairs: - -(((head1 sub-head1 ... key1) (value)) - ((head2 sub-head2 ... key2) (value2)) - ...). - -We try do deduce the Cabal format from the following document: -https://www.haskell.org/cabal/users-guide/developing-packages.html - -Keys are case-insensitive. We therefore lowercase them. Values are -case-sensitive. Currently only indentation-structured files are parsed. -Braces structured files are not handled." ;" <- make emacs happy. - (define (read-and-trim-line port) - (let ((line (read-line port))) - (if (string? line) - (string-trim-both line #\return) - line))) - - (define (strip-insignificant-lines port) - (let loop ((line (read-and-trim-line port)) - (result '())) - (cond - ((eof-object? line) - (reverse result)) - ((or (string-null? line) (comment-line? line)) - (loop (read-and-trim-line port) result)) - (else - (loop (read-and-trim-line port) (cons line result)))))) - - (let loop - ((lines (strip-insignificant-lines port)) - (indents '()) ; only includes indents at start of section heads. - (sections '()) - (result '())) - (let-values - (((current-indent line) - (if (null? lines) - (values 0 "") - (line-indentation+rest (first lines)))) - ((next-line-indent next-line) - (if (or (null? lines) (null? (cdr lines))) - (values 0 "") - (line-indentation+rest (second lines))))) - (if (null? lines) - (reverse result) - (let ((rx-result (has-key? line))) - (cond - (rx-result - (let ((key (string-downcase (match:substring rx-result 1))) - (value (match:substring rx-result 2))) - (cond - ;; Simple single line "key: value". - ((= next-line-indent current-indent) - (loop (cdr lines) indents sections - (cons - (list (reverse (cons key sections)) (list value)) - result))) - ;; Multi line "key: value\n value cont...". - ((> next-line-indent current-indent) - (let*-values (((value-lst lines) - (multi-line-value (cdr lines) - (if (string-null? value) - '() - `(,value))))) - ;; multi-line-value returns to the first line after the - ;; multi-value. - (loop lines indents sections - (cons - (list (reverse (cons key sections)) value-lst) - result)))) - ;; Section ended. - (else - ;; Indentation is reduced. Check by how many levels. - (let* ((idx (and=> (list-index - (lambda (x) (= next-line-indent x)) - indents) - (cut + <> - (if (has-key? next-line) 1 0)))) - (sec - (if idx - (drop sections idx) - (raise - (condition - (&message - (message "unable to parse Cabal file")))))) - (ind (drop indents idx))) - (loop (cdr lines) ind sec - (cons - (list (reverse (cons key sections)) (list value)) - result))))))) - ;; Start of a new section. - ((or (null? indents) - (> current-indent (first indents))) - (loop (cdr lines) (cons current-indent indents) - (cons (string-downcase line) sections) result)) - (else - (loop (cdr lines) indents - (cons (string-downcase line) (cdr sections)) - result)))))))) - -(define condition-rx - ;; Regexp for conditionals. - (make-regexp "^if +(.*)$")) - -(define (split-section section) - "Split SECTION in individual words with exception for the predicate of an -'if' conditional." - (let ((rx-result (regexp-exec condition-rx section))) - (if rx-result - `("if" ,(match:substring rx-result 1)) - (map match:substring (list-matches sections-rx section))))) - -(define (join-sections sec1 sec2) - (fold-right cons sec2 sec1)) - -(define (pre-process-keys key) - (match key - (() '()) - ((sec1 rest ...) - (join-sections (split-section sec1) (pre-process-keys rest))))) - -(define (pre-process-entry-keys entry) - (match entry - ((key value) - (list (pre-process-keys key) value)) - (() '()))) - -(define (pre-process-entries-keys entries) - "ENTRIES is a list of list pairs, a keys list and a valules list, as -produced by 'read-cabal'. Split each element of the keys list into individual -words. This pre-processing is used to read flags." - (match entries - ((entry rest ...) - (cons (pre-process-entry-keys entry) - (pre-process-entries-keys rest))) - (() - '()))) - -(define (get-flags pre-processed-entries) - "PRE-PROCESSED-ENTRIES is a list of list pairs, a keys list and a values -list, as produced by 'read-cabal' and pre-processed by -'pre-process-entries-keys'. Return a list of pairs with the name of flags and -their default value (one of \"False\" or \"True\") as specified in the Cabal file: - -((\"flag1-name\" . \"False-or-True\") ...)." ;" <- make emacs happy - (match pre-processed-entries - (() '()) - (((("flag" flag-name "default") (flag-val)) rest ...) - (cons (cons flag-name flag-val) - (get-flags rest))) - ((entry rest ... ) - (get-flags rest)) - (_ #f))) - -;; Part 2: -;; -;; Functions to read information from the Cabal object created by 'read-cabal' -;; and convert Cabal format dependencies conditionals into equivalent -;; S-expressions. - -(define tests-rx - ;; Cabal test keywords - (make-regexp "(os|arch|flag|impl) *\\(([ a-zA-Z0-9_.<>=-]+)\\)")) - -(define parens-rx - ;; Parentheses within conditions - (make-regexp "\\((.+)\\)")) - -(define or-rx - ;; OR operator in conditions - (make-regexp " +\\|\\| +")) - -(define and-rx - ;; AND operator in conditions - (make-regexp " +&& +")) - -(define not-rx - ;; NOT operator in conditions - (make-regexp "^!.+")) - -(define (bi-op-args str match-lst) - "Return a list with the arguments of (logic) bianry operators. MATCH-LST -is the result of 'list-match' against a binary operator regexp on STR." - (let ((operators (length match-lst))) - (map (lambda (from to) - (substring str from to)) - (cons 0 (map match:end match-lst)) - (append (map match:start match-lst) (list (string-length str)))))) - -(define (bi-op->sexp-like bi-op args) - "BI-OP is a string with the name of a Scheme operator which in a Cabal file -is represented by a binary operator. ARGS are the arguments of said operator. -Return a string representing an S-expression of the operator applied to its -arguments." - (if (= (length args) 1) - (first args) - (string-append "(" bi-op - (fold (lambda (arg seed) (string-append seed " " arg)) - "" args) ")"))) - -(define (not->sexp-like arg) - "If the string ARG is prefixed by a Cabal negation operator, convert it to -an equivalent Scheme S-expression string." - (if (regexp-exec not-rx arg) - (string-append "(not " - (substring arg 1 (string-length arg)) - ")") - arg)) - -(define (parens-less-cond->sexp-like conditional) - "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme -syntax. This procedure accepts only simple conditionals without parentheses." - ;; The outher operation is the one with the lowest priority: OR - (bi-op->sexp-like - "or" - ;; each OR argument may be an AND operation - (map (lambda (or-arg) - (let ((m-lst (list-matches and-rx or-arg))) - ;; is there an AND operation? - (if (> (length m-lst) 0) - (bi-op->sexp-like - "and" - ;; expand NOT operators when there are ANDs - (map not->sexp-like (bi-op-args or-arg m-lst))) - ;; ... and when there aren't. - (not->sexp-like or-arg)))) - ;; list of OR arguments - (bi-op-args conditional (list-matches or-rx conditional))))) - -(define test-keyword-ornament "__") - -(define (conditional->sexp-like conditional) - "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme -syntax." - ;; First we substitute TEST-KEYWORD-ORNAMENT for parentheses around tests - ;; keywords so that parentheses are only used to set precedences. This - ;; substantially simplify parsing. - (let ((conditional - (regexp-substitute/global #f tests-rx conditional - 'pre 1 test-keyword-ornament 2 - test-keyword-ornament 'post))) - (let loop ((sub-cond conditional)) - (let ((rx-result (regexp-exec parens-rx sub-cond))) - (cond - (rx-result - (parens-less-cond->sexp-like - (string-append - (match:prefix rx-result) - (loop (match:substring rx-result 1)) - (match:suffix rx-result)))) - (else - (parens-less-cond->sexp-like sub-cond))))))) - -(define (eval-flags sexp-like-cond flags) - "SEXP-LIKE-COND is a string representing an S-expression conditional. FLAGS -is a list of flag name and value pairs as produced by 'get-flags'. Substitute -\"#t\" or \"#f\" according to the value of flags. (Default to \"True\")." - (fold-right - (lambda (flag sexp) - (match flag - ((name . value) - (let ((rx (make-regexp - (string-append "flag" test-keyword-ornament name - test-keyword-ornament)))) - (regexp-substitute/global - #f rx sexp - 'pre (if (string-ci= value "False") "#f" "#t") 'post))) - (_ sexp))) - sexp-like-cond - (cons '("[a-zA-Z0-9_-]+" . "True") flags))) - -(define (eval-tests->sexp sexp-like-cond) - "In the string SEXP-LIKE-COND substitute test keywords \"os(...)\" and -\"arch(...)\" with equivalent Scheme checks. Retrun an S-expression." - (with-input-from-string - (fold-right - (lambda (test sexp) - (match test - ((type pre-match post-match) - (let ((rx (make-regexp - (string-append type test-keyword-ornament "(\\w+)" - test-keyword-ornament)))) - (regexp-substitute/global - #f rx sexp - 'pre pre-match 2 post-match 'post))) - (_ sexp))) - sexp-like-cond - ;; (%current-system) returns, e.g., "x86_64-linux" or "i686-linux". - '(("(os|arch)" "(string-match \"" "\" (%current-system))"))) - read)) - -(define (eval-impl sexp-like-cond) - "Check for the Cabal test \"impl(...)\" in the string SEXP-LIKE-COND. -Assume the module declaring the generated package includes a local variable -called \"haskell-implementation\" with a string value of the form NAME-VERSION -against which we compare." - (with-output-to-string - (lambda () - (write - (with-input-from-string - (fold-right - (lambda (test sexp) - (match test - ((pre-match post-match) - (let ((rx-with-version - (make-regexp - (string-append - "impl" test-keyword-ornament - "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *" - test-keyword-ornament))) - (rx-without-version - (make-regexp - (string-append "impl" test-keyword-ornament "(\\w+)" - test-keyword-ornament)))) - (if (regexp-exec rx-with-version sexp) - (regexp-substitute/global - #f rx-with-version sexp - 'pre pre-match 2 " " post-match " \"" 1 "-" 3 "\")" 'post) - (regexp-substitute/global - #f rx-without-version sexp - 'pre pre-match "-match \"" 1 "\" " post-match ")" 'post)))) - (_ sexp))) - sexp-like-cond - '(("(string" "haskell-implementation"))) - read))))) - -(define (eval-cabal-keywords sexp-like-cond flags) - ((compose eval-tests->sexp eval-impl (cut eval-flags <> flags)) - sexp-like-cond)) - -(define (key->values meta key) - "META is the representation of a Cabal file as produced by 'read-cabal'. -Return the list of values associated with a specific KEY (a string)." - (match meta - (() '()) - (((((? (lambda(x) (equal? x key)))) v) r ...) - v) - (((k v) r ...) - (key->values (cdr meta) key)) - (_ "key Not fount"))) - -(define (key-start-end->entries meta key-start-rx key-end-rx) - "META is the representation of a Cabal file as produced by 'read-cabal'. -Return all entries whose keys list starts with KEY-START and ends with -KEY-END." - (let ((pred - (lambda (x) - (and (regexp-exec key-start-rx (first x)) - (regexp-exec key-end-rx (last x)))))) - ;; (equal? (list key-start key-end) (list (first x) (last x)))))) - (match meta - (() '()) - ((((? pred k) v) r ...) - (cons `(,k ,v) - (key-start-end->entries (cdr meta) key-start-rx key-end-rx))) - (((k v) r ...) - (key-start-end->entries (cdr meta) key-start-rx key-end-rx)) - (_ "key Not fount")))) - -(define else-rx - (make-regexp "^else$")) - -(define (count-if-else rx-result-ls) - (apply + (map (lambda (m) (if m 1 0)) rx-result-ls))) - -(define (analyze-entry-cond entry) - (let* ((keys (first entry)) - (vals (second entry)) - (rx-cond-result - (map (cut regexp-exec condition-rx <>) keys)) - (rx-else-result - (map (cut regexp-exec else-rx <>) keys)) - (cond-no (count-if-else rx-cond-result)) - (else-no (count-if-else rx-else-result)) - (cond-idx (list-index (lambda (rx) (if rx #t #f)) rx-cond-result)) - (else-idx (list-index (lambda (rx) (if rx #t #f)) rx-else-result)) - (key-cond - (cond - ((or (and cond-idx else-idx (< cond-idx else-idx)) - (and cond-idx (not else-idx))) - (match:substring - (receive (head tail) - (split-at rx-cond-result cond-idx) (first tail)))) - ((or (and cond-idx else-idx (> cond-idx else-idx)) - (and (not cond-idx) else-idx)) - (match:substring - (receive (head tail) - (split-at rx-else-result else-idx) (first tail)))) - (else - "")))) - (values keys vals rx-cond-result - rx-else-result cond-no else-no key-cond))) - -(define (remove-cond entry cond) - (match entry - ((k v) - (list (cdr (member cond k)) v)))) - -(define (group-and-reduce-level entries group group-cond) - (let loop - ((true-group group) - (false-group '()) - (entries entries)) - (if (null? entries) - (values (reverse true-group) (reverse false-group) entries) - (let*-values (((entry) (first entries)) - ((keys vals rx-cond-result rx-else-result - cond-no else-no key-cond) - (analyze-entry-cond entry))) - (cond - ((and (>= (+ cond-no else-no) 1) (string= group-cond key-cond)) - (loop (cons (remove-cond entry group-cond) true-group) false-group - (cdr entries))) - ((and (>= (+ cond-no else-no) 1) (string= key-cond "else")) - (loop true-group (cons (remove-cond entry "else") false-group) - (cdr entries))) - (else - (values (reverse true-group) (reverse false-group) entries))))))) - -(define dependencies-rx - (make-regexp "([a-zA-Z0-9_-]+) *[^,]*,?")) - (define (hackage-name->package-name name) + "Given the NAME of a Cabal package, return the corresponding Guix name." (if (string-prefix? package-name-prefix name) (string-downcase name) (string-append package-name-prefix (string-downcase name)))) -(define (split-and-filter-dependencies ls names-to-filter) - "Split the comma separated list of dependencies LS coming from the Cabal -file, filter packages included in NAMES-TO-FILTER and return a list with -inputs suitable for the Guix package. Currently the version information is -discarded." - (define (split-at-comma-and-filter d) - (fold - (lambda (m seed) - (let* ((name (string-downcase (match:substring m 1))) - (pkg-name (hackage-name->package-name name))) - (if (member name names-to-filter) - seed - (cons (list pkg-name (list 'unquote (string->symbol pkg-name))) - seed)))) - '() - (list-matches dependencies-rx d))) - - (fold (lambda (d p) (append (split-at-comma-and-filter d) p)) '() ls)) - -(define* (dependencies-cond->sexp meta #:key (include-test-dependencies? #t)) - "META is the representation of a Cabal file as produced by 'read-cabal'. -Return an S-expression containing the list of dependencies as expected by the -'inputs' field of a package. The generated S-expressions may include -conditionals as defined in the cabal file. During this process we discard the -version information of the packages." - (define (take-dependencies meta) - (let ((key-start-exe (make-regexp "executable")) - (key-start-lib (make-regexp "library")) - (key-start-tests (make-regexp "test-suite")) - (key-end (make-regexp "build-depends"))) - (append - (key-start-end->entries meta key-start-exe key-end) - (key-start-end->entries meta key-start-lib key-end) - (if include-test-dependencies? - (key-start-end->entries meta key-start-tests key-end) - '())))) - - (let ((flags (get-flags (pre-process-entries-keys meta))) - (augmented-ghc-std-libs (append (key->values meta "name") - ghc-standard-libraries))) - (delete-duplicates - (let loop ((entries (take-dependencies meta)) - (result '())) - (if (null? entries) - (reverse result) - (let*-values (((entry) (first entries)) - ((keys vals rx-cond-result rx-else-result - cond-no else-no key-cond) - (analyze-entry-cond entry))) - (cond - ((= (+ cond-no else-no) 0) - (loop (cdr entries) - (append - (split-and-filter-dependencies vals - augmented-ghc-std-libs) - result))) - (else - (let-values (((true-group false-group entries) - (group-and-reduce-level entries '() - key-cond)) - ((cond-final) (eval-cabal-keywords - (conditional->sexp-like - (last (split-section key-cond))) - flags))) - (loop entries - (cond - ((or (eq? cond-final #t) (equal? cond-final '(not #f))) - (append (loop true-group '()) result)) - ((or (eq? cond-final #f) (equal? cond-final '(not #t))) - (append (loop false-group '()) result)) - (else - (let ((true-group-result (loop true-group '())) - (false-group-result (loop false-group '()))) - (cond - ((and (null? true-group-result) - (null? false-group-result)) - result) - ((null? false-group-result) - (cons `(unquote-splicing - (when ,cond-final ,true-group-result)) - result)) - ((null? true-group-result) - (cons `(unquote-splicing - (unless ,cond-final ,false-group-result)) - result)) - (else - (cons `(unquote-splicing - (if ,cond-final - ,true-group-result - ,false-group-result)) - result)))))))))))))))) - -;; Part 3: -;; -;; Retrive the desired package and its Cabal file from -;; http://hackage.haskell.org and construct the Guix package S-expression. - (define (hackage-fetch name-version) "Return the Cabal file for the package NAME-VERSION, or #f on failure. If the version part is omitted from the package name, then return the latest @@ -696,33 +111,63 @@ version." ((lst ...) `(list ,@(map string->license lst))) (_ #f))) -(define* (hackage-module->sexp meta #:key (include-test-dependencies? #t)) - "Return the `package' S-expression for a Cabal package. META is the + +(define (cabal-dependencies->names cabal include-test-dependencies?) + "Return the list of dependencies names from the CABAL package object. If +INCLUDE-TEST-DEPENDENCIES? is #f, do not include dependencies required by test +suites." + (let* ((lib (cabal-package-library cabal)) + (lib-deps (if (pair? lib) + (map cabal-dependency-name + (append-map cabal-library-dependencies lib)) + '())) + (exe (cabal-package-executables cabal)) + (exe-deps (if (pair? exe) + (map cabal-dependency-name + (append-map cabal-executable-dependencies exe)) + '())) + (ts (cabal-package-test-suites cabal)) + (ts-deps (if (pair? ts) + (map cabal-dependency-name + (append-map cabal-test-suite-dependencies ts)) + '()))) + (if include-test-dependencies? + (delete-duplicates (append lib-deps exe-deps ts-deps)) + (delete-duplicates (append lib-deps exe-deps))))) + +(define (filter-dependencies dependencies own-name) + "Filter the dependencies included with the GHC compiler from DEPENDENCIES, a +list with the names of dependencies. OWN-NAME is the name of the Cabal +package being processed and is used to filter references to itself." + (filter (lambda (d) (not (member (string-downcase d) + (cons own-name ghc-standard-libraries)))) + dependencies)) + +(define* (hackage-module->sexp cabal #:key (include-test-dependencies? #t)) + "Return the `package' S-expression for a Cabal package. CABAL is the representation of a Cabal file as produced by 'read-cabal'." (define name - (first (key->values meta "name"))) + (cabal-package-name cabal)) (define version - (first (key->values meta "version"))) - - (define description - (let*-values (((description) (key->values meta "description")) - ((lines last) - (split-at description (- (length description) 1)))) - (fold-right (lambda (line seed) (string-append line "\n" seed)) - (first last) lines))) + (cabal-package-version cabal)) (define source-url (string-append "http://hackage.haskell.org/package/" name "/" name "-" version ".tar.gz")) - ;; Several packages do not have an official home-page other than on Hackage. - (define home-page - (let ((home-page-entry (key->values meta "homepage"))) - (if (null? home-page-entry) - (string-append "http://hackage.haskell.org/package/" name) - (first home-page-entry)))) + (define dependencies + (let ((names + (map hackage-name->package-name + ((compose (cut filter-dependencies <> + (cabal-package-name cabal)) + (cut cabal-dependencies->names <> + include-test-dependencies?)) + cabal)))) + (map (lambda (name) + (list name (list 'unquote (string->symbol name)))) + names))) (define (maybe-inputs input-type inputs) (match inputs @@ -732,6 +177,11 @@ representation of a Cabal file as produced by 'read-cabal'." (list (list input-type (list 'quasiquote inputs)))))) + (define (maybe-arguments) + (if (not include-test-dependencies?) + '((arguments `(#:tests? #f))) + '())) + (let ((tarball (with-store store (download-to-store store source-url)))) `(package @@ -746,22 +196,33 @@ representation of a Cabal file as produced by 'read-cabal'." (bytevector->nix-base32-string (file-sha256 tarball)) "failed to download tar archive"))))) (build-system haskell-build-system) - ,@(maybe-inputs 'inputs - (dependencies-cond->sexp meta - #:include-test-dependencies? - include-test-dependencies?)) - (home-page ,home-page) - (synopsis ,@(key->values meta "synopsis")) - (description ,description) - (license ,(string->license (key->values meta "license")))))) - -(define* (hackage->guix-package module-name - #:key (include-test-dependencies? #t)) - "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, and return -the `package' S-expression corresponding to that package, or #f on failure." - (let ((module-meta (hackage-fetch module-name))) - (and=> module-meta (cut hackage-module->sexp <> - #:include-test-dependencies? - include-test-dependencies?)))) + ,@(maybe-inputs 'inputs dependencies) + ,@(maybe-arguments) + (home-page ,(cabal-package-home-page cabal)) + (synopsis ,(cabal-package-synopsis cabal)) + (description ,(cabal-package-description cabal)) + (license ,(string->license (cabal-package-license cabal)))))) + +(define* (hackage->guix-package package-name #:key + (include-test-dependencies? #t) + (port #f) + (cabal-environment '())) + "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, or, if the +called with keyword parameter PORT, from PORT. Return the `package' +S-expression corresponding to that package, or #f on failure. +CABAL-ENVIRONMENT is an alist defining the environment in which the Cabal +conditionals are evaluated. The accepted keys are: \"os\", \"arch\", \"impl\" +and the name of a flag. The value associated with a flag has to be either the +symbol 'true' or 'false'. The value associated with other keys has to conform +to the Cabal file format definition. The default value associated with the +keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\" +respectively." + (let ((cabal-meta (if port + (read-cabal port) + (hackage-fetch package-name)))) + (and=> cabal-meta (compose (cut hackage-module->sexp <> + #:include-test-dependencies? + include-test-dependencies?) + (cut eval-cabal <> cabal-environment))))) ;;; cabal.scm ends here diff --git a/guix/licenses.scm b/guix/licenses.scm index 1be35001ff..480442158d 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -37,6 +37,7 @@ freetype gpl1 gpl1+ gpl2 gpl2+ gpl3 gpl3+ fdl1.3+ + opl1.0+ isc ijg ibmpl1.0 @@ -206,6 +207,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://www.gnu.org/licenses/fdl.html" "https://www.gnu.org/licenses/license-list#FDL")) +(define opl1.0+ + (license "Open Publication License 1.0 or later" + "http://opencontent.org/openpub/" + "https://www.gnu.org/licenses/license-list#OpenPublicationL")) + (define isc (license "ISC" "http://directory.fsf.org/wiki/License:ISC" diff --git a/guix/monads.scm b/guix/monads.scm index f693e99a59..2196a9c991 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -112,6 +112,29 @@ (lambda (s) (syntax-violation 'return "return used outside of 'with-monad'" s))) +(define-syntax-rule (bind-syntax bind) + "Return a macro transformer that handles the expansion of '>>=' expressions +using BIND as the binary bind operator. + +This macro exists to allow the expansion of n-ary '>>=' expressions, even +though BIND is simply binary, as in: + + (with-monad %state-monad + (>>= (return 1) + (lift 1+ %state-monad) + (lift 1+ %state-monad))) +" + (lambda (stx) + (define (expand body) + (syntax-case body () + ((_ mval mproc) + #'(bind mval mproc)) + ((x mval mproc0 mprocs (... ...)) + (expand #'(>>= (>>= mval mproc0) + mprocs (... ...)))))) + + (expand stx))) + (define-syntax with-monad (lambda (s) "Evaluate BODY in the context of MONAD, and return its result." @@ -120,13 +143,13 @@ (eq? 'macro (syntax-local-binding #'monad)) ;; MONAD is a syntax transformer, so we can obtain the bind and return ;; methods by directly querying it. - #'(syntax-parameterize ((>>= (identifier-syntax (monad %bind))) + #'(syntax-parameterize ((>>= (bind-syntax (monad %bind))) (return (identifier-syntax (monad %return)))) body ...)) ((_ monad body ...) ;; MONAD refers to the <monad> record that represents the monad at run ;; time, so use the slow method. - #'(syntax-parameterize ((>>= (identifier-syntax + #'(syntax-parameterize ((>>= (bind-syntax (monad-bind monad))) (return (identifier-syntax (monad-return monad)))) @@ -225,8 +248,11 @@ MONAD---i.e., return a monadic function in MONAD." (return (apply proc args))))) (define (foldm monad mproc init lst) - "Fold MPROC over LST, a list of monadic values in MONAD, and return a -monadic value seeded by INIT." + "Fold MPROC over LST and return a monadic value seeded by INIT. + + (foldm %state-monad (lift2 cons %state-monad) '() '(a b c)) + => '(c b a) ;monadic +" (with-monad monad (let loop ((lst lst) (result init)) @@ -234,18 +260,21 @@ monadic value seeded by INIT." (() (return result)) ((head tail ...) - (mlet* monad ((item head) - (result (mproc item result))) - (loop tail result))))))) + (>>= (mproc head result) + (lambda (result) + (loop tail result)))))))) (define (mapm monad mproc lst) - "Map MPROC over LST, a list of monadic values in MONAD, and return a monadic -list. LST items are bound from left to right, so effects in MONAD are known -to happen in that order." + "Map MPROC over LST and return a monadic list. + + (mapm %state-monad (lift1 1+ %state-monad) '(0 1 2)) + => (1 2 3) ;monadic +" (mlet monad ((result (foldm monad (lambda (item result) - (mlet monad ((item (mproc item))) - (return (cons item result)))) + (>>= (mproc item) + (lambda (item) + (return (cons item result))))) '() lst))) (return (reverse result)))) @@ -268,20 +297,24 @@ evaluating each item of LST in sequence." (lambda (item) (seq tail (cons item result))))))))) -(define (anym monad proc lst) - "Apply PROC to the list of monadic values LST; return the first value, -lifted in MONAD, for which PROC returns true." +(define (anym monad mproc lst) + "Apply MPROC to the list of values LST; return as a monadic value the first +value for which MPROC returns a true monadic value or #f. For example: + + (anym %state-monad (lift1 odd? %state-monad) '(0 1 2)) + => #t ;monadic +" (with-monad monad (let loop ((lst lst)) (match lst (() (return #f)) ((head tail ...) - (mlet* monad ((value head) - (result -> (proc value))) - (if result - (return result) - (loop tail)))))))) + (>>= (mproc head) + (lambda (result) + (if result + (return result) + (loop tail))))))))) (define-syntax listm (lambda (s) diff --git a/guix/packages.scm b/guix/packages.scm index d5bf6dbf65..cbe6127f28 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -26,6 +26,7 @@ #:use-module (guix base32) #:use-module (guix derivations) #:use-module (guix build-system) + #:use-module (guix search-paths) #:use-module (guix gexp) #:use-module (ice-9 match) #:use-module (ice-9 vlist) @@ -36,7 +37,8 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:re-export (%current-system - %current-target-system) + %current-target-system + search-path-specification) ;for convenience #:export (origin origin? origin-uri @@ -52,11 +54,6 @@ origin-imported-modules base32 - <search-path-specification> - search-path-specification - search-path-specification? - search-path-specification->sexp - package package? package-name @@ -82,6 +79,8 @@ package-location package-field-location + package-direct-sources + package-transitive-sources package-direct-inputs package-transitive-inputs package-transitive-target-inputs @@ -186,26 +185,6 @@ representation." ((_ str) #'(nix-base32-string->bytevector str))))) -;; The specification of a search path. -(define-record-type* <search-path-specification> - search-path-specification make-search-path-specification - search-path-specification? - (variable search-path-specification-variable) ;string - (files search-path-specification-files) ;list of strings - (separator search-path-specification-separator ;string - (default ":")) - (file-type search-path-specification-file-type ;symbol - (default 'directory)) - (file-pattern search-path-specification-file-pattern ;#f | string - (default #f))) - -(define (search-path-specification->sexp spec) - "Return an sexp representing SPEC, a <search-path-specification>. The sexp -corresponds to the arguments expected by `set-path-environment-variable'." - (match spec - (($ <search-path-specification> variable files separator type pattern) - `(,variable ,files ,separator ,type ,pattern)))) - (define %supported-systems ;; This is the list of system types that are supported. By default, we ;; expect all packages to build successfully here. @@ -527,6 +506,28 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET." ((input rest ...) (loop rest (cons input result)))))) +(define (package-direct-sources package) + "Return all source origins associated with PACKAGE; including origins in +PACKAGE's inputs." + `(,@(or (and=> (package-source package) list) '()) + ,@(filter-map (match-lambda + ((_ (? origin? orig) _ ...) + orig) + (_ #f)) + (package-direct-inputs package)))) + +(define (package-transitive-sources package) + "Return PACKAGE's direct sources, and their direct sources, recursively." + (delete-duplicates + (concatenate (filter-map (match-lambda + ((_ (? origin? orig) _ ...) + (list orig)) + ((_ (? package? p) _ ...) + (package-direct-sources p)) + (_ #f)) + (bag-transitive-inputs + (package->bag package)))))) + (define (package-direct-inputs package) "Return all the direct inputs of PACKAGE---i.e, its direct inputs along with their propagated inputs." diff --git a/guix/profiles.scm b/guix/profiles.scm index 4bb309305b..28150affb6 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,8 +23,9 @@ (define-module (guix profiles) #:use-module (guix utils) #:use-module (guix records) - #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) #:use-module (guix gexp) #:use-module (guix monads) #:use-module (guix store) @@ -59,6 +61,7 @@ manifest-entry-output manifest-entry-item manifest-entry-dependencies + manifest-entry-search-paths manifest-pattern manifest-pattern? @@ -78,6 +81,7 @@ profile-manifest package->manifest-entry + packages->manifest %default-profile-hooks profile-derivation generation-number @@ -133,6 +137,8 @@ (default "out")) (item manifest-entry-item) ; package | store path (dependencies manifest-entry-dependencies ; (store path | package)* + (default '())) + (search-paths manifest-entry-search-paths ; search-path-specification* (default '()))) (define-record-type* <manifest-pattern> manifest-pattern @@ -165,25 +171,72 @@ omitted or #f, use the first output of PACKAGE." (version (package-version package)) (output (or output (car (package-outputs package)))) (item package) - (dependencies (delete-duplicates deps))))) + (dependencies (delete-duplicates deps)) + (search-paths (package-native-search-paths package))))) + +(define (packages->manifest packages) + "Return a list of manifest entries, one for each item listed in PACKAGES. +Elements of PACKAGES can be either package objects or package/string tuples +denoting a specific output of a package." + (manifest + (map (match-lambda + ((package output) + (package->manifest-entry package output)) + (package + (package->manifest-entry package))) + packages))) (define (manifest->gexp manifest) "Return a representation of MANIFEST as a gexp." (define (entry->gexp entry) (match entry - (($ <manifest-entry> name version output (? string? path) (deps ...)) - #~(#$name #$version #$output #$path #$deps)) - (($ <manifest-entry> name version output (? package? package) (deps ...)) + (($ <manifest-entry> name version output (? string? path) + (deps ...) (search-paths ...)) + #~(#$name #$version #$output #$path + (propagated-inputs #$deps) + (search-paths #$(map search-path-specification->sexp + search-paths)))) + (($ <manifest-entry> name version output (? package? package) + (deps ...) (search-paths ...)) #~(#$name #$version #$output - (ungexp package (or output "out")) #$deps)))) + (ungexp package (or output "out")) + (propagated-inputs #$deps) + (search-paths #$(map search-path-specification->sexp + search-paths)))))) (match manifest (($ <manifest> (entries ...)) - #~(manifest (version 1) + #~(manifest (version 2) (packages #$(map entry->gexp entries)))))) +(define (find-package name version) + "Return a package from the distro matching NAME and possibly VERSION. This +procedure is here for backward-compatibility and will eventually vanish." + (define find-best-packages-by-name ;break abstractions + (module-ref (resolve-interface '(gnu packages)) + 'find-best-packages-by-name)) + + ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name'; the + ;; former traverses the module tree only once and then allows for efficient + ;; access via a vhash. + (match (find-best-packages-by-name name version) + ((p _ ...) p) + (_ + (match (find-best-packages-by-name name #f) + ((p _ ...) p) + (_ #f))))) + (define (sexp->manifest sexp) "Parse SEXP as a manifest." + (define (infer-search-paths name version) + ;; Infer the search path specifications for NAME-VERSION by looking up a + ;; same-named package in the distro. Useful for the old manifest formats + ;; that did not store search path info. + (let ((package (find-package name version))) + (if package + (package-native-search-paths package) + '()))) + (match sexp (('manifest ('version 0) ('packages ((name version output path) ...))) @@ -193,7 +246,8 @@ omitted or #f, use the first output of PACKAGE." (name name) (version version) (output output) - (item path))) + (item path) + (search-paths (infer-search-paths name version)))) name version output path))) ;; Version 1 adds a list of propagated inputs to the @@ -215,11 +269,31 @@ omitted or #f, use the first output of PACKAGE." (version version) (output output) (item path) - (dependencies deps)))) + (dependencies deps) + (search-paths (infer-search-paths name version))))) name version output path deps))) + ;; Version 2 adds search paths and is slightly more verbose. + (('manifest ('version 2 minor-version ...) + ('packages ((name version output path + ('propagated-inputs deps) + ('search-paths search-paths) + extra-stuff ...) + ...))) + (manifest + (map (lambda (name version output path deps search-paths) + (manifest-entry + (name name) + (version version) + (output output) + (item path) + (dependencies deps) + (search-paths (map sexp->search-path-specification + search-paths)))) + name version output path deps search-paths))) (_ - (error "unsupported manifest format" manifest)))) + (raise (condition + (&message (message "unsupported manifest format"))))))) (define (read-manifest port) "Return the packages listed in MANIFEST." @@ -409,7 +483,7 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." (module-ref (resolve-interface '(gnu packages haskell)) 'ghc)) (define build - #~(begin + #~(begin (use-modules (guix build utils) (srfi srfi-1) (srfi srfi-26) (ice-9 ftw)) @@ -418,20 +492,20 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." (let* ((base (basename #+ghc))) (string-drop base (+ 1 (string-index base #\-))))) - + (define db-subdir (string-append "lib/" ghc-name-version "/package.conf.d")) (define db-dir (string-append #$output "/" db-subdir)) - + (define (conf-files top) (find-files (string-append top "/" db-subdir) "\\.conf$")) (define (copy-conf-file conf) (let ((base (basename conf))) (copy-file conf (string-append db-dir "/" base)))) - + (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir) (for-each copy-conf-file (append-map conf-files @@ -443,12 +517,14 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." (for-each delete-file (find-files db-dir "\\.conf$")) success))) - ;; Don't depend on GHC when there's nothing to do. - (and (any (cut string-prefix? "ghc" <>) - (map manifest-entry-name (manifest-entries manifest))) - (gexp->derivation "ghc-package-cache" build - #:modules '((guix build utils)) - #:local-build? #t))) + (with-monad %store-monad + ;; Don't depend on GHC when there's nothing to do. + (if (any (cut string-prefix? "ghc" <>) + (map manifest-entry-name (manifest-entries manifest))) + (gexp->derivation "ghc-package-cache" build + #:modules '((guix build utils)) + #:local-build? #t) + (return #f)))) (define (ca-certificate-bundle manifest) "Return a derivation that builds a single-file bundle containing the CA @@ -513,12 +589,92 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." #:modules '((guix build utils)) #:local-build? #t)) +(define (gtk-icon-themes manifest) + "Return a derivation that unions all icon themes from manifest entries and +creates the GTK+ 'icon-theme.cache' file for each theme." + ;; Return as a monadic value the GTK+ package or store path referenced by the + ;; manifest ENTRY, or #f if not referenced. + (define (entry-lookup-gtk+ entry) + (define (find-among-inputs inputs) + (find (lambda (input) + (and (package? input) + (string=? "gtk+" (package-name input)))) + inputs)) + + (define (find-among-store-items items) + (find (lambda (item) + (equal? "gtk+" + (package-name->name+version + (store-path-package-name item)))) + items)) + + ;; TODO: Factorize. + (define references* + (store-lift references)) + + (with-monad %store-monad + (match (manifest-entry-item entry) + ((? package? package) + (match (package-transitive-inputs package) + (((labels inputs . _) ...) + (return (find-among-inputs inputs))))) + ((? string? item) + (mlet %store-monad ((refs (references* item))) + (return (find-among-store-items refs))))))) + + (define (manifest-lookup-gtk+ manifest) + (anym %store-monad + entry-lookup-gtk+ (manifest-entries manifest))) + + (mlet %store-monad ((gtk+ (manifest-lookup-gtk+ manifest))) + (define build + #~(begin + (use-modules (guix build utils) + (guix build union) + (guix build profiles) + (srfi srfi-26) + (ice-9 ftw)) + + (let* ((destdir (string-append #$output "/share/icons")) + (icondirs (filter file-exists? + (map (cut string-append <> "/share/icons") + '#$(manifest-inputs manifest)))) + (update-icon-cache (string-append + #+gtk+ "/bin/gtk-update-icon-cache"))) + + ;; Union all the icons. + (mkdir-p (string-append #$output "/share")) + (union-build destdir icondirs) + + ;; Update the 'icon-theme.cache' file for each icon theme. + (for-each + (lambda (theme) + (let ((dir (string-append destdir "/" theme))) + ;; Occasionally DESTDIR contains plain files, such as + ;; "abiword_48.png". Ignore these. + (when (file-is-directory? dir) + (ensure-writable-directory dir) + (system* update-icon-cache "-t" dir)))) + (scandir destdir (negate (cut member <> '("." "..")))))))) + + ;; Don't run the hook when there's nothing to do. + (if gtk+ + (gexp->derivation "gtk-icon-themes" build + #:modules '((guix build utils) + (guix build union) + (guix build profiles) + (guix search-paths) + (guix records)) + #:local-build? #t) + (return #f)))) + (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called by ;; default when making a non-empty profile. (list info-dir-file ghc-package-cache-file - ca-certificate-bundle)) + ca-certificate-bundle + gtk-icon-themes)) (define* (profile-derivation manifest #:key @@ -529,29 +685,42 @@ the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." (mlet %store-monad ((extras (if (null? (manifest-entries manifest)) (return '()) (sequence %store-monad - (filter-map (lambda (hook) - (hook manifest)) - hooks))))) + (map (lambda (hook) + (hook manifest)) + hooks))))) (define inputs - (append (map gexp-input extras) + (append (filter-map (lambda (drv) + (and (derivation? drv) + (gexp-input drv))) + extras) (manifest-inputs manifest))) (define builder #~(begin - (use-modules (ice-9 pretty-print) - (guix build union)) + (use-modules (guix build profiles) + (guix search-paths)) (setvbuf (current-output-port) _IOLBF) (setvbuf (current-error-port) _IOLBF) - (union-build #$output '#$inputs - #:log-port (%make-void-port "w")) - (call-with-output-file (string-append #$output "/manifest") - (lambda (p) - (pretty-print '#$(manifest->gexp manifest) p))))) + (define search-paths + ;; Search paths of MANIFEST's packages, converted back to their + ;; record form. + (map sexp->search-path-specification + '#$(map search-path-specification->sexp + (append-map manifest-entry-search-paths + (manifest-entries manifest))))) + + (build-profile #$output '#$inputs + #:manifest '#$(manifest->gexp manifest) + #:search-paths search-paths))) (gexp->derivation "profile" builder - #:modules '((guix build union)) + #:modules '((guix build profiles) + (guix build union) + (guix build utils) + (guix search-paths) + (guix records)) #:local-build? #t))) (define (profile-regexp profile) diff --git a/guix/records.scm b/guix/records.scm index fd17e135e1..db59a99052 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -42,102 +42,106 @@ (format #f fmt args ...) form)))) -(define* (make-syntactic-constructor type name ctor fields - #:key (thunked '()) (defaults '()) - (delayed '())) - "Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects +(eval-when (expand load eval) + ;; This procedure is a syntactic helper used by 'define-record-type*', hence + ;; 'eval-when'. + + (define* (make-syntactic-constructor type name ctor fields + #:key (thunked '()) (defaults '()) + (delayed '())) + "Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects all of FIELDS to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked fields, and DELAYED is the list of identifiers of delayed fields." - (with-syntax ((type type) - (name name) - (ctor ctor) - (expected fields) - (defaults defaults)) - #`(define-syntax name - (lambda (s) - (define (record-inheritance orig-record field+value) - ;; Produce code that returns a record identical to ORIG-RECORD, - ;; except that values for the FIELD+VALUE alist prevail. - (define (field-inherited-value f) - (and=> (find (lambda (x) - (eq? f (car (syntax->datum x)))) - field+value) - car)) - - ;; Make sure there are no unknown field names. - (let* ((fields (map (compose car syntax->datum) field+value)) - (unexpected (lset-difference eq? fields 'expected))) - (when (pair? unexpected) - (record-error 'name s "extraneous field initializers ~a" - unexpected))) - - #`(make-struct type 0 - #,@(map (lambda (field index) - (or (field-inherited-value field) - #`(struct-ref #,orig-record - #,index))) - 'expected - (iota (length 'expected))))) - - (define (thunked-field? f) - (memq (syntax->datum f) '#,thunked)) - - (define (delayed-field? f) - (memq (syntax->datum f) '#,delayed)) - - (define (wrap-field-value f value) - (cond ((thunked-field? f) - #`(lambda () #,value)) - ((delayed-field? f) - #`(delay #,value)) - (else value))) - - (define (field-bindings field+value) - ;; Return field to value bindings, for use in 'let*' below. - (map (lambda (field+value) - (syntax-case field+value () - ((field value) - #`(field - #,(wrap-field-value #'field #'value))))) - field+value)) - - (syntax-case s (inherit #,@fields) - ((_ (inherit orig-record) (field value) (... ...)) - #`(let* #,(field-bindings #'((field value) (... ...))) - #,(record-inheritance #'orig-record - #'((field value) (... ...))))) - ((_ (field value) (... ...)) - (let ((fields (map syntax->datum #'(field (... ...)))) - (dflt (map (match-lambda - ((f v) - (list (syntax->datum f) v))) - #'defaults))) - - (define (field-value f) - (or (and=> (find (lambda (x) - (eq? f (car (syntax->datum x)))) - #'((field value) (... ...))) - car) - (let ((value - (car (assoc-ref dflt (syntax->datum f))))) - (wrap-field-value f value)))) - - (let ((fields (append fields (map car dflt)))) - (cond ((lset= eq? fields 'expected) - #`(let* #,(field-bindings - #'((field value) (... ...))) - (ctor #,@(map field-value 'expected)))) - ((pair? (lset-difference eq? fields 'expected)) - (record-error 'name s - "extraneous field initializers ~a" - (lset-difference eq? fields - 'expected))) - (else - (record-error 'name s - "missing field initializers ~a" - (lset-difference eq? 'expected - fields)))))))))))) + (with-syntax ((type type) + (name name) + (ctor ctor) + (expected fields) + (defaults defaults)) + #`(define-syntax name + (lambda (s) + (define (record-inheritance orig-record field+value) + ;; Produce code that returns a record identical to ORIG-RECORD, + ;; except that values for the FIELD+VALUE alist prevail. + (define (field-inherited-value f) + (and=> (find (lambda (x) + (eq? f (car (syntax->datum x)))) + field+value) + car)) + + ;; Make sure there are no unknown field names. + (let* ((fields (map (compose car syntax->datum) field+value)) + (unexpected (lset-difference eq? fields 'expected))) + (when (pair? unexpected) + (record-error 'name s "extraneous field initializers ~a" + unexpected))) + + #`(make-struct type 0 + #,@(map (lambda (field index) + (or (field-inherited-value field) + #`(struct-ref #,orig-record + #,index))) + 'expected + (iota (length 'expected))))) + + (define (thunked-field? f) + (memq (syntax->datum f) '#,thunked)) + + (define (delayed-field? f) + (memq (syntax->datum f) '#,delayed)) + + (define (wrap-field-value f value) + (cond ((thunked-field? f) + #`(lambda () #,value)) + ((delayed-field? f) + #`(delay #,value)) + (else value))) + + (define (field-bindings field+value) + ;; Return field to value bindings, for use in 'let*' below. + (map (lambda (field+value) + (syntax-case field+value () + ((field value) + #`(field + #,(wrap-field-value #'field #'value))))) + field+value)) + + (syntax-case s (inherit #,@fields) + ((_ (inherit orig-record) (field value) (... ...)) + #`(let* #,(field-bindings #'((field value) (... ...))) + #,(record-inheritance #'orig-record + #'((field value) (... ...))))) + ((_ (field value) (... ...)) + (let ((fields (map syntax->datum #'(field (... ...)))) + (dflt (map (match-lambda + ((f v) + (list (syntax->datum f) v))) + #'defaults))) + + (define (field-value f) + (or (and=> (find (lambda (x) + (eq? f (car (syntax->datum x)))) + #'((field value) (... ...))) + car) + (let ((value + (car (assoc-ref dflt (syntax->datum f))))) + (wrap-field-value f value)))) + + (let ((fields (append fields (map car dflt)))) + (cond ((lset= eq? fields 'expected) + #`(let* #,(field-bindings + #'((field value) (... ...))) + (ctor #,@(map field-value 'expected)))) + ((pair? (lset-difference eq? fields 'expected)) + (record-error 'name s + "extraneous field initializers ~a" + (lset-difference eq? fields + 'expected))) + (else + (record-error 'name s + "missing field initializers ~a" + (lset-difference eq? 'expected + fields))))))))))))) (define-syntax define-record-type* (lambda (s) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index e9900689fa..eedebb4bac 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -82,12 +82,6 @@ to stdout upon success." (leave (_ "error: corrupt signature data: ~a~%") (canonical-sexp->string signature))))) -(define %default-port-conversion-strategy - ;; This fluid is in Guile > 2.0.5. - (if (defined? '%default-port-conversion-strategy) - (@ (guile) %default-port-conversion-strategy) - (make-fluid #f))) - ;;; ;;; Entry point with 'openssl'-compatible interface. We support this diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 370c2a37ff..2307f76b42 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -37,6 +37,7 @@ #:autoload (guix download) (download-to-store) #:export (%standard-build-options set-build-options-from-command-line + set-build-options-from-command-line* show-build-options-help guix-build)) @@ -139,6 +140,9 @@ options handled by 'set-build-options-from-command-line', and listed in #:print-build-trace (assoc-ref opts 'print-build-trace?) #:verbosity (assoc-ref opts 'verbosity))) +(define set-build-options-from-command-line* + (store-lift set-build-options-from-command-line)) + (define %standard-build-options ;; List of standard command-line options for tools that build something. (list (option '(#\L "load-path") #t #f @@ -228,6 +232,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (display (_ " -S, --source build the packages' source derivations")) (display (_ " + --sources[=TYPE] build source derivations; TYPE may optionally be one + of \"package\", \"all\" (default), or \"transitive\"")) + (display (_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) @@ -262,10 +269,22 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix build"))) - (option '(#\S "source") #f #f (lambda (opt name arg result) - (alist-cons 'source? #t result))) + (alist-cons 'source #t result))) + (option '("sources") #f #t + (lambda (opt name arg result) + (match arg + ("package" + (alist-cons 'source #t result)) + ((or "all" #f) + (alist-cons 'source package-direct-sources result)) + ("transitive" + (alist-cons 'source package-transitive-sources result)) + (else + (leave (_ "invalid argument: '~a' option argument: ~a, ~ +must be one of 'package', 'all', or 'transitive'~%") + name arg))))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg @@ -308,28 +327,34 @@ build." (triplet (cut package-cross-derivation <> <> triplet <>)))) - (define src? (assoc-ref opts 'source?)) + (define src (assoc-ref opts 'source)) (define sys (assoc-ref opts 'system)) (define graft? (assoc-ref opts 'graft?)) (parameterize ((%graft? graft?)) (let ((opts (options/with-source store (options/resolve-packages store opts)))) - (filter-map (match-lambda - (('argument . (? package? p)) - (if src? + (concatenate + (filter-map (match-lambda + (('argument . (? package? p)) + (match src + (#f + (list (package->derivation store p sys))) + (#t (let ((s (package-source p))) - (package-source-derivation store s)) - (package->derivation store p sys))) - (('argument . (? derivation? drv)) - drv) - (('argument . (? derivation-path? drv)) - (call-with-input-file drv read-derivation)) - (('argument . (? store-path?)) - ;; Nothing to do; maybe for --log-file. - #f) - (_ #f)) - opts)))) + (list (package-source-derivation store s)))) + (proc + (map (cut package-source-derivation store <>) + (proc p))))) + (('argument . (? derivation? drv)) + (list drv)) + (('argument . (? derivation-path? drv)) + (list (call-with-input-file drv read-derivation))) + (('argument . (? store-path?)) + ;; Nothing to do; maybe for --log-file. + #f) + (_ #f)) + opts))))) (define (options/resolve-packages store opts) "Return OPTS with package specification strings replaced by actual diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 80ae924410..42178091e6 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; Copyright © 2014, 2015 David Thompson <davet@gnu.org> +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,9 +23,9 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) + #:use-module (guix search-paths) #:use-module (guix utils) #:use-module (guix monads) - #:use-module (guix build utils) #:use-module (guix scripts build) #:use-module (gnu packages) #:use-module (ice-9 format) @@ -35,32 +36,20 @@ #:use-module (srfi srfi-98) #:export (guix-environment)) -(define (for-each-search-path proc inputs derivations pure?) - "Apply PROC for each native search path in INPUTS in addition to 'PATH'. -Use the output paths of DERIVATIONS to build each search path. When PURE? is -#t, the existing search path value is ignored. Otherwise, the existing search -path value is appended." - (let ((paths (append-map (lambda (drv) - (map (match-lambda - ((_ . output) - (derivation-output-path output))) - (derivation-outputs drv))) - derivations))) - (for-each (match-lambda - (($ <search-path-specification> - variable directories separator) - (let* ((current (getenv variable)) - (path (search-path-as-list directories paths)) - (value (list->search-path-as-string path separator))) - (proc variable - (if (and current (not pure?)) - (string-append value separator current) - value))))) - (cons* (search-path-specification - (variable "PATH") - (files '("bin" "sbin"))) - (delete-duplicates - (append-map package-native-search-paths inputs)))))) +(define (evaluate-input-search-paths inputs derivations) + "Evaluate the native search paths of INPUTS, a list of packages, of the +outputs of DERIVATIONS, and return a list of search-path/value pairs." + (let ((directories (append-map (lambda (drv) + (map (match-lambda + ((_ . output) + (derivation-output-path output))) + (derivation-outputs drv))) + derivations)) + (paths (cons $PATH + (delete-duplicates + (append-map package-native-search-paths + inputs))))) + (evaluate-search-paths paths directories))) ;; Protect some env vars from purification. Borrowed from nix-shell. (define %precious-variables @@ -80,15 +69,26 @@ as 'HOME' and 'USER' are left untouched." PURE? is #t, unset the variables in the current environment. Otherwise, augment existing enviroment variables with additional search paths." (when pure? (purify-environment)) - (for-each-search-path setenv inputs derivations pure?)) + (for-each (match-lambda + ((($ <search-path-specification> variable _ separator) . value) + (let ((current (getenv variable))) + (setenv variable + (if (and current (not pure?)) + (string-append value separator current) + value))))) + (evaluate-input-search-paths inputs derivations))) (define (show-search-paths inputs derivations pure?) "Display the needed search paths to build an environment that contains the packages within INPUTS. When PURE? is #t, do not augment existing environment variables with additional search paths." - (for-each-search-path (lambda (variable value) - (format #t "export ~a=\"~a\"~%" variable value)) - inputs derivations pure?)) + (for-each (match-lambda + ((search-path . value) + (display + (search-path-definition search-path value + #:kind (if pure? 'exact 'prefix))) + (newline))) + (evaluate-input-search-paths inputs derivations))) (define (show-help) (display (_ "Usage: guix environment [OPTION]... PACKAGE... @@ -103,6 +103,9 @@ shell command in that environment.\n")) (display (_ " -E, --exec=COMMAND execute COMMAND in new environment")) (display (_ " + --ad-hoc include all specified packages in the environment instead + of only their inputs")) + (display (_ " --pure unset existing environment variables")) (display (_ " --search-paths display needed environment variable definitions")) @@ -147,6 +150,9 @@ shell command in that environment.\n")) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) + (option '("ad-hoc") #f #f + (lambda (opt name arg result) + (alist-cons 'ad-hoc? #t result))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t result))) @@ -191,12 +197,17 @@ packages." (delete-duplicates (append-map transitive-inputs packages))) -;; TODO: Deduplicate these. -(define show-what-to-build* - (store-lift show-what-to-build)) - -(define set-build-options-from-command-line* - (store-lift set-build-options-from-command-line)) +(define (packages+propagated-inputs packages) + "Return a list containing PACKAGES plus all of their propagated inputs." + (delete-duplicates + (append packages + (map (match-lambda + ((or (_ (? package? package)) + (_ (? package? package) _)) + package) + (_ #f)) + (append-map package-transitive-propagated-inputs + packages))))) (define (build-inputs inputs opts) "Build the packages in INPUTS using the build options in OPTS." @@ -225,9 +236,12 @@ packages." (let* ((opts (parse-command-line args %options (list %default-options) #:argument-handler handle-argument)) (pure? (assoc-ref opts 'pure)) + (ad-hoc? (assoc-ref opts 'ad-hoc?)) (command (assoc-ref opts 'exec)) - (inputs (packages->transitive-inputs - (pick-all (options/resolve-packages opts) 'package))) + (packages (pick-all (options/resolve-packages opts) 'package)) + (inputs (if ad-hoc? + (packages+propagated-inputs packages) + (packages->transitive-inputs packages))) (drvs (run-with-store store (mbegin %store-monad (set-guile-for-build (default-guile)) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index ed16cab8f9..6403893687 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,6 +44,8 @@ Invoke the garbage collector.\n")) (display (_ " -d, --delete attempt to delete PATHS")) (display (_ " + --optimize optimize the store by deduplicating identical files")) + (display (_ " --list-dead list dead paths")) (display (_ " --list-live list live paths")) @@ -56,6 +58,11 @@ Invoke the garbage collector.\n")) --referrers list the referrers of PATHS")) (newline) (display (_ " + --verify[=OPTS] verify the integrity of the store; OPTS is a + comma-separated combination of 'repair' and + 'contents'")) + (newline) + (display (_ " -h, --help display this help and exit")) (display (_ " -V, --version display version information and exit")) @@ -88,6 +95,21 @@ Invoke the garbage collector.\n")) (lambda (opt name arg result) (alist-cons 'action 'delete (alist-delete 'action result)))) + (option '("optimize") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'optimize + (alist-delete 'action result)))) + (option '("verify") #f #t + (let ((not-comma (char-set-complement (char-set #\,)))) + (lambda (opt name arg result) + (let ((options (if arg + (map string->symbol + (string-tokenize arg not-comma)) + '()))) + (alist-cons 'action 'verify + (alist-cons 'verify-options options + (alist-delete 'action + result))))))) (option '("list-dead") #f #f (lambda (opt name arg result) (alist-cons 'action 'list-dead @@ -162,13 +184,21 @@ Invoke the garbage collector.\n")) (collect-garbage store min-freed) (collect-garbage store)))) ((delete) - (delete-paths store paths)) + (delete-paths store (map direct-store-path paths))) ((list-references) (list-relatives references)) ((list-requisites) (list-relatives requisites)) ((list-referrers) (list-relatives referrers)) + ((optimize) + (optimize-store store)) + ((verify) + (let ((options (assoc-ref opts 'verify-options))) + (exit + (verify-store store + #:check-contents? (memq 'contents options) + #:repair? (memq 'repair options))))) ((list-dead) (for-each (cut simple-format #t "~a~%" <>) (dead-paths store))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 06b4c17573..45ce092f13 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -86,6 +86,7 @@ rather than \\n." Run IMPORTER with ARGS.\n")) (newline) (display (_ "IMPORTER must be one of the importers listed below:\n")) + (newline) (format #t "~{ ~a~%~}" importers) (display (_ " -h, --help display this help and exit")) diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index f7c18cd3bf..e5e9b0ed64 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -34,7 +34,9 @@ ;;; (define %default-options - '((include-test-dependencies? . #t))) + '((include-test-dependencies? . #t) + (read-from-stdin? . #f) + ('cabal-environment . '()))) (define (show-help) (display (_ "Usage: guix import hackage PACKAGE-NAME @@ -45,8 +47,13 @@ package will be generated. If no version suffix is pecified, then the generated package definition will correspond to the latest available version.\n")) (display (_ " + -e ALIST, --cabal-environment=ALIST + specify environment for Cabal evaluation")) + (display (_ " -h, --help display this help and exit")) (display (_ " + -s, --stdin read from standard input")) + (display (_ " -t, --no-test-dependencies don't include test only dependencies")) (display (_ " -V, --version display version information and exit")) @@ -67,6 +74,16 @@ version.\n")) (alist-cons 'include-test-dependencies? #f (alist-delete 'include-test-dependencies? result)))) + (option '(#\s "stdin") #f #f + (lambda (opt name arg result) + (alist-cons 'read-from-stdin? #t + (alist-delete 'read-from-stdin? + result)))) + (option '(#\e "cabal-environment") #t #f + (lambda (opt name arg result) + (alist-cons 'cabal-environment (read/eval arg) + (alist-delete 'cabal-environment + result)))) %standard-import-options)) @@ -84,23 +101,42 @@ version.\n")) (alist-cons 'argument arg result)) %default-options)) + (define (run-importer package-name opts error-fn) + (let ((sexp (hackage->guix-package + package-name + #:include-test-dependencies? + (assoc-ref opts 'include-test-dependencies?) + #:port (if (assoc-ref opts 'read-from-stdin?) + (current-input-port) + #f) + #:cabal-environment + (assoc-ref opts 'cabal-environment)))) + (unless sexp (error-fn)) + sexp)) + (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) value) (_ #f)) (reverse opts)))) - (match args - ((package-name) - (let ((sexp (hackage->guix-package - package-name - #:include-test-dependencies? - (assoc-ref opts 'include-test-dependencies?)))) - (unless sexp - (leave (_ "failed to download cabal file for package '~a'~%") - package-name)) - sexp)) - (() - (leave (_ "too few arguments~%"))) - ((many ...) - (leave (_ "too many arguments~%")))))) + (if (assoc-ref opts 'read-from-stdin?) + (match args + (() + (run-importer "stdin" opts + (lambda () + (leave (_ "failed to import cabal file from '~a'~%")) + package-name))) + ((many ...) + (leave (_ "too many arguments~%")))) + (match args + ((package-name) + (run-importer package-name opts + (lambda () + (leave + (_ "failed to download cabal file for package '~a'~%")) + package-name))) + (() + (leave (_ "too few arguments~%"))) + ((many ...) + (leave (_ "too many arguments~%"))))))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index cced1bda66..3740b71d5e 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -28,6 +28,7 @@ #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix gnu-maintenance) + #:use-module (guix monads) #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -41,6 +42,7 @@ #:use-module (web request) #:use-module (web response) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-6) ;Unicode string ports #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -71,6 +73,25 @@ (package-full-name package) message))) +(define (call-with-accumulated-warnings thunk) + "Call THUNK, accumulating any warnings in the current state, using the state +monad." + (let ((port (open-output-string))) + (mlet %state-monad ((state (current-state)) + (result -> (parameterize ((guix-warning-port port)) + (thunk))) + (warning -> (get-output-string port))) + (mbegin %state-monad + (munless (string=? "" warning) + (set-current-state (cons warning state))) + (return result))))) + +(define-syntax-rule (with-accumulated-warnings exp ...) + "Evaluate EXP and accumulate warnings in the state monad." + (call-with-accumulated-warnings + (lambda () + exp ...))) + ;;; ;;; Checkers @@ -287,20 +308,22 @@ response from URI, and additional details, such as the actual HTTP response." (values 'unknown-protocol #f))))) (define (validate-uri uri package field) - "Return #t if the given URI can be reached, otherwise emit a + "Return #t if the given URI can be reached, otherwise return #f and emit a warning for PACKAGE mentionning the FIELD." (let-values (((status argument) (probe-uri uri))) (case status ((http-response) (or (= 200 (response-code argument)) - (emit-warning package - (format #f - (_ "URI ~a not reachable: ~a (~s)") - (uri->string uri) - (response-code argument) - (response-reason-phrase argument)) - field))) + (begin + (emit-warning package + (format #f + (_ "URI ~a not reachable: ~a (~s)") + (uri->string uri) + (response-code argument) + (response-reason-phrase argument)) + field) + #f))) ((ftp-response) (match argument (('ok) #t) @@ -309,7 +332,8 @@ warning for PACKAGE mentionning the FIELD." (format #f (_ "URI ~a not reachable: ~a (~s)") (uri->string uri) - code (string-trim-both message)))))) + code (string-trim-both message))) + #f))) ((getaddrinfo-error) (emit-warning package (format #f @@ -432,6 +456,16 @@ descriptions maintained upstream." (define (check-source package) "Emit a warning if PACKAGE has an invalid 'source' field, or if that 'source' is not reachable." + (define (try-uris uris) + (run-with-state + (anym %state-monad + (lambda (uri) + (with-accumulated-warnings + (validate-uri uri package 'source))) + (append-map (cut maybe-expand-mirrors <> %mirrors) + uris)) + '())) + (let ((origin (package-source package))) (when (and origin (eqv? (origin-method origin) url-fetch)) @@ -439,10 +473,24 @@ descriptions maintained upstream." (uris (if (list? strings) (map string->uri strings) (list (string->uri strings))))) + ;; Just make sure that at least one of the URIs is valid. - (any (cut validate-uri <> package 'source) - (append-map (cut maybe-expand-mirrors <> %mirrors) - uris)))))) + (call-with-values + (lambda () (try-uris uris)) + (lambda (success? warnings) + ;; When everything fails, report all of WARNINGS, otherwise don't + ;; report anything. + ;; + ;; XXX: Ideally we'd still allow warnings to be raised if *some* + ;; URIs are unreachable, but distinguish that from the error case + ;; where *all* the URIs are unreachable. + (unless success? + (emit-warning package + (_ "all the source URIs are unreachable:") + 'source) + (for-each (lambda (warning) + (display warning (guix-warning-port))) + (reverse warnings))))))))) (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." @@ -527,7 +575,8 @@ descriptions maintained upstream." (define (show-help) (display (_ "Usage: guix lint [OPTION]... [PACKAGE]... -Run a set of checkers on the specified package; if none is specified, run the checkers on all packages.\n")) +Run a set of checkers on the specified package; if none is specified, +run the checkers on all packages.\n")) (display (_ " -c, --checkers=CHECKER1,CHECKER2... only run the specificed checkers")) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 1e724b4e19..d9f38fb8bc 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -25,6 +25,7 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) + #:use-module (guix search-paths) #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix config) @@ -52,6 +53,7 @@ roll-back delete-generation delete-generations + display-search-paths guix-package)) (define %store @@ -89,6 +91,15 @@ return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if %current-profile profile)) +(define (user-friendly-profile profile) + "Return either ~/.guix-profile if that's what PROFILE refers to, directly or +indirectly, or PROFILE." + (if (and %user-profile-directory + (false-if-exception + (string=? (readlink %user-profile-directory) profile))) + %user-profile-directory + profile)) + (define (link-to-empty-profile store generation) "Link GENERATION, a string, to the empty profile." (let* ((drv (run-with-store store @@ -365,77 +376,35 @@ an output path different than CURRENT-PATH." ;;; Search paths. ;;; -(define-syntax-rule (with-null-error-port exp) - "Evaluate EXP with the error port pointing to the bit bucket." - (with-error-to-port (%make-void-port "w") - (lambda () exp))) - (define* (search-path-environment-variables entries profile - #:optional (getenv getenv)) + #:optional (getenv getenv) + #:key (kind 'exact)) "Return environment variable definitions that may be needed for the use of ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the -current settings and report only settings not already effective." - - ;; Prefer ~/.guix-profile to the real profile directory name. - (let ((profile (if (and %user-profile-directory - (false-if-exception - (string=? (readlink %user-profile-directory) - profile))) - %user-profile-directory - profile))) - - ;; The search path info is not stored in the manifest. Thus, we infer the - ;; search paths from same-named packages found in the distro. - - (define manifest-entry->package - (match-lambda - (($ <manifest-entry> name version) - ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name'; - ;; the former traverses the module tree only once and then allows for - ;; efficient access via a vhash. - (match (find-best-packages-by-name name version) - ((p _ ...) p) - (_ - (match (find-best-packages-by-name name #f) - ((p _ ...) p) - (_ #f))))))) - - (define search-path-definition - (match-lambda - (($ <search-path-specification> variable files separator - type pattern) - (let* ((values (or (and=> (getenv variable) - (cut string-tokenize* <> separator)) - '())) - ;; Add a trailing slash to force symlinks to be treated as - ;; directories when 'find-files' traverses them. - (files (if pattern - (map (cut string-append <> "/") files) - files)) - - ;; XXX: Silence 'find-files' when it stumbles upon non-existent - ;; directories (see - ;; <http://lists.gnu.org/archive/html/guix-devel/2015-01/msg00269.html>.) - (path (with-null-error-port - (search-path-as-list files (list profile) - #:type type - #:pattern pattern)))) - (if (every (cut member <> values) path) - #f - (format #f "export ~a=\"~a\"" - variable - (string-join path separator))))))) - - (let* ((packages (filter-map manifest-entry->package entries)) - (search-paths (delete-duplicates - (append-map package-native-search-paths - packages)))) - (filter-map search-path-definition search-paths)))) - -(define (display-search-paths entries profile) +current settings and report only settings not already effective. KIND +must be one of 'exact, 'prefix, or 'suffix, depending on the kind of search +path definition to be returned." + (let ((search-paths (delete-duplicates + (cons $PATH + (append-map manifest-entry-search-paths + entries))))) + (filter-map (match-lambda + ((spec . value) + (let ((variable (search-path-specification-variable spec)) + (sep (search-path-specification-separator spec))) + (environment-variable-definition variable value + #:separator sep + #:kind kind)))) + (evaluate-search-paths search-paths (list profile) + getenv)))) + +(define* (display-search-paths entries profile + #:key (kind 'exact)) "Display the search path environment variables that may need to be set for ENTRIES, a list of manifest entries, in the context of PROFILE." - (let ((settings (search-path-environment-variables entries profile))) + (let* ((profile (user-friendly-profile profile)) + (settings (search-path-environment-variables entries profile + #:kind kind))) (unless (null? settings) (format #t (_ "The following environment variable definitions may be needed:~%")) (format #t "~{ ~a~%~}" settings)))) @@ -453,23 +422,29 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (substitutes? . #t))) (define (show-help) - (display (_ "Usage: guix package [OPTION]... PACKAGES... -Install, remove, or upgrade PACKAGES in a single transaction.\n")) + (display (_ "Usage: guix package [OPTION]... +Install, remove, or upgrade packages in a single transaction.\n")) (display (_ " - -i, --install=PACKAGE install PACKAGE")) + -i, --install PACKAGE ... + install PACKAGEs")) (display (_ " -e, --install-from-expression=EXP install the package EXP evaluates to")) (display (_ " - -r, --remove=PACKAGE remove PACKAGE")) + -r, --remove PACKAGE ... + remove PACKAGEs")) (display (_ " -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP")) (display (_ " + -m, --manifest=FILE create a new profile generation with the manifest + from FILE")) + (display (_ " --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP")) (display (_ " --roll-back roll back to the previous generation")) (display (_ " - --search-paths display needed environment variable definitions")) + --search-paths[=KIND] + display needed environment variable definitions")) (display (_ " -l, --list-generations[=PATTERN] list generations matching PATTERN")) @@ -496,7 +471,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) -A, --list-available[=REGEXP] list available packages matching REGEXP")) (display (_ " - --show=PACKAGE show details about PACKAGE")) + --show=PACKAGE show details about PACKAGE")) (newline) (show-build-options-help) (newline) @@ -556,6 +531,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (lambda (opt name arg result arg-handler) (values (alist-cons 'roll-back? #t result) #f))) + (option '(#\m "manifest") #t #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'manifest arg result) + arg-handler))) (option '(#\l "list-generations") #f #t (lambda (opt name arg result arg-handler) (values (cons `(query list-generations ,(or arg "")) @@ -570,10 +549,20 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (lambda (opt name arg result arg-handler) (values (alist-cons 'switch-generation arg result) #f))) - (option '("search-paths") #f #f + (option '("search-paths") #f #t (lambda (opt name arg result arg-handler) - (values (cons `(query search-paths) result) - #f))) + (let ((kind (match arg + ((or "exact" "prefix" "suffix") + (string->symbol arg)) + (#f + 'exact) + (x + (leave (_ "~a: unsupported \ +kind of search path~%") + x))))) + (values (cons `(query search-paths ,kind) + result) + #f)))) (option '(#\p "profile") #t #f (lambda (opt name arg result arg-handler) (values (alist-cons 'profile (canonicalize-profile arg) @@ -822,6 +811,50 @@ more information.~%")) (define dry-run? (assoc-ref opts 'dry-run?)) (define profile (assoc-ref opts 'profile)) + (define (build-and-use-profile manifest) + (let* ((bootstrap? (assoc-ref opts 'bootstrap?))) + + (when (equal? profile %current-profile) + (ensure-default-profile)) + + (let* ((prof-drv (run-with-store (%store) + (profile-derivation + manifest + #:hooks (if bootstrap? + '() + %default-profile-hooks)))) + (prof (derivation->output-path prof-drv))) + (show-what-to-build (%store) (list prof-drv) + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? dry-run?) + + (cond + (dry-run? #t) + ((and (file-exists? profile) + (and=> (readlink* profile) (cut string=? prof <>))) + (format (current-error-port) (_ "nothing to be done~%"))) + (else + (let* ((number (generation-number profile)) + + ;; Always use NUMBER + 1 for the new profile, + ;; possibly overwriting a "previous future + ;; generation". + (name (generation-file-name profile + (+ 1 number)))) + (and (build-derivations (%store) (list prof-drv)) + (let* ((entries (manifest-entries manifest)) + (count (length entries))) + (switch-symlinks name prof) + (switch-symlinks profile name) + (unless (string=? profile %current-profile) + (register-gc-root (%store) name)) + (format #t (N_ "~a package in profile~%" + "~a packages in profile~%" + count) + count) + (display-search-paths entries profile))))))))) + ;; First roll back if asked to. (cond ((and (assoc-ref opts 'roll-back?) (not dry-run?)) @@ -856,60 +889,30 @@ more information.~%")) (alist-delete 'delete-generations opts))) (_ #f)) opts)) + ((assoc-ref opts 'manifest) + (let* ((file-name (assoc-ref opts 'manifest)) + (user-module (make-user-module '((guix profiles) + (gnu)))) + (manifest (load* file-name user-module))) + (if (assoc-ref opts 'dry-run?) + (format #t (_ "would install new manifest from '~a' with ~d entries~%") + file-name (length (manifest-entries manifest))) + (format #t (_ "installing new manifest from '~a' with ~d entries~%") + file-name (length (manifest-entries manifest)))) + (build-and-use-profile manifest))) (else (let* ((manifest (profile-manifest profile)) (install (options->installable opts manifest)) (remove (options->removable opts manifest)) - (bootstrap? (assoc-ref opts 'bootstrap?)) (transaction (manifest-transaction (install install) (remove remove))) (new (manifest-perform-transaction manifest transaction))) - (when (equal? profile %current-profile) - (ensure-default-profile)) - (unless (and (null? install) (null? remove)) - (let* ((prof-drv (run-with-store (%store) - (profile-derivation - new - #:hooks (if bootstrap? - '() - %default-profile-hooks)))) - (prof (derivation->output-path prof-drv))) - (show-manifest-transaction (%store) manifest transaction - #:dry-run? dry-run?) - (show-what-to-build (%store) (list prof-drv) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? dry-run?) - - (cond - (dry-run? #t) - ((and (file-exists? profile) - (and=> (readlink* profile) (cut string=? prof <>))) - (format (current-error-port) (_ "nothing to be done~%"))) - (else - (let* ((number (generation-number profile)) - - ;; Always use NUMBER + 1 for the new profile, - ;; possibly overwriting a "previous future - ;; generation". - (name (generation-file-name profile - (+ 1 number)))) - (and (build-derivations (%store) (list prof-drv)) - (let* ((entries (manifest-entries new)) - (count (length entries))) - (switch-symlinks name prof) - (switch-symlinks profile name) - (unless (string=? profile %current-profile) - (register-gc-root (%store) name)) - (format #t (N_ "~a package in profile~%" - "~a packages in profile~%" - count) - count) - (display-search-paths entries - profile)))))))))))) + (show-manifest-transaction (%store) manifest transaction + #:dry-run? dry-run?) + (build-and-use-profile new)))))) (define (process-query opts) ;; Process any query specified by OPTS. Return #t when a query was @@ -1014,11 +1017,13 @@ more information.~%")) (find-packages-by-name name version))) #t)) - (('search-paths) + (('search-paths kind) (let* ((manifest (profile-manifest profile)) (entries (manifest-entries manifest)) + (profile (user-friendly-profile profile)) (settings (search-path-environment-variables entries profile - (const #f)))) + (const #f) + #:kind kind))) (format #t "~{~a~%~}" settings) #t)) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index c7c66fefbe..7bad2619b9 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -51,6 +51,10 @@ Publish ~a over HTTP.\n") %store-directory) (display (_ " -p, --port=PORT listen on PORT")) (display (_ " + --listen=HOST listen on the network interface for HOST")) + (display (_ " + -u, --user=USER change privileges to USER as soon as possible")) + (display (_ " -r, --repl[=PORT] spawn REPL server on PORT")) (newline) (display (_ " @@ -60,6 +64,15 @@ Publish ~a over HTTP.\n") %store-directory) (newline) (show-bug-report-information)) +(define (getaddrinfo* host) + "Like 'getaddrinfo', but properly report errors." + (catch 'getaddrinfo-error + (lambda () + (getaddrinfo host)) + (lambda (key error) + (leave (_ "lookup of host '~a' failed: ~a~%") + host (gai-strerror error))))) + (define %options (list (option '(#\h "help") #f #f (lambda _ @@ -68,9 +81,21 @@ Publish ~a over HTTP.\n") %store-directory) (option '(#\V "version") #f #f (lambda _ (show-version-and-exit "guix publish"))) + (option '(#\u "user") #t #f + (lambda (opt name arg result) + (alist-cons 'user arg result))) (option '(#\p "port") #t #f (lambda (opt name arg result) (alist-cons 'port (string->number* arg) result))) + (option '("listen") #t #f + (lambda (opt name arg result) + (match (getaddrinfo* arg) + ((info _ ...) + (alist-cons 'address (addrinfo:addr info) + result)) + (() + (leave (_ "lookup of host '~a' returned nothing") + name))))) (option '(#\r "repl") #f #t (lambda (opt name arg result) ;; If port unspecified, use default Guile REPL port. @@ -78,7 +103,8 @@ Publish ~a over HTTP.\n") %store-directory) (alist-cons 'repl (or port 37146) result)))))) (define %default-options - '((port . 8080) + `((port . 8080) + (address . ,(make-socket-address AF_INET INADDR_ANY 0)) (repl . #f))) (define (lazy-read-file-sexp file) @@ -220,24 +246,69 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (_ (not-found request))) (not-found request)))) -(define (run-publish-server port store) +(define (run-publish-server socket store) (run-server (make-request-handler store) 'http - `(#:addr ,INADDR_ANY - #:port ,port))) + `(#:socket ,socket))) + +(define (open-server-socket address) + "Return a TCP socket bound to ADDRESS, a socket address." + (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (bind sock address) + sock)) + +(define (gather-user-privileges user) + "Switch to the identity of USER, a user name." + (catch 'misc-error + (lambda () + (let ((user (getpw user))) + (setgroups #()) + (setgid (passwd:gid user)) + (setuid (passwd:uid user)))) + (lambda (key proc message args . rest) + (leave (_ "user '~a' not found: ~a~%") + user (apply format #f message args))))) + + +;;; +;;; Entry point. +;;; (define (guix-publish . args) (with-error-handling - (let* ((opts (args-fold* args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (leave (_ "~A: extraneuous argument~%") arg)) - %default-options)) - (port (assoc-ref opts 'port)) + (let* ((opts (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (_ "~A: extraneuous argument~%") arg)) + %default-options)) + (user (assoc-ref opts 'user)) + (port (assoc-ref opts 'port)) + (address (let ((addr (assoc-ref opts 'address))) + (make-socket-address (sockaddr:fam addr) + (sockaddr:addr addr) + port))) + (socket (open-server-socket address)) (repl-port (assoc-ref opts 'repl))) - (format #t (_ "publishing ~a on port ~d~%") %store-directory port) + ;; Read the key right away so that (1) we fail early on if we can't + ;; access them, and (2) we can then drop privileges. + (force %private-key) + (force %public-key) + + (when user + ;; Now that we've read the key material and opened the socket, we can + ;; drop privileges. + (gather-user-privileges user)) + + (when (zero? (getuid)) + (warning (_ "server running as root; \ +consider using the '--user' option!~%"))) + (format #t (_ "publishing ~a on ~a, port ~d~%") + %store-directory + (inet-ntop (sockaddr:fam address) (sockaddr:addr address)) + (sockaddr:port address)) (when repl-port (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) (with-store store - (run-publish-server (assoc-ref opts 'port) store))))) + (run-publish-server socket store))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index b9983c5b9c..8b4fa36d2a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -84,8 +84,10 @@ disabled!~%")) (define %narinfo-ttl ;; Number of seconds during which cached narinfo lookups are considered - ;; valid. - (* 24 3600)) + ;; valid. This is a reasonable default value (corresponds to the TTL for + ;; nginx's .nar cache on hydra.gnu.org) but we'd rather want publishers to + ;; state what their TTL is in /nix-cache-info. (XXX) + (* 36 3600)) (define %narinfo-negative-ttl ;; Likewise, but for negative lookups---i.e., cached lookup failures. @@ -155,15 +157,12 @@ to the caller without emitting an error message." (leave (_ "download from '~a' failed: ~a, ~s~%") (uri->string (http-get-error-uri c)) code (http-get-error-reason c)))))) - ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So - ;; honor TIMEOUT? to disable the timeout when fetching a nar. - ;; ;; Test this with: ;; sudo tc qdisc add dev eth0 root netem delay 1500ms ;; and then cancel with: ;; sudo tc qdisc del dev eth0 root (let ((port #f)) - (with-timeout (if (or timeout? (guile-version>? "2.0.5")) + (with-timeout (if timeout? %fetch-timeout 0) (begin @@ -180,7 +179,9 @@ to the caller without emitting an error message." (close-port port)))) (begin (when (or (not port) (port-closed? port)) - (set! port (open-socket-for-uri uri #:buffered? buffered?))) + (set! port (open-socket-for-uri uri)) + (unless buffered? + (setvbuf port _IONBF))) (http-fetch uri #:text? #f #:port port)))))))) (define-record-type <cache> @@ -645,17 +646,9 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by ;; XXX: We're not in control, so we always return anyway. n)) - ;; Since `http-fetch' in Guile 2.0.5 returns all the data once it's done, - ;; don't pretend to report any progress in that case. - (if (guile-version>? "2.0.5") - (make-custom-binary-input-port "progress-port-proc" - read! #f #f - (cut close-port port)) - (begin - (format (current-error-port) (_ "Downloading, please wait...~%")) - (format (current-error-port) - (_ "(Please consider upgrading Guile to get proper progress report.)~%")) - port))) + (make-custom-binary-input-port "progress-port-proc" + read! #f #f + (cut close-port port))) (define-syntax with-networking (syntax-rules () diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 1838e89452..aa9b3f838a 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -48,28 +48,14 @@ (define %user-module ;; Module in which the machine description file is loaded. - (let ((module (make-fresh-user-module))) - (for-each (lambda (iface) - (module-use! module (resolve-interface iface))) - '((gnu system) - (gnu services) - (gnu system shadow))) - module)) + (make-user-module '((gnu system) + (gnu services) + (gnu system shadow)))) (define (read-operating-system file) "Read the operating-system declaration from FILE and return it." - ;; TODO: Factorize. - (catch #t - (lambda () - ;; Avoid ABI incompatibility with the <operating-system> record. - (set! %fresh-auto-compile #t) + (load* file %user-module)) - (save-module-excursion - (lambda () - (set-current-module %user-module) - (primitive-load file)))) - (lambda args - (report-load-error file args)))) ;;; @@ -81,8 +67,6 @@ (store-lift references)) (define topologically-sorted* (store-lift topologically-sorted)) -(define show-what-to-build* - (store-lift show-what-to-build)) (define* (copy-item item target @@ -92,6 +76,13 @@ (let ((dest (string-append target item)) (state (string-append target "/var/guix"))) (format log-port "copying '~a'...~%" item) + + ;; Remove DEST if it exists to make sure that (1) we do not fail badly + ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and + ;; (2) we end up with the right contents. + (when (file-exists? dest) + (delete-file-recursively dest)) + (copy-recursively item dest #:log (%make-void-port "w")) @@ -144,8 +135,9 @@ TARGET, and register them." (define* (install os-drv target #:key (log-port (current-output-port)) grub? grub.cfg device) - "Copy the output of OS-DRV and its dependencies to directory TARGET. TARGET -must be an absolute directory name since that's what 'guix-register' expects. + "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to +directory TARGET. TARGET must be an absolute directory name since that's what +'guix-register' expects. When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." (define (maybe-copy to-copy) @@ -161,12 +153,24 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." ;; Copy items to the new store. (copy-closure to-copy target #:log-port log-port))))) + ;; Make sure TARGET is root-owned when running as root, but still allow + ;; non-root uses (useful for testing.) See + ;; <http://lists.gnu.org/archive/html/guix-devel/2015-05/msg00452.html>. + (if (zero? (geteuid)) + (chown target 0 0) + (warning (_ "not running as 'root', so \ +the ownership of '~a' may be incorrect!~%") + target)) + + (chmod target #o755) (let ((os-dir (derivation->output-path os-drv)) (format (lift format %store-monad)) (populate (lift2 populate-root-file-system %store-monad))) (mbegin %store-monad - (maybe-copy os-dir) + ;; Copy the closure of GRUB.CFG, which includes OS-DIR, GRUB's + ;; background image and so on. + (maybe-copy grub.cfg) ;; Create a bunch of additional files. (format log-port "populating '~a'...~%" target) @@ -290,10 +294,6 @@ it atomically, and then run OS's activation script." ((disk-image) (system-disk-image os #:disk-image-size image-size)))) -(define (grub.cfg os) - "Return the GRUB configuration file for OS." - (operating-system-grub.cfg os (previous-grub-entries))) - (define* (maybe-build drvs #:key dry-run? use-substitutes?) "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is @@ -323,7 +323,10 @@ boot directly to the kernel or to the bootloader." #:full-boot? full-boot? #:mappings mappings)) (grub (package->derivation grub)) - (grub.cfg (grub.cfg os)) + (grub.cfg (operating-system-grub.cfg os + (if (eq? 'init action) + '() + (previous-grub-entries)))) (drvs -> (if (and grub? (memq action '(init reconfigure))) (list sys grub grub.cfg) (list sys))) @@ -372,21 +375,25 @@ boot directly to the kernel or to the bootloader." Build the operating system declared in FILE according to ACTION.\n")) (newline) (display (_ "The valid values for ACTION are:\n")) + (newline) (display (_ "\ - - 'reconfigure', switch to a new operating system configuration\n")) + reconfigure switch to a new operating system configuration\n")) (display (_ "\ - - 'build', build the operating system without installing anything\n")) + build build the operating system without installing anything\n")) (display (_ "\ - - 'vm', build a virtual machine image that shares the host's store\n")) + vm build a virtual machine image that shares the host's store\n")) (display (_ "\ - - 'vm-image', build a freestanding virtual machine image\n")) + vm-image build a freestanding virtual machine image\n")) (display (_ "\ - - 'disk-image', build a disk image, suitable for a USB stick\n")) + disk-image build a disk image, suitable for a USB stick\n")) (display (_ "\ - - 'init', initialize a root file system to run GNU.\n")) + init initialize a root file system to run GNU.\n")) (show-build-options-help) (display (_ " + --on-error=STRATEGY + apply STRATEGY when an error occurs while reading FILE")) + (display (_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) (display (_ " --no-grub for 'init', do not install GRUB")) @@ -426,6 +433,10 @@ Build the operating system declared in FILE according to ACTION.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix system"))) + (option '("on-error") #t #f + (lambda (opt name arg result) + (alist-cons 'on-error (string->symbol arg) + result))) (option '("image-size") #t #f (lambda (opt name arg result) (alist-cons 'image-size (size->number arg) @@ -518,7 +529,8 @@ Build the operating system declared in FILE according to ACTION.\n")) (action (assoc-ref opts 'action)) (system (assoc-ref opts 'system)) (os (if file - (read-operating-system file) + (load* file %user-module + #:on-error (assoc-ref opts 'on-error)) (leave (_ "no configuration file specified~%")))) (dry? (assoc-ref opts 'dry-run?)) diff --git a/guix/search-paths.scm b/guix/search-paths.scm new file mode 100644 index 0000000000..7fd15d440c --- /dev/null +++ b/guix/search-paths.scm @@ -0,0 +1,193 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015 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 (guix search-paths) + #:use-module (guix records) + #:use-module (guix build utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:export (<search-path-specification> + search-path-specification + search-path-specification? + search-path-specification-variable + search-path-specification-files + search-path-specification-separator + search-path-specification-file-type + search-path-specification-file-pattern + + $PATH + + search-path-specification->sexp + sexp->search-path-specification + string-tokenize* + evaluate-search-paths + environment-variable-definition + search-path-definition)) + +;;; Commentary: +;;; +;;; This module defines "search path specifications", which allow packages to +;;; declare environment variables that they use to define search paths. For +;;; instance, GCC has the 'CPATH' variable, Guile has the 'GUILE_LOAD_PATH' +;;; variable, etc. +;;; +;;; Code: + +;; The specification of a search path. +(define-record-type* <search-path-specification> + search-path-specification make-search-path-specification + search-path-specification? + (variable search-path-specification-variable) ;string + (files search-path-specification-files) ;list of strings + (separator search-path-specification-separator ;string + (default ":")) + (file-type search-path-specification-file-type ;symbol + (default 'directory)) + (file-pattern search-path-specification-file-pattern ;#f | string + (default #f))) + +(define $PATH + ;; The 'PATH' variable. This variable is a bit special: it is not attached + ;; to any package in particular. + (search-path-specification + (variable "PATH") + (files '("bin" "sbin")))) + +(define (search-path-specification->sexp spec) + "Return an sexp representing SPEC, a <search-path-specification>. The sexp +corresponds to the arguments expected by `set-path-environment-variable'." + ;; Note that this sexp format is used both by build systems and in + ;; (guix profiles), so think twice before you change it. + (match spec + (($ <search-path-specification> variable files separator type pattern) + `(,variable ,files ,separator ,type ,pattern)))) + +(define (sexp->search-path-specification sexp) + "Convert SEXP, which is as returned by 'search-path-specification->sexp', to +a <search-path-specification> object." + (match sexp + ((variable files separator type pattern) + (search-path-specification + (variable variable) + (files files) + (separator separator) + (file-type type) + (file-pattern pattern))))) + +(define-syntax-rule (with-null-error-port exp) + "Evaluate EXP with the error port pointing to the bit bucket." + (with-error-to-port (%make-void-port "w") + (lambda () exp))) + +;; XXX: This procedure used to be in (guix utils) but since we want to be able +;; to use (guix search-paths) on the build side, we want to avoid the +;; dependency on (guix utils), and so this procedure is back here for now. +(define (string-tokenize* string separator) + "Return the list of substrings of STRING separated by SEPARATOR. This is +like `string-tokenize', but SEPARATOR is a string." + (define (index string what) + (let loop ((string string) + (offset 0)) + (cond ((string-null? string) + #f) + ((string-prefix? what string) + offset) + (else + (loop (string-drop string 1) (+ 1 offset)))))) + + (define len + (string-length separator)) + + (let loop ((string string) + (result '())) + (cond ((index string separator) + => + (lambda (offset) + (loop (string-drop string (+ offset len)) + (cons (substring string 0 offset) + result)))) + (else + (reverse (cons string result)))))) + +(define* (evaluate-search-paths search-paths directories + #:optional (getenv (const #f))) + "Evaluate SEARCH-PATHS, a list of search-path specifications, for +DIRECTORIES, a list of directory names, and return a list of +specification/value pairs. Use GETENV to determine the current settings and +report only settings not already effective." + (define search-path-definition + (match-lambda + ((and spec + ($ <search-path-specification> variable files separator + type pattern)) + (let* ((values (or (and=> (getenv variable) + (cut string-tokenize* <> separator)) + '())) + ;; Add a trailing slash to force symlinks to be treated as + ;; directories when 'find-files' traverses them. + (files (if pattern + (map (cut string-append <> "/") files) + files)) + + ;; XXX: Silence 'find-files' when it stumbles upon non-existent + ;; directories (see + ;; <http://lists.gnu.org/archive/html/guix-devel/2015-01/msg00269.html>.) + (path (with-null-error-port + (search-path-as-list files directories + #:type type + #:pattern pattern)))) + (if (every (cut member <> values) path) + #f ;VARIABLE is already set appropriately + (cons spec (string-join path separator))))))) + + (filter-map search-path-definition search-paths)) + +(define* (environment-variable-definition variable value + #:key + (kind 'exact) + (separator ":")) + "Return a the definition of VARIABLE to VALUE in Bash syntax. + +KIND can be either 'exact (return the definition of VARIABLE=VALUE), +'prefix (return the definition where VALUE is added as a prefix to VARIABLE's +current value), or 'suffix (return the definition where VALUE is added as a +suffix to VARIABLE's current value.) In the case of 'prefix and 'suffix, +SEPARATOR is used as the separator between VARIABLE's current value and its +prefix/suffix." + (match kind + ('exact + (format #f "export ~a=\"~a\"" variable value)) + ('prefix + (format #f "export ~a=\"~a${~a:+~a}$~a\"" + variable value variable separator variable)) + ('suffix + (format #f "export ~a=\"$~a${~a:+~a}~a\"" + variable variable variable separator value)))) + +(define* (search-path-definition search-path value + #:key (kind 'exact)) + "Similar to 'environment-variable-definition', but applied to a +<search-path-specification>." + (match search-path + (($ <search-path-specification> variable _ separator) + (environment-variable-definition variable value + #:kind kind + #:separator separator)))) + +;;; search-paths.scm ends here diff --git a/guix/serialization.scm b/guix/serialization.scm index 51d7ef76c6..7a3defc03d 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -279,17 +279,11 @@ sub-directories of FILE as needed." (write-string "type" p) (write-string "directory" p) (let ((entries - ;; NOTE: Guile 2.0.5's 'scandir' returns all subdirectories - ;; unconditionally, including "." and "..", regardless of the - ;; 'select?' predicate passed to it, so we have to filter - ;; those out externally. - (filter (negate (cut member <> '("." ".."))) - ;; 'scandir' defaults to 'string-locale<?' to sort - ;; files, but this happens to be case-insensitive (at - ;; least in 'en_US' locale on libc 2.18.) Conversely, - ;; we want files to be sorted in a case-sensitive - ;; fashion. - (scandir f (const #t) string<?)))) + ;; 'scandir' defaults to 'string-locale<?' to sort files, but + ;; this happens to be case-insensitive (at least in 'en_US' + ;; locale on libc 2.18.) Conversely, we want files to be + ;; sorted in a case-sensitive fashion. + (scandir f (negate (cut member <> '("." ".."))) string<?))) (for-each (lambda (e) (let ((f (string-append f "/" e))) (write-string "entry" p) diff --git a/guix/store.scm b/guix/store.scm index 10b9062db2..933708defc 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -90,6 +90,8 @@ references requisites referrers + optimize-store + verify-store topologically-sorted valid-derivers query-derivation-outputs @@ -120,6 +122,7 @@ derivation-path? store-path-package-name store-path-hash-part + direct-store-path log-file)) (define %protocol-version #x10c) @@ -171,7 +174,9 @@ (query-substitutable-path-infos 30) (query-valid-paths 31) (query-substitutable-paths 32) - (query-valid-derivers 33)) + (query-valid-derivers 33) + (optimize-store 34) + (verify-store 35)) (define-enumerate-type hash-algo ;; hash.hh @@ -494,8 +499,8 @@ encoding conversion errors." ;; Client-provided substitute URLs. For ;; unprivileged clients, these are considered - ;; "untrusted"; for root, they override the - ;; daemon's settings. + ;; "untrusted"; for "trusted" users, they override + ;; the daemon's settings. (substitute-urls %default-substitute-urls)) ;; Must be called after `open-connection'. @@ -760,6 +765,25 @@ substitutable. For each substitutable path, a `substitutable?' object is returned." substitutable-path-list)) +(define-operation (optimize-store) + "Optimize the store by hard-linking identical files (\"deduplication\".) +Return #t on success." + ;; Note: the daemon in Guix <= 0.8.2 does not implement this RPC. + boolean) + +(define verify-store + (let ((verify (operation (verify-store (boolean check-contents?) + (boolean repair?)) + "Verify the store." + boolean))) + (lambda* (store #:key check-contents? repair?) + "Verify the integrity of the store and return false if errors remain, +and true otherwise. When REPAIR? is true, repair any missing or altered store +items by substituting them (this typically requires root privileges because it +is not an atomic operation.) When CHECK-CONTENTS? is true, check the contents +of store items; this can take a lot of time." + (not (verify store check-contents? repair?))))) + (define (run-gc server action to-delete min-freed) "Perform the garbage-collector operation ACTION, one of the `gc-action' values. When ACTION is `delete-specific', the TO-DELETE is @@ -1004,6 +1028,15 @@ valid inputs." (let ((len (+ 1 (string-length (%store-prefix))))) (not (string-index (substring path len) #\/))))) +(define (direct-store-path path) + "Return the direct store path part of PATH, stripping components after +'/gnu/store/xxxx-foo'." + (let ((prefix-length (+ (string-length (%store-prefix)) 35))) + (if (> (string-length path) prefix-length) + (let ((slash (string-index path #\/ prefix-length))) + (if slash (string-take path slash) path)) + path))) + (define (derivation-path? path) "Return #t if PATH is a derivation path." (and (store-path? path) (string-suffix? ".drv" path))) diff --git a/guix/tests.scm b/guix/tests.scm index 080ee9cc74..87e6cc2830 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -37,7 +37,8 @@ %substitute-directory with-derivation-narinfo with-derivation-substitute - dummy-package)) + dummy-package + dummy-origin)) ;;; Commentary: ;;; @@ -219,6 +220,13 @@ initialized with default values, and with EXTRA-FIELDS set as specified." (synopsis #f) (description #f) (home-page #f) (license #f))) +(define-syntax-rule (dummy-origin extra-fields ...) + "Return a \"dummy\" origin, with all its compulsory fields initialized with +default values, and with EXTRA-FIELDS set as specified." + (origin extra-fields ... + (method #f) (uri "http://www.example.com") + (sha256 (base32 (make-string 52 #\x))))) + ;; Local Variables: ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1) ;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2) diff --git a/guix/ui.scm b/guix/ui.scm index e717ab713e..11af646a6e 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -35,6 +35,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-31) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) @@ -42,19 +43,22 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 regex) - #:replace (symlink) + #:autoload (system repl repl) (start-repl) + #:autoload (system repl debug) (make-debug stack->vector) #:export (_ N_ P_ report-error leave - report-load-error + make-user-module + load* warn-about-load-error show-version-and-exit show-bug-report-information string->number* size->number show-what-to-build + show-what-to-build* show-manifest-transaction call-with-error-handling with-error-handling @@ -133,22 +137,102 @@ messages." (report-error args ...) (exit 1))) -(define (report-load-error file args) - "Report the failure to load FILE, a user-provided Scheme file, and exit. +(define (make-user-module modules) + "Return a new user module with the additional MODULES loaded." + ;; Module in which the machine description file is loaded. + (let ((module (make-fresh-user-module))) + (for-each (lambda (iface) + (module-use! module (resolve-interface iface))) + modules) + module)) + +(define* (load* file user-module + #:key (on-error 'nothing-special)) + "Load the user provided Scheme source code FILE." + (define (frame-with-source frame) + ;; Walk from FRAME upwards until source location information is found. + (let loop ((frame frame) + (previous frame)) + (if (not frame) + previous + (if (frame-source frame) + frame + (loop (frame-previous frame) frame))))) + + (define (error-string frame args) + (call-with-output-string + (lambda (port) + (apply display-error frame port (cdr args))))) + + (define tag + (make-prompt-tag "user-code")) + + (catch #t + (lambda () + ;; XXX: Force a recompilation to avoid ABI issues. + (set! %fresh-auto-compile #t) + (set! %load-should-auto-compile #t) + + (save-module-excursion + (lambda () + (set-current-module user-module) + + ;; Hide the "auto-compiling" messages. + (parameterize ((current-warning-port (%make-void-port "w"))) + (call-with-prompt tag + (lambda () + ;; Give 'load' an absolute file name so that it doesn't try to + ;; search for FILE in %LOAD-PATH. Note: use 'load', not + ;; 'primitive-load', so that FILE is compiled, which then allows us + ;; to provide better error reporting with source line numbers. + (load (canonicalize-path file))) + (const #f)))))) + (lambda _ + ;; XXX: Errors are reported from the pre-unwind handler below, but + ;; calling 'exit' from there has no effect, so we call it here. + (exit 1)) + (rec (handle-error . args) + ;; Capture the stack up to this procedure call, excluded, and pass + ;; the faulty stack frame to 'report-load-error'. + (let* ((stack (make-stack #t handle-error tag)) + (depth (stack-length stack)) + (last (and (> depth 0) (stack-ref stack 0))) + (frame (frame-with-source + (if (> depth 1) + (stack-ref stack 1) ;skip the 'throw' frame + last)))) + + (report-load-error file args frame) + + (case on-error + ((debug) + (newline) + (display (_ "entering debugger; type ',bt' for a backtrace\n")) + (start-repl #:debug (make-debug (stack->vector stack) 0 + (error-string frame args) + #f))) + ((backtrace) + (newline (current-error-port)) + (display-backtrace stack (current-error-port))) + (else + #t)))))) + +(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." (match args (('system-error . _) (let ((err (system-error-errno args))) - (leave (_ "failed to load '~a': ~a~%") file (strerror err)))) + (report-error (_ "failed to load '~a': ~a~%") file (strerror err)))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) (format (current-error-port) (_ "~a: error: ~a~%") - (location->string loc) message) - (exit 1))) + (location->string loc) message))) + (('srfi-34 obj) + (report-error (_ "exception thrown: ~s~%") obj)) ((error args ...) (report-error (_ "failed to load '~a':~%") file) - (apply display-error #f (current-error-port) args) - (exit 1)))) + (apply display-error frame (current-error-port) args)))) (define (warn-about-load-error file args) ;FIXME: factorize with ↑ "Report the failure to load FILE, a user-provided Scheme file, without @@ -161,6 +245,9 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (let ((loc (source-properties->location properties))) (format (current-error-port) (_ "~a: warning: ~a~%") (location->string loc) message))) + (('srfi-34 obj) + (warning (_ "failed to load '~a': exception thrown: ~s~%") + file obj)) ((error args ...) (warning (_ "failed to load '~a':~%") file) (apply display-error #f (current-error-port) args)))) @@ -206,7 +293,9 @@ Report bugs to: ~a.") %guix-bug-report-address) General help using GNU software: <http://www.gnu.org/gethelp/>")) (newline)) -(define symlink +(set! symlink + ;; We 'set!' the global binding because (gnu build ...) modules and similar + ;; typically don't use (guix ui). (let ((real-symlink (@ (guile) symlink))) (lambda (target link) "This is a 'symlink' replacement that provides proper error reporting." @@ -218,8 +307,25 @@ General help using GNU software: <http://www.gnu.org/gethelp/>")) ;; information is missing as of Guile 2.0.11, making the exception ;; uninformative.) (apply throw key proc "~A: ~S" - (append args (list link)) - errno)))))) + (list (strerror (car errno)) link) + (list errno))))))) + +(set! copy-file + ;; Note: here we use 'set!', not #:replace, because UIs typically use + ;; 'copy-recursively', which doesn't use (guix ui). + (let ((real-copy-file (@ (guile) copy-file))) + (lambda (source target) + "This is a 'copy-file' replacement that provides proper error reporting." + (catch 'system-error + (lambda () + (real-copy-file source target)) + (lambda (key proc fmt args errno) + ;; Augment the FMT and ARGS with information about TARGET (this + ;; information is missing as of Guile 2.0.11, making the exception + ;; uninformative.) + (apply throw key proc "~A: ~S" + (list (strerror (car errno)) target) + (list errno))))))) (define (string->number* str) "Like `string->number', but error out with an error message on failure." @@ -346,8 +452,16 @@ interpreted." (lambda () (eval exp (force %guix-user-module))) (lambda args - (leave (_ "failed to evaluate expression `~a': ~s~%") - exp args))))) + (report-error (_ "failed to evaluate expression '~a':~%") exp) + (match args + (('syntax-error proc message properties form . rest) + (report-error (_ "syntax error: ~a~%") message)) + (('srfi-34 obj) + (report-error (_ "exception thrown: ~s~%") obj)) + ((error args ...) + (apply display-error #f (current-error-port) args)) + (what? #f)) + (exit 1))))) (define (read/eval-package-expression str) "Read and evaluate STR and return the package it refers to, or exit an @@ -429,6 +543,9 @@ available for download." (null? download) download))) (pair? build))) +(define show-what-to-build* + (store-lift show-what-to-build)) + (define (right-arrow port) "Return either a string containing the 'RIGHT ARROW' character, or an ASCII replacement if PORT is not Unicode-capable." @@ -852,11 +969,8 @@ parameter of 'args-fold'." (define dot-scm? (cut string-suffix? ".scm" <>)) - ;; In Guile 2.0.5 `scandir' would return "." and ".." regardless even though - ;; they don't match `dot-scm?'. Work around it by doing additional - ;; filtering. (if directory - (filter dot-scm? (scandir directory dot-scm?)) + (scandir directory dot-scm?) '())) (define (commands) diff --git a/guix/utils.scm b/guix/utils.scm index 3d38ba1223..a2ade2bf97 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -72,7 +72,6 @@ version-major+minor guile-version>? package-name->name+version - string-tokenize* string-replace-substring arguments-from-environment-variable file-extension @@ -606,33 +605,6 @@ introduce the version part." (substring file 0 dot) file))) -(define (string-tokenize* string separator) - "Return the list of substrings of STRING separated by SEPARATOR. This is -like `string-tokenize', but SEPARATOR is a string." - (define (index string what) - (let loop ((string string) - (offset 0)) - (cond ((string-null? string) - #f) - ((string-prefix? what string) - offset) - (else - (loop (string-drop string 1) (+ 1 offset)))))) - - (define len - (string-length separator)) - - (let loop ((string string) - (result '())) - (cond ((index string separator) - => - (lambda (offset) - (loop (string-drop string (+ offset len)) - (cons (substring string 0 offset) - result)))) - (else - (reverse (cons string result)))))) - (define* (string-replace-substring str substr replacement #:optional (start 0) |