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.

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