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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228

(use-modules
 (srfi srfi-1)  ;; map/fold
 (srfi srfi-19) ;; date/time
 (srfi srfi-26) ;; partial application
 (oop goops)
 (oop goops describe)
 (ice-9 regex)
 (sxml simple)
 (directory-view)
 (file-view)
 (path-utils)
 (file-utils)
 (html-wrapper)
 (system-utils)
 (favicon))

(define (error-exit message)
  (error message)
  (exit 1))

(define (parse-args rest result)
  (if (null? rest)
      result
      (let ((arg (car rest)))
        (cond
         ((or (string=? arg "-s")
              (string=? arg "--settings"))
          (if (null? rest)
              (error-exit "expecting settings file after -s --settings")
              (parse-args (cdr (cdr rest))
                          (cons (cons 'settings (cadr rest)) result))))
         ((or (string=? arg "-e")
              (string=? arg "--eval"))
          (if (null? rest)
              (error-exit
               "expecting settings file after -e --eval")
              (parse-args (cdr (cdr rest))
                          (cons (cons 'eval-settings (cadr rest)) result))))
         ((or (string=? arg "-r")
              (string=? arg "--raw-directory"))
          (if (null? rest)
              (error-exit
               "expecting raw directory after -r --raw-directory")
              (parse-args (cdr (cdr rest))
                          (cons (cons 'settings (cadr rest)) result))))
         ((or (string=? arg "-o")
              (string=? arg "--out-dir"))
          (if (null? rest)
              (error-exit "expecting output directory after -o --out-dir")
              (parse-args (cdr (cdr rest))
                          (cons (cons 'out-dir (cadr rest)) result))))
         ((or (string=? arg "-h")
              (string=? arg "--help"))
          (display "* git-to-web
 static web page generator for git repositories.
 -s / --settings <settings-file>
    The Settings file containing settings for the output.
    You can use \"-s\" multiple times. Settings from the last file given will
    outrule previous ones.
 -e / --eval <settings-script-file>
    Execute <settings-script-file> with guile and take the result as settings.
    Beware of enabling this for users provided files, since it allows arbitary
    code execution on your server.
    \"-e\" can be given multiple times just like \"-s\".
 -r / --raw-directory <raw-directory>
    Read this directory's file tree to generate the webpage.
    The default is \"./raw\".
 -o / --output-diretory <output-directory>
    The directory where to put the generated index.html and html/ directory.
    The default is \".\".
 -h / --help
    Display this text.\n")
          (exit 0))
         (else (error-exit (string-append "unknown argument '"
                                          arg
                                          "'\nRun --help for info.\n")))))))

(define (handle-settings-file file-arg)
  (cond ((not (pair? file-arg)) #f)
        ((eq? 'settings (car file-arg))
         (with-input-from-file (cdr file-arg) (lambda () (read))))
        ((eq? 'eval-settings (car file-arg))
         (load (cdr file-arg)))
        (else #f)))

;;; TODO
;;; The path / project nameing setup is currently a mess
;;; with code specificly written for my setup

(define base-dir (path-normalize (path-abs "../")))
(define example-git-links '(("git://" . "git@example.com/git")
                            ("https://" . "example.com/git")))

(define (substring-base base longstr)
  (let ((base-length (string-length base)))
    (if (and (> (string-length longstr) base-length)
             (string= longstr base 0 base-length))
        (substring longstr base-length)
        "")))

(define (make-git-link dir link)
  (let ((path (string-append (car link) (path-append (cdr link) dir))))
    `(pre "git clone " (a (@ (href ,path)) ,path))))

(define (make-git-links git-links)
  (let* ((dir (substring-base base-dir (path-abs "."))))
    `(div (@ (class "git-links"))
          (h4 "Git Links")
          (div
           ,(map (cut make-git-link dir <>) git-links)))))

(define (make-git-latest-commits git-dir)
  ;; git log --date=format:%Y-%m-%d --pretty=format:"%ad %s"
  (define logs (shell-command-to-string* "git"
                                         "log"
                                         "-n 3"
                                         "--date=format:%Y-%m-%d"
                                         "--pretty=format:%ad %s"))
  `(div
    ,(file-view-text-raw logs "Latest Logs")))

(define (make-flatpak-links base-dir)
  (define files (get-files-list base-dir))
  (define explicit-desktop (find-with-suffix files ".desktop.flatpak"))
  (define implicit-desktop (find-with-suffix files ".flatpak"))
  (define desktop-download-link (or explicit-desktop implicit-desktop))
  (define mobile-download-link (find-with-suffix files "mobile.flatpak"))
  (if (or desktop-download-link mobile-download-link)
      `((h4 "Flatpak Downloads")
        (div (@ (class "flatpak"))
             ,(if desktop-download-link
                  `(a (@ (href ,desktop-download-link))
                      (div (@ (class "desktop platform"))
                           (div (@ (class "icon")) "🖥️")

                           (div (span "Desktop") (span (@ (class "small")) "(x86_64)"))
                           ))
                  '())
             ,(if mobile-download-link
                  `(a (@ (href ,mobile-download-link))
                      (div (@ (class "mobile platform"))
                           (div (@ (class "icon")) "📱")
                           (div (span "Mobile") (span (@ (class "small")) "(AArch64)"))
                           ))
                  '())))
      '()))

(define (find-favicon base-dir)
  (or (find-local-favicon base-dir)
      (find-gnome-app-icon base-dir)))

(define (find-local-favicon base-dir)
  (define files (get-files-list base-dir))
  (define file (find-with-prefix files "favicon."))
  (if file
      (make <favicon> #:relative-path (path-normalize (string-append base-dir "/" file)))
      #f))

(define (find-gnome-app-icon base-dir)
  (define dir (string-append base-dir "/raw/data/icons"))
  (and
   (file-exists? dir)
   (let ()
     (define icons (get-files-list dir))
     (define svgs (filter (lambda (s) (regexp-exec (make-regexp ".svg$" regexp/icase) s)) icons))
     ;; svg icon that doesn't end in -symbolic.svg or .Devel.svg
     (define result
       (find (lambda (s) (and
                          (not (regexp-exec (make-regexp "-symbolic.svg$" regexp/icase) s))
                          (not (regexp-exec (make-regexp ".Devel.svg$" regexp/icase) s))))
             svgs))
     (if result
         (make <favicon> #:raw-path (path-normalize (string-append base-dir "/data/icons/" result)))
         #f))))

(define (assoc-value key alist fallback)
  (let ((value (assoc key alist)))
    (if value (cdr value) fallback)))

(define (main raw-args)
  (define args (parse-args (cdr raw-args) '()))
  (define settings (concatenate
                    (filter identity (map handle-settings-file args))))

  (setlocale LC_ALL "")
  (with-output-to-file "index.html"
    (lambda ()
      (set-port-encoding! (current-output-port) "utf-8")
      (let* ((base-dir (assoc-value 'out-dir args "."))
             (raw-dir (assoc-value 'raw-dir args (path-append base-dir "raw")))
             (files (get-files-list raw-dir)))
        (define title (assoc-value 'title settings (basename (path-abs base-dir))))
        (define favicon (find-favicon base-dir))
        (sxml->xml
         (html-wrapper
          (if title
              (string-append title " - Project Overview")
              "Project Overview")
          `(
            ;; (div (@ (class "menu"))
            ;;      ,(let* ((issues-active (assoc-value 'issues settings #t))
            ;;              (issues (if issues-active
            ;;                          (make-issues-page settings)
            ;;                          '())))
            ;;         (if issues-active
            ;;             '()
            ;;             `(a (@ (href "./issues.html"))
            ;;                 ,(string-append
            ;;                   "Issues ("
            ;;                   (length issues)
            ;;                   ")")))))
            (h1 ,title)
            ,(directory-view-head "./html")
            ,(directory-view-dir raw-dir "./html" "html" files
                                 #:favicon favicon)
            ,(make-git-links (assoc-value 'git-links settings
                                          example-git-links))
            ,(make-git-latest-commits ".")
            ,(make-flatpak-links base-dir)
            (main ,(directory-view-readme raw-dir files))
            ,(if (assoc-value 'credit-git-to-web settings #t)
                 '(footer
                   (small "This page was generated with "
                          (a (@ (href "https://hidamari.blue/git/git-to-web"))
                             "git-to-web")
                          "."))
                 '()))
          #:favicon (favicon-href favicon ".")))))))