From 526382ff92b20f6c651f03711c160c0c88264b88 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 20 Dec 2013 17:17:42 +0100
Subject: daemon: Implement signed archive import/export.

* guix/scripts/authenticate.scm, nix/scripts/guix-authenticate.in,
  tests/signing-key.pub, tests/signing-key.sec: New files.
* po/POTFILES.in: Add 'guix/scripts/authenticate.scm'.
* guix/store.scm (dump-port): New procedure.
  (process-stderr): Add 'user-port' optional parameter.  Handle
  the %STDERR-WRITE and %STDERR-READ cases as expected.
  (import-paths, export-path, export-paths): New procedures.
* tests/store.scm ("export/import several paths", "import corrupt
  path"): New tests.
* Makefile.am (MODULES): Add 'guix/scripts/authenticate.scm'.
  (EXTRA_DIST): Add 'tests/signing-key.{pub,sec}'.
* daemon.am (libstore_a_CPPFLAGS)[-DNIX_CONF_DIR]: Change 'NIX_CONF_DIR'
  to .../guix.  Change 'OPENSSL_PATH' to 'guix-authenticate'.
* config-daemon.ac: Instantiate 'nix/scripts/guix-authenticate'.
* nix/nix-daemon/guix-daemon.cc (main): Augment $PATH to include
  'settings.nixLibexecDir'.
* test-env.in: Export 'NIX_CONF_DIR' and 'NIX_LIBEXEC_DIR'.  Populate
  $NIX_CONF_DIR.
---
 guix/store.scm | 79 +++++++++++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 75 insertions(+), 4 deletions(-)

(limited to 'guix/store.scm')

diff --git a/guix/store.scm b/guix/store.scm
index 08b0671b29..4ceca0daa2 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -80,6 +80,8 @@ (define-module (guix store)
             dead-paths
             collect-garbage
             delete-paths
+            import-paths
+            export-paths
 
             current-build-output-port
 
@@ -323,7 +325,30 @@ (define current-build-output-port
   ;; The port where build output is sent.
   (make-parameter (current-error-port)))
 
-(define (process-stderr server)
+(define* (dump-port in out
+                    #:optional len
+                    #:key (buffer-size 16384))
+  "Read LEN bytes from IN (or as much as possible if LEN is #f) and write it
+to OUT, using chunks of BUFFER-SIZE bytes."
+  (define buffer
+    (make-bytevector buffer-size))
+
+  (let loop ((total 0)
+             (bytes (get-bytevector-n! in buffer 0
+                                       (if len
+                                           (min len buffer-size)
+                                           buffer-size))))
+    (or (eof-object? bytes)
+        (and len (= total len))
+        (let ((total (+ total bytes)))
+          (put-bytevector out buffer 0 bytes)
+          (loop total
+                (get-bytevector-n! in buffer 0
+                                   (if len
+                                       (min (- len total) buffer-size)
+                                       buffer-size)))))))
+
+(define* (process-stderr server #:optional user-port)
   "Read standard output and standard error from SERVER, writing it to
 CURRENT-BUILD-OUTPUT-PORT.  Return #t when SERVER is done sending data, and
 #f otherwise; in the latter case, the caller should call `process-stderr'
@@ -344,17 +369,30 @@ (define %stderr-error #x63787470)
 
   (let ((k (read-int p)))
     (cond ((= k %stderr-write)
-           (read-latin1-string p)
+           ;; Write a byte stream to USER-PORT.
+           (let* ((len (read-int p))
+                  (m   (modulo len 8)))
+             (dump-port p user-port len)
+             (unless (zero? m)
+               ;; Consume padding, as for strings.
+               (get-bytevector-n p (- 8 m))))
            #f)
           ((= k %stderr-read)
-           (let ((len (read-int p)))
-             (read-latin1-string p)               ; FIXME: what to do?
+           ;; Read a byte stream from USER-PORT.
+           (let* ((max-len (read-int p))
+                  (data    (get-bytevector-n user-port max-len))
+                  (len     (bytevector-length data)))
+             (write-int len p)
+             (put-bytevector p data)
+             (write-padding len p)
              #f))
           ((= k %stderr-next)
+           ;; Log a string.
            (let ((s (read-latin1-string p)))
              (display s (current-build-output-port))
              #f))
           ((= k %stderr-error)
+           ;; Report an error.
            (let ((error  (read-latin1-string p))
                  ;; Currently the daemon fails to send a status code for early
                  ;; errors like DB schema version mismatches, so check for EOF.
@@ -624,6 +662,39 @@ (define* (delete-paths server paths #:optional (min-freed (%long-long-max)))
 collected, and the number of bytes freed."
   (run-gc server (gc-action delete-specific) paths min-freed))
 
+(define (import-paths server port)
+  "Import the set of store paths read from PORT into SERVER's store.  An error
+is raised if the set of paths read from PORT is not signed (as per
+'export-path #:sign? #t'.)  Return the list of store paths imported."
+  (let ((s (nix-server-socket server)))
+    (write-int (operation-id import-paths) s)
+    (let loop ((done? (process-stderr server port)))
+      (or done? (loop (process-stderr server port))))
+    (read-store-path-list s)))
+
+(define* (export-path server path port #:key (sign? #t))
+  "Export PATH to PORT.  When SIGN? is true, sign it."
+  (let ((s (nix-server-socket server)))
+    (write-int (operation-id export-path) s)
+    (write-store-path path s)
+    (write-arg boolean sign? s)
+    (let loop ((done? (process-stderr server port)))
+      (or done? (loop (process-stderr server port))))
+    (= 1 (read-int s))))
+
+(define* (export-paths server paths port #:key (sign? #t))
+  "Export the store paths listed in PATHS to PORT, signing them if SIGN?
+is true."
+  (let ((s (nix-server-socket server)))
+    (let loop ((paths paths))
+      (match paths
+        (()
+         (write-int 0 port))
+        ((head tail ...)
+         (write-int 1 port)
+         (and (export-path server head port #:sign? sign?)
+              (loop tail)))))))
+
 
 ;;;
 ;;; Store paths.
-- 
cgit v1.2.3