diff options
Diffstat (limited to 'scripts')
| -rwxr-xr-x | scripts/guix-web | 243 |
1 files changed, 4 insertions, 239 deletions
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 |