mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
publish: Make the nar URL prefix a parameter.
* guix/scripts/publish.scm (narinfo-string): Add #:nar-path and honor it.
(render-narinfo): Likewise.
(make-request-handler): Likewise.
(run-publish-server): Likewise.
* tests/publish.scm ("custom nar path"): New test.
This commit is contained in:
Ludovic Courtès
parent
46f58390cb
commit
cdd7a7d210
2 changed files with 64 additions and 20 deletions
|
|
@ -204,16 +204,17 @@ (define base64-encode-string
|
|||
(compose base64-encode string->utf8))
|
||||
|
||||
(define* (narinfo-string store store-path key
|
||||
#:key (compression %no-compression))
|
||||
#:key (compression %no-compression)
|
||||
(nar-path "nar"))
|
||||
"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."
|
||||
(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"
|
||||
`(,@(split-and-decode-uri-path nar-path)
|
||||
,@(match compression
|
||||
(($ <compression> 'none)
|
||||
'())
|
||||
|
|
@ -275,11 +276,12 @@ (define (render-nix-cache-info)
|
|||
%nix-cache-info))))
|
||||
|
||||
(define* (render-narinfo store request hash
|
||||
#:key ttl (compression %no-compression))
|
||||
#:key ttl (compression %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)
|
||||
|
|
@ -289,6 +291,7 @@ (define* (render-narinfo store request hash
|
|||
'()))
|
||||
(cut display
|
||||
(narinfo-string store store-path (%private-key)
|
||||
#:nar-path nar-path
|
||||
#:compression compression)
|
||||
<>)))))
|
||||
|
||||
|
|
@ -478,7 +481,12 @@ (define-server-impl concurrent-http-server
|
|||
(define* (make-request-handler store
|
||||
#:key
|
||||
narinfo-ttl
|
||||
(nar-path "nar")
|
||||
(compression %no-compression))
|
||||
(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)
|
||||
|
|
@ -494,19 +502,23 @@ (define* (make-request-handler store
|
|||
;; NARINFO-TTL.
|
||||
(render-narinfo store request hash
|
||||
#:ttl narinfo-ttl
|
||||
#:nar-path nar-path
|
||||
#:compression compression))
|
||||
;; /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))))
|
||||
|
||||
;; 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?)
|
||||
((components ... "gzip" store-item)
|
||||
(if (and (nar-path? components) (zlib-available?))
|
||||
(render-nar store request store-item
|
||||
#:compression
|
||||
(match compression
|
||||
|
|
@ -516,19 +528,21 @@ (define* (make-request-handler store
|
|||
%default-gzip-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)
|
||||
(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 (compression %no-compression)
|
||||
(nar-path "nar") narinfo-ttl)
|
||||
(run-server (make-request-handler store
|
||||
#:nar-path nar-path
|
||||
#:narinfo-ttl narinfo-ttl
|
||||
#:compression compression)
|
||||
concurrent-http-server
|
||||
|
|
|
|||
|
|
@ -232,6 +232,36 @@ (define (wait-until-ready port)
|
|||
(list (assoc-ref info "Compression")
|
||||
(dirname (assoc-ref info "URL")))))
|
||||
|
||||
(test-equal "custom nar path"
|
||||
;; Serve nars at /foo/bar/chbouib instead of /nar.
|
||||
(list `(("StorePath" . ,%item)
|
||||
("URL" . ,(string-append "foo/bar/chbouib/" (basename %item)))
|
||||
("Compression" . "none"))
|
||||
200
|
||||
404)
|
||||
(let ((thread (with-separate-output-ports
|
||||
(call-with-new-thread
|
||||
(lambda ()
|
||||
(guix-publish "--port=6798" "-C0"
|
||||
"--nar-path=///foo/bar//chbouib/"))))))
|
||||
(wait-until-ready 6798)
|
||||
(let* ((base "http://localhost:6798/")
|
||||
(part (store-path-hash-part %item))
|
||||
(url (string-append base part ".narinfo"))
|
||||
(nar-url (string-append base "foo/bar/chbouib/"
|
||||
(basename %item)))
|
||||
(body (http-get-port url)))
|
||||
(list (filter (lambda (item)
|
||||
(match item
|
||||
(("Compression" . _) #t)
|
||||
(("StorePath" . _) #t)
|
||||
(("URL" . _) #t)
|
||||
(_ #f)))
|
||||
(recutils->alist body))
|
||||
(response-code (http-get nar-url))
|
||||
(response-code
|
||||
(http-get (string-append base "nar/" (basename %item))))))))
|
||||
|
||||
(test-equal "/nar/ with properly encoded '+' sign"
|
||||
"Congrats!"
|
||||
(let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
|
||||
|
|
|
|||
Loading…
Reference in a new issue