aboutsummaryrefslogtreecommitdiff
path: root/web
diff options
context:
space:
mode:
Diffstat (limited to 'web')
-rw-r--r--web/.guix-shell8
-rw-r--r--web/css/gn-template-style.css39
-rw-r--r--web/templates/genenetwork.scm18
-rw-r--r--web/view/markdown.scm29
-rw-r--r--web/view/view.scm4
-rw-r--r--web/webserver.scm108
6 files changed, 133 insertions, 73 deletions
diff --git a/web/.guix-shell b/web/.guix-shell
deleted file mode 100644
index b4aee2a..0000000
--- a/web/.guix-shell
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/bin/bash
-#
-# run with options '-- ./webserver.scm 8091' e.g.
-# . .guix-shell -- guile -L .. --fresh-auto-compile --listen=1970 -e main ./webserver.scm 8091
-
-echo "Note run: running web-server"
-
-guix shell guile guile-commonmark guile-fibers guile-json guile-gnutls guile-readline guile-redis openssl nss-certs $*
diff --git a/web/css/gn-template-style.css b/web/css/gn-template-style.css
new file mode 100644
index 0000000..38893c6
--- /dev/null
+++ b/web/css/gn-template-style.css
@@ -0,0 +1,39 @@
+* {
+ box-sizing: border-box;
+}
+
+body {
+ margin: 0.7em;
+ display: grid;
+ grid-template-columns: 9fr 1fr;
+ grid-gap: 20px;
+
+ font-family: "Helvetica Neue", Helvetica, Arial, sans-serif;
+ font-style: normal;
+ font-size: 20px;
+}
+
+#header {
+ grid-column-start: 1;
+ grid-column-end: 3;
+
+ background-color: #336699;
+ color: #FFFFFF;
+ border-radius: 3px;
+ min-height: 30px;
+}
+
+#header #header-text {
+ padding-left: 0.2em;
+}
+
+#main {
+ grid-column-start: 1;
+ grid-column-end: 2;
+
+ max-width: 650px;
+}
+
+#main img {
+ max-width: 650px;
+}
diff --git a/web/templates/genenetwork.scm b/web/templates/genenetwork.scm
new file mode 100644
index 0000000..64e9852
--- /dev/null
+++ b/web/templates/genenetwork.scm
@@ -0,0 +1,18 @@
+(define-module (web templates genenetwork)
+ #:use-module (web view markdown)
+
+ #:export (default-gn-template))
+
+(define* (default-gn-template path #:optional (title "Default Page Template"))
+ "Render `PATH' with a default template and styling that fits in with
+ GeneNetwork's look and feel."
+ `(html
+ (head
+ (meta (@ (charset "UTF-8")))
+ (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
+ (title ,title)
+ (link (@ (rel "stylesheet") (type "text/css")
+ (href "/css/gn-template-style.css"))))
+ (body
+ (header (@ (id "header")) (span (@ (id "header-text")) "GeneNetwork"))
+ (main (@ (id "main")) ,(markdown-github->sxml path)))))
diff --git a/web/view/markdown.scm b/web/view/markdown.scm
index 653596f..6aa2935 100644
--- a/web/view/markdown.scm
+++ b/web/view/markdown.scm
@@ -15,9 +15,8 @@
#:use-module (web request)
#:use-module (web sxml)
#:use-module (commonmark)
-
#:export (markdown-file->sxml markdown-github->sxml fetch-file
- fetch-raw-file commit-file))
+ fetch-raw-file commit-file git-invoke))
(define (markdown-file->sxml fn)
"Parse a local file"
@@ -26,26 +25,26 @@
(define (fetch-raw-file url)
(receive (response-status response-body)
- (http-request url) response-body))
-
-;; https://github.com/genenetwork/gn-docs/master/general/brand/aging/home.md
-;; https://raw.githubusercontent.com/genenetwork/gn-docs/master/general/brand/aging/home.md
-;; https://github.com/genenetwork/gn-docs/edit/master/general/brand/aging/home.md
+ (http-request url) response-body))
-(define (form-github-raw-url project repo page)
+(define* (form-github-raw-url project repo page #:optional (branch "master"))
(string-append "https://raw.githubusercontent.com/"
project
"/"
repo
- "/master/"
+ "/"
+ branch
+ "/"
(string-join page "/")))
-(define (form-github-edit-url project repo page)
+(define* (form-github-edit-url project repo page #:optional (branch "master"))
(string-append "https://github.com/"
project
"/"
repo
- "/edit/master/"
+ "/edit/"
+ branch
+ "/"
(string-join page "/")))
(define (markdown-github->sxml path)
@@ -120,12 +119,12 @@
(if (zero? git-commit-file)
`(("status" . "201")
("message" . "committed file successfully")
- ("content" unquote content)
- ("commit_sha" unquote git-commit-sha)
- ("commit_message" unquote commit-message))
+ ("content" . ,content)
+ ("commit_sha" . ,git-commit-sha)
+ ("commit_message" . ,commit-message))
`(("status" . "200")
("message" . "Nothing to commit, working tree clean")
- ("commit_sha" unquote git-commit-sha)))))
+ ("commit_sha" . ,git-commit-sha)))))
(#f (throw 'system-error
(format #f "~a File does not exist error" file-path))))
(throw 'system-error
diff --git a/web/view/view.scm b/web/view/view.scm
index 4584cf8..4300863 100644
--- a/web/view/view.scm
+++ b/web/view/view.scm
@@ -10,6 +10,7 @@
#:use-module (web view markdown)
#:use-module (web view brand msk)
#:use-module (web view brand aging)
+ #:use-module (web templates genenetwork)
#:export (view-brand))
@@ -45,6 +46,9 @@ data to benefit from the power of integrated datasets, please contact:")
(define* (view-brand path)
(match path
("aging" (view-aging))
+ ("gnqa" (default-gn-template
+ "genenetwork/gn-docs/general/brand/gnqa/gnqa.md"
+ "GeneNetwork Question and Answer System"))
( _ (msk-html #:info
`(
,(markdown-github->sxml "genenetwork/gn-docs/general/brand/msk/home.md")
diff --git a/web/webserver.scm b/web/webserver.scm
index 145f192..880ab49 100644
--- a/web/webserver.scm
+++ b/web/webserver.scm
@@ -27,22 +27,27 @@
(web view doc)
(web view markdown))
+(define +current-repo-path+
+ (getenv "CURRENT_REPO_PATH"))
+
+(define +cgit-repo-path+
+ (getenv "CGIT_REPO_PATH"))
+
(define +info+
- `(("name" . "GeneNetwork REST API") ("version" unquote get-version)
+ `(("name" . "GeneNetwork REST API") ("version" . ,get-version)
("comment" . "This is the official REST API for the GeneNetwork service hosted at https://genenetwork.org/")
("license"
("source code (unless otherwise specified)" . "Affero GNU Public License 3.0 (AGPL3)")
("data (unless otherwise specified)" . "Attribution-NonCommercial-NoDerivatives 4.0 International (CC BY-NC-ND 4.0)"))
("note" . "This is work in progress (WIP). Note that the final base URL will change! The temporary prefix is:")
- ("prefix" ,(prefix))
- ("links" ("species" ,(mk-meta "species")))))
+ ("prefix" . ,(prefix))
+ ("links" ("species" . ,(mk-meta "species")))))
(define +info-meta+
- `(("doc" unquote
- (mk-html "info"))
- ("API" ((unquote (mk-url "species")) . "Get a list of all species")
- ((unquote (mk-url "mouse")) . "Get information on mouse")
- ((unquote (mk-url "datasets")) . "Get a list of datasets"))))
+ `(("doc" ,(mk-html "info"))
+ ("API" ((,(mk-url "species")) . "Get a list of all species")
+ ((,(mk-url "mouse")) . "Get information on mouse")
+ ((,(mk-url "datasets")) . "Get a list of datasets"))))
(define (get-id-data id)
"Get data based on identifier id. If it is a taxon return the taxon data,
@@ -51,6 +56,10 @@ otherwise search for set/group data"
(if taxoninfo taxoninfo
(cdr (get-group-data id)))))
+(define (get-gene-aliases genename)
+ "Return a vector of aliases for genename."
+ (list->vector (memo-sparql-wd-gene-aliases (memo-sparql-wd-geneids genename))))
+
(define (not-found2 request)
(values (build-response #:code 404)
(string-append "Resource X not found: "
@@ -82,11 +91,9 @@ otherwise search for set/group data"
(modified (and stat
(make-time time-utc 0
(stat:mtime stat)))))
- (list `((content-type unquote
- (assoc-ref file-mime-types
- (file-extension file-name)))
- (last-modified unquote
- (time-utc->date modified)))
+ (list `((content-type . ,(assoc-ref file-mime-types
+ (file-extension file-name)))
+ (last-modified . ,(time-utc->date modified)))
(call-with-input-file file-name
get-bytevector-all))))
@@ -97,11 +104,9 @@ otherwise search for set/group data"
(modified (and stat
(make-time time-utc 0
(stat:mtime stat)))))
- (list `((content-type unquote
- (assoc-ref file-mime-types
- (file-extension path)))
- (last-modified unquote
- (time-utc->date modified)))
+ (list `((content-type . ,(assoc-ref file-mime-types
+ (file-extension path)))
+ (last-modified . ,(time-utc->date modified)))
(call-with-input-file path
get-bytevector-all))))
@@ -171,11 +176,8 @@ otherwise search for set/group data"
(lambda (key . args)
(let ((msg (car args)))
(build-json-response 400
- `(("error" unquote key)
- ("msg" unquote msg)))))))
-
-(define +global-repo+
- (getenv "REPO_PATH"))
+ `(("error" . ,key)
+ ("msg" . ,msg)))))))
(define (invalid-data? data target)
(if (string? (assoc-ref data target))
@@ -190,30 +192,34 @@ otherwise search for set/group data"
(define (commit-file-handler repo request body)
(catch 'system-error
(lambda ()
- (let* ((post-data (decode-request-json body))
- (_ (for-each (lambda (target)
- (invalid-data? post-data target))
- '("filename" "content" "username" "email"
- "prev_commit")))
- (file-name (assoc-ref post-data "filename"))
- (content (assoc-ref post-data "content"))
- (username (assoc-ref post-data "username"))
- (email (assoc-ref post-data "email"))
- (commit-message (assoc-ref post-data "commit_message"))
- (prev-commit (assoc-ref post-data "prev_commit")))
- (build-json-response 200
- (commit-file repo
- file-name
- content
- commit-message
- username
- email
- prev-commit))))
+ (let* ((post-data (decode-request-json body))
+ (_ (for-each (lambda (target)
+ (invalid-data? post-data target))
+ '("filename" "content" "username" "email"
+ "prev_commit")))
+ (file-name (assoc-ref post-data "filename"))
+ (content (assoc-ref post-data "content"))
+ (username (assoc-ref post-data "username"))
+ (email (assoc-ref post-data "email"))
+ (commit-message (assoc-ref post-data "commit_message"))
+ (prev-commit (assoc-ref post-data "prev_commit")))
+ (build-json-response 200
+ ((lambda ()
+ (let ((message
+ (commit-file +current-repo-path+
+ file-name
+ content
+ commit-message
+ username
+ email
+ prev-commit)))
+ (git-invoke +current-repo-path+ "push" +cgit-repo-path+)
+ message))))))
(lambda (key . args)
(let ((msg (car args)))
(build-json-response 400
- `(("error" unquote key)
- ("msg" unquote msg)))))))
+ `(("error" . ,key)
+ ("msg" . ,msg)))))))
(define (controller request body)
(match-lambda
@@ -222,13 +228,13 @@ otherwise search for set/group data"
(('GET "version")
(render-json get-version))
(('GET "css" fn)
- (render-static-file (string-append "css/" fn)))
+ (render-static-file (string-append (dirname (current-filename)) "/css/" fn)))
(('GET "map" fn)
- (render-static-file (string-append "css/" fn)))
+ (render-static-file (string-append (dirname (current-filename)) "/css/" fn)))
(('GET "static" "images" fn)
- (render-static-image (string-append "static/images/" fn)))
+ (render-static-image (string-append (dirname (current-filename)) "/static/images/" fn)))
(('GET "home" path)
- (render-brand path))
+ (render-brand path)) ; branding route for /home/aging, /home/msk etc
(('GET "doc" "species.html")
(render-doc "doc" "species.html"
(get-species-meta)))
@@ -245,6 +251,8 @@ otherwise search for set/group data"
(('GET "doc" path ... page)
;; serve documents from /doc/
(render-doc path page))
+ (('GET "gene" "aliases" genename)
+ (render-json (get-gene-aliases genename)))
(('GET "species.json")
(render-json (get-species-data)))
(('GET "species.meta.json")
@@ -252,9 +260,9 @@ otherwise search for set/group data"
(('GET "species")
(render-json (get-species-meta)))
(('GET "edit")
- (edit-file-handler +global-repo+ request))
+ (edit-file-handler +current-repo-path+ request))
(('POST "commit")
- (commit-file-handler +global-repo+ request body))
+ (commit-file-handler +current-repo-path+ request body))
(('GET id)
(let ((names (get-species-shortnames (get-expanded-species))))
(match (string->list id)
generated by cgit v1.2.3 (git 2.47.1) at 2025-07-17 03:18:54 +0000