1 files changed, 83 insertions, 0 deletions
diff --git a/guix/web/render.scm b/guix/web/render.scm
new file mode 100644
index 0000000..9a91c73
--- /dev/null
+++ b/guix/web/render.scm
@@ -0,0 +1,83 @@
+;;; guix-web - Web interface for GNU Guix
+;;; Copyright © 2014  David Thompson <davet@gnu.org>
+;;;
+;;; 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 web render)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (guix web sxml)
+  #:use-module (json)
+  #:use-module (guix web config)
+  #:use-module (guix web util)
+  #:export (render-static-asset
+            render-html
+            render-json
+            not-found
+            unprocessable-entity
+            created
+            redirect))
+
+(define file-mime-types
+  '(("css" . (text/css))
+    ("js" . (text/javascript))
+    ("png" . (image/png))))
+
+(define (render-static-asset path)
+  (let ((file-name (string-join (cons* guix-web-asset-dir path) "/")))
+    (if (and (file-exists? file-name)
+             (not (directory? file-name)))
+        (list `((content-type . ,(assoc-ref file-mime-types
+                                            (file-extension file-name))))
+              (call-with-input-file file-name get-bytevector-all))
+        (not-found (build-uri 'http
+                              #:host guix-web-host
+                              #:port guix-web-port
+                              #:path (string-join path "/" 'prefix))))))
+
+(define (render-html sxml)
+  (list '((content-type . (text/html)))
+        (lambda (port)
+          (sxml->html sxml port))))
+
+(define (render-json json)
+  (list '((content-type . (application/json)))
+        (lambda (port)
+          (scm->json json port))))
+
+(define (not-found uri)
+  (list (build-response #:code 404)
+        (string-append "Resource not found: " (uri->string uri))))
+
+(define (unprocessable-entity)
+  (list (build-response #:code 422)
+        ""))
+
+(define (created)
+  (list (build-response #:code 201)
+        ""))
+
+(define (redirect path)
+  (let ((uri (build-uri 'http
+                        #:host "192.168.1.157" ;;guix-web-host
+                        #:port guix-web-port
+                        #:path (string-append
+                                "/" (encode-and-join-uri-path path)))))
+    (list (build-response
+           #:code 301
+           #:headers `((content-type . (text/html))
+                       (location . ,uri)))
+          (format #f "Redirect to ~a" (uri->string uri)))))