diff options
| -rw-r--r-- | Makefile.am | 4 | ||||
| -rw-r--r-- | doc/guix.texi | 52 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 243 | ||||
| -rw-r--r-- | po/guix/POTFILES.in | 1 | ||||
| -rw-r--r-- | tests/publish.scm | 114 |
5 files changed, 412 insertions, 2 deletions
diff --git a/Makefile.am b/Makefile.am index cf709986ed..e15e43fdd4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -105,6 +105,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) @@ -180,7 +181,8 @@ SCM_TESTS = \ tests/profiles.scm \ tests/syscalls.scm \ tests/gremlin.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 f7f22e5b8a..f1dea45f1d 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 @@ -2527,7 +2528,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 @@ -2777,6 +2778,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 @@ -3439,6 +3441,54 @@ 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, 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. + +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 daemon may download substitutes from it: + +@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 0000000000..c7c66fefbe --- /dev/null +++ b/guix/scripts/publish.scm @@ -0,0 +1,243 @@ +;;; 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 (lazy-read-file-sexp file) + "Return a promise to read the canonical sexp from FILE." + (delay + (call-with-input-file file + (compose string->canonical-sexp + get-string-all)))) + +(define %private-key + (lazy-read-file-sexp %private-key-file)) + +(define %public-key + (lazy-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* ((public-key (force %public-key)) + (hash (bytevector->hash-data (sha256 (string->utf8 s)) + #:key-type (key-type public-key)))) + (signature-sexp hash (force %private-key) public-key))) + +(define base64-encode-string + (compose base64-encode string->utf8)) + +(define (narinfo-string store-path path-info key) + "Generate a narinfo key/value string for STORE-PATH using the details in +PATH-INFO. The narinfo is signed with 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 (force %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 (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (_ "~A: extraneuous argument~%") arg)) + %default-options)) + (port (assoc-ref opts 'port)) + (repl-port (assoc-ref opts 'repl))) + (format #t (_ "publishing ~a on port ~d~%") %store-directory port) + (when repl-port + (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) + (with-store store + (run-publish-server (assoc-ref opts 'port) store))))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 39115f970b..5ac9201295 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -13,6 +13,7 @@ guix/scripts/substitute.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 0000000000..60f57a8ddb --- /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") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) |