diff options
Diffstat (limited to 'guix/scripts')
-rw-r--r-- | guix/scripts/challenge.scm | 40 | ||||
-rw-r--r-- | guix/scripts/gc.scm | 7 | ||||
-rw-r--r-- | guix/scripts/lint.scm | 17 | ||||
-rw-r--r-- | guix/scripts/publish.scm | 169 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 3 | ||||
-rw-r--r-- | guix/scripts/system.scm | 2 |
6 files changed, 191 insertions, 47 deletions
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 149647cfdf..590d8f1099 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -21,6 +21,7 @@ #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix grafts) #:use-module (guix monads) #:use-module (guix base32) #:use-module (guix packages) @@ -222,23 +223,26 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (urls (assoc-ref opts 'substitute-urls))) (leave-on-EPIPE (with-store store - (let ((files (match files - (() - (filter (cut locally-built? store <>) - (live-paths store))) - (x - files)))) - (set-build-options store - #:use-substitutes? #f) - - (run-with-store store - (mlet* %store-monad ((items (mapm %store-monad - ensure-store-item files)) - (issues (discrepancies items urls))) - (for-each summarize-discrepancy issues) - (unless (null? issues) - (exit 2)) - (return (null? issues))) - #:system system))))))) + ;; Disable grafts since substitute servers normally provide only + ;; ungrafted stuff. + (parameterize ((%graft? #f)) + (let ((files (match files + (() + (filter (cut locally-built? store <>) + (live-paths store))) + (x + files)))) + (set-build-options store + #:use-substitutes? #f) + + (run-with-store store + (mlet* %store-monad ((items (mapm %store-monad + ensure-store-item files)) + (issues (discrepancies items urls))) + (for-each summarize-discrepancy issues) + (unless (null? issues) + (exit 2)) + (return (null? issues))) + #:system system)))))))) ;;; challenge.scm ends here diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 8db28138c8..bdfee4308c 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -24,6 +24,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:export (guix-gc)) @@ -221,9 +222,11 @@ Invoke the garbage collector.\n")) (free-space (ensure-free-space store free-space)) (min-freed - (collect-garbage store min-freed)) + (let-values (((paths freed) (collect-garbage store min-freed))) + (info (_ "freed ~h bytes~%") freed))) (else - (collect-garbage store))))) + (let-values (((paths freed) (collect-garbage store))) + (info (_ "freed ~h bytes~%") freed)))))) ((delete) (delete-paths store (map direct-store-path paths))) ((list-references) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index b4fdb6f905..d5e9197cc9 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -359,7 +359,22 @@ warning for PACKAGE mentionning the FIELD." (probe-uri uri #:timeout 3))) ;wait at most 3 seconds (case status ((http-response) - (or (= 200 (response-code argument)) + (if (= 200 (response-code argument)) + (match (response-content-length argument) + ((? number? length) + ;; As of July 2016, SourceForge returns 200 (instead of 404) + ;; with a small HTML page upon failure. Attempt to detect such + ;; malicious behavior. + (or (> length 1000) + (begin + (emit-warning package + (format #f + (_ "URI ~a returned \ +suspiciously small file (~a bytes)") + (uri->string uri) + length)) + #f))) + (_ #t)) (begin (emit-warning package (format #f diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 4c0aa8e419..3baceaf645 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -27,6 +27,7 @@ #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) @@ -45,6 +46,7 @@ #:use-module (guix pk-crypto) #:use-module (guix store) #:use-module (guix serialization) + #:use-module (guix zlib) #:use-module (guix ui) #:use-module (guix scripts) #:export (guix-publish)) @@ -59,6 +61,9 @@ Publish ~a over HTTP.\n") %store-directory) (display (_ " -u, --user=USER change privileges to USER as soon as possible")) (display (_ " + -C, --compression[=LEVEL] + compress archives at LEVEL")) + (display (_ " --ttl=TTL announce narinfos can be cached for TTL seconds")) (display (_ " -r, --repl[=PORT] spawn REPL server on PORT")) @@ -79,6 +84,20 @@ Publish ~a over HTTP.\n") %store-directory) (leave (_ "lookup of host '~a' failed: ~a~%") host (gai-strerror error))))) +;; Nar compression parameters. +(define-record-type <compression> + (compression type level) + compression? + (type compression-type) + (level compression-level)) + +(define %no-compression + (compression 'none 0)) + +(define %default-gzip-compression + ;; Since we compress on the fly, default to fast compression. + (compression 'gzip 3)) + (define %options (list (option '(#\h "help") #f #f (lambda _ @@ -102,6 +121,20 @@ Publish ~a over HTTP.\n") %store-directory) (() (leave (_ "lookup of host '~a' returned nothing") name))))) + (option '(#\C "compression") #f #t + (lambda (opt name arg result) + (match (if arg (string->number* arg) 3) + (0 + (alist-cons 'compression %no-compression result)) + (level + (if (zlib-available?) + (alist-cons 'compression + (compression 'gzip level) + result) + (begin + (warning (_ "zlib support is missing; \ +compression disabled~%")) + result)))))) (option '("ttl") #t #f (lambda (opt name arg result) (let ((duration (string->duration arg))) @@ -117,6 +150,12 @@ Publish ~a over HTTP.\n") %store-directory) (define %default-options `((port . 8080) + + ;; Default to fast & low compression. + (compression . ,(if (zlib-available?) + %default-gzip-compression + %no-compression)) + (address . ,(make-socket-address AF_INET INADDR_ANY 0)) (repl . #f))) @@ -152,12 +191,20 @@ Publish ~a over HTTP.\n") %store-directory) (define base64-encode-string (compose base64-encode string->utf8)) -(define (narinfo-string store store-path key) +(define* (narinfo-string store store-path key + #:key (compression %no-compression)) "Generate a narinfo key/value string for STORE-PATH; an exception is raised -if STORE-PATH is invalid. The narinfo is signed with KEY." +if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The +narinfo is signed with KEY." (let* ((path-info (query-path-info store store-path)) - (url (encode-and-join-uri-path (list "nar" - (basename store-path)))) + (url (encode-and-join-uri-path + `("nar" + ,@(match compression + (($ <compression> 'none) + '()) + (($ <compression> type) + (list (symbol->string type)))) + ,(basename store-path)))) (hash (bytevector->nix-base32-string (path-info-hash path-info))) (size (path-info-nar-size path-info)) @@ -166,13 +213,16 @@ if STORE-PATH is invalid. The narinfo is signed with KEY." " ")) (deriver (path-info-deriver path-info)) (base-info (format #f - "StorePath: ~a + "\ +StorePath: ~a URL: ~a -Compression: none +Compression: ~a NarHash: sha256:~a NarSize: ~d References: ~a~%" - store-path url hash size references)) + store-path url + (compression-type compression) + hash size references)) ;; Do not render a "Deriver" or "System" line if we are rendering ;; info for a derivation. (info (if (not deriver) @@ -209,7 +259,8 @@ References: ~a~%" (format port "~a: ~a~%" key value))) %nix-cache-info)))) -(define* (render-narinfo store request hash #:key ttl) +(define* (render-narinfo store request hash + #:key ttl (compression %no-compression)) "Render metadata for the store path corresponding to HASH. If TTL is true, advertise it as the maximum validity period (in seconds) via the 'Cache-Control' header. This allows 'guix substitute' to cache it for an @@ -222,18 +273,35 @@ appropriate duration." `((cache-control (max-age . ,ttl))) '())) (cut display - (narinfo-string store store-path (force %private-key)) - <>))))) - -(define (render-nar store request store-item) + (narinfo-string store store-path (force %private-key) + #:compression compression) + <>))))) + +;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for +;; internal consumption: it allows us to pass the compression info to +;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>. +(declare-header! "Guix-Nar-Compression" + (lambda (str) + (match (call-with-input-string str read) + (('compression type level) + (compression type level)))) + compression? + (lambda (compression port) + (match compression + (($ <compression> type level) + (write `(compression ,type ,level) port))))) + +(define* (render-nar store request store-item + #:key (compression %no-compression)) "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 (valid-path? store store-path) - (values '((content-type . (application/x-nix-archive - (charset . "ISO-8859-1")))) + (values `((content-type . (application/x-nix-archive + (charset . "ISO-8859-1"))) + (guix-nar-compression . ,compression)) ;; XXX: We're not returning the actual contents, deferring ;; instead to 'http-write'. This is a hack to work around ;; <http://bugs.gnu.org/21093>. @@ -282,6 +350,28 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (values) (apply throw args))))) +(define-syntax-rule (swallow-zlib-error exp ...) + "Swallow 'zlib-error' exceptions raised by EXP..." + (catch 'zlib-error + (lambda () + exp ...) + (const #f))) + +(define (nar-response-port response) + "Return a port on which to write the body of RESPONSE, the response of a +/nar request, according to COMPRESSION." + (match (assoc-ref (response-headers response) 'guix-nar-compression) + (($ <compression> 'gzip level) + ;; Note: We cannot used chunked encoding here because + ;; 'make-gzip-output-port' wants a file port. + (make-gzip-output-port (response-port response) + #:level level + #:buffer-size (* 64 1024))) + (($ <compression> 'none) + (response-port response)) + (#f + (response-port response)))) + (define (http-write server client response body) "Write RESPONSE and BODY to CLIENT, possibly in a separate thread to avoid blocking." @@ -293,16 +383,20 @@ blocking." (lambda () (let* ((response (write-response (sans-content-length response) client)) - (port (response-port response))) + (port (begin + (force-output client) + (nar-response-port response)))) ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> in ;; 'render-nar', BODY here is just the file name of the store item. ;; We call 'write-file' from here because we know that's the only ;; way to avoid building the whole nar in memory, which could ;; quickly become a real problem. As a bonus, we even do ;; sendfile(2) directly from the store files to the socket. - (swallow-EPIPE - (write-file (utf8->string body) port)) - (close-port port) + (swallow-zlib-error + (swallow-EPIPE + (write-file (utf8->string body) port))) + (swallow-zlib-error + (close-port port)) (values))))) (_ ;; Handle other responses sequentially. @@ -316,7 +410,10 @@ blocking." http-write (@@ (web server http) http-close)) -(define* (make-request-handler store #:key narinfo-ttl) +(define* (make-request-handler store + #:key + narinfo-ttl + (compression %no-compression)) (lambda (request body) (format #t "~a ~a~%" (request-method request) @@ -330,16 +427,37 @@ blocking." (((= extract-narinfo-hash (? string? hash))) ;; TODO: Register roots for HASH that will somehow remain for ;; NARINFO-TTL. - (render-narinfo store request hash #:ttl narinfo-ttl)) + (render-narinfo store request hash + #:ttl narinfo-ttl + #:compression compression)) + + ;; Use different URLs depending on the compression type. This + ;; guarantees that /nar URLs remain valid even when 'guix publish' + ;; is restarted with different compression parameters. + ;; /nar/<store-item> (("nar" store-item) - (render-nar store request store-item)) + (render-nar store request store-item + #:compression %no-compression)) + ;; /nar/gzip/<store-item> + (("nar" "gzip" store-item) + (if (zlib-available?) + (render-nar store request store-item + #:compression + (match compression + (($ <compression> 'gzip) + compression) + (_ + %default-gzip-compression))) + (not-found request))) (_ (not-found request))) (not-found request)))) (define* (run-publish-server socket store - #:key narinfo-ttl) - (run-server (make-request-handler store #:narinfo-ttl narinfo-ttl) + #:key (compression %no-compression) narinfo-ttl) + (run-server (make-request-handler store + #:narinfo-ttl narinfo-ttl + #:compression compression) concurrent-http-server `(#:socket ,socket))) @@ -378,6 +496,7 @@ blocking." (user (assoc-ref opts 'user)) (port (assoc-ref opts 'port)) (ttl (assoc-ref opts 'narinfo-ttl)) + (compression (assoc-ref opts 'compression)) (address (let ((addr (assoc-ref opts 'address))) (make-socket-address (sockaddr:fam addr) (sockaddr:addr addr) @@ -404,4 +523,6 @@ consider using the '--user' option!~%"))) (when repl-port (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port))) (with-store store - (run-publish-server socket store #:narinfo-ttl ttl))))) + (run-publish-server socket store + #:compression compression + #:narinfo-ttl ttl))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 5722aa821d..8827c45fb8 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -610,7 +610,8 @@ if file doesn't exist, and the narinfo otherwise." (update-progress!) (cons narinfo result)) (let* ((path (uri-path (request-uri request))) - (hash-part (string-drop-right path 8))) ; drop ".narinfo" + (hash-part (basename + (string-drop-right path 8)))) ;drop ".narinfo" (if len (get-bytevector-n port len) (read-to-eof port)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index dd1e534c9b..e2c6b2efee 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -362,7 +362,7 @@ it atomically, and then run OS's activation script." ;; The activation script may modify '%load-path' & co., so protect ;; against that. This is necessary to ensure that ;; 'upgrade-shepherd-services' gets to see the right modules when it - ;; computes derivations with (gexp->derivation #:modules …). + ;; computes derivations with 'gexp->derivation'. (save-load-path-excursion (primitive-load (derivation->output-path script)))) |