From 7200a8ca892308a03a92e737b493244154bab358 Mon Sep 17 00:00:00 2001 From: David Thompson 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))) ; /.narinfo + (render-narinfo request hash)) + (("nar" store-path) ; /nar/ + (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