diff options
Diffstat (limited to 'web')
| -rw-r--r-- | web/.guix-shell | 8 | ||||
| -rw-r--r-- | web/css/gn-template-style.css | 39 | ||||
| -rw-r--r-- | web/templates/genenetwork.scm | 18 | ||||
| -rw-r--r-- | web/view/markdown.scm | 29 | ||||
| -rw-r--r-- | web/view/view.scm | 4 | ||||
| -rw-r--r-- | web/webserver.scm | 156 |
6 files changed, 177 insertions, 77 deletions
diff --git a/web/.guix-shell b/web/.guix-shell deleted file mode 100644 index b4aee2a..0000000 --- a/web/.guix-shell +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/bash -# -# run with options '-- ./webserver.scm 8091' e.g. -# . .guix-shell -- guile -L .. --fresh-auto-compile --listen=1970 -e main ./webserver.scm 8091 - -echo "Note run: running web-server" - -guix shell guile guile-commonmark guile-fibers guile-json guile-gnutls guile-readline guile-redis openssl nss-certs $* diff --git a/web/css/gn-template-style.css b/web/css/gn-template-style.css new file mode 100644 index 0000000..38893c6 --- /dev/null +++ b/web/css/gn-template-style.css @@ -0,0 +1,39 @@ +* { + box-sizing: border-box; +} + +body { + margin: 0.7em; + display: grid; + grid-template-columns: 9fr 1fr; + grid-gap: 20px; + + font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; + font-style: normal; + font-size: 20px; +} + +#header { + grid-column-start: 1; + grid-column-end: 3; + + background-color: #336699; + color: #FFFFFF; + border-radius: 3px; + min-height: 30px; +} + +#header #header-text { + padding-left: 0.2em; +} + +#main { + grid-column-start: 1; + grid-column-end: 2; + + max-width: 650px; +} + +#main img { + max-width: 650px; +} diff --git a/web/templates/genenetwork.scm b/web/templates/genenetwork.scm new file mode 100644 index 0000000..64e9852 --- /dev/null +++ b/web/templates/genenetwork.scm @@ -0,0 +1,18 @@ +(define-module (web templates genenetwork) + #:use-module (web view markdown) + + #:export (default-gn-template)) + +(define* (default-gn-template path #:optional (title "Default Page Template")) + "Render `PATH' with a default template and styling that fits in with + GeneNetwork's look and feel." + `(html + (head + (meta (@ (charset "UTF-8"))) + (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0"))) + (title ,title) + (link (@ (rel "stylesheet") (type "text/css") + (href "/css/gn-template-style.css")))) + (body + (header (@ (id "header")) (span (@ (id "header-text")) "GeneNetwork")) + (main (@ (id "main")) ,(markdown-github->sxml path))))) diff --git a/web/view/markdown.scm b/web/view/markdown.scm index 653596f..6aa2935 100644 --- a/web/view/markdown.scm +++ b/web/view/markdown.scm @@ -15,9 +15,8 @@ #:use-module (web request) #:use-module (web sxml) #:use-module (commonmark) - #:export (markdown-file->sxml markdown-github->sxml fetch-file - fetch-raw-file commit-file)) + fetch-raw-file commit-file git-invoke)) (define (markdown-file->sxml fn) "Parse a local file" @@ -26,26 +25,26 @@ (define (fetch-raw-file url) (receive (response-status 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 + (http-request url) response-body)) -(define (form-github-raw-url project repo page) +(define* (form-github-raw-url project repo page #:optional (branch "master")) (string-append "https://raw.githubusercontent.com/" project "/" repo - "/master/" + "/" + branch + "/" (string-join page "/"))) -(define (form-github-edit-url project repo page) +(define* (form-github-edit-url project repo page #:optional (branch "master")) (string-append "https://github.com/" project "/" repo - "/edit/master/" + "/edit/" + branch + "/" (string-join page "/"))) (define (markdown-github->sxml path) @@ -120,12 +119,12 @@ (if (zero? git-commit-file) `(("status" . "201") ("message" . "committed file successfully") - ("content" unquote content) - ("commit_sha" unquote git-commit-sha) - ("commit_message" unquote commit-message)) + ("content" . ,content) + ("commit_sha" . ,git-commit-sha) + ("commit_message" . ,commit-message)) `(("status" . "200") ("message" . "Nothing to commit, working tree clean") - ("commit_sha" unquote git-commit-sha))))) + ("commit_sha" . ,git-commit-sha))))) (#f (throw 'system-error (format #f "~a File does not exist error" file-path)))) (throw 'system-error diff --git a/web/view/view.scm b/web/view/view.scm index 4584cf8..4300863 100644 --- a/web/view/view.scm +++ b/web/view/view.scm @@ -10,6 +10,7 @@ #:use-module (web view markdown) #:use-module (web view brand msk) #:use-module (web view brand aging) + #:use-module (web templates genenetwork) #:export (view-brand)) @@ -45,6 +46,9 @@ data to benefit from the power of integrated datasets, please contact:") (define* (view-brand path) (match path ("aging" (view-aging)) + ("gnqa" (default-gn-template + "genenetwork/gn-docs/general/brand/gnqa/gnqa.md" + "GeneNetwork Question and Answer System")) ( _ (msk-html #:info `( ,(markdown-github->sxml "genenetwork/gn-docs/general/brand/msk/home.md") diff --git a/web/webserver.scm b/web/webserver.scm index 145f192..e0b0ea6 100644 --- a/web/webserver.scm +++ b/web/webserver.scm @@ -7,6 +7,7 @@ (ice-9 exceptions) (srfi srfi-1) (srfi srfi-11) + (srfi srfi-13) (srfi srfi-19) (srfi srfi-26) (rnrs io ports) @@ -16,33 +17,45 @@ (web request) (web response) (web uri) - (fibers web server) + (web server) (gn cache memoize) (web gn-uri) (gn db sparql) + (gn data dataset) (gn data species) (gn data group) + (gn runner gemma) (web sxml) (web view view) (web view doc) (web view markdown)) +(define (get-extension filename) + (let ((dot-pos (string-rindex filename #\.))) + (if dot-pos + (substring filename dot-pos) ""))) + +(define +current-repo-path+ + (getenv "CURRENT_REPO_PATH")) + +(define +cgit-repo-path+ + (getenv "CGIT_REPO_PATH")) + (define +info+ - `(("name" . "GeneNetwork REST API") ("version" unquote get-version) + `(("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"))))) + ("prefix" . ,(prefix)) + ("links" ("species" . ,(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")))) + `(("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) "Get data based on identifier id. If it is a taxon return the taxon data, @@ -51,6 +64,20 @@ otherwise search for set/group data" (if taxoninfo taxoninfo (cdr (get-group-data id))))) +(define (get-bxd-publish) + "Return a list of published datasets by their record ID. We add the dataset ID and phenotype ID for quick reference" + (list->vector (get-bxd-publish-list))) + +(define* (get-bxd-publish-dataid-values dataid #:optional used-for-mapping?) + (get-bxd-publish-dataid-name-value-dict dataid used-for-mapping?)) + +(define* (get-bxd-publish-values dataid #:optional used-for-mapping?) + (get-bxd-publish-name-value-dict dataid used-for-mapping?)) + +(define (get-gene-aliases genename) + "Return a vector of aliases for genename." + (list->vector (memo-sparql-wd-gene-aliases (memo-sparql-wd-geneids genename)))) + (define (not-found2 request) (values (build-response #:code 404) (string-append "Resource X not found: " @@ -74,7 +101,7 @@ otherwise search for set/group data" ("html" text/html))) (define (file-extension file-name) - (last (string-split file-name #\.))) + (last (string-split file-name #\.))) ;; FIXME: does not handle files with multiple dots (define* (render-static-image file-name #:key (extra-headers '())) @@ -82,11 +109,9 @@ otherwise search for set/group data" (modified (and stat (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))) + (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)))) @@ -97,11 +122,9 @@ otherwise search for set/group data" (modified (and stat (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))) + (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)))) @@ -122,6 +145,11 @@ otherwise search for set/group data" (lambda (port) (sxml->html (view-brand path) port)))) +(define (render-string str) + (list '((content-type application/txt)) + (lambda (port) + (put-string port str)))) + (define (render-json json) (list '((content-type application/json)) (lambda (port) @@ -171,11 +199,8 @@ otherwise search for set/group data" (lambda (key . args) (let ((msg (car args))) (build-json-response 400 - `(("error" unquote key) - ("msg" unquote msg))))))) - -(define +global-repo+ - (getenv "REPO_PATH")) + `(("error" . ,key) + ("msg" . ,msg))))))) (define (invalid-data? data target) (if (string? (assoc-ref data target)) @@ -190,30 +215,34 @@ otherwise search for set/group data" (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)))) + (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 + ((lambda () + (let ((message + (commit-file +current-repo-path+ + file-name + content + commit-message + username + email + prev-commit))) + (git-invoke +current-repo-path+ "push" +cgit-repo-path+) + message)))))) (lambda (key . args) (let ((msg (car args))) (build-json-response 400 - `(("error" unquote key) - ("msg" unquote msg))))))) + `(("error" . ,key) + ("msg" . ,msg))))))) (define (controller request body) (match-lambda @@ -222,13 +251,29 @@ otherwise search for set/group data" (('GET "version") (render-json get-version)) (('GET "css" fn) - (render-static-file (string-append "css/" fn))) + (render-static-file (string-append (dirname (current-filename)) "/css/" fn))) (('GET "map" fn) - (render-static-file (string-append "css/" fn))) + (render-static-file (string-append (dirname (current-filename)) "/css/" fn))) (('GET "static" "images" fn) - (render-static-image (string-append "static/images/" fn))) + (render-static-image (string-append (dirname (current-filename)) "/static/images/" fn))) (('GET "home" path) - (render-brand path)) + (render-brand path)) ; branding route for /home/aging, /home/msk etc + (('GET "dataset" "bxd-publish" "list") + (render-json (get-bxd-publish))) + (('GET "dataset" "bxd-publish" "dataid" "values" page) + (match (get-extension page) + (".json" + (render-json (get-bxd-publish-dataid-values (basename page ".json")))) + (else (display "ERROR: unknown file extension")))) + (('GET "dataset" "bxd-publish" "values" page) + (match (get-extension page) + (".json" + (render-json (get-bxd-publish-values (basename page ".json")))) + ;; (".tsv" (render-string "TEST1\nTEST2")) + ;; (".gemma" (render-string (string-join (gemma-pheno-txt "BXD" (get-bxd-publish-values (basename page ".gemma"))) ""))) + (else (display "ERROR: unknown file extension")))) + (('GET "dataset" "bxd-publish" "mapping" "values" (string-append dataid ".json")) + (render-json (get-bxd-publish-values dataid #t))) (('GET "doc" "species.html") (render-doc "doc" "species.html" (get-species-meta))) @@ -245,6 +290,8 @@ otherwise search for set/group data" (('GET "doc" path ... page) ;; serve documents from /doc/ (render-doc path page)) + (('GET "gene" "aliases" genename) + (render-json (get-gene-aliases genename))) (('GET "species.json") (render-json (get-species-data))) (('GET "species.meta.json") @@ -252,9 +299,9 @@ otherwise search for set/group data" (('GET "species") (render-json (get-species-meta))) (('GET "edit") - (edit-file-handler +global-repo+ request)) + (edit-file-handler +current-repo-path+ request)) (('POST "commit") - (commit-file-handler +global-repo+ request body)) + (commit-file-handler +current-repo-path+ request body)) (('GET id) (let ((names (get-species-shortnames (get-expanded-species)))) (match (string->list id) @@ -301,8 +348,9 @@ otherwise search for set/group data" ;; only way to update the handler reference held by the web server ;; would be to restart the web server. (run-server (cut handler <> <>) - #:addr (inet-pton AF_INET address) - #:port port)) + 'http + (list #:addr (inet-pton AF_INET address) + #:port port))) (define (main args) (write (string-append "Starting Guile REST API " get-version " server!")) |