blob: 0a408b387b3d9a9406307b62edc8b23371d1e090 (
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
|
(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))
(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" . ,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))))
|
