From 260bc60f83b1955ac7f48b71872d3d2809132ee2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Jul 2016 16:39:19 +0200 Subject: derivations: Export 'fixed-output-path'. * guix/derivations.scm (fixed-output-path): Change 'output', 'hash-algo', and 'recursive?' to keyword parameters. Export. (derivation): Adjust accordingly. --- guix/derivations.scm | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 76593f373b..7f74ed6c77 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -73,6 +73,7 @@ (define-module (guix derivations) derivation-name derivation-output-names fixed-output-derivation? + fixed-output-path offloadable-derivation? substitutable-derivation? substitution-oracle @@ -676,7 +677,11 @@ (define (output-path output hash name) ; makeOutputPath name (string-append name "-" output)))) -(define (fixed-output-path output hash-algo hash recursive? name) +(define* (fixed-output-path name hash + #:key + (output "out") + (hash-algo 'sha256) + (recursive? #t)) "Return an output path for the fixed output OUTPUT defined by HASH of type HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for 'add-to-store'." @@ -736,12 +741,14 @@ (define (add-output-paths drv) (outputs (map (match-lambda ((output-name . ($ _ algo hash rec?)) - (let ((path (if hash - (fixed-output-path output-name - algo hash - rec? name) - (output-path output-name - drv-hash name)))) + (let ((path + (if hash + (fixed-output-path name hash + #:hash-algo algo + #:output output-name + #:recursive? rec?) + (output-path output-name + drv-hash name)))) (cons output-name (make-derivation-output path algo hash rec?))))) -- cgit v1.2.3 From ff6638d112d794c9c433731643711932452fd2ff Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Jul 2016 16:54:31 +0200 Subject: publish: Handle '/file' URLs, for content-addressed files. * guix/scripts/publish.scm (render-content-addressed-file): New procedure. (http-write): Add 'application/octet-stream' case. (make-request-handler): Add /file/NAME/sha256/HASH URLs. * tests/publish.scm ("/file/NAME/sha256/HASH") ("/file/NAME/sha256/INVALID-NIX-BASE32-STRING") ("/file/NAME/sha256/INVALID-HASH"): New tests. * doc/guix.texi (Invoking guix publish): Mention the /file URLs. --- doc/guix.texi | 14 ++++++++++++ guix/scripts/publish.scm | 59 +++++++++++++++++++++++++++++++++++++++++++++++- tests/publish.scm | 34 ++++++++++++++++++++++++++++ 3 files changed, 106 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 7ea9ddfe35..e7b233d828 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5633,6 +5633,20 @@ archive}), the daemon may download substitutes from it: guix-daemon --substitute-urls=http://example.org:8080 @end example +As a bonus, @command{guix publish} also serves as a content-addressed +mirror for source files referenced in @code{origin} records +(@pxref{origin Reference}). For instance, assuming @command{guix +publish} is running on @code{example.org}, the following URL returns the +raw @file{hello-2.10.tar.gz} file with the given SHA256 hash +(represented in @code{nix-base32} format, @pxref{Invoking guix hash}): + +@example +http://example.org/file/hello-2.10.tar.gz/sha256/0ssi1@dots{}ndq1i +@end example + +Obviously, these URLs only work for files that are in the store; in +other cases, they return 404 (``Not Found''). + The following options are available: @table @code diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 3baceaf645..2ca2aeebe3 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -31,6 +31,7 @@ (define-module (guix scripts publish) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:use-module (web http) #:use-module (web request) @@ -49,6 +50,7 @@ (define-module (guix scripts publish) #:use-module (guix zlib) #:use-module (guix ui) #:use-module (guix scripts) + #:use-module ((guix build utils) #:select (dump-port)) #:export (guix-publish)) (define (show-help) @@ -308,6 +310,25 @@ (define* (render-nar store request store-item store-path) (not-found request)))) +(define (render-content-addressed-file store request + name algo hash) + "Return the content of the result of the fixed-output derivation NAME that +has the given HASH of type ALGO." + ;; TODO: Support other hash algorithms. + (if (and (eq? algo 'sha256) (= 32 (bytevector-length hash))) + (let ((item (fixed-output-path name hash + #:hash-algo algo + #:recursive? #f))) + (if (valid-path? store item) + (values `((content-type . (application/octet-stream + (charset . "ISO-8859-1")))) + ;; XXX: We're not returning the actual contents, deferring + ;; instead to 'http-write'. This is a hack to work around + ;; . + item) + (not-found request))) + (not-found request))) + (define extract-narinfo-hash (let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$"))) (lambda (str) @@ -398,6 +419,34 @@ (define (http-write server client response body) (swallow-zlib-error (close-port port)) (values))))) + (('application/octet-stream . _) + ;; Send a raw file in a separate thread. + (call-with-new-thread + (lambda () + (catch 'system-error + (lambda () + (call-with-input-file (utf8->string body) + (lambda (input) + (let* ((size (stat:size (stat input))) + (headers (alist-cons 'content-length size + (alist-delete 'content-length + (response-headers response) + eq?))) + (response (write-response (set-field response + (response-headers) + headers) + client)) + (output (response-port response))) + (dump-port input output) + (close-port output) + (values))))) + (lambda args + ;; If the file was GC'd behind our back, that's fine. Likewise if + ;; the client closes the connection. + (unless (memv (system-error-errno args) + (list ENOENT EPIPE ECONNRESET)) + (apply throw args)) + (values)))))) (_ ;; Handle other responses sequentially. (%http-write server client response body)))) @@ -418,7 +467,7 @@ (define* (make-request-handler store (format #t "~a ~a~%" (request-method request) (uri-path (request-uri request))) - (if (get-request? request) ; reject POST, PUT, etc. + (if (get-request? request) ;reject POST, PUT, etc. (match (request-path-components request) ;; /nix-cache-info (("nix-cache-info") @@ -450,6 +499,14 @@ (define* (make-request-handler store (_ %default-gzip-compression))) (not-found request))) + + ;; /nar/file/NAME/sha256/HASH + (("file" name "sha256" hash) + (guard (c ((invalid-base32-character? c) + (not-found request))) + (let ((hash (nix-base32-string->bytevector hash))) + (render-content-addressed-file store request + name 'sha256 hash)))) (_ (not-found request))) (not-found request)))) diff --git a/tests/publish.scm b/tests/publish.scm index 9bf181f1fc..0ba33487bd 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -26,6 +26,8 @@ (define-module (test-publish) #:use-module (guix utils) #:use-module (guix hash) #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix gexp) #:use-module (guix base32) #:use-module (guix base64) #:use-module ((guix records) #:select (recutils->alist)) @@ -210,4 +212,36 @@ (define (wait-until-ready port) (display "This file is not a valid store item." port))) (response-code (http-get (publish-uri (string-append "/nar/invalid")))))) +(test-equal "/file/NAME/sha256/HASH" + "Hello, Guix world!" + (let* ((data "Hello, Guix world!") + (hash (call-with-input-string data port-sha256)) + (drv (run-with-store %store + (gexp->derivation "the-file.txt" + #~(call-with-output-file #$output + (lambda (port) + (display #$data port))) + #:hash-algo 'sha256 + #:hash hash))) + (out (build-derivations %store (list drv)))) + (utf8->string + (http-get-body + (publish-uri + (string-append "/file/the-file.txt/sha256/" + (bytevector->nix-base32-string hash))))))) + +(test-equal "/file/NAME/sha256/INVALID-NIX-BASE32-STRING" + 404 + (let ((uri (publish-uri + "/file/the-file.txt/sha256/not-a-nix-base32-string"))) + (response-code (http-get uri)))) + +(test-equal "/file/NAME/sha256/INVALID-HASH" + 404 + (let ((uri (publish-uri + (string-append "/file/the-file.txt/sha256/" + (bytevector->nix-base32-string + (call-with-input-string "" port-sha256)))))) + (response-code (http-get uri)))) + (test-end "publish") -- cgit v1.2.3 From ab84b927efa44cd3e81568db4c775f6ab7e3c344 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Jul 2016 17:00:50 +0200 Subject: download: Prepare to support the 'guix publish' /file URLs. * guix/download.scm (%content-addressed-mirrors): Add 'file' parameter to the lambda. * guix/build/download.scm (url-fetch)[content-addressed-uris]: Adjust accordingly. --- guix/build/download.scm | 2 +- guix/download.scm | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 103e784bb1..307258be92 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -737,7 +737,7 @@ (define content-addressed-uris (append-map (lambda (make-url) (filter-map (match-lambda ((hash-algo . hash) - (string->uri (make-url hash-algo hash)))) + (string->uri (make-url file hash-algo hash)))) hashes)) content-addressed-mirrors)) diff --git a/guix/download.scm b/guix/download.scm index bcb043ba80..8f38a4f552 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -232,10 +232,10 @@ (define %mirror-file (define %content-addressed-mirrors ;; List of content-addressed mirrors. Each mirror is represented as a - ;; procedure that takes an algorithm (symbol) and a hash (bytevector), and - ;; returns a URL or #f. + ;; procedure that takes a file name, an algorithm (symbol) and a hash + ;; (bytevector), and returns a URL or #f. ;; TODO: Add more. - '(list (lambda (algo hash) + '(list (lambda (file algo hash) ;; 'tarballs.nixos.org' supports several algorithms. (string-append "http://tarballs.nixos.org/" (symbol->string algo) "/" -- cgit v1.2.3 From 0b0086e94c68769bfcada7c2b3b426873aac8efc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Jul 2016 19:27:32 +0200 Subject: config: Export the raw installation directories. * guix/config.scm.in (%storedir, %localstatedir) (%sysconfdir, %sbindir): New variables. (%store-directory): Use %STOREDIR. (%state-directory): Use %LOCALSTATEDIR. (%config-directory): Use %SYSCONFDIR. (%guix-register-program): Use %SBINDIR. --- guix/config.scm.in | 30 ++++++++++++++++++++++++++---- 1 file changed, 26 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/config.scm.in b/guix/config.scm.in index 6d42cf233c..7a420401ce 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -21,10 +21,17 @@ (define-module (guix config) %guix-version %guix-bug-report-address %guix-home-page-url + + %storedir + %localstatedir + %sysconfdir + %sbindir + %store-directory %state-directory %config-directory %guix-register-program + %system %libgcrypt %libz @@ -51,21 +58,36 @@ (define %guix-bug-report-address (define %guix-home-page-url "@PACKAGE_URL@") +(define %storedir + "@storedir@") + +(define %localstatedir + "@guix_localstatedir@") + +(define %sysconfdir + "@guix_sysconfdir@") + +(define %sbindir + "@guix_sbindir@") + (define %store-directory (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path) - "@storedir@")) + %storedir)) (define %state-directory ;; This must match `NIX_STATE_DIR' as defined in `nix/local.mk'. - (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/guix")) + (or (getenv "NIX_STATE_DIR") + (string-append %localstatedir "/guix"))) (define %config-directory ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'. - (or (getenv "GUIX_CONFIGURATION_DIRECTORY") "@guix_sysconfdir@/guix")) + (or (getenv "GUIX_CONFIGURATION_DIRECTORY") + (string-append %sysconfdir "/guix"))) (define %guix-register-program ;; The 'guix-register' program. - (or (getenv "GUIX_REGISTER") "@guix_sbindir@/guix-register")) + (or (getenv "GUIX_REGISTER") + (string-append %sbindir "/guix-register"))) (define %system "@guix_system@") -- cgit v1.2.3 From 13cee334f1a31e7d8f7124d045b136106fe8d356 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Jul 2016 22:23:15 +0200 Subject: pull: Install (guix config) module to override the user's one. * build-aux/build-self.scm (zlib, gzip, bzip2, xz): New variables. (build)[storedir, localstatedir, sysconfdir, sbindir]: New variables. [builder]: Pass them to 'build-guix'. * guix/build/pull.scm (build-guix): Add #:system, #:storedir, #:localstatedir, #:sysconfdir, #:sbindir, #:package-name, #:package-version, #:bug-report-address, #:home-page-url, #:libgcrypt, #:zlib, #:gzip, #:bzip2, and #:xz. Remove #:gcrypt. Instantiate all the substitution variables in (guix config). Remove code to delete OUT/guix/config.{scm,go}. * guix/config.scm.in: Add note about (guix script pull). --- build-aux/build-self.scm | 48 +++++++++++++++++++++++++++++++++++++++++++++--- guix/build/pull.scm | 39 +++++++++++++++++++++++++++++---------- guix/config.scm.in | 3 ++- 3 files changed, 76 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index b78f3cb437..c673912af5 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès +;;; Copyright © 2014, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +19,7 @@ (define-module (build-self) #:use-module (gnu) #:use-module (guix) + #:use-module (guix config) #:use-module (srfi srfi-1) #:export (build)) @@ -44,6 +45,18 @@ (define-module (build-self) (define libgcrypt (first (find-best-packages-by-name "libgcrypt" #f))) +(define zlib + (first (find-best-packages-by-name "zlib" #f))) + +(define gzip + (first (find-best-packages-by-name "gzip" #f))) + +(define bzip2 + (first (find-best-packages-by-name "bzip2" #f))) + +(define xz + (first (find-best-packages-by-name "xz" #f))) + (define guile-json (first (find-best-packages-by-name "guile-json" #f))) @@ -63,6 +76,19 @@ (define* (build source #:key verbose? #:rest rest) "Return a derivation that unpacks SOURCE into STORE and compiles Scheme files." + ;; The '%xxxdir' variables were added to (guix config) in July 2016 so we + ;; cannot assume that they are defined. Try to guess their value when + ;; they're undefined (XXX: we get an incorrect guess when environment + ;; variables such as 'NIX_STATE_DIR' are defined!). + (define storedir + (if (defined? '%storedir) %storedir %store-directory)) + (define localstatedir + (if (defined? '%localstatedir) %localstatedir (dirname %state-directory))) + (define sysconfdir + (if (defined? '%sysconfdir) %sysconfdir (dirname %config-directory))) + (define sbindir + (if (defined? '%sbindir) %sbindir (dirname %guix-register-program))) + (define builder #~(begin (use-modules (guix build pull)) @@ -73,12 +99,28 @@ (define builder (build-guix #$output #$source + #:system #$%system + #:storedir #$storedir + #:localstatedir #$localstatedir + #:sysconfdir #$sysconfdir + #:sbindir #$sbindir + + #:package-name #$%guix-package-name + #:package-version #$%guix-version + #:bug-report-address #$%guix-bug-report-address + #:home-page-url #$%guix-home-page-url + + #:libgcrypt #$libgcrypt + #:zlib #$zlib + #:gzip #$gzip + #:bzip2 #$bzip2 + #:xz #$xz + ;; XXX: This is not perfect, enabling VERBOSE? means ;; building a different derivation. #:debug-port (if #$verbose? (current-error-port) - (%make-void-port "w")) - #:gcrypt #$libgcrypt))) + (%make-void-port "w"))))) (gexp->derivation "guix-latest" builder #:modules '((guix build pull) diff --git a/guix/build/pull.scm b/guix/build/pull.scm index 4ddb12ac04..ccf1868516 100644 --- a/guix/build/pull.scm +++ b/guix/build/pull.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès +;;; Copyright © 2013, 2014, 2016 Ludovic Courtès ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer ;;; ;;; This file is part of GNU Guix. @@ -36,7 +36,17 @@ (define-module (guix build pull) ;;; Code: (define* (build-guix out source - #:key gcrypt + #:key + system + storedir localstatedir sysconfdir sbindir + + (package-name "GNU Guix") + (package-version "0") + (bug-report-address "bug-guix@gnu.org") + (home-page-url "https://gnu.org/s/guix") + + libgcrypt zlib gzip bzip2 xz + (debug-port (%make-void-port "w")) (log-port (current-error-port))) "Build and install Guix in directory OUT using SOURCE, a directory @@ -55,13 +65,26 @@ (define* (build-guix out source (copy-file "guix.scm" (string-append out "/guix.scm")) (copy-file "gnu.scm" (string-append out "/gnu.scm")) - ;; Add a fake (guix config) module to allow the other modules to be - ;; compiled. The user's (guix config) is the one that will be used. + ;; Instantiate a (guix config) module that preserves the original + ;; settings. (copy-file "guix/config.scm.in" (string-append out "/guix/config.scm")) (substitute* (string-append out "/guix/config.scm") - (("@LIBGCRYPT@") - (string-append gcrypt "/lib/libgcrypt"))) + (("@PACKAGE_NAME@") package-name) + (("@PACKAGE_VERSION@") package-version) + (("@PACKAGE_BUGREPORT@") bug-report-address) + (("@PACKAGE_URL@") home-page-url) + (("@storedir@") storedir) + (("@guix_localstatedir@") localstatedir) + (("@guix_sysconfdir@") sysconfdir) + (("@guix_sbindir@") sbindir) + (("@guix_system@") system) + (("@LIBGCRYPT@") (string-append libgcrypt "/lib/libgcrypt")) + (("@LIBZ@") (string-append zlib "/lib/libz")) + (("@GZIP@") (string-append gzip "/bin/gzip")) + (("@BZIP2@") (string-append bzip2 "/bin/bzip2")) + (("@XZ@") (string-append xz "/bin/xz")) + (("@NIX_INSTANTIATE@") "")) ;remnants from the past ;; Augment the search path so Scheme code can be compiled. (set! %load-path (cons out %load-path)) @@ -119,10 +142,6 @@ (define* (build-guix out source (set! completed (+ 1 completed)))) files)))) - ;; Remove the "fake" (guix config). - (delete-file (string-append out "/guix/config.scm")) - (delete-file (string-append out "/guix/config.go")) - (newline) #t) diff --git a/guix/config.scm.in b/guix/config.scm.in index 7a420401ce..8f2c4abd8e 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -42,7 +42,8 @@ (define-module (guix config) ;;; Commentary: ;;; -;;; Compile-time configuration of Guix. +;;; Compile-time configuration of Guix. When adding a substitution variable +;;; here, make sure to equip (guix scripts pull) to substitute it. ;;; ;;; Code: -- cgit v1.2.3