From d572ce5ed2a34b42a0a3748925f3e5756f0ac4e2 Mon Sep 17 00:00:00 2001 From: Alexander_Kabui Date: Wed, 7 Aug 2024 18:00:18 +0300 Subject: Apply guix style formatting to files. --- web/webserver.scm | 341 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 193 insertions(+), 148 deletions(-) mode change 100755 => 100644 web/webserver.scm (limited to 'web/webserver.scm') diff --git a/web/webserver.scm b/web/webserver.scm old mode 100755 new mode 100644 index 3cfcf50..b5e862c --- 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))) -- cgit v1.2.3