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. --- guix/web/view/html.scm | 131 +++++++++++++++++++++++++++++++++++++++++++++++++ guix/web/view/json.scm | 92 ++++++++++++++++++++++++++++++++++ 2 files changed, 223 insertions(+) create mode 100644 guix/web/view/html.scm create mode 100644 guix/web/view/json.scm (limited to 'guix/web/view') 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