diff options
| -rw-r--r-- | guix-web/config.scm | 38 | ||||
| -rw-r--r-- | guix-web/controller.scm | 37 | ||||
| -rw-r--r-- | guix-web/render.scm | 51 | ||||
| -rw-r--r-- | guix-web/server.scm | 75 | ||||
| -rw-r--r-- | guix-web/view.scm | 156 | ||||
| -rwxr-xr-x | scripts/guix-web | 243 |
6 files changed, 361 insertions, 239 deletions
diff --git a/guix-web/config.scm b/guix-web/config.scm new file mode 100644 index 0000000..0ca28cd --- /dev/null +++ b/guix-web/config.scm @@ -0,0 +1,38 @@ +;;; 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 config) + #:use-module (ice-9 match) + #:use-module (guix-web server) + #:export (guix-web-asset-dir + guix-web-router)) + +(define guix-web-asset-dir (getcwd)) + +(define (guix-web-router path) + (match path + ((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))) diff --git a/guix-web/controller.scm b/guix-web/controller.scm new file mode 100644 index 0000000..6640810 --- /dev/null +++ b/guix-web/controller.scm @@ -0,0 +1,37 @@ +;;; 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 controller) + #:use-module (ice-9 match) + #:use-module (web request) + #:use-module (guix-web render) + #:use-module (guix-web view) + #:export (controller)) + +(define (controller path) + (match path + ((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))) diff --git a/guix-web/render.scm b/guix-web/render.scm new file mode 100644 index 0000000..de5da7c --- /dev/null +++ b/guix-web/render.scm @@ -0,0 +1,51 @@ +;;; 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 (web response) + #:use-module (web uri) + #:use-module (sxml simple) + #:use-module (json) + #:export (render-html + render-json + not-found + redirect)) + +(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 (not-found uri) + (list (build-response #:code 404) + (string-append "Resource not found: " (uri->string uri)))) + +(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))))) diff --git a/guix-web/server.scm b/guix-web/server.scm new file mode 100644 index 0000000..49c6a07 --- /dev/null +++ b/guix-web/server.scm @@ -0,0 +1,75 @@ +;;; 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 server) + #:use-module (ice-9 binary-ports) + #:use-module (srfi srfi-1) + #:use-module (web http) + #:use-module (web request) + #:use-module (web server) + #:use-module (web uri) + #:use-module (guix-web config) + #:use-module (guix-web controller) + #:use-module (guix-web render) + #:export (start-guix-web)) + +(define (file-extension file-name) + (last (string-split file-name #\.))) + +(define (directory? filename) + (string=? filename (dirname filename))) + +(define file-mime-types + '(("css" . (text/css)) + ("js" . (text/javascript)) + ("png" . (image/png)))) + +(define (request-path-components request) + (split-and-decode-uri-path (uri-path (request-uri request)))) + +(define (serve-static-asset request) + (let ((filename (string-join + (cons guix-web-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 (run-controller controller request) + (controller (cons (request-method request) + (request-path-components request)))) + +(define (handler request body controller) + (format #t "~a ~a\n" + (request-method request) + (uri-path (request-uri request))) + (apply values + (append + (or (run-controller controller request) + (serve-static-asset request) + (not-found (request-uri request))) + (list controller)))) + +(define (start-guix-web controller) + (run-server (lambda args (apply handler args)) + 'http + `(#:addr ,INADDR_ANY + #:port 8080) + controller)) diff --git a/guix-web/view.scm b/guix-web/view.scm new file mode 100644 index 0000000..35cce29 --- /dev/null +++ b/guix-web/view.scm @@ -0,0 +1,156 @@ +;;; 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 view) + #:use-module (json) + #:use-module (guix licenses) + #:use-module (guix packages) + #:use-module (gnu packages) + #:export (all-packages + all-packages-json + view-package + librejs)) + +(define javascripts + '("/js/underscore.js" + "/js/mithril.js" + "/js/guix-packages.js")) + +(define (script-tag src) + `(script (@ (type "text/javascript") + (src ,src)) + ;; hack to ensure closing </script> tag + "")) + +(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 (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 (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)))))) diff --git a/scripts/guix-web b/scripts/guix-web index e28ce1e..9d984bb 100755 --- a/scripts/guix-web +++ b/scripts/guix-web @@ -18,247 +18,12 @@ ;;; 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)))))) +(use-modules ((system repl server)) + (guix-web controller) + (guix-web server)) (spawn-server (make-tcp-server-socket #:port 37146)) -(run-server (lambda args (apply handler args)) - 'http - `(#:addr ,INADDR_ANY - #:port 8080)) +(start-guix-web controller) ;;; Local Variables: ;;; mode: scheme |