diff options
| -rw-r--r-- | Makefile.am | 3 | ||||
| -rw-r--r-- | guix-web/controller.scm | 3 | ||||
| -rw-r--r-- | guix-web/view/html.scm (renamed from guix-web/view.scm) | 70 | ||||
| -rw-r--r-- | guix-web/view/json.scm | 92 |
4 files changed, 99 insertions, 69 deletions
diff --git a/Makefile.am b/Makefile.am index 74b731a..ff6692a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -27,7 +27,8 @@ SOURCES = \ guix-web/render.scm \ guix-web/server.scm \ guix-web/util.scm \ - guix-web/view.scm + guix-web/view/html.scm \ + guix-web/view/json.scm EXTRA_DIST += env.in diff --git a/guix-web/controller.scm b/guix-web/controller.scm index 490c80f..b3104fe 100644 --- a/guix-web/controller.scm +++ b/guix-web/controller.scm @@ -21,7 +21,8 @@ #:use-module (web request) #:use-module (gnu packages) #:use-module (guix-web render) - #:use-module (guix-web view) + #:use-module (guix-web view html) + #:use-module (guix-web view json) #:use-module (guix-web package) #:export (controller)) diff --git a/guix-web/view.scm b/guix-web/view/html.scm index 559d275..4331692 100644 --- a/guix-web/view.scm +++ b/guix-web/view/html.scm @@ -1,5 +1,5 @@ ;;; guix-web - Web interface for GNU Guix -;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; 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 @@ -15,12 +15,11 @@ ;;; License along with this program. If not, see ;;; <http://www.gnu.org/licenses/>. -(define-module (guix-web view) +(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 (json) #:use-module (web uri) #:use-module (guix licenses) #:use-module (guix packages) @@ -28,11 +27,8 @@ #:use-module (gnu packages) #:use-module (guix-web package) #:export (all-packages - all-packages-json view-package - view-package-json - librejs - generations-json)) + librejs)) (define-record-type <javascript> (javascript source-uri license) @@ -79,48 +75,6 @@ (href "/css/guix.css")))) (body ,body))) -(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))) - ("native-inputs" ,(serialize-inputs - (package-native-inputs package))) - ("propagated-inputs" ,(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 (render-package-license package) (define (license-link license) `(a (@ (href ,(license-uri license))) @@ -221,21 +175,3 @@ (th "License") (th "Source Code"))) (tbody ,@(map weblabel javascripts)))))) - -(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*))) diff --git a/guix-web/view/json.scm b/guix-web/view/json.scm new file mode 100644 index 0000000..fd279ad --- /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))) + ("native-inputs" ,(serialize-inputs + (package-native-inputs package))) + ("propagated-inputs" ,(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*))) |