summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix-web/config.scm38
-rw-r--r--guix-web/controller.scm37
-rw-r--r--guix-web/render.scm51
-rw-r--r--guix-web/server.scm75
-rw-r--r--guix-web/view.scm156
-rwxr-xr-xscripts/guix-web243
6 files changed, 361 insertions, 239 deletions
diff --git a/guix-web/config.scm b/guix-web/config.scm
new file mode 100644
index 0000000..0ca28cd
--- /dev/null
+++ b/guix-web/config.scm
@@ -0,0 +1,38 @@
+;;; 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)
+ #:use-module (guix-web server)
+ #:export (guix-web-asset-dir
+ guix-web-router))
+
+(define guix-web-asset-dir (getcwd))
+
+(define (guix-web-router path)
+ (match path
+ ((GET)
+ (redirect '("packages")))
+ ((GET "packages")
+ (render-html (all-packages)))
+ ((GET "packages.json")
+ (render-json (all-packages-json)))
+ ((GET "package" name)
+ (render-html (view-package name)))
+ ((GET "librejs")
+ (render-html (librejs)))
+ (_ #f)))
diff --git a/guix-web/controller.scm b/guix-web/controller.scm
new file mode 100644
index 0000000..6640810
--- /dev/null
+++ b/guix-web/controller.scm
@@ -0,0 +1,37 @@
+;;; 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 (web request)
+ #:use-module (guix-web render)
+ #:use-module (guix-web view)
+ #:export (controller))
+
+(define (controller path)
+ (match path
+ ((GET)
+ (redirect '("packages")))
+ ((GET "packages")
+ (render-html (all-packages)))
+ ((GET "packages.json")
+ (render-json (all-packages-json)))
+ ((GET "package" name)
+ (render-html (view-package name)))
+ ((GET "librejs")
+ (render-html (librejs)))
+ (_ #f)))
diff --git a/guix-web/render.scm b/guix-web/render.scm
new file mode 100644
index 0000000..de5da7c
--- /dev/null
+++ b/guix-web/render.scm
@@ -0,0 +1,51 @@
+;;; 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 (web response)
+ #:use-module (web uri)
+ #:use-module (sxml simple)
+ #:use-module (json)
+ #:export (render-html
+ render-json
+ not-found
+ redirect))
+
+(define (render-html sxml)
+ (list '((content-type . (text/html)))
+ (lambda (port)
+ (display "<!DOCTYPE html>" port)
+ (sxml->xml 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 (redirect path)
+ (let ((uri (build-uri 'http
+ #: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..49c6a07
--- /dev/null
+++ b/guix-web/server.scm
@@ -0,0 +1,75 @@
+;;; 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 binary-ports)
+ #: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)
+ #:export (start-guix-web))
+
+(define (file-extension file-name)
+ (last (string-split file-name #\.)))
+
+(define (directory? filename)
+ (string=? filename (dirname filename)))
+
+(define file-mime-types
+ '(("css" . (text/css))
+ ("js" . (text/javascript))
+ ("png" . (image/png))))
+
+(define (request-path-components request)
+ (split-and-decode-uri-path (uri-path (request-uri request))))
+
+(define (serve-static-asset request)
+ (let ((filename (string-join
+ (cons guix-web-asset-dir
+ (request-path-components request))
+ "/")))
+ (and (file-exists? filename)
+ (not (directory? filename))
+ (list `((content-type . ,(assoc-ref file-mime-types
+ (file-extension filename))))
+ (call-with-input-file filename get-bytevector-all)))))
+
+(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
+ (or (run-controller controller request)
+ (serve-static-asset request)
+ (not-found (request-uri request)))
+ (list controller))))
+
+(define (start-guix-web controller)
+ (run-server (lambda args (apply handler args))
+ 'http
+ `(#:addr ,INADDR_ANY
+ #:port 8080)
+ controller))
diff --git a/guix-web/view.scm b/guix-web/view.scm
new file mode 100644
index 0000000..35cce29
--- /dev/null
+++ b/guix-web/view.scm
@@ -0,0 +1,156 @@
+;;; 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 view)
+ #:use-module (json)
+ #:use-module (guix licenses)
+ #:use-module (guix packages)
+ #:use-module (gnu packages)
+ #:export (all-packages
+ all-packages-json
+ view-package
+ librejs))
+
+(define javascripts
+ '("/js/underscore.js"
+ "/js/mithril.js"
+ "/js/guix-packages.js"))
+
+(define (script-tag src)
+ `(script (@ (type "text/javascript")
+ (src ,src))
+ ;; hack to ensure closing </script> tag
+ ""))
+
+(define (main-layout subtitle body)
+ `(html
+ (head
+ (title ,(string-append "GNU Guix - " subtitle))
+ (link (@ (rel "stylesheet")
+ (href "/css/bootstrap.css"))))
+ (body
+ (div (@ (class "container"))
+ (image (@ (src "/images/logo.png")))
+ ,@body
+ (footer
+ (small
+ (a (@ (href "/librejs")
+ (rel "jslicense"))
+ "JavaScript license information")))))))
+
+(define (all-packages-json)
+ (define (serialize-license package)
+ (define (serialize license)
+ (json
+ (object
+ ("name" ,(license-name license))
+ ("uri" ,(license-uri license)))))
+ (let ((license (package-license package)))
+ (cond
+ ((list? license)
+ (map serialize license))
+ ((license? license)
+ (serialize license))
+ (else #f))))
+
+ (json
+ ,(map (lambda (p)
+ (json
+ (object
+ ("name" ,(package-name p))
+ ("version" ,(package-version p))
+ ("synopsis" ,(package-synopsis p))
+ ("description" ,(package-description p))
+ ("homepage" ,(package-home-page p))
+ ("license" ,(serialize-license p)))))
+ (fold-packages cons '()))))
+
+(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"
+ `((div (@ (id "guix")) "")
+ ,@(map script-tag javascripts))))
+
+(define (view-package name)
+ (define (describe-package package)
+ `(dl
+ (dt "Version")
+ (dd ,(package-version package))
+ (dt "Synopsis")
+ (dd ,(package-synopsis package))
+ (dt "Description")
+ (dd ,(package-description package))
+ (dt "License")
+ (dd ,(render-package-license package))))
+
+ (let ((packages (find-packages-by-name name)))
+ (define (format-package-count)
+ (let ((count (length packages)))
+ (format #f "~d ~a"
+ count
+ (if (> count 1)
+ "versions"
+ "version"))))
+
+ (main-layout
+ name
+ `((h1 ,name (span (@ (class "badge"))
+ ,(format-package-count)))
+ (ul (@ (class "list-unstyled"))
+ ,@(map (lambda (p)
+ `(li ,(describe-package p)))
+ packages))))))
+
+(define (librejs)
+ (define (weblabel js)
+ `(tr
+ (td
+ (a (@ (href ,js))
+ ,(basename js)))
+ (td
+ (a (@ (href "http://www.gnu.org/licenses/agpl-3.0.html"))
+ ,(license-name agpl3+)))
+ (td
+ (a (@ (href ,js))
+ ,(basename js)))))
+
+ (main-layout
+ "LibreJS"
+ `((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/scripts/guix-web b/scripts/guix-web
index e28ce1e..9d984bb 100755
--- a/scripts/guix-web
+++ b/scripts/guix-web
@@ -18,247 +18,12 @@
;;; License along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
-(use-modules (ice-9 rdelim)
- (ice-9 match)
- (ice-9 binary-ports)
- (srfi srfi-1)
- (srfi srfi-26)
- ((system repl server)
- #:select (spawn-server make-tcp-server-socket))
- (web http)
- (web request)
- (web response)
- (web server)
- (web uri)
- (guix packages)
- (guix licenses)
- (gnu packages)
- (sxml simple)
- (json))
-
-;;;
-;;; Framework
-;;;
-
-(define (file-extension file-name)
- (last (string-split file-name #\.)))
-
-(define (directory? filename)
- (string=? filename (dirname filename)))
-
-(define asset-dir ".")
-
-(define file-mime-types
- '(("css" . (text/css))
- ("js" . (text/javascript))
- ("png" . (image/png))))
-
-(define (serve-static-asset request)
- (let ((filename (string-join
- (cons asset-dir (request-path-components request))
- "/")))
- (and (file-exists? filename)
- (not (directory? filename))
- (list `((content-type . ,(assoc-ref file-mime-types
- (file-extension filename))))
- (call-with-input-file filename get-bytevector-all)))))
-
-(define (render-html sxml)
- (list '((content-type . (text/html)))
- (lambda (port)
- (display "<!DOCTYPE html>" port)
- (sxml->xml sxml port))))
-
-(define (render-json json)
- (list '((content-type . (application/json)))
- (lambda (port)
- (scm->json json port))))
-
-(define (request-path-components request)
- (split-and-decode-uri-path (uri-path (request-uri request))))
-
-(define (not-found request)
- (list (build-response #:code 404)
- (string-append "Resource not found: "
- (uri->string (request-uri request)))))
-
-(define (redirect path)
- (let ((uri (build-uri 'http
- #: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)))))
-
-(define (handler request body)
- (format #t "~a ~a\n"
- (request-method request)
- (uri-path (request-uri request)))
- (apply values
- (or (run-route request)
- (serve-static-asset request)
- (not-found request))))
-
-;;;
-;;; JavaScript
-;;;
-
-(define (script-tag src)
- `(script (@ (type "text/javascript")
- (src ,src))
- ;; hack to ensure closing </script> tag
- ""))
-
-;;;
-;;; Application
-;;;
-
-(define javascripts
- '("/js/underscore.js"
- "/js/mithril.js"
- "/js/guix-packages.js"))
-
-(define (run-route request)
- (match (cons (request-method request)
- (request-path-components request))
- ((GET)
- (redirect '("packages")))
- ((GET "packages")
- (render-html (all-packages)))
- ((GET "packages.json")
- (render-json (all-packages-json)))
- ((GET "package" name)
- (render-html (view-package name)))
- ((GET "librejs")
- (render-html (librejs)))
- (_ #f)))
-
-(define (all-packages-json)
- (define (serialize-license package)
- (define (serialize license)
- (json
- (object
- ("name" ,(license-name license))
- ("uri" ,(license-uri license)))))
- (let ((license (package-license package)))
- (cond
- ((list? license)
- (map serialize license))
- ((license? license)
- (serialize license))
- (else #f))))
-
- (json
- ,(map (lambda (p)
- (json
- (object
- ("name" ,(package-name p))
- ("version" ,(package-version p))
- ("synopsis" ,(package-synopsis p))
- ("description" ,(package-description p))
- ("homepage" ,(package-home-page p))
- ("license" ,(serialize-license p)))))
- (fold-packages cons '()))))
-
-(define (main-layout subtitle body)
- `(html
- (head
- (title ,(string-append "GNU Guix - " subtitle))
- (link (@ (rel "stylesheet")
- (href "/css/bootstrap.css"))))
- (body
- (div (@ (class "container"))
- (image (@ (src "/images/logo.png")))
- ,@body
- (footer
- (small
- (a (@ (href "/librejs")
- (rel "jslicense"))
- "JavaScript license information")))))))
-
-(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"
- `((div (@ (id "guix")) "")
- ,@(map script-tag javascripts))))
-
-(define (view-package name)
- (define (describe-package package)
- `(dl
- (dt "Version")
- (dd ,(package-version package))
- (dt "Synopsis")
- (dd ,(package-synopsis package))
- (dt "Description")
- (dd ,(package-description package))
- (dt "License")
- (dd ,(render-package-license package))))
-
- (let ((packages (find-packages-by-name name)))
- (define (format-package-count)
- (let ((count (length packages)))
- (format #f "~d ~a"
- count
- (if (> count 1)
- "versions"
- "version"))))
-
- (main-layout
- name
- `((h1 ,name (span (@ (class "badge"))
- ,(format-package-count)))
- (ul (@ (class "list-unstyled"))
- ,@(map (lambda (p)
- `(li ,(describe-package p)))
- packages))))))
-
-(define (librejs)
- (define (weblabel js)
- `(tr
- (td
- (a (@ (href ,js))
- ,(basename js)))
- (td
- (a (@ (href "http://www.gnu.org/licenses/agpl-3.0.html"))
- ,(license-name agpl3+)))
- (td
- (a (@ (href ,js))
- ,(basename js)))))
-
- (main-layout
- "LibreJS"
- `((h1 "JavaScript License Information")
- (table (@ (id "jslicense-labels1")
- (class "table"))
- (thead
- (tr
- (th "URI")
- (th "License")
- (th "Source Code")))
- (tbody ,@(map weblabel javascripts))))))
+(use-modules ((system repl server))
+ (guix-web controller)
+ (guix-web server))
(spawn-server (make-tcp-server-socket #:port 37146))
-(run-server (lambda args (apply handler args))
- 'http
- `(#:addr ,INADDR_ANY
- #:port 8080))
+(start-guix-web controller)
;;; Local Variables:
;;; mode: scheme