summaryrefslogtreecommitdiff
path: root/scripts
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2014-08-07 21:20:32 -0400
committerDavid Thompson <dthompson2@worcester.edu>2014-08-07 21:20:32 -0400
commitd5fa21bd3887197cf5e4387f787e44872e42e671 (patch)
tree63243014fc0aa094a6d608dc624fabdb16451fe1 /scripts
parentd866718649a385bdf3366783d9fdbed5a2630f92 (diff)
Break guix-web script into many modules.
* guix-web/config.scm: New file. * guix-web/controller.scm: New file. * guix-web/render.scm: New file. * guix-web/server.scm: New file. * guix-web/view.scm: New file. * scripts/guix-web: Remove extracted code.
Diffstat (limited to 'scripts')
-rwxr-xr-xscripts/guix-web243
1 files changed, 4 insertions, 239 deletions
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
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-21 22:05:56 +0000