diff options
author | Ludovic Courtès <ludo@gnu.org> | 2016-07-20 11:42:02 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2016-07-20 11:42:17 +0200 |
commit | 7575655212ecfbcd1f04e429c8a7a41f8720d027 (patch) | |
tree | 558982d3cf50ef6b19ef293850de1f485fde66a6 /guix | |
parent | 5d4c90ae02f1e0b42d575bba2d828d63aaf79be5 (diff) | |
parent | 5f01078129f4eaa4760a14f22761cf357afb6738 (diff) | |
download | gnu-guix-7575655212ecfbcd1f04e429c8a7a41f8720d027.tar gnu-guix-7575655212ecfbcd1f04e429c8a7a41f8720d027.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build/download.scm | 14 | ||||
-rw-r--r-- | guix/build/svn.scm | 21 | ||||
-rw-r--r-- | guix/config.scm.in | 6 | ||||
-rw-r--r-- | guix/cvs-download.scm | 20 | ||||
-rw-r--r-- | guix/download.scm | 96 | ||||
-rw-r--r-- | guix/gexp.scm | 188 | ||||
-rw-r--r-- | guix/git-download.scm | 36 | ||||
-rw-r--r-- | guix/hg-download.scm | 22 | ||||
-rw-r--r-- | guix/import/cpan.scm | 13 | ||||
-rw-r--r-- | guix/packages.scm | 209 | ||||
-rw-r--r-- | guix/profiles.scm | 422 | ||||
-rw-r--r-- | guix/records.scm | 19 | ||||
-rw-r--r-- | guix/scripts/challenge.scm | 40 | ||||
-rw-r--r-- | guix/scripts/gc.scm | 7 | ||||
-rw-r--r-- | guix/scripts/lint.scm | 17 | ||||
-rw-r--r-- | guix/scripts/publish.scm | 169 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 3 | ||||
-rw-r--r-- | guix/scripts/system.scm | 2 | ||||
-rw-r--r-- | guix/store.scm | 2 | ||||
-rw-r--r-- | guix/svn-download.scm | 26 | ||||
-rw-r--r-- | guix/zlib.scm | 234 |
21 files changed, 999 insertions, 567 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index bd011ce878..103e784bb1 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -23,9 +23,11 @@ #:use-module (web http) #:use-module ((web client) #:hide (open-socket-for-uri)) #:use-module (web response) + #:use-module (guix base64) #:use-module (guix ftp-client) #:use-module (guix build utils) #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -598,14 +600,22 @@ FILE on success." (string>? (version) "2.0.7"))) (define headers - '(;; Some web sites, such as http://dist.schmorp.de, would block you if + `(;; Some web sites, such as http://dist.schmorp.de, would block you if ;; there's no 'User-Agent' header, presumably on the assumption that ;; you're a spammer. So work around that. (User-Agent . "GNU Guile") ;; Some servers, such as https://alioth.debian.org, return "406 Not ;; Acceptable" when not explicitly told that everything is accepted. - (Accept . "*/*"))) + (Accept . "*/*") + + ;; Basic authentication, if needed. + ,@(match (uri-userinfo uri) + ((? string? str) + `((Authorization . ,(string-append "Basic " + (base64-encode + (string->utf8 str)))))) + (_ '())))) (let*-values (((connection) (open-connection-for-uri uri #:timeout timeout)) diff --git a/guix/build/svn.scm b/guix/build/svn.scm index 74fe084da5..31c30edaf5 100644 --- a/guix/build/svn.scm +++ b/guix/build/svn.scm @@ -29,15 +29,22 @@ ;;; Code: (define* (svn-fetch url revision directory - #:key (svn-command "svn")) + #:key (svn-command "svn") + (user-name #f) + (password #f)) "Fetch REVISION from URL into DIRECTORY. REVISION must be an integer, and a valid Subversion revision. Return #t on success, #f otherwise." - (and (zero? (system* svn-command "checkout" "--non-interactive" - ;; Trust the server certificate. This is OK as we - ;; verify the checksum later. This can be removed when - ;; ca-certificates package is added. - "--trust-server-cert" "-r" (number->string revision) - url directory)) + (and (zero? (apply system* svn-command + "checkout" "--non-interactive" + ;; Trust the server certificate. This is OK as we + ;; verify the checksum later. This can be removed when + ;; ca-certificates package is added. + "--trust-server-cert" "-r" (number->string revision) + `(,@(if (and user-name password) + (list (string-append "--username=" user-name) + (string-append "--password=" password)) + '()) + ,url ,directory))) (with-directory-excursion directory (begin ;; The contents of '.svn' vary as a function of the current status diff --git a/guix/config.scm.in b/guix/config.scm.in index adffa0cfec..6d42cf233c 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +27,7 @@ %guix-register-program %system %libgcrypt + %libz %nix-instantiate %gzip %bzip2 @@ -72,6 +73,9 @@ (define %libgcrypt "@LIBGCRYPT@") +(define %libz + "@LIBZ@") + (define %nix-instantiate "@NIX_INSTANTIATE@") diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm index 72478dd2c2..85744c5b55 100644 --- a/guix/cvs-download.scm +++ b/guix/cvs-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; @@ -60,13 +60,15 @@ object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define build - #~(begin - (use-modules (guix build cvs)) - (cvs-fetch '#$(cvs-reference-root-directory ref) - '#$(cvs-reference-module ref) - '#$(cvs-reference-revision ref) - #$output - #:cvs-command (string-append #+cvs "/bin/cvs")))) + (with-imported-modules '((guix build cvs) + (guix build utils)) + #~(begin + (use-modules (guix build cvs)) + (cvs-fetch '#$(cvs-reference-root-directory ref) + '#$(cvs-reference-module ref) + '#$(cvs-reference-revision ref) + #$output + #:cvs-command (string-append #+cvs "/bin/cvs"))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "cvs-checkout") build @@ -74,8 +76,6 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:hash-algo hash-algo #:hash hash #:recursive? #t - #:modules '((guix build cvs) - (guix build utils)) #:guile-for-build guile #:local-build? #t))) diff --git a/guix/download.scm b/guix/download.scm index 9b238dcbdf..bcb043ba80 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -99,27 +99,23 @@ "http://www.centervenus.com/mirrors/nongnu/" "http://download.savannah.gnu.org/releases-noredirect/") (sourceforge ; https://sourceforge.net/p/forge/documentation/Mirrors/ - "http://prdownloads.sourceforge.net/" - "http://heanet.dl.sourceforge.net/sourceforge/" - "http://dfn.dl.sourceforge.net/sourceforge/" - "http://freefr.dl.sourceforge.net/sourceforge/" - "http://internode.dl.sourceforge.net/sourceforge/" - "http://iweb.dl.sourceforge.net/sourceforge/" - "http://jaist.dl.sourceforge.net/sourceforge/" - "http://kaz.dl.sourceforge.net/sourceforge/" - "http://kent.dl.sourceforge.net/sourceforge/" - "http://liquidtelecom.dl.sourceforge.net/sourceforge/" - "http://nbtelecom.dl.sourceforge.net/sourceforge/" - "http://nchc.dl.sourceforge.net/sourceforge/" - "http://ncu.dl.sourceforge.net/sourceforge/" - "http://netcologne.dl.sourceforge.net/sourceforge/" - "http://netix.dl.sourceforge.net/sourceforge/" - "http://pilotfiber.dl.sourceforge.net/sourceforge/" - "http://superb-sea2.dl.sourceforge.net/sourceforge/" - "http://tenet.dl.sourceforge.net/sourceforge/" - "http://ufpr.dl.sourceforge.net/sourceforge/" - "http://vorboss.dl.sourceforge.net/sourceforge/" - "http://netassist.dl.sourceforge.net/sourceforge/") + "http://ufpr.dl.sourceforge.net/project/" + "http://heanet.dl.sourceforge.net/project/" + "http://freefr.dl.sourceforge.net/project/" + "http://internode.dl.sourceforge.net/project/" + "http://jaist.dl.sourceforge.net/project/" + "http://kent.dl.sourceforge.net/project/" + "http://liquidtelecom.dl.sourceforge.net/project/" + "http://nbtelecom.dl.sourceforge.net/project/" + "http://nchc.dl.sourceforge.net/project/" + "http://ncu.dl.sourceforge.net/project/" + "http://netcologne.dl.sourceforge.net/project/" + "http://netix.dl.sourceforge.net/project/" + "http://pilotfiber.dl.sourceforge.net/project/" + "http://superb-sea2.dl.sourceforge.net/project/" + "http://tenet.dl.sourceforge.net/project/" + "http://vorboss.dl.sourceforge.net/project/" + "http://netassist.dl.sourceforge.net/project/") (kernel.org "http://www.all.kernel.org/pub/" "http://ramses.wh2.tu-dresden.de/pub/mirrors/kernel.org/" @@ -168,7 +164,7 @@ "http://x.cs.pu.edu.tw/" "ftp://ftp.is.co.za/pub/x.org") ; South Africa (cpan ; from http://www.cpan.org/SITES.html - "http://cpan.enstimac.fr/" + "http://mirror.ibcp.fr/pub/CPAN/" "ftp://ftp.ciril.fr/pub/cpan/" "ftp://artfiles.org/cpan.org/" "http://www.cpan.org/" @@ -286,33 +282,39 @@ in the store." (any https? url))))) (define builder - #~(begin - #+(if need-gnutls? + (with-imported-modules '((guix build download) + (guix build utils) + (guix ftp-client) + (guix base32) + (guix base64)) + #~(begin + #+(if need-gnutls? - ;; Add GnuTLS to the inputs and to the load path. - #~(eval-when (load expand eval) - (set! %load-path - (cons (string-append #+(gnutls-package) - "/share/guile/site/" - (effective-version)) - %load-path))) - #~#t) + ;; Add GnuTLS to the inputs and to the load path. + #~(eval-when (load expand eval) + (set! %load-path + (cons (string-append #+(gnutls-package) + "/share/guile/site/" + (effective-version)) + %load-path))) + #~#t) - (use-modules (guix build download) - (guix base32)) + (use-modules (guix build download) + (guix base32)) - (let ((value-from-environment (lambda (variable) - (call-with-input-string - (getenv variable) - read)))) - (url-fetch (value-from-environment "guix download url") - #$output - #:mirrors (call-with-input-file #$%mirror-file read) + (let ((value-from-environment (lambda (variable) + (call-with-input-string + (getenv variable) + read)))) + (url-fetch (value-from-environment "guix download url") + #$output + #:mirrors (call-with-input-file #$%mirror-file read) - ;; Content-addressed mirrors. - #:hashes (value-from-environment "guix download hashes") - #:content-addressed-mirrors - (primitive-load #$%content-addressed-mirror-file))))) + ;; Content-addressed mirrors. + #:hashes + (value-from-environment "guix download hashes") + #:content-addressed-mirrors + (primitive-load #$%content-addressed-mirror-file)))))) (let ((uri (and (string? url) (string->uri url)))) (if (or (and (string? url) (not uri)) @@ -325,10 +327,6 @@ in the store." #:system system #:hash-algo hash-algo #:hash hash - #:modules '((guix build download) - (guix build utils) - (guix ftp-client) - (guix base32)) ;; Use environment variables and a fixed script ;; name so there's only one script in store for diff --git a/guix/gexp.scm b/guix/gexp.scm index b929b79c26..302879fb42 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -29,6 +29,7 @@ #:use-module (ice-9 match) #:export (gexp gexp? + with-imported-modules gexp-input gexp-input? @@ -49,14 +50,12 @@ computed-file? computed-file-name computed-file-gexp - computed-file-modules computed-file-options program-file program-file? program-file-name program-file-gexp - program-file-modules program-file-guile scheme-file @@ -98,11 +97,11 @@ ;; "G expressions". (define-record-type <gexp> - (make-gexp references natives proc) + (make-gexp references modules proc) gexp? - (references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...) - (natives gexp-native-references) ; ((DRV-OR-PKG OUTPUT) ...) - (proc gexp-proc)) ; procedure + (references gexp-references) ;list of <gexp-input> + (modules gexp-self-modules) ;list of module names + (proc gexp-proc)) ;procedure (define (write-gexp gexp port) "Write GEXP on PORT." @@ -113,8 +112,7 @@ ;; tries to use 'append' on that, which fails with wrong-type-arg. (false-if-exception (write (apply (gexp-proc gexp) - (append (gexp-references gexp) - (gexp-native-references gexp))) + (gexp-references gexp)) port)) (format port " ~a>" (number->string (object-address gexp) 16))) @@ -273,55 +271,49 @@ This is the declarative counterpart of 'text-file'." (text-file name content references)))) (define-record-type <computed-file> - (%computed-file name gexp modules options) + (%computed-file name gexp options) computed-file? (name computed-file-name) ;string (gexp computed-file-gexp) ;gexp - (modules computed-file-modules) ;list of module names (options computed-file-options)) ;list of arguments (define* (computed-file name gexp - #:key (modules '()) (options '(#:local-build? #t))) + #:key (options '(#:local-build? #t))) "Return an object representing the store item NAME, a file or directory -computed by GEXP. MODULES specifies the set of modules visible in the -execution context of GEXP. OPTIONS is a list of additional arguments to pass +computed by GEXP. OPTIONS is a list of additional arguments to pass to 'gexp->derivation'. This is the declarative counterpart of 'gexp->derivation'." - (%computed-file name gexp modules options)) + (%computed-file name gexp options)) (define-gexp-compiler (computed-file-compiler (file computed-file?) system target) ;; Compile FILE by returning a derivation whose build expression is its ;; gexp. (match file - (($ <computed-file> name gexp modules options) - (apply gexp->derivation name gexp #:modules modules options)))) + (($ <computed-file> name gexp options) + (apply gexp->derivation name gexp options)))) (define-record-type <program-file> - (%program-file name gexp modules guile) + (%program-file name gexp guile) program-file? (name program-file-name) ;string (gexp program-file-gexp) ;gexp - (modules program-file-modules) ;list of module names (guile program-file-guile)) ;package -(define* (program-file name gexp - #:key (modules '()) (guile #f)) +(define* (program-file name gexp #:key (guile #f)) "Return an object representing the executable store item NAME that runs -GEXP. GUILE is the Guile package used to execute that script, and MODULES is -the list of modules visible to that script. +GEXP. GUILE is the Guile package used to execute that script. This is the declarative counterpart of 'gexp->script'." - (%program-file name gexp modules guile)) + (%program-file name gexp guile)) (define-gexp-compiler (program-file-compiler (file program-file?) system target) ;; Compile FILE by returning a derivation that builds the script. (match file - (($ <program-file> name gexp modules guile) + (($ <program-file> name gexp guile) (gexp->script name gexp - #:modules modules #:guile (or guile (default-guile)))))) (define-record-type <scheme-file> @@ -386,6 +378,23 @@ whether this should be considered a \"native\" input or not." (set-record-type-printer! <gexp-output> write-gexp-output) +(define (gexp-modules gexp) + "Return the list of Guile module names GEXP relies on." + (delete-duplicates + (append (gexp-self-modules gexp) + (append-map (match-lambda + (($ <gexp-input> (? gexp? exp)) + (gexp-modules exp)) + (($ <gexp-input> (lst ...)) + (append-map (lambda (item) + (if (gexp? item) + (gexp-modules item) + '())) + lst)) + (_ + '())) + (gexp-references gexp))))) + (define raw-derivation (store-lift derivation)) @@ -467,7 +476,8 @@ derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME. When TARGET is true, it is used as the cross-compilation target triplet for packages referred to by EXP. -Make MODULES available in the evaluation context of EXP; MODULES is a list of +MODULES is deprecated in favor of 'with-imported-modules'. Its meaning is to +make MODULES available in the evaluation context of EXP; MODULES is a list of names of Guile modules searched in MODULE-PATH to be copied in the store, compiled, and made available in the load path during the execution of EXP---e.g., '((guix build utils) (guix build gnu-build-system)). @@ -496,7 +506,9 @@ Similarly for DISALLOWED-REFERENCES, which can list items that must not be referenced by the outputs. The other arguments are as for 'derivation'." - (define %modules modules) + (define %modules + (delete-duplicates + (append modules (gexp-modules exp)))) (define outputs (gexp-outputs exp)) (define (graphs-file-names graphs) @@ -630,11 +642,15 @@ references; otherwise, return only non-native references." ;; Ignore references to other kinds of objects. result))) + (define (native-input? x) + (and (gexp-input? x) + (gexp-input-native? x))) + (fold-right add-reference-inputs '() (if native? - (gexp-native-references exp) - (gexp-references exp)))) + (filter native-input? (gexp-references exp)) + (remove native-input? (gexp-references exp))))) (define gexp-native-inputs (cut gexp-inputs <> #:native? #t)) @@ -687,7 +703,7 @@ and in the current monad setting (system type, etc.)" (if (gexp-input? ref) ref (%gexp-input ref "out" n?)) - native?)) + (or n? native?))) refs))) (($ <gexp-input> (? struct? thing) output n?) (let ((target (if (or n? native?) #f target))) @@ -706,9 +722,7 @@ and in the current monad setting (system type, etc.)" (mlet %store-monad ((args (sequence %store-monad - (append (map reference->sexp (gexp-references exp)) - (map (cut reference->sexp <> #t) - (gexp-native-references exp)))))) + (map reference->sexp (gexp-references exp))))) (return (apply (gexp-proc exp) args)))) (define (syntax-location-string s) @@ -724,6 +738,17 @@ and in the current monad setting (system type, etc.)" (simple-format #f "~a:~a" line column))) "<unknown location>"))) +(define-syntax-parameter current-imported-modules + ;; Current list of imported modules. + (identifier-syntax '())) + +(define-syntax-rule (with-imported-modules modules body ...) + "Mark the gexps defined in BODY... as requiring MODULES in their execution +environment." + (syntax-parameterize ((current-imported-modules + (identifier-syntax modules))) + body ...)) + (define-syntax gexp (lambda (s) (define (collect-escapes exp) @@ -741,33 +766,9 @@ and in the current monad setting (system type, etc.)" ((ungexp-splicing _ ...) (cons exp result)) ((ungexp-native _ ...) - result) - ((ungexp-native-splicing _ ...) - result) - ((exp0 exp ...) - (let ((result (loop #'exp0 result))) - (fold loop result #'(exp ...)))) - (_ - result)))) - - (define (collect-native-escapes exp) - ;; Return all the 'ungexp-native' forms present in EXP. - (let loop ((exp exp) - (result '())) - (syntax-case exp (ungexp - ungexp-splicing - ungexp-native - ungexp-native-splicing) - ((ungexp-native _) - (cons exp result)) - ((ungexp-native _ _) (cons exp result)) ((ungexp-native-splicing _ ...) (cons exp result)) - ((ungexp _ ...) - result) - ((ungexp-splicing _ ...) - result) ((exp0 exp ...) (let ((result (loop #'exp0 result))) (fold loop result #'(exp ...)))) @@ -838,14 +839,12 @@ and in the current monad setting (system type, etc.)" (syntax-case s (ungexp output) ((_ exp) - (let* ((normals (delete-duplicates (collect-escapes #'exp))) - (natives (delete-duplicates (collect-native-escapes #'exp))) - (escapes (append normals natives)) + (let* ((escapes (delete-duplicates (collect-escapes #'exp))) (formals (generate-temporaries escapes)) (sexp (substitute-references #'exp (zip escapes formals))) - (refs (map escape->ref normals)) - (nrefs (map escape->ref natives))) - #`(make-gexp (list #,@refs) (list #,@nrefs) + (refs (map escape->ref escapes))) + #`(make-gexp (list #,@refs) + current-imported-modules (lambda #,formals #,sexp))))))) @@ -983,12 +982,24 @@ they can refer to each other." (module-ref (resolve-interface '(gnu packages commencement)) 'guile-final)) -(define* (gexp->script name exp - #:key (modules '()) (guile (default-guile))) - "Return an executable script NAME that runs EXP using GUILE with MODULES in -its search path." +(define (load-path-expression modules) + "Return as a monadic value a gexp that sets '%load-path' and +'%load-compiled-path' to point to MODULES, a list of module names." (mlet %store-monad ((modules (imported-modules modules)) (compiled (compiled-modules modules))) + (return (gexp (eval-when (expand load eval) + (set! %load-path + (cons (ungexp modules) %load-path)) + (set! %load-compiled-path + (cons (ungexp compiled) + %load-compiled-path))))))) + +(define* (gexp->script name exp + #:key (guile (default-guile))) + "Return an executable script NAME that runs EXP using GUILE, with EXP's +imported modules in its search path." + (mlet %store-monad ((set-load-path + (load-path-expression (gexp-modules exp)))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) @@ -1001,28 +1012,33 @@ its search path." "#!~a/bin/guile --no-auto-compile~%!#~%" (ungexp guile)) - ;; Write the 'eval-when' form so that it can be - ;; compiled. - (write - '(eval-when (expand load eval) - (set! %load-path - (cons (ungexp modules) %load-path)) - (set! %load-compiled-path - (cons (ungexp compiled) - %load-compiled-path))) - port) + (write '(ungexp set-load-path) port) (write '(ungexp exp) port) (chmod port #o555))))))) -(define (gexp->file name exp) - "Return a derivation that builds a file NAME containing EXP." - (gexp->derivation name - (gexp - (call-with-output-file (ungexp output) - (lambda (port) - (write '(ungexp exp) port)))) - #:local-build? #t - #:substitutable? #f)) +(define* (gexp->file name exp #:key (set-load-path? #t)) + "Return a derivation that builds a file NAME containing EXP. When +SET-LOAD-PATH? is true, emit code in the resulting file to set '%load-path' +and '%load-compiled-path' to honor EXP's imported modules." + (match (if set-load-path? (gexp-modules exp) '()) + (() ;zero modules + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (write '(ungexp exp) port)))) + #:local-build? #t + #:substitutable? #f)) + ((modules ...) + (mlet %store-monad ((set-load-path (load-path-expression modules))) + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (write '(ungexp set-load-path) port) + (write '(ungexp exp) port)))) + #:local-build? #t + #:substitutable? #f))))) (define* (text-file* name #:rest text) "Return as a monadic value a derivation that builds a text file containing diff --git a/guix/git-download.scm b/guix/git-download.scm index 1e5c845e34..9cc6dd3d94 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -68,23 +68,25 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." '())) (define build - #~(begin - (use-modules (guix build git) - (guix build utils) - (ice-9 match)) + (with-imported-modules '((guix build git) + (guix build utils)) + #~(begin + (use-modules (guix build git) + (guix build utils) + (ice-9 match)) - ;; The 'git submodule' commands expects Coreutils, sed, - ;; grep, etc. to be in $PATH. - (set-path-environment-variable "PATH" '("bin") - (match '#+inputs - (((names dirs) ...) - dirs))) + ;; The 'git submodule' commands expects Coreutils, sed, + ;; grep, etc. to be in $PATH. + (set-path-environment-variable "PATH" '("bin") + (match '#+inputs + (((names dirs) ...) + dirs))) - (git-fetch '#$(git-reference-url ref) - '#$(git-reference-commit ref) - #$output - #:recursive? '#$(git-reference-recursive? ref) - #:git-command (string-append #+git "/bin/git")))) + (git-fetch '#$(git-reference-url ref) + '#$(git-reference-commit ref) + #$output + #:recursive? '#$(git-reference-recursive? ref) + #:git-command (string-append #+git "/bin/git"))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build @@ -93,8 +95,6 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:hash-algo hash-algo #:hash hash #:recursive? #t - #:modules '((guix build git) - (guix build utils)) #:guile-for-build guile #:local-build? #t))) diff --git a/guix/hg-download.scm b/guix/hg-download.scm index f3e1d2906a..8420980905 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -60,15 +60,17 @@ object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define build - #~(begin - (use-modules (guix build hg) - (guix build utils) - (ice-9 match)) + (with-imported-modules '((guix build hg) + (guix build utils)) + #~(begin + (use-modules (guix build hg) + (guix build utils) + (ice-9 match)) - (hg-fetch '#$(hg-reference-url ref) - '#$(hg-reference-changeset ref) - #$output - #:hg-command (string-append #+hg "/bin/hg")))) + (hg-fetch '#$(hg-reference-url ref) + '#$(hg-reference-changeset ref) + #$output + #:hg-command (string-append #+hg "/bin/hg"))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "hg-checkout") build @@ -77,8 +79,6 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:hash-algo hash-algo #:hash hash #:recursive? #t - #:modules '((guix build hg) - (guix build utils)) #:guile-for-build guile))) ;;; hg-download.scm ends here diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index ad61ee7916..213a155fd6 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co> ;;; ;;; This file is part of GNU Guix. ;;; @@ -99,6 +100,13 @@ or #f on failure. MODULE should be e.g. \"Test::Script\"" (define (cpan-home name) (string-append "http://search.cpan.org/dist/" name)) +(define (fix-source-url download-url) + "Return a new download URL based on DOWNLOAD-URL which now uses our mirrors, +if the original's domain was metacpan." + (regexp-substitute/global #f "http[s]?://cpan.metacpan.org" download-url + 'pre "mirror://cpan" 'post)) + + (define %corelist (delay (let* ((perl (with-store store @@ -183,10 +191,7 @@ META." (list (list guix-name (list 'quasiquote inputs)))))) - (define source-url - (regexp-substitute/global #f "http://cpan.metacpan.org" - (assoc-ref meta "download_url") - 'pre "mirror://cpan" 'post)) + (define source-url (fix-source-url (assoc-ref meta "download_url"))) (let ((tarball (with-store store (download-to-store store source-url)))) diff --git a/guix/packages.scm b/guix/packages.scm index acb8f34417..bfb4c557ab 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -56,7 +56,6 @@ origin-patch-guile origin-snippet origin-modules - origin-imported-modules base32 package @@ -164,8 +163,7 @@ (default #f)) (modules origin-modules ; list of module names (default '())) - (imported-modules origin-imported-modules ; list of module names - (default '())) + (patch-guile origin-patch-guile ; package or #f (default #f))) @@ -381,14 +379,13 @@ the build code of derivation." (snippet #f) (flags '("-p1")) (modules '()) - (imported-modules '()) (guile-for-build (%guile-for-build)) (system (%current-system))) "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and repack the tarball using the tools listed in INPUTS. When SNIPPET is true, it must be an s-expression that will run from within the directory where -SOURCE was unpacked, after all of PATCHES have been applied. MODULES and -IMPORTED-MODULES specify modules to use/import for use by SNIPPET." +SOURCE was unpacked, after all of PATCHES have been applied. MODULES +specifies modules in scope when evaluating SNIPPET." (define source-file-name ;; SOURCE is usually a derivation, but it could be a store file. (if (derivation? source) @@ -449,107 +446,107 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET." (patches (sequence %store-monad (map instantiate-patch patches)))) (define build - #~(begin - (use-modules (ice-9 ftw) - (srfi srfi-1) - (guix build utils)) - - ;; The --sort option was added to GNU tar in version 1.28, released - ;; 2014-07-28. During bootstrap we must cope with older versions. - (define tar-supports-sort? - (zero? (system* (string-append #+tar "/bin/tar") - "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) - - (define (apply-patch patch) - (format (current-error-port) "applying '~a'...~%" patch) - - ;; Use '--force' so that patches that do not apply perfectly are - ;; rejected. - (zero? (system* (string-append #+patch "/bin/patch") - "--force" #+@flags "--input" patch))) - - (define (first-file directory) - ;; Return the name of the first file in DIRECTORY. - (car (scandir directory - (lambda (name) - (not (member name '("." ".."))))))) - - ;; Encoding/decoding errors shouldn't be silent. - (fluid-set! %default-port-conversion-strategy 'error) - - (when #+locales - ;; First of all, install a UTF-8 locale so that UTF-8 file names - ;; are correctly interpreted. During bootstrap, LOCALES is #f. - (setenv "LOCPATH" - (string-append #+locales "/lib/locale/" - #+(and locales - (package-version locales)))) - (setlocale LC_ALL "en_US.utf8")) - - (setenv "PATH" (string-append #+xz "/bin" ":" - #+decomp "/bin")) - - ;; SOURCE may be either a directory or a tarball. - (and (if (file-is-directory? #+source) - (let* ((store (%store-directory)) - (len (+ 1 (string-length store))) - (base (string-drop #+source len)) - (dash (string-index base #\-)) - (directory (string-drop base (+ 1 dash)))) - (mkdir directory) - (copy-recursively #+source directory) - #t) - #+(if (string=? decompression-type "unzip") - #~(zero? (system* "unzip" #+source)) - #~(zero? (system* (string-append #+tar "/bin/tar") - "xvf" #+source)))) - (let ((directory (first-file "."))) - (format (current-error-port) - "source is under '~a'~%" directory) - (chdir directory) - - (and (every apply-patch '#+patches) - #+@(if snippet - #~((let ((module (make-fresh-user-module))) - (module-use-interfaces! module - (map resolve-interface - '#+modules)) - ((@ (system base compile) compile) - '#+snippet - #:to 'value - #:opts %auto-compilation-options - #:env module))) - #~()) - - (begin (chdir "..") #t) - - (unless tar-supports-sort? - (call-with-output-file ".file_list" - (lambda (port) - (for-each (lambda (name) (format port "~a~%" name)) - (find-files directory - #:directories? #t - #:fail-on-error? #t))))) - (zero? (apply system* (string-append #+tar "/bin/tar") - "cvfa" #$output - ;; avoid non-determinism in the archive - "--mtime=@0" - "--owner=root:0" - "--group=root:0" - (if tar-supports-sort? - `("--sort=name" - ,directory) - '("--no-recursion" - "--files-from=.file_list"))))))))) - - (let ((name (tarxz-name original-file-name)) - (modules (delete-duplicates (cons '(guix build utils) - imported-modules)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (ice-9 ftw) + (srfi srfi-1) + (guix build utils)) + + ;; The --sort option was added to GNU tar in version 1.28, released + ;; 2014-07-28. During bootstrap we must cope with older versions. + (define tar-supports-sort? + (zero? (system* (string-append #+tar "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + + (define (apply-patch patch) + (format (current-error-port) "applying '~a'...~%" patch) + + ;; Use '--force' so that patches that do not apply perfectly are + ;; rejected. + (zero? (system* (string-append #+patch "/bin/patch") + "--force" #+@flags "--input" patch))) + + (define (first-file directory) + ;; Return the name of the first file in DIRECTORY. + (car (scandir directory + (lambda (name) + (not (member name '("." ".."))))))) + + ;; Encoding/decoding errors shouldn't be silent. + (fluid-set! %default-port-conversion-strategy 'error) + + (when #+locales + ;; First of all, install a UTF-8 locale so that UTF-8 file names + ;; are correctly interpreted. During bootstrap, LOCALES is #f. + (setenv "LOCPATH" + (string-append #+locales "/lib/locale/" + #+(and locales + (package-version locales)))) + (setlocale LC_ALL "en_US.utf8")) + + (setenv "PATH" (string-append #+xz "/bin" ":" + #+decomp "/bin")) + + ;; SOURCE may be either a directory or a tarball. + (and (if (file-is-directory? #+source) + (let* ((store (%store-directory)) + (len (+ 1 (string-length store))) + (base (string-drop #+source len)) + (dash (string-index base #\-)) + (directory (string-drop base (+ 1 dash)))) + (mkdir directory) + (copy-recursively #+source directory) + #t) + #+(if (string=? decompression-type "unzip") + #~(zero? (system* "unzip" #+source)) + #~(zero? (system* (string-append #+tar "/bin/tar") + "xvf" #+source)))) + (let ((directory (first-file "."))) + (format (current-error-port) + "source is under '~a'~%" directory) + (chdir directory) + + (and (every apply-patch '#+patches) + #+@(if snippet + #~((let ((module (make-fresh-user-module))) + (module-use-interfaces! + module + (map resolve-interface '#+modules)) + ((@ (system base compile) compile) + '#+snippet + #:to 'value + #:opts %auto-compilation-options + #:env module))) + #~()) + + (begin (chdir "..") #t) + + (unless tar-supports-sort? + (call-with-output-file ".file_list" + (lambda (port) + (for-each (lambda (name) + (format port "~a~%" name)) + (find-files directory + #:directories? #t + #:fail-on-error? #t))))) + (zero? (apply system* + (string-append #+tar "/bin/tar") + "cvfa" #$output + ;; avoid non-determinism in the archive + "--mtime=@0" + "--owner=root:0" + "--group=root:0" + (if tar-supports-sort? + `("--sort=name" + ,directory) + '("--no-recursion" + "--files-from=.file_list")))))))))) + + (let ((name (tarxz-name original-file-name))) (gexp->derivation name build #:graft? #f #:system system - #:modules modules #:guile-for-build guile-for-build)))) (define (transitive-inputs inputs) @@ -1138,8 +1135,7 @@ cross-compilation target triplet." ;; No patches, no snippet: this is a fixed-output derivation. (method uri 'sha256 sha256 name #:system system)) (($ <origin> uri method sha256 name (= force (patches ...)) snippet - (flags ...) inputs (modules ...) (imported-modules ...) - guile-for-build) + (flags ...) inputs (modules ...) guile-for-build) ;; Patches and/or a snippet. (mlet %store-monad ((source (method uri 'sha256 sha256 name #:system system)) @@ -1153,7 +1149,6 @@ cross-compilation target triplet." #:flags flags #:system system #:modules modules - #:imported-modules imported-modules #:guile-for-build guile))))) (define-gexp-compiler (origin-compiler (origin origin?) system target) diff --git a/guix/profiles.scm b/guix/profiles.scm index 90c43325a0..77df6ad185 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -489,87 +489,87 @@ MANIFEST." (module-ref (resolve-interface '(gnu packages compression)) 'gzip)) (define build - #~(begin - (use-modules (guix build utils) - (srfi srfi-1) (srfi srfi-26) - (ice-9 ftw)) - - (define (info-file? file) - (or (string-suffix? ".info" file) - (string-suffix? ".info.gz" file))) - - (define (info-files top) - (let ((infodir (string-append top "/share/info"))) - (map (cut string-append infodir "/" <>) - (or (scandir infodir info-file?) '())))) - - (define (install-info info) - (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files - (zero? - (system* (string-append #+texinfo "/bin/install-info") "--silent" - info (string-append #$output "/share/info/dir")))) - - (mkdir-p (string-append #$output "/share/info")) - (exit (every install-info - (append-map info-files - '#$(manifest-inputs manifest)))))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-1) (srfi srfi-26) + (ice-9 ftw)) + + (define (info-file? file) + (or (string-suffix? ".info" file) + (string-suffix? ".info.gz" file))) + + (define (info-files top) + (let ((infodir (string-append top "/share/info"))) + (map (cut string-append infodir "/" <>) + (or (scandir infodir info-file?) '())))) + + (define (install-info info) + (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files + (zero? + (system* (string-append #+texinfo "/bin/install-info") "--silent" + info (string-append #$output "/share/info/dir")))) + + (mkdir-p (string-append #$output "/share/info")) + (exit (every install-info + (append-map info-files + '#$(manifest-inputs manifest))))))) (gexp->derivation "info-dir" build - #:modules '((guix build utils)) #:local-build? #t #:substitutable? #f)) (define (ghc-package-cache-file manifest) "Return a derivation that builds the GHC 'package.cache' file for all the entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." - (define ghc ;lazy reference + (define ghc ;lazy reference (module-ref (resolve-interface '(gnu packages haskell)) 'ghc)) (define build - #~(begin - (use-modules (guix build utils) - (srfi srfi-1) (srfi srfi-26) - (ice-9 ftw)) - - (define ghc-name-version - (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) - (let ((db (string-append top "/" db-subdir))) - (if (file-exists? db) - (find-files db "\\.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 - (delete-duplicates - '#$(manifest-inputs manifest)))) - (let ((success - (zero? - (system* (string-append #+ghc "/bin/ghc-pkg") "recache" - (string-append "--package-db=" db-dir))))) - (for-each delete-file (find-files db-dir "\\.conf$")) - (exit success)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-1) (srfi srfi-26) + (ice-9 ftw)) + + (define ghc-name-version + (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) + (let ((db (string-append top "/" db-subdir))) + (if (file-exists? db) + (find-files db "\\.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 + (delete-duplicates + '#$(manifest-inputs manifest)))) + (let ((success + (zero? + (system* (string-append #+ghc "/bin/ghc-pkg") "recache" + (string-append "--package-db=" db-dir))))) + (for-each delete-file (find-files db-dir "\\.conf$")) + (exit success))))) (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 #:substitutable? #f) (return #f)))) @@ -585,58 +585,58 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales)) (define build - #~(begin - (use-modules (guix build utils) - (rnrs io ports) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 ftw) - (ice-9 match)) - - (define (pem-file? file) - (string-suffix? ".pem" file)) - - (define (ca-files top) - (let ((cert-dir (string-append top "/etc/ssl/certs"))) - (map (cut string-append cert-dir "/" <>) - (or (scandir cert-dir pem-file?) '())))) - - (define (concatenate-files files result) - "Make RESULT the concatenation of all of FILES." - (define (dump file port) - (display (call-with-input-file file get-string-all) - port) - (newline port)) ;required, see <https://bugs.debian.org/635570> - - (call-with-output-file result - (lambda (port) - (for-each (cut dump <> port) files)))) - - ;; Some file names in the NSS certificates are UTF-8 encoded so - ;; install a UTF-8 locale. - (setenv "LOCPATH" - (string-append #+glibc-utf8-locales "/lib/locale/" - #+(package-version glibc-utf8-locales))) - (setlocale LC_ALL "en_US.utf8") - - (match (append-map ca-files '#$(manifest-inputs manifest)) - (() - ;; Since there are no CA files, just create an empty directory. Do - ;; not create the etc/ssl/certs sub-directory, since that would - ;; wrongfully lead to a message about 'SSL_CERT_DIR' needing to be - ;; defined. - (mkdir #$output) - #t) - ((ca-files ...) - (let ((result (string-append #$output "/etc/ssl/certs"))) - (mkdir-p result) - (concatenate-files ca-files - (string-append result - "/ca-certificates.crt")) - #t))))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (rnrs io ports) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 ftw) + (ice-9 match)) + + (define (pem-file? file) + (string-suffix? ".pem" file)) + + (define (ca-files top) + (let ((cert-dir (string-append top "/etc/ssl/certs"))) + (map (cut string-append cert-dir "/" <>) + (or (scandir cert-dir pem-file?) '())))) + + (define (concatenate-files files result) + "Make RESULT the concatenation of all of FILES." + (define (dump file port) + (display (call-with-input-file file get-string-all) + port) + (newline port)) ;required, see <https://bugs.debian.org/635570> + + (call-with-output-file result + (lambda (port) + (for-each (cut dump <> port) files)))) + + ;; Some file names in the NSS certificates are UTF-8 encoded so + ;; install a UTF-8 locale. + (setenv "LOCPATH" + (string-append #+glibc-utf8-locales "/lib/locale/" + #+(package-version glibc-utf8-locales))) + (setlocale LC_ALL "en_US.utf8") + + (match (append-map ca-files '#$(manifest-inputs manifest)) + (() + ;; Since there are no CA files, just create an empty directory. Do + ;; not create the etc/ssl/certs sub-directory, since that would + ;; wrongfully lead to a message about 'SSL_CERT_DIR' needing to be + ;; defined. + (mkdir #$output) + #t) + ((ca-files ...) + (let ((result (string-append #$output "/etc/ssl/certs"))) + (mkdir-p result) + (concatenate-files ca-files + (string-append result + "/ca-certificates.crt")) + #t)))))) (gexp->derivation "ca-certificate-bundle" build - #:modules '((guix build utils)) #:local-build? #t #:substitutable? #f)) @@ -645,44 +645,44 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." creates the GTK+ 'icon-theme.cache' file for each theme." (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+"))) (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 - #:log-port (%make-void-port "w")) - - ;; 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 "--quiet")))) - (scandir destdir (negate (cut member <> '("." "..")))))))) + (with-imported-modules '((guix build utils) + (guix build union) + (guix build profiles) + (guix search-paths) + (guix records)) + #~(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 + #:log-port (%make-void-port "w")) + + ;; 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 "--quiet")))) + (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 #:substitutable? #f) (return #f)))) @@ -695,28 +695,28 @@ MIME type." (manifest-lookup-package manifest "desktop-file-utils"))) (define build - #~(begin - (use-modules (srfi srfi-26) - (guix build utils) - (guix build union)) - (let* ((destdir (string-append #$output "/share/applications")) - (appdirs (filter file-exists? - (map (cut string-append <> - "/share/applications") - '#$(manifest-inputs manifest)))) - (update-desktop-database (string-append - #+desktop-file-utils - "/bin/update-desktop-database"))) - (mkdir-p (string-append #$output "/share")) - (union-build destdir appdirs - #:log-port (%make-void-port "w")) - (exit (zero? (system* update-desktop-database destdir)))))) + (with-imported-modules '((guix build utils) + (guix build union)) + #~(begin + (use-modules (srfi srfi-26) + (guix build utils) + (guix build union)) + (let* ((destdir (string-append #$output "/share/applications")) + (appdirs (filter file-exists? + (map (cut string-append <> + "/share/applications") + '#$(manifest-inputs manifest)))) + (update-desktop-database (string-append + #+desktop-file-utils + "/bin/update-desktop-database"))) + (mkdir-p (string-append #$output "/share")) + (union-build destdir appdirs + #:log-port (%make-void-port "w")) + (exit (zero? (system* update-desktop-database destdir))))))) ;; Don't run the hook when 'desktop-file-utils' is not referenced. (if desktop-file-utils (gexp->derivation "xdg-desktop-database" build - #:modules '((guix build utils) - (guix build union)) #:local-build? #t #:substitutable? #f) (return #f)))) @@ -728,30 +728,30 @@ entries. It's used to query the MIME type of a given file." (manifest-lookup-package manifest "shared-mime-info"))) (define build - #~(begin - (use-modules (srfi srfi-26) - (guix build utils) - (guix build union)) - (let* ((datadir (string-append #$output "/share")) - (destdir (string-append datadir "/mime")) - (pkgdirs (filter file-exists? - (map (cut string-append <> - "/share/mime/packages") - '#$(manifest-inputs manifest)))) - (update-mime-database (string-append - #+shared-mime-info - "/bin/update-mime-database"))) - (mkdir-p destdir) - (union-build (string-append destdir "/packages") pkgdirs - #:log-port (%make-void-port "w")) - (setenv "XDG_DATA_HOME" datadir) - (exit (zero? (system* update-mime-database destdir)))))) + (with-imported-modules '((guix build utils) + (guix build union)) + #~(begin + (use-modules (srfi srfi-26) + (guix build utils) + (guix build union)) + (let* ((datadir (string-append #$output "/share")) + (destdir (string-append datadir "/mime")) + (pkgdirs (filter file-exists? + (map (cut string-append <> + "/share/mime/packages") + '#$(manifest-inputs manifest)))) + (update-mime-database (string-append + #+shared-mime-info + "/bin/update-mime-database"))) + (mkdir-p destdir) + (union-build (string-append destdir "/packages") pkgdirs + #:log-port (%make-void-port "w")) + (setenv "XDG_DATA_HOME" datadir) + (exit (zero? (system* update-mime-database destdir))))))) ;; Don't run the hook when 'shared-mime-info' is referenced. (if shared-mime-info (gexp->derivation "xdg-mime-database" build - #:modules '((guix build utils) - (guix build union)) #:local-build? #t #:substitutable? #f) (return #f)))) @@ -790,34 +790,34 @@ the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." (manifest-inputs manifest))) (define builder - #~(begin - (use-modules (guix build profiles) - (guix search-paths) - (srfi srfi-1)) - - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (define search-paths - ;; Search paths of MANIFEST's packages, converted back to their - ;; record form. - (map sexp->search-path-specification - (delete-duplicates - '#$(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))) + (with-imported-modules '((guix build profiles) + (guix build union) + (guix build utils) + (guix search-paths) + (guix records)) + #~(begin + (use-modules (guix build profiles) + (guix search-paths) + (srfi srfi-1)) + + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (define search-paths + ;; Search paths of MANIFEST's packages, converted back to their + ;; record form. + (map sexp->search-path-specification + (delete-duplicates + '#$(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 #:system system - #:modules '((guix build profiles) - (guix build union) - (guix build utils) - (guix search-paths) - (guix records)) ;; Not worth offloading. #:local-build? #t diff --git a/guix/records.scm b/guix/records.scm index 0d35a747b0..f3f3aafb04 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -42,6 +42,15 @@ (format #f fmt args ...) form)))) +(define (report-invalid-field-specifier name bindings) + "Report the first invalid binding among BINDINGS." + (let loop ((bindings bindings)) + (syntax-case bindings () + (((field value) rest ...) ;good + (loop #'(rest ...))) + ((weird _ ...) ;weird! + (syntax-violation name "invalid field specifier" #'weird))))) + (define-syntax make-syntactic-constructor (syntax-rules () "Make the syntactic constructor NAME for TYPE, that calls CTOR, and @@ -147,7 +156,13 @@ fields, and DELAYED is the list of identifiers of delayed fields." "missing field initializers ~a" (lset-difference eq? '(expected ...) - fields))))))))))))) + fields))))))) + ((_ bindings (... ...)) + ;; One of BINDINGS doesn't match the (field value) pattern. + ;; Report precisely which one is faulty, instead of letting the + ;; "source expression failed to match any pattern" error. + (report-invalid-field-specifier 'name + #'(bindings (... ...)))))))))) (define-syntax-rule (define-field-property-predicate predicate property) "Define PREDICATE as a procedure that takes a syntax object and, when passed diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 149647cfdf..590d8f1099 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -21,6 +21,7 @@ #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix grafts) #:use-module (guix monads) #:use-module (guix base32) #:use-module (guix packages) @@ -222,23 +223,26 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (urls (assoc-ref opts 'substitute-urls))) (leave-on-EPIPE (with-store store - (let ((files (match files - (() - (filter (cut locally-built? store <>) - (live-paths store))) - (x - files)))) - (set-build-options store - #:use-substitutes? #f) - - (run-with-store store - (mlet* %store-monad ((items (mapm %store-monad - ensure-store-item files)) - (issues (discrepancies items urls))) - (for-each summarize-discrepancy issues) - (unless (null? issues) - (exit 2)) - (return (null? issues))) - #:system system))))))) + ;; Disable grafts since substitute servers normally provide only + ;; ungrafted stuff. + (parameterize ((%graft? #f)) + (let ((files (match files + (() + (filter (cut locally-built? store <>) + (live-paths store))) + (x + files)))) + (set-build-options store + #:use-substitutes? #f) + + (run-with-store store + (mlet* %store-monad ((items (mapm %store-monad + ensure-store-item files)) + (issues (discrepancies items urls))) + (for-each summarize-discrepancy issues) + (unless (null? issues) + (exit 2)) + (return (null? issues))) + #:system system)))))))) ;;; challenge.scm ends here diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 8db28138c8..bdfee4308c 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -24,6 +24,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:export (guix-gc)) @@ -221,9 +222,11 @@ Invoke the garbage collector.\n")) (free-space (ensure-free-space store free-space)) (min-freed - (collect-garbage store min-freed)) + (let-values (((paths freed) (collect-garbage store min-freed))) + (info (_ "freed ~h bytes~%") freed))) (else - (collect-garbage store))))) + (let-values (((paths freed) (collect-garbage store))) + (info (_ "freed ~h bytes~%") freed)))))) ((delete) (delete-paths store (map direct-store-path paths))) ((list-references) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index b4fdb6f905..d5e9197cc9 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -359,7 +359,22 @@ warning for PACKAGE mentionning the FIELD." (probe-uri uri #:timeout 3))) ;wait at most 3 seconds (case status ((http-response) - (or (= 200 (response-code argument)) + (if (= 200 (response-code argument)) + (match (response-content-length argument) + ((? number? length) + ;; As of July 2016, SourceForge returns 200 (instead of 404) + ;; with a small HTML page upon failure. Attempt to detect such + ;; malicious behavior. + (or (> length 1000) + (begin + (emit-warning package + (format #f + (_ "URI ~a returned \ +suspiciously small file (~a bytes)") + (uri->string uri) + length)) + #f))) + (_ #t)) (begin (emit-warning package (format #f diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 4c0aa8e419..3baceaf645 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -27,6 +27,7 @@ #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) @@ -45,6 +46,7 @@ #:use-module (guix pk-crypto) #:use-module (guix store) #:use-module (guix serialization) + #:use-module (guix zlib) #:use-module (guix ui) #:use-module (guix scripts) #:export (guix-publish)) @@ -59,6 +61,9 @@ Publish ~a over HTTP.\n") %store-directory) (display (_ " -u, --user=USER change privileges to USER as soon as possible")) (display (_ " + -C, --compression[=LEVEL] + compress archives at LEVEL")) + (display (_ " --ttl=TTL announce narinfos can be cached for TTL seconds")) (display (_ " -r, --repl[=PORT] spawn REPL server on PORT")) @@ -79,6 +84,20 @@ Publish ~a over HTTP.\n") %store-directory) (leave (_ "lookup of host '~a' failed: ~a~%") host (gai-strerror error))))) +;; Nar compression parameters. +(define-record-type <compression> + (compression type level) + compression? + (type compression-type) + (level compression-level)) + +(define %no-compression + (compression 'none 0)) + +(define %default-gzip-compression + ;; Since we compress on the fly, default to fast compression. + (compression 'gzip 3)) + (define %options (list (option '(#\h "help") #f #f (lambda _ @@ -102,6 +121,20 @@ Publish ~a over HTTP.\n") %store-directory) (() (leave (_ "lookup of host '~a' returned nothing") name))))) + (option '(#\C "compression") #f #t + (lambda (opt name arg result) + (match (if arg (string->number* arg) 3) + (0 + (alist-cons 'compression %no-compression result)) + (level + (if (zlib-available?) + (alist-cons 'compression + (compression 'gzip level) + result) + (begin + (warning (_ "zlib support is missing; \ +compression disabled~%")) + result)))))) (option '("ttl") #t #f (lambda (opt name arg result) (let ((duration (string->duration arg))) @@ -117,6 +150,12 @@ Publish ~a over HTTP.\n") %store-directory) (define %default-options `((port . 8080) + + ;; Default to fast & low compression. + (compression . ,(if (zlib-available?) + %default-gzip-compression + %no-compression)) + (address . ,(make-socket-address AF_INET INADDR_ANY 0)) (repl . #f))) @@ -152,12 +191,20 @@ Publish ~a over HTTP.\n") %store-directory) (define base64-encode-string (compose base64-encode string->utf8)) -(define (narinfo-string store store-path key) +(define* (narinfo-string store store-path key + #:key (compression %no-compression)) "Generate a narinfo key/value string for STORE-PATH; an exception is raised -if STORE-PATH is invalid. The narinfo is signed with KEY." +if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The +narinfo is signed with KEY." (let* ((path-info (query-path-info store store-path)) - (url (encode-and-join-uri-path (list "nar" - (basename store-path)))) + (url (encode-and-join-uri-path + `("nar" + ,@(match compression + (($ <compression> 'none) + '()) + (($ <compression> type) + (list (symbol->string type)))) + ,(basename store-path)))) (hash (bytevector->nix-base32-string (path-info-hash path-info))) (size (path-info-nar-size path-info)) @@ -166,13 +213,16 @@ if STORE-PATH is invalid. The narinfo is signed with KEY." " ")) (deriver (path-info-deriver path-info)) (base-info (format #f - "StorePath: ~a + "\ +StorePath: ~a URL: ~a -Compression: none +Compression: ~a NarHash: sha256:~a NarSize: ~d References: ~a~%" - store-path url hash size references)) + store-path url + (compression-type compression) + hash size references)) ;; Do not render a "Deriver" or "System" line if we are rendering ;; info for a derivation. (info (if (not deriver) @@ -209,7 +259,8 @@ References: ~a~%" (format port "~a: ~a~%" key value))) %nix-cache-info)))) -(define* (render-narinfo store request hash #:key ttl) +(define* (render-narinfo store request hash + #:key ttl (compression %no-compression)) "Render metadata for the store path corresponding to HASH. If TTL is true, advertise it as the maximum validity period (in seconds) via the 'Cache-Control' header. This allows 'guix substitute' to cache it for an @@ -222,18 +273,35 @@ appropriate duration." `((cache-control (max-age . ,ttl))) '())) (cut display - (narinfo-string store store-path (force %private-key)) - <>))))) - -(define (render-nar store request store-item) + (narinfo-string store store-path (force %private-key) + #:compression compression) + <>))))) + +;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for +;; internal consumption: it allows us to pass the compression info to +;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>. +(declare-header! "Guix-Nar-Compression" + (lambda (str) + (match (call-with-input-string str read) + (('compression type level) + (compression type level)))) + compression? + (lambda (compression port) + (match compression + (($ <compression> type level) + (write `(compression ,type ,level) port))))) + +(define* (render-nar store request store-item + #:key (compression %no-compression)) "Render archive of the store path corresponding to STORE-ITEM." (let ((store-path (string-append %store-directory "/" store-item))) ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte ;; sequences. (if (valid-path? store store-path) - (values '((content-type . (application/x-nix-archive - (charset . "ISO-8859-1")))) + (values `((content-type . (application/x-nix-archive + (charset . "ISO-8859-1"))) + (guix-nar-compression . ,compression)) ;; XXX: We're not returning the actual contents, deferring ;; instead to 'http-write'. This is a hack to work around ;; <http://bugs.gnu.org/21093>. @@ -282,6 +350,28 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (values) (apply throw args))))) +(define-syntax-rule (swallow-zlib-error exp ...) + "Swallow 'zlib-error' exceptions raised by EXP..." + (catch 'zlib-error + (lambda () + exp ...) + (const #f))) + +(define (nar-response-port response) + "Return a port on which to write the body of RESPONSE, the response of a +/nar request, according to COMPRESSION." + (match (assoc-ref (response-headers response) 'guix-nar-compression) + (($ <compression> 'gzip level) + ;; Note: We cannot used chunked encoding here because + ;; 'make-gzip-output-port' wants a file port. + (make-gzip-output-port (response-port response) + #:level level + #:buffer-size (* 64 1024))) + (($ <compression> 'none) + (response-port response)) + (#f + (response-port response)))) + (define (http-write server client response body) "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid blocking." @@ -293,16 +383,20 @@ blocking." (lambda () (let* ((response (write-response (sans-content-length response) client)) - (port (response-port response))) + (port (begin + (force-output client) + (nar-response-port response)))) ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> in ;; 'render-nar', BODY here is just the file name of the store item. ;; We call 'write-file' from here because we know that's the only ;; way to avoid building the whole nar in memory, which could ;; quickly become a real problem. As a bonus, we even do ;; sendfile(2) directly from the store files to the socket. - (swallow-EPIPE - (write-file (utf8->string body) port)) - (close-port port) + (swallow-zlib-error + (swallow-EPIPE + (write-file (utf8->string body) port))) + (swallow-zlib-error + (close-port port)) (values))))) (_ ;; Handle other responses sequentially. @@ -316,7 +410,10 @@ blocking." http-write (@@ (web server http) http-close)) -(define* (make-request-handler store #:key narinfo-ttl) +(define* (make-request-handler store + #:key + narinfo-ttl + (compression %no-compression)) (lambda (request body) (format #t "~a ~a~%" (request-method request) @@ -330,16 +427,37 @@ blocking." (((= extract-narinfo-hash (? string? hash))) ;; TODO: Register roots for HASH that will somehow remain for ;; NARINFO-TTL. - (render-narinfo store request hash #:ttl narinfo-ttl)) + (render-narinfo store request hash + #:ttl narinfo-ttl + #:compression compression)) + + ;; Use different URLs depending on the compression type. This + ;; guarantees that /nar URLs remain valid even when 'guix publish' + ;; is restarted with different compression parameters. + ;; /nar/<store-item> (("nar" store-item) - (render-nar store request store-item)) + (render-nar store request store-item + #:compression %no-compression)) + ;; /nar/gzip/<store-item> + (("nar" "gzip" store-item) + (if (zlib-available?) + (render-nar store request store-item + #:compression + (match compression + (($ <compression> 'gzip) + compression) + (_ + %default-gzip-compression))) + (not-found request))) (_ (not-found request))) (not-found request)))) (define* (run-publish-server socket store - #:key narinfo-ttl) - (run-server (make-request-handler store #:narinfo-ttl narinfo-ttl) + #:key (compression %no-compression) narinfo-ttl) + (run-server (make-request-handler store + #:narinfo-ttl narinfo-ttl + #:compression compression) concurrent-http-server `(#:socket ,socket))) @@ -378,6 +496,7 @@ blocking." (user (assoc-ref opts 'user)) (port (assoc-ref opts 'port)) (ttl (assoc-ref opts 'narinfo-ttl)) + (compression (assoc-ref opts 'compression)) (address (let ((addr (assoc-ref opts 'address))) (make-socket-address (sockaddr:fam addr) (sockaddr:addr addr) @@ -404,4 +523,6 @@ consider using the '--user' option!~%"))) (when repl-port (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) (with-store store - (run-publish-server socket store #:narinfo-ttl ttl))))) + (run-publish-server socket store + #:compression compression + #:narinfo-ttl ttl))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 5722aa821d..8827c45fb8 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -610,7 +610,8 @@ if file doesn't exist, and the narinfo otherwise." (update-progress!) (cons narinfo result)) (let* ((path (uri-path (request-uri request))) - (hash-part (string-drop-right path 8))) ; drop ".narinfo" + (hash-part (basename + (string-drop-right path 8)))) ;drop ".narinfo" (if len (get-bytevector-n port len) (read-to-eof port)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index dd1e534c9b..e2c6b2efee 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -362,7 +362,7 @@ it atomically, and then run OS's activation script." ;; The activation script may modify '%load-path' & co., so protect ;; against that. This is necessary to ensure that ;; 'upgrade-shepherd-services' gets to see the right modules when it - ;; computes derivations with (gexp->derivation #:modules …). + ;; computes derivations with 'gexp->derivation'. (save-load-path-excursion (primitive-load (derivation->output-path script)))) diff --git a/guix/store.scm b/guix/store.scm index 276684e2fb..9f409b4209 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -510,7 +510,7 @@ encoding conversion errors." (map (if (false-if-exception (resolve-interface '(gnutls))) (cut string-append "https://" <>) (cut string-append "http://" <>)) - '("mirror.hydra.gnu.org" "hydra.gnu.org"))) + '("mirror.hydra.gnu.org"))) (define* (set-build-options server #:key keep-failed? keep-going? fallback? diff --git a/guix/svn-download.scm b/guix/svn-download.scm index d6853ca861..c1200fa0c5 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> ;;; ;;; This file is part of GNU Guix. @@ -41,8 +41,10 @@ (define-record-type* <svn-reference> svn-reference make-svn-reference svn-reference? - (url svn-reference-url) ; string - (revision svn-reference-revision)) ; number + (url svn-reference-url) ; string + (revision svn-reference-revision) ; number + (user-name svn-reference-user-name (default #f)) + (password svn-reference-password (default #f))) (define (subversion-package) "Return the default Subversion package." @@ -57,12 +59,16 @@ object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define build - #~(begin - (use-modules (guix build svn)) - (svn-fetch '#$(svn-reference-url ref) - '#$(svn-reference-revision ref) - #$output - #:svn-command (string-append #+svn "/bin/svn")))) + (with-imported-modules '((guix build svn) + (guix build utils)) + #~(begin + (use-modules (guix build svn)) + (svn-fetch '#$(svn-reference-url ref) + '#$(svn-reference-revision ref) + #$output + #:svn-command (string-append #+svn "/bin/svn") + #:user-name #$(svn-reference-user-name ref) + #:password #$(svn-reference-password ref))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "svn-checkout") build @@ -70,8 +76,6 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:hash-algo hash-algo #:hash hash #:recursive? #t - #:modules '((guix build svn) - (guix build utils)) #:guile-for-build guile #:local-build? #t))) diff --git a/guix/zlib.scm b/guix/zlib.scm new file mode 100644 index 0000000000..51e5e9e426 --- /dev/null +++ b/guix/zlib.scm @@ -0,0 +1,234 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 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 zlib) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (system foreign) + #:use-module (guix config) + #:export (zlib-available? + make-gzip-input-port + make-gzip-output-port + call-with-gzip-input-port + call-with-gzip-output-port + %default-buffer-size + %default-compression-level)) + +;;; Commentary: +;;; +;;; Bindings to the gzip-related part of zlib's API. The main limitation of +;;; this API is that it requires a file descriptor as the source or sink. +;;; +;;; Code: + +(define %zlib + ;; File name of zlib's shared library. When updating via 'guix pull', + ;; '%libz' might be undefined so protect against it. + (delay (dynamic-link (if (defined? '%libz) + %libz + "libz")))) + +(define (zlib-available?) + "Return true if zlib is available, #f otherwise." + (false-if-exception (force %zlib))) + +(define (zlib-procedure ret name parameters) + "Return a procedure corresponding to C function NAME in libz, or #f if +either zlib or the function could not be found." + (match (false-if-exception (dynamic-func name (force %zlib))) + ((? pointer? ptr) + (pointer->procedure ret ptr parameters)) + (#f + #f))) + +(define-wrapped-pointer-type <gzip-file> + ;; Scheme counterpart of the 'gzFile' opaque type. + gzip-file? + pointer->gzip-file + gzip-file->pointer + (lambda (obj port) + (format port "#<gzip-file ~a>" + (number->string (object-address obj) 16)))) + +(define gzerror + (let ((proc (zlib-procedure '* "gzerror" '(* *)))) + (lambda (gzfile) + (let* ((errnum* (make-bytevector (sizeof int))) + (ptr (proc (gzip-file->pointer gzfile) + (bytevector->pointer errnum*)))) + (values (bytevector-sint-ref errnum* 0 + (native-endianness) (sizeof int)) + (pointer->string ptr)))))) + +(define gzdopen + (let ((proc (zlib-procedure '* "gzdopen" (list int '*)))) + (lambda (fd mode) + "Open file descriptor FD as a gzip stream with the given MODE. MODE must +be a string denoting the how FD is to be opened, such as \"r\" for reading or +\"w9\" for writing data compressed at level 9 to FD. Calling 'gzclose' also +closes FD." + (let ((result (proc fd (string->pointer mode)))) + (if (null-pointer? result) + (throw 'zlib-error 'gzdopen) + (pointer->gzip-file result)))))) + +(define gzread! + (let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int)))) + (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) + "Read up to COUNT bytes from GZFILE into BV at offset START. Return the +number of uncompressed bytes actually read." + (let ((ret (proc (gzip-file->pointer gzfile) + (bytevector->pointer bv start) + count))) + (if (< ret 0) + (throw 'zlib-error 'gzread! ret) + ret))))) + +(define gzwrite + (let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int)))) + (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) + "Write up to COUNT bytes from BV at offset START into GZFILE. Return +the number of uncompressed bytes written, a strictly positive integer." + (let ((ret (proc (gzip-file->pointer gzfile) + (bytevector->pointer bv start) + count))) + (if (<= ret 0) + (throw 'zlib-error 'gzwrite ret) + ret))))) + +(define gzbuffer! + (let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int)))) + (lambda (gzfile size) + "Change the internal buffer size of GZFILE to SIZE bytes." + (let ((ret (proc (gzip-file->pointer gzfile) size))) + (unless (zero? ret) + (throw 'zlib-error 'gzbuffer! ret)))))) + +(define gzeof? + (let ((proc (zlib-procedure int "gzeof" '(*)))) + (lambda (gzfile) + "Return true if the end-of-file has been reached on GZFILE." + (not (zero? (proc (gzip-file->pointer gzfile))))))) + +(define gzclose + (let ((proc (zlib-procedure int "gzclose" '(*)))) + (lambda (gzfile) + "Close GZFILE." + (let ((ret (proc (gzip-file->pointer gzfile)))) + (unless (zero? ret) + (throw 'zlib-error 'gzclose ret (gzerror gzfile))))))) + + + +;;; +;;; Port interface. +;;; + +(define %default-buffer-size + ;; Default buffer size, as documented in <zlib.h>. + 8192) + +(define %default-compression-level + ;; Z_DEFAULT_COMPRESSION. + -1) + +(define (close-procedure gzfile port) + "Return a procedure that closes GZFILE, ensuring its underlying PORT is +closed even if closing GZFILE triggers an exception." + (lambda () + (catch 'zlib-error + (lambda () + ;; 'gzclose' closes the underlying file descriptor. 'close-port' + ;; calls close(2), gets EBADF, which is ignores. + (gzclose gzfile) + (close-port port)) + (lambda args + ;; Make sure PORT is closed despite the zlib error. + (close-port port) + (apply throw args))))) + +(define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size)) + "Return an input port that decompresses data read from PORT, a file port. +PORT is automatically closed when the resulting port is closed. BUFFER-SIZE +is the size in bytes of the internal buffer, 8 KiB by default; using a larger +buffer increases decompression speed." + (define gzfile + (gzdopen (fileno port) "r")) + + (define (read! bv start count) + ;; XXX: Can 'gzread!' return zero even though we haven't reached the EOF? + (gzread! gzfile bv start count)) + + (unless (= buffer-size %default-buffer-size) + (gzbuffer! gzfile buffer-size)) + + (make-custom-binary-input-port "gzip-input" read! #f #f + (close-procedure gzfile port))) + +(define* (make-gzip-output-port port + #:key + (level %default-compression-level) + (buffer-size %default-buffer-size)) + "Return an output port that compresses data at the given LEVEL, using PORT, +a file port, as its sink. PORT is automatically closed when the resulting +port is closed." + (define gzfile + (gzdopen (fileno port) + (string-append "w" (number->string level)))) + + (define (write! bv start count) + (gzwrite gzfile bv start count)) + + (unless (= buffer-size %default-buffer-size) + (gzbuffer! gzfile buffer-size)) + + (make-custom-binary-output-port "gzip-output" write! #f #f + (close-procedure gzfile port))) + +(define* (call-with-gzip-input-port port proc + #:key (buffer-size %default-buffer-size)) + "Call PROC with a port that wraps PORT and decompresses data read from it. +PORT is closed upon completion. The gzip internal buffer size is set to +BUFFER-SIZE bytes." + (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size))) + (dynamic-wind + (const #t) + (lambda () + (proc gzip)) + (lambda () + (close-port gzip))))) + +(define* (call-with-gzip-output-port port proc + #:key + (level %default-compression-level) + (buffer-size %default-buffer-size)) + "Call PROC with an output port that wraps PORT and compresses data. PORT is +close upon completion. The gzip internal buffer size is set to BUFFER-SIZE +bytes." + (let ((gzip (make-gzip-output-port port + #:level level + #:buffer-size buffer-size))) + (dynamic-wind + (const #t) + (lambda () + (proc gzip)) + (lambda () + (close-port gzip))))) + +;;; zlib.scm ends here |