Apply guix style formatting to files.

1 files changed, 193 insertions, 148 deletions

diff --git a/web/webserver.scm b/web/webserver.scm
index 3cfcf50..b5e862c 100755..100644
--- a/web/webserver.scm
+++ b/web/webserver.scm
@@ -1,68 +1,56 @@
-#!/usr/bin/env guile \
--e main -s
-!#
-;; Minimal web server can be started from command line. Current example routes:
-;;
-;;    localhost:8080/
-;;
+(use-modules (json)
+             (ice-9 match)
+             (ice-9 format)
+             (ice-9 iconv)
+             (ice-9 receive)
+             (ice-9 string-fun)
+             (ice-9 exceptions)
+             (srfi srfi-1)
+             (srfi srfi-11)
+             (srfi srfi-19)
+             (srfi srfi-26)
+             (rnrs io ports)
+             (rnrs bytevectors)
+             (web http)
+             (web client)
+             (web request)
+             (web response)
+             (web uri)
+             (fibers web server)
+             (gn cache memoize)
+             (web gn-uri)
+             (gn db sparql)
+             (gn data species)
+             (gn data group)
+             (web sxml)
+             (web view view)
+             (web view doc)
+             (web view markdown))
 
-(use-modules
- (json)
- (ice-9 match)
- (ice-9 format)
- (ice-9 iconv)
- (ice-9 receive)
- (ice-9 string-fun)
- (ice-9 exceptions)
- ;; (ice-9 debugger)
- ;; (ice-9 breakpoints)
- ;; (ice-9 source)
- (srfi srfi-1)
- (srfi srfi-11) ; let-values
- (srfi srfi-19) ; time
- (srfi srfi-26)
- (rnrs io ports) ; bytevector-all
- (rnrs bytevectors)
- (web http)
- (web client)
- (web request)
- (web response)
- (web uri)
- (fibers web server)
- (gn cache memoize)
- (web gn-uri)
- (gn db sparql)
- (gn data species)
- (gn data group)
- (web sxml)
- (web view view)
- (web view doc)
- (web view markdown))
-
-(define info `(
-               ("name" . "GeneNetwork REST API")
-               ("version" . ,get-version)
-               ("comment" . "This is the official REST API for the GeneNetwork service hosted at https://genenetwork.org/")
-               ("license" . (("source code (unless otherwise specified)" . "Affero GNU Public License 3.0 (AGPL3)")
-                             ("data (unless otherwise specified)" . "Attribution-NonCommercial-NoDerivatives 4.0 International (CC BY-NC-ND 4.0)")))
-               ("note" . "This is work in progress (WIP). Note that the final base URL will change! The temporary prefix is:")
-               ("prefix" . ,(prefix))
-               ("links". (("species" . ,(mk-meta "species"))))))
-
-(define info-meta `(
-                    ("doc" . ,(mk-html "info"))
-                    ("API" .
-                     ((,(mk-url "species")."Get a list of all species")
-                      (,(mk-url "mouse")."Get information on mouse")
-                      (,(mk-url "datasets")."Get a list of datasets")))))
+(define info
+  `(("name" . "GeneNetwork REST API") ("version" unquote get-version)
+    ("comment" . "This is the official REST API for the GeneNetwork service hosted at https://genenetwork.org/")
+    ("license"
+     ("source code (unless otherwise specified)" . "Affero GNU Public License 3.0 (AGPL3)")
+     ("data (unless otherwise specified)" . "Attribution-NonCommercial-NoDerivatives 4.0 International (CC BY-NC-ND 4.0)"))
+    ("note" . "This is work in progress (WIP). Note that the final base URL will change! The temporary prefix is:")
+    ("prefix" unquote
+     (prefix))
+    ("links" ("species" unquote
+              (mk-meta "species")))))
 
+(define info-meta
+  `(("doc" unquote
+     (mk-html "info"))
+    ("API" ((unquote (mk-url "species")) . "Get a list of all species")
+     ((unquote (mk-url "mouse")) . "Get information on mouse")
+     ((unquote (mk-url "datasets")) . "Get a list of datasets"))))
 
 (define (get-id-data id)
   "Get data based on identifier id. If it is a taxon return the taxon data,
 otherwise search for set/group data"
-  (let ([taxoninfo (get-expanded-taxon-data id)])
-    (if taxoninfo
-        taxoninfo
+  (let ((taxoninfo (get-expanded-taxon-data id)))
+    (if taxoninfo taxoninfo
         (cdr (get-group-data id)))))
 
 (define (not-found2 request)
@@ -72,70 +60,85 @@ otherwise search for set/group data"
 
 (define (not-found uri)
   (list (build-response #:code 404)
-        (string-append "Resource not found: " (uri->string uri))))
+        (string-append "Resource not found: "
+                       (uri->string uri))))
 
 (define file-mime-types
-  '(("css"  . (text/css))
-    ("js"   . (text/javascript))
-    ("svg"  . (image/svg+xml))
-    ("png"  . (image/png))
-    ("gif"  . (image/gif))
-    ("jpg"  . (image/jpg))
-    ("woff" . (application/font-woff))
-    ("ttf"  . (application/octet-stream))
-    ("map"  . (text/json))
-    ("html" . (text/html))))
+  '(("css" text/css)
+    ("js" text/javascript)
+    ("svg" image/svg+xml)
+    ("png" image/png)
+    ("gif" image/gif)
+    ("jpg" image/jpg)
+    ("woff" application/font-woff)
+    ("ttf" application/octet-stream)
+    ("map" text/json)
+    ("html" text/html)))
 
 (define (file-extension file-name)
   (last (string-split file-name #\.)))
 
-(define* (render-static-image file-name #:key (extra-headers '()))
+(define* (render-static-image file-name
+                              #:key (extra-headers '()))
   (let* ((stat (stat file-name #f))
          (modified (and stat
-                        (make-time time-utc 0 (stat:mtime stat)))))
-    (list `((content-type . ,(assoc-ref file-mime-types
-                                        (file-extension file-name)))
-            (last-modified . ,(time-utc->date modified)))
-          (call-with-input-file file-name get-bytevector-all))))
+                        (make-time time-utc 0
+                                   (stat:mtime stat)))))
+    (list `((content-type unquote
+                          (assoc-ref file-mime-types
+                                     (file-extension file-name)))
+            (last-modified unquote
+                           (time-utc->date modified)))
+          (call-with-input-file file-name
+            get-bytevector-all))))
 
-(define* (render-static-file path #:optional rec #:key (extra-headers '()))
+(define* (render-static-file path
+                             #:optional rec
+                             #:key (extra-headers '()))
   (let* ((stat (stat path #f))
          (modified (and stat
-                        (make-time time-utc 0 (stat:mtime stat)))))
-    (list `((content-type . ,(assoc-ref file-mime-types
-                                        (file-extension path)))
-            (last-modified . ,(time-utc->date modified)))
-          (call-with-input-file path get-bytevector-all))))
+                        (make-time time-utc 0
+                                   (stat:mtime stat)))))
+    (list `((content-type unquote
+                          (assoc-ref file-mime-types
+                                     (file-extension path)))
+            (last-modified unquote
+                           (time-utc->date modified)))
+          (call-with-input-file path
+            get-bytevector-all))))
 
-(define* (render-doc path page #:optional rec #:key (extra-headers '()))
+(define* (render-doc path
+                     page
+                     #:optional rec
+                     #:key (extra-headers '()))
   (list (append extra-headers
-                '((content-type . (text/html))))
+                '((content-type text/html)))
         (lambda (port)
           (sxml->html (view-doc path page rec) port))))
 
-(define* (render-brand path #:optional rec #:key (extra-headers '()))
+(define* (render-brand path
+                       #:optional rec
+                       #:key (extra-headers '()))
   (list (append extra-headers
-                '((content-type . (text/html))))
+                '((content-type text/html)))
         (lambda (port)
           (sxml->html (view-brand path) port))))
 
 (define (render-json json)
-  (list '((content-type . (application/json)))
+  (list '((content-type application/json))
         (lambda (port)
           (scm->json json port))))
 
 (define (render-json-string2 json)
-  (list '((content-type . (text/plain)))
+  (list '((content-type text/plain))
         (lambda (port)
           (format port "~a" "foo"))))
 
 (define (build-json-response status-code json)
-  (list
-   (build-response
-    #:code status-code
-    #:headers `((content-type . (application/json))))
-   (lambda (port)
-     (scm->json json port))))
+  (list (build-response #:code status-code
+                        #:headers `((content-type application/json)))
+        (lambda (port)
+          (scm->json json port))))
 
 (define (decode-request-json body)
   (if (not body)
@@ -143,57 +146,76 @@ otherwise search for set/group data"
       (json-string->scm (utf8->string body))))
 
 (define (decode-query-component component)
-  (let* ([index (string-index component #\=)]
-         [key (if index (substring component 0 index) component)]
-         [value (if index (substring component (1+ index)) "")])
+  (let* ((index (string-index component #\=))
+         (key (if index
+                  (substring component 0 index) component))
+         (value (if index
+                    (substring component
+                               (1+ index)) "")))
     (cons (string->symbol (uri-decode key))
           (uri-decode value))))
 
-(define (edit-file-handler  repo request)
+(define (edit-file-handler repo request)
   (catch 'file-error
-    (lambda ()
-      (let* ((query (uri-query (request-uri request)))
-             (params (if (not query)
-                         '()
-                         (map decode-query-component (string-split query #\&))))
-             (query-path (assoc-ref params 'file_path)))
-        (if query-path
-            (build-json-response 400 (fetch-file repo query-path))
-            (throw 'file-error "Please provide a valid file path in the query"))))
-    (lambda (key . args)
-      (let ((msg (car args))) (build-json-response 400 `(("error" . ,key) ("msg" . ,msg)))))))
+         (lambda ()
+           (let* ((query (uri-query (request-uri request)))
+                  (params (if (not query)
+                              '()
+                              (map decode-query-component
+                                   (string-split query #\&))))
+                  (query-path (assoc-ref params
+                                         'file_path)))
+             (if query-path
+                 (build-json-response 400
+                                      (fetch-file repo query-path))
+                 (throw 'file-error
+                        "Please provide a valid file path in the query"))))
+         (lambda (key . args)
+           (let ((msg (car args)))
+             (build-json-response 400
+                                  `(("error" unquote key)
+                                    ("msg" unquote msg)))))))
 
-(define +global-repo+ (getenv "REPO_PATH"))
+(define +global-repo+
+  (getenv "REPO_PATH"))
 
 (define (invalid-data? data target)
   (if (string? (assoc-ref data target))
       (if (string-null? (assoc-ref data target))
-          (throw 'system-error (format #f "Value for Key *** ~a  *** Cannot be Empty"  target))
+          (throw 'system-error
+                 (format #f "Value for Key *** ~a  *** Cannot be Empty" target))
           (assoc-ref data target))
-      (throw 'system-error (format #f "The Key  *** ~a *** is missing in your  Json Data" target))))
+      (throw 'system-error
+             (format #f "The Key  *** ~a *** is missing in your  Json Data"
+                     target))))
 
 (define (commit-file-handler repo request body)
   (catch 'system-error
-    (lambda ()
-      (let* ((post-data
-              (decode-request-json body))
-             (_ (for-each (lambda (target)
-                            (invalid-data?  post-data target)
-                            ) '("filename" "content" "username" "email" "prev_commit")))
-             (file-name (assoc-ref post-data "filename"))
-             (content  (assoc-ref post-data "content"))
-             (username (assoc-ref post-data "username"))
-             (email   (assoc-ref post-data "email"))
-             (commit-message (assoc-ref post-data "commit_message"))
-             (prev-commit (assoc-ref post-data "prev_commit")))
-        (build-json-response 200
-                             (commit-file repo
-                                          file-name content
-                                          commit-message
-                                          username email
-                                          prev-commit))))
-    (lambda (key . args)
-      (let ((msg (car args))) (build-json-response 400 `(("error" . ,key) ("msg" . ,msg)))))))
+         (lambda ()
+           (let* ((post-data (decode-request-json body))
+                  (_ (for-each (lambda (target)
+                                 (invalid-data? post-data target))
+                               '("filename" "content" "username" "email"
+                                 "prev_commit")))
+                  (file-name (assoc-ref post-data "filename"))
+                  (content (assoc-ref post-data "content"))
+                  (username (assoc-ref post-data "username"))
+                  (email (assoc-ref post-data "email"))
+                  (commit-message (assoc-ref post-data "commit_message"))
+                  (prev-commit (assoc-ref post-data "prev_commit")))
+             (build-json-response 200
+                                  (commit-file repo
+                                               file-name
+                                               content
+                                               commit-message
+                                               username
+                                               email
+                                               prev-commit))))
+         (lambda (key . args)
+           (let ((msg (car args)))
+             (build-json-response 400
+                                  `(("error" unquote key)
+                                    ("msg" unquote msg)))))))
 
 (define (controller request body)
   (match-lambda
@@ -201,21 +223,29 @@ otherwise search for set/group data"
      (render-json info))
     (('GET "version")
      (render-json get-version))
-    (('GET "css" fn )
+    (('GET "css" fn)
      (render-static-file (string-append "css/" fn)))
-    (('GET "map" fn )
+    (('GET "map" fn)
      (render-static-file (string-append "css/" fn)))
     (('GET "static" "images" fn)
      (render-static-image (string-append "static/images/" fn)))
     (('GET "home" path)
      (render-brand path))
     (('GET "doc" "species.html")
-     (render-doc "doc" "species.html" (get-species-meta)))
+     (render-doc "doc" "species.html"
+                 (get-species-meta)))
     (('GET "doc" taxon)
      (match (string->list taxon)
-       [(name ... #\. #\h #\t #\m #\l)
-        (render-doc "doc" taxon (get-expanded-taxon-meta (list->string name)))]))
-    (('GET "doc" path ... page)         ; serve documents from /doc/
+       ((name ...
+              #\.
+              #\h
+              #\t
+              #\m
+              #\l)
+        (render-doc "doc" taxon
+                    (get-expanded-taxon-meta (list->string name))))))
+    (('GET "doc" path ... page)
+      ;serve documents from /doc/
      (render-doc path page))
     (('GET "species.json")
      (render-json (get-species-data)))
@@ -224,16 +254,32 @@ otherwise search for set/group data"
     (('GET "species")
      (render-json (get-species-meta)))
     (('GET "edit")
-     (edit-file-handler +global-repo+  request))
+     (edit-file-handler +global-repo+ request))
     (('POST "commit")
-     (commit-file-handler +global-repo+  request body))
+     (commit-file-handler +global-repo+ request body))
     (('GET id)
-     (let ([names (get-species-shortnames (get-expanded-species))])
+     (let ((names (get-species-shortnames (get-expanded-species))))
        (match (string->list id)
-         [(name ... #\. #\m #\e #\t #\a #\. #\j #\s #\o #\n) (render-json (get-expanded-taxon-meta (list->string name)))]
-         [(name ... #\. #\j #\s #\o #\n) (render-json
-                                          (get-id-data (list->string name)))]
-         [rest (render-json "NOP")])))
+         ((name ...
+                #\.
+                #\m
+                #\e
+                #\t
+                #\a
+                #\.
+                #\j
+                #\s
+                #\o
+                #\n)
+          (render-json (get-expanded-taxon-meta (list->string name))))
+         ((name ...
+                #\.
+                #\j
+                #\s
+                #\o
+                #\n)
+          (render-json (get-id-data (list->string name))))
+         (rest (render-json "NOP")))))
     (_ (not-found (request-uri request)))))
 
 (define (request-path-components request)
@@ -250,8 +296,7 @@ otherwise search for set/group data"
 
 (define (start-web-server address port)
   (format (current-error-port)
-          "GN REST API web server listening on http://~a:~a/~%"
-          address port)
+          "GN REST API web server listening on http://~a:~a/~%" address port)
   ;; Wrap handler in another function to support live hacking via the
   ;; REPL. If handler is passed as is and is then redefined via the
   ;; REPL, the web server will still be using the old handler. The
@@ -267,4 +312,4 @@ otherwise search for set/group data"
   (newline)
   (let ((listen (inexact->exact (string->number (car (cdr args))))))
     (display `("listening on" ,listen))
-    (start-web-server  "127.0.0.1" listen)))
+    (start-web-server "127.0.0.1" listen)))