aboutsummaryrefslogtreecommitdiff
path: root/web
diff options
context:
space:
mode:
Diffstat (limited to 'web')
-rw-r--r--web/view/markdown.scm132
-rw-r--r--[-rwxr-xr-x]web/webserver.scm341
2 files changed, 273 insertions, 200 deletions
diff --git a/web/view/markdown.scm b/web/view/markdown.scm
index fd8838f..653596f 100644
--- a/web/view/markdown.scm
+++ b/web/view/markdown.scm
@@ -16,89 +16,117 @@
#:use-module (web sxml)
#:use-module (commonmark)
- #:export (markdown-file->sxml
- markdown-github->sxml
- fetch-file
- fetch-raw-file
- commit-file))
-
+ #:export (markdown-file->sxml markdown-github->sxml fetch-file
+ fetch-raw-file commit-file))
(define (markdown-file->sxml fn)
"Parse a local file"
- (commonmark->sxml
- (call-with-input-file fn
- get-string-all)))
+ (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)
- (string-append "https://raw.githubusercontent.com/" project "/" repo "/master/" (string-join 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 "/")))
+ (string-append "https://github.com/"
+ project
+ "/"
+ repo
+ "/edit/master/"
+ (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" . ,query-path)
- ("content" . ,content)
- ("hash" . ,commit-sha))
- ) (throw 'file-error (format #f "~a does not exists" abs-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")))
+ (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")))
+ (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))
+ (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)))
+(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)))
+ (#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-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))))
+ `(("status" . "201")
+ ("message" . "committed file successfully")
+ ("content" unquote content)
+ ("commit_sha" unquote git-commit-sha)
+ ("commit_message" unquote commit-message))
+ `(("status" . "200")
+ ("message" . "Nothing to commit, working tree clean")
+ ("commit_sha" unquote 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/webserver.scm b/web/webserver.scm
index 3cfcf50..b5e862c 100755..100644
--- a/web/webserver.scm
+++ b/web/webserver.scm
@@ -1,68 +1,56 @@
-#!/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 exceptions)
+ (srfi srfi-1)
+ (srfi srfi-11)
+ (srfi srfi-19)
+ (srfi srfi-26)
+ (rnrs io ports)
+ (rnrs bytevectors)
+ (web http)
+ (web client)
+ (web request)
+ (web response)
+ (web uri)
+ (fibers web server)
+ (gn cache memoize)
+ (web gn-uri)
+ (gn db sparql)
+ (gn data species)
+ (gn data group)
+ (web sxml)
+ (web view view)
+ (web view doc)
+ (web view markdown))
-(use-modules
- (json)
- (ice-9 match)
- (ice-9 format)
- (ice-9 iconv)
- (ice-9 receive)
- (ice-9 string-fun)
- (ice-9 exceptions)
- ;; (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
- (rnrs bytevectors)
- (web http)
- (web client)
- (web request)
- (web response)
- (web uri)
- (fibers web server)
- (gn cache memoize)
- (web gn-uri)
- (gn db sparql)
- (gn data species)
- (gn data group)
- (web sxml)
- (web view view)
- (web view doc)
- (web view markdown))
-
-(define 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 info
+ `(("name" . "GeneNetwork REST API") ("version" unquote 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" unquote
+ (prefix))
+ ("links" ("species" unquote
+ (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"))))
(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)))))
(define (not-found2 request)
@@ -72,70 +60,85 @@ 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 #\.)))
-(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 unquote
+ (assoc-ref file-mime-types
+ (file-extension file-name)))
+ (last-modified unquote
+ (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 unquote
+ (assoc-ref file-mime-types
+ (file-extension path)))
+ (last-modified unquote
+ (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-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)))
+ (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))))
+ (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)
@@ -143,57 +146,76 @@ otherwise search for set/group data"
(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)) "")])
+ (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)
+(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 400 (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)))))))
+ (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 400
+ (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" unquote key)
+ ("msg" unquote msg)))))))
-(define +global-repo+ (getenv "REPO_PATH"))
+(define +global-repo+
+ (getenv "REPO_PATH"))
(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))
+ (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))))
+ (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
- (commit-file repo
- file-name content
- commit-message
- username email
- prev-commit))))
- (lambda (key . args)
- (let ((msg (car args))) (build-json-response 400 `(("error" . ,key) ("msg" . ,msg)))))))
+ (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))))
+ (lambda (key . args)
+ (let ((msg (car args)))
+ (build-json-response 400
+ `(("error" unquote key)
+ ("msg" unquote msg)))))))
(define (controller request body)
(match-lambda
@@ -201,21 +223,29 @@ otherwise search for set/group data"
(render-json info))
(('GET "version")
(render-json get-version))
- (('GET "css" fn )
+ (('GET "css" fn)
(render-static-file (string-append "css/" fn)))
- (('GET "map" fn )
+ (('GET "map" fn)
(render-static-file (string-append "css/" fn)))
(('GET "static" "images" fn)
(render-static-image (string-append "static/images/" fn)))
(('GET "home" path)
(render-brand path))
(('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 "species.json")
(render-json (get-species-data)))
@@ -224,16 +254,32 @@ otherwise search for set/group data"
(('GET "species")
(render-json (get-species-meta)))
(('GET "edit")
- (edit-file-handler +global-repo+ request))
+ (edit-file-handler +global-repo+ request))
(('POST "commit")
- (commit-file-handler +global-repo+ request body))
+ (commit-file-handler +global-repo+ 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")])))
+ ((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)
@@ -250,8 +296,7 @@ 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
@@ -267,4 +312,4 @@ otherwise search for set/group data"
(newline)
(let ((listen (inexact->exact (string->number (car (cdr args))))))
(display `("listening on" ,listen))
- (start-web-server "127.0.0.1" listen)))
+ (start-web-server "127.0.0.1" listen)))
generated by cgit v1.2.3 (git 2.44.0) at 2024-09-20 14:29:37 +0000