Render nar files for derivations

In the same manor that Guix publish does. This is working towards being able
to serve substitutes for derivations.

3 files changed, 73 insertions, 0 deletions

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 <mail@cbaines.net>
+;;;
+;;; 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
+;;; <http://www.gnu.org/licenses/>.
+
+(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)))))