diff options
31 files changed, 1516 insertions, 608 deletions
diff --git a/.gitignore b/.gitignore index 55bfd36..5f81cf8 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ BXD.* pheno.txt GWA.json K.json +.aider* diff --git a/.guix-channel b/.guix-channel new file mode 100644 index 0000000..6e0982a --- /dev/null +++ b/.guix-channel @@ -0,0 +1,8 @@ +(channel + (version 0) + (directory ".guix/modules") + (dependencies + (channel + (name guix-bioinformatics) + (url "https://git.genenetwork.org/guix-bioinformatics") + (branch "master")))) \ No newline at end of file diff --git a/.guix-shell b/.guix-shell deleted file mode 100755 index bc81e06..0000000 --- a/.guix-shell +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/bash -# -# . .guix-shell -- guile -L . --fresh-auto-compile --listen=1970 - -echo "Create a shell to run tools." - -guix shell -L ~/guix-bioinformatics -C -D -F --network coreutils guile guile-dbi guile-dbd-mysql guile-fibers guile-json guile-gnutls guile-readline guile-redis openssl nss-certs gemma parallel tar xz python python-lmdb python-cffi guile-gcrypt guile-hashing time gemma-gn2 $* diff --git a/.guix/modules/gn-guile.scm b/.guix/modules/gn-guile.scm new file mode 100644 index 0000000..03f2b14 --- /dev/null +++ b/.guix/modules/gn-guile.scm @@ -0,0 +1,34 @@ +;; To use this file to build HEAD of gn-guile: +;; +;; guix build -f guix.scm +;; +;; To get a development container +;; +;; guix shell -C -D -f guix.scm +;; + +(define-module (gn-guile) + #:use-module ((gn packages guile) #:select (gn-guile) #:prefix gn:) + #:use-module (guix gexp) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix git-download)) + +(define %source-dir (dirname (dirname (current-source-directory)))) + +(define vcs-file? + (or (git-predicate %source-dir) + (const #t))) + +(define-public gn-guile + (package + (inherit gn:gn-guile) + (source + (local-file "../.." + "gn-guile-checkout" + #:recursive? #t + #:select? vcs-file?)))) + +;; Add definition for tests should you need it, here. + +gn-guile diff --git a/README.md b/README.md index c7f367b..79b00bd 100644 --- a/README.md +++ b/README.md @@ -2,6 +2,17 @@ This directory provides a Guile web service incl. the new REST API. It is used in conjunction with the Python web services and (very much) WIP. +## Run + +1. **Navigate to the Web Directory and Start the Server** + +Running the web server is documented in [guix script](./web/.guix-shell). + +``` +curl http://127.0.0.1:8091/version +"4.0.0" +``` + # Documentation Start with this file and then the documentation in [doc](./doc/gn-guile.md). @@ -14,28 +25,59 @@ The current repository lives at git clone tux02.genenetwork.org:/home/git/public/gn-guile ``` -GNU Guile allows you to develop against a live running web server using emacs-geiser. To try this fire up the web server from the `web` directory as +or + +``` +git remote add gn git.genenetwork.org:/home/git/public/gn-guile +``` + +GNU Guile allows you to develop against a live running web server using emacs-geiser on port 1970. To try this fire up the web server from the `web` directory as ```sh -cd web -unset GUIX_PROFILE -. .guix-shell -- guile -L .. --listen=1970 -e main ./webserver.scm 8091 +guix shell -L ~/guix-bioinformatics -m manifest.scm --container --network --file=guix.scm -- guile -L . --fresh-auto-compile --listen=1970 -e main web/webserver.scm 8091 ``` -Note the leading dot. The .guix-shell is defined in `gn-guile/web` and loads required packages using GNU Guix. -If you are on Debian you may need to unset GUIX_PROFILE first. +By default the root points to the API: + +curl http://127.0.0.1:8091 + +We also have some services + +curl http://127.0.0.1:8091/home/msk +curl http://127.0.0.1:8091/home/aging + +The `--container` option runs the code in an isolated container, and the `--network` option connects that container's networking to the host to allow you to access the running service. + +If you get an error `no code for module (gn packages guile)` add the appropriate guix-bioinformatics repo to the load path (`-L` switch). Note that, instead of hard-wiring guix-bioinformatics, the recommended way is to use a guix channel as defined in [guix-channel](./.guix-channel). + +We recommend checking the Guix documentation for manifests, channels and guix.scm definitions. + +## Welcome to the world of interactive Lisp programming + +Next fire up emacs with `emacs-geiser-guile` and connect to the running web server with `M-x geiser-connect` and the port `1970`. Now you can not only inspect procedures, but also update any prodedure on the live server using `C-M-x` on code, call and get updated output from the webserver! No need to save/reload files and all that. + +Note that you may have to try different versions of guile+emacs to succeed. + +Also these days it may be a better bet to use Andrew Tropin's alternatives ares and arei that are very powerful alternatives to geiser (with a more common lisp type interactive experience): + +=> https://git.sr.ht/~abcdw/guile-ares-rs +=> https://git.sr.ht/~abcdw/emacs-arei -Next fire up emacs with `emacs-geiser-guile` and connect to the running web server with `M-x geiser-connect` and the port `1970`. Now you can not only inspect procedures, but also update any prodedure on the live server using `C-M-x` and get updated output from the webserver! # Tools Some tooling and scripts that run independently are stored in `./scripts`. -# Development +# Forwarding a MySQL port -``` -git remote add gn git.genenetwork.org:/home/git/public/gn-guile -``` +You may want to forward a mysql port if there is no DB locally you can do something like: + +ssh -L 3306:127.0.0.1:3306 -f -N tux02.genenetwork.org + +# Topics + +* More on [gn-guile](./doc/gn-guile.md) +* Markdown editor with git backend see [markdown](./doc/git-markdown-editor.md). # LICENSE diff --git a/doc/git-markdown-editor.md b/doc/git-markdown-editor.md new file mode 100644 index 0000000..f286284 --- /dev/null +++ b/doc/git-markdown-editor.md @@ -0,0 +1,117 @@ +# Gn-Markdown + +Gn-Markdown is an API endpoint to edit, parse, and commit markdown files for gn-docs. + +## How to Test the APIs + +1. **Navigate to the Web Directory and Start the Server** + +Running the web server is documented in [guix script](./web/.guix-shell). + +``` +curl http://127.0.0.1:8091/version +"4.0.0" +``` + +```sh +cd web +export CURRENT_REPO_PATH=<path-to-git-repo-with-files> +export CGIT_REPO_PATH=<path-to-git-bare-repo> +. .guix-shell -- guile -L .. --listen=1970 -e main ./webserver.scm 8091 +``` + + + +2. **Test Endpoints** + +The main endpoints provided are `/edit` and `/commit`. More endpoints may be added in the future. + +## Edit (GET) + +This is a GET request to retrieve a file's details. Make sure you pass a valid file_path as search_query (the path should be relative to the repo) + +**Request Example:** + +```bash + +curl -G -d "file_path=test.md" localhost:8091/edit + +``` + +**Expected Success Response:** + +```json +{ +"file_path": "test.md", +"content": "Test for new user\n test 2 for line\n test 3 for new line\n ## real markdown two test\n", +"hash": "ecd96f27c45301279150fbda411544687db1aa45" +} +``` + +**Expected Error Response (Status 400):** + +```json +{ +"error": <error_type>, +"msg": <error_reason> +} +``` + +## Commit (POST) + +This is a POST request to commit changes to a file. + +**Request URL:** + +```bash + +curl -X POST http://127.0.0.1:8091/commit \ +-H 'Content-Type: application/json' \ +-d '{ +"content": "make test commit", +"filename": "test.md", +"email": "test@gmail.com", +"username": "test", +"commit_message": "init commit", +"prev_commit": "7cbfc40d98b49a64e98e7cd562f373053d0325bd" +}' + +``` + + + +**Expected Response for success:** + +```json +{ +"status": "201", +"message": "Committed file successfully", +"content": "Test for new user\n test 2 for line\n test 3 for new line\n ## real markdown two test\n", +"commit_sha": "47df3b7f13a935d50cc8b40e98ca9e513cba104c", +"commit_message": "commit by genetics" +} + +``` + +**If No Changes to File:** + +```json +{ +"status": "200", +"message": "Nothing to commit, working tree clean", +"commit_sha": "ecd96f27c45301279150fbda411544687db1aa45" +} +``` + +**Expected Error Response:** + +```json +{ +"error": "system-error", +"msg": "Commits do not match. Please pull in the latest changes for the current commit *ecd96f27c45301279150fbda411544687db1aa45* and previous commits." +} +``` + +## Notes + +This is meant to be used as api endpoint only to edit any local repo; Clients are expected to handle other service e.g User Interface, authentication diff --git a/doc/gn-guile.md b/doc/gn-guile.md index 7a86c13..9e84e23 100644 --- a/doc/gn-guile.md +++ b/doc/gn-guile.md @@ -4,4 +4,5 @@ The GeneNetwork Guile web server serves an exploratory REST API as well as HTML Topics are: +* [Markdown editor](./git-markdown-editor.md). * [Branding GN](./branding.md) diff --git a/gn-guile.sh b/gn-guile.sh new file mode 100755 index 0000000..9341b26 --- /dev/null +++ b/gn-guile.sh @@ -0,0 +1,3 @@ +#! @SHELL@ + +guile -e main web/webserver.scm "$@" diff --git a/gn/data/dataset.scm b/gn/data/dataset.scm index c28cf25..afe75ba 100644 --- a/gn/data/dataset.scm +++ b/gn/data/dataset.scm @@ -4,14 +4,21 @@ #:use-module (ice-9 iconv) #:use-module (ice-9 receive) #:use-module (ice-9 string-fun) + #:use-module (srfi srfi-1) #:use-module (dbi dbi) #:use-module (gn db mysql) + #:use-module (gn data genotype) #:use-module (gn data group) #:use-module (gn util convert) #:use-module (web gn-uri) + #:use-module (rnrs base) ; for assert #:export ( dataset-name + get-bxd-publish-list + get-bxd-publish-values-list + get-bxd-publish-name-value-dict + get-bxd-publish-dataid-name-value-dict )) (define (get-dataset db probesetfreeze-id) @@ -22,3 +29,57 @@ (define (dataset-name db probesetfreeze-id) (assoc-ref (get-dataset db probesetfreeze-id) "Name")) + +(define (get-dataid-from-publishxrefid id) + "Get the internal dataid from publishxref - which is the same as used in the GN2 web interface" + (call-with-db + (lambda (db) + (let [(query (string-append "SELECT Id,PhenotypeId,DataId FROM PublishXRef WHERE Id=" id " AND InbredSetId=1 LIMIT 1"))] + (dbi-query db query) + (pk (int-to-string (assoc-ref (get-row db) "DataId"))))))) + +(define (get-bxd-publish-list) + (call-with-db + (lambda (db) + (let [(query "SELECT Id,PhenotypeId,DataId FROM PublishXRef WHERE InbredSetId=1")] + (dbi-query db query) + (get-rows db '()))))) + +(define* (get-bxd-publish-values-list dataid #:optional used-for-mapping?) + "Returns dict of name values , e.g. [{\"Name\":\"C57BL/6J\",\"value\":9.136},{\"Name\":\"DBA/2J\",\"value\":4.401},{\"Name\":\"BXD9\",\"value\":4.36}, ... used-for-mapping? skips the founders and maybe other unmappable inds. Note, currently unused." + (call-with-db + (lambda (db) + (let [(query (string-append "SELECT Strain.Name, PublishData.value FROM Strain, PublishData WHERE PublishData.Id=" dataid " and Strain.Id=StrainID;"))] + (dbi-query db query) + (if used-for-mapping? + (remove null? (pk (get-rows-apply db + (lambda (r) + (if (string-contains (assoc-ref r "Name") "BXD") + `(("Name" . ,(assoc-ref r "Name")) ("value" . ,(assoc-ref r "value"))) + '() ) ;; return empty on no match + ) '()))) + (get-rows db '()) + ))))) + +(define* (get-bxd-publish-dataid-name-value-dict dataid #:optional used-for-mapping?) + "Returns dict of name values, e.g. (((\"C57BL/6J\" . 9.136) (\"DBA/2J\" . 4.401) (\"BXD9\" . 4.36) ... used-for-mapping? skips the founders and maybe other unmappable inds." + (call-with-db + (lambda (db) + (let [(query (string-append "SELECT Strain.Name, PublishData.value FROM Strain, PublishData WHERE PublishData.Id=" dataid " and Strain.Id=StrainID;"))] + (dbi-query db query) + (if used-for-mapping? + (remove null? (pk (get-rows-apply db + (lambda (r) + (if (string-contains (assoc-ref r "Name") "BXD") + `(,(assoc-ref r "Name") . ,(assoc-ref r "value")) + '() ) ;; return empty on no match + ) '()))) + (remove null? (pk (get-rows-apply db + (lambda (r) + `(,(assoc-ref r "Name") . ,(assoc-ref r "value")) + ) '()))) + ))))) + +(define* (get-bxd-publish-name-value-dict id #:optional used-for-mapping?) + "Same as above function, but starting from data id" + (get-bxd-publish-dataid-name-value-dict (get-dataid-from-publishxrefid id) used-for-mapping?)) diff --git a/gn/data/genotype.scm b/gn/data/genotype.scm index c7cb63c..5574382 100644 --- a/gn/data/genotype.scm +++ b/gn/data/genotype.scm @@ -16,6 +16,7 @@ )) (define (geno-inds-bxd fn) + "Returns information from GN's BXD.json, note it fetches the first geno file info, now BXD.8.geno" (let [(js (call-with-input-file fn (lambda (port) (json->scm port))))] diff --git a/gn/data/hits.scm b/gn/data/hits.scm index f7ce49e..85c4912 100644 --- a/gn/data/hits.scm +++ b/gn/data/hits.scm @@ -5,6 +5,7 @@ #:use-module (ice-9 iconv) #:use-module (ice-9 receive) #:use-module (ice-9 string-fun) + #:use-module (srfi srfi-9) ;; #:use-module (gn db sparql) #:use-module (dbi dbi) #:use-module (gn db mysql) @@ -17,11 +18,26 @@ get-precompute-hit set-precompute-hit-status! update-precompute! + hit-data-id + hit-probeset-id + hit-probesetfreeze-id )) -(define (get-precompute-hits db prev-id num) - (dbi-query db (string-append "select Locus, DataId, ProbeSetId, ProbeSetFreezeId from ProbeSetXRef where DataId>" (int-to-string prev-id) " AND Locus_old is NULL ORDER BY DataId LIMIT " (format #f "~d" num))) - (get-rows db '())) + +(define-record-type <hit> + (make-hit data-id probeset-id probesetfreeze-id) + hit? + (data-id hit-data-id) + (probeset-id hit-probeset-id) + (probesetfreeze-id hit-probesetfreeze-id) + ) + +(define (get-precompute-hits db first-id num) + (dbi-query db (string-append "select Locus, DataId, ProbeSetId, ProbeSetFreezeId from ProbeSetXRef where DataId>" (int-to-string first-id) " AND Locus_old is NULL ORDER BY DataId LIMIT " (int-to-string num))) + (map (lambda (r) + (make-hit (assoc-ref r "DataId") (assoc-ref r "ProbeSetId") (assoc-ref r "ProbeSetFreezeId"))) + (get-rows db '()) + )) (define (get-precompute-hit db prev-id) (car (get-precompute-hits db prev-id 1))) diff --git a/gn/data/strains.scm b/gn/data/strains.scm index e5f839b..07b69ff 100644 --- a/gn/data/strains.scm +++ b/gn/data/strains.scm @@ -25,7 +25,7 @@ "Return assoc list of tuples of strain id+names: ((4 . BXD1) (5 . BXD2) (6 . BXD5) (7 . BXD6)... -used-for-mapping? will say whether the strains/individuals are used for mapping. Always True, FIXME +optional key used-for-mapping? will say whether the strains/individuals are used for mapping. " (call-with-db (lambda (db) diff --git a/gn/db/mysql.scm b/gn/db/mysql.scm index ccd414a..223b5fd 100644 --- a/gn/db/mysql.scm +++ b/gn/db/mysql.scm @@ -32,22 +32,23 @@ ;; (display "===> OPENING DB") ;; (newline) (let [(db (dbi-open "mysql" "webqtlout:webqtlout:db_webqtl:tcp:127.0.0.1:3306"))] - (ensure db) + (ensure db "Can't open connection") db ))) (define (call-with-db thunk) (thunk (db-open))) -(define (ensure db) +(define (ensure db msg1) "Use DBI-style handle to report an error. On error the program will stop." (match (dbi-get_status db) ((stat . msg) (if (= stat 0) #t (begin - (display msg) + (display "SQL Connection ERROR! ") + (display (string-append msg1 " - " msg) (newline) - (assert stat)))))) + (assert #f))))))) (define (has-result? db) "Return #t or #f if result is valid" diff --git a/gn/db/sources/wikidata.scm b/gn/db/sources/wikidata.scm new file mode 100644 index 0000000..954ce93 --- /dev/null +++ b/gn/db/sources/wikidata.scm @@ -0,0 +1,65 @@ +#! + +Wikidata queries, initially lifted over from the gn3 gene-alias code (that was written in Racket). + +Note you can take a SPARQL query and push it into https://query.wikidata.org/. E.g. generate a query and +copy paste into the query service: + +scheme@(guile-user) [3]> (display (wikidata-query-geneids "Shh")) +``` +SELECT DISTINCT ?wikidata_id + WHERE { + ?wikidata_id wdt:P31 wd:Q7187; + wdt:P703 ?species . + VALUES (?species) { (wd:Q15978631 ) ( wd:Q83310 ) ( wd:Q184224 ) } . + ?wikidata_id rdfs:label "Shh"@en . + } +``` + +It is possible to run queries through curl with + +``` +curl -G https://query.wikidata.org/sparql -H "Accept: application/json; charset=utf-8" --data-urlencode query=" + SELECT DISTINCT ?alias + WHERE { + wd:Q24420953 rdfs:label ?name ; + skos:altLabel ?alias . + FILTER(LANG(?name) = \"en\" && LANG(?alias) = \"en\"). + }" +``` +!# + +(define-module (gn db sources wikidata) + #:export (wikidata-query-geneids + wikidata-query-gene-aliases + ) +) + +(define ps-encoded-by "ps:P702") +(define wdt-instance-of "wdt:P31") +(define wdt-in-taxon "wdt:P703") +(define wd-human "wd:Q15978631") +(define wd-mouse "wd:Q83310") +(define wd-rat "wd:Q184224") +(define wd-gene "wd:Q7187") +(define wd-shh-rat "wd:Q24420953") + +(define (wikidata-query-geneids gene_name) + "SPARQL query to get the wikidata identifiers pointing to genes of listed species, e.g. 'Shh'" + (string-append + "SELECT DISTINCT ?wikidata_id + WHERE { + ?wikidata_id " wdt-instance-of " " wd-gene "; + " wdt-in-taxon " ?species . + VALUES (?species) { (" wd-human " ) ( " wd-mouse" ) ( " wd-rat" ) } . + ?wikidata_id rdfs:label \"" gene_name "\"@en .}")) + +(define (wikidata-query-gene-aliases wikidata_id) + "SPARQL query to get a list of gene aliases based on a wikidata identifier, e.g. for Q24420953. This +version supports the expanded id only, so <http://www.wikidata.org/entity/Q24420953> including the <,>." + (string-append + "SELECT DISTINCT ?stripped_alias + WHERE { " wikidata_id " rdfs:label ?name ; + skos:altLabel ?alias . + BIND (STR(?alias) AS ?stripped_alias) . + FILTER(LANG(?name) = \"en\" && LANG(?alias) = \"en\").}")) diff --git a/gn/db/sparql.scm b/gn/db/sparql.scm index b7d94f3..bd7a306 100644 --- a/gn/db/sparql.scm +++ b/gn/db/sparql.scm @@ -2,23 +2,25 @@ Module for handling SPARQL primitives. -Note that GN queries should go into gn/data - this is currently not +Note that GN queries should go into gn/db/sources - this is currently not the case. !# (define-module (gn db sparql) - #:use-module (json) - #:use-module (ice-9 match) + #:use-module (gn cache memoize) + #:use-module (gn db sources wikidata) #:use-module (ice-9 format) #:use-module (ice-9 iconv) + #:use-module (ice-9 match) #:use-module (ice-9 receive) #:use-module (ice-9 string-fun) + #:use-module (json) + #:use-module (srfi srfi-1) #:use-module (web client) + #:use-module (web gn-uri) #:use-module (web request) #:use-module (web uri) - #:use-module (gn cache memoize) - #:use-module (web gn-uri) #:export (memo-sparql-species memo-sparql-species-meta @@ -26,6 +28,8 @@ the case. sparql-groups-meta sparql-group-info memo-sparql-wd-species-info + memo-sparql-wd-gene-aliases + memo-sparql-wd-geneids compile-species compile-groups-meta get-rows @@ -72,7 +76,9 @@ PREFIX rdf: <http://www.w3.org/1999/02/22-rdf-syntax-ns#> (define (sparql-tsv endpoint-url query) "Execute raw SPARQL query returning response as a UTF8 string, e.g. -(tsv->scm (sparql-tsv (wd-sparql-endpoint-url) \"wd:Q158695\")) +(tsv->scm (sparql-tsv (wd-sparql-endpoint-url) \"wd:Q158695\")). + +Note this procedure works for wikidata, but not for gn! " ; GET /sparql?query=SELECT%20DISTINCT%20%2A%20where%20%7B%0A%20%20wd%3AQ158695%20wdt%3AP225%20%3Fo%20.%0A%7D%20limit%205 HTTP/2 (receive (response-status response-body) @@ -92,7 +98,9 @@ PREFIX rdf: <http://www.w3.org/1999/02/22-rdf-syntax-ns#> (unpack "bindings" (unpack "results" response))) (define (sparql-scm endpoint-url query) - "Return dual S-exp 'resultset' of varnames and results" + "Return dual S-exp 'resultset' of varnames and results. + +Note this procedure works for GN, but does not yet work for wikidata" (let ((response (json-string->scm (sparql-exec endpoint-url (gn-sparql-prefix query))))) (values (sparql-names response) (sparql-results response)))) @@ -160,9 +168,47 @@ SELECT DISTINCT ?taxon ?ncbi ?descr where { "))) +(define (flatten lst) + (cond ((null? lst) '()) + ((pair? lst) (append (flatten (car lst)) (flatten (cdr lst)))) + (else (list lst)))) + +(define (remove-quotes s) + (substring s 1 (- (string-length s) 1))) + (define memo-sparql-wd-species-info (memoize sparql-wd-species-info)) +(define (sparql-wd-geneids gene-name) + "Return a list of expanded wikidata ids, e.g. +(\"<http://www.wikidata.org/entity/Q14860079>\" \"<http://www.wikidata.org/entity/Q24420953>\")" + (receive (type values) + (tsv->scm (sparql-tsv (wd-sparql-endpoint-url) (wikidata-query-geneids gene-name))) + (map (lambda (item) (car item)) values) ;; flatten list + )) + +(define memo-sparql-wd-geneids + (memoize sparql-wd-geneids)) + +(define (sparql-wd-gene-aliases geneids) + "Returns a flattened and dedpulicated list of geneids with +(sparql-wd-gene-aliases '(\"Q14860079\" \"Q24420953\")) +" + (let* ([aliases + (map (lambda (geneid) + (receive (type values) + (tsv->scm (sparql-tsv (wd-sparql-endpoint-url) (wikidata-query-gene-aliases (pk geneid)))) + (map (lambda (item) (car item)) values) ;; flatten list)) + ) + ) geneids)] + [rm-quotes-aliases (map (lambda (s) (remove-quotes s)) (flatten aliases))] + ) + (delete-duplicates rm-quotes-aliases))) + +(define memo-sparql-wd-gene-aliases + (memoize sparql-wd-gene-aliases)) + + #! gn:Mus_musculus rdf:type gnc:species . gn:Mus_musculus gnt:name "Mouse" . diff --git a/gn/runner/gemma.scm b/gn/runner/gemma.scm index 69991dd..c577305 100644 --- a/gn/runner/gemma.scm +++ b/gn/runner/gemma.scm @@ -10,11 +10,24 @@ #:use-module (rnrs base) #:export ( - write-pheno-file + gemma-pheno-txt invoke-gemma-wrapper-loco run-gemma )) +(define (gemma-pheno-txt family traits) + "Return a list of values for GEMMA" + (assert (string=? family "BXD")) ; only supported right now + (define bxd-inds (geno-inds-bxd "BXD.json")) + (assert (= 235 (length bxd-inds))) + (map (lambda (ind) + (let [(value (assoc-ref traits ind))] + (if value + (format #f "~a" value) + "NA\n") + )) + bxd-inds)) + (define (write-pheno-file fn traits) (define bxd-inds (geno-inds-bxd "BXD.json")) (assert (= 235 (length bxd-inds))) @@ -39,24 +52,27 @@ )) ) -(define (invoke-gemma-wrapper-loco name trait-name pheno-fn) +(define (invoke-gemma-wrapper-loco name trait-name trait-fn pheno-fn geno-fn) "Create a tmpdir and invoke gemma-wrapper using parallel LOCO. Note that at this point we use a number of defaults for BXD" (let* [(population "BXD") (sys-tmpdir (getenv "TMPDIR")) (tmpdir (mkdtemp (string-append sys-tmpdir "/run-gemma-XXXXXX"))) (k-json-fn (string-append tmpdir "/K.json")) - (gwa-json-fn (string-append tmpdir "/GWA.json"))] + (gwa-json-fn (string-append tmpdir "/GWA.json")) + (trait-json-fn (string-append tmpdir "/" trait-fn))] + (copy-file trait-fn trait-json-fn) ;; --- First we compute K - control output goes to K.json - (let [(err (system (string-append "/gemma-wrapper/bin/gemma-wrapper --verbose --population \"" population "\" --name \"" name "\" --trait \"" trait-name "\" --verbose --loco --json --parallel -- -gk -g BXD.8_geno.txt.gz -p " pheno-fn " -a BXD.8_snps.txt > " k-json-fn )))] + (let [(err (system (string-append "/gemma-wrapper/bin/gemma-wrapper --verbose --population \"" population "\" --name \"" name "\" --trait \"" trait-name "\" --verbose --loco --json --parallel -- -gk -g " geno-fn " -p " pheno-fn " -a BXD.8_snps.txt > " k-json-fn )))] (if (not (= err 0)) (exit err))) - (let [(err (system (string-append "/gemma-wrapper/bin/gemma-wrapper --population \"" population "\" --name \"" name "\" --id \"" trait-name "\" --trait \"" trait-name "\" --verbose --loco --json --input " k-json-fn " -- -g BXD.8_geno.txt.gz -p " pheno-fn " -a BXD.8_snps.txt -lmm 9 -maf 0.1 > " gwa-json-fn)))] + (let [(err (system (string-append "/gemma-wrapper/bin/gemma-wrapper --meta \"" trait-json-fn "\" --population \"" population "\" --name \"" name "\" --id \"" trait-name "\" --trait \"" trait-name "\" --verbose --loco --json --lmdb --input " k-json-fn " -- -g " geno-fn " -p " pheno-fn " -a BXD.8_snps.txt -lmm 9 -maf 0.1 > " gwa-json-fn)))] (if (not (= err 0)) (exit err))) - ;; (delete-file pheno-fn) - ;; (delete-file gwa-json-fn) - ;; (delete-file k-json-fn) - ;; (rmdir tmpdir) + (delete-file pheno-fn) + (delete-file gwa-json-fn) + (delete-file k-json-fn) + (delete-file trait-json-fn) + (rmdir tmpdir) ) ) diff --git a/guix.scm b/guix.scm index 4417452..973f44f 100644..120000 --- a/guix.scm +++ b/guix.scm @@ -1,71 +1 @@ -;; To use this file to build HEAD of gn-guile: -;; -;; guix build -f guix.scm -;; -;; To get a development container -;; -;; guix shell -C -D -f guix.scm -;; - -(use-modules - ((guix licenses) #:prefix license:) - (guix gexp) - (guix packages) - (guix git-download) - (guix build-system guile) - (gnu packages algebra) - (gnu packages base) - (gnu packages bash) - (gnu packages compression) - (gnu packages bioinformatics) - (gnu packages build-tools) - (gnu packages certs) - (gnu packages curl) - (gnu packages gcc) - (gnu packages guile) - (gnu packages guile-xyz) - (gnu packages llvm) - (gnu packages ninja) - (gnu packages parallel) - (gnu packages perl) - (gnu packages perl6) - (gnu packages pkg-config) - (gnu packages python) - (gnu packages tls) - (srfi srfi-1) - (ice-9 popen) - (ice-9 rdelim)) - -(define %source-dir (dirname (current-filename))) - -(define %git-commit - (read-string (open-pipe "git show HEAD | head -1 | cut -d ' ' -f 2" OPEN_READ))) - -(define-public gn-guile-git - (package - (name "gn-guile-git") - (version (git-version "4.0.0-" "HEAD" %git-commit)) - (source (local-file %source-dir #:recursive? #t)) - (build-system guile-build-system) - - (inputs - (list guile-3.0-latest bash-minimal perl - guile-dbi guile-dbd-mysql guile-fibers guile-gnutls guile-readline guile-redis openssl nss-certs gemma parallel)) - (propagated-inputs - (list guile-json-4)) - -#! - (arguments - `(#:compile-flags '("--r6rs" "-Wunbound-variable" "-Warity-mismatch") - #:modules ((guix build guile-build-system) - (guix build utils) - (srfi srfi-26) - (ice-9 ftw) - (json)))) -!# - (home-page "https://git.genenetwork.com/gn-guile") - (synopsis "Next generation GN code in guile") - (description "Use of guile.") - (license license:gpl3))) - -gn-guile-git +.guix/modules/gn-guile.scm \ No newline at end of file diff --git a/scripts/lmdb-publishdata-export.scm b/scripts/lmdb-publishdata-export.scm new file mode 100755 index 0000000..8427112 --- /dev/null +++ b/scripts/lmdb-publishdata-export.scm @@ -0,0 +1,229 @@ +#! /usr/bin/env guile +!# +;; To run this script run: +;; +;; $ guix shell guile guile-hashing guile3-dbi guile3-dbd-mysql \ +;; guile-lmdb -- guile lmdb-publishdata-export.scm +;; conn.scm +;; +;; Example conn.scm: +;; ((sql-username . "webqtlout") +;; (sql-password . "xxxx") +;; (sql-database . "db_webqtl") +;; (sql-host . "localhost") +;; (sql-port . 3306) +;; (output-dir . "/tmp/data") +;; (log-file . "/tmp/export.log")) + +(use-modules (dbi dbi) + (rnrs bytevectors) + (system foreign) + (ice-9 match) + (srfi srfi-1) + (srfi srfi-26) + (srfi srfi-43) + (rnrs io ports) + (hashing md5) + ((lmdb lmdb) #:prefix mdb:) + (ice-9 format) + (ice-9 exceptions) + (json) + (logging logger) + (logging rotating-log) + (logging port-log) + (oop goops)) + + +;; Set up logging +(define* (setup-logging #:key (log-file "lmdb-dump-log")) + "Initialize the logging system with rotating file logs and error port output. + Creates a new logger, adds rotating and error port handlers, + sets it as the default logger, and opens the log for writing." + (let ((lgr (make <logger>)) + (rotating (make <rotating-log> + #:num-files 3 + #:size-limit 1024 + #:file-name log-file)) + (err (make <port-log> #:port (current-error-port)))) + ;; add the handlers to our logger + (add-handler! lgr rotating) + (add-handler! lgr err) + ;; make this the application's default logger + (set-default-logger! lgr) + (open-log! lgr))) + +(define (shutdown-logging) + "Properly shutdown the logging system. + Flushes any pending log messages, closes the log handlers, + and removes the default logger reference." + (flush-log) ;; since no args, it uses the default + (close-log!) ;; since no args, it uses the default + (set-default-logger! #f)) + +(define (call-with-database backend connection-string proc) + "Execute PROC with an open database connection. BACKEND is the +database type (e.g. \"mysql\"). CONNECTION-STRING is the database +connection string." + (let ((db #f)) + (dynamic-wind + (lambda () + (set! db (dbi-open backend connection-string))) + (cut proc db) + (lambda () + (when db + (dbi-close db)))))) + +(define (call-with-target-database connection-settings proc) + "Connect to the target database using CONNECTION-SETTINGS and execute +PROC." + (call-with-database "mysql" (string-join + (list (assq-ref connection-settings 'sql-username) + (assq-ref connection-settings 'sql-password) + (assq-ref connection-settings 'sql-database) + "tcp" + (assq-ref connection-settings 'sql-host) + (number->string + (assq-ref connection-settings 'sql-port))) + ":") + proc)) + +(define* (lmdb-save path key value) + "Save a NUM with KEY to PATH." + (mdb:with-env-and-txn + (path) (env txn) + (let ((dbi (mdb:dbi-open txn #f 0))) + (mdb:put txn dbi key + (if (number? value) + (number->string value) + value))))) + +(define (sql-exec db statement) + "Execute an SQL STATEMENT on database connection DB. Throws an error +if the statement execution fails." + (dbi-query db statement) + (database-check-status db)) + +(define (sql-fold proc init db statement) + "Fold over SQL query results." + (sql-exec db statement) + (let loop ((result init)) + (let ((row (dbi-get_row db))) + (if row + (loop (proc row result)) + result)))) + +(define (sql-for-each proc db statement) + "Apply PROC to each row returned by STATEMENT." + (sql-fold (lambda (row _) + (proc row)) + #f db statement)) + +(define (sql-map proc db statement) + "Map PROC over rows returned by STATEMENT." + (sql-fold (lambda (row result) + (cons (proc row) result)) + (list) db statement)) + +(define (sql-find db statement) + (sql-exec db statement) + (dbi-get_row db)) + +(define (database-check-status db) + "Check the status of the last database operation on DB. Throws an +error if the status code is non-zero." + (match (dbi-get_status db) + ((code . str) + (unless (zero? code) + (error str))))) + +(define* (save-dataset-values settings) + "Main function to extract and save dataset values. Queries the +database for datasets and their values, computes MD5 hashes for +dataset-trait combinations, and saves strain values to LMDB files in +/export5/lmdb-data-hashes/." + (dynamic-wind + (lambda () + (setup-logging #:log-file (assq-ref settings 'log-file)) + (log-msg 'INFO "Starting dataset value extraction")) + (lambda () + (call-with-target-database + settings + (lambda (db) + (sql-for-each + (lambda (row) + (match row + ((("Name" . dataset-name) + ("Id" . trait-id)) + (let* ((data-query (format #f "SELECT +JSON_ARRAYAGG(JSON_ARRAY(Strain.Name, PublishData.Value)) AS data, + MD5(JSON_ARRAY(Strain.Name, PublishData.Value)) as md5hash +FROM + PublishData + INNER JOIN Strain ON PublishData.StrainId = Strain.Id + INNER JOIN PublishXRef ON PublishData.Id = PublishXRef.DataId + INNER JOIN PublishFreeze ON PublishXRef.InbredSetId = PublishFreeze.InbredSetId +LEFT JOIN PublishSE ON + PublishSE.DataId = PublishData.Id AND + PublishSE.StrainId = PublishData.StrainId +LEFT JOIN NStrain ON + NStrain.DataId = PublishData.Id AND + NStrain.StrainId = PublishData.StrainId +WHERE + PublishFreeze.Name = \"~a\" AND + PublishXRef.Id = ~a AND + PublishFreeze.public > 0 AND + PublishData.value IS NOT NULL AND + PublishFreeze.confidentiality < 1 +ORDER BY + LENGTH(Strain.Name), Strain.Name" dataset-name trait-id))) + (match (call-with-target-database + settings + (lambda (db2) (sql-find db2 data-query))) + ((("data" . data) + ("md5hash" . md5-hash)) + (let* ((trait-name (format #f "~a~a" dataset-name trait-id)) + (base-dir (assq-ref settings 'output-dir)) + (out (format #f "~a-~a" trait-name + (substring md5-hash 0 12))) + (out-dir (format #f "~a/~a" base-dir out))) + (log-msg + 'INFO (format #f "Writing ~a to: ~a" trait-name out-dir)) + (unless (file-exists? out-dir) + (mkdir out-dir)) + (lmdb-save (format #f "~a/index" base-dir) trait-name out) + (vector-for-each + (lambda (_ x) + (match x + (#(strain value) + (lmdb-save out-dir strain value)))) + (json-string->scm data))))))))) + db + "SELECT DISTINCT PublishFreeze.Name, PublishXRef.Id FROM +PublishData INNER JOIN Strain ON PublishData.StrainId = Strain.Id +INNER JOIN PublishXRef ON PublishData.Id = PublishXRef.DataId +INNER JOIN PublishFreeze ON PublishXRef.InbredSetId = PublishFreeze.InbredSetId +LEFT JOIN PublishSE ON + PublishSE.DataId = PublishData.Id AND + PublishSE.StrainId = PublishData.StrainId +LEFT JOIN NStrain ON + NStrain.DataId = PublishData.Id AND + NStrain.StrainId = PublishData.StrainId +WHERE + PublishFreeze.public > 0 AND + PublishFreeze.confidentiality < 1 +ORDER BY + PublishFreeze.Id, PublishXRef.Id")))) + (lambda () + (shutdown-logging)))) + +(define main + (match-lambda* + ((_ connection-settings-file) + (save-dataset-values (call-with-input-file connection-settings-file + read))) + ((arg0 _ ...) + (display (format "Usage: ~a CONNECTION-SETTINGS-FILE~%" arg0) + (current-error-port)) + (exit #f)))) + +(apply main (command-line)) diff --git a/scripts/precompute/list-traits-to-compute.scm b/scripts/precompute/list-traits-to-compute.scm index 2c48d83..102a6fa 100755 --- a/scripts/precompute/list-traits-to-compute.scm +++ b/scripts/precompute/list-traits-to-compute.scm @@ -15,6 +15,10 @@ You may want to forward a mysql port if there is no DB locally ssh -L 3306:127.0.0.1:3306 -f -N tux02.genenetwork.org +ignore IPv6 message: + + bind [::1]:3306: Cannot assign requested address + test connection with mysql client: mysql -uwebqtlout -pwebqtlout -A -h 127.0.0.1 -P 3306 db_webqtl -e "show tables;" @@ -78,19 +82,50 @@ When that is the case we might as well write the phenotype file because we have (json) (rnrs bytevectors) (srfi srfi-1) + (srfi srfi-9) (srfi srfi-19) ; time ) +(define (get-trait db probeset-id) + (dbi-query db (string-append "select Id,Chr,Mb,Name,Symbol,description from ProbeSet where Id=" (int-to-string probeset-id) " limit 1")) + (get-row db) + ) + +#! + +The following is produced by gemma-wrapper as metadata + + "meta": { + "type": "gemma-wrapper", + "version": "0.99.7-pre1", + "population": "BXD", + "name": "HC_U_0304_R", + "trait": "101500_at", + "url": "https://genenetwork.org/show_trait?trait_id=101500_at&dataset=HC_U_0304_R", + "archive_GRM": "46bfba373fe8c19e68be6156cad3750120280e2e-gemma-cXX.tar.xz", + "archive_GWA": "779a54a59e4cd03608178db4068791db4ca44ab3-gemma-GWA.tar.xz", + "dataid": 75629, + "probesetid": 1097, + "probesetfreezeid": 7 + } -(define (write-json-ld id recs) +!# + + +(define (write-json-ld id name trait trait-name probesetfreeze-id probeset-id recs) ;; see also https://www.w3.org/2018/jsonld-cg-reports/json-ld/ (display id) + (display ":") + (display name) + (display ":") + (display trait-name) (newline) (let* [(traits (map (lambda (r) (match r [(strain-id . value) (cons (bxd-name strain-id) value)] )) (reverse recs))) + (uri (format #f "https://genenetwork.org/show_trait?trait_id=~a&dataset=~a" trait-name name)) (sha256 (sha-256->string (sha-256 (string->utf8 (scm->json-string traits))))) (json-data `(("@context" . "https://genenetwork.org/resource") (type . traits) @@ -98,8 +133,16 @@ When that is the case we might as well write the phenotype file because we have (steps . ()) (sha256 . ((input-traits . ,sha256))) (time . ,(date->string (time-utc->date (current-time)))))) - (traits . - ((,id . ,traits)))))] + (data . + ((,id . + ((group . "BXD") + (probesetfreeze-id . ,probesetfreeze-id) + (probeset-id . ,probeset-id) + (name . ,name) + (trait-name . ,trait-name) + (uri . ,uri) + (traits . ,traits) + ))))))] (call-with-output-file (string-append (number->string id) ".json") (lambda (port) (put-string port (scm->json-string json-data)))) @@ -111,22 +154,23 @@ When that is the case we might as well write the phenotype file because we have (begin ;; (let [(bxd-strains (memo-bxd-strain-id-names #:used-for-mapping? #t))] (define (run-list-traits-to-compute db num prev-id) + ;; ---- Build a query to collect num traits (let* [(count (if (< batch-size num) batch-size num)) (rest (- num count)) (hits (get-precompute-hits db prev-id count)) - (data-ids (map (lambda (hit) - (let* [(data-id (assoc-ref hit "DataId")) - ; (data-id-str (int-to-string data-id)) - ] - data-id)) + (data-ids (map (lambda (h) + (hit-data-id h)) hits)) (data-str-ids (map (lambda (id) (string-append "Id=" (int-to-string id))) data-ids)) (data-ids-query (string-join data-str-ids " OR ")) (query (string-append "SELECT Id,StrainId,value FROM ProbeSetData WHERE " data-ids-query)) ] + (format #t "writing-phenotypes from ~d to ~d batch ~d to ~d\n" first-id (+ first-id num) prev-id (+ prev-id count)) + (display query) (dbi-query db query) + ;; ---- Walk each resulting trait and build a hash of data-id and list of trait values (let [(id-traits (get-rows db '())) (nrecs '())] (for-each (lambda (r) @@ -140,12 +184,20 @@ When that is the case we might as well write the phenotype file because we have )] (set! nrecs (assoc-set! nrecs data-id lst)))) id-traits) - (for-each (lambda (r) - (match r - ((id . recs) (if (has-bxd? recs) - (write-json-ld id recs) - )) - )) nrecs) + ;; --- create the json output as a file by walking traits and hits + (for-each (lambda (h) + (let* [ + (id (hit-data-id h)) + (probeset-id (hit-probeset-id h)) + (probesetfreeze-id (hit-probesetfreeze-id h)) + (name (dataset-name db probesetfreeze-id)) + (trait (get-trait db probeset-id)) + (trait-name (assoc-ref trait "Name")) + (recs (assoc-ref nrecs id)) + ] + (if (has-bxd? recs) + (write-json-ld id name trait trait-name probesetfreeze-id probeset-id recs) + ))) hits) (if (> rest 0) (run-list-traits-to-compute db rest (first (reverse data-ids)))) ;; start precompute ))) diff --git a/scripts/precompute/run-gemma.scm b/scripts/precompute/run-gemma.scm index e6a4e26..4952834 100755 --- a/scripts/precompute/run-gemma.scm +++ b/scripts/precompute/run-gemma.scm @@ -9,7 +9,7 @@ Run from base dir with and with some extra paths (for gemma) -~/opt/guix-pull/bin/guix shell -C -F xz tar time parallel coreutils-minimal guile guile-dbi guile-json ruby --expose=/home/wrk/iwrk/opensource/code/genetics/gemma-wrapper/=/gemma-wrapper --expose=/home/wrk/iwrk/opensource/code/genetics/gemma/=/gemma -- env TMPDIR=tmp GEMMA_COMMAND=/gemma/bin/gemma-0.98.5-linux-static-debug guile -L . -e main -s ./scripts/precompute/run-gemma.scm +~/opt/guix-pull/bin/guix shell -C -F xz python python-lmdb tar time parallel coreutils-minimal guile guile-dbi guile-json ruby --expose=/home/wrk/iwrk/opensource/code/genetics/gemma-wrapper/=/gemma-wrapper --expose=/home/wrk/iwrk/opensource/code/genetics/gemma/=/gemma -- env TMPDIR=tmp GEMMA_COMMAND=/gemma/bin/gemma-0.98.5-linux-static-debug guile -L . -e main -s ./scripts/precompute/run-gemma.scm --id 21529 !# @@ -30,24 +30,36 @@ and with some extra paths (for gemma) ;; (write args) (let* [ (option-spec '( (version (single-char #\v) (value #f)) + (id (value #t)) (help (single-char #\h) (value #f)))) (options (getopt-long args option-spec)) + (show-version (option-ref options 'version #f)) (help-wanted (option-ref options 'help #f))] - (display "RUNNING") + (if show-version + (begin + (display "run-gemma version 1.0\n") + (exit))) (if help-wanted - (format #t "list-traits-to-compute writes JSON traits files from the GN DB -Usage: list-traits-to-compute [options...] - -h, --help Display this help -")) - (let [(trait-name "115475")] - (call-with-input-file "115475.json" + (format #t "run-gemma +Usage: run-gemma [options...] filename(s) + --id Run on identifier + -v --version Display version + -h --help Display this help +") + (let* [(trait-id (option-ref options 'id "0")) + (trait-fn (string-append trait-id ".json")) + ] + + (call-with-input-file trait-fn (lambda (port) (let* [(json (json->scm port)) - (dataset (assoc-ref json "traits")) - (dataset-name (car (car dataset))) - (traits (assoc-ref dataset dataset-name)) + (dataset (car (assoc-ref json "data"))) + (data (cdr dataset)) + (dataset-name (assoc-ref data "name")) + (trait-name (assoc-ref data "trait-name")) + (traits (assoc-ref data "traits")) + (pheno-fn (string-append trait-id "-pheno.txt")) ] - (display dataset) - (write-pheno-file "pheno.txt" traits) - (invoke-gemma-wrapper-loco dataset-name trait-name "pheno.txt") - )))))) + (write-pheno-file pheno-fn traits) + (invoke-gemma-wrapper-loco dataset-name trait-name trait-fn pheno-fn "BXD.8_geno.txt.gz") + ))))))) 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/gn-uri.scm b/web/gn-uri.scm index b849e95..3455d51 100644 --- a/web/gn-uri.scm +++ b/web/gn-uri.scm @@ -3,11 +3,10 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) - #:export ( - get-version - ; url-parse-id - ; normalize-id - ; strip-lang + #:export (get-version + ;; url-parse-id + ;; normalize-id + ;; strip-lang mk-meta mk-data mk-doc @@ -18,50 +17,38 @@ mk-predicate prefix url-parse-id - normalize-id - )) - + normalize-id)) (define (normalize-id str) ;; (string-replace-substring (string-downcase str) " " "_") (match str (#f "unknown") - (_ (string-replace-substring str " " "_")) - )) + (_ (string-replace-substring str " " "_")))) (define (url-parse-id uri) (if uri - (car (reverse (string-split uri #\057))) - "unknown" - )) + (car (reverse (string-split uri #\/))) "unknown")) (define get-version "4.0.0") -; (define base-url -; "https://luna.genenetwork.org") - -;(define (prefix) -; "Build the API URL including version" -; (string-append base-url "/api/v" get-version)) - (define base-url "http://localhost:8091") -(define uri-base-url ; always points to genenetwork.org! +(define uri-base-url + ;always points to genenetwork.org! "http://genenetwork.org") (define (prefix) - "Build the API URL including version" - base-url) + "Build the API URL including version" base-url) -(define* (mk-url postfix #:optional (ext "")) +(define* (mk-url postfix + #:optional (ext "")) "Makes a fully qualified URL by adding the path (postfix+ext) to the API URL. If there is an existing http+hostname no prefix is added" (match (string-match "^http:" postfix) - [ #f (string-append (prefix) "/" postfix ext)] - [ _ (string-append postfix ext)] - )) + (#f (string-append (prefix) "/" postfix ext)) + (_ (string-append postfix ext)))) (define* (mk-uri postfix) "Add the path to the GN URI. A URI always points to http://genenetwork.org/" @@ -92,9 +79,11 @@ (define (mk-id postfix) "Expand URL to make $api/id/identifier. If postfix is a path it will only apply the last element" - (mk-url (string-append "id" "/" (url-parse-id postfix)))) + (mk-url (string-append "id" "/" + (url-parse-id postfix)))) (define (mk-gnid postfix) "Expand URL to make http://genenetwork.org/id/identifier. If postfix is a path it will only apply the last element" - (mk-uri (string-append "id" "/" (url-parse-id postfix)))) + (mk-uri (string-append "id" "/" + (url-parse-id postfix)))) diff --git a/web/sxml.scm b/web/sxml.scm index de30b3f..29eeee3 100644 --- a/web/sxml.scm +++ b/web/sxml.scm @@ -30,277 +30,274 @@ #:export (sxml->html)) (define %self-closing-tags - '(area - base - br - col - command - embed - hr - img - input - keygen - link - meta - param - source - track - wbr)) + '(area base + br + col + command + embed + hr + img + input + keygen + link + meta + param + source + track + wbr)) (define (self-closing-tag? tag) "Return #t if TAG is self-closing." (pair? (memq tag %self-closing-tags))) (define %escape-chars - (alist->hash-table - '((#\" . "quot") - (#\& . "amp") - (#\' . "apos") - (#\< . "lt") - (#\> . "gt") - (#\¡ . "iexcl") - (#\¢ . "cent") - (#\£ . "pound") - (#\¤ . "curren") - (#\¥ . "yen") - (#\¦ . "brvbar") - (#\§ . "sect") - (#\¨ . "uml") - (#\© . "copy") - (#\ª . "ordf") - (#\« . "laquo") - (#\¬ . "not") - (#\® . "reg") - (#\¯ . "macr") - (#\° . "deg") - (#\± . "plusmn") - (#\² . "sup2") - (#\³ . "sup3") - (#\´ . "acute") - (#\µ . "micro") - (#\¶ . "para") - (#\· . "middot") - (#\¸ . "cedil") - (#\¹ . "sup1") - (#\º . "ordm") - (#\» . "raquo") - (#\¼ . "frac14") - (#\½ . "frac12") - (#\¾ . "frac34") - (#\¿ . "iquest") - (#\À . "Agrave") - (#\Á . "Aacute") - (#\ . "Acirc") - (#\à . "Atilde") - (#\Ä . "Auml") - (#\Å . "Aring") - (#\Æ . "AElig") - (#\Ç . "Ccedil") - (#\È . "Egrave") - (#\É . "Eacute") - (#\Ê . "Ecirc") - (#\Ë . "Euml") - (#\Ì . "Igrave") - (#\Í . "Iacute") - (#\Î . "Icirc") - (#\Ï . "Iuml") - (#\Ð . "ETH") - (#\Ñ . "Ntilde") - (#\Ò . "Ograve") - (#\Ó . "Oacute") - (#\Ô . "Ocirc") - (#\Õ . "Otilde") - (#\Ö . "Ouml") - (#\× . "times") - (#\Ø . "Oslash") - (#\Ù . "Ugrave") - (#\Ú . "Uacute") - (#\Û . "Ucirc") - (#\Ü . "Uuml") - (#\Ý . "Yacute") - (#\Þ . "THORN") - (#\ß . "szlig") - (#\à . "agrave") - (#\á . "aacute") - (#\â . "acirc") - (#\ã . "atilde") - (#\ä . "auml") - (#\å . "aring") - (#\æ . "aelig") - (#\ç . "ccedil") - (#\è . "egrave") - (#\é . "eacute") - (#\ê . "ecirc") - (#\ë . "euml") - (#\ì . "igrave") - (#\í . "iacute") - (#\î . "icirc") - (#\ï . "iuml") - (#\ð . "eth") - (#\ñ . "ntilde") - (#\ò . "ograve") - (#\ó . "oacute") - (#\ô . "ocirc") - (#\õ . "otilde") - (#\ö . "ouml") - (#\÷ . "divide") - (#\ø . "oslash") - (#\ù . "ugrave") - (#\ú . "uacute") - (#\û . "ucirc") - (#\ü . "uuml") - (#\ý . "yacute") - (#\þ . "thorn") - (#\ÿ . "yuml") - (#\Œ . "OElig") - (#\œ . "oelig") - (#\Š . "Scaron") - (#\š . "scaron") - (#\Ÿ . "Yuml") - (#\ƒ . "fnof") - (#\ˆ . "circ") - (#\˜ . "tilde") - (#\Α . "Alpha") - (#\Β . "Beta") - (#\Γ . "Gamma") - (#\Δ . "Delta") - (#\Ε . "Epsilon") - (#\Ζ . "Zeta") - (#\Η . "Eta") - (#\Θ . "Theta") - (#\Ι . "Iota") - (#\Κ . "Kappa") - (#\Λ . "Lambda") - (#\Μ . "Mu") - (#\Ν . "Nu") - (#\Ξ . "Xi") - (#\Ο . "Omicron") - (#\Π . "Pi") - (#\Ρ . "Rho") - (#\Σ . "Sigma") - (#\Τ . "Tau") - (#\Υ . "Upsilon") - (#\Φ . "Phi") - (#\Χ . "Chi") - (#\Ψ . "Psi") - (#\Ω . "Omega") - (#\α . "alpha") - (#\β . "beta") - (#\γ . "gamma") - (#\δ . "delta") - (#\ε . "epsilon") - (#\ζ . "zeta") - (#\η . "eta") - (#\θ . "theta") - (#\ι . "iota") - (#\κ . "kappa") - (#\λ . "lambda") - (#\μ . "mu") - (#\ν . "nu") - (#\ξ . "xi") - (#\ο . "omicron") - (#\π . "pi") - (#\ρ . "rho") - (#\ς . "sigmaf") - (#\σ . "sigma") - (#\τ . "tau") - (#\υ . "upsilon") - (#\φ . "phi") - (#\χ . "chi") - (#\ψ . "psi") - (#\ω . "omega") - (#\ϑ . "thetasym") - (#\ϒ . "upsih") - (#\ϖ . "piv") - (#\ . "ensp") - (#\ . "emsp") - (#\ . "thinsp") - (#\– . "ndash") - (#\— . "mdash") - (#\‘ . "lsquo") - (#\’ . "rsquo") - (#\‚ . "sbquo") - (#\“ . "ldquo") - (#\” . "rdquo") - (#\„ . "bdquo") - (#\† . "dagger") - (#\‡ . "Dagger") - (#\• . "bull") - (#\… . "hellip") - (#\‰ . "permil") - (#\′ . "prime") - (#\″ . "Prime") - (#\‹ . "lsaquo") - (#\› . "rsaquo") - (#\‾ . "oline") - (#\⁄ . "frasl") - (#\€ . "euro") - (#\ℑ . "image") - (#\℘ . "weierp") - (#\ℜ . "real") - (#\™ . "trade") - (#\ℵ . "alefsym") - (#\← . "larr") - (#\↑ . "uarr") - (#\→ . "rarr") - (#\↓ . "darr") - (#\↔ . "harr") - (#\↵ . "crarr") - (#\⇐ . "lArr") - (#\⇑ . "uArr") - (#\⇒ . "rArr") - (#\⇓ . "dArr") - (#\⇔ . "hArr") - (#\∀ . "forall") - (#\∂ . "part") - (#\∃ . "exist") - (#\∅ . "empty") - (#\∇ . "nabla") - (#\∈ . "isin") - (#\∉ . "notin") - (#\∋ . "ni") - (#\∏ . "prod") - (#\∑ . "sum") - (#\− . "minus") - (#\∗ . "lowast") - (#\√ . "radic") - (#\∝ . "prop") - (#\∞ . "infin") - (#\∠ . "ang") - (#\∧ . "and") - (#\∨ . "or") - (#\∩ . "cap") - (#\∪ . "cup") - (#\∫ . "int") - (#\∴ . "there4") - (#\∼ . "sim") - (#\≅ . "cong") - (#\≈ . "asymp") - (#\≠ . "ne") - (#\≡ . "equiv") - (#\≤ . "le") - (#\≥ . "ge") - (#\⊂ . "sub") - (#\⊃ . "sup") - (#\⊄ . "nsub") - (#\⊆ . "sube") - (#\⊇ . "supe") - (#\⊕ . "oplus") - (#\⊗ . "otimes") - (#\⊥ . "perp") - (#\⋅ . "sdot") - (#\⋮ . "vellip") - (#\⌈ . "lceil") - (#\⌉ . "rceil") - (#\⌊ . "lfloor") - (#\⌋ . "rfloor") - (#\〈 . "lang") - (#\〉 . "rang") - (#\◊ . "loz") - (#\♠ . "spades") - (#\♣ . "clubs") - (#\♥ . "hearts") - (#\♦ . "diams")))) + (alist->hash-table '((#\" . "quot") (#\& . "amp") + (#\' . "apos") + (#\< . "lt") + (#\> . "gt") + (#\¡ . "iexcl") + (#\¢ . "cent") + (#\£ . "pound") + (#\¤ . "curren") + (#\¥ . "yen") + (#\¦ . "brvbar") + (#\§ . "sect") + (#\¨ . "uml") + (#\© . "copy") + (#\ª . "ordf") + (#\« . "laquo") + (#\¬ . "not") + (#\® . "reg") + (#\¯ . "macr") + (#\° . "deg") + (#\± . "plusmn") + (#\² . "sup2") + (#\³ . "sup3") + (#\´ . "acute") + (#\µ . "micro") + (#\¶ . "para") + (#\· . "middot") + (#\¸ . "cedil") + (#\¹ . "sup1") + (#\º . "ordm") + (#\» . "raquo") + (#\¼ . "frac14") + (#\½ . "frac12") + (#\¾ . "frac34") + (#\¿ . "iquest") + (#\À . "Agrave") + (#\Á . "Aacute") + (#\ . "Acirc") + (#\à . "Atilde") + (#\Ä . "Auml") + (#\Å . "Aring") + (#\Æ . "AElig") + (#\Ç . "Ccedil") + (#\È . "Egrave") + (#\É . "Eacute") + (#\Ê . "Ecirc") + (#\Ë . "Euml") + (#\Ì . "Igrave") + (#\Í . "Iacute") + (#\Î . "Icirc") + (#\Ï . "Iuml") + (#\Ð . "ETH") + (#\Ñ . "Ntilde") + (#\Ò . "Ograve") + (#\Ó . "Oacute") + (#\Ô . "Ocirc") + (#\Õ . "Otilde") + (#\Ö . "Ouml") + (#\× . "times") + (#\Ø . "Oslash") + (#\Ù . "Ugrave") + (#\Ú . "Uacute") + (#\Û . "Ucirc") + (#\Ü . "Uuml") + (#\Ý . "Yacute") + (#\Þ . "THORN") + (#\ß . "szlig") + (#\à . "agrave") + (#\á . "aacute") + (#\â . "acirc") + (#\ã . "atilde") + (#\ä . "auml") + (#\å . "aring") + (#\æ . "aelig") + (#\ç . "ccedil") + (#\è . "egrave") + (#\é . "eacute") + (#\ê . "ecirc") + (#\ë . "euml") + (#\ì . "igrave") + (#\í . "iacute") + (#\î . "icirc") + (#\ï . "iuml") + (#\ð . "eth") + (#\ñ . "ntilde") + (#\ò . "ograve") + (#\ó . "oacute") + (#\ô . "ocirc") + (#\õ . "otilde") + (#\ö . "ouml") + (#\÷ . "divide") + (#\ø . "oslash") + (#\ù . "ugrave") + (#\ú . "uacute") + (#\û . "ucirc") + (#\ü . "uuml") + (#\ý . "yacute") + (#\þ . "thorn") + (#\ÿ . "yuml") + (#\Œ . "OElig") + (#\œ . "oelig") + (#\Š . "Scaron") + (#\š . "scaron") + (#\Ÿ . "Yuml") + (#\ƒ . "fnof") + (#\ˆ . "circ") + (#\˜ . "tilde") + (#\Α . "Alpha") + (#\Β . "Beta") + (#\Γ . "Gamma") + (#\Δ . "Delta") + (#\Ε . "Epsilon") + (#\Ζ . "Zeta") + (#\Η . "Eta") + (#\Θ . "Theta") + (#\Ι . "Iota") + (#\Κ . "Kappa") + (#\Λ . "Lambda") + (#\Μ . "Mu") + (#\Ν . "Nu") + (#\Ξ . "Xi") + (#\Ο . "Omicron") + (#\Π . "Pi") + (#\Ρ . "Rho") + (#\Σ . "Sigma") + (#\Τ . "Tau") + (#\Υ . "Upsilon") + (#\Φ . "Phi") + (#\Χ . "Chi") + (#\Ψ . "Psi") + (#\Ω . "Omega") + (#\α . "alpha") + (#\β . "beta") + (#\γ . "gamma") + (#\δ . "delta") + (#\ε . "epsilon") + (#\ζ . "zeta") + (#\η . "eta") + (#\θ . "theta") + (#\ι . "iota") + (#\κ . "kappa") + (#\λ . "lambda") + (#\μ . "mu") + (#\ν . "nu") + (#\ξ . "xi") + (#\ο . "omicron") + (#\π . "pi") + (#\ρ . "rho") + (#\ς . "sigmaf") + (#\σ . "sigma") + (#\τ . "tau") + (#\υ . "upsilon") + (#\φ . "phi") + (#\χ . "chi") + (#\ψ . "psi") + (#\ω . "omega") + (#\ϑ . "thetasym") + (#\ϒ . "upsih") + (#\ϖ . "piv") + (#\20002 . "ensp") + (#\20003 . "emsp") + (#\20011 . "thinsp") + (#\– . "ndash") + (#\— . "mdash") + (#\‘ . "lsquo") + (#\’ . "rsquo") + (#\‚ . "sbquo") + (#\“ . "ldquo") + (#\” . "rdquo") + (#\„ . "bdquo") + (#\† . "dagger") + (#\‡ . "Dagger") + (#\• . "bull") + (#\… . "hellip") + (#\‰ . "permil") + (#\′ . "prime") + (#\″ . "Prime") + (#\‹ . "lsaquo") + (#\› . "rsaquo") + (#\‾ . "oline") + (#\⁄ . "frasl") + (#\€ . "euro") + (#\ℑ . "image") + (#\℘ . "weierp") + (#\ℜ . "real") + (#\™ . "trade") + (#\ℵ . "alefsym") + (#\← . "larr") + (#\↑ . "uarr") + (#\→ . "rarr") + (#\↓ . "darr") + (#\↔ . "harr") + (#\↵ . "crarr") + (#\⇐ . "lArr") + (#\⇑ . "uArr") + (#\⇒ . "rArr") + (#\⇓ . "dArr") + (#\⇔ . "hArr") + (#\∀ . "forall") + (#\∂ . "part") + (#\∃ . "exist") + (#\∅ . "empty") + (#\∇ . "nabla") + (#\∈ . "isin") + (#\∉ . "notin") + (#\∋ . "ni") + (#\∏ . "prod") + (#\∑ . "sum") + (#\− . "minus") + (#\∗ . "lowast") + (#\√ . "radic") + (#\∝ . "prop") + (#\∞ . "infin") + (#\∠ . "ang") + (#\∧ . "and") + (#\∨ . "or") + (#\∩ . "cap") + (#\∪ . "cup") + (#\∫ . "int") + (#\∴ . "there4") + (#\∼ . "sim") + (#\≅ . "cong") + (#\≈ . "asymp") + (#\≠ . "ne") + (#\≡ . "equiv") + (#\≤ . "le") + (#\≥ . "ge") + (#\⊂ . "sub") + (#\⊃ . "sup") + (#\⊄ . "nsub") + (#\⊆ . "sube") + (#\⊇ . "supe") + (#\⊕ . "oplus") + (#\⊗ . "otimes") + (#\⊥ . "perp") + (#\⋅ . "sdot") + (#\⋮ . "vellip") + (#\⌈ . "lceil") + (#\⌉ . "rceil") + (#\⌊ . "lfloor") + (#\⌋ . "rfloor") + (#\〈 . "lang") + (#\〉 . "rang") + (#\◊ . "loz") + (#\♠ . "spades") + (#\♣ . "clubs") + (#\♥ . "hearts") + (#\♦ . "diams")))) (define (string->escaped-html s port) "Write the HTML escaped form of S to PORT." @@ -313,9 +310,7 @@ (define (object->escaped-html obj port) "Write the HTML escaped form of OBJ to PORT." - (string->escaped-html - (call-with-output-string (cut display obj <>)) - port)) + (string->escaped-html (call-with-output-string (cut display obj <>)) port)) (define (attribute-value->html value port) "Write the HTML escaped form of VALUE to PORT." @@ -334,11 +329,11 @@ list ATTRS and the child nodes in BODY." (format port "<~a" tag) (for-each (match-lambda - ((attr value) - (display #\space port) - (attribute->html attr value port))) - attrs) - (if (and (null? body) (self-closing-tag? tag)) + ((attr value) + (display #\space port) + (attribute->html attr value port))) attrs) + (if (and (null? body) + (self-closing-tag? tag)) (display " />" port) (begin (display #\> port) @@ -348,7 +343,8 @@ list ATTRS and the child nodes in BODY." (define (doctype->html doctype port) (format port "<!DOCTYPE ~a>" doctype)) -(define* (sxml->html tree #:optional (port (current-output-port))) +(define* (sxml->html tree + #:optional (port (current-output-port))) "Write the serialized HTML form of TREE to PORT." (match tree (() *unspecified*) @@ -357,10 +353,13 @@ list ATTRS and the child nodes in BODY." ;; Unescaped, raw HTML output (('raw html) (display html port)) - (((? symbol? tag) ('@ attrs ...) body ...) + (((? symbol? tag) + ('@ attrs ...) body ...) (element->html tag attrs body port)) - (((? symbol? tag) body ...) - (element->html tag '() body port)) + (((? symbol? tag) + body ...) + (element->html tag + '() body port)) ((nodes ...) (for-each (cut sxml->html <> port) nodes)) ((? string? text) 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/brand/aging.scm b/web/view/brand/aging.scm index 19db4d7..040c711 100644 --- a/web/view/brand/aging.scm +++ b/web/view/brand/aging.scm @@ -53,7 +53,7 @@ ,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/markdown.scm b/web/view/markdown.scm index 2af2b26..6aa2935 100644 --- a/web/view/markdown.scm +++ b/web/view/markdown.scm @@ -6,50 +6,126 @@ #:use-module (ice-9 receive) #:use-module (ice-9 string-fun) #:use-module (ice-9 textual-ports) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) #:use-module (sxml simple) #:use-module (web client) #:use-module (web uri) #:use-module (web request) #:use-module (web sxml) #:use-module (commonmark) - - #:export (markdown-file->sxml - markdown-github->sxml - fetch-raw-file) - ) - + #:export (markdown-file->sxml markdown-github->sxml fetch-file + fetch-raw-file commit-file git-invoke)) (define (markdown-file->sxml fn) "Parse a local file" - (commonmark->sxml - (call-with-input-file fn - get-string-all))) - -;; --- fetch github style URLs + (commonmark->sxml (call-with-input-file fn + get-string-all))) (define (fetch-raw-file url) (receive (response-status response-body) - (http-request url) - 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 +(define* (form-github-raw-url project repo page #:optional (branch "master")) + (string-append "https://raw.githubusercontent.com/" + project + "/" + repo + "/" + branch + "/" + (string-join page "/"))) -(define (form-github-raw-url project repo page) - (string-append "https://raw.githubusercontent.com/" project "/" repo "/master/" (string-join page "/"))) - -(define (form-github-edit-url project repo page) - (string-append "https://github.com/" project "/" repo "/edit/master/" (string-join page "/"))) +(define* (form-github-edit-url project repo page #:optional (branch "master")) + (string-append "https://github.com/" + project + "/" + repo + "/edit/" + branch + "/" + (string-join page "/"))) (define (markdown-github->sxml path) "Parse a github markdown file that is formed like genenetwork/gn-docs/general/brand/aging/home.md" - (match-let (((project repo page ...) (string-split path #\/))) - `(div (@ (class "markdown")) - ,(commonmark->sxml - (fetch-raw-file (pk (form-github-raw-url project repo (pk page))))) - (p - (div (@ (class "button-align-right")) - (a (@ (href ,(form-github-edit-url project repo page)) (role "button")) "edit"))) - (br) - (br)))) + (match-let (((project repo page ...) + (string-split path #\/))) + `(div (@ (class "markdown")) + ,(commonmark->sxml (fetch-raw-file (pk (form-github-raw-url + project repo + (pk page))))) + (p (div (@ (class "button-align-right")) + (a (@ (href ,(form-github-edit-url project repo + page)) + (role "button")) "edit"))) + (br) + (br)))) + +(define (fetch-file repo query-path) + (let* ((abs-path (format #f "~a/~a" repo query-path))) + (if (file-exists? abs-path) + (let* ((full-path (canonicalize-path abs-path)) + (content (call-with-input-file full-path + get-string-all)) + (commit-sha (get-latest-commit-sha1 repo))) + `(("file_path" unquote query-path) + ("content" unquote content) + ("hash" unquote commit-sha))) + (throw 'file-error + (format #f "~a does not exists" abs-path))))) + +(define (git-invoke repo-path . args) + (apply system* "git" "-C" repo-path args)) + +(define (git-repository? repo-path) + (let ((data (git-invoke repo-path "rev-parse"))) + (zero? data))) + +(define (get-latest-commit-sha1 repo-path) + (let* ((output-port (open-input-pipe (string-append "git -C " repo-path + " log -n 1 --pretty=format:%H HEAD"))) + (commit-sha (read-line output-port))) + (close-port output-port) commit-sha)) + +(define* (commit-file repo + file-path + content + commit-message + username + email + #:optional (prev-commit "")) + (unless (string=? prev-commit + (get-latest-commit-sha1 repo)) + (throw 'system-error + (format #f + "Commits do no match.Please pull in latest changes for current * ~a * and prev * ~a * " + (get-latest-commit-sha1 repo) prev-commit))) + (if (git-repository? repo) + (match (file-exists? (format #f "~a/~a" repo file-path)) + (#t (with-output-to-file (format #f "~a/~a" repo file-path) + (lambda () + (display content))) + (let* ((git-add-file (git-invoke repo "add" file-path)) + (git-commit-file (git-invoke repo + "commit" + "-m" + commit-message + "-m" + " * Commit made via the GN Markdown Editor" + "--author" + (format #f "~a <~a>" username email))) + (git-commit-sha (get-latest-commit-sha1 repo))) + (if (zero? git-commit-file) + `(("status" . "201") + ("message" . "committed file successfully") + ("content" . ,content) + ("commit_sha" . ,git-commit-sha) + ("commit_message" . ,commit-message)) + `(("status" . "200") + ("message" . "Nothing to commit, working tree clean") + ("commit_sha" . ,git-commit-sha))))) + (#f (throw 'system-error + (format #f "~a File does not exist error" file-path)))) + (throw 'system-error + (format #f "~a is no a git repo" repo)))) diff --git a/web/view/view.scm b/web/view/view.scm index 4584cf8..95ff0a1 100644 --- a/web/view/view.scm +++ b/web/view/view.scm @@ -10,11 +10,12 @@ #: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)) -(define (view-aging) +(define (view-aging-home) (aging-html #:info `( ,(markdown-github->sxml "genenetwork/gn-docs/general/brand/aging/home.md") @@ -44,7 +45,14 @@ data to benefit from the power of integrated datasets, please contact:") (define* (view-brand path) (match path - ("aging" (view-aging)) + ("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")) ( _ (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 05e842c..0c0bdd1 100755..100644 --- a/web/webserver.scm +++ b/web/webserver.scm @@ -1,69 +1,82 @@ -#!/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 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 - (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)) - - -(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"))))) +(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-13) + (srfi srfi-19) + (srfi srfi-26) + (rnrs io ports) + (rnrs bytevectors) + (web http) + (web client) + (web request) + (web response) + (web uri) + (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" . ,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 (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))))) -;; ---- REST API web server handler +(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) @@ -72,101 +85,249 @@ 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 #\.))) + (last (string-split file-name #\.))) ;; FIXME: does not handle files with multiple dots -(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 . ,(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 '())) +(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 . ,(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 '())) +(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-string str) + (list '((content-type application/txt)) + (lambda (port) + (put-string port str)))) + (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))) - (lambda (port) - (format port "~a" "foo")))) + (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)))) + +(define (decode-request-json body) + (if (not body) + '() + (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)) ""))) + (cons (string->symbol (uri-decode key)) + (uri-decode value)))) + +(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 200 + (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))))))) + +(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)) + (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) + (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" . ,key) + ("msg" . ,msg))))))) (define (controller request body) (match-lambda (('GET) - (render-json info)) + (render-json +info+)) (('GET "version") (render-json get-version)) - (('GET "css" fn ) - (render-static-file (string-append "css/" fn))) - (('GET "map" fn ) - (render-static-file (string-append "css/" fn))) + (('GET "css" fn) + (render-static-file (string-append (dirname (current-filename)) "/css/" fn))) + (('GET "map" 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 "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))) + (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 "gene" "aliases" genename) + (render-json (get-gene-aliases genename))) (('GET "species.json") (render-json (get-species-data))) (('GET "species.meta.json") (render-json (get-species-meta))) (('GET "species") (render-json (get-species-meta))) + (('GET "edit") + (edit-file-handler +current-repo-path+ request)) + (('POST "commit") + (commit-file-handler +current-repo-path+ 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")]))) - (_ (not-found (request-uri request))) - )) + ((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) (split-and-decode-uri-path (uri-path (request-uri request)))) @@ -182,16 +343,16 @@ 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 ;; 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!")) @@ -199,6 +360,4 @@ otherwise search for set/group data" (newline) (let ((listen (inexact->exact (string->number (car (cdr args)))))) (display `("listening on" ,listen)) - ;; (write listen) - ;; (run-server hello-world-handler 'http `(#:port ,listen)))) - (start-web-server "127.0.0.1" listen))) + (start-web-server "127.0.0.1" listen))) |