aboutsummaryrefslogtreecommitdiff
path: root/web/webserver.scm
diff options
context:
space:
mode:
Diffstat (limited to 'web/webserver.scm')
-rw-r--r--[-rwxr-xr-x]web/webserver.scm341
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)))
generated by cgit v1.2.3 (git 2.44.0) at 2024-11-10 15:10:02 +0000