diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/base16.scm | 83 | ||||
| -rw-r--r-- | guix/build-system/cargo.scm | 3 | ||||
| -rw-r--r-- | guix/build-system/r.scm | 2 | ||||
| -rw-r--r-- | guix/build/cargo-build-system.scm | 116 | ||||
| -rw-r--r-- | guix/build/download.scm | 32 | ||||
| -rw-r--r-- | guix/derivations.scm | 1 | ||||
| -rw-r--r-- | guix/docker.scm | 154 | ||||
| -rw-r--r-- | guix/gexp.scm | 40 | ||||
| -rw-r--r-- | guix/http-client.scm | 25 | ||||
| -rw-r--r-- | guix/import/cran.scm | 18 | ||||
| -rw-r--r-- | guix/import/snix.scm | 3 | ||||
| -rw-r--r-- | guix/memoization.scm | 21 | ||||
| -rw-r--r-- | guix/pk-crypto.scm | 6 | ||||
| -rw-r--r-- | guix/profiles.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/archive.scm | 31 | ||||
| -rw-r--r-- | guix/scripts/authenticate.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/download.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/hash.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 151 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 23 | ||||
| -rw-r--r-- | guix/serialization.scm | 3 | ||||
| -rw-r--r-- | guix/store.scm | 1 | ||||
| -rw-r--r-- | guix/utils.scm | 65 |
24 files changed, 505 insertions, 299 deletions
diff --git a/guix/base16.scm b/guix/base16.scm new file mode 100644 index 0000000000..6c15a9f588 --- /dev/null +++ b/guix/base16.scm @@ -0,0 +1,83 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2014, 2017 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 base16) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-60) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 vlist) + #:use-module (ice-9 format) + #:export (bytevector->base16-string + base16-string->bytevector)) + +;;; +;;; Base 16. +;;; + +(define (bytevector->base16-string bv) + "Return the hexadecimal representation of BV's contents." + (define len + (bytevector-length bv)) + + (let-syntax ((base16-chars (lambda (s) + (syntax-case s () + (_ + (let ((v (list->vector + (unfold (cut > <> 255) + (lambda (n) + (format #f "~2,'0x" n)) + 1+ + 0)))) + v)))))) + (define chars base16-chars) + (let loop ((i len) + (r '())) + (if (zero? i) + (string-concatenate r) + (let ((i (- i 1))) + (loop i + (cons (vector-ref chars (bytevector-u8-ref bv i)) r))))))) + +(define base16-string->bytevector + (let ((chars->value (fold (lambda (i r) + (vhash-consv (string-ref (number->string i 16) + 0) + i r)) + vlist-null + (iota 16)))) + (lambda (s) + "Return the bytevector whose hexadecimal representation is string S." + (define bv + (make-bytevector (quotient (string-length s) 2) 0)) + + (string-fold (lambda (chr i) + (let ((j (quotient i 2)) + (v (and=> (vhash-assv chr chars->value) cdr))) + (if v + (if (zero? (logand i 1)) + (bytevector-u8-set! bv j + (arithmetic-shift v 4)) + (let ((w (bytevector-u8-ref bv j))) + (bytevector-u8-set! bv j (logior v w)))) + (error "invalid hexadecimal character" chr))) + (+ i 1)) + 0 + s) + bv))) + diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index 578c4446a4..c637fbb162 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -64,7 +64,7 @@ to NAME and VERSION." #:key (tests? #t) (test-target #f) - (configure-flags #f) + (cargo-build-flags ''("--release")) (phases '(@ (guix build cargo-build-system) %standard-phases)) (outputs '("out")) @@ -89,6 +89,7 @@ to NAME and VERSION." source)) #:system ,system #:test-target ,test-target + #:cargo-build-flags ,cargo-build-flags #:tests? ,tests? #:phases ,phases #:outputs %outputs diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index e8269fdeb1..c649036210 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -62,7 +62,7 @@ release corresponding to NAME and VERSION." "Return the default R package." ;; Lazily resolve the binding to avoid a circular dependency. (let ((r-mod (resolve-interface '(gnu packages statistics)))) - (module-ref r-mod 'r))) + (module-ref r-mod 'r-minimal))) (define* (lower name #:key source inputs native-inputs outputs system target diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 7d656a8d58..f11d858749 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -19,13 +19,16 @@ (define-module (guix build cargo-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build utils) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) #:use-module (ice-9 ftw) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases - cargo-build)) + cargo-build + generate-checksums)) ;; Commentary: ;; @@ -45,27 +48,57 @@ "Replace Cargo.toml [dependencies] section with guix inputs." ;; Make sure Cargo.toml is writeable when the crate uses git-fetch. (chmod "Cargo.toml" #o644) - (let ((port (open-file "Cargo.toml" "a" #:encoding "utf-8"))) - (format port "~%[replace]~%") - (for-each - (match-lambda - ((name . path) - (let ((crate (package-name->crate-name name))) - (when (and crate path) - (match (string-split (basename path) #\-) - ((_ ... version) - (format port "\"~a:~a\" = { path = \"~a/share/rust-source\" }~%" - crate version path))))))) - inputs) - (close-port port)) + (chmod "." #o755) + (if (not (file-exists? "vendor")) + (if (not (file-exists? "Cargo.lock")) + (begin + (substitute* "Cargo.toml" + ((".*32-sys.*") " +") + ((".*winapi.*") " +") + ((".*core-foundation.*") " +")) + ;; Prepare one new directory with all the required dependencies. + ;; It's necessary to do this (instead of just using /gnu/store as the + ;; directory) because we want to hide the libraries in subdirectories + ;; share/rust-source/... instead of polluting the user's profile root. + (mkdir "vendor") + (for-each + (match-lambda + ((name . path) + (let ((crate (package-name->crate-name name))) + (when (and crate path) + (match (string-split (basename path) #\-) + ((_ ... version) + (symlink (string-append path "/share/rust-source") + (string-append "vendor/" (basename path))))))))) + inputs) + ;; Configure cargo to actually use this new directory. + (mkdir-p ".cargo") + (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8"))) + (display " +[source.crates-io] +registry = 'https://github.com/rust-lang/crates.io-index' +replace-with = 'vendored-sources' + +[source.vendored-sources] +directory = '" port) + (display (getcwd) port) + (display "/vendor" port) + (display "' +" port) + (close-port port))))) + (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc")) + + ;(setenv "CARGO_HOME" "/gnu/store") + ; (setenv "CMAKE_C_COMPILER" cc) #t) -(define* (build #:key (cargo-build-flags '("--release" "--frozen")) +(define* (build #:key (cargo-build-flags '("--release")) #:allow-other-keys) "Build a given Cargo package." - (if (file-exists? "Cargo.lock") - (zero? (apply system* `("cargo" "build" ,@cargo-build-flags))) - #t)) + (zero? (apply system* `("cargo" "build" ,@cargo-build-flags)))) (define* (check #:key tests? #:allow-other-keys) "Run tests for a given Cargo package." @@ -73,6 +106,44 @@ (zero? (system* "cargo" "test")) #t)) +(define (file-sha256 file-name) + "Calculate the hexdigest of the sha256 checksum of FILE-NAME and return it." + (let ((port (open-pipe* OPEN_READ + "sha256sum" + "--" + file-name))) + (let ((result (read-delimited " " port))) + (close-pipe port) + result))) + +;; Example dir-name: "/gnu/store/hwlr49riz3la33m6in2n898ly045ylld-rust-rand-0.3.15". +(define (generate-checksums dir-name src-name) + "Given DIR-NAME, checksum all the files in it one by one and put the + result into the file \".cargo-checksum.json\" in the same directory. + Also includes the checksum of an extra file SRC-NAME as if it was + part of the directory DIR-NAME with name \"package\"." + (let* ((file-names (find-files dir-name ".")) + (dir-prefix-name (string-append dir-name "/")) + (dir-prefix-name-len (string-length dir-prefix-name)) + (checksums-file-name (string-append dir-name "/.cargo-checksum.json"))) + (call-with-output-file checksums-file-name + (lambda (port) + (display "{\"files\":{" port) + (let ((sep "")) + (for-each (lambda (file-name) + (let ((file-relative-name (string-drop file-name dir-prefix-name-len))) + (display sep port) + (set! sep ",") + (write file-relative-name port) + (display ":" port) + (write (file-sha256 file-name) port))) file-names)) + (display "},\"package\":" port) + (write (file-sha256 src-name) port) + (display "}" port))))) + +(define (touch file-name) + (call-with-output-file file-name (const #t))) + (define* (install #:key inputs outputs #:allow-other-keys) "Install a given Cargo package." (let* ((out (assoc-ref outputs "out")) @@ -86,16 +157,19 @@ ;; distributing crates as source and replacing ;; references in Cargo.toml with store paths. (copy-recursively "src" (string-append rsrc "/src")) + (touch (string-append rsrc "/.cargo-ok")) + (generate-checksums rsrc src) (install-file "Cargo.toml" rsrc) ;; When the package includes executables we install ;; it using cargo install. This fails when the crate ;; doesn't contain an executable. (if (file-exists? "Cargo.lock") - (system* "cargo" "install" "--root" out) - (mkdir out)))) + (zero? (system* "cargo" "install" "--root" out)) + (begin + (mkdir out) + #t)))) (define %standard-phases - ;; 'configure' phase is not needed. (modify-phases gnu:%standard-phases (replace 'configure configure) (replace 'build build) diff --git a/guix/build/download.scm b/guix/build/download.scm index e7a7afecd1..36c815c167 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -464,6 +464,9 @@ ETIMEDOUT error is raised." "Like 'open-socket-for-uri', but also handle HTTPS connections. The resulting port must be closed with 'close-connection'. When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." + ;; Note: Guile 2.2.0's (web client) has a same-named export that's actually + ;; undefined. See Guile commit 011669af3b428e5626f7bbf66b11d57d9768c047. + (define https? (eq? 'https (uri-scheme uri))) @@ -512,12 +515,6 @@ port if PORT is a TLS session record port." 'set-port-encoding! (lambda (p e) #f)) -;; 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)) - - ;; XXX: Work around <http://bugs.gnu.org/23421>, fixed in Guile commit ;; 16050431f29d56f80c4a8253506fc851b8441840. Guile's date validation ;; procedure rejects dates in which the hour is not padded with a zero but @@ -682,12 +679,6 @@ the connection could not be established in less than TIMEOUT seconds. Return FILE on success. When VERIFY-CERTIFICATE? is true, verify HTTPS certificates; otherwise simply ignore them." - (define post-2.0.7? - (or (> (string->number (major-version)) 2) - (> (string->number (minor-version)) 0) - (> (string->number (micro-version)) 7) - (string>? (version) "2.0.7"))) - (define headers `(;; Some web sites, such as http://dist.schmorp.de, would block you if ;; there's no 'User-Agent' header, presumably on the assumption that @@ -712,20 +703,9 @@ certificates; otherwise simply ignore them." #:verify-certificate? verify-certificate?)) ((resp bv-or-port) - ;; XXX: `http-get*' was introduced in 2.0.7, and replaced by - ;; #:streaming? in 2.0.8. We know we're using it within the - ;; chroot, but `guix-download' might be using a different - ;; version. So keep this compatibility hack for now. - (if post-2.0.7? - (http-get uri #:port connection #:decode-body? #f - #:streaming? #t - #:headers headers) - (if (module-defined? (resolve-interface '(web client)) - 'http-get*) - (http-get* uri #:port connection #:decode-body? #f - #:headers headers) - (http-get uri #:port connection #:decode-body? #f - #:extra-headers headers)))) + (http-get uri #:port connection #:decode-body? #f + #:streaming? #t + #:headers headers)) ((code) (response-code resp)) ((size) diff --git a/guix/derivations.scm b/guix/derivations.scm index 47a783f42f..e02d1ee036 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -31,6 +31,7 @@ #:use-module (ice-9 vlist) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix base16) #:use-module (guix memoization) #:use-module (guix combinators) #:use-module (guix monads) diff --git a/guix/docker.scm b/guix/docker.scm index dbe1e5351c..060232148e 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,16 +19,20 @@ (define-module (guix docker) #:use-module (guix hash) - #:use-module (guix store) - #:use-module (guix utils) + #:use-module (guix base16) #:use-module ((guix build utils) - #:select (delete-file-recursively + #:select (mkdir-p + delete-file-recursively with-directory-excursion)) - #:use-module (json) + #:use-module (guix build store-copy) + #:use-module (srfi srfi-19) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:export (build-docker-image)) +;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co. +(module-use! (current-module) (resolve-interface '(json))) + ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image ;; containing the closure at PATH. (define docker-id @@ -80,48 +85,99 @@ (rootfs . ((type . "layers") (diff_ids . (,(layer-diff-id layer))))))) -(define* (build-docker-image path #:key system) - "Generate a Docker image archive from the given store PATH. The image -contains the closure of the given store item." - (let ((id (docker-id path)) - (time (strftime "%FT%TZ" (localtime (current-time)))) - (name (string-append (getcwd) - "/docker-image-" (basename path) ".tar")) - (arch (match system - ("x86_64-linux" "amd64") - ("i686-linux" "386") - ("armhf-linux" "arm") - ("mips64el-linux" "mips64le")))) - (and (call-with-temporary-directory - (lambda (directory) - (with-directory-excursion directory - ;; Add symlink from /bin to /gnu/store/.../bin - (symlink (string-append path "/bin") "bin") - - (mkdir id) - (with-directory-excursion id - (with-output-to-file "VERSION" - (lambda () (display schema-version))) - (with-output-to-file "json" - (lambda () (scm->json (image-description id time)))) - - ;; Wrap it up - (let ((items (with-store store - (requisites store (list path))))) - (and (zero? (apply system* "tar" "-cf" "layer.tar" - (cons "../bin" items))) - (delete-file "../bin")))) - - (with-output-to-file "config.json" - (lambda () - (scm->json (config (string-append id "/layer.tar") - time arch)))) - (with-output-to-file "manifest.json" - (lambda () - (scm->json (manifest path id)))) - (with-output-to-file "repositories" - (lambda () - (scm->json (repositories path id))))) - (and (zero? (system* "tar" "-C" directory "-cf" name ".")) - (begin (delete-file-recursively directory) #t)))) - name))) +(define %tar-determinism-options + ;; GNU tar options to produce archives deterministically. + '("--sort=name" "--mtime=@1" + "--owner=root:0" "--group=root:0")) + +(define symlink-source + (match-lambda + ((source '-> target) + (string-trim source #\/)))) + +(define (topmost-component file) + "Return the topmost component of FILE. For instance, if FILE is \"/a/b/c\", +return \"a\"." + (match (string-tokenize file (char-set-complement (char-set #\/))) + ((first rest ...) + first))) + +(define* (build-docker-image image path + #:key closure compressor + (symlinks '()) + (system (utsname:machine (uname))) + (creation-time (current-time time-utc))) + "Write to IMAGE a Docker image archive from the given store PATH. The image +contains the closure of PATH, as specified in CLOSURE (a file produced by +#:references-graphs). SYMLINKS must be a list of (SOURCE -> TARGET) tuples +describing symlinks to be created in the image, where each TARGET is relative +to PATH. SYSTEM is a GNU triplet (or prefix thereof) of the system the +binaries at PATH are for; it is used to produce metadata in the image. + +Use COMPRESSOR, a command such as '(\"gzip\" \"-9n\"), to compress IMAGE. Use +CREATION-TIME, a SRFI-19 time-utc object, as the creation time in metadata." + (let ((directory "/tmp/docker-image") ;temporary working directory + (closure (canonicalize-path closure)) + (id (docker-id path)) + (time (date->string (time-utc->date creation-time) "~4")) + (arch (let-syntax ((cond* (syntax-rules () + ((_ (pattern clause) ...) + (cond ((string-prefix? pattern system) + clause) + ... + (else + (error "unsupported system" + system))))))) + (cond* ("x86_64" "amd64") + ("i686" "386") + ("arm" "arm") + ("mips64" "mips64le"))))) + ;; Make sure we start with a fresh, empty working directory. + (mkdir directory) + + (and (with-directory-excursion directory + (mkdir id) + (with-directory-excursion id + (with-output-to-file "VERSION" + (lambda () (display schema-version))) + (with-output-to-file "json" + (lambda () (scm->json (image-description id time)))) + + ;; Wrap it up. + (let ((items (call-with-input-file closure + read-reference-graph))) + ;; Create SYMLINKS. + (for-each (match-lambda + ((source '-> target) + (let ((source (string-trim source #\/))) + (mkdir-p (dirname source)) + (symlink (string-append path "/" target) + source)))) + symlinks) + + (and (zero? (apply system* "tar" "-cf" "layer.tar" + (append %tar-determinism-options + items + (map symlink-source symlinks)))) + (for-each delete-file-recursively + (map (compose topmost-component symlink-source) + symlinks))))) + + (with-output-to-file "config.json" + (lambda () + (scm->json (config (string-append id "/layer.tar") + time arch)))) + (with-output-to-file "manifest.json" + (lambda () + (scm->json (manifest path id)))) + (with-output-to-file "repositories" + (lambda () + (scm->json (repositories path id))))) + + (and (zero? (apply system* "tar" "-C" directory "-cf" image + `(,@%tar-determinism-options + ,@(if compressor + (list "-I" (string-join compressor)) + '()) + "."))) + (begin (delete-file-recursively directory) #t))))) diff --git a/guix/gexp.scm b/guix/gexp.scm index d11ed177fe..1b8e43e994 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -912,13 +912,17 @@ environment." (system (%current-system)) (guile (%guile-for-build))) "Return a derivation that imports FILES into STORE. FILES must be a list -of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file -system, imported, and appears under FINAL-PATH in the resulting store path." +of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the +resulting store path. FILE can be either a file name, or a file-like object, +as returned by 'local-file' for example." (define file-pair (match-lambda - ((final-path . file-name) + ((final-path . (? string? file-name)) (mlet %store-monad ((file (interned-file file-name (basename final-path)))) + (return (list final-path file)))) + ((final-path . file-like) + (mlet %store-monad ((file (lower-object file-like system))) (return (list final-path file)))))) (mlet %store-monad ((files (sequence %store-monad @@ -950,14 +954,28 @@ system, imported, and appears under FINAL-PATH in the resulting store path." (guile (%guile-for-build)) (module-path %load-path)) "Return a derivation that contains the source files of MODULES, a list of -module names such as `(ice-9 q)'. All of MODULES must be in the MODULE-PATH -search path." - ;; TODO: Determine the closure of MODULES, build the `.go' files, - ;; canonicalize the source files through read/write, etc. - (let ((files (map (lambda (m) - (let ((f (module->source-file-name m))) - (cons f (search-path* module-path f)))) - modules))) +module names such as `(ice-9 q)'. All of MODULES must be either names of +modules to be found in the MODULE-PATH search path, or a module name followed +by an arrow followed by a file-like object. For example: + + (imported-modules `((guix build utils) + (guix gcrypt) + ((guix config) => ,(scheme-file …)))) + +In this example, the first two modules are taken from MODULE-PATH, and the +last one is created from the given <scheme-file> object." + (mlet %store-monad ((files + (mapm %store-monad + (match-lambda + (((module ...) '=> file) + (return + (cons (module->source-file-name module) + file))) + ((module ...) + (let ((f (module->source-file-name module))) + (return + (cons f (search-path* module-path f)))))) + modules))) (imported-files files #:name name #:system system #:guile guile))) diff --git a/guix/http-client.scm b/guix/http-client.scm index 78d39a0208..6874c51db6 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -38,7 +38,9 @@ #:select (mkdir-p dump-port)) #:use-module ((guix build download) #:select (open-socket-for-uri - open-connection-for-uri resolve-uri-reference)) + (open-connection-for-uri + . guix:open-connection-for-uri) + resolve-uri-reference)) #:re-export (open-socket-for-uri) #:export (&http-get-error http-get-error? @@ -217,10 +219,6 @@ or if EOF is reached." (when (module-variable %web-http 'read-line*) (module-set! %web-http 'read-line* read-header-line)))) -;; 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* (http-fetch uri #:key port (text? #f) (buffered? #t) keep-alive? (verify-certificate? #t) @@ -238,9 +236,9 @@ Raise an '&http-get-error' condition if downloading fails." (let loop ((uri (if (string? uri) (string->uri uri) uri))) - (let ((port (or port (open-connection-for-uri uri - #:verify-certificate? - verify-certificate?))) + (let ((port (or port (guix:open-connection-for-uri uri + #:verify-certificate? + verify-certificate?))) (headers (match (uri-userinfo uri) ((? string? str) (cons (cons 'Authorization @@ -252,14 +250,9 @@ Raise an '&http-get-error' condition if downloading fails." (unless (or buffered? (not (file-port? port))) (setvbuf port _IONBF)) (let*-values (((resp data) - ;; Try hard to use the API du jour to get an input port. - (if (guile-version>? "2.0.7") - (http-get uri #:streaming? #t #:port port - #:keep-alive? #t - #:headers headers) ; 2.0.9+ - (http-get* uri #:decode-body? text? ; 2.0.7 - #:keep-alive? #t - #:port port #:headers headers))) + (http-get uri #:streaming? #t #:port port + #:keep-alive? #t + #:headers headers)) ((code) (response-code resp))) (case code diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 40cdea029b..7521a39bc9 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -164,32 +164,16 @@ empty list when the FIELD cannot be found." (map string-trim-both items)))))) (define default-r-packages - (list "KernSmooth" - "MASS" - "Matrix" - "base" - "boot" - "class" - "cluster" - "codetools" + (list "base" "compiler" - "datasets" - "foreign" "grDevices" "graphics" "grid" - "lattice" "methods" - "mgcv" - "nlme" - "nnet" "parallel" - "rpart" - "spatial" "splines" "stats" "stats4" - "survival" "tcltk" "tools" "translations" diff --git a/guix/import/snix.scm b/guix/import/snix.scm index bc75cbfda5..778768ff2d 100644 --- a/guix/import/snix.scm +++ b/guix/import/snix.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,6 +39,7 @@ #:use-module ((guix build utils) #:select (package-name->name+version)) #:use-module (guix import utils) + #:use-module (guix base16) #:use-module (guix base32) #:use-module (guix config) #:use-module (guix gnu-maintenance) diff --git a/guix/memoization.scm b/guix/memoization.scm index d64f60fe9c..5cae283610 100644 --- a/guix/memoization.scm +++ b/guix/memoization.scm @@ -31,9 +31,6 @@ (define-syntax-rule (return/1 value) value) -(define %nothing ;nothingness - (list 'this 'is 'nothing)) - (define-syntax define-cache-procedure (syntax-rules () "Define a procedure NAME that implements a cache using HASH-REF and @@ -41,15 +38,17 @@ HASH-SET!. Use CALL to invoke the thunk and RETURN to return its value; CALL and RETURN are used to distinguish between multiple-value and single-value returns." ((_ name hash-ref hash-set! call return) - (define (name cache key thunk) - "Cache the result of THUNK under KEY in CACHE, or return the + (define name + (let ((%nothing '(this is nothing))) + (lambda (cache key thunk) + "Cache the result of THUNK under KEY in CACHE, or return the already-cached result." - (let ((results (hash-ref cache key %nothing))) - (if (eq? results %nothing) - (let ((results (call thunk))) - (hash-set! cache key results) - (return results)) - (return results))))) + (let ((results (hash-ref cache key %nothing))) + (if (eq? results %nothing) + (let ((results (call thunk))) + (hash-set! cache key results) + (return results)) + (return results))))))) ((_ name hash-ref hash-set!) (define-cache-procedure name hash-ref hash-set! call/mv return/mv)))) diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm index f90c2e61d5..7017006a71 100644 --- a/guix/pk-crypto.scm +++ b/guix/pk-crypto.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,9 +17,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix pk-crypto) - #:use-module ((guix utils) - #:select (bytevector->base16-string - base16-string->bytevector)) + #:use-module (guix base16) #:use-module (guix gcrypt) #:use-module (system foreign) diff --git a/guix/profiles.scm b/guix/profiles.scm index de82eae348..a62a076f64 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> @@ -933,13 +933,16 @@ files for the truetype fonts of the @var{manifest} entries." #:key (hooks %default-profile-hooks) (locales? #t) - system) + system target) "Return a derivation that builds a profile (aka. 'user environment') with the given MANIFEST. The profile includes additional derivations returned by the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc. When LOCALES? is true, the build is performed under a UTF-8 locale; this adds -a dependency on the 'glibc-utf8-locales' package." +a dependency on the 'glibc-utf8-locales' package. + +When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST +are cross-built for TARGET." (mlet %store-monad ((system (if system (return system) (current-system))) @@ -1000,6 +1003,7 @@ a dependency on the 'glibc-utf8-locales' package." (gexp->derivation "profile" builder #:system system + #:target target ;; Not worth offloading. #:local-build? #t diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index cad279fb50..8137455a9d 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,6 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,11 +44,6 @@ #:export (guix-archive options->derivations+files)) -;; XXX: Use this hack instead of #:autoload to avoid compilation errors. -;; See <http://bugs.gnu.org/12202>. -(module-autoload! (current-module) - '(guix docker) '(build-docker-image)) - ;;; ;;; Command-line options. @@ -57,8 +51,7 @@ (define %default-options ;; Alist of default option values. - `((format . "nar") - (system . ,(%current-system)) + `((system . ,(%current-system)) (substitutes? . #t) (graft? . #t) (max-silent-time . 3600) @@ -70,8 +63,6 @@ Export/import one or more packages from/to the store.\n")) (display (_ " --export export the specified files/packages to stdout")) (display (_ " - --format=FMT export files/packages in the specified format FMT")) - (display (_ " -r, --recursive combined with '--export', include dependencies")) (display (_ " --import import from the archive passed on stdin")) @@ -126,9 +117,6 @@ Export/import one or more packages from/to the store.\n")) (option '("export") #f #f (lambda (opt name arg result) (alist-cons 'export #t result))) - (option '(#\f "format") #t #f - (lambda (opt name arg result . rest) - (alist-cons 'format arg result))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'export-recursive? #t result))) @@ -258,21 +246,8 @@ resulting archive to the standard output port." (if (or (assoc-ref opts 'dry-run?) (build-derivations store drv)) - (match (assoc-ref opts 'format) - ("nar" - (export-paths store files (current-output-port) - #:recursive? (assoc-ref opts 'export-recursive?))) - ("docker" - (match files - ((file) - (let ((system (assoc-ref opts 'system))) - (format #t "~a\n" - (build-docker-image file #:system system)))) - (x - ;; TODO: Remove this restriction. - (leave (_ "only a single item can be exported to Docker~%"))))) - (format - (leave (_ "~a: unknown archive format~%") format))) + (export-paths store files (current-output-port) + #:recursive? (assoc-ref opts 'export-recursive?)) (leave (_ "unable to export the given packages~%"))))) (define (generate-key-pair parameters) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index d9f799df26..d9a312f1da 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, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,7 +18,7 @@ (define-module (guix scripts authenticate) #:use-module (guix config) - #:use-module (guix utils) + #:use-module (guix base16) #:use-module (guix pk-crypto) #:use-module (guix pki) #:use-module (guix ui) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index dffff79729..1ddfd648cd 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,7 +21,7 @@ #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix hash) - #:use-module (guix utils) + #:use-module (guix base16) #:use-module (guix base32) #:use-module ((guix download) #:hide (url-fetch)) #:use-module ((guix build download) diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index 640b2417d2..a048b53461 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -24,7 +24,7 @@ #:use-module (guix serialization) #:use-module (guix ui) #:use-module (guix scripts) - #:use-module (guix utils) + #:use-module (guix base16) #:use-module (ice-9 binary-ports) #:use-module (rnrs files) #:use-module (ice-9 match) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 776e7332c5..66c82f0409 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -44,7 +44,8 @@ #:use-module (web uri) #:use-module ((guix build download) #:select (maybe-expand-mirrors - open-connection-for-uri + (open-connection-for-uri + . guix:open-connection-for-uri) close-connection)) #:use-module (web request) #:use-module (web response) @@ -377,7 +378,8 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." ((or 'http 'https) (catch #t (lambda () - (let ((port (open-connection-for-uri uri #:timeout timeout)) + (let ((port (guix:open-connection-for-uri + uri #:timeout timeout)) (request (build-request uri #:headers headers))) (define response (dynamic-wind diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 067b1227e0..626c592e1c 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -24,6 +24,7 @@ #:use-module (guix store) #:use-module (guix grafts) #:use-module (guix monads) + #:use-module (guix modules) #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix derivations) @@ -32,6 +33,8 @@ #:use-module (gnu packages compression) #:autoload (gnu packages base) (tar) #:autoload (gnu packages package-management) (guix) + #:autoload (gnu packages gnupg) (libgcrypt) + #:autoload (gnu packages guile) (guile-json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-37) @@ -43,19 +46,22 @@ ;; Type of a compression tool. (define-record-type <compressor> - (compressor name package extension command) + (compressor name extension command) compressor? - (name compressor-name) ;string (e.g., "gzip") - (package compressor-package) ;package - (extension compressor-extension) ;string (e.g., "lz") - (command compressor-command)) ;list (e.g., '("gzip" "-9n")) + (name compressor-name) ;string (e.g., "gzip") + (extension compressor-extension) ;string (e.g., "lz") + (command compressor-command)) ;gexp (e.g., #~("/gnu/store/…/gzip" "-9n")) (define %compressors ;; Available compression tools. - (list (compressor "gzip" gzip "gz" '("gzip" "-9n")) - (compressor "lzip" lzip "lz" '("lzip" "-9")) - (compressor "xz" xz "xz" '("xz" "-e")) - (compressor "bzip2" bzip2 "bz2" '("bzip2" "-9")))) + (list (compressor "gzip" "gz" + #~(#+(file-append gzip "/bin/gzip") "-9n")) + (compressor "lzip" "lz" + #~(#+(file-append lzip "/bin/lzip") "-9")) + (compressor "xz" "xz" + #~(#+(file-append xz "/bin/xz") "-e")) + (compressor "bzip2" "bz2" + #~(#+(file-append bzip2 "/bin/bzip2") "-9")))) (define (lookup-compressor name) "Return the compressor object called NAME. Error out if it could not be @@ -67,7 +73,8 @@ found." (leave (_ "~a: compressor not found~%") name))) (define* (self-contained-tarball name profile - #:key deduplicate? + #:key target + deduplicate? (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -118,8 +125,7 @@ added to the pack." (string-append #$(if localstatedir? (file-append guix "/sbin:") "") - #$tar "/bin:" - #$(compressor-package compressor) "/bin")) + #$tar "/bin")) ;; Note: there is not much to gain here with deduplication and ;; there is the overhead of the '.links' directory, so turn it @@ -139,7 +145,8 @@ added to the pack." (with-directory-excursion %root (exit (zero? (apply system* "tar" - "-I" #$(string-join (compressor-command compressor)) + "-I" + (string-join '#+(compressor-command compressor)) "--format=gnu" ;; Avoid non-determinism in the archive. Use @@ -177,6 +184,63 @@ added to the pack." build #:references-graphs `(("profile" ,profile)))) +(define* (docker-image name profile + #:key target + deduplicate? + (compressor (first %compressors)) + localstatedir? + (symlinks '()) + (tar tar)) + "Return a derivation to construct a Docker image of PROFILE. The +image is a tarball conforming to the Docker Image Specification, compressed +with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it +must a be a GNU triplet and it is used to derive the architecture metadata in +the image." + ;; FIXME: Honor LOCALSTATEDIR?. + (define not-config? + (match-lambda + (('guix 'config) #f) + (('guix rest ...) #t) + (('gnu rest ...) #t) + (rest #f))) + + (define config + ;; (guix config) module for consumption by (guix gcrypt). + (scheme-file "gcrypt-config.scm" + #~(begin + (define-module (guix config) + #:export (%libgcrypt)) + + ;; XXX: Work around <http://bugs.gnu.org/15602>. + (eval-when (expand load eval) + (define %libgcrypt + #+(file-append libgcrypt "/lib/libgcrypt")))))) + + (define build + (with-imported-modules `(,@(source-module-closure '((guix docker)) + #:select? not-config?) + ((guix config) => ,config)) + #~(begin + ;; Guile-JSON is required by (guix docker). + (add-to-load-path + (string-append #$guile-json "/share/guile/site/" + (effective-version))) + + (use-modules (guix docker) (srfi srfi-19)) + + (setenv "PATH" (string-append #$tar "/bin")) + + (build-docker-image #$output #$profile + #:system (or #$target (utsname:machine (uname))) + #:closure "profile" + #:symlinks '#$symlinks + #:compressor '#$(compressor-command compressor) + #:creation-time (make-time time-utc 0 1))))) + + (gexp->derivation (string-append name ".tar." + (compressor-extension compressor)) + build + #:references-graphs `(("profile" ,profile)))) ;;; @@ -185,7 +249,8 @@ added to the pack." (define %default-options ;; Alist of default option values. - `((system . ,(%current-system)) + `((format . tarball) + (system . ,(%current-system)) (substitutes? . #t) (graft? . #t) (max-silent-time . 3600) @@ -193,6 +258,11 @@ added to the pack." (symlinks . ()) (compressor . ,(first %compressors)))) +(define %formats + ;; Supported pack formats. + `((tarball . ,self-contained-tarball) + (docker . ,docker-image))) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -206,19 +276,27 @@ added to the pack." (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (option '(#\f "format") #t #f + (lambda (opt name arg result) + (alist-cons 'format (string->symbol arg) result))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg (alist-delete 'system result eq?)))) + (option '("target") #t #f + (lambda (opt name arg result) + (alist-cons 'target arg + (alist-delete 'target result eq?)))) (option '(#\C "compression") #t #f (lambda (opt name arg result) (alist-cons 'compressor (lookup-compressor arg) result))) (option '(#\S "symlink") #t #f (lambda (opt name arg result) - (match (string-tokenize arg - (char-set-complement - (char-set #\=))) + ;; Note: Using 'string-split' allows us to handle empty + ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is + ;; a symlink to the profile) correctly. + (match (string-split arg (char-set #\=)) ((source target) (let ((symlinks (assoc-ref result 'symlinks))) (alist-cons 'symlinks @@ -242,8 +320,12 @@ Create a bundle of PACKAGE.\n")) (show-transformation-options-help) (newline) (display (_ " + -f, --format=FORMAT build a pack in the given FORMAT")) + (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\"")) + (display (_ " -C, --compression=TOOL compress using TOOL--e.g., \"lzip\"")) (display (_ " -S, --symlink=SPEC create symlinks to the profile according to SPEC")) @@ -280,20 +362,35 @@ Create a bundle of PACKAGE.\n")) (specification->package+output spec)) list)) specs)) - (compressor (assoc-ref opts 'compressor)) - (symlinks (assoc-ref opts 'symlinks)) + (pack-format (assoc-ref opts 'format)) + (name (string-append (symbol->string pack-format) + "-pack")) + (target (assoc-ref opts 'target)) + (compressor (assoc-ref opts 'compressor)) + (symlinks (assoc-ref opts 'symlinks)) + (build-image (match (assq-ref %formats pack-format) + ((? procedure? proc) proc) + (#f + (leave (_ "~a: unknown pack format") + format)))) (localstatedir? (assoc-ref opts 'localstatedir?))) (with-store store + ;; Set the build options before we do anything else. + (set-build-options-from-command-line store opts) + (run-with-store store (mlet* %store-monad ((profile (profile-derivation - (packages->manifest packages))) - (drv (self-contained-tarball "pack" profile - #:compressor - compressor - #:symlinks - symlinks - #:localstatedir? - localstatedir?))) + (packages->manifest packages) + #:target target)) + (drv (build-image name profile + #:target + target + #:compressor + compressor + #:symlinks + symlinks + #:localstatedir? + localstatedir?))) (mbegin %store-monad (show-what-to-build* (list drv) #:use-substitutes? diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 524b019a31..faeb019120 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. @@ -34,7 +34,8 @@ #:use-module ((guix build download) #:select (current-terminal-columns progress-proc uri-abbreviation nar-uri-abbreviation - open-connection-for-uri + (open-connection-for-uri + . guix:open-connection-for-uri) close-connection store-path-abbreviation byte-count->string)) #:use-module (ice-9 rdelim) @@ -210,8 +211,8 @@ provide." (close-connection port)))) (begin (when (or (not port) (port-closed? port)) - (set! port (open-connection-for-uri uri - #:verify-certificate? #f)) + (set! port (guix:open-connection-for-uri + uri #:verify-certificate? #f)) (unless (or buffered? (not (file-port? port))) (setvbuf port _IONBF))) (http-fetch uri #:text? #f #:port port @@ -247,9 +248,10 @@ failure, return #f and #f." read-cache-info) #f)) ((http https) - (let ((port (open-connection-for-uri uri - #:verify-certificate? #f - #:timeout %fetch-timeout))) + (let ((port (guix:open-connection-for-uri + uri + #:verify-certificate? #f + #:timeout %fetch-timeout))) (guard (c ((http-get-error? c) (warning (_ "while fetching '~a': ~a (~s)~%") (uri->string (http-get-error-uri c)) @@ -533,9 +535,10 @@ initial connection on which HTTP requests are sent." (result seed)) ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) - (let ((p (or port (open-connection-for-uri base-uri - #:verify-certificate? - verify-certificate?)))) + (let ((p (or port (guix:open-connection-for-uri + base-uri + #:verify-certificate? + verify-certificate?)))) ;; For HTTPS, P is not a file port and does not support 'setvbuf'. (when (file-port? p) (setvbuf p _IOFBF (expt 2 16))) diff --git a/guix/serialization.scm b/guix/serialization.scm index 4cab5910f7..4a8cd2086e 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -130,8 +130,7 @@ ;; <http://bugs.gnu.org/19621>. See <http://bugs.gnu.org/19610> for ;; a discussion. (let ((bv (read-byte-string p))) - ;; XXX: Rewrite using (ice-9 iconv) when the minimum requirement is - ;; upgraded to Guile >= 2.0.9. + ;; XXX: Rewrite using (ice-9 iconv). (list->string (map integer->char (bytevector->u8-list bv))))) (define (read-maybe-utf8-string p) diff --git a/guix/store.scm b/guix/store.scm index cce460f3ce..2f05351767 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -22,6 +22,7 @@ #:use-module (guix memoization) #:use-module (guix serialization) #:use-module (guix monads) + #:use-module (guix base16) #:autoload (guix base32) (bytevector->base32-string) #:autoload (guix build syscalls) (terminal-columns) #:use-module (rnrs bytevectors) diff --git a/guix/utils.scm b/guix/utils.scm index b72e3f233f..bc90686de0 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -28,15 +28,12 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-39) - #:use-module (srfi srfi-60) - #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:autoload (rnrs io ports) (make-custom-binary-input-port) #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) #:use-module (guix memoization) #:use-module ((guix build utils) #:select (dump-port)) #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) - #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:autoload (ice-9 popen) (open-pipe*) #:autoload (ice-9 rdelim) (read-line) @@ -46,10 +43,7 @@ #:use-module ((ice-9 iconv) #:prefix iconv:) #:use-module (system foreign) #:re-export (memoize) ; for backwards compatibility - #:export (bytevector->base16-string - base16-string->bytevector - - strip-keyword-arguments + #:export (strip-keyword-arguments default-keyword-arguments substitute-keyword-arguments ensure-keyword-arguments @@ -100,63 +94,6 @@ ;;; -;;; Base 16. -;;; - -(define (bytevector->base16-string bv) - "Return the hexadecimal representation of BV's contents." - (define len - (bytevector-length bv)) - - (let-syntax ((base16-chars (lambda (s) - (syntax-case s () - (_ - (let ((v (list->vector - (unfold (cut > <> 255) - (lambda (n) - (format #f "~2,'0x" n)) - 1+ - 0)))) - v)))))) - (define chars base16-chars) - (let loop ((i len) - (r '())) - (if (zero? i) - (string-concatenate r) - (let ((i (- i 1))) - (loop i - (cons (vector-ref chars (bytevector-u8-ref bv i)) r))))))) - -(define base16-string->bytevector - (let ((chars->value (fold (lambda (i r) - (vhash-consv (string-ref (number->string i 16) - 0) - i r)) - vlist-null - (iota 16)))) - (lambda (s) - "Return the bytevector whose hexadecimal representation is string S." - (define bv - (make-bytevector (quotient (string-length s) 2) 0)) - - (string-fold (lambda (chr i) - (let ((j (quotient i 2)) - (v (and=> (vhash-assv chr chars->value) cdr))) - (if v - (if (zero? (logand i 1)) - (bytevector-u8-set! bv j - (arithmetic-shift v 4)) - (let ((w (bytevector-u8-ref bv j))) - (bytevector-u8-set! bv j (logior v w)))) - (error "invalid hexadecimal character" chr))) - (+ i 1)) - 0 - s) - bv))) - - - -;;; ;;; Filtering & pipes. ;;; |