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

[David Thompson]

>From 7200a8ca892308a03a92e737b493244154bab358 Mon Sep 17 00:00:00 2001
From: David Thompson <address@hidden>
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}).
 
address@hidden Invoking guix publish
address@hidden 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:
+
address@hidden
+guix publish @address@hidden
address@hidden example
+
+Running @command{guix publish} without any additional arguments will
+spawn an HTTP server on port 8080:
+
address@hidden
+guix publish
address@hidden example
+
+Once a publishing server has been authorized (@pxref{Invoking guix archive}),
+the Guix daemon may use it to download substitutes:
+
address@hidden
+guix-daemon --substitute-urls=example.org:8080
address@hidden example
+
+The following options are available:
+
address@hidden @code
address@hidden address@hidden
address@hidden -p @var{port}
+Listen for HTTP requests on @var{port}.
+
address@hidden address@hidden
address@hidden -r address@hidden
+Spawn a Guile REPL server (@pxref{REPL Servers,,, guile, GNU Guile
+Reference Manual}) on @var{port} (37146 by default).  Useful for developers.
address@hidden 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

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