summaryrefslogtreecommitdiff
path: root/scripts
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2014-08-07 17:45:27 -0400
committerDavid Thompson <dthompson2@worcester.edu>2014-08-07 17:45:27 -0400
commitd866718649a385bdf3366783d9fdbed5a2630f92 (patch)
tree63b79bc71e485bb677212c672c854984ec7ea795 /scripts
parent2804e28ef22ded73a95da4508f7630db1db3c97d (diff)
Move guix-web to scripts directory.
* README.md ("Use"): Update. * guix-web: Moved. * pre-inst-env: New file. * scripts/guix-web: New file.
Diffstat (limited to 'scripts')
-rwxr-xr-xscripts/guix-web265
1 files changed, 265 insertions, 0 deletions
diff --git a/scripts/guix-web b/scripts/guix-web
new file mode 100755
index 0000000..e28ce1e
--- /dev/null
+++ b/scripts/guix-web
@@ -0,0 +1,265 @@
+#!/usr/bin/guile
+!#
+
+;;; 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/>.
+
+(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))))))
+
+(spawn-server (make-tcp-server-socket #:port 37146))
+(run-server (lambda args (apply handler args))
+ 'http
+ `(#:addr ,INADDR_ANY
+ #:port 8080))
+
+;;; Local Variables:
+;;; mode: scheme
+;;; End:
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-21 21:22:21 +0000