From 74217b986ba5582c70ec84b94b3b972764b515b6 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sat, 31 Jan 2015 20:54:35 -0500 Subject: Move all modules into the 'guix web' namespace. * guix-web/config.scm: Delete. * guix-web/controller.scm: Delete. * guix-web/package.scm: Delete. * guix-web/render.scm: Delete. * guix-web/server.scm: Delete. * guix-web/sxml.scm: Delete. * guix-web/util.scm: Delete. * guix-web/view/html.scm: Delete. * guix-web/view/json.scm: Delete. * guix/web/config.scm: New file. * guix/web/controller.scm: New file. * guix/web/package.scm: New file. * guix/web/render.scm: New file. * guix/web/server.scm: New file. * guix/web/sxml.scm: New file. * guix/web/util.scm: New file. * guix/web/view/html.scm: New file. * guix/web/view/json.scm: New file. * guix/scripts/web.scm: Tweak imports. * Makefile.am (SOURCES): Add new files and remove deleted ones. --- Makefile.am | 18 +-- guix-web/config.scm | 26 ---- guix-web/controller.scm | 57 -------- guix-web/package.scm | 68 --------- guix-web/render.scm | 83 ----------- guix-web/server.scm | 49 ------- guix-web/sxml.scm | 369 ------------------------------------------------ guix-web/util.scm | 43 ------ guix-web/view/html.scm | 131 ----------------- guix-web/view/json.scm | 92 ------------ guix/scripts/web.scm | 4 +- guix/web/config.scm | 26 ++++ guix/web/controller.scm | 57 ++++++++ guix/web/package.scm | 68 +++++++++ guix/web/render.scm | 83 +++++++++++ guix/web/server.scm | 49 +++++++ guix/web/sxml.scm | 369 ++++++++++++++++++++++++++++++++++++++++++++++++ guix/web/util.scm | 43 ++++++ guix/web/view/html.scm | 131 +++++++++++++++++ guix/web/view/json.scm | 92 ++++++++++++ 20 files changed, 929 insertions(+), 929 deletions(-) delete mode 100644 guix-web/config.scm delete mode 100644 guix-web/controller.scm delete mode 100644 guix-web/package.scm delete mode 100644 guix-web/render.scm delete mode 100644 guix-web/server.scm delete mode 100644 guix-web/sxml.scm delete mode 100644 guix-web/util.scm delete mode 100644 guix-web/view/html.scm delete mode 100644 guix-web/view/json.scm create mode 100644 guix/web/config.scm create mode 100644 guix/web/controller.scm create mode 100644 guix/web/package.scm create mode 100644 guix/web/render.scm create mode 100644 guix/web/server.scm create mode 100644 guix/web/sxml.scm create mode 100644 guix/web/util.scm create mode 100644 guix/web/view/html.scm create mode 100644 guix/web/view/json.scm diff --git a/Makefile.am b/Makefile.am index ee0cab2..19e5aaf 100644 --- a/Makefile.am +++ b/Makefile.am @@ -21,15 +21,15 @@ moddir=$(prefix)/share/guile/site/2.0 godir=$(libdir)/guile/2.0/ccache SOURCES = \ - guix-web/config.scm \ - guix-web/controller.scm \ - guix-web/package.scm \ - guix-web/render.scm \ - guix-web/server.scm \ - guix-web/util.scm \ - guix-web/sxml.scm \ - guix-web/view/html.scm \ - guix-web/view/json.scm \ + guix/web/config.scm \ + guix/web/controller.scm \ + guix/web/package.scm \ + guix/web/render.scm \ + guix/web/server.scm \ + guix/web/util.scm \ + guix/web/sxml.scm \ + guix/web/view/html.scm \ + guix/web/view/json.scm \ guix/scripts/web.scm EXTRA_DIST += env.in diff --git a/guix-web/config.scm b/guix-web/config.scm deleted file mode 100644 index 8094d83..0000000 --- a/guix-web/config.scm +++ /dev/null @@ -1,26 +0,0 @@ -;;; 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 -;;; . - -(define-module (guix-web config) - #:use-module (ice-9 match) - #:export (guix-web-asset-dir - guix-web-host - guix-web-port)) - -(define guix-web-asset-dir (getcwd)) -(define guix-web-host "localhost") -(define guix-web-port 8080) diff --git a/guix-web/controller.scm b/guix-web/controller.scm deleted file mode 100644 index fa7dfc3..0000000 --- a/guix-web/controller.scm +++ /dev/null @@ -1,57 +0,0 @@ -;;; 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 -;;; . - -(define-module (guix-web controller) - #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (web request) - #:use-module (gnu packages) - #:use-module (guix-web render) - #:use-module (guix-web view html) - #:use-module (guix-web view json) - #:use-module (guix-web package) - #:export (controller)) - -(define extract-package-name - (let ((regexp (make-regexp "^(.*)\\.json$"))) - (lambda (path-part) - (and=> (regexp-exec regexp path-part) - (cut match:substring <> 1))))) - -(define controller - (match-lambda - ((GET) - (redirect '("packages"))) - ((GET "packages") - (render-html (all-packages))) - ((GET "packages.json") - (render-json (all-packages-json))) - ((GET "package" (= extract-package-name (? string? name))) - (render-json (view-package-json name))) - ((POST "packages" name "install") - (let ((package (car (find-packages-by-name name)))) - (if (package-install package) - (created) - (unprocessable-entity)))) - ((GET "generations") - (render-json (generations-json))) - ((GET "librejs") - (render-html (librejs))) - ((GET path ...) - (render-static-asset path)))) diff --git a/guix-web/package.scm b/guix-web/package.scm deleted file mode 100644 index bf92351..0000000 --- a/guix-web/package.scm +++ /dev/null @@ -1,68 +0,0 @@ -;;; 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 -;;; . - -(define-module (guix-web package) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (guix derivations) - #:use-module (guix monads) - #:use-module (guix packages) - #:use-module (guix profiles) - #:use-module (guix store) - #:use-module (guix utils) - #:use-module (guix ui) - #:use-module (gnu packages) - #:export (%all-packages - package-install - profile-generations*)) - -(define %all-packages - (fold-packages cons '())) - -(define %profile - (string-append "/usr/var/guix/profiles/per-user/" - (getenv "USER") "/guix-profile")) -(define manifest (profile-manifest %profile)) - -(define (maybe-register-gc-root store profile) - "Register PROFILE as a GC root, unless it doesn't need it." - (unless (string=? profile %profile) - (add-indirect-root store (canonicalize-path profile)))) - -(define (package-install package) - (with-store %store - (let* ((new (manifest-add manifest - (list (package->manifest-entry package)))) - (prof-drv (run-with-store %store - (profile-derivation new))) - (prof (derivation->output-path prof-drv))) - (let* ((number (generation-number %profile)) - (name (generation-file-name %profile - (+ 1 number)))) - (and (build-derivations %store (list prof-drv)) - (let* ((entries (manifest-entries new)) - (count (length entries))) - (switch-symlinks name prof) - (switch-symlinks %profile name))))))) - -(define (profile-generations*) - (map (lambda (n) - (cons n (reverse - (manifest-entries - (profile-manifest - (generation-file-name %profile n)))))) - (generation-numbers %profile))) diff --git a/guix-web/render.scm b/guix-web/render.scm deleted file mode 100644 index 04e687a..0000000 --- a/guix-web/render.scm +++ /dev/null @@ -1,83 +0,0 @@ -;;; 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 -;;; . - -(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 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))))) diff --git a/guix-web/server.scm b/guix-web/server.scm deleted file mode 100644 index c713616..0000000 --- a/guix-web/server.scm +++ /dev/null @@ -1,49 +0,0 @@ -;;; 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 -;;; . - -(define-module (guix-web server) - #:use-module (ice-9 match) - #: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) - #:use-module (guix-web util) - #:export (start-guix-web)) - -(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 - (run-controller controller request) - (list controller)))) - -(define (start-guix-web controller) - (run-server (lambda args (apply handler args)) - 'http - `(#:addr ,INADDR_ANY - #:port ,guix-web-port) - controller)) diff --git a/guix-web/sxml.scm b/guix-web/sxml.scm deleted file mode 100644 index 91dee4c..0000000 --- a/guix-web/sxml.scm +++ /dev/null @@ -1,369 +0,0 @@ -;;; guix-web - Web interface for GNU Guix -;;; Copyright © 2015 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 -;;; . - -;;; Commentary: -;; -;; SXML to HTML conversion. -;; -;;; Code: - -(define-module (guix-web sxml) - #:use-module (sxml simple) - #:use-module (srfi srfi-26) - #:use-module (ice-9 match) - #:use-module (ice-9 format) - #:use-module (ice-9 hash-table) - #:export (sxml->html)) - -(define %self-closing-tags - '(area - base - br - col - command - embed - hr - img - input - keygen - link - meta - param - source - track - wbr)) - -(define (self-closing-tag? tag) - "Return #t if TAG is self-closing." - (pair? (memq tag %self-closing-tags))) - -(define %escape-chars - (alist->hash-table - '((#\" . "quot") - (#\& . "amp") - (#\' . "apos") - (#\< . "lt") - (#\> . "gt") - (#\¡ . "iexcl") - (#\¢ . "cent") - (#\£ . "pound") - (#\¤ . "curren") - (#\¥ . "yen") - (#\¦ . "brvbar") - (#\§ . "sect") - (#\¨ . "uml") - (#\© . "copy") - (#\ª . "ordf") - (#\« . "laquo") - (#\¬ . "not") - (#\® . "reg") - (#\¯ . "macr") - (#\° . "deg") - (#\± . "plusmn") - (#\² . "sup2") - (#\³ . "sup3") - (#\´ . "acute") - (#\µ . "micro") - (#\¶ . "para") - (#\· . "middot") - (#\¸ . "cedil") - (#\¹ . "sup1") - (#\º . "ordm") - (#\» . "raquo") - (#\¼ . "frac14") - (#\½ . "frac12") - (#\¾ . "frac34") - (#\¿ . "iquest") - (#\À . "Agrave") - (#\Á . "Aacute") - (#\ . "Acirc") - (#\à . "Atilde") - (#\Ä . "Auml") - (#\Å . "Aring") - (#\Æ . "AElig") - (#\Ç . "Ccedil") - (#\È . "Egrave") - (#\É . "Eacute") - (#\Ê . "Ecirc") - (#\Ë . "Euml") - (#\Ì . "Igrave") - (#\Í . "Iacute") - (#\Î . "Icirc") - (#\Ï . "Iuml") - (#\Ð . "ETH") - (#\Ñ . "Ntilde") - (#\Ò . "Ograve") - (#\Ó . "Oacute") - (#\Ô . "Ocirc") - (#\Õ . "Otilde") - (#\Ö . "Ouml") - (#\× . "times") - (#\Ø . "Oslash") - (#\Ù . "Ugrave") - (#\Ú . "Uacute") - (#\Û . "Ucirc") - (#\Ü . "Uuml") - (#\Ý . "Yacute") - (#\Þ . "THORN") - (#\ß . "szlig") - (#\à . "agrave") - (#\á . "aacute") - (#\â . "acirc") - (#\ã . "atilde") - (#\ä . "auml") - (#\å . "aring") - (#\æ . "aelig") - (#\ç . "ccedil") - (#\è . "egrave") - (#\é . "eacute") - (#\ê . "ecirc") - (#\ë . "euml") - (#\ì . "igrave") - (#\í . "iacute") - (#\î . "icirc") - (#\ï . "iuml") - (#\ð . "eth") - (#\ñ . "ntilde") - (#\ò . "ograve") - (#\ó . "oacute") - (#\ô . "ocirc") - (#\õ . "otilde") - (#\ö . "ouml") - (#\÷ . "divide") - (#\ø . "oslash") - (#\ù . "ugrave") - (#\ú . "uacute") - (#\û . "ucirc") - (#\ü . "uuml") - (#\ý . "yacute") - (#\þ . "thorn") - (#\ÿ . "yuml") - (#\Œ . "OElig") - (#\œ . "oelig") - (#\Š . "Scaron") - (#\š . "scaron") - (#\Ÿ . "Yuml") - (#\ƒ . "fnof") - (#\ˆ . "circ") - (#\˜ . "tilde") - (#\Α . "Alpha") - (#\Β . "Beta") - (#\Γ . "Gamma") - (#\Δ . "Delta") - (#\Ε . "Epsilon") - (#\Ζ . "Zeta") - (#\Η . "Eta") - (#\Θ . "Theta") - (#\Ι . "Iota") - (#\Κ . "Kappa") - (#\Λ . "Lambda") - (#\Μ . "Mu") - (#\Ν . "Nu") - (#\Ξ . "Xi") - (#\Ο . "Omicron") - (#\Π . "Pi") - (#\Ρ . "Rho") - (#\Σ . "Sigma") - (#\Τ . "Tau") - (#\Υ . "Upsilon") - (#\Φ . "Phi") - (#\Χ . "Chi") - (#\Ψ . "Psi") - (#\Ω . "Omega") - (#\α . "alpha") - (#\β . "beta") - (#\γ . "gamma") - (#\δ . "delta") - (#\ε . "epsilon") - (#\ζ . "zeta") - (#\η . "eta") - (#\θ . "theta") - (#\ι . "iota") - (#\κ . "kappa") - (#\λ . "lambda") - (#\μ . "mu") - (#\ν . "nu") - (#\ξ . "xi") - (#\ο . "omicron") - (#\π . "pi") - (#\ρ . "rho") - (#\ς . "sigmaf") - (#\σ . "sigma") - (#\τ . "tau") - (#\υ . "upsilon") - (#\φ . "phi") - (#\χ . "chi") - (#\ψ . "psi") - (#\ω . "omega") - (#\ϑ . "thetasym") - (#\ϒ . "upsih") - (#\ϖ . "piv") - (#\  . "ensp") - (#\  . "emsp") - (#\  . "thinsp") - (#\– . "ndash") - (#\— . "mdash") - (#\‘ . "lsquo") - (#\’ . "rsquo") - (#\‚ . "sbquo") - (#\“ . "ldquo") - (#\” . "rdquo") - (#\„ . "bdquo") - (#\† . "dagger") - (#\‡ . "Dagger") - (#\• . "bull") - (#\… . "hellip") - (#\‰ . "permil") - (#\′ . "prime") - (#\″ . "Prime") - (#\‹ . "lsaquo") - (#\› . "rsaquo") - (#\‾ . "oline") - (#\⁄ . "frasl") - (#\€ . "euro") - (#\ℑ . "image") - (#\℘ . "weierp") - (#\ℜ . "real") - (#\™ . "trade") - (#\ℵ . "alefsym") - (#\← . "larr") - (#\↑ . "uarr") - (#\→ . "rarr") - (#\↓ . "darr") - (#\↔ . "harr") - (#\↵ . "crarr") - (#\⇐ . "lArr") - (#\⇑ . "uArr") - (#\⇒ . "rArr") - (#\⇓ . "dArr") - (#\⇔ . "hArr") - (#\∀ . "forall") - (#\∂ . "part") - (#\∃ . "exist") - (#\∅ . "empty") - (#\∇ . "nabla") - (#\∈ . "isin") - (#\∉ . "notin") - (#\∋ . "ni") - (#\∏ . "prod") - (#\∑ . "sum") - (#\− . "minus") - (#\∗ . "lowast") - (#\√ . "radic") - (#\∝ . "prop") - (#\∞ . "infin") - (#\∠ . "ang") - (#\∧ . "and") - (#\∨ . "or") - (#\∩ . "cap") - (#\∪ . "cup") - (#\∫ . "int") - (#\∴ . "there4") - (#\∼ . "sim") - (#\≅ . "cong") - (#\≈ . "asymp") - (#\≠ . "ne") - (#\≡ . "equiv") - (#\≤ . "le") - (#\≥ . "ge") - (#\⊂ . "sub") - (#\⊃ . "sup") - (#\⊄ . "nsub") - (#\⊆ . "sube") - (#\⊇ . "supe") - (#\⊕ . "oplus") - (#\⊗ . "otimes") - (#\⊥ . "perp") - (#\⋅ . "sdot") - (#\⋮ . "vellip") - (#\⌈ . "lceil") - (#\⌉ . "rceil") - (#\⌊ . "lfloor") - (#\⌋ . "rfloor") - (#\〈 . "lang") - (#\〉 . "rang") - (#\◊ . "loz") - (#\♠ . "spades") - (#\♣ . "clubs") - (#\♥ . "hearts") - (#\♦ . "diams")))) - -(define (string->escaped-html s port) - "Write the HTML escaped form of S to PORT." - (define (escape c) - (let ((escaped (hash-ref %escape-chars c))) - (if escaped - (format port "&~a;" escaped) - (display c port)))) - (string-for-each escape s)) - -(define (object->escaped-html obj port) - "Write the HTML escaped form of OBJ to PORT." - (string->escaped-html - (call-with-output-string (cut display obj <>)) - port)) - -(define (attribute-value->html value port) - "Write the HTML escaped form of VALUE to PORT." - (if (string? value) - (string->escaped-html value port) - (object->escaped-html value port))) - -(define (attribute->html attr value port) - "Write ATTR and VALUE to PORT." - (format port "~a=\"" attr) - (attribute-value->html value port) - (display #\" port)) - -(define (element->html tag attrs body port) - "Write the HTML TAG to PORT, where TAG has the attributes in the -list ATTRS and the child nodes in BODY." - (format port "<~a" tag) - (for-each (match-lambda - ((attr value) - (display #\space port) - (attribute->html attr value port))) - attrs) - (if (and (null? body) (self-closing-tag? tag)) - (display " />" port) - (begin - (display #\> port) - (for-each (cut sxml->html <> port) body) - (format port "" tag)))) - -(define (doctype->html doctype port) - (format port "" doctype)) - -(define* (sxml->html tree #:optional (port (current-output-port))) - "Write the serialized HTML form of TREE to PORT." - (match tree - (() *unspecified*) - (('doctype type) - (doctype->html type port)) - ;; Unescaped, raw HTML output - (('raw html) - (display html port)) - (((? symbol? tag) ('@ attrs ...) body ...) - (element->html tag attrs body port)) - (((? symbol? tag) body ...) - (element->html tag '() body port)) - ((nodes ...) - (for-each (cut sxml->html <> port) nodes)) - ((? string? text) - (string->escaped-html text port)) - ;; Render arbitrary Scheme objects, too. - (obj (object->escaped-html obj port)))) diff --git a/guix-web/util.scm b/guix-web/util.scm deleted file mode 100644 index f99eed5..0000000 --- a/guix-web/util.scm +++ /dev/null @@ -1,43 +0,0 @@ -;;; 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 -;;; . - -(define-module (guix-web util) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (web request) - #:use-module (web uri) - #:export (parse-query-string - request-path-components - file-extension - directory?)) - -(define (parse-query-string query) - "Parse and decode the URI query string QUERY and return an alist." - (let lp ((lst (map uri-decode (string-split query (char-set #\& #\=))))) - (match lst - ((key value . rest) - (cons (cons key value) (lp rest))) - (() '())))) - -(define (request-path-components request) - (split-and-decode-uri-path (uri-path (request-uri request)))) - -(define (file-extension file-name) - (last (string-split file-name #\.))) - -(define (directory? filename) - (string=? filename (dirname filename))) diff --git a/guix-web/view/html.scm b/guix-web/view/html.scm deleted file mode 100644 index 83ff226..0000000 --- a/guix-web/view/html.scm +++ /dev/null @@ -1,131 +0,0 @@ -;;; guix-web - Web interface for GNU Guix -;;; Copyright © 2014, 2015 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 -;;; . - -(define-module (guix-web view html) - #:use-module (ice-9 format) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (web uri) - #:use-module (guix licenses) - #:use-module (guix packages) - #:use-module (guix profiles) - #:use-module (gnu packages) - #:use-module (guix-web package) - #:export (all-packages - view-package - librejs)) - -(define-record-type - (javascript source-uri license) - javascript? - (source-uri javascript-source-uri) - (license javascript-license)) - -(define (javascript-license-uri javascript) - (let ((license (javascript-license javascript))) - (cond - ((eq? license expat) - "http://www.jclark.com/xml/copying.txt") - ((eq? license agpl3+) - "https://www.gnu.org/licenses/agpl-3.0.html")))) - -(define javascripts - (list (javascript "/js/lib/underscore.js" expat) - (javascript "/js/lib/mithril.js" expat) - (javascript "/js/utils.js" agpl3+) - (javascript "/js/view/ui.js" agpl3+) - (javascript "/js/view/layout.js" agpl3+) - (javascript "/js/model/packages.js" agpl3+) - (javascript "/js/model/generations.js" agpl3+) - (javascript "/js/controller/packages.js" agpl3+) - (javascript "/js/controller/packageInfo.js" agpl3+) - (javascript "/js/controller/generations.js" agpl3+) - (javascript "/js/view/packages.js" agpl3+) - (javascript "/js/view/packageInfo.js" agpl3+) - (javascript "/js/view/generations.js" agpl3+) - (javascript "/js/routes.js" agpl3+))) - -(define stylesheets - (list "/css/bootstrap.css" - "/css/guix.css")) - -(define (render-javascript javascript) - `(script (@ (type "text/javascript") - (src ,(javascript-source-uri javascript))))) - -(define (render-stylesheet stylesheet-uri) - `(link (@ (rel "stylesheet") - (href ,stylesheet-uri)))) - -(define (main-layout subtitle body) - `((doctype "HTML") - (html - (head - (meta (@ (content "text/html;charset=utf-8") - (http-equiv "Content-Type"))) - (title ,(string-append "GNU Guix - " subtitle)) - ,@(map render-stylesheet stylesheets)) - (body ,body)))) - -(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" (map render-javascript javascripts))) - -(define (librejs) - (define (weblabel js) - (let ((source (javascript-source-uri js))) - `(tr - (td - (a (@ (href ,source)) - ,source)) - (td - (a (@ (href ,(javascript-license-uri js))) - ,(license-name (javascript-license js)))) - (td - (a (@ (href ,source)) - ,(basename source)))))) - - (main-layout - "LibreJS" - `(div (@ (class "container")) - (div - (a (@ (href "/")) - (img (@ (src "/images/logo.png"))))) - (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/guix-web/view/json.scm b/guix-web/view/json.scm deleted file mode 100644 index 8896c9d..0000000 --- a/guix-web/view/json.scm +++ /dev/null @@ -1,92 +0,0 @@ -;;; guix-web - Web interface for GNU Guix -;;; Copyright © 2014, 2015 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 -;;; . - -(define-module (guix-web view json) - #:use-module (ice-9 format) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (json) - #:use-module (web uri) - #:use-module (guix licenses) - #:use-module (guix packages) - #:use-module (guix profiles) - #:use-module (gnu packages) - #:use-module (guix-web package) - #:export (all-packages-json - view-package-json - generations-json)) - -(define (license->json license) - (json - (object - ("name" ,(license-name license)) - ("uri" ,(license-uri license))))) - -(define* (package->json package #:optional serialize-inputs?) - (define (serialize-license package) - (let ((license (package-license package))) - (cond - ((list? license) - (map license->json license)) - ((license? license) - (license->json license)) - (else #f)))) - - (define (serialize-inputs packages) - (map package->json (filter package? (map second packages)))) - - (json - (object - ("name" ,(package-name package)) - ("version" ,(package-version package)) - ("synopsis" ,(package-synopsis package)) - ("description" ,(package-description package)) - ("homepage" ,(package-home-page package)) - ("license" ,(serialize-license package)) - ,@(if serialize-inputs? - `(("inputs" ,(serialize-inputs (package-inputs package))) - ("nativeInputs" ,(serialize-inputs - (package-native-inputs package))) - ("propagatedInputs" ,(serialize-inputs - (package-propagated-inputs package)))) - '())))) - -(define (all-packages-json) - (map package->json %all-packages)) - -(define (view-package-json name) - (map (lambda (p) (package->json p #t)) - (find-packages-by-name name))) - -(define (generations-json) - (map (match-lambda - ((n . manifest-entries) - (json - (object - ("number" ,n) - ("manifestEntries" - ,(map (match-lambda - (($ name version output location _) - (json - (object - ("name" ,name) - ("version" ,version) - ("output" ,output) - ("location" ,location))))) - manifest-entries)))))) - (profile-generations*))) diff --git a/guix/scripts/web.scm b/guix/scripts/web.scm index da6270e..cb9fb47 100644 --- a/guix/scripts/web.scm +++ b/guix/scripts/web.scm @@ -17,8 +17,8 @@ (define-module (guix scripts web) #:use-module (system repl server) - #:use-module (guix-web controller) - #:use-module (guix-web server) + #:use-module (guix web controller) + #:use-module (guix web server) #:export (guix-web)) (define (guix-web . args) diff --git a/guix/web/config.scm b/guix/web/config.scm new file mode 100644 index 0000000..2461cc9 --- /dev/null +++ b/guix/web/config.scm @@ -0,0 +1,26 @@ +;;; 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 +;;; . + +(define-module (guix web config) + #:use-module (ice-9 match) + #:export (guix-web-asset-dir + guix-web-host + guix-web-port)) + +(define guix-web-asset-dir (getcwd)) +(define guix-web-host "localhost") +(define guix-web-port 8080) diff --git a/guix/web/controller.scm b/guix/web/controller.scm new file mode 100644 index 0000000..dedb1c5 --- /dev/null +++ b/guix/web/controller.scm @@ -0,0 +1,57 @@ +;;; 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 +;;; . + +(define-module (guix web controller) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (web request) + #:use-module (gnu packages) + #:use-module (guix web render) + #:use-module (guix web view html) + #:use-module (guix web view json) + #:use-module (guix web package) + #:export (controller)) + +(define extract-package-name + (let ((regexp (make-regexp "^(.*)\\.json$"))) + (lambda (path-part) + (and=> (regexp-exec regexp path-part) + (cut match:substring <> 1))))) + +(define controller + (match-lambda + ((GET) + (redirect '("packages"))) + ((GET "packages") + (render-html (all-packages))) + ((GET "packages.json") + (render-json (all-packages-json))) + ((GET "package" (= extract-package-name (? string? name))) + (render-json (view-package-json name))) + ((POST "packages" name "install") + (let ((package (car (find-packages-by-name name)))) + (if (package-install package) + (created) + (unprocessable-entity)))) + ((GET "generations") + (render-json (generations-json))) + ((GET "librejs") + (render-html (librejs))) + ((GET path ...) + (render-static-asset path)))) diff --git a/guix/web/package.scm b/guix/web/package.scm new file mode 100644 index 0000000..f5a032c --- /dev/null +++ b/guix/web/package.scm @@ -0,0 +1,68 @@ +;;; 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 +;;; . + +(define-module (guix web package) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (guix derivations) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix ui) + #:use-module (gnu packages) + #:export (%all-packages + package-install + profile-generations*)) + +(define %all-packages + (fold-packages cons '())) + +(define %profile + (string-append "/usr/var/guix/profiles/per-user/" + (getenv "USER") "/guix-profile")) +(define manifest (profile-manifest %profile)) + +(define (maybe-register-gc-root store profile) + "Register PROFILE as a GC root, unless it doesn't need it." + (unless (string=? profile %profile) + (add-indirect-root store (canonicalize-path profile)))) + +(define (package-install package) + (with-store %store + (let* ((new (manifest-add manifest + (list (package->manifest-entry package)))) + (prof-drv (run-with-store %store + (profile-derivation new))) + (prof (derivation->output-path prof-drv))) + (let* ((number (generation-number %profile)) + (name (generation-file-name %profile + (+ 1 number)))) + (and (build-derivations %store (list prof-drv)) + (let* ((entries (manifest-entries new)) + (count (length entries))) + (switch-symlinks name prof) + (switch-symlinks %profile name))))))) + +(define (profile-generations*) + (map (lambda (n) + (cons n (reverse + (manifest-entries + (profile-manifest + (generation-file-name %profile n)))))) + (generation-numbers %profile))) 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 +;;; +;;; 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 +;;; . + +(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))))) diff --git a/guix/web/server.scm b/guix/web/server.scm new file mode 100644 index 0000000..e95487f --- /dev/null +++ b/guix/web/server.scm @@ -0,0 +1,49 @@ +;;; 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 +;;; . + +(define-module (guix web server) + #:use-module (ice-9 match) + #: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) + #:use-module (guix web util) + #:export (start-guix-web)) + +(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 + (run-controller controller request) + (list controller)))) + +(define (start-guix-web controller) + (run-server (lambda args (apply handler args)) + 'http + `(#:addr ,INADDR_ANY + #:port ,guix-web-port) + controller)) diff --git a/guix/web/sxml.scm b/guix/web/sxml.scm new file mode 100644 index 0000000..0b65a2d --- /dev/null +++ b/guix/web/sxml.scm @@ -0,0 +1,369 @@ +;;; guix-web - Web interface for GNU Guix +;;; Copyright © 2015 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 +;;; . + +;;; Commentary: +;; +;; SXML to HTML conversion. +;; +;;; Code: + +(define-module (guix web sxml) + #:use-module (sxml simple) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (ice-9 hash-table) + #:export (sxml->html)) + +(define %self-closing-tags + '(area + base + br + col + command + embed + hr + img + input + keygen + link + meta + param + source + track + wbr)) + +(define (self-closing-tag? tag) + "Return #t if TAG is self-closing." + (pair? (memq tag %self-closing-tags))) + +(define %escape-chars + (alist->hash-table + '((#\" . "quot") + (#\& . "amp") + (#\' . "apos") + (#\< . "lt") + (#\> . "gt") + (#\¡ . "iexcl") + (#\¢ . "cent") + (#\£ . "pound") + (#\¤ . "curren") + (#\¥ . "yen") + (#\¦ . "brvbar") + (#\§ . "sect") + (#\¨ . "uml") + (#\© . "copy") + (#\ª . "ordf") + (#\« . "laquo") + (#\¬ . "not") + (#\® . "reg") + (#\¯ . "macr") + (#\° . "deg") + (#\± . "plusmn") + (#\² . "sup2") + (#\³ . "sup3") + (#\´ . "acute") + (#\µ . "micro") + (#\¶ . "para") + (#\· . "middot") + (#\¸ . "cedil") + (#\¹ . "sup1") + (#\º . "ordm") + (#\» . "raquo") + (#\¼ . "frac14") + (#\½ . "frac12") + (#\¾ . "frac34") + (#\¿ . "iquest") + (#\À . "Agrave") + (#\Á . "Aacute") + (#\ . "Acirc") + (#\à . "Atilde") + (#\Ä . "Auml") + (#\Å . "Aring") + (#\Æ . "AElig") + (#\Ç . "Ccedil") + (#\È . "Egrave") + (#\É . "Eacute") + (#\Ê . "Ecirc") + (#\Ë . "Euml") + (#\Ì . "Igrave") + (#\Í . "Iacute") + (#\Î . "Icirc") + (#\Ï . "Iuml") + (#\Ð . "ETH") + (#\Ñ . "Ntilde") + (#\Ò . "Ograve") + (#\Ó . "Oacute") + (#\Ô . "Ocirc") + (#\Õ . "Otilde") + (#\Ö . "Ouml") + (#\× . "times") + (#\Ø . "Oslash") + (#\Ù . "Ugrave") + (#\Ú . "Uacute") + (#\Û . "Ucirc") + (#\Ü . "Uuml") + (#\Ý . "Yacute") + (#\Þ . "THORN") + (#\ß . "szlig") + (#\à . "agrave") + (#\á . "aacute") + (#\â . "acirc") + (#\ã . "atilde") + (#\ä . "auml") + (#\å . "aring") + (#\æ . "aelig") + (#\ç . "ccedil") + (#\è . "egrave") + (#\é . "eacute") + (#\ê . "ecirc") + (#\ë . "euml") + (#\ì . "igrave") + (#\í . "iacute") + (#\î . "icirc") + (#\ï . "iuml") + (#\ð . "eth") + (#\ñ . "ntilde") + (#\ò . "ograve") + (#\ó . "oacute") + (#\ô . "ocirc") + (#\õ . "otilde") + (#\ö . "ouml") + (#\÷ . "divide") + (#\ø . "oslash") + (#\ù . "ugrave") + (#\ú . "uacute") + (#\û . "ucirc") + (#\ü . "uuml") + (#\ý . "yacute") + (#\þ . "thorn") + (#\ÿ . "yuml") + (#\Œ . "OElig") + (#\œ . "oelig") + (#\Š . "Scaron") + (#\š . "scaron") + (#\Ÿ . "Yuml") + (#\ƒ . "fnof") + (#\ˆ . "circ") + (#\˜ . "tilde") + (#\Α . "Alpha") + (#\Β . "Beta") + (#\Γ . "Gamma") + (#\Δ . "Delta") + (#\Ε . "Epsilon") + (#\Ζ . "Zeta") + (#\Η . "Eta") + (#\Θ . "Theta") + (#\Ι . "Iota") + (#\Κ . "Kappa") + (#\Λ . "Lambda") + (#\Μ . "Mu") + (#\Ν . "Nu") + (#\Ξ . "Xi") + (#\Ο . "Omicron") + (#\Π . "Pi") + (#\Ρ . "Rho") + (#\Σ . "Sigma") + (#\Τ . "Tau") + (#\Υ . "Upsilon") + (#\Φ . "Phi") + (#\Χ . "Chi") + (#\Ψ . "Psi") + (#\Ω . "Omega") + (#\α . "alpha") + (#\β . "beta") + (#\γ . "gamma") + (#\δ . "delta") + (#\ε . "epsilon") + (#\ζ . "zeta") + (#\η . "eta") + (#\θ . "theta") + (#\ι . "iota") + (#\κ . "kappa") + (#\λ . "lambda") + (#\μ . "mu") + (#\ν . "nu") + (#\ξ . "xi") + (#\ο . "omicron") + (#\π . "pi") + (#\ρ . "rho") + (#\ς . "sigmaf") + (#\σ . "sigma") + (#\τ . "tau") + (#\υ . "upsilon") + (#\φ . "phi") + (#\χ . "chi") + (#\ψ . "psi") + (#\ω . "omega") + (#\ϑ . "thetasym") + (#\ϒ . "upsih") + (#\ϖ . "piv") + (#\  . "ensp") + (#\  . "emsp") + (#\  . "thinsp") + (#\– . "ndash") + (#\— . "mdash") + (#\‘ . "lsquo") + (#\’ . "rsquo") + (#\‚ . "sbquo") + (#\“ . "ldquo") + (#\” . "rdquo") + (#\„ . "bdquo") + (#\† . "dagger") + (#\‡ . "Dagger") + (#\• . "bull") + (#\… . "hellip") + (#\‰ . "permil") + (#\′ . "prime") + (#\″ . "Prime") + (#\‹ . "lsaquo") + (#\› . "rsaquo") + (#\‾ . "oline") + (#\⁄ . "frasl") + (#\€ . "euro") + (#\ℑ . "image") + (#\℘ . "weierp") + (#\ℜ . "real") + (#\™ . "trade") + (#\ℵ . "alefsym") + (#\← . "larr") + (#\↑ . "uarr") + (#\→ . "rarr") + (#\↓ . "darr") + (#\↔ . "harr") + (#\↵ . "crarr") + (#\⇐ . "lArr") + (#\⇑ . "uArr") + (#\⇒ . "rArr") + (#\⇓ . "dArr") + (#\⇔ . "hArr") + (#\∀ . "forall") + (#\∂ . "part") + (#\∃ . "exist") + (#\∅ . "empty") + (#\∇ . "nabla") + (#\∈ . "isin") + (#\∉ . "notin") + (#\∋ . "ni") + (#\∏ . "prod") + (#\∑ . "sum") + (#\− . "minus") + (#\∗ . "lowast") + (#\√ . "radic") + (#\∝ . "prop") + (#\∞ . "infin") + (#\∠ . "ang") + (#\∧ . "and") + (#\∨ . "or") + (#\∩ . "cap") + (#\∪ . "cup") + (#\∫ . "int") + (#\∴ . "there4") + (#\∼ . "sim") + (#\≅ . "cong") + (#\≈ . "asymp") + (#\≠ . "ne") + (#\≡ . "equiv") + (#\≤ . "le") + (#\≥ . "ge") + (#\⊂ . "sub") + (#\⊃ . "sup") + (#\⊄ . "nsub") + (#\⊆ . "sube") + (#\⊇ . "supe") + (#\⊕ . "oplus") + (#\⊗ . "otimes") + (#\⊥ . "perp") + (#\⋅ . "sdot") + (#\⋮ . "vellip") + (#\⌈ . "lceil") + (#\⌉ . "rceil") + (#\⌊ . "lfloor") + (#\⌋ . "rfloor") + (#\〈 . "lang") + (#\〉 . "rang") + (#\◊ . "loz") + (#\♠ . "spades") + (#\♣ . "clubs") + (#\♥ . "hearts") + (#\♦ . "diams")))) + +(define (string->escaped-html s port) + "Write the HTML escaped form of S to PORT." + (define (escape c) + (let ((escaped (hash-ref %escape-chars c))) + (if escaped + (format port "&~a;" escaped) + (display c port)))) + (string-for-each escape s)) + +(define (object->escaped-html obj port) + "Write the HTML escaped form of OBJ to PORT." + (string->escaped-html + (call-with-output-string (cut display obj <>)) + port)) + +(define (attribute-value->html value port) + "Write the HTML escaped form of VALUE to PORT." + (if (string? value) + (string->escaped-html value port) + (object->escaped-html value port))) + +(define (attribute->html attr value port) + "Write ATTR and VALUE to PORT." + (format port "~a=\"" attr) + (attribute-value->html value port) + (display #\" port)) + +(define (element->html tag attrs body port) + "Write the HTML TAG to PORT, where TAG has the attributes in the +list ATTRS and the child nodes in BODY." + (format port "<~a" tag) + (for-each (match-lambda + ((attr value) + (display #\space port) + (attribute->html attr value port))) + attrs) + (if (and (null? body) (self-closing-tag? tag)) + (display " />" port) + (begin + (display #\> port) + (for-each (cut sxml->html <> port) body) + (format port "" tag)))) + +(define (doctype->html doctype port) + (format port "" doctype)) + +(define* (sxml->html tree #:optional (port (current-output-port))) + "Write the serialized HTML form of TREE to PORT." + (match tree + (() *unspecified*) + (('doctype type) + (doctype->html type port)) + ;; Unescaped, raw HTML output + (('raw html) + (display html port)) + (((? symbol? tag) ('@ attrs ...) body ...) + (element->html tag attrs body port)) + (((? symbol? tag) body ...) + (element->html tag '() body port)) + ((nodes ...) + (for-each (cut sxml->html <> port) nodes)) + ((? string? text) + (string->escaped-html text port)) + ;; Render arbitrary Scheme objects, too. + (obj (object->escaped-html obj port)))) diff --git a/guix/web/util.scm b/guix/web/util.scm new file mode 100644 index 0000000..396f4ee --- /dev/null +++ b/guix/web/util.scm @@ -0,0 +1,43 @@ +;;; 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 +;;; . + +(define-module (guix web util) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (web request) + #:use-module (web uri) + #:export (parse-query-string + request-path-components + file-extension + directory?)) + +(define (parse-query-string query) + "Parse and decode the URI query string QUERY and return an alist." + (let lp ((lst (map uri-decode (string-split query (char-set #\& #\=))))) + (match lst + ((key value . rest) + (cons (cons key value) (lp rest))) + (() '())))) + +(define (request-path-components request) + (split-and-decode-uri-path (uri-path (request-uri request)))) + +(define (file-extension file-name) + (last (string-split file-name #\.))) + +(define (directory? filename) + (string=? filename (dirname filename))) diff --git a/guix/web/view/html.scm b/guix/web/view/html.scm new file mode 100644 index 0000000..462055c --- /dev/null +++ b/guix/web/view/html.scm @@ -0,0 +1,131 @@ +;;; guix-web - Web interface for GNU Guix +;;; Copyright © 2014, 2015 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 +;;; . + +(define-module (guix web view html) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (web uri) + #:use-module (guix licenses) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (gnu packages) + #:use-module (guix web package) + #:export (all-packages + view-package + librejs)) + +(define-record-type + (javascript source-uri license) + javascript? + (source-uri javascript-source-uri) + (license javascript-license)) + +(define (javascript-license-uri javascript) + (let ((license (javascript-license javascript))) + (cond + ((eq? license expat) + "http://www.jclark.com/xml/copying.txt") + ((eq? license agpl3+) + "https://www.gnu.org/licenses/agpl-3.0.html")))) + +(define javascripts + (list (javascript "/js/lib/underscore.js" expat) + (javascript "/js/lib/mithril.js" expat) + (javascript "/js/utils.js" agpl3+) + (javascript "/js/view/ui.js" agpl3+) + (javascript "/js/view/layout.js" agpl3+) + (javascript "/js/model/packages.js" agpl3+) + (javascript "/js/model/generations.js" agpl3+) + (javascript "/js/controller/packages.js" agpl3+) + (javascript "/js/controller/packageInfo.js" agpl3+) + (javascript "/js/controller/generations.js" agpl3+) + (javascript "/js/view/packages.js" agpl3+) + (javascript "/js/view/packageInfo.js" agpl3+) + (javascript "/js/view/generations.js" agpl3+) + (javascript "/js/routes.js" agpl3+))) + +(define stylesheets + (list "/css/bootstrap.css" + "/css/guix.css")) + +(define (render-javascript javascript) + `(script (@ (type "text/javascript") + (src ,(javascript-source-uri javascript))))) + +(define (render-stylesheet stylesheet-uri) + `(link (@ (rel "stylesheet") + (href ,stylesheet-uri)))) + +(define (main-layout subtitle body) + `((doctype "HTML") + (html + (head + (meta (@ (content "text/html;charset=utf-8") + (http-equiv "Content-Type"))) + (title ,(string-append "GNU Guix - " subtitle)) + ,@(map render-stylesheet stylesheets)) + (body ,body)))) + +(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" (map render-javascript javascripts))) + +(define (librejs) + (define (weblabel js) + (let ((source (javascript-source-uri js))) + `(tr + (td + (a (@ (href ,source)) + ,source)) + (td + (a (@ (href ,(javascript-license-uri js))) + ,(license-name (javascript-license js)))) + (td + (a (@ (href ,source)) + ,(basename source)))))) + + (main-layout + "LibreJS" + `(div (@ (class "container")) + (div + (a (@ (href "/")) + (img (@ (src "/images/logo.png"))))) + (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/guix/web/view/json.scm b/guix/web/view/json.scm new file mode 100644 index 0000000..4fe45a2 --- /dev/null +++ b/guix/web/view/json.scm @@ -0,0 +1,92 @@ +;;; guix-web - Web interface for GNU Guix +;;; Copyright © 2014, 2015 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 +;;; . + +(define-module (guix web view json) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (json) + #:use-module (web uri) + #:use-module (guix licenses) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (gnu packages) + #:use-module (guix web package) + #:export (all-packages-json + view-package-json + generations-json)) + +(define (license->json license) + (json + (object + ("name" ,(license-name license)) + ("uri" ,(license-uri license))))) + +(define* (package->json package #:optional serialize-inputs?) + (define (serialize-license package) + (let ((license (package-license package))) + (cond + ((list? license) + (map license->json license)) + ((license? license) + (license->json license)) + (else #f)))) + + (define (serialize-inputs packages) + (map package->json (filter package? (map second packages)))) + + (json + (object + ("name" ,(package-name package)) + ("version" ,(package-version package)) + ("synopsis" ,(package-synopsis package)) + ("description" ,(package-description package)) + ("homepage" ,(package-home-page package)) + ("license" ,(serialize-license package)) + ,@(if serialize-inputs? + `(("inputs" ,(serialize-inputs (package-inputs package))) + ("nativeInputs" ,(serialize-inputs + (package-native-inputs package))) + ("propagatedInputs" ,(serialize-inputs + (package-propagated-inputs package)))) + '())))) + +(define (all-packages-json) + (map package->json %all-packages)) + +(define (view-package-json name) + (map (lambda (p) (package->json p #t)) + (find-packages-by-name name))) + +(define (generations-json) + (map (match-lambda + ((n . manifest-entries) + (json + (object + ("number" ,n) + ("manifestEntries" + ,(map (match-lambda + (($ name version output location _) + (json + (object + ("name" ,name) + ("version" ,version) + ("output" ,output) + ("location" ,location))))) + manifest-entries)))))) + (profile-generations*))) -- cgit v1.2.3