blob: 653596f2c5aca5f22d4243a9cd916610092c67c2 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
(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))
(define (markdown-file->sxml fn)
"Parse a local file"
(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))
;; 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 (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" 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))))
|
