summaryrefslogtreecommitdiff
path: root/guix/web/view
diff options
context:
space:
mode:
Diffstat (limited to 'guix/web/view')
-rw-r--r--guix/web/view/html.scm131
-rw-r--r--guix/web/view/json.scm92
2 files changed, 223 insertions, 0 deletions
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-22 10:08:02 +0000