From d866718649a385bdf3366783d9fdbed5a2630f92 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Thu, 7 Aug 2014 17:45:27 -0400 Subject: Move guix-web to scripts directory. * README.md ("Use"): Update. * guix-web: Moved. * pre-inst-env: New file. * scripts/guix-web: New file. --- README.md | 3 +- guix-web | 266 ------------------------------------------------------- pre-inst-env | 6 ++ scripts/guix-web | 265 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 273 insertions(+), 267 deletions(-) delete mode 100755 guix-web create mode 100755 pre-inst-env create mode 100755 scripts/guix-web diff --git a/README.md b/README.md index b937559..35ef584 100644 --- a/README.md +++ b/README.md @@ -7,7 +7,8 @@ and JavaScript. Use --- -Simply run `./guix-web` and visit `localhost:8080` in your web browser. +Simply run `./pre-inst-env guix-web` and visit `localhost:8080` in +your web browser. Copyright --------- diff --git a/guix-web b/guix-web deleted file mode 100755 index d628987..0000000 --- a/guix-web +++ /dev/null @@ -1,266 +0,0 @@ -#!/usr/bin/guile -!# - -;;; guix-web - Web interface for GNU Guix -;;; Copyright © 2014 David Thompson -;;; -;;; 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 -;;; . - -(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 "" 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 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 -;;; compile-command: "./guix-web" -;;; End: diff --git a/pre-inst-env b/pre-inst-env new file mode 100755 index 0000000..cd6ad23 --- /dev/null +++ b/pre-inst-env @@ -0,0 +1,6 @@ +#!/bin/bash + +export PATH="$PWD/scripts:$PATH" +export GUILE_LOAD_PATH="$PWD:$GUILE_LOAD_PATH" + +exec "$@" 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 +;;; +;;; 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 +;;; . + +(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 "" 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 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: -- cgit v1.2.3