blob: 30c9f33f2060b6963d1ca3e11a01e58517fb3e76 (
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
|
(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)))
;; --- 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))
)
`(("path" . ,query_path)
("content" . ,content)
("hash" . "commit hash here"))
) (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)
(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)
)
)
;;prevent users from commit other people changes check for git add status
(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))
)
;; check if git add had an error ;; check git commit if had an error
;;runs the risk of commit a different user changes check this ;; potential for collisions
(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."))
)
)
|
