06/06: substitute: Improve functional decomposition.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit ef8f910fce7946e9b1452379f93ab50d93b21493
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jul 13 17:51:02 2015 +0200

    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.
---
 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 5cdda34..95aae2a 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: