diff options
Diffstat (limited to 'web')
| -rw-r--r-- | web/view/markdown.scm | 29 | ||||
| -rw-r--r-- | web/webserver.scm | 90 |
2 files changed, 60 insertions, 59 deletions
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/webserver.scm b/web/webserver.scm index 145f192..c0fb9a1 100644 --- a/web/webserver.scm +++ b/web/webserver.scm @@ -27,8 +27,14 @@ (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)") @@ -38,11 +44,10 @@ ("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, @@ -82,11 +87,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 +100,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 +172,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 +188,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 @@ -252,9 +254,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) |