diff options
Diffstat (limited to 'guix-data-service/web/nar/controller.scm')
| -rw-r--r-- | guix-data-service/web/nar/controller.scm | 110 |
1 files changed, 109 insertions, 1 deletions
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))) |