diff options
Diffstat (limited to 'web')
| -rw-r--r-- | web/.guix-shell | 8 | ||||
| -rw-r--r-- | web/css/gn-template-style.css | 39 | ||||
| -rw-r--r-- | web/gn-uri.scm | 47 | ||||
| -rw-r--r-- | web/sxml.scm | 553 | ||||
| -rw-r--r-- | web/templates/genenetwork.scm | 18 | ||||
| -rw-r--r-- | web/view/brand/aging.scm | 2 | ||||
| -rw-r--r-- | web/view/brand/msk.scm | 2 | ||||
| -rw-r--r-- | web/view/doc.scm | 2 | ||||
| -rw-r--r-- | web/view/markdown.scm | 136 | ||||
| -rw-r--r-- | web/view/view.scm | 12 | ||||
| -rw-r--r--[-rwxr-xr-x] | web/webserver.scm | 393 |
11 files changed, 746 insertions, 466 deletions
diff --git a/web/.guix-shell b/web/.guix-shell deleted file mode 100644 index b4aee2a..0000000 --- a/web/.guix-shell +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/bash -# -# run with options '-- ./webserver.scm 8091' e.g. -# . .guix-shell -- guile -L .. --fresh-auto-compile --listen=1970 -e main ./webserver.scm 8091 - -echo "Note run: running web-server" - -guix shell guile guile-commonmark guile-fibers guile-json guile-gnutls guile-readline guile-redis openssl nss-certs $* diff --git a/web/css/gn-template-style.css b/web/css/gn-template-style.css new file mode 100644 index 0000000..38893c6 --- /dev/null +++ b/web/css/gn-template-style.css @@ -0,0 +1,39 @@ +* { + box-sizing: border-box; +} + +body { + margin: 0.7em; + display: grid; + grid-template-columns: 9fr 1fr; + grid-gap: 20px; + + font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; + font-style: normal; + font-size: 20px; +} + +#header { + grid-column-start: 1; + grid-column-end: 3; + + background-color: #336699; + color: #FFFFFF; + border-radius: 3px; + min-height: 30px; +} + +#header #header-text { + padding-left: 0.2em; +} + +#main { + grid-column-start: 1; + grid-column-end: 2; + + max-width: 650px; +} + +#main img { + max-width: 650px; +} diff --git a/web/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))) |