nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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 2015-07-13 17:51:02 +02:00
parent f8a8e0fe16
commit ef8f910fce
1 changed files with 96 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

175
guix/scripts/substitute.scm
View File

@ -697,6 +697,95 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
(show-bug-report-information)) (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. ;;; Entry point.
@ -800,90 +889,19 @@ substituter disabled~%")
(with-error-handling ; for signature errors (with-error-handling ; for signature errors
(match args (match args
(("--query") (("--query")
(let ((cache %cache-url) (let ((acl (current-acl)))
(acl (current-acl)))
(define (valid? obj)
(and (narinfo? obj) (valid-narinfo? obj acl)))
(let loop ((command (read-line))) (let loop ((command (read-line)))
(or (eof-object? command) (or (eof-object? command)
(begin (begin
(match (string-tokenize command) (process-query command
(("have" paths ..1) #:cache-url %cache-url
;; Return the subset of PATHS available in CACHE. #:acl acl)
(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)))
(loop (read-line))))))) (loop (read-line)))))))
(("--substitute" store-path destination) (("--substitute" store-path destination)
;; Download STORE-PATH and add store it as a Nar in file DESTINATION. ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
(let* ((cache %cache-url) (process-substitution store-path destination
(narinfo (lookup-narinfo cache store-path)) #:cache-url %cache-url
(uri (narinfo-uri narinfo))) #:acl (current-acl)))
;; 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))))
(("--version") (("--version")
(show-version-and-exit "guix substitute")) (show-version-and-exit "guix substitute"))
(("--help") (("--help")
@ -891,7 +909,6 @@ substituter disabled~%")
(opts (opts
(leave (_ "~a: unrecognized options~%") opts)))))) (leave (_ "~a: unrecognized options~%") opts))))))
;;; Local Variables: ;;; Local Variables:
;;; eval: (put 'with-timeout 'scheme-indent-function 1) ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
;;; End: ;;; End: