diff options
Diffstat (limited to 'web/view')
| -rw-r--r-- | web/view/markdown.scm | 136 | ||||
| -rw-r--r-- | web/view/view.scm | 4 |
2 files changed, 110 insertions, 30 deletions
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..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") |