;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 threads)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (web response)
#:use-module (web server)
#:use-module (web uri)
+ #:autoload (sxml simple) (sxml->xml)
#:use-module (guix base32)
#:use-module (guix base64)
#:use-module (guix config)
#:use-module (guix derivations)
- #:use-module (guix hash)
+ #:use-module (gcrypt hash)
#:use-module (guix pki)
- #:use-module (guix pk-crypto)
+ #:use-module (gcrypt pk-crypto)
+ #:use-module (guix workers)
#:use-module (guix store)
#:use-module ((guix serialization) #:select (write-file))
#:use-module (guix zlib)
+ #:autoload (guix lzlib) (lzlib-available?)
+ #:use-module (guix cache)
#:use-module (guix ui)
#:use-module (guix scripts)
- #:use-module ((guix utils) #:select (compressed-file?))
- #:use-module ((guix build utils) #:select (dump-port))
- #:export (guix-publish))
+ #:use-module ((guix utils)
+ #:select (with-atomic-file-output compressed-file?))
+ #:use-module ((guix build utils)
+ #:select (dump-port mkdir-p find-files))
+ #:use-module ((guix build syscalls) #:select (set-thread-name))
+ #:export (%public-key
+ %private-key
+
+ guix-publish))
(define (show-help)
- (format #t (_ "Usage: guix publish [OPTION]...
+ (format #t (G_ "Usage: guix publish [OPTION]...
Publish ~a over HTTP.\n") %store-directory)
- (display (_ "
+ (display (G_ "
-p, --port=PORT listen on PORT"))
- (display (_ "
+ (display (G_ "
--listen=HOST listen on the network interface for HOST"))
- (display (_ "
+ (display (G_ "
-u, --user=USER change privileges to USER as soon as possible"))
- (display (_ "
- -C, --compression[=LEVEL]
- compress archives at LEVEL"))
- (display (_ "
+ (display (G_ "
+ -C, --compression[=METHOD:LEVEL]
+ compress archives with METHOD at LEVEL"))
+ (display (G_ "
+ -c, --cache=DIRECTORY cache published items to DIRECTORY"))
+ (display (G_ "
+ --workers=N use N workers to bake items"))
+ (display (G_ "
--ttl=TTL announce narinfos can be cached for TTL seconds"))
- (display (_ "
+ (display (G_ "
+ --nar-path=PATH use PATH as the prefix for nar URLs"))
+ (display (G_ "
+ --public-key=FILE use FILE as the public key for signatures"))
+ (display (G_ "
+ --private-key=FILE use FILE as the private key for signatures"))
+ (display (G_ "
-r, --repl[=PORT] spawn REPL server on PORT"))
(newline)
- (display (_ "
+ (display (G_ "
-h, --help display this help and exit"))
- (display (_ "
+ (display (G_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
(lambda ()
(getaddrinfo host))
(lambda (key error)
- (leave (_ "lookup of host '~a' failed: ~a~%")
+ (leave (G_ "lookup of host '~a' failed: ~a~%")
host (gai-strerror error)))))
;; Nar compression parameters.
;; Since we compress on the fly, default to fast compression.
(compression 'gzip 3))
+(define (default-compression type)
+ (compression type 3))
+
+(define (actual-compressions item requested)
+ "Return the actual compressions used for ITEM, which may be %NO-COMPRESSION
+if ITEM is already compressed."
+ (if (compressed-file? item)
+ (list %no-compression)
+ requested))
+
(define %options
(list (option '(#\h "help") #f #f
(lambda _
(alist-cons 'address (addrinfo:addr info)
result))
(()
- (leave (_ "lookup of host '~a' returned nothing")
+ (leave (G_ "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))))))
+ (let* ((colon (string-index arg #\:))
+ (type (cond
+ (colon (string-take arg colon))
+ ((string->number arg) "gzip")
+ (else arg)))
+ (level (if colon
+ (string->number*
+ (string-drop arg (+ 1 colon)))
+ (or (string->number arg) 3))))
+ (match level
+ (0
+ (alist-cons 'compression %no-compression result))
+ (level
+ (match (string->compression-type type)
+ ((? symbol? type)
+ (alist-cons 'compression
+ (compression type level)
+ result))
+ (_
+ (warning (G_ "~a: unsupported compression type~%")
+ type)
+ result)))))))
+ (option '(#\c "cache") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'cache arg result)))
+ (option '("workers") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'workers (string->number* arg)
+ result)))
(option '("ttl") #t #f
(lambda (opt name arg result)
(let ((duration (string->duration arg)))
(unless duration
- (leave (_ "~a: invalid duration~%") arg))
+ (leave (G_ "~a: invalid duration~%") arg))
(alist-cons 'narinfo-ttl (time-second duration)
result))))
+ (option '("nar-path") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'nar-path arg result)))
+ (option '("public-key") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'public-key-file arg result)))
+ (option '("private-key" "secret-key") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'private-key-file arg result)))
(option '(#\r "repl") #f #t
(lambda (opt name arg result)
;; If port unspecified, use default Guile REPL port.
(define %default-options
`((port . 8080)
- ;; Default to fast & low compression.
- (compression . ,(if (zlib-available?)
- %default-gzip-compression
- %no-compression))
+ ;; By default, serve nars under "/nar".
+ (nar-path . "nar")
+
+ (public-key-file . ,%public-key-file)
+ (private-key-file . ,%private-key-file)
+
+ ;; Default number of workers when caching is enabled.
+ (workers . ,(current-processor-count))
(address . ,(make-socket-address AF_INET INADDR_ANY 0))
(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
- read-string))))
-
+;; The key pair used to sign narinfos.
(define %private-key
- (lazy-read-file-sexp %private-key-file))
-
+ (make-parameter #f))
(define %public-key
- (lazy-read-file-sexp %public-key-file))
+ (make-parameter #f))
(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))
+ (let* ((public-key (%public-key))
(hash (bytevector->hash-data (sha256 (string->utf8 s))
#:key-type (key-type public-key))))
- (signature-sexp hash (force %private-key) public-key)))
+ (signature-sexp hash (%private-key) public-key)))
(define base64-encode-string
(compose base64-encode string->utf8))
+(define* (store-item->recutils store-item
+ #:key
+ (nar-path "nar")
+ (compression %no-compression)
+ file-size)
+ "Return the 'Compression' and 'URL' fields of the narinfo for STORE-ITEM,
+with COMPRESSION, starting at NAR-PATH."
+ (let ((url (encode-and-join-uri-path
+ `(,@(split-and-decode-uri-path nar-path)
+ ,@(match compression
+ (($ <compression> 'none)
+ '())
+ (($ <compression> type)
+ (list (symbol->string type))))
+ ,(basename store-item)))))
+ (format #f "URL: ~a~%Compression: ~a~%~@[FileSize: ~a~%~]"
+ url (compression-type compression) file-size)))
+
(define* (narinfo-string store store-path key
- #:key (compression %no-compression))
+ #:key (compressions (list %no-compression))
+ (nar-path "nar") (file-sizes '()))
"Generate a narinfo key/value string for STORE-PATH; an exception is raised
if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The
-narinfo is signed with KEY."
+narinfo is signed with KEY. NAR-PATH specifies the prefix for nar URLs.
+
+Optionally, FILE-SIZES is a list of compression/integer pairs, where the
+integer is size in bytes of the compressed NAR; it informs the client of how
+much needs to be downloaded."
(let* ((path-info (query-path-info store store-path))
- (compression (if (compressed-file? store-path)
- %no-compression
- compression))
- (url (encode-and-join-uri-path
- `("nar"
- ,@(match compression
- (($ <compression> 'none)
- '())
- (($ <compression> type)
- (list (symbol->string type))))
- ,(basename store-path))))
+ (compressions (actual-compressions store-path compressions))
(hash (bytevector->nix-base32-string
(path-info-hash path-info)))
(size (path-info-nar-size path-info))
+ (file-sizes `((,%no-compression . ,size) ,@file-sizes))
(references (string-join
(map basename (path-info-references path-info))
" "))
(base-info (format #f
"\
StorePath: ~a
-URL: ~a
-Compression: ~a
+~{~a~}\
NarHash: sha256:~a
NarSize: ~d
References: ~a~%"
- store-path url
- (compression-type compression)
+ store-path
+ (map (lambda (compression)
+ (let ((size (assoc-ref file-sizes
+ compression)))
+ (store-item->recutils store-path
+ #:file-size size
+ #:nar-path nar-path
+ #:compression
+ compression)))
+ compressions)
hash size references))
;; Do not render a "Deriver" or "System" line if we are rendering
;; info for a derivation.
base-info
(catch 'system-error
(lambda ()
- (let ((drv (load-derivation deriver)))
+ (let ((drv (read-derivation-from-file deriver)))
(format #f "~aSystem: ~a~%Deriver: ~a~%"
base-info (derivation-system drv)
(basename deriver))))
(canonical-sexp->string (signed-string info)))))
(format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature)))
-(define (not-found request)
+(define* (not-found request
+ #:key (phrase "Resource not found")
+ ttl)
"Render 404 response for REQUEST."
- (values (build-response #:code 404)
- (string-append "Resource not found: "
+ (values (build-response #:code 404
+ #:headers (if ttl
+ `((cache-control (max-age . ,ttl)))
+ '()))
+ (string-append phrase ": "
(uri-path (request-uri request)))))
(define (render-nix-cache-info)
%nix-cache-info))))
(define* (render-narinfo store request hash
- #:key ttl (compression %no-compression))
+ #:key ttl (compressions (list %no-compression))
+ (nar-path "nar"))
"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
-appropriate duration."
+appropriate duration. NAR-PATH specifies the prefix for nar URLs."
(let ((store-path (hash-part->path store hash)))
(if (string-null? store-path)
- (not-found request)
+ (not-found request #:phrase "")
(values `((content-type . (application/x-nix-narinfo))
,@(if ttl
`((cache-control (max-age . ,ttl)))
'()))
(cut display
- (narinfo-string store store-path (force %private-key)
- #:compression compression)
+ (narinfo-string store store-path (%private-key)
+ #:nar-path nar-path
+ #:compressions compressions)
<>)))))
-;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for
+(define* (nar-cache-file directory item
+ #:key (compression %no-compression))
+ (string-append directory "/"
+ (symbol->string (compression-type compression))
+ "/" (basename item) ".nar"))
+
+(define* (narinfo-cache-file directory item
+ #:key (compression %no-compression))
+ (string-append directory "/"
+ (symbol->string (compression-type compression))
+ "/" (basename item)
+ ".narinfo"))
+
+(define (hash-part-mapping-cache-file directory hash)
+ (string-append directory "/hashes/" hash))
+
+(define run-single-baker
+ (let ((baking (make-weak-value-hash-table))
+ (mutex (make-mutex)))
+ (lambda (item thunk)
+ "Run THUNK, which is supposed to bake ITEM, but make sure only one
+thread is baking ITEM at a given time."
+ (define selected?
+ (with-mutex mutex
+ (and (not (hash-ref baking item))
+ (begin
+ (hash-set! baking item (current-thread))
+ #t))))
+
+ (when selected?
+ (dynamic-wind
+ (const #t)
+ thunk
+ (lambda ()
+ (with-mutex mutex
+ (hash-remove! baking item))))))))
+
+(define-syntax-rule (single-baker item exp ...)
+ "Bake ITEM by evaluating EXP, but make sure there's only one baker for ITEM
+at a time."
+ (run-single-baker item (lambda () exp ...)))
+
+
+(define (narinfo-files cache)
+ "Return the list of .narinfo files under CACHE."
+ (if (file-is-directory? cache)
+ (find-files cache
+ (lambda (file stat)
+ (string-suffix? ".narinfo" file)))
+ '()))
+
+(define (nar-expiration-time ttl)
+ "Return the narinfo expiration time (in seconds since the Epoch). The
+expiration time is +inf.0 when passed an item that is still in the store; in
+other cases, it is the last-access time of the item plus TTL.
+
+This policy allows us to keep cached nars that correspond to valid store
+items. Failing that, we could eventually have to recompute them and return
+404 in the meantime."
+ (let ((expiration-time (file-expiration-time ttl)))
+ (lambda (file)
+ (let ((item (string-append (%store-prefix) "/"
+ (basename file ".narinfo"))))
+ ;; Note: We don't need to use 'valid-path?' here because FILE would
+ ;; not exist if ITEM were not valid in the first place.
+ (if (file-exists? item)
+ +inf.0
+ (expiration-time file))))))
+
+(define (hash-part->path* store hash cache)
+ "Like 'hash-part->path' but cached results under CACHE. This ensures we can
+still map HASH to the corresponding store file name, even if said store item
+vanished from the store in the meantime."
+ (let ((cached (hash-part-mapping-cache-file cache hash)))
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file cached read-string))
+ (lambda args
+ (if (= ENOENT (system-error-errno args))
+ (match (hash-part->path store hash)
+ ("" "")
+ (result
+ (mkdir-p (dirname cached))
+ (call-with-output-file (string-append cached ".tmp")
+ (lambda (port)
+ (display result port)))
+ (rename-file (string-append cached ".tmp") cached)
+ result))
+ (apply throw args))))))
+
+(define* (render-narinfo/cached store request hash
+ #:key ttl (compressions (list %no-compression))
+ (nar-path "nar")
+ cache pool)
+ "Respond to the narinfo request for REQUEST. If the narinfo is available in
+CACHE, then send it; otherwise, return 404 and \"bake\" that nar and narinfo
+requested using POOL."
+ (define (delete-entry narinfo)
+ ;; Delete NARINFO and the corresponding nar from CACHE.
+ (let* ((nar (string-append (string-drop-right narinfo
+ (string-length ".narinfo"))
+ ".nar"))
+ (base (basename narinfo ".narinfo"))
+ (hash (string-take base (string-index base #\-)))
+ (mapping (hash-part-mapping-cache-file cache hash)))
+ (delete-file* narinfo)
+ (delete-file* nar)
+ (delete-file* mapping)))
+
+ (let* ((item (hash-part->path* store hash cache))
+ (compressions (actual-compressions item compressions))
+ (cached (and (not (string-null? item))
+ (narinfo-cache-file cache item
+ #:compression
+ (first compressions)))))
+ (cond ((string-null? item)
+ (not-found request))
+ ((file-exists? cached)
+ ;; Narinfo is in cache, send it.
+ (values `((content-type . (application/x-nix-narinfo))
+ ,@(if ttl
+ `((cache-control (max-age . ,ttl)))
+ '()))
+ (lambda (port)
+ (display (call-with-input-file cached
+ read-string)
+ port))))
+ ((and (file-exists? item) ;cheaper than the 'valid-path?' RPC
+ (valid-path? store item))
+ ;; Nothing in cache: bake the narinfo and nar in the background and
+ ;; return 404.
+ (eventually pool
+ (single-baker item
+ ;; Check whether CACHED has been produced in the meantime.
+ (unless (file-exists? cached)
+ ;; (format #t "baking ~s~%" item)
+ (bake-narinfo+nar cache item
+ #:ttl ttl
+ #:compressions compressions
+ #:nar-path nar-path)))
+
+ (when ttl
+ (single-baker 'cache-cleanup
+ (maybe-remove-expired-cache-entries cache
+ narinfo-files
+ #:entry-expiration
+ (nar-expiration-time ttl)
+ #:delete-entry delete-entry
+ #:cleanup-period ttl))))
+ (not-found request
+ #:phrase "We're baking it"
+ #:ttl 300)) ;should be available within 5m
+ (else
+ (not-found request #:phrase "")))))
+
+(define (compress-nar cache item compression)
+ "Save in directory CACHE the nar for ITEM compressed with COMPRESSION."
+ (define nar
+ (nar-cache-file cache item #:compression compression))
+
+ (mkdir-p (dirname nar))
+ (match (compression-type compression)
+ ('gzip
+ ;; Note: the file port gets closed along with the gzip port.
+ (call-with-gzip-output-port (open-output-file (string-append nar ".tmp"))
+ (lambda (port)
+ (write-file item port))
+ #:level (compression-level compression)
+ #:buffer-size (* 128 1024))
+ (rename-file (string-append nar ".tmp") nar))
+ ('lzip
+ ;; Note: the file port gets closed along with the lzip port.
+ (call-with-lzip-output-port (open-output-file (string-append nar ".tmp"))
+ (lambda (port)
+ (write-file item port))
+ #:level (compression-level compression))
+ (rename-file (string-append nar ".tmp") nar))
+ ('none
+ ;; Cache nars even when compression is disabled so that we can
+ ;; guarantee the TTL (see <https://bugs.gnu.org/28664>.)
+ (with-atomic-file-output nar
+ (lambda (port)
+ (write-file item port))))))
+
+(define* (bake-narinfo+nar cache item
+ #:key ttl (compressions (list %no-compression))
+ (nar-path "/nar"))
+ "Write the narinfo and nar for ITEM to CACHE."
+ (define (compressed-nar-size compression)
+ (let* ((nar (nar-cache-file cache item #:compression compression))
+ (stat (stat nar #f)))
+ (and stat
+ (cons compression (stat:size stat)))))
+
+ (let ((compression (actual-compressions item compressions)))
+
+ (for-each (cut compress-nar cache item <>) compressions)
+
+ (match compressions
+ ((main others ...)
+ (let ((narinfo (narinfo-cache-file cache item
+ #:compression main)))
+ (with-atomic-file-output narinfo
+ (lambda (port)
+ ;; Open a new connection to the store. We cannot reuse the main
+ ;; thread's connection to the store since we would end up sending
+ ;; stuff concurrently on the same channel.
+ (with-store store
+ (let ((sizes (filter-map compressed-nar-size compression)))
+ (display (narinfo-string store item
+ (%private-key)
+ #:nar-path nar-path
+ #:compressions compressions
+ #:file-sizes sizes)
+ port)))))
+
+ ;; Make narinfo files for OTHERS hard links to NARINFO such that the
+ ;; atime-based cache eviction considers either all the nars or none
+ ;; of them as candidates.
+ (for-each (lambda (other)
+ (let ((other (narinfo-cache-file cache item
+ #:compression other)))
+ (link narinfo other)))
+ others))))))
+
+;; XXX: Declare the 'X-Nar-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"
+(declare-header! "X-Nar-Compression"
(lambda (str)
(match (call-with-input-string str read)
(('compression type level)
(if (valid-path? store store-path)
(values `((content-type . (application/x-nix-archive
(charset . "ISO-8859-1")))
- (guix-nar-compression . ,compression))
+ (x-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>.
store-path)
(not-found request))))
+(define* (render-nar/cached store cache request store-item
+ #:key ttl (compression %no-compression))
+ "Respond to REQUEST with a nar for STORE-ITEM. If the nar is in CACHE,
+return it; otherwise, return 404. When TTL is true, use it as the
+'Cache-Control' expiration time."
+ (let ((cached (nar-cache-file cache store-item
+ #:compression compression)))
+ (if (file-exists? cached)
+ (values `((content-type . (application/octet-stream
+ (charset . "ISO-8859-1")))
+ ,@(if ttl
+ `((cache-control (max-age . ,ttl)))
+ '())
+
+ ;; 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>.
+ (x-raw-file . ,cached))
+ #f)
+ (not-found request))))
+
(define (render-content-addressed-file store request
name algo hash)
"Return the content of the result of the fixed-output derivation NAME that
#:recursive? #f)))
(if (valid-path? store item)
(values `((content-type . (application/octet-stream
- (charset . "ISO-8859-1"))))
- ;; 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>.
- item)
+ (charset . "ISO-8859-1")))
+ ;; 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>.
+ (x-raw-file . ,item))
+ #f)
(not-found request)))
(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
+(define (render-log-file store request name)
+ "Render the log file for NAME, the base name of a store item. Don't attempt
+to compress or decompress the log file; just return it as-is."
+ (define (response-headers file)
+ ;; 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>.
+ (cond ((string-suffix? ".gz" file)
+ `((content-type . (text/plain (charset . "UTF-8")))
+ (content-encoding . (gzip))
+ (x-raw-file . ,file)))
+ ((string-suffix? ".bz2" file)
+ `((content-type . (application/x-bzip2
+ (charset . "ISO-8859-1")))
+ (x-raw-file . ,file)))
+ (else ;uncompressed
+ `((content-type . (text/plain (charset . "UTF-8")))
+ (x-raw-file . ,file)))))
+
+ (let ((log (log-file store
+ (string-append (%store-prefix) "/" name))))
+ (if log
+ (values (response-headers log) log)
+ (not-found request))))
+
+(define (render-home-page request)
+ "Render the home page."
+ (values `((content-type . (text/html (charset . "UTF-8"))))
+ (call-with-output-string
+ (lambda (port)
+ (sxml->xml '(html
+ (head (title "GNU Guix Substitute Server"))
+ (body
+ (h1 "GNU Guix Substitute Server")
+ (p "Hi, "
+ (a (@ (href
+ "https://gnu.org/s/guix/manual/html_node/Invoking-guix-publish.html"))
+ (tt "guix publish"))
+ " speaking. Welcome!")))
+ port)))))
+
+(define (extract-narinfo-hash 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)))))
+ (and (string-suffix? ".narinfo" str)
+ (let ((base (string-drop-right str 8)))
+ (and (string-every %nix-base32-charset base)
+ base))))
(define (get-request? request)
"Return #t if REQUEST uses the GET method."
(define %http-write
(@@ (web server http) http-write))
+(define (strip-headers response)
+ "Return RESPONSE's headers minus 'Content-Length' and our internal headers."
+ (fold alist-delete
+ (response-headers response)
+ '(content-length x-raw-file x-nar-compression)))
+
(define (sans-content-length response)
"Return RESPONSE without its 'content-length' header."
(set-field response (response-headers)
- (alist-delete 'content-length
- (response-headers response)
- eq?)))
+ (strip-headers response)))
(define (with-content-length response length)
"Return RESPONSE with a 'content-length' header set to LENGTH."
(set-field response (response-headers)
(alist-cons 'content-length length
- (alist-delete 'content-length
- (response-headers response)
- eq?))))
+ (strip-headers response))))
(define-syntax-rule (swallow-EPIPE exp ...)
"Swallow EPIPE errors raised by EXP..."
exp ...)
(const #f)))
-(define (nar-response-port response)
+(define (nar-response-port response compression)
"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)
+ (match 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> 'lzip level)
+ (make-lzip-output-port (response-port response)
+ #:level level))
(($ <compression> 'none)
(response-port response))
(#f
;; thread so that the main thread can keep working in the meantime.
(call-with-new-thread
(lambda ()
- (let* ((response (write-response (sans-content-length response)
- client))
- (port (begin
- (force-output client)
- (nar-response-port response))))
+ (set-thread-name "publish nar")
+ (let* ((compression (assoc-ref (response-headers response)
+ 'x-nar-compression))
+ (response (write-response (sans-content-length response)
+ client))
+ (port (begin
+ (force-output client)
+ (nar-response-port response compression))))
;; 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
(swallow-zlib-error
(close-port port))
(values)))))
- (('application/octet-stream . _)
- ;; Send a raw file in a separate thread.
- (call-with-new-thread
- (lambda ()
- (catch 'system-error
- (lambda ()
- (call-with-input-file (utf8->string body)
- (lambda (input)
- (let* ((size (stat:size (stat input)))
- (response (write-response (with-content-length response
- size)
- client))
- (output (response-port response)))
- (dump-port input output)
- (close-port output)
- (values)))))
- (lambda args
- ;; If the file was GC'd behind our back, that's fine. Likewise if
- ;; the client closes the connection.
- (unless (memv (system-error-errno args)
- (list ENOENT EPIPE ECONNRESET))
- (apply throw args))
- (values))))))
(_
- ;; Handle other responses sequentially.
- (%http-write server client response body))))
+ (match (assoc-ref (response-headers response) 'x-raw-file)
+ ((? string? file)
+ ;; Send a raw file in a separate thread.
+ (call-with-new-thread
+ (lambda ()
+ (set-thread-name "publish file")
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file file
+ (lambda (input)
+ (let* ((size (stat:size (stat input)))
+ (response (write-response (with-content-length response
+ size)
+ client))
+ (output (response-port response)))
+ (if (file-port? output)
+ (sendfile output input size)
+ (dump-port input output))
+ (close-port output)
+ (values)))))
+ (lambda args
+ ;; If the file was GC'd behind our back, that's fine. Likewise if
+ ;; the client closes the connection.
+ (unless (memv (system-error-errno args)
+ (list ENOENT EPIPE ECONNRESET))
+ (apply throw args))
+ (values))))))
+ (#f
+ ;; Handle other responses sequentially.
+ (%http-write server client response body))))))
(define-server-impl concurrent-http-server
;; A variant of Guile's built-in HTTP server that offloads possibly long
http-write
(@@ (web server http) http-close))
+(define (string->compression-type string)
+ "Return a symbol denoting the compression method expressed by STRING; return
+#f if STRING doesn't match any supported method."
+ (match string
+ ("gzip" (and (zlib-available?) 'gzip))
+ ("lzip" (and (lzlib-available?) 'lzip))
+ (_ #f)))
+
+(define (effective-compression requested-type compressions)
+ "Given the REQUESTED-TYPE for compression and the set of chosen COMPRESSION
+methods, return the applicable compression."
+ (or (find (match-lambda
+ (($ <compression> type)
+ (and (eq? type requested-type)
+ compression)))
+ compressions)
+ (default-compression requested-type)))
+
(define* (make-request-handler store
#:key
+ cache pool
narinfo-ttl
- (compression %no-compression))
+ (nar-path "nar")
+ (compressions (list %no-compression)))
+ (define compression-type?
+ string->compression-type)
+
+ (define nar-path?
+ (let ((expected (split-and-decode-uri-path nar-path)))
+ (cut equal? expected <>)))
+
(lambda (request body)
(format #t "~a ~a~%"
(request-method request)
;; /nix-cache-info
(("nix-cache-info")
(render-nix-cache-info))
+ ;; /
+ ((or () ("index.html"))
+ (render-home-page request))
;; /<hash>.narinfo
(((= 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
- #:compression compression))
+ (if cache
+ (render-narinfo/cached store request hash
+ #:cache cache
+ #:pool pool
+ #:ttl narinfo-ttl
+ #:nar-path nar-path
+ #:compressions compressions)
+ (render-narinfo store request hash
+ #:ttl narinfo-ttl
+ #:nar-path nar-path
+ #:compressions compressions)))
+ ;; /nar/file/NAME/sha256/HASH
+ (("file" name "sha256" hash)
+ (guard (c ((invalid-base32-character? c)
+ (not-found request)))
+ (let ((hash (nix-base32-string->bytevector hash)))
+ (render-content-addressed-file store request
+ name 'sha256 hash))))
+
+ ;; /log/OUTPUT
+ (("log" name)
+ (render-log-file store request name))
;; 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
- #: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)))
+ ((components ... (? compression-type? type) store-item)
+ (if (nar-path? components)
+ (let* ((compression-type (string->compression-type type))
+ (compression (effective-compression compression-type
+ compressions)))
+ (if cache
+ (render-nar/cached store cache request store-item
+ #:ttl narinfo-ttl
+ #:compression compression)
+ (render-nar store request store-item
+ #:compression compression)))
(not-found request)))
- ;; /nar/file/NAME/sha256/HASH
- (("file" name "sha256" hash)
- (guard (c ((invalid-base32-character? c)
- (not-found request)))
- (let ((hash (nix-base32-string->bytevector hash)))
- (render-content-addressed-file store request
- name 'sha256 hash))))
- (_ (not-found request)))
+ ;; /nar/<store-item>
+ ((components ... store-item)
+ (if (nar-path? components)
+ (if cache
+ (render-nar/cached store cache request store-item
+ #:ttl narinfo-ttl
+ #:compression %no-compression)
+ (render-nar store request store-item
+ #:compression %no-compression))
+ (not-found request)))
+
+ (x (not-found request)))
(not-found request))))
(define* (run-publish-server socket store
- #:key (compression %no-compression) narinfo-ttl)
+ #:key
+ (compressions (list %no-compression))
+ (nar-path "nar") narinfo-ttl
+ cache pool)
(run-server (make-request-handler store
+ #:cache cache
+ #:pool pool
+ #:nar-path nar-path
#:narinfo-ttl narinfo-ttl
- #:compression compression)
+ #:compressions compressions)
concurrent-http-server
`(#:socket ,socket)))
(setgid (passwd:gid user))
(setuid (passwd:uid user))))
(lambda (key proc message args . rest)
- (leave (_ "user '~a' not found: ~a~%")
+ (leave (G_ "user '~a' not found: ~a~%")
user (apply format #f message args)))))
\f
(with-error-handling
(let* ((opts (args-fold* args %options
(lambda (opt name arg result)
- (leave (_ "~A: unrecognized option~%") name))
+ (leave (G_ "~A: unrecognized option~%") name))
(lambda (arg result)
- (leave (_ "~A: extraneous argument~%") arg))
+ (leave (G_ "~A: extraneous argument~%") arg))
%default-options))
(user (assoc-ref opts 'user))
(port (assoc-ref opts 'port))
(ttl (assoc-ref opts 'narinfo-ttl))
- (compression (assoc-ref opts 'compression))
+ (compressions (match (filter-map (match-lambda
+ (('compression . compression)
+ compression)
+ (_ #f))
+ opts)
+ (()
+ ;; Default to fast & low compression.
+ (list (if (zlib-available?)
+ %default-gzip-compression
+ %no-compression)))
+ (lst (reverse lst))))
(address (let ((addr (assoc-ref opts 'address)))
(make-socket-address (sockaddr:fam addr)
(sockaddr:addr addr)
port)))
(socket (open-server-socket address))
- (repl-port (assoc-ref opts 'repl)))
- ;; Read the key right away so that (1) we fail early on if we can't
- ;; access them, and (2) we can then drop privileges.
- (force %private-key)
- (force %public-key)
+ (nar-path (assoc-ref opts 'nar-path))
+ (repl-port (assoc-ref opts 'repl))
+ (cache (assoc-ref opts 'cache))
+ (workers (assoc-ref opts 'workers))
+
+ ;; Read the key right away so that (1) we fail early on if we can't
+ ;; access them, and (2) we can then drop privileges.
+ (public-key (read-file-sexp (assoc-ref opts 'public-key-file)))
+ (private-key (read-file-sexp (assoc-ref opts 'private-key-file))))
(when user
;; Now that we've read the key material and opened the socket, we can
(gather-user-privileges user))
(when (zero? (getuid))
- (warning (_ "server running as root; \
+ (warning (G_ "server running as root; \
consider using the '--user' option!~%")))
- (format #t (_ "publishing ~a on ~a, port ~d~%")
+
+ (parameterize ((%public-key public-key)
+ (%private-key private-key))
+ (info (G_ "publishing ~a on ~a, port ~d~%")
%store-directory
(inet-ntop (sockaddr:fam address) (sockaddr:addr address))
(sockaddr:port address))
- (when repl-port
- (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
- (with-store store
- (run-publish-server socket store
- #:compression compression
- #:narinfo-ttl ttl)))))
+
+ (for-each (lambda (compression)
+ (info (G_ "using '~a' compression method, level ~a~%")
+ (compression-type compression)
+ (compression-level compression)))
+ compressions)
+
+ (when repl-port
+ (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
+
+ ;; Set the name of the main thread.
+ (set-thread-name "guix publish")
+
+ (with-store store
+ (run-publish-server socket store
+ #:cache cache
+ #:pool (and cache (make-pool workers
+ #:thread-name
+ "publish worker"))
+ #:nar-path nar-path
+ #:compressions compressions
+ #:narinfo-ttl ttl))))))
+
+;;; Local Variables:
+;;; eval: (put 'single-baker 'scheme-indent-function 1)
+;;; End:
HCoop / jackhill / guix / guix.git / blobdiff