diff options
| -rw-r--r-- | guix-data-service/web/controller.scm | 2 | ||||
| -rw-r--r-- | guix-data-service/web/nar/controller.scm | 110 | ||||
| -rw-r--r-- | scripts/guix-data-service.in | 48 |
3 files changed, 150 insertions, 10 deletions
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index b8d5d6b..f2a6385 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -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))))) diff --git a/guix-data-service/web/nar/controller.scm b/guix-data-service/web/nar/controller.scm index bdc8ec7..783fd12 100644 --- a/guix-data-service/web/nar/controller.scm +++ b/guix-data-service/web/nar/controller.scm @@ -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))) diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in index d91b659..efa6425 100644 --- a/scripts/guix-data-service.in +++ b/scripts/guix-data-service.in @@ -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)))) |