diff options
Diffstat (limited to 'web')
| -rw-r--r-- | web/README.md | 1 | ||||
| -rw-r--r-- | web/config.scm | 86 | ||||
| -rw-r--r-- | web/view/brand/aging.scm | 7 | ||||
| -rw-r--r-- | web/view/brand/msk.scm | 2 | ||||
| -rw-r--r-- | web/view/doc.scm | 2 | ||||
| -rw-r--r-- | web/view/view.scm | 12 | ||||
| -rw-r--r-- | web/webserver.scm | 197 |
7 files changed, 241 insertions, 66 deletions
diff --git a/web/README.md b/web/README.md new file mode 100644 index 0000000..fc7e158 --- /dev/null +++ b/web/README.md @@ -0,0 +1 @@ +Run the webserver from one directory up. diff --git a/web/config.scm b/web/config.scm new file mode 100644 index 0000000..9b3b9c2 --- /dev/null +++ b/web/config.scm @@ -0,0 +1,86 @@ +;;; Copyright © 2026 Frederick M Muriithi <fredmanglis@gmail.com> + +(define-module (web config) + #:use-module (srfi srfi-9 gnu) + + #:use-module (config) + #:use-module (config api) + #:use-module (config parser sexp) + + #:export (<gn-guile-config> + gn-guile-config-port + gn-guile-config-gn-docs-remote-url + gn-guile-config-gn-docs-local-checkout + gn-guile-config-gn-docs-working-branch + + parse-cli-options + cli-options->gn-guile-config)) + +(define-immutable-record-type <gn-guile-config> + (gn-guile-config port gn-docs-remote-url gn-docs-local-checkout + gn-docs-working-branch) + gn-guile-config? + (port gn-guile-config-port) + (gn-docs-remote-url gn-guile-config-gn-docs-remote-url) + (gn-docs-local-checkout gn-guile-config-gn-docs-local-checkout) + (gn-docs-working-branch gn-guile-config-gn-docs-working-branch)) + + +(define string->exact (compose inexact->exact string->number)) + + +(define (user-port? parsed) + (and (positive? parsed) (>= parsed 1024) (<= parsed 49151))) + + +(define (parse-cli-options cmd-line) + "Read configuration values from files and command-line options and convert them to appropriate data types." + (let ((config + (configuration (name 'gn-guile) + (synopsis "gn-guile web service: provide services + to main Genenetwork service.") + (description "gn-guile web service is a small +service, written in GNU Guile, that provides some functionality to the main +Genenetwork service in the background. This is not meant for direct user +interaction.") + (keywords + (list (switch (name 'write) + (default #f) + (test boolean?) + (character #f) + (synopsis "Write the settings to configuration file(s)") + (description "When this option is present, the configuration values, provided as command line option, will be written to the file path(s) that has/have been specified.")) + (setting (name 'port) + (default 8091) + (test user-port?) + (handler string->exact) + (character #\p) + (synopsis "Port number that the service will listen on")) + (setting (name 'gn-docs-remote-url) + (default "git@git.genenetwork.org:/home/git/public/gn-docs") + (test string?) + (character #\r) + (synopsis "Remote URI for gn-docs repository")) + (setting (name 'gn-docs-local-checkout) + (default (string-append (dirname (getcwd)) "/gn-guile-files/gn-docs")) + (test file-exists?) + (character #\c) + (synopsis "Path where gn-docs is checked out")) + (setting (name 'gn-docs-working-branch) + (default "non-existent") + (test string?) + (character #\b) + (synopsis "Branch to push/pull from")))) + (parser sexp-parser) + (directory (list (in-home ".config/gn-guile/") + (in-cwd ".config/")))))) + (getopt-config-auto cmd-line config))) + + +(define (cli-options->gn-guile-config cli-options) + "Extract specific values from guile-config's <codex> object into gn-guile's custom configuration object." + (gn-guile-config + (option-ref cli-options 'port) + (option-ref cli-options 'gn-docs-remote-url) + (option-ref cli-options 'gn-docs-local-checkout) + (option-ref cli-options 'gn-docs-working-branch))) diff --git a/web/view/brand/aging.scm b/web/view/brand/aging.scm index 19db4d7..f1c48c9 100644 --- a/web/view/brand/aging.scm +++ b/web/view/brand/aging.scm @@ -45,15 +45,14 @@ )) ,@head) (body - ;; (header (p "TEST")) (main (@ (class "container")) (h1 ,title) (article - (img (@ (src "/static/images/ole-farmer.jpg") (alt "ol farmer by hohumhobo is licensed under CC BY 2.0") (width "400") (align "right"))) -,info) + ;; (img (@ (src "/static/images/ole-farmer.jpg") (alt "ol farmer by hohumhobo is licensed under CC BY 2.0") (width "400") (align "right"))) + ,info) (footer (hr) - (p "Copyright © 2005-2023 " + (p "Copyright © 2005-2025 " (a (@ (href "https://genenetwork.org/")) "GeneNetwork Webservices") " | GeneNetwork and this website runs fully on free software. See status and download the " (a (@ (href "https://ci.genenetwork.org/")) "source code") "."))) diff --git a/web/view/brand/msk.scm b/web/view/brand/msk.scm index 69c1253..4cbcec4 100644 --- a/web/view/brand/msk.scm +++ b/web/view/brand/msk.scm @@ -51,7 +51,7 @@ (p ,info) (footer (hr) - (p "Copyright © 2005-2023 " + (p "Copyright © 2005-2025 " (a (@ (href "https://genenetwork.org/")) "GeneNetwork Webservices") " | GeneNetwork and this website runs fully on free software. See status and download the " (a (@ (href "https://ci.genenetwork.org/")) "source code") "."))) diff --git a/web/view/doc.scm b/web/view/doc.scm index 71112eb..cec4400 100644 --- a/web/view/doc.scm +++ b/web/view/doc.scm @@ -44,7 +44,7 @@ ,(scm->json-string body #:pretty #t)) ; (p ,(parse-html "<b>some raw really <i>text</i> here</b>")) (footer - (p "Copyright © 2005—2023 by the GeneNetwork community with a touch of " (span (@ (class "lambda")) "λ") "!") + (p "Copyright © 2005—2025 by the GeneNetwork community with a touch of " (span (@ (class "lambda")) "λ") "!") (p "This is free software. Download the " (a (@ (href "https://ci.genenetwork.org/")) "source code") ".")) diff --git a/web/view/view.scm b/web/view/view.scm index 4300863..a7592ad 100644 --- a/web/view/view.scm +++ b/web/view/view.scm @@ -15,7 +15,7 @@ #:export (view-brand)) -(define (view-aging) +(define (view-aging-home) (aging-html #:info `( ,(markdown-github->sxml "genenetwork/gn-docs/general/brand/aging/home.md") @@ -45,7 +45,15 @@ data to benefit from the power of integrated datasets, please contact:") (define* (view-brand path) (match path - ("aging" (view-aging)) + ("aging/um-het3" (aging-html #:info + `(,(markdown-github->sxml "genenetwork/gn-docs/general/brand/aging/home.md")))) + ("aging/UM-HET3" (aging-html #:info + `(,(markdown-github->sxml "genenetwork/gn-docs/general/brand/aging/home.md")))) + ("aging/UMHET-3" (aging-html #:info + `(,(markdown-github->sxml "genenetwork/gn-docs/general/brand/aging/home.md")))) + ("aging/umhet-3" (aging-html #:info + `(,(markdown-github->sxml "genenetwork/gn-docs/general/brand/aging/home.md")))) + ("aging" (view-aging-home)) ("gnqa" (default-gn-template "genenetwork/gn-docs/general/brand/gnqa/gnqa.md" "GeneNetwork Question and Answer System")) diff --git a/web/webserver.scm b/web/webserver.scm index d2a8c8d..8c909a5 100644 --- a/web/webserver.scm +++ b/web/webserver.scm @@ -1,37 +1,42 @@ -(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)) - -(define +current-repo-path+ - (getenv "CURRENT_REPO_PATH")) - -(define +cgit-repo-path+ - (getenv "CGIT_REPO_PATH")) +(define-module (web webserver) + #:use-module (json) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (ice-9 iconv) + #:use-module (ice-9 receive) + #:use-module (ice-9 string-fun) + #:use-module (ice-9 exceptions) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-13) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) + #:use-module (web http) + #:use-module (web client) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:use-module (web server) + #:use-module (gn cache memoize) + #:use-module (web gn-uri) + #:use-module (gn db sparql) + #:use-module (gn data dataset) + #:use-module (gn data species) + #:use-module (gn data group) + #:use-module (gn runner gemma) + #:use-module (web sxml) + #:use-module (web config) + #:use-module (web view view) + #:use-module (web view doc) + #:use-module (web view markdown) + #:export (start-web-server)) + +(define (get-extension filename) + (let ((dot-pos (string-rindex filename #\.))) + (if dot-pos + (substring filename dot-pos) ""))) (define +info+ `(("name" . "GeneNetwork REST API") ("version" . ,get-version) @@ -56,6 +61,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: " @@ -79,7 +98,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 '())) @@ -123,6 +142,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) @@ -154,7 +178,7 @@ otherwise search for set/group data" (cons (string->symbol (uri-decode key)) (uri-decode value)))) -(define (edit-file-handler repo request) +(define (edit-file-handler local-repo working-branch request) (catch 'file-error (lambda () (let* ((query (uri-query (request-uri request))) @@ -165,8 +189,12 @@ otherwise search for set/group data" (query-path (assoc-ref params 'file_path))) (if query-path - (build-json-response 200 - (fetch-file repo query-path)) + (begin + (git-invoke local-repo "fetch" "origin" working-branch) + (git-invoke local-repo "reset" "--hard" + (string-append "origin/" working-branch)) + (build-json-response 200 + (fetch-file local-repo query-path))) (throw 'file-error "Please provide a valid file path in the query")))) (lambda (key . args) @@ -175,6 +203,24 @@ otherwise search for set/group data" `(("error" . ,key) ("msg" . ,msg))))))) +(define (render-sparql request prefix val) + (let* ((mime (negotiate-mime request)) + (resp-mime (if (or (string-contains (symbol->string mime) "html") + (string-contains (symbol->string mime) "microdata")) + 'text/html + mime))) + (receive (sparql-header sparql-resp) + (sparql-http-get + (or (getenv "SPARQL-ENDPOINT") "http://localhost:8890/sparql/") + (sparql-by-term prefix val) + (symbol->string mime)) + (list `((content-type ,resp-mime)) + (lambda (port) + (let ((resp (if (string? sparql-resp) + sparql-resp + (utf8->string sparql-resp)))) + (put-string port resp))))))) + (define (invalid-data? data target) (if (string? (assoc-ref data target)) (if (string-null? (assoc-ref data target)) @@ -185,7 +231,7 @@ otherwise search for set/group data" (format #f "The Key *** ~a *** is missing in your Json Data" target)))) -(define (commit-file-handler repo request body) +(define (commit-file-handler repo-checkout remote-url request body) (catch 'system-error (lambda () (let* ((post-data (decode-request-json body)) @@ -202,14 +248,14 @@ otherwise search for set/group data" (build-json-response 200 ((lambda () (let ((message - (commit-file +current-repo-path+ + (commit-file repo-checkout file-name content commit-message username email prev-commit))) - (git-invoke +current-repo-path+ "push" +cgit-repo-path+) + (git-invoke repo-checkout "push" remote-url) message)))))) (lambda (key . args) (let ((msg (car args))) @@ -217,7 +263,15 @@ otherwise search for set/group data" `(("error" . ,key) ("msg" . ,msg))))))) -(define (controller request body) +(define (negotiate-mime request) + (let* ((headers (request-headers request)) + (accept (caar (assoc-ref headers 'accept)))) + (if (or (eq? (string->symbol "*/*") accept) + (eq? (string->symbol "text/html") accept)) + 'application/x-nice-microdata + accept))) + +(define (controller request body config) (match-lambda (('GET) (render-json +info+)) @@ -231,6 +285,24 @@ otherwise search for set/group data" (render-static-image (string-append (dirname (current-filename)) "/static/images/" fn))) (('GET "home" path) (render-brand path)) ; branding route for /home/aging, /home/msk etc + (('GET "home" "aging" path) + (render-brand (string-append "aging/" path))) ; branding route subs of /home/aging/... + (('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))) @@ -247,6 +319,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") @@ -254,9 +328,13 @@ otherwise search for set/group data" (('GET "species") (render-json (get-species-meta))) (('GET "edit") - (edit-file-handler +current-repo-path+ request)) + (edit-file-handler (gn-guile-config-gn-docs-local-checkout config) + (gn-guile-config-gn-docs-working-branch config) + request)) (('POST "commit") - (commit-file-handler +current-repo-path+ request body)) + (commit-file-handler (gn-guile-config-gn-docs-local-checkout config) + (gn-guile-config-gn-docs-remote-url config) + request body)) (('GET id) (let ((names (get-species-shortnames (get-expanded-species)))) (match (string->list id) @@ -280,21 +358,31 @@ otherwise search for set/group data" #\n) (render-json (get-id-data (list->string name)))) (rest (render-json "NOP"))))) + ;; RDF End-points + (('GET "v1" "id" id) + (render-sparql request 'gn id)) + + (('GET "v1" "category" category) + (render-sparql request 'gnc category)) + + (('GET "v1" "term" term) + (render-sparql request 'gnt term)) + (_ (not-found (request-uri request))))) (define (request-path-components request) (split-and-decode-uri-path (uri-path (request-uri request)))) -(define (handler request body) +(define (handler request body config) (format #t "~a ~a\n" (request-method request) (uri-path (request-uri request))) (apply values - ((controller request body) + ((controller request body config) (cons (request-method request) (request-path-components request))))) -(define (start-web-server address port) +(define (start-web-server address port config) (format (current-error-port) "GN REST API web server listening on http://~a:~a/~%" address port) ;; Wrap handler in another function to support live hacking via the @@ -302,14 +390,7 @@ otherwise search for set/group data" ;; REPL, the web server will still be using the old handler. The ;; 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)) - -(define (main args) - (write (string-append "Starting Guile REST API " get-version " server!")) - (write args) - (newline) - (let ((listen (inexact->exact (string->number (car (cdr args)))))) - (display `("listening on" ,listen)) - (start-web-server "127.0.0.1" listen))) + (run-server (cut handler <> <> config) + 'http + (list #:addr (inet-pton AF_INET address) + #:port port))) |