diff --git a/Makefile.am b/Makefile.am index cded23a..0900e31 100644 --- a/Makefile.am +++ b/Makefile.am @@ -104,6 +104,7 @@ SOURCES = \ guix-data-service/web/build-server/html.scm \ guix-data-service/web/jobs/controller.scm \ guix-data-service/web/jobs/html.scm \ + guix-data-service/web/nar/controller.scm \ guix-data-service/web/query-parameters.scm \ guix-data-service/web/render.scm \ guix-data-service/web/repository/controller.scm \ diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 3f35304..b8d5d6b 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -55,6 +55,7 @@ #:use-module (guix-data-service web util) #:use-module (guix-data-service web build controller) #:use-module (guix-data-service web revision controller) + #:use-module (guix-data-service web nar controller) #:use-module (guix-data-service web jobs controller) #:use-module (guix-data-service web view html) #:use-module (guix-data-service web build-server controller) @@ -321,6 +322,7 @@ (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)) diff --git a/guix-data-service/web/nar/controller.scm b/guix-data-service/web/nar/controller.scm new file mode 100644 index 0000000..bdc8ec7 --- /dev/null +++ b/guix-data-service/web/nar/controller.scm @@ -0,0 +1,70 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2019 Christopher Baines +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU Affero General Public License +;;; as published by the Free Software Foundation, either version 3 of +;;; the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with this program. If not, see +;;; . + +(define-module (guix-data-service web nar controller) + #:use-module (ice-9 iconv) + #:use-module (ice-9 match) + #:use-module (ice-9 binary-ports) + #:use-module (rnrs bytevectors) + #:use-module (web request) + #:use-module (web response) + #:use-module (guix serialization) + #:use-module (guix-data-service web render) + #:use-module (guix-data-service model derivation) + #:export (nar-controller)) + +(define (nar-controller request + method-and-path-components + mime-types + body + conn) + (match method-and-path-components + (('GET "nar" derivation) + (render-nar request + mime-types + conn + (string-append "/gnu/store/" derivation))) + (_ #f))) + +(define (render-nar request + mime-types + conn + derivation-file-name) + (let ((derivation-text + (select-serialized-derivation-by-file-name + conn + derivation-file-name))) + (if derivation-text + (let ((derivation-bytevector + (string->bytevector derivation-text + "ISO-8859-1"))) + (list (build-response + #:code 200 + #:headers '((content-type . (application/x-nix-archive + (charset . "ISO-8859-1"))))) + (lambda (port) + (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)))))) + (not-found (request-uri request)))))