diff options
Diffstat (limited to 'web/view/markdown.scm')
| -rw-r--r-- | web/view/markdown.scm | 132 |
1 files changed, 80 insertions, 52 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)))) |