diff options
| -rwxr-xr-x | guix/scripts/substitute.scm | 175 |
1 files changed, 96 insertions, 79 deletions
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 5cdda343d1..95aae2a372 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -699,6 +699,95 @@ Internal tool to substitute a pre-built binary to a local build.\n")) ;;; +;;; Daemon/substituter protocol. +;;; + +(define (display-narinfo-data narinfo) + "Write to the current output port the contents of NARINFO is the format +expected by the daemon." + (format #t "~a\n~a\n~a\n" + (narinfo-path narinfo) + (or (and=> (narinfo-deriver narinfo) + (cute string-append (%store-prefix) "/" <>)) + "") + (length (narinfo-references narinfo))) + (for-each (cute format #t "~a/~a~%" (%store-prefix) <>) + (narinfo-references narinfo)) + (format #t "~a\n~a\n" + (or (narinfo-file-size narinfo) 0) + (or (narinfo-size narinfo) 0))) + +(define* (process-query command + #:key cache-url acl) + "Reply to COMMAND, a query as written by the daemon to this process's +standard input. Use ACL as the access-control list against which to check +authorized substitutes." + (define (valid? obj) + (and (narinfo? obj) (valid-narinfo? obj acl))) + + (match (string-tokenize command) + (("have" paths ..1) + ;; Return the subset of PATHS available in CACHE-URL. + (let ((substitutable (lookup-narinfos cache-url paths))) + (for-each (lambda (narinfo) + (format #t "~a~%" (narinfo-path narinfo))) + (filter valid? substitutable)) + (newline))) + (("info" paths ..1) + ;; Reply info about PATHS if it's in CACHE-URL. + (let ((substitutable (lookup-narinfos cache-url paths))) + (for-each display-narinfo-data (filter valid? substitutable)) + (newline))) + (wtf + (error "unknown `--query' command" wtf)))) + +(define* (process-substitution store-item destination + #:key cache-url acl) + "Substitute STORE-ITEM (a store file name) from CACHE-URL, and write it to +DESTINATION as a nar file. Verify the substitute against ACL." + (let* ((narinfo (lookup-narinfo cache-url store-item)) + (uri (narinfo-uri narinfo))) + ;; Make sure it is signed and everything. + (assert-valid-narinfo narinfo acl) + + ;; Tell the daemon what the expected hash of the Nar itself is. + (format #t "~a~%" (narinfo-hash narinfo)) + + (format (current-error-port) "downloading `~a'~:[~*~; (~,1f MiB installed)~]...~%" + store-item + + ;; Use the Nar size as an estimate of the installed size. + (narinfo-size narinfo) + (and=> (narinfo-size narinfo) + (cute / <> (expt 2. 20)))) + (let*-values (((raw download-size) + ;; Note that Hydra currently generates Nars on the fly + ;; and doesn't specify a Content-Length, so + ;; DOWNLOAD-SIZE is #f in practice. + (fetch uri #:buffered? #f #:timeout? #f)) + ((progress) + (let* ((comp (narinfo-compression narinfo)) + (dl-size (or download-size + (and (equal? comp "none") + (narinfo-size narinfo)))) + (progress (progress-proc (uri-abbreviation uri) + dl-size + (current-error-port)))) + (progress-report-port progress raw))) + ((input pids) + (decompressed-port (and=> (narinfo-compression narinfo) + string->symbol) + progress))) + ;; Unpack the Nar at INPUT into DESTINATION. + (restore-file input destination) + + ;; Skip a line after what 'progress-proc' printed. + (newline (current-error-port)) + + (every (compose zero? cdr waitpid) pids)))) + + +;;; ;;; Entry point. ;;; @@ -800,90 +889,19 @@ substituter disabled~%") (with-error-handling ; for signature errors (match args (("--query") - (let ((cache %cache-url) - (acl (current-acl))) - (define (valid? obj) - (and (narinfo? obj) (valid-narinfo? obj acl))) - + (let ((acl (current-acl))) (let loop ((command (read-line))) (or (eof-object? command) (begin - (match (string-tokenize command) - (("have" paths ..1) - ;; Return the subset of PATHS available in CACHE. - (let ((substitutable - (lookup-narinfos cache paths))) - (for-each (lambda (narinfo) - (format #t "~a~%" (narinfo-path narinfo))) - (filter valid? substitutable)) - (newline))) - (("info" paths ..1) - ;; Reply info about PATHS if it's in CACHE. - (let ((substitutable - (lookup-narinfos cache paths))) - (for-each (lambda (narinfo) - (format #t "~a\n~a\n~a\n" - (narinfo-path narinfo) - (or (and=> (narinfo-deriver narinfo) - (cute string-append - (%store-prefix) "/" - <>)) - "") - (length (narinfo-references narinfo))) - (for-each (cute format #t "~a/~a~%" - (%store-prefix) <>) - (narinfo-references narinfo)) - (format #t "~a\n~a\n" - (or (narinfo-file-size narinfo) 0) - (or (narinfo-size narinfo) 0))) - (filter valid? substitutable)) - (newline))) - (wtf - (error "unknown `--query' command" wtf))) + (process-query command + #:cache-url %cache-url + #:acl acl) (loop (read-line))))))) (("--substitute" store-path destination) ;; Download STORE-PATH and add store it as a Nar in file DESTINATION. - (let* ((cache %cache-url) - (narinfo (lookup-narinfo cache store-path)) - (uri (narinfo-uri narinfo))) - ;; Make sure it is signed and everything. - (assert-valid-narinfo narinfo) - - ;; Tell the daemon what the expected hash of the Nar itself is. - (format #t "~a~%" (narinfo-hash narinfo)) - - (format (current-error-port) "downloading `~a'~:[~*~; (~,1f MiB installed)~]...~%" - store-path - - ;; Use the Nar size as an estimate of the installed size. - (narinfo-size narinfo) - (and=> (narinfo-size narinfo) - (cute / <> (expt 2. 20)))) - (let*-values (((raw download-size) - ;; Note that Hydra currently generates Nars on the fly - ;; and doesn't specify a Content-Length, so - ;; DOWNLOAD-SIZE is #f in practice. - (fetch uri #:buffered? #f #:timeout? #f)) - ((progress) - (let* ((comp (narinfo-compression narinfo)) - (dl-size (or download-size - (and (equal? comp "none") - (narinfo-size narinfo)))) - (progress (progress-proc (uri-abbreviation uri) - dl-size - (current-error-port)))) - (progress-report-port progress raw))) - ((input pids) - (decompressed-port (and=> (narinfo-compression narinfo) - string->symbol) - progress))) - ;; Unpack the Nar at INPUT into DESTINATION. - (restore-file input destination) - - ;; Skip a line after what 'progress-proc' printed. - (newline (current-error-port)) - - (every (compose zero? cdr waitpid) pids)))) + (process-substitution store-path destination + #:cache-url %cache-url + #:acl (current-acl))) (("--version") (show-version-and-exit "guix substitute")) (("--help") @@ -891,7 +909,6 @@ substituter disabled~%") (opts (leave (_ "~a: unrecognized options~%") opts)))))) - ;;; Local Variables: ;;; eval: (put 'with-timeout 'scheme-indent-function 1) ;;; End: |