Apply guix style formatting to files.

2 files changed, 273 insertions, 200 deletions

diff --git a/web/view/markdown.scm b/web/view/markdown.scm
index fd8838f..653596f 100644
--- a/web/view/markdown.scm
+++ b/web/view/markdown.scm
@@ -16,89 +16,117 @@
   #:use-module (web sxml)
   #:use-module (commonmark)
 
-  #:export (markdown-file->sxml
-            markdown-github->sxml
-            fetch-file
-            fetch-raw-file
-            commit-file))
-
+  #:export (markdown-file->sxml markdown-github->sxml fetch-file
+                                fetch-raw-file commit-file))
 
 (define (markdown-file->sxml fn)
   "Parse a local file"
-  (commonmark->sxml
-   (call-with-input-file fn
-     get-string-all)))
+  (commonmark->sxml (call-with-input-file fn
+                      get-string-all)))
 
 (define (fetch-raw-file url)
   (receive (response-status response-body)
-      (http-request url)
-    response-body))
+           (http-request url) response-body))
 
 ;; https://github.com/genenetwork/gn-docs/master/general/brand/aging/home.md
 ;; https://raw.githubusercontent.com/genenetwork/gn-docs/master/general/brand/aging/home.md
 ;; https://github.com/genenetwork/gn-docs/edit/master/general/brand/aging/home.md
 
 (define (form-github-raw-url project repo page)
-  (string-append "https://raw.githubusercontent.com/" project "/" repo "/master/" (string-join page "/")))
+  (string-append "https://raw.githubusercontent.com/"
+                 project
+                 "/"
+                 repo
+                 "/master/"
+                 (string-join page "/")))
 
 (define (form-github-edit-url project repo page)
-  (string-append "https://github.com/" project "/" repo "/edit/master/" (string-join page "/")))
+  (string-append "https://github.com/"
+                 project
+                 "/"
+                 repo
+                 "/edit/master/"
+                 (string-join page "/")))
 
 (define (markdown-github->sxml path)
   "Parse a github markdown file that is formed like genenetwork/gn-docs/general/brand/aging/home.md"
-  (match-let (((project repo page ...) (string-split path #\/)))
-    `(div (@ (class "markdown"))
-          ,(commonmark->sxml
-            (fetch-raw-file (pk (form-github-raw-url project repo (pk page)))))
-          (p
-           (div (@ (class "button-align-right"))
-                (a (@ (href ,(form-github-edit-url project repo page)) (role "button")) "edit")))
-          (br)
-          (br))))
+  (match-let (((project repo page ...)
+               (string-split path #\/)))
+             `(div (@ (class "markdown"))
+                   ,(commonmark->sxml (fetch-raw-file (pk (form-github-raw-url
+                                                           project repo
+                                                           (pk page)))))
+                   (p (div (@ (class "button-align-right"))
+                           (a (@ (href ,(form-github-edit-url project repo
+                                                              page))
+                                 (role "button")) "edit")))
+                   (br)
+                   (br))))
 
 (define (fetch-file repo query-path)
-  (let* ( (abs-path (format #f "~a/~a" repo query-path)))
-    (if (file-exists? abs-path)  (let* ((full-path (canonicalize-path abs-path))
-                                        (content (call-with-input-file full-path get-string-all))
-                                        (commit-sha (get-latest-commit-sha1 repo)))
-                                   `(("file_path" . ,query-path)
-                                     ("content" . ,content)
-                                     ("hash" . ,commit-sha))
-                                   ) (throw 'file-error  (format #f "~a does not exists" abs-path)))))
+  (let* ((abs-path (format #f "~a/~a" repo query-path)))
+    (if (file-exists? abs-path)
+        (let* ((full-path (canonicalize-path abs-path))
+               (content (call-with-input-file full-path
+                          get-string-all))
+               (commit-sha (get-latest-commit-sha1 repo)))
+          `(("file_path" unquote query-path)
+            ("content" unquote content)
+            ("hash" unquote commit-sha)))
+        (throw 'file-error
+               (format #f "~a does not exists" abs-path)))))
 
 (define (git-invoke repo-path . args)
   (apply system* "git" "-C" repo-path args))
 
 (define (git-repository? repo-path)
-  (let ((data (git-invoke repo-path  "rev-parse")))
+  (let ((data (git-invoke repo-path "rev-parse")))
     (zero? data)))
 
 (define (get-latest-commit-sha1 repo-path)
-  (let* ((output-port (open-input-pipe (string-append "git -C " repo-path " log -n 1 --pretty=format:%H HEAD")))
+  (let* ((output-port (open-input-pipe (string-append "git -C " repo-path
+                                        " log -n 1 --pretty=format:%H HEAD")))
          (commit-sha (read-line output-port)))
-    (close-port output-port)
-    commit-sha))
+    (close-port output-port) commit-sha))
 
-(define* (commit-file repo file-path content commit-message username email #:optional (prev-commit ""))
-  (unless (string=? prev-commit (get-latest-commit-sha1 repo))
-    (throw 'system-error (format #f "Commits do no match.Please pull in latest  changes for current * ~a * and prev * ~a * "
-                                 (get-latest-commit-sha1 repo) prev-commit)))
+(define* (commit-file repo
+                      file-path
+                      content
+                      commit-message
+                      username
+                      email
+                      #:optional (prev-commit ""))
+  (unless (string=? prev-commit
+                    (get-latest-commit-sha1 repo))
+    (throw 'system-error
+           (format #f
+            "Commits do no match.Please pull in latest  changes for current * ~a * and prev * ~a * "
+            (get-latest-commit-sha1 repo) prev-commit)))
   (if (git-repository? repo)
       (match (file-exists? (format #f "~a/~a" repo file-path))
-        (#t
-         (with-output-to-file (format #f "~a/~a" repo file-path)
-           (lambda ()
-             (display content)))
+        (#t (with-output-to-file (format #f "~a/~a" repo file-path)
+              (lambda ()
+                (display content)))
          (let* ((git-add-file (git-invoke repo "add" file-path))
-                (git-commit-file
-                 (git-invoke repo "commit"
-                             "-m" commit-message
-                             "-m" " * Commit made via the GN Markdown Editor"
-                             "--author" (format  #f "~a <~a>" username  email)))
+                (git-commit-file (git-invoke repo
+                                  "commit"
+                                  "-m"
+                                  commit-message
+                                  "-m"
+                                  " * Commit made via the GN Markdown Editor"
+                                  "--author"
+                                  (format #f "~a <~a>" username email)))
                 (git-commit-sha (get-latest-commit-sha1 repo)))
            (if (zero? git-commit-file)
-               `(("status" . "201") ("message" . "committed file successfully") ("content" . ,content) ("commit_sha" . ,git-commit-sha) ("commit_message" . ,commit-message) )
-               `(("status" . "200") ("message" . "Nothing to commit, working tree clean") ("commit_sha" . ,git-commit-sha)))))
-        (#f
-         (throw 'system-error (format #f "~a File does not exist error" file-path))))
-      (throw 'system-error (format #f  "~a is no a git repo" repo))))
+               `(("status" . "201")
+                 ("message" . "committed file successfully")
+                 ("content" unquote content)
+                 ("commit_sha" unquote git-commit-sha)
+                 ("commit_message" unquote commit-message))
+               `(("status" . "200")
+                 ("message" . "Nothing to commit, working tree clean")
+                 ("commit_sha" unquote git-commit-sha)))))
+        (#f (throw 'system-error
+                   (format #f "~a File does not exist error" file-path))))
+      (throw 'system-error
+             (format #f "~a is no a git repo" repo))))
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)))