guix
/
data-service
mirror of git://git.savannah.gnu.org/guix/data-service.git
2
0
Fork 0
Code Issues Releases Wiki Activity

Serve narinfo files for derivations

This commit is contained in:
Christopher Baines 2019-12-25 23:09:59 +00:00
parent 120af42c24
commit 66e886a6b4
3 changed files with 150 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
guix-data-service/web/controller.scm
View File

@ -322,11 +322,11 @@
(render-narinfos conn filename))
(((or 'GET 'POST) "build-server" _ ...)
(delegate-to-with-secret-key-base build-server-controller))
(('GET "nar" _ ...) (delegate-to nar-controller))
(('GET "compare" _ ...) (delegate-to compare-controller))
(('GET "compare-by-datetime" _ ...) (delegate-to compare-controller))
(('GET "jobs") (delegate-to jobs-controller))
(('GET "jobs" "queue") (delegate-to jobs-controller))
(('GET "job" job-id) (delegate-to jobs-controller))
(('GET _ ...) (delegate-to nar-controller))
((method path ...)
(not-found (request-uri request)))))

110
guix-data-service/web/nar/controller.scm
View File

@ -16,28 +16,95 @@
;;; <http://www.gnu.org/licenses/>.
(define-module (guix-data-service web nar controller)
#:use-module (srfi srfi-1)
#:use-module (ice-9 iconv)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 binary-ports)
#:use-module (rnrs bytevectors)
#:use-module (gcrypt hash)
#:use-module (gcrypt pk-crypto)
#:use-module (web uri)
#:use-module (web request)
#:use-module (web response)
#:use-module (guix pki)
#:use-module (guix base32)
#:use-module (guix base64)
#:use-module (guix serialization)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service model derivation)
#:export (nar-controller))
#:export (nar-controller
%narinfo-signing-private-key
%narinfo-signing-public-key))
(define %narinfo-signing-private-key
(make-parameter #f))
(define %narinfo-signing-public-key
(make-parameter #f))
(define (nar-controller request
method-and-path-components
mime-types
body
conn)
(define (.narinfo-suffix s)
(string-suffix? ".narinfo" s))
(match method-and-path-components
(('GET "nar" derivation)
(render-nar request
mime-types
conn
(string-append "/gnu/store/" derivation)))
(('GET (? .narinfo-suffix path))
(let* ((hash (string-drop-right
path
(string-length ".narinfo")))
(derivation (select-derivation-by-file-name-hash
conn
hash)))
(if derivation
(list (build-response
#:code 200
#:headers '((content-type . (application/x-narinfo))))
(let* ((derivation-file-name
(second derivation))
(derivation-text
(select-serialized-derivation-by-file-name
conn
derivation-file-name))
(derivation-bytevector
(string->bytevector derivation-text
"ISO-8859-1"))
(derivation-references
(select-derivation-references-by-derivation-id
conn
(first derivation)))
(nar-bytevector
(call-with-values
(lambda ()
(open-bytevector-output-port))
(lambda (port get-bytevector)
(write-file-tree
derivation-file-name
port
#:file-type+size
(lambda (file)
(values 'regular
(bytevector-length derivation-bytevector)))
#:file-port
(lambda (file)
(open-bytevector-input-port derivation-bytevector)))
(get-bytevector)))))
(lambda (port)
(display (narinfo-string derivation-file-name
nar-bytevector
derivation-references)
port))))
(not-found (request-uri request)))))
(_ #f)))
(define (render-nar request
@ -68,3 +135,44 @@
(lambda (file)
(open-bytevector-input-port derivation-bytevector))))))
(not-found (request-uri request)))))
(define* (narinfo-string store-item
nar-bytevector
references
#:key
(nar-path "nar"))
(define (signed-string s)
(let* ((public-key (%narinfo-signing-public-key))
(hash (bytevector->hash-data (sha256 (string->utf8 s))
#:key-type (key-type public-key))))
(signature-sexp hash (%narinfo-signing-private-key) public-key)))
(let* ((hash (bytevector->nix-base32-string
(sha256 nar-bytevector)))
(size (bytevector-length nar-bytevector))
(references (string-join
(map basename references)
" "))
(info (format #f
"\
StorePath: ~a
URL: ~a
Compression: none
NarHash: sha256:~a
NarSize: ~d
References: ~a~%"
store-item
(encode-and-join-uri-path
(list nar-path
(basename store-item)))
hash
size
references)))
(if (%narinfo-signing-private-key)
(format #f "~aSignature: 1;~a;~a~%"
info
(gethostname)
(base64-encode
(string->utf8
(canonical-sexp->string (signed-string info)))))
info)))

48
scripts/guix-data-service.in
View File

@ -27,8 +27,11 @@
(srfi srfi-37)
(ice-9 textual-ports)
(system repl server)
(gcrypt pk-crypto)
(guix pki)
(guix-data-service config)
(guix-data-service web server))
(guix-data-service web server)
(guix-data-service web nar controller))
(define %default-repl-server-port
;; Default port to run REPL server on, if --listen-repl is provided
@ -56,6 +59,12 @@
(string-trim-right
(call-with-input-file arg get-string-all))
result)))
(option '("narinfo-signing-public-key") #t #f
(lambda (opt name arg result)
(alist-cons 'narinfo-signing-public-key-file arg result)))
(option '("narinfo-signing-private-key") #t #f
(lambda (opt name arg result)
(alist-cons 'narinfo-signing-private-key-file arg result)))
(option '("update-database") #f #f
(lambda (opt name _ result)
(alist-cons 'update-database #t result)))
@ -73,10 +82,12 @@
(define %default-options
;; Alist of default option values
`((listen-repl . #f)
(update-database . #f)
(port . 8765)
(host . "0.0.0.0")))
`((listen-repl . #f)
(narinfo-signing-public-key . ,%public-key-file)
(narinfo-signing-private-key . ,%private-key-file)
(update-database . #f)
(port . 8765)
(host . "0.0.0.0")))
(define (parse-options args)
(args-fold
@ -129,6 +140,27 @@
(simple-format #t "starting the server on port ~A\n"
(assq-ref opts 'port))
(start-guix-data-service-web-server (assq-ref opts 'port)
(assq-ref opts 'host)
(assq-ref opts 'secret-key-base)))
(parameterize ((%narinfo-signing-public-key
(and=> (assoc-ref opts 'narinfo-signing-public-key)
read-file-sexp))
(%narinfo-signing-private-key
(catch
'system-error
(lambda ()
(and=> (assoc-ref opts 'narinfo-signing-private-key)
read-file-sexp))
(lambda (key . args)
(simple-format
(current-error-port)
"warning: failed to load narinfo signing private key from ~A\n"
(assoc-ref opts 'narinfo-signing-private-key))
(simple-format (current-error-port)
" ~A: ~A\n"
key args)
(display "warning: not signing narinfo files\n"
(current-error-port))
#f))))
(start-guix-data-service-web-server (assq-ref opts 'port)
(assq-ref opts 'host)
(assq-ref opts 'secret-key-base))))