mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
substitute: Improve functional decomposition.
* guix/scripts/substitute.scm (display-narinfo-data, process-query, process-substitution): New procedures. Code moved from... (guix-substitute): ... here. Use them.
This commit is contained in:
Ludovic Courtès
parent
f8a8e0fe16
commit
ef8f910fce
1 changed files with 96 additions and 79 deletions
|
|
@ -697,6 +697,95 @@ (define (show-help)
|
|||
(show-bug-report-information))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; 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 @@ (define (guix-substitute . args)
|
|||
(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 @@ (define (valid? obj)
|
|||
(opts
|
||||
(leave (_ "~a: unrecognized options~%") opts))))))
|
||||
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'with-timeout 'scheme-indent-function 1)
|
||||
;;; End:
|
||||
|
|
|
|||
Loading…
Reference in a new issue