diff options
| -rwxr-xr-x | web/webserver.scm | 126 |
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)))) |