diff options
| -rw-r--r-- | nar-herder/server.scm | 127 |
1 files changed, 127 insertions, 0 deletions
diff --git a/nar-herder/server.scm b/nar-herder/server.scm index 68e3219..4743627 100644 --- a/nar-herder/server.scm +++ b/nar-herder/server.scm @@ -18,15 +18,33 @@ (define-module (nar-herder server) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-34) #:use-module (ice-9 match) + #:use-module (ice-9 binary-ports) + #:use-module (rnrs bytevectors) #:use-module (web uri) #:use-module (web response) #:use-module (web request) #:use-module (logging logger) #:use-module (prometheus) #:use-module (json) + #:use-module ((system foreign) + #:select (bytevector->pointer pointer->bytevector)) + #:use-module (guix store) + #:use-module (guix base32) + #:use-module (guix serialization) + #:use-module ((guix utils) + #:select (decompressed-port)) + #:use-module ((guix build utils) + #:select (dump-port)) #:use-module (nar-herder database) #:use-module (nar-herder storage) + + + #:use-module (ice-9 textual-ports) + + #:export (make-request-handler)) (define* (render-json json #:key (extra-headers '()) @@ -73,6 +91,66 @@ (metric-set metric value)))) metrics)))) +(define (serve-fixed-output-file input compression proc) + ;; TODO It's hard with fold-archive from (guix serialization) to + ;; read just the singular file from the archive, so the following + ;; procedures allow to just read the parts prior to the file, which + ;; includes the file length + + (define (sub-bytevector bv len) + (define max (bytevector-length bv)) + (cond ((= len max) bv) + ((< len max) + ;; Yes, this is safe because the result of each conversion procedure + ;; has its life cycle synchronized with that of its argument. + (pointer->bytevector (bytevector->pointer bv) len)) + (else + (error "sub-bytevector called to get a super bytevector")))) + + (define (read-long-long p) + (let ((b (get-bytevector-n p 8))) + (bytevector-u64-ref b 0 (endianness little)))) + + (define (read-int p) + (let ((b (get-bytevector-n p 8))) + (bytevector-u32-ref b 0 (endianness little)))) + + (define (read-byte-string p) + (let* ((len (read-int p)) + (m (modulo len 8)) + (pad (if (zero? m) 0 (- 8 m))) + (bv (get-bytevector-n p (+ len pad)))) + (sub-bytevector bv len))) + + (define (read-string p) + (utf8->string (read-byte-string p))) + + (let*-values (((port pids) + (decompressed-port + (string->symbol compression) + input))) + + ;; The decompressor can be an external program, so wait for it to + ;; exit + (every (compose zero? cdr waitpid) pids) + + (match (list + (read-string port) + (read-string port) + (read-string port) + (read-string port) + + (match (read-string port) + ("contents" 'regular) + ("executable" + (match (list (read-string port) (read-string port)) + (("" "contents") 'executable)))) + + (read-long-long port)) + (("nix-archive-1" "(" "type" "regular" type size) + + (proc port size))))) + (define* (make-request-handler database storage-root #:key ttl negative-ttl logger metrics-registry) @@ -178,6 +256,55 @@ #f) (values (build-response #:code 404) "404")))) + (('GET "file" name algo hash) + (guard (c ((invalid-base32-character? c) + (values (build-response #:code 404) + "404"))) + (let ((hash-bytevector (nix-base32-string->bytevector hash))) + (if (and (string=? algo "sha256") (= 32 (bytevector-length + hash-bytevector))) + (let* ((store-path + (fixed-output-path name hash-bytevector + #:hash-algo + (string->symbol algo) + #:recursive? #f)) + (store-path-hash + (store-path-hash-part store-path)) + (narinfo-files + (database-select-narinfo-files + database + store-path-hash)) + (selected-narinfo-file + ;; TODO Select intelligently + (first narinfo-files))) + + (if selected-narinfo-file + (let* ((url + (assq-ref selected-narinfo-file 'url)) + (filename + (string-append storage-root + (uri-decode url)))) + + (serve-fixed-output-file + (open-input-file filename) + (assq-ref selected-narinfo-file + 'compression) + (lambda (nar-port bytes) + (values `((content-type . (application/octet-stream + (charset . "ISO-8859-1"))) + (content-length . ,bytes)) + (lambda (output-port) + (dump-port nar-port + output-port + bytes) + + (close-port output-port)))))) + + (values (build-response #:code 404) + "404"))) + (values (build-response #:code 404) + "404"))))) + (('GET "recent-changes") (let ((query-parameters (or (and=> (uri-query (request-uri request)) |