aboutsummaryrefslogtreecommitdiff
path: root/web/view/markdown.scm
blob: 3236ccecd00ca9ec15047c3b509cfd0980275a66 (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)))

(define (fetch-raw-file url)
  (receive (response-status response-body)
      (http-request url) response-body))

(define* (form-github-raw-url project repo page #:optional (branch "master"))
  (string-append "https://raw.githubusercontent.com/"
                 project
                 "/"
                 repo
                 "/"
		 branch
		 "/"
                 (string-join page "/")))

(define* (form-github-edit-url project repo page #:optional (branch "master"))
  (string-append "https://github.com/"
                 project
                 "/"
                 repo
		 "/edit/"
		 branch
		 "/"
                 (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))))