summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLeo Famulari <leo@famulari.name>2016-07-22 18:57:40 -0400
committerLeo Famulari <leo@famulari.name>2016-07-22 18:58:31 -0400
commitd227260d2f7833b6bdc55b8e3792378626ef3b69 (patch)
tree26d47d5d8ee8efb102323bca215429a8f8fe1095 /guix
parentd778fa5ff6f4a860919eaf13db3f84cfc68cbee8 (diff)
parent26ad4adb5568c6ff370f446431b079520fb09615 (diff)
Merge branch 'master' into core-updates
Resolved conflicts: * gnu/packages/scheme.scm: Conflict in import of (guix licenses). On master, "#:hide (openssl)" was used. On core-updates, "#:select (some licenses)" was used. The latter won the conflict. * gnu/packages/version-control.scm (git)[arguments]: Whitespace conflict in 'install-shell-completion.
Diffstat (limited to 'guix')
-rw-r--r--guix/build/download.scm2
-rw-r--r--guix/build/pull.scm39
-rw-r--r--guix/config.scm.in33
-rw-r--r--guix/derivations.scm21
-rw-r--r--guix/download.scm6
-rw-r--r--guix/scripts/publish.scm59
6 files changed, 133 insertions, 27 deletions
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 @@ or #f."
(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/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 <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -36,7 +36,17 @@
;;; 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 @@ containing the source code. Write any debugging output to DEBUG-PORT."
(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 @@ containing the source code. Write any debugging output to DEBUG-PORT."
(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 6d42cf233c..8f2c4abd8e 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -21,10 +21,17 @@
%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
@@ -35,7 +42,8 @@
;;; 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:
@@ -51,21 +59,36 @@
(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@")
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 @@
derivation-name
derivation-output-names
fixed-output-derivation?
+ fixed-output-path
offloadable-derivation?
substitutable-derivation?
substitution-oracle
@@ -676,7 +677,11 @@ the derivation called NAME with hash HASH."
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 @@ output should not be used."
(outputs (map (match-lambda
((output-name . ($ <derivation-output>
_ 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?)))))
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 %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) "/"
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 @@
#: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 @@
#: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 @@ appropriate duration."
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
+ ;; <http://bugs.gnu.org/21093>.
+ 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 @@ blocking."
(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 @@ blocking."
(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 @@ blocking."
(_
%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))))