[PATCH 0/2] Add 'guix publish' command

[PATCH 0/2] Add 'guix publish' command

[David Thompson]

This patch set has been a long time coming.  Thanks to Ludo for helping
me solve the last blocking issue this morning.

This new utility allows anyone to publish their /gnu/store directory
over HTTP, exposing a Hydra-compatible API.

To use it, simply run `guix publish` on one of your machines, then tell
your other machines to use that one to fetch substitutes:

    guix archive --authorize < your-server-key.pub
    guix-daemon --substitute-urls=your-server:8080

Someday, Guix will support multiple substitution servers, which will
make this feature a lot more useful.  Being able to fetch substitutes
from hydra.gnu.org *and* from other Guix users that you trust will be
awesome. :)

TIA for the code review.

-- 
David Thompson
Web Developer - Free Software Foundation - http://fsf.org
GPG Key: 0FF1D807
Support the FSF: https://fsf.org/donate

[PATCH 1/2] store: Add query-path-info operation.

[David Thompson]

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: 0001-store-Add-query-path-info-operation.patch --]
[-- Type: text/x-diff, Size: 2997 bytes --]

From e72bd43190bd561f7d96810a93f3b30f5f741343 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Tue, 17 Mar 2015 10:19:36 -0400
Subject: [PATCH 1/2] store: Add query-path-info operation.

* guix/store.scm (<path-info>): New record type.
  (read-path-info): New procedure.
  (read-arg): Add 'path-info' syntax.
  (query-path-info): New variable.
---
 guix/store.scm | 34 +++++++++++++++++++++++++++++++++-
 1 file changed, 33 insertions(+), 1 deletion(-)

diff --git a/guix/store.scm b/guix/store.scm
index a3f3cbf..8e1a180 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -60,6 +60,7 @@
             valid-path?
             query-path-hash
             hash-part->path
+            query-path-info
             add-text-to-store
             add-to-store
             build-things
@@ -79,6 +80,13 @@
             substitutable-paths
             substitutable-path-info
 
+            path-info?
+            path-info-deriver
+            path-info-hash
+            path-info-refs
+            path-info-reg-time
+            path-info-nar-size
+
             references
             requisites
             referrers
@@ -212,6 +220,24 @@
                 (cons (substitutable path deriver refs dl-size nar-size)
                       result))))))
 
+;; Information about a store path.
+(define-record-type <path-info>
+  (path-info deriver hash refs reg-time nar-size)
+  path-info?
+  (deriver path-info-deriver)
+  (hash path-info-hash)
+  (refs path-info-refs)
+  (reg-time path-info-reg-time)
+  (nar-size path-info-nar-size))
+
+(define (read-path-info p)
+  (let ((deriver  (read-store-path p))
+        (hash     (base16-string->bytevector (read-string p)))
+        (refs     (read-store-path-list p))
+        (reg-time (read-int p))
+        (nar-size (read-long-long p)))
+    (path-info deriver hash refs reg-time nar-size)))
+
 (define-syntax write-arg
   (syntax-rules (integer boolean file string string-list string-pairs
                  store-path store-path-list base16)
@@ -236,7 +262,7 @@
 
 (define-syntax read-arg
   (syntax-rules (integer boolean string store-path store-path-list
-                 substitutable-path-list base16)
+                 substitutable-path-list path-info base16)
     ((_ integer p)
      (read-int p))
     ((_ boolean p)
@@ -249,6 +275,8 @@
      (read-store-path-list p))
     ((_ substitutable-path-list p)
      (read-substitutable-path-list p))
+    ((_ path-info p)
+     (read-path-info p))
     ((_ base16 p)
      (base16-string->bytevector (read-string p)))))
 
@@ -532,6 +560,10 @@ string).  Raise an error if no such path exists."
      ;; /HASH.narinfo.
      (query-path-from-hash-part server hash-part))))
 
