diff options
Diffstat (limited to 'scripts')
| -rwxr-xr-x | scripts/guix-web | 265 |
1 files changed, 265 insertions, 0 deletions
diff --git a/scripts/guix-web b/scripts/guix-web new file mode 100755 index 0000000..e28ce1e --- /dev/null +++ b/scripts/guix-web @@ -0,0 +1,265 @@ +#!/usr/bin/guile +!# + +;;; 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/>. + +(use-modules (ice-9 rdelim) + (ice-9 match) + (ice-9 binary-ports) + (srfi srfi-1) + (srfi srfi-26) + ((system repl server) + #:select (spawn-server make-tcp-server-socket)) + (web http) + (web request) + (web response) + (web server) + (web uri) + (guix packages) + (guix licenses) + (gnu packages) + (sxml simple) + (json)) + +;;; +;;; Framework +;;; + +(define (file-extension file-name) + (last (string-split file-name #\.))) + +(define (directory? filename) + (string=? filename (dirname filename))) + +(define asset-dir ".") + +(define file-mime-types + '(("css" . (text/css)) + ("js" . (text/javascript)) + ("png" . (image/png)))) + +(define (serve-static-asset request) + (let ((filename (string-join + (cons asset-dir (request-path-components request)) + "/"))) + (and (file-exists? filename) + (not (directory? filename)) + (list `((content-type . ,(assoc-ref file-mime-types + (file-extension filename)))) + (call-with-input-file filename get-bytevector-all))))) + +(define (render-html sxml) + (list '((content-type . (text/html))) + (lambda (port) + (display "<!DOCTYPE html>" port) + (sxml->xml sxml port)))) + +(define (render-json json) + (list '((content-type . (application/json))) + (lambda (port) + (scm->json json port)))) + +(define (request-path-components request) + (split-and-decode-uri-path (uri-path (request-uri request)))) + +(define (not-found request) + (list (build-response #:code 404) + (string-append "Resource not found: " + (uri->string (request-uri request))))) + +(define (redirect path) + (let ((uri (build-uri 'http + #: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))))) + +(define (handler request body) + (format #t "~a ~a\n" + (request-method request) + (uri-path (request-uri request))) + (apply values + (or (run-route request) + (serve-static-asset request) + (not-found request)))) + +;;; +;;; JavaScript +;;; + +(define (script-tag src) + `(script (@ (type "text/javascript") + (src ,src)) + ;; hack to ensure closing </script> tag + "")) + +;;; +;;; Application +;;; + +(define javascripts + '("/js/underscore.js" + "/js/mithril.js" + "/js/guix-packages.js")) + +(define (run-route request) + (match (cons (request-method request) + (request-path-components request)) + ((GET) + (redirect '("packages"))) + ((GET "packages") + (render-html (all-packages))) + ((GET "packages.json") + (render-json (all-packages-json))) + ((GET "package" name) + (render-html (view-package name))) + ((GET "librejs") + (render-html (librejs))) + (_ #f))) + +(define (all-packages-json) + (define (serialize-license package) + (define (serialize license) + (json + (object + ("name" ,(license-name license)) + ("uri" ,(license-uri license))))) + (let ((license (package-license package))) + (cond + ((list? license) + (map serialize license)) + ((license? license) + (serialize license)) + (else #f)))) + + (json + ,(map (lambda (p) + (json + (object + ("name" ,(package-name p)) + ("version" ,(package-version p)) + ("synopsis" ,(package-synopsis p)) + ("description" ,(package-description p)) + ("homepage" ,(package-home-page p)) + ("license" ,(serialize-license p))))) + (fold-packages cons '())))) + +(define (main-layout subtitle body) + `(html + (head + (title ,(string-append "GNU Guix - " subtitle)) + (link (@ (rel "stylesheet") + (href "/css/bootstrap.css")))) + (body + (div (@ (class "container")) + (image (@ (src "/images/logo.png"))) + ,@body + (footer + (small + (a (@ (href "/librejs") + (rel "jslicense")) + "JavaScript license information"))))))) + +(define (render-package-license package) + (define (license-link license) + `(a (@ (href ,(license-uri license))) + ,(license-name license))) + + (let ((license (package-license package))) + (cond ((list? license) + `(ul (@ (class "list-inline")) + ,@(map (lambda (l) + `(li ,(license-link l))) + license))) + ((license? license) + (license-link license)) + (else "")))) + +(define (all-packages) + (main-layout + "Packages" + `((div (@ (id "guix")) "") + ,@(map script-tag javascripts)))) + +(define (view-package name) + (define (describe-package package) + `(dl + (dt "Version") + (dd ,(package-version package)) + (dt "Synopsis") + (dd ,(package-synopsis package)) + (dt "Description") + (dd ,(package-description package)) + (dt "License") + (dd ,(render-package-license package)))) + + (let ((packages (find-packages-by-name name))) + (define (format-package-count) + (let ((count (length packages))) + (format #f "~d ~a" + count + (if (> count 1) + "versions" + "version")))) + + (main-layout + name + `((h1 ,name (span (@ (class "badge")) + ,(format-package-count))) + (ul (@ (class "list-unstyled")) + ,@(map (lambda (p) + `(li ,(describe-package p))) + packages)))))) + +(define (librejs) + (define (weblabel js) + `(tr + (td + (a (@ (href ,js)) + ,(basename js))) + (td + (a (@ (href "http://www.gnu.org/licenses/agpl-3.0.html")) + ,(license-name agpl3+))) + (td + (a (@ (href ,js)) + ,(basename js))))) + + (main-layout + "LibreJS" + `((h1 "JavaScript License Information") + (table (@ (id "jslicense-labels1") + (class "table")) + (thead + (tr + (th "URI") + (th "License") + (th "Source Code"))) + (tbody ,@(map weblabel javascripts)))))) + +(spawn-server (make-tcp-server-socket #:port 37146)) +(run-server (lambda args (apply handler args)) + 'http + `(#:addr ,INADDR_ANY + #:port 8080)) + +;;; Local Variables: +;;; mode: scheme +;;; End: |