(define-module (web view markdown) #:use-module (json) #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 iconv) #: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-file fetch-raw-file commit-file is-repo?)) (define (markdown-file->sxml fn) "Parse a local file" (commonmark->sxml (call-with-input-file fn get-string-all))) ;; --- fetch github style URLs (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 (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 (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)))) (define (fetch-file repo query_path) (let* ( (abs_path (string-append 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 (string-append "the file path " abs_path " does not exists"))))) (define (git-invoke repo-path . args) (apply system* "git" "-C" repo-path args)) (define (is-repo? 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 "")) (if (string=? prev-commit (get-latest-commit-sha1 repo)) #t (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 (is-repo? repo) (match (file-exists? (string-append repo "/" file-path)) (#t (with-output-to-file (string-append 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 (string-append file-path " File does not exist Error")))) (throw 'system-error (string-append repo " Is not a git repo."))))