aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xweb/webserver.scm126
1 files changed, 57 insertions, 69 deletions
diff --git a/web/webserver.scm b/web/webserver.scm
index a44181c..72984a1 100755
--- a/web/webserver.scm
+++ b/web/webserver.scm
@@ -37,26 +37,25 @@
(web sxml)
(web view view)
(web view doc)
- (web view markdown)
- )
+ (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"))))))
+ ("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")))))
+ ("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 (get-id-data id)
@@ -98,19 +97,19 @@ otherwise search for set/group data"
(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))))
+ (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))))
(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))))
+ (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))))
(define* (render-doc path page #:optional rec #:key (extra-headers '()))
(list (append extra-headers
@@ -131,8 +130,8 @@ otherwise search for set/group data"
(define (render-json-string2 json)
(list '((content-type . (text/plain)))
- (lambda (port)
- (format port "~a" "foo"))))
+ (lambda (port)
+ (format port "~a" "foo"))))
(define (build-json-response status_code json)
@@ -141,8 +140,7 @@ otherwise search for set/group data"
#:code status_code
#:headers `((content-type . (application/json))))
(lambda (port)
- (scm->json json port)))
- )
+ (scm->json json port))))
(define (decode-query query)
(if (not query)
@@ -152,7 +150,7 @@ otherwise search for set/group data"
(define (decode-request-json body)
(if (not body)
'()
- (json-string->scm (utf8->string body))))
+ (json-string->scm (utf8->string body))))
(define (decode-query-component component)
@@ -166,52 +164,43 @@ otherwise search for set/group data"
(catch 'file-error
(lambda ()
(let* ((params (decode-query (uri-query (request-uri request)))) (query_path (assoc-ref params 'file_path)))
- (if query_path
- (build-json-response 400 (fetch-file repo query_path))
- (throw 'file-error (string-append "Please provide a valid file path in the query")))
- )
- )
+ (if query_path
+ (build-json-response 400 (fetch-file repo query_path))
+ (throw 'file-error (string-append "Please provide a valid file path in the query")))))
(lambda (key . args)
- (let ((msg (car args))) (build-json-response 400 `(("error" . ,key) ("msg" . ,msg))))
- )))
+ (let ((msg (car args))) (build-json-response 400 `(("error" . ,key) ("msg" . ,msg)))))))
-(define global-repo (getenv "REPO_PATH")) ;; handle this better way
+(define global-repo (getenv "REPO_PATH"))
(define (is-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))
- (assoc-ref data target)
- )
- (throw 'system-error (format #f "The Key *** ~a *** is missing in your Json Data" 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))))
(define (commit-file-handler repo request body)
(catch 'system-error
(lambda ()
(let* ((post-data
- (decode-request-json body)
- )
- (_ (for-each (lambda (target)
- (is-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))))
+ (decode-request-json body))
+ (_ (for-each (lambda (target)
+ (is-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))))
- )) )
+ (let ((msg (car args))) (build-json-response 400 `(("error" . ,key) ("msg" . ,msg)))))))
(define (controller request body)
(match-lambda
(('GET)
@@ -232,7 +221,7 @@ otherwise search for set/group data"
(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/
+ (('GET "doc" path ... page) ; serve documents from /doc/
(render-doc path page))
(('GET "species.json")
(render-json (get-species-data)))
@@ -243,16 +232,15 @@ otherwise search for set/group data"
(('GET "edit")
(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))])
(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
+ [(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)))
- ))
+ [rest (render-json "NOP")])))
+ (_ (not-found (request-uri request)))))
(define (request-path-components request)
(split-and-decode-uri-path (uri-path (request-uri request))))