summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/web.scm4
-rw-r--r--guix/web/config.scm26
-rw-r--r--guix/web/controller.scm57
-rw-r--r--guix/web/package.scm68
-rw-r--r--guix/web/render.scm83
-rw-r--r--guix/web/server.scm49
-rw-r--r--guix/web/sxml.scm369
-rw-r--r--guix/web/util.scm43
-rw-r--r--guix/web/view/html.scm131
-rw-r--r--guix/web/view/json.scm92
10 files changed, 920 insertions, 2 deletions
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 <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)
+ #: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 <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 (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 <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 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 <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 (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 <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 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 <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/>.
+
+;;; 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 "</~a>" tag))))
+
+(define (doctype->html doctype port)
+ (format port "<!DOCTYPE ~a>" 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 <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 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 <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 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>
+ (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 <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 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
+ (($ <manifest-entry> name version output location _)
+ (json
+ (object
+ ("name" ,name)
+ ("version" ,version)
+ ("output" ,output)
+ ("location" ,location)))))
+ manifest-entries))))))
+ (profile-generations*)))
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-21 15:01:13 +0000