+(define-operation (query-path-info (store-path path))
+  "Return the derivation store path for PATH."
+  path-info)
+
 (define add-text-to-store
   ;; A memoizing version of `add-to-store', to avoid repeated RPCs with
   ;; the very same arguments during a given session.
-- 
2.1.4


[-- Attachment #2: Type: text/plain, Size: 136 bytes --]


-- 
David Thompson
Web Developer - Free Software Foundation - http://fsf.org
GPG Key: 0FF1D807
Support the FSF: https://fsf.org/donate

[PATCH 2/2] scripts: Add 'publish' command.

[David Thompson]

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: 0002-scripts-Add-publish-command.patch --]
[-- Type: text/x-diff, Size: 11032 bytes --]

From 7200a8ca892308a03a92e737b493244154bab358 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Tue, 17 Mar 2015 10:21:31 -0400
Subject: [PATCH 2/2] scripts: Add 'publish' command.

* guix/scripts/publish.scm: New file.
* Makefile.am (MODULES): Add it.
* doc/guix.texi ("Invoking guix publish"): New node.
---
 Makefile.am              |   1 +
 doc/guix.texi            |  41 +++++++++
 guix/scripts/publish.scm | 210 +++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 252 insertions(+)
 create mode 100644 guix/scripts/publish.scm

diff --git a/Makefile.am b/Makefile.am
index 882ab8e..703cbc1 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -104,6 +104,7 @@ MODULES =					\
   guix/scripts/import/gnu.scm			\
   guix/scripts/import/nix.scm			\
   guix/scripts/environment.scm			\
+  guix/scripts/publish.scm			\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
 
diff --git a/doc/guix.texi b/doc/guix.texi
index b605c5b..71d70ed 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -120,6 +120,7 @@ Utilities
 * Invoking guix refresh::       Updating package definitions.
 * Invoking guix lint::          Finding errors in package definitions.
 * Invoking guix environment::   Setting up development environments.
+* Invoking guix publish::       Sharing substitutes.
 
 GNU Distribution
 
@@ -2712,6 +2713,7 @@ programming interface of Guix in a convenient way.
 * Invoking guix refresh::       Updating package definitions.
 * Invoking guix lint::          Finding errors in package definitions.
 * Invoking guix environment::   Setting up development environments.
+* Invoking guix publish::       Sharing substitutes.
 @end menu
 
 @node Invoking guix build
@@ -3374,6 +3376,45 @@ environment.
 It also supports all of the common build options that @command{guix
 build} supports (@pxref{Invoking guix build, common build options}).
 
+@node Invoking guix publish
+@section Invoking @command{guix publish}
+
+The purpose of @command{guix publish} is to expose a Hydra-compatible
+HTTP API for sharing substitutes from the local store.
+
+The general syntax is:
+
+@example
+guix publish @var{options}@dots{}
+@end example
+
+Running @command{guix publish} without any additional arguments will
+spawn an HTTP server on port 8080:
+
+@example
+guix publish
+@end example
+
+Once a publishing server has been authorized (@pxref{Invoking guix archive}),
+the Guix daemon may use it to download substitutes:
+
+@example
+guix-daemon --substitute-urls=example.org:8080
+@end example
+
+The following options are available:
+
+@table @code
+@item --port=@var{port}
+@itemx -p @var{port}
+Listen for HTTP requests on @var{port}.
+
+@item --repl[=@var{port}]
+@itemx -r [@var{port}]
+Spawn a Guile REPL server (@pxref{REPL Servers,,, guile, GNU Guile
+Reference Manual}) on @var{port} (37146 by default).  Useful for developers.
+@end table
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
new file mode 100644
index 0000000..6be5ca6
--- /dev/null
+++ b/guix/scripts/publish.scm
@@ -0,0 +1,210 @@
+(define-module (guix scripts publish)
+  #:use-module ((system repl server) #:prefix repl:)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-37)
+  #:use-module (web http)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web server)
+  #:use-module (web uri)
+  #:use-module (guix base32)
+  #:use-module (guix base64)
+  #:use-module (guix config)
+  #:use-module (guix derivations)
+  #:use-module (guix hash)
+  #:use-module (guix pki)
+  #:use-module (guix pk-crypto)
+  #:use-module (guix store)
+  #:use-module (guix serialization)
+  #:use-module (guix ui)
+  #:export (guix-publish))
+
+(define (show-help)
+  (display (_ "Usage: guix publish [OPTION]...
+Publish the store directory over HTTP.\n"))
+  (display (_ "
+  -p, --port=PORT        listen on PORT"))
+  (display (_ "
+  -r, --repl[=PORT]      spawn REPL server on PORT"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  (list (option '(#\h "help") #f #f
+                (lambda _
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda _
+                  (show-version-and-exit "guix publish")))
+        (option '(#\p "port") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'port (string->number* arg) result)))
+        (option '(#\r "repl") #f #t
+                (lambda (opt name arg result)
+                  ;; If port unspecified, use default Guile REPL port.
+                  (let ((port (and arg (string->number* arg))))
+                    (alist-cons 'repl (or port 37146) result))))))
+
+(define %default-options
+  '((port . 8080)
+    (repl . #f)))
+
+(define %store (open-connection))
+
+(define %private-key
+  (call-with-input-file %private-key-file
+    (compose string->canonical-sexp
+             get-string-all)))
+
+(define %public-key
+  (call-with-input-file %public-key-file
+    (compose string->canonical-sexp
+             get-string-all)))
+
+(define %nix-cache-info
+  `(("StoreDir" . ,%store-directory)
+    ("WantMassQuery" . 0)
+    ("Priority" . 100)))
+
+(define (load-derivation file-name)
+  "Read the derivation located at FILE-NAME."
+  (with-input-from-file file-name
+    (lambda ()
+      (read-derivation (current-input-port)))))
+
+(define (false-if-empty-string str)
+  (and (not (string-null? str)) str))
+
+(define (sign-string s)
+  "Sign the hash of the string S with the daemon's key."
+  (let ((hash (bytevector->hash-data (sha256 (string->utf8 s)))))
+    (signature-sexp hash %private-key %public-key)))
+
+(define base64-encode-string
+  (compose base64-encode string->utf8))
+
+(define (narinfo-string store-path path-info derivation deriver key)
+  (let* ((url (string-append "nar/" (basename store-path)))
+         (nar-hash (bytevector->base32-string
+                    (path-info-hash path-info)))
+         (nar-size (path-info-nar-size path-info))
+         (references (string-join (map basename (path-info-refs path-info))
+                                  " "))
+         (system (derivation-system derivation))
+         (deriver (basename deriver))
+         (info (format #f
+                       "StorePath: ~a
+URL: ~a
+Compression: none
+NarHash: sha256:~a
+NarSize: ~d
+References: ~a
+System: ~a
+Deriver: ~a~%"
+                       store-path url nar-hash nar-size references
+                       system deriver))
+         (signature (base64-encode-string
+                     (canonical-sexp->string (sign-string info)))))
+    (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature)))
+
+(define (not-found request)
+  "Render 404 response for REQUEST."
+  (values (build-response #:code 404)
+          (string-append "Resource not found: "
+                         (uri-path (request-uri request)))))
+
+(define (render-nix-cache-info)
+  "Render server information."
+  (values '((content-type . (text/plain)))
+          (lambda (port)
+            (for-each (match-lambda
+                       ((key . value)
+                        (format port "~a: ~a~%" key value)))
+                      %nix-cache-info))))
+
+(define (render-narinfo request hash)
+  "Render metadata for the store path corresponding to HASH."
+  (apply values
+         (or (and-let* ((store-path (false-if-empty-string
+                                     (hash-part->path %store hash)))
+                        (path-info (query-path-info %store store-path))
+                        (deriver (let ((d (path-info-deriver path-info)))
+                                   (if (string-null? d) store-path d)))
+                        (drv (and (file-exists? deriver)
+                                  (load-derivation deriver)))
+                        (info (narinfo-string store-path path-info drv
+                                              deriver %private-key)))
+               (list '((content-type . (application/x-nix-narinfo)))
+                     (lambda (port)
+                       (display info port))))
+             (call-with-values (lambda () (not-found request)) list))))
+
+(define (render-nar request store-item)
+  "Render archive of the store path corresponding to STORE-ITEM."
+  (let ((store-path (string-append %store-directory "/" store-item)))
+    (values '((content-type . (application/x-nix-archive
+                               (charset . "ISO-8859-1"))))
+            (lambda (port)
+              (write-file store-path port)))))
+
+(define extract-narinfo-hash
+  (let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$")))
+    (lambda (str)
+      "Return the hash within the narinfo resource string STR, or false if STR
+is invalid."
+      (and=> (regexp-exec regexp str)
+             (cut match:substring <> 1)))))
+
+(define (get-request? request)
+  "Return #t if REQUEST uses the GET method."
+  (eq? (request-method request) 'GET))
+
+(define (request-path-components request)
+  "Split the URI path of REQUEST into a list of component strings.  For
+example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
+  (split-and-decode-uri-path (uri-path (request-uri request))))
+
+(define (request-handler request body)
+  (format #t "~a ~a~%"
+          (request-method request)
+          (uri-path (request-uri request)))
+  (if (get-request? request) ; reject POST, PUT, etc.
+      (match (request-path-components request)
+        (("nix-cache-info")                          ; /nix-cache-info
+         (render-nix-cache-info))
+        (((= extract-narinfo-hash (? string? hash))) ; /<hash>.narinfo
+         (render-narinfo request hash))
+        (("nar" store-path)                          ; /nar/<hash-part>
+         (render-nar request store-path))
+        (_ (not-found request)))
+      (not-found request)))
+
+(define (run-publish-server port)
+  (run-server (lambda args (apply request-handler args))
+              'http
+              `(#:addr ,INADDR_ANY
+                #:port ,port)))
+
+(define (guix-publish . args)
+  (with-error-handling
+    (let* ((opts (parse-command-line args %options (list %default-options)))
+           (port (assoc-ref opts 'port))
+           (repl-port (assoc-ref opts 'repl)))
+      (format #t "Publishing store on port ~d~%" port)
+      (when repl-port
+        (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
+      (run-publish-server (assoc-ref opts 'port)))))
-- 
2.1.4


[-- Attachment #2: Type: text/plain, Size: 136 bytes --]


-- 
David Thompson
Web Developer - Free Software Foundation - http://fsf.org
GPG Key: 0FF1D807
Support the FSF: https://fsf.org/donate

Re: [PATCH 0/2] Add 'guix publish' command

[David Thompson]

David Thompson <dthompson2@worcester.edu> writes:

> This patch set has been a long time coming.  Thanks to Ludo for helping
> me solve the last blocking issue this morning.
>
> This new utility allows anyone to publish their /gnu/store directory
> over HTTP, exposing a Hydra-compatible API.
>
> To use it, simply run `guix publish` on one of your machines, then tell
> your other machines to use that one to fetch substitutes:
>
>     guix archive --authorize < your-server-key.pub
>     guix-daemon --substitute-urls=your-server:8080

Oh, I forgot to mention a limitation: 'guix publish' currently does not
use compress archives, so it uses a lot more bandwidth than Hydra does
currently.  In the future, it will be changed to use bz2 compression
like Hydra.

-- 
David Thompson
Web Developer - Free Software Foundation - http://fsf.org
GPG Key: 0FF1D807
Support the FSF: https://fsf.org/donate

Re: [PATCH 1/2] store: Add query-path-info operation.

[Ludovic Courtès]

David Thompson <dthompson2@worcester.edu> skribis:

> From e72bd43190bd561f7d96810a93f3b30f5f741343 Mon Sep 17 00:00:00 2001
> From: David Thompson <dthompson2@worcester.edu>
> Date: Tue, 17 Mar 2015 10:19:36 -0400
> Subject: [PATCH 1/2] store: Add query-path-info operation.
>
> * guix/store.scm (<path-info>): New record type.
>   (read-path-info): New procedure.
>   (read-arg): Add 'path-info' syntax.
>   (query-path-info): New variable.

[...]

> +  (reg-time path-info-reg-time)

Please change the procedure name to ‘path-info-registration-time’.

> +(define-operation (query-path-info (store-path path))
> +  "Return the derivation store path for PATH."
> +  path-info)

Invalid docstring.

Could you add a test in tests/store.scm?  It could add a file with
‘add-text-to-store’, with a non-empty reference list, and check its
references and hash, for instance.

Thanks!

Ludo’.

Re: [PATCH 2/2] scripts: Add 'publish' command.

[Ludovic Courtès]

[-- Attachment #1: Type: text/plain, Size: 1370 bytes --]

David Thompson <dthompson2@worcester.edu> skribis:

> From 7200a8ca892308a03a92e737b493244154bab358 Mon Sep 17 00:00:00 2001
> From: David Thompson <dthompson2@worcester.edu>
> Date: Tue, 17 Mar 2015 10:21:31 -0400
> Subject: [PATCH 2/2] scripts: Add 'publish' command.
>
> * guix/scripts/publish.scm: New file.
> * Makefile.am (MODULES): Add it.
> * doc/guix.texi ("Invoking guix publish"): New node.

Yaaay!

> +@node Invoking guix publish
> +@section Invoking @command{guix publish}
> +
> +The purpose of @command{guix publish} is to expose a Hydra-compatible
> +HTTP API for sharing substitutes from the local store.

s/API/interface/ maybe

I think we should first describe the functionality (what it means to
share the store over HTTP), and only then mention Hydra-compatibility
(which is not something users really care about.)

There should be a word about signing, with an xref to ‘guix archive’ I
think.  Perhaps later we could add an option to choose the signing key.

> +@example
> +guix-daemon --substitute-urls=example.org:8080

It should have “http://”.

Eventually™ it will be possible to specify substitute URLs from the
client; whether to actually use them with still be decided based on the
keys the sysadmin authorized.  Preliminary patch that adds
‘--substitute-urls’ to ‘guix build’ et al.:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 3429 bytes --]

--- a/guix/store.scm
+++ b/guix/store.scm
@@ -484,11 +512,11 @@ encoding conversion errors."
     (when (>= (nix-server-minor-version server) 10)
       (send (boolean use-substitutes?)))
     (when (>= (nix-server-minor-version server) 12)
-      (let ((pairs (if timeout
-                       `(("build-timeout" . ,(number->string timeout))
-                         ,@binary-caches)
-                       binary-caches)))
-        (send (string-pairs pairs))))
+      (let ((pairs `(,@(if timeout
+                           `(("build-timeout" . ,(number->string timeout)))
+                           '())
+                     ("substitute-urls" . ,(string-join substitute-urls)))))
+        (send (string-pairs (pk 'pairs pairs)))))
     (let loop ((done? (process-stderr server)))
       (or done? (process-stderr server)))))
 
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 370c2a3..df38b5e 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -110,6 +110,9 @@ options handled by 'set-build-options-from-command-line', and listed in
   (display (_ "
       --no-substitutes   build instead of resorting to pre-built substitutes"))
   (display (_ "
+      --substitute-urls=URLS
+                         fetch substitute from URLS if they are authorized"))
+  (display (_ "
       --no-build-hook    do not attempt to offload builds via the build hook"))
   (display (_ "
       --max-silent-time=SECONDS
@@ -133,6 +136,8 @@ options handled by 'set-build-options-from-command-line', and listed in
                      #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1)
                      #:fallback? (assoc-ref opts 'fallback?)
                      #:use-substitutes? (assoc-ref opts 'substitutes?)
+                     #:substitute-urls (or (assoc-ref opts 'substitute-urls)
+                                           '())
                      #:use-build-hook? (assoc-ref opts 'build-hook?)
                      #:max-silent-time (assoc-ref opts 'max-silent-time)
                      #:timeout (assoc-ref opts 'timeout)
@@ -166,6 +171,13 @@ options handled by 'set-build-options-from-command-line', and listed in
                          (alist-cons 'substitutes? #f
                                      (alist-delete 'substitutes? result))
                          rest)))
+        (option '("substitute-urls") #t #f
+                (lambda (opt name arg result . rest)
+                  (apply values
+                         (alist-cons 'substitute-urls
+                                     (string-tokenize arg)
+                                     (alist-delete 'substitute-urls result))
+                         rest)))
         (option '("no-build-hook") #f #f
                 (lambda (opt name arg result . rest)
                   (apply values

diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 903564c..1d45753 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -631,7 +631,10 @@ found."
   (assoc-ref (daemon-options) option))
 
 (define %cache-url
-  (match (and=> (find-daemon-option "substitute-urls")
+  (match (and=> (string-append
+                 (find-daemon-option "untrusted-substitute-urls") ;client
+                 " "
+                 (find-daemon-option "substitute-urls"))          ;admin
                 string-tokenize)
     ((url)
      url)

[-- Attachment #3: Type: text/plain, Size: 3438 bytes --]


I won’t commit it yet because at this point the substituter caches only
from one server, so users could populate
/var/guix/substitute-binary/cache and lead other users to use the
substituter that they chose (or to use nothing if the substituter server
in question returned 404 for all the narinfos.)

That should be easily fixed though (for the interested reader? ;-)).

> --- /dev/null
> +++ b/guix/scripts/publish.scm

Make sure to add the license header.

> +  (display (_ "Usage: guix publish [OPTION]...
> +Publish the store directory over HTTP.\n"))

Maybe “Publish ~a over HTTP” with (%store-directory) would be more
immediately obvious (and translations would be accurate ;-)).

> +(define (load-derivation file-name)
> +  "Read the derivation located at FILE-NAME."
> +  (with-input-from-file file-name
> +    (lambda ()
> +      (read-derivation (current-input-port)))))

(call-with-input-file file read-derivation)

> +(define (sign-string s)
> +  "Sign the hash of the string S with the daemon's key."
> +  (let ((hash (bytevector->hash-data (sha256 (string->utf8 s)))))
> +    (signature-sexp hash %private-key %public-key)))

I had to change it to:

  (define (sign-string s)
    "Sign the hash of the string S with the daemon's key."
    (let ((hash (bytevector->hash-data (sha256 (string->utf8 s))
                                       #:key-type (key-type %public-key))))
      (signature-sexp hash %private-key %public-key)))

Otherwise, ‘bytevector->hash-data’ will assume you have an ECC key and
‘sign’ will raise an exception if you happen to have an RSA key, for
instance.

Maybe ‘signed-string’ would be a more appropriate name since it’s a pure
function.

> +(define (narinfo-string store-path path-info derivation deriver key)

Docstring please.  I would suggest using keyword arguments for arguments
above position 2.

Aren’t ‘derivation’ and ‘deriver’ redundant with ‘path-info’?

> +  (let* ((url (string-append "nar/" (basename store-path)))
> +         (nar-hash (bytevector->base32-string
> +                    (path-info-hash path-info)))
> +         (nar-size (path-info-nar-size path-info))
> +         (references (string-join (map basename (path-info-refs path-info))
> +                                  " "))
> +         (system (derivation-system derivation))
> +         (deriver (basename deriver))
> +         (info (format #f

Please align the RHS and maybe use single-word identifiers.  (I hate it
when I look this fussy.)

> +    (values '((content-type . (application/x-nix-archive
> +                               (charset . "ISO-8859-1"))))

Please add a comment saying that choosing ISO-8859-1 is crucial since
otherwise HTTP clients will interpret the byte stream as UTF-8 and
arbitrarily change invalid byte sequences.  We don’t want anyone to feel
that pain again.  ;-)

> +      (format #t "Publishing store on port ~d~%" port)

Lowercase and use (_ "publishing ..."), and add the file to
po/guix/POTFILES.in.

Now, it would be good to add a bunch of tests.  :-)

Perhaps one way to do it would be to write them in Scheme, and invoke
‘guix-publish’ in a thread, similar to the HTTP tests in
tests/lint.scm.  From there we could check .narinfo and .nar URLs.
WDYT?

Thanks for working on it in spite of the numerous issues you
encountered!

Ludo’.

Re: [PATCH 1/2] store: Add query-path-info operation.

[David Thompson]

[-- Attachment #1: Type: text/plain, Size: 1012 bytes --]

Ludovic Courtès <ludo@gnu.org> writes:

> David Thompson <dthompson2@worcester.edu> skribis:
>
>> From e72bd43190bd561f7d96810a93f3b30f5f741343 Mon Sep 17 00:00:00 2001
>> From: David Thompson <dthompson2@worcester.edu>
>> Date: Tue, 17 Mar 2015 10:19:36 -0400
>> Subject: [PATCH 1/2] store: Add query-path-info operation.
>>
>> * guix/store.scm (<path-info>): New record type.
>>   (read-path-info): New procedure.
>>   (read-arg): Add 'path-info' syntax.
>>   (query-path-info): New variable.
>
> [...]
>
>> +  (reg-time path-info-reg-time)
>
> Please change the procedure name to ‘path-info-registration-time’.
>
>> +(define-operation (query-path-info (store-path path))
>> +  "Return the derivation store path for PATH."
>> +  path-info)
>
> Invalid docstring.
>
> Could you add a test in tests/store.scm?  It could add a file with
> ‘add-text-to-store’, with a non-empty reference list, and check its
> references and hash, for instance.

Done.

New patch below.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-store-Add-query-path-info-operation.patch --]
[-- Type: text/x-diff, Size: 3873 bytes --]

From d86678e29c951ae4983cea92074e8f04c3e49f50 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Tue, 17 Mar 2015 10:19:36 -0400
Subject: [PATCH 1/2] store: Add query-path-info operation.

* guix/store.scm (<path-info>): New record type.
  (read-path-info): New procedure.
  (read-arg): Add 'path-info' syntax.
  (query-path-info): New variable.
* tests/store.scm ("query-path-info"): New test.
---
 guix/store.scm  | 34 +++++++++++++++++++++++++++++++++-
 tests/store.scm | 10 ++++++++++
 2 files changed, 43 insertions(+), 1 deletion(-)

diff --git a/guix/store.scm b/guix/store.scm
index 3d6b069..10b9062 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -60,6 +60,7 @@
             valid-path?
             query-path-hash
             hash-part->path
+            query-path-info
             add-text-to-store
             add-to-store
             build-things
@@ -79,6 +80,13 @@
             substitutable-paths
             substitutable-path-info
 
+            path-info?
+            path-info-deriver
+            path-info-hash
+            path-info-references
+            path-info-registration-time
+            path-info-nar-size
+
             references
             requisites
             referrers
@@ -212,6 +220,24 @@
                 (cons (substitutable path deriver refs dl-size nar-size)
                       result))))))
 
+;; Information about a store path.
+(define-record-type <path-info>
+  (path-info deriver hash references registration-time nar-size)
+  path-info?
+  (deriver path-info-deriver)
+  (hash path-info-hash)
+  (references path-info-references)
+  (registration-time path-info-registration-time)
+  (nar-size path-info-nar-size))
+
+(define (read-path-info p)
+  (let ((deriver  (read-store-path p))
+        (hash     (base16-string->bytevector (read-string p)))
+        (refs     (read-store-path-list p))
+        (registration-time (read-int p))
+        (nar-size (read-long-long p)))
+    (path-info deriver hash refs registration-time nar-size)))
+
 (define-syntax write-arg
   (syntax-rules (integer boolean file string string-list string-pairs
                  store-path store-path-list base16)
@@ -236,7 +262,7 @@
 
 (define-syntax read-arg
   (syntax-rules (integer boolean string store-path store-path-list
-                 substitutable-path-list base16)
+                 substitutable-path-list path-info base16)
     ((_ integer p)
      (read-int p))
     ((_ boolean p)
@@ -249,6 +275,8 @@
      (read-store-path-list p))
     ((_ substitutable-path-list p)
      (read-substitutable-path-list p))
+    ((_ path-info p)
+     (read-path-info p))
     ((_ base16 p)
      (base16-string->bytevector (read-string p)))))
 
@@ -541,6 +569,10 @@ string).  Raise an error if no such path exists."
      ;; /HASH.narinfo.
      (query-path-from-hash-part server hash-part))))
 
+(define-operation (query-path-info (store-path path))
+  "Return the info (hash, references, etc.) for PATH."
+  path-info)
+
 (define add-text-to-store
   ;; A memoizing version of `add-to-store', to avoid repeated RPCs with
   ;; the very same arguments during a given session.
diff --git a/tests/store.scm b/tests/store.scm
index f778c20..eeceed4 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -606,6 +606,16 @@
          (file (add %store "foo" "Lowered.")))
     (call-with-input-file file get-string-all)))
 
+(test-assert "query-path-info"
+  (let* ((ref (add-text-to-store %store "ref" "foo"))
+         (item (add-text-to-store %store "item" "bar" (list ref)))
+         (info (query-path-info %store item)))
+    (and (equal? (path-info-references info) (list ref))
+         (equal? (path-info-hash info)
+                 (sha256
+                  (string->utf8
+                   (call-with-output-string (cut write-file item <>))))))))
+
 (test-end "store")
 
 \f
-- 
2.1.4


[-- Attachment #3: Type: text/plain, Size: 136 bytes --]


-- 
David Thompson
Web Developer - Free Software Foundation - http://fsf.org
GPG Key: 0FF1D807
Support the FSF: https://fsf.org/donate

Re: [PATCH 2/2] scripts: Add 'publish' command.

[David Thompson]

[-- Attachment #1: Type: text/plain, Size: 549 bytes --]

Ludovic Courtès <ludo@gnu.org> writes:

> [...]

Fixed everything you mentioned.

> Now, it would be good to add a bunch of tests.  :-)
>
> Perhaps one way to do it would be to write them in Scheme, and invoke
> ‘guix-publish’ in a thread, similar to the HTTP tests in
> tests/lint.scm.  From there we could check .narinfo and .nar URLs.
> WDYT?

Good idea.  That's what I ended up doing.

> Thanks for working on it in spite of the numerous issues you
> encountered!

And thanks for the thorough review!  New patch below:


[-- Attachment #2: 0002-scripts-Add-publish-command.patch --]
[-- Type: text/x-diff, Size: 18012 bytes --]

From a40d47dc64571aade0c92b4bdf3c56f6870842cc Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Tue, 17 Mar 2015 10:21:31 -0400
Subject: [PATCH 2/2] scripts: Add 'publish' command.

* guix/scripts/publish.scm: New file.
* po/guix/POTFILES.in: Add it.
* tests/publish.scm: New file.
* Makefile.am (MODULES): Add script module.
  (SCM_TESTS): Add test module.
* doc/guix.texi ("Invoking guix publish"): New node.
---
 Makefile.am              |   4 +-
 doc/guix.texi            |  51 ++++++++++-
 guix/scripts/publish.scm | 233 +++++++++++++++++++++++++++++++++++++++++++++++
 po/guix/POTFILES.in      |   1 +
 tests/publish.scm        | 114 +++++++++++++++++++++++
 5 files changed, 401 insertions(+), 2 deletions(-)
 create mode 100644 guix/scripts/publish.scm
 create mode 100644 tests/publish.scm

diff --git a/Makefile.am b/Makefile.am
index 4a1f8d0..4ff7e65 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -104,6 +104,7 @@ MODULES =					\
   guix/scripts/import/gnu.scm			\
   guix/scripts/import/nix.scm			\
   guix/scripts/environment.scm			\
+  guix/scripts/publish.scm			\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
 
@@ -178,7 +179,8 @@ SCM_TESTS =					\
   tests/union.scm				\
   tests/profiles.scm				\
   tests/syscalls.scm				\
-  tests/lint.scm
+  tests/lint.scm				\
+  tests/publish.scm
 
 if HAVE_GUILE_JSON
 
diff --git a/doc/guix.texi b/doc/guix.texi
index 3c72e65..1b81217 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -121,6 +121,7 @@ Utilities
 * Invoking guix refresh::       Updating package definitions.
 * Invoking guix lint::          Finding errors in package definitions.
 * Invoking guix environment::   Setting up development environments.
+* Invoking guix publish::       Sharing substitutes.
 
 GNU Distribution
 
@@ -2511,7 +2512,7 @@ To illustrate the idea, here is an example of a gexp:
   #~(begin
       (mkdir #$output)
       (chdir #$output)
-      (symlink (string-append #$coreutils "/bin/ls") 
+      (symlink (string-append #$coreutils "/bin/ls")
                "list-files")))
 @end example
 
@@ -2746,6 +2747,7 @@ programming interface of Guix in a convenient way.
 * Invoking guix refresh::       Updating package definitions.
 * Invoking guix lint::          Finding errors in package definitions.
 * Invoking guix environment::   Setting up development environments.
+* Invoking guix publish::       Sharing substitutes.
 @end menu
 
 @node Invoking guix build
@@ -3408,6 +3410,53 @@ environment.
 It also supports all of the common build options that @command{guix
 build} supports (@pxref{Invoking guix build, common build options}).
 
+@node Invoking guix publish
+@section Invoking @command{guix publish}
+
+The purpose of @command{guix publish} is to enable users to easily share
+their store with others.  When @command{guix publish} runs, it spawns an
+HTTP server which allows anyone with network access to obtain
+substitutes from it.  This means that any machine running Guix can also
+act as if it were a build farm, since the HTTP interface is
+Hydra-compatible.  For security, each substitute is signed with the
+system's signing key (@pxref{Invoking guix archive}).
+
+@command{guix publish} is a tool for system administrators, so only the
+root user may invoke it.
+
+The general syntax is:
+
+@example
+guix publish @var{options}@dots{}
+@end example
+
+Running @command{guix publish} without any additional arguments will
+spawn an HTTP server on port 8080:
+
+@example
+guix publish
+@end example
+
+Once a publishing server has been authorized (@pxref{Invoking guix archive}),
+the Guix daemon may use it to download substitutes:
+
+@example
+guix-daemon --substitute-urls=http://example.org:8080
+@end example
+
+The following options are available:
+
+@table @code
+@item --port=@var{port}
+@itemx -p @var{port}
+Listen for HTTP requests on @var{port}.
+
+@item --repl[=@var{port}]
+@itemx -r [@var{port}]
+Spawn a Guile REPL server (@pxref{REPL Servers,,, guile, GNU Guile
+Reference Manual}) on @var{port} (37146 by default).
+@end table
+
 @c *********************************************************************
 @node GNU Distribution
 @chapter GNU Distribution
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
new file mode 100644
index 0000000..1339e3b
--- /dev/null
+++ b/guix/scripts/publish.scm
@@ -0,0 +1,233 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts publish)
+  #:use-module ((system repl server) #:prefix repl:)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-37)
+  #:use-module (web http)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web server)
+  #:use-module (web uri)
+  #:use-module (guix base32)
+  #:use-module (guix base64)
+  #:use-module (guix config)
+  #:use-module (guix derivations)
+  #:use-module (guix hash)
+  #:use-module (guix pki)
+  #:use-module (guix pk-crypto)
+  #:use-module (guix store)
+  #:use-module (guix serialization)
+  #:use-module (guix ui)
+  #:export (guix-publish))
+
+(define (show-help)
+  (format #t (_ "Usage: guix publish [OPTION]...
+Publish ~a over HTTP.\n") %store-directory)
+  (display (_ "
+  -p, --port=PORT        listen on PORT"))
+  (display (_ "
+  -r, --repl[=PORT]      spawn REPL server on PORT"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  (list (option '(#\h "help") #f #f
+                (lambda _
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda _
+                  (show-version-and-exit "guix publish")))
+        (option '(#\p "port") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'port (string->number* arg) result)))
+        (option '(#\r "repl") #f #t
+                (lambda (opt name arg result)
+                  ;; If port unspecified, use default Guile REPL port.
+                  (let ((port (and arg (string->number* arg))))
+                    (alist-cons 'repl (or port 37146) result))))))
+
+(define %default-options
+  '((port . 8080)
+    (repl . #f)))
+
+(define (read-file-sexp file)
+  (call-with-input-file file
+    (compose string->canonical-sexp
+             get-string-all)))
+
+(define %private-key
+  (read-file-sexp %private-key-file))
+
+(define %public-key
+  (read-file-sexp %public-key-file))
+
+(define %nix-cache-info
+  `(("StoreDir" . ,%store-directory)
+    ("WantMassQuery" . 0)
+    ("Priority" . 100)))
+
+(define (load-derivation file)
+  "Read the derivation from FILE."
+  (call-with-input-file file read-derivation))
+
+(define (signed-string s)
+  "Sign the hash of the string S with the daemon's key."
+  (let ((hash (bytevector->hash-data (sha256 (string->utf8 s))
+                                     #:key-type (key-type %public-key))))
+    (signature-sexp hash %private-key %public-key)))
+
+(define base64-encode-string
+  (compose base64-encode string->utf8))
+
+(define (narinfo-string store-path path-info key)
+  (let* ((url        (string-append "nar/" (basename store-path)))
+         (hash       (bytevector->base32-string
+                      (path-info-hash path-info)))
+         (size       (path-info-nar-size path-info))
+         (references (string-join
+                      (map basename (path-info-references path-info))
+                      " "))
+         (deriver (path-info-deriver path-info))
+         (base-info  (format #f
+                             "StorePath: ~a
+URL: ~a
+Compression: none
+NarHash: sha256:~a
+NarSize: ~d
+References: ~a~%"
+                             store-path url hash size references))
+         ;; Do not render a "Deriver" or "System" line if we are rendering
+         ;; info for a derivation.
+         (info (if (string-null? deriver)
+                   base-info
+                   (let ((drv (load-derivation deriver)))
+                     (format #f "~aSystem: ~a~%Deriver: ~a~%"
+                             base-info (derivation-system drv)
+                             (basename deriver)))))
+         (signature  (base64-encode-string
+                      (canonical-sexp->string (signed-string info)))))
+    (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature)))
+
+(define (not-found request)
+  "Render 404 response for REQUEST."
+  (values (build-response #:code 404)
+          (string-append "Resource not found: "
+                         (uri-path (request-uri request)))))
+
+(define (render-nix-cache-info)
+  "Render server information."
+  (values '((content-type . (text/plain)))
+          (lambda (port)
+            (for-each (match-lambda
+                       ((key . value)
+                        (format port "~a: ~a~%" key value)))
+                      %nix-cache-info))))
+
+(define (render-narinfo store request hash)
+  "Render metadata for the store path corresponding to HASH."
+  (let* ((store-path (hash-part->path store hash))
+         (path-info (and (not (string-null? store-path))
+                         (query-path-info store store-path))))
+    (if path-info
+        (values '((content-type . (application/x-nix-narinfo)))
+                (cut display
+                     (narinfo-string store-path path-info %private-key)
+                     <>))
+        (not-found request))))
+
+(define (render-nar request store-item)
+  "Render archive of the store path corresponding to STORE-ITEM."
+  (let ((store-path (string-append %store-directory "/" store-item)))
+    ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will
+    ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte
+    ;; sequences.
+    (if (file-exists? store-path)
+        (values '((content-type . (application/x-nix-archive
+                                   (charset . "ISO-8859-1"))))
+                (lambda (port)
+                  (write-file store-path port)))
+        (not-found request))))
+
+(define extract-narinfo-hash
+  (let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$")))
+    (lambda (str)
+      "Return the hash within the narinfo resource string STR, or false if STR
+is invalid."
+      (and=> (regexp-exec regexp str)
+             (cut match:substring <> 1)))))
+
+(define (get-request? request)
+  "Return #t if REQUEST uses the GET method."
+  (eq? (request-method request) 'GET))
+
+(define (request-path-components request)
+  "Split the URI path of REQUEST into a list of component strings.  For
+example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
+  (split-and-decode-uri-path (uri-path (request-uri request))))
+
+(define (make-request-handler store)
+  (lambda (request body)
+    (format #t "~a ~a~%"
+            (request-method request)
+            (uri-path (request-uri request)))
+    (if (get-request? request) ; reject POST, PUT, etc.
+        (match (request-path-components request)
+          ;; /nix-cache-info
+          (("nix-cache-info")
+           (render-nix-cache-info))
+          ;; /<hash>.narinfo
+          (((= extract-narinfo-hash (? string? hash)))
+           (render-narinfo store request hash))
+          ;; /nar/<store-item>
+          (("nar" store-item)
+           (render-nar request store-item))
+          (_ (not-found request)))
+        (not-found request))))
+
+(define (run-publish-server port store)
+  (run-server (make-request-handler store)
+              'http
+              `(#:addr ,INADDR_ANY
+                #:port ,port)))
+
+(define (guix-publish . args)
+  (with-error-handling
+    (let* ((opts (parse-command-line args %options (list %default-options)))
+           (port (assoc-ref opts 'port))
+           (repl-port (assoc-ref opts 'repl))
+           (store (open-connection)))
+      (format #t (_ "publishing ~a on port ~d~%") %store-directory port)
+      (when repl-port
+        (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
+      (run-publish-server (assoc-ref opts 'port) store))))
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index 619f6f9..998c611 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -13,6 +13,7 @@ guix/scripts/substitute-binary.scm
 guix/scripts/authenticate.scm
 guix/scripts/system.scm
 guix/scripts/lint.scm
+guix/scripts/publish.scm
 guix/gnu-maintenance.scm
 guix/ui.scm
 guix/http-client.scm
diff --git a/tests/publish.scm b/tests/publish.scm
new file mode 100644
index 0000000..60f57a8
--- /dev/null
+++ b/tests/publish.scm
@@ -0,0 +1,114 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-publish)
+  #:use-module (guix scripts publish)
+  #:use-module (guix tests)
+  #:use-module (guix config)
+  #:use-module (guix utils)
+  #:use-module (guix hash)
+  #:use-module (guix store)
+  #:use-module (guix base32)
+  #:use-module (guix base64)
+  #:use-module ((guix serialization) #:select (restore-file))
+  #:use-module (guix pk-crypto)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-64)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim))
+
+(define %store
+  (open-connection-for-tests))
+
+(define %reference (add-text-to-store %store "ref" "foo"))
+
+(define %item (add-text-to-store %store "item" "bar" (list %reference)))
+
+(define (http-get-body uri)
+  (call-with-values (lambda () (http-get uri))
+    (lambda (response body) body)))
+
+(define (publish-uri route)
+  (string-append "http://localhost:6789" route))
+
+;; Run a local publishing server in a separate thread.
+(call-with-new-thread
+ (lambda ()
+   (guix-publish "--port=6789"))) ; attempt to avoid port collision
+
+;; Wait until the server is accepting connections.
+(let ((conn (socket PF_INET SOCK_STREAM 0)))
+  (let loop ()
+    (unless (false-if-exception
+             (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") 6789))
+      (loop))))
+
+(test-begin "publish")
+
+(test-equal "/nix-cache-info"
+  (format #f "StoreDir: ~a\nWantMassQuery: 0\nPriority: 100\n"
+          %store-directory)
+  (http-get-body (publish-uri "/nix-cache-info")))
+
+(test-equal "/*.narinfo"
+  (let* ((info (query-path-info %store %item))
+         (unsigned-info
+          (format #f
+                  "StorePath: ~a
+URL: nar/~a
+Compression: none
+NarHash: sha256:~a
+NarSize: ~d
+References: ~a~%"
+                  %item
+                  (basename %item)
+                  (bytevector->base32-string
+                   (path-info-hash info))
+                  (path-info-nar-size info)
+                  (basename (first (path-info-references info)))))
+         (signature (base64-encode
+                     (string->utf8
+                      (canonical-sexp->string
+                       ((@@ (guix scripts publish) signed-string)
+                        unsigned-info))))))
+    (format #f "~aSignature: 1;~a;~a~%"
+            unsigned-info (gethostname) signature))
+  (utf8->string
+   (http-get-body
+    (publish-uri
+     (string-append "/" (store-path-hash-part %item) ".narinfo")))))
+
+(test-equal "/nar/*"
+  "bar"
+  (call-with-temporary-output-file
+   (lambda (temp port)
+     (let ((nar (utf8->string
+                 (http-get-body
+                  (publish-uri
+                   (string-append "/nar/" (basename %item)))))))
+       (call-with-input-string nar (cut restore-file <> temp)))
+     (call-with-input-file temp read-string))))
+
+(test-end "publish")
+
+\f
+(exit (= (test-runner-fail-count (test-runner-current)) 0))
-- 
2.1.4


[-- Attachment #3: Type: text/plain, Size: 136 bytes --]


-- 
David Thompson
Web Developer - Free Software Foundation - http://fsf.org
GPG Key: 0FF1D807
Support the FSF: https://fsf.org/donate

Re: [PATCH 1/2] store: Add query-path-info operation.

[Ludovic Courtès]

David Thompson <dthompson2@worcester.edu> skribis:

> From d86678e29c951ae4983cea92074e8f04c3e49f50 Mon Sep 17 00:00:00 2001
> From: David Thompson <dthompson2@worcester.edu>
> Date: Tue, 17 Mar 2015 10:19:36 -0400
> Subject: [PATCH 1/2] store: Add query-path-info operation.
>
> * guix/store.scm (<path-info>): New record type.
>   (read-path-info): New procedure.
>   (read-arg): Add 'path-info' syntax.
>   (query-path-info): New variable.
> * tests/store.scm ("query-path-info"): New test.

LGTM.  Also add a copyright line in the files.

Thank you!

Ludo’.

Re: [PATCH 2/2] scripts: Add 'publish' command.

[Ludovic Courtès]

David Thompson <dthompson2@worcester.edu> skribis:

> From a40d47dc64571aade0c92b4bdf3c56f6870842cc Mon Sep 17 00:00:00 2001
> From: David Thompson <dthompson2@worcester.edu>
> Date: Tue, 17 Mar 2015 10:21:31 -0400
> Subject: [PATCH 2/2] scripts: Add 'publish' command.
>
> * guix/scripts/publish.scm: New file.
> * po/guix/POTFILES.in: Add it.
> * tests/publish.scm: New file.
> * Makefile.am (MODULES): Add script module.
>   (SCM_TESTS): Add test module.
> * doc/guix.texi ("Invoking guix publish"): New node.

[...]

> +@node Invoking guix publish
> +@section Invoking @command{guix publish}
> +
> +The purpose of @command{guix publish} is to enable users to easily share
> +their store with others.  When @command{guix publish} runs, it spawns an
> +HTTP server which allows anyone with network access to obtain
> +substitutes from it.  This means that any machine running Guix can also
> +act as if it were a build farm, since the HTTP interface is
> +Hydra-compatible.  For security, each substitute is signed with the
> +system's signing key (@pxref{Invoking guix archive}).

I would skip a line after “Hydra-compatible,” and make it like:

  For security, each substitute is signed, allowing recipients to check
  their authenticity and integrity (@pxref{Substitutes}).  Because
  @command{guix publish} uses the system's signing key, which is only
  readable by the system administrator, it must run as root.

> +@command{guix publish} is a tool for system administrators, so only the
> +root user may invoke it.

... so this sentence can be removed.

Note for later: it should drop privileges once the key has been read and
the port open.

> +Once a publishing server has been authorized (@pxref{Invoking guix archive}),
> +the Guix daemon may use it to download substitutes:

“the daemon may download substitutes from it:”

> +(define (read-file-sexp file)
> +  (call-with-input-file file
> +    (compose string->canonical-sexp
> +             get-string-all)))
> +
> +(define %private-key
> +  (read-file-sexp %private-key-file))
> +
> +(define %public-key
> +  (read-file-sexp %public-key-file))

Since this can throw, it should not be done at the top-level.  So it
should be wrapped it in ‘delay’ or in a thunk.

> +(define (narinfo-string store-path path-info key)

Docstring please.  :-)

> +(define (render-nar request store-item)
> +  "Render archive of the store path corresponding to STORE-ITEM."
> +  (let ((store-path (string-append %store-directory "/" store-item)))
> +    ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will
> +    ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte
> +    ;; sequences.
> +    (if (file-exists? store-path)
> +        (values '((content-type . (application/x-nix-archive
> +                                   (charset . "ISO-8859-1"))))
> +                (lambda (port)
> +                  (write-file store-path port)))
> +        (not-found request))))

This is OK for now, but I just realized that this will be blocking the
server for the duration of the whole transfer.  Someone could DoS you by
substituting TeX Live.  ;-)

We’ll need a solution but it seems that it’ll be hard to avoid threads.

Thoughts?

> +(define (guix-publish . args)
> +  (with-error-handling
> +    (let* ((opts (parse-command-line args %options (list %default-options)))

I had overlooked it but it should use plain ‘args-fold*’ instead of
‘parse-command-line’ (the latter handles $GUIX_BUILD_OPTIONS and ‘guix
publish’ doesn’t build anything.)

> +           (store (open-connection)))

Use (with-store store body ...) instead.

OK to push with these changes.

Thanks!

Ludo’.

Re: [PATCH 2/2] scripts: Add 'publish' command.

[Mark H Weaver]

ludo@gnu.org (Ludovic Courtès) writes:

> David Thompson <dthompson2@worcester.edu> skribis:
>
>> +(define (render-nar request store-item)
>> +  "Render archive of the store path corresponding to STORE-ITEM."
>> +  (let ((store-path (string-append %store-directory "/" store-item)))
>> +    ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will
>> +    ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte
>> +    ;; sequences.
>> +    (if (file-exists? store-path)
>> +        (values '((content-type . (application/x-nix-archive
>> +                                   (charset . "ISO-8859-1"))))
>> +                (lambda (port)
>> +                  (write-file store-path port)))
>> +        (not-found request))))
>
> This is OK for now, but I just realized that this will be blocking the
> server for the duration of the whole transfer.  Someone could DoS you by
> substituting TeX Live.  ;-)
>
> We’ll need a solution but it seems that it’ll be hard to avoid threads.
>
> Thoughts?

I haven't looked closely, but how about using subprocesses instead of
threads?

      Mark

Re: [PATCH 2/2] scripts: Add 'publish' command.

[David Thompson]

Mark H Weaver <mhw@netris.org> writes:

> ludo@gnu.org (Ludovic Courtès) writes:
>
>> David Thompson <dthompson2@worcester.edu> skribis:
>>
>>> +(define (render-nar request store-item)
>>> +  "Render archive of the store path corresponding to STORE-ITEM."
>>> +  (let ((store-path (string-append %store-directory "/" store-item)))
>>> +    ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will
>>> +    ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte
>>> +    ;; sequences.
>>> +    (if (file-exists? store-path)
>>> +        (values '((content-type . (application/x-nix-archive
>>> +                                   (charset . "ISO-8859-1"))))
>>> +                (lambda (port)
>>> +                  (write-file store-path port)))
>>> +        (not-found request))))
>>
>> This is OK for now, but I just realized that this will be blocking the
>> server for the duration of the whole transfer.  Someone could DoS you by
>> substituting TeX Live.  ;-)
>>
>> We’ll need a solution but it seems that it’ll be hard to avoid threads.
>>
>> Thoughts?
>
> I haven't looked closely, but how about using subprocesses instead of
> threads?

That's along the lines of what I was thinking.  One could spawn a bunch
of 'guix publish' processes on different ports and put a load balancer
in front of them.

I think that this problem, if it is to be solved with more Scheme code,
is an issue to address in Guile core by changing the http server
implementation.

-- 
David Thompson
Web Developer - Free Software Foundation - http://fsf.org
GPG Key: 0FF1D807
Support the FSF: https://fsf.org/donate

Re: [PATCH 2/2] scripts: Add 'publish' command.

[Ludovic Courtès]

David Thompson <dthompson2@worcester.edu> skribis:

> Mark H Weaver <mhw@netris.org> writes:
>
>> ludo@gnu.org (Ludovic Courtès) writes:
>>
>>> David Thompson <dthompson2@worcester.edu> skribis:
>>>
>>>> +(define (render-nar request store-item)
>>>> +  "Render archive of the store path corresponding to STORE-ITEM."
>>>> +  (let ((store-path (string-append %store-directory "/" store-item)))
>>>> +    ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will
>>>> +    ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte
>>>> +    ;; sequences.
>>>> +    (if (file-exists? store-path)
>>>> +        (values '((content-type . (application/x-nix-archive
>>>> +                                   (charset . "ISO-8859-1"))))
>>>> +                (lambda (port)
>>>> +                  (write-file store-path port)))
>>>> +        (not-found request))))
>>>
>>> This is OK for now, but I just realized that this will be blocking the
>>> server for the duration of the whole transfer.  Someone could DoS you by
>>> substituting TeX Live.  ;-)
>>>
>>> We’ll need a solution but it seems that it’ll be hard to avoid threads.
>>>
>>> Thoughts?
>>
>> I haven't looked closely, but how about using subprocesses instead of
>> threads?

Sounds good.

> That's along the lines of what I was thinking.  One could spawn a bunch
> of 'guix publish' processes on different ports and put a load balancer
> in front of them.

What about changing the ‘open’ method of the <server-impl> (as in
tests/lint.scm) so that it forks upon socket opening?  (That could also
be the moment where we’d drop privileges.)

> I think that this problem, if it is to be solved with more Scheme code,
> is an issue to address in Guile core by changing the http server
> implementation.

Once we have a sufficiently different and valuable server
implementation, we could turn it into a (web server xxx) module.  I
think there’s value in keeping the simple/simplistic (web server http)
too.

Ludo’.

Re: [PATCH 2/2] scripts: Add 'publish' command.

[David Thompson]

Ludovic Courtès <ludo@gnu.org> writes:

> OK to push with these changes.

Done and pushed!  Thanks for the helpful review.

We'll see about addressing the web server issues moving forward.  I'm
not feeling up to the challenge of writing a new HTTP server at the
moment.

-- 
David Thompson
Web Developer - Free Software Foundation - http://fsf.org
GPG Key: 0FF1D807
Support the FSF: https://fsf.org/donate