diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 18 | ||||
| -rw-r--r-- | guix/scripts/authenticate.scm | 9 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 50 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 20 |
4 files changed, 71 insertions, 26 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 0ab7686585..c900fcecb9 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -87,6 +87,13 @@ Export/import one or more packages from/to the store.\n")) (newline) (show-bug-report-information)) +(define %key-generation-parameters + ;; Default key generation parameters. We prefer Ed25519, but it was + ;; introduced in libgcrypt 1.6.0. + (if (version>? (gcrypt-version) "1.6.0") + "(genkey (ecdsa (curve Ed25519) (flags rfc6979)))" + "(genkey (rsa (nbits 4:4096)))")) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -110,13 +117,16 @@ Export/import one or more packages from/to the store.\n")) (lambda (opt name arg result) (catch 'gcry-error (lambda () + ;; XXX: Curve25519 was actually introduced in + ;; libgcrypt 1.6.0. (let ((params (string->canonical-sexp - (or arg "(genkey (rsa (nbits 4:4096)))")))) + (or arg %key-generation-parameters)))) (alist-cons 'generate-key params result))) - (lambda args - (leave (_ "invalid key generation parameters: ~s~%") - arg))))) + (lambda (key err) + (leave (_ "invalid key generation parameters: ~a: ~a~%") + (error-source err) + (error-string err)))))) (option '("authorize") #f #f (lambda (opt name arg result) (alist-cons 'authorize #t result))) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 27580dedff..927dbe8afc 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -39,11 +39,12 @@ (call-with-input-file file (compose string->canonical-sexp get-string-all))) -(define (read-hash-data file) - "Read sha256 hash data from FILE and return it as a gcrypt sexp." +(define (read-hash-data file key-type) + "Read sha256 hash data from FILE 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)) (bv (base16-string->bytevector (string-trim-both hex)))) - (bytevector->hash-data bv))) + (bytevector->hash-data bv #:key-type key-type))) ;;; @@ -64,7 +65,7 @@ (leave (_ "cannot find public key for secret key '~a'~%") key))) - (data (read-hash-data hash-file)) + (data (read-hash-data hash-file (key-type public-key))) (signature (signature-sexp data secret-key public-key))) (display (canonical-sexp->string signature)) #t)) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 95e35088a1..e078012582 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -159,19 +159,35 @@ determined." ;; (leave (_ "failed to execute '~a': ~a~%") ;; %lsh-command (strerror (system-error-errno args)))))) -(define (remote-pipe machine mode command) +(define-syntax with-error-to-port + (syntax-rules () + ((_ port exp0 exp ...) + (let ((new port) + (old (current-error-port))) + (dynamic-wind + (lambda () + (set-current-error-port new)) + (lambda () + exp0 exp ...) + (lambda () + (set-current-error-port old))))))) + +(define* (remote-pipe machine mode command + #:key (error-port (current-error-port))) "Run COMMAND on MACHINE, assuming an lsh gateway has been set up." (catch 'system-error (lambda () - (apply open-pipe* mode %lshg-command "-z" - "-l" (build-machine-user machine) - "-p" (number->string (build-machine-port machine)) + ;; Let the child inherit ERROR-PORT. + (with-error-to-port error-port + (apply open-pipe* mode %lshg-command "-z" + "-l" (build-machine-user machine) + "-p" (number->string (build-machine-port machine)) - ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg. - "-i" (build-machine-private-key machine) + ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg. + "-i" (build-machine-private-key machine) - (build-machine-name machine) - command)) + (build-machine-name machine) + command))) (lambda args (warning (_ "failed to execute '~a': ~a~%") %lshg-command (strerror (system-error-errno args))) @@ -257,9 +273,18 @@ connections allowed to MACHINE." ;;; Offloading. ;;; +(define (build-log-port) + "Return the default port where build logs should be sent. The default is +file descriptor 4, which is open by the daemon before running the offload +hook." + (let ((port (fdopen 4 "w0"))) + ;; Make sure file descriptor 4 isn't closed when PORT is GC'd. + (set-port-revealed! port 1) + port)) + (define* (offload drv machine #:key print-build-trace? (max-silent-time 3600) - build-timeout (log-port (current-output-port))) + build-timeout (log-port (build-log-port))) "Perform DRV on MACHINE, assuming DRV and its prerequisites are available there, and write the build log to LOG-PORT. Return the exit status." (format (current-error-port) "offloading '~a' to '~a'...~%" @@ -276,7 +301,11 @@ there, and write the build log to LOG-PORT. Return the exit status." (list (format #f "--timeout=~a" build-timeout)) '()) - ,(derivation-file-name drv))))) + ,(derivation-file-name drv)) + + ;; Since 'guix build' writes the build log to its + ;; stderr, everything will go directly to LOG-PORT. + #:error-port log-port))) (let loop ((line (read-line pipe))) (unless (eof-object? line) (display line log-port) @@ -597,6 +626,7 @@ This tool is meant to be used internally by 'guix-daemon'.\n")) ;;; Local Variables: ;;; eval: (put 'with-machine-lock 'scheme-indent-function 2) ;;; eval: (put 'with-file-lock 'scheme-indent-function 1) +;;; eval: (put 'with-error-to-port 'scheme-indent-function 1) ;;; End: ;;; offload.scm ends here diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 54f4aaa6c0..7ac12ddef2 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -125,9 +125,10 @@ again." (sigaction SIGALRM SIG_DFL) (apply values result))))) -(define* (fetch uri #:key (buffered? #t) (timeout? #t)) +(define* (fetch uri #:key (buffered? #t) (timeout? #t) (quiet-404? #f)) "Return a binary input port to URI and the number of bytes it's expected to -provide." +provide. If QUIET-404? is true, HTTP 404 error conditions are passed through +to the caller without emitting an error message." (case (uri-scheme uri) ((file) (let ((port (open-file (uri-path uri) @@ -135,10 +136,12 @@ provide." (values port (stat:size (stat port))))) ((http) (guard (c ((http-get-error? c) - (leave (_ "download from '~a' failed: ~a, ~s~%") - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)))) + (let ((code (http-get-error-code c))) + (if (and (= code 404) quiet-404?) + (raise c) + (leave (_ "download from '~a' failed: ~a, ~s~%") + (uri->string (http-get-error-uri c)) + code (http-get-error-reason c)))))) ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So ;; honor TIMEOUT? to disable the timeout when fetching a nar. ;; @@ -275,8 +278,9 @@ reading PORT." "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH." (define (download url) ;; Download the .narinfo from URL, and return its contents as a list of - ;; key/value pairs. - (false-if-exception (fetch (string->uri url)))) + ;; key/value pairs. Don't emit an error message upon 404. + (false-if-exception (fetch (string->uri url) + #:quiet-404? #t))) (and (string=? (cache-store-directory cache) (%store-prefix)) (and=> (download (string-append (cache-url cache) "/" |