diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/download.scm | 6 | ||||
| -rw-r--r-- | guix/licenses.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/authenticate.scm | 94 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 75 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 13 | ||||
| -rw-r--r-- | guix/utils.scm | 129 |
6 files changed, 224 insertions, 95 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index f9715e10f7..54115a9de2 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -196,9 +196,9 @@ which is not available during bootstrap." "Fetch data from URI and write it to FILE. Return FILE on success." (define post-2.0.7? - (or (string>? (major-version) "2") - (string>? (minor-version) "0") - (string>? (micro-version) "7") + (or (> (string->number (major-version)) 2) + (> (string->number (minor-version)) 0) + (> (string->number (micro-version)) 7) (string>? (version) "2.0.7"))) (define headers diff --git a/guix/licenses.scm b/guix/licenses.scm index 5f1b3c16cf..fce3d2b896 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -57,7 +57,7 @@ ;;; Available licenses. ;;; ;;; This list is based on these links: -;;; https://github.com/NixOS/nixpkgs/blob/master/pkgs/lib/licenses.nix +;;; https://github.com/NixOS/nixpkgs/blob/master/lib/licenses.nix ;;; https://www.gnu.org/licenses/license-list ;;; ;;; Code: diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 927dbe8afc..62717bb09c 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -34,18 +34,53 @@ ;;; ;;; Code: -(define (read-canonical-sexp file) - "Read a gcrypt sexp from FILE and return it." - (call-with-input-file file - (compose string->canonical-sexp get-string-all))) +(define read-canonical-sexp + ;; Read a gcrypt sexp from a port and return it. + (compose string->canonical-sexp get-string-all)) -(define (read-hash-data file key-type) - "Read sha256 hash data from FILE and return it as a gcrypt sexp. KEY-TYPE +(define (read-hash-data port key-type) + "Read sha256 hash data from PORT and return it as a gcrypt sexp. KEY-TYPE is a symbol representing the type of public key algo being used." - (let* ((hex (call-with-input-file file get-string-all)) + (let* ((hex (get-string-all port)) (bv (base16-string->bytevector (string-trim-both hex)))) (bytevector->hash-data bv #:key-type key-type))) +(define (sign-with-key key-file port) + "Sign the hash read from PORT with KEY-FILE, and write an sexp that includes +both the hash and the actual signature." + (let* ((secret-key (call-with-input-file key-file read-canonical-sexp)) + (public-key (if (string-suffix? ".sec" key-file) + (call-with-input-file + (string-append (string-drop-right key-file 4) + ".pub") + read-canonical-sexp) + (leave + (_ "cannot find public key for secret key '~a'~%") + key-file))) + (data (read-hash-data port (key-type public-key))) + (signature (signature-sexp data secret-key public-key))) + (display (canonical-sexp->string signature)) + #t)) + +(define (validate-signature port) + "Read the signature from PORT (which is as produced above), check whether +its public key is authorized, verify the signature, and print the signed data +to stdout upon success." + (let* ((signature (read-canonical-sexp port)) + (subject (signature-subject signature)) + (data (signature-signed-data signature))) + (if (and data subject) + (if (authorized-key? subject) + (if (valid-signature? signature) + (let ((hash (hash-data->bytevector data))) + (display (bytevector->base16-string hash)) + #t) ; success + (leave (_ "error: invalid signature: ~a~%") + (canonical-sexp->string signature))) + (leave (_ "error: unauthorized public key: ~a~%") + (canonical-sexp->string subject))) + (leave (_ "error: corrupt signature data: ~a~%") + (canonical-sexp->string signature))))) ;;; ;;; Entry point with 'openssl'-compatible interface. We support this @@ -55,39 +90,22 @@ is a symbol representing the type of public key algo being used." (define (guix-authenticate . args) (match args + ;; As invoked by guix-daemon. (("rsautl" "-sign" "-inkey" key "-in" hash-file) - ;; Sign the hash in HASH-FILE with KEY, and return an sexp that includes - ;; both the hash and the actual signature. - (let* ((secret-key (read-canonical-sexp key)) - (public-key (if (string-suffix? ".sec" key) - (read-canonical-sexp - (string-append (string-drop-right key 4) ".pub")) - (leave - (_ "cannot find public key for secret key '~a'~%") - key))) - (data (read-hash-data hash-file (key-type public-key))) - (signature (signature-sexp data secret-key public-key))) - (display (canonical-sexp->string signature)) - #t)) + (call-with-input-file hash-file + (lambda (port) + (sign-with-key key port)))) + ;; As invoked by Nix/Crypto.pm (used by Hydra.) + (("rsautl" "-sign" "-inkey" key) + (sign-with-key key (current-input-port))) + ;; As invoked by guix-daemon. (("rsautl" "-verify" "-inkey" _ "-pubin" "-in" signature-file) - ;; Read the signature as produced above, check whether its public key is - ;; authorized, and verify the signature, and print the signed data to - ;; stdout upon success. - (let* ((signature (read-canonical-sexp signature-file)) - (subject (signature-subject signature)) - (data (signature-signed-data signature))) - (if (and data subject) - (if (authorized-key? subject) - (if (valid-signature? signature) - (let ((hash (hash-data->bytevector data))) - (display (bytevector->base16-string hash)) - #t) ; success - (leave (_ "error: invalid signature: ~a~%") - (canonical-sexp->string signature))) - (leave (_ "error: unauthorized public key: ~a~%") - (canonical-sexp->string subject))) - (leave (_ "error: corrupt signature data: ~a~%") - (canonical-sexp->string signature))))) + (call-with-input-file signature-file + (lambda (port) + (validate-signature port)))) + ;; As invoked by Nix/Crypto.pm (used by Hydra.) + (("rsautl" "-verify" "-inkey" _ "-pubin") + (validate-signature (current-input-port))) (("--help") (display (_ "Usage: guix authenticate OPTION... Sign or verify the signature on the given file. This tool is meant to diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index e078012582..d06dd744a8 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -26,6 +26,7 @@ #:use-module ((guix build utils) #:select (which mkdir-p)) #:use-module (guix ui) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -136,7 +137,7 @@ determined." ;; "-i" (build-machine-private-key machine) ;; ;; XXX: With lsh 2.1, passing '--write-pid' ;; ;; last causes the PID not to be printed. -;; "--write-pid" "--gateway" "--background" "-z" +;; "--write-pid" "--gateway" "--background" ;; (build-machine-name machine))) ;; (line (read-line port)) ;; (status (close-pipe port))) @@ -179,7 +180,7 @@ determined." (lambda () ;; Let the child inherit ERROR-PORT. (with-error-to-port error-port - (apply open-pipe* mode %lshg-command "-z" + (apply open-pipe* mode %lshg-command "-l" (build-machine-user machine) "-p" (number->string (build-machine-port machine)) @@ -324,10 +325,10 @@ there, and write the build log to LOG-PORT. Return the exit status." "Offload DRV to MACHINE. Prior to the actual offloading, transfer all of INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from MACHINE." - ;; Acquire MACHINE's exclusive lock to serialize file transfers - ;; to/from MACHINE in the presence of several 'offload' hook - ;; instance. - (when (with-machine-lock machine 'bandwidth + ;; Acquire MACHINE's upload or download lock to serialize file transfers in + ;; a given direction to/from MACHINE in the presence of several 'offload' + ;; hook instance. + (when (with-machine-lock machine 'upload (send-files (cons (derivation-file-name drv) inputs) machine)) (let ((status (offload drv machine @@ -337,7 +338,7 @@ MACHINE." (if (zero? status) (begin ;; Likewise (see above.) - (with-machine-lock machine 'bandwidth + (with-machine-lock machine 'download (retrieve-files outputs machine)) (format (current-error-port) "done with offloaded '~a'~%" @@ -356,15 +357,18 @@ with exit code ~a~%" success, #f otherwise." (define (missing-files files) ;; Return the subset of FILES not already on MACHINE. - (let* ((files (format #f "~{~a~%~}" files)) - (missing (filtered-port - (list (which %lshg-command) - "-l" (build-machine-user machine) - "-p" (number->string (build-machine-port machine)) - "-i" (build-machine-private-key machine) - (build-machine-name machine) - "guix" "archive" "--missing") - (open-input-string files)))) + (let*-values (((files) + (format #f "~{~a~%~}" files)) + ((missing pids) + (filtered-port + (list (which %lshg-command) + "-l" (build-machine-user machine) + "-p" (number->string (build-machine-port machine)) + "-i" (build-machine-private-key machine) + (build-machine-name machine) + "guix" "archive" "--missing") + (open-input-string files)))) + (for-each waitpid pids) (string-tokenize (get-string-all missing)))) (with-store store @@ -372,24 +376,26 @@ success, #f otherwise." (warning (_ "failed to export files for '~a': ~s~%") (build-machine-name machine) c) - (false-if-exception (close-pipe pipe)) #f)) ;; Compute the subset of FILES missing on MACHINE, and send them in ;; topologically sorted order so that they can actually be imported. - (let ((files (missing-files (topologically-sorted store files))) - (pipe (remote-pipe machine OPEN_WRITE - '("guix" "archive" "--import")))) + (let* ((files (missing-files (topologically-sorted store files))) + (pipe (remote-pipe machine OPEN_WRITE + '("xz" "-dc" "|" + "guix" "archive" "--import")))) (format #t (_ "sending ~a store files to '~a'...~%") (length files) (build-machine-name machine)) - (catch 'system-error - (lambda () - (export-paths store files pipe)) - (lambda args - (warning (_ "failed while exporting files to '~a': ~a~%") - (build-machine-name machine) - (strerror (system-error-errno args))))) - (zero? (close-pipe pipe)))))) + (call-with-compressed-output-port 'xz pipe + (lambda (compressed) + (catch 'system-error + (lambda () + (export-paths store files compressed)) + (lambda args + (warning (_ "failed while exporting files to '~a': ~a~%") + (build-machine-name machine) + (strerror (system-error-errno args))))))) + #t)))) (define (retrieve-files files machine) "Retrieve FILES from MACHINE's store, and import them." @@ -397,7 +403,8 @@ success, #f otherwise." (build-machine-name machine)) (let ((pipe (remote-pipe machine OPEN_READ - `("guix" "archive" "--export" ,@files)))) + `("guix" "archive" "--export" ,@files + "|" "xz" "-c")))) (and pipe (with-store store (guard (c ((nix-protocol-error? c) @@ -409,11 +416,13 @@ success, #f otherwise." ;; We cannot use the 'import-paths' RPC here because we already ;; hold the locks for FILES. - (restore-file-set pipe - #:log-port (current-error-port) - #:lock? #f) + (call-with-decompressed-port 'xz pipe + (lambda (decompressed) + (restore-file-set decompressed + #:log-port (current-error-port) + #:lock? #f))) - (zero? (close-pipe pipe))))))) + #t))))) ;;; diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 7ac12ddef2..4e49b0c3ac 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -400,16 +400,6 @@ indefinitely." (call-with-output-file expiry-file (cute write (time-second now) <>)))) -(define (decompressed-port compression input) - "Return an input port where INPUT is decompressed according to COMPRESSION, -along with a list of PIDs to wait for." - (match compression - ("none" (values input '())) - ("bzip2" (filtered-port `(,%bzip2 "-dc") input)) - ("xz" (filtered-port `(,%xz "-dc") input)) - ("gzip" (filtered-port `(,%gzip "-dc") input)) - (else (error "unsupported compression scheme" compression)))) - (define (progress-report-port report-progress port) "Return a port that calls REPORT-PROGRESS every time something is read from PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by @@ -598,7 +588,8 @@ substituter disabled~%") (current-error-port)))) (progress-report-port progress raw))) ((input pids) - (decompressed-port (narinfo-compression narinfo) + (decompressed-port (and=> (narinfo-compression narinfo) + string->symbol) progress))) ;; Unpack the Nar at INPUT into DESTINATION. (restore-file input destination) diff --git a/guix/utils.scm b/guix/utils.scm index 68329ec915..7306c6011d 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -21,6 +21,7 @@ #:use-module (guix config) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-39) #:use-module (srfi srfi-60) @@ -70,7 +71,13 @@ call-with-temporary-output-file with-atomic-file-output fold2 - filtered-port)) + + filtered-port + compressed-port + decompressed-port + call-with-decompressed-port + compressed-output-port + call-with-compressed-output-port)) ;;; @@ -155,18 +162,29 @@ COMMAND (a list). In addition, return a list of PIDs that the caller must wait. When INPUT is a file port, it must be unbuffered; otherwise, any buffered data is lost." (let loop ((input input) - (pids '())) + (pids '())) (if (file-port? input) (match (pipe) ((in . out) (match (primitive-fork) (0 - (close-port in) - (close-port (current-input-port)) - (dup2 (fileno input) 0) - (close-port (current-output-port)) - (dup2 (fileno out) 1) - (apply execl (car command) command)) + (dynamic-wind + (const #f) + (lambda () + (close-port in) + (close-port (current-input-port)) + (dup2 (fileno input) 0) + (close-port (current-output-port)) + (dup2 (fileno out) 1) + (catch 'system-error + (lambda () + (apply execl (car command) command)) + (lambda args + (format (current-error-port) + "filtered-port: failed to execute '~{~a ~}': ~a~%" + command (strerror (system-error-errno args)))))) + (lambda () + (primitive-_exit 1)))) (child (close-port out) (values in (cons child pids)))))) @@ -184,11 +202,104 @@ buffered data is lost." (dump-port input out)) (lambda () (false-if-exception (close out)) - (primitive-exit 0)))) + (primitive-_exit 0)))) (child (close-port out) (loop in (cons child pids))))))))) +(define (decompressed-port compression input) + "Return an input port where INPUT is decompressed according to COMPRESSION, +a symbol such as 'xz." + (match compression + ((or #f 'none) (values input '())) + ('bzip2 (filtered-port `(,%bzip2 "-dc") input)) + ('xz (filtered-port `(,%xz "-dc") input)) + ('gzip (filtered-port `(,%gzip "-dc") input)) + (else (error "unsupported compression scheme" compression)))) + +(define (compressed-port compression input) + "Return an input port where INPUT is decompressed according to COMPRESSION, +a symbol such as 'xz." + (match compression + ((or #f 'none) (values input '())) + ('bzip2 (filtered-port `(,%bzip2 "-c") input)) + ('xz (filtered-port `(,%xz "-c") input)) + ('gzip (filtered-port `(,%gzip "-c") input)) + (else (error "unsupported compression scheme" compression)))) + +(define (call-with-decompressed-port compression port proc) + "Call PROC with a wrapper around PORT, a file port, that decompresses data +read from PORT according to COMPRESSION, a symbol such as 'xz. PORT is closed +as soon as PROC's dynamic extent is entered." + (let-values (((decompressed pids) + (decompressed-port compression port))) + (dynamic-wind + (const #f) + (lambda () + (close-port port) + (proc decompressed)) + (lambda () + (close-port decompressed) + (unless (every (compose zero? cdr waitpid) pids) + (error "decompressed-port failure" pids)))))) + +(define (filtered-output-port command output) + "Return an output port. Data written to that port is filtered through +COMMAND and written to OUTPUT, an output file port. In addition, return a +list of PIDs to wait for. OUTPUT must be unbuffered; otherwise, any buffered +data is lost." + (match (pipe) + ((in . out) + (match (primitive-fork) + (0 + (dynamic-wind + (const #f) + (lambda () + (close-port out) + (close-port (current-input-port)) + (dup2 (fileno in) 0) + (close-port (current-output-port)) + (dup2 (fileno output) 1) + (catch 'system-error + (lambda () + (apply execl (car command) command)) + (lambda args + (format (current-error-port) + "filtered-output-port: failed to execute '~{~a ~}': ~a~%" + command (strerror (system-error-errno args)))))) + (lambda () + (primitive-_exit 1)))) + (child + (close-port in) + (values out (list child))))))) + +(define (compressed-output-port compression output) + "Return an output port whose input is compressed according to COMPRESSION, +a symbol such as 'xz, and then written to OUTPUT. In addition return a list +of PIDs to wait for." + (match compression + ((or #f 'none) (values output '())) + ('bzip2 (filtered-output-port `(,%bzip2 "-c") output)) + ('xz (filtered-output-port `(,%xz "-c") output)) + ('gzip (filtered-output-port `(,%gzip "-c") output)) + (else (error "unsupported compression scheme" compression)))) + +(define (call-with-compressed-output-port compression port proc) + "Call PROC with a wrapper around PORT, a file port, that compresses data +that goes to PORT according to COMPRESSION, a symbol such as 'xz. PORT is +closed as soon as PROC's dynamic extent is entered." + (let-values (((compressed pids) + (compressed-output-port compression port))) + (dynamic-wind + (const #f) + (lambda () + (close-port port) + (proc compressed)) + (lambda () + (close-port compressed) + (unless (every (compose zero? cdr waitpid) pids) + (error "compressed-output-port failure" pids)))))) + ;;; ;;; Nixpkgs. |