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

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

(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))))
    `(li (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")
          (ul
           ,(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 (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)))
        (sxml->xml
         (html-wrapper
          "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 ,(assoc-value 'title settings (basename (path-abs base-dir))))
            ,(directory-view-head "./html")
            ,(directory-view-dir raw-dir "./html" "html" files)
            ,(make-git-links (assoc-value 'git-links settings
                                          example-git-links))
            ,(make-git-latest-commits ".")
            (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")
                          "."))
                 '()))))))))