diff options
Diffstat (limited to 'guix/scripts')
-rw-r--r-- | guix/scripts/package.scm | 63 | ||||
-rw-r--r-- | guix/scripts/publish.scm | 243 |
2 files changed, 279 insertions, 27 deletions
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 3cc7ae760f..6190f3286d 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -232,6 +232,41 @@ DURATION-RELATION with the current time." filter-by-duration) (else #f))) +(define (delete-matching-generations store profile pattern) + "Delete from PROFILE all the generations matching PATTERN. PATTERN must be +a string denoting a set of generations: the empty list means \"all generations +but the current one\", a number designates a generation, and other patterns +denote ranges as interpreted by 'matching-derivations'." + (let ((current (generation-number profile))) + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((string-null? pattern) + (delete-generations (%store) profile + (delv current (profile-generations profile)))) + ;; Do not delete the zeroth generation. + ((equal? 0 (string->number pattern)) + #t) + + ;; If PATTERN is a duration, match generations that are + ;; older than the specified duration. + ((matching-generations pattern profile + #:duration-relation >) + => + (lambda (numbers) + (when (memv current numbers) + (warning (_ "not removing generation ~a, which is current~%") + current)) + + ;; Make sure we don't inadvertently remove the current + ;; generation. + (let ((numbers (delv current numbers))) + (when (null-list? numbers) + (leave (_ "no matching generation~%"))) + (delete-generations (%store) profile numbers)))) + (else + (leave (_ "invalid syntax: ~a~%") pattern))))) + ;;; ;;; Package specifications. @@ -751,9 +786,6 @@ more information.~%")) (define dry-run? (assoc-ref opts 'dry-run?)) (define profile (assoc-ref opts 'profile)) - (define current-generation-number - (generation-number profile)) - ;; First roll back if asked to. (cond ((and (assoc-ref opts 'roll-back?) (not dry-run?)) @@ -782,30 +814,7 @@ more information.~%")) (for-each (match-lambda (('delete-generations . pattern) - (cond ((not (file-exists? profile)) ; XXX: race condition - (raise (condition (&profile-not-found-error - (profile profile))))) - ((string-null? pattern) - (delete-generations - (%store) profile - (delete current-generation-number - (profile-generations profile)))) - ;; Do not delete the zeroth generation. - ((equal? 0 (string->number pattern)) - (exit 0)) - - ;; If PATTERN is a duration, match generations that are - ;; older than the specified duration. - ((matching-generations pattern profile - #:duration-relation >) - => - (lambda (numbers) - (if (null-list? numbers) - (exit 1) - (delete-generations (%store) profile numbers)))) - (else - (leave (_ "invalid syntax: ~a~%") - pattern))) + (delete-matching-generations (%store) profile pattern) (process-actions (alist-delete 'delete-generations opts))) 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))))) |