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

(define-module (directory-view)
  #:use-module (srfi srfi-1)  ;; map/fold
  #:use-module (srfi srfi-19) ;; date/time
  #:use-module (srfi srfi-26) ;; partial application
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 regex)
  #:use-module (sxml simple)
  ;; local
  #:use-module (path-utils)
  #:use-module (system-utils)
  #:use-module (utils)
  #:use-module (html-wrapper)
  #:use-module (file-view)
  #:use-module (favicon)
  #:export (directory-view
            directory-view-head
            directory-view-dir
            directory-view-readme
            find-with-suffix
            find-with-prefix
            get-files-list
            make-readme))

(define (list-files dir)
  (define (step stream acc)
    (let ((item (readdir stream)))
      (if (eof-object? item)
          acc
          (step stream (cons item acc)))))
  (let ((stream (opendir dir)))
    (step stream '())))

(define (filter-files a)
  (if (string-match "~$|^\\.$|^\\.\\.$|^\\.git$" a ) #f #t))

(define (sort-files prefix a b)
  (let ((a-is-dir (eq? 'directory (stat:type (lstat (path-append prefix a)))))
        (b-is-dir (eq? 'directory (stat:type (lstat (path-append prefix b))))))
    (if (or (and a-is-dir
                 b-is-dir)
            (and (not a-is-dir)
                 (not b-is-dir)))
        (string<? a b)
        a-is-dir)))

(define (get-files-list path)
  (sort
   (filter filter-files (list-files path))
   (cut sort-files path <> <>)))

(define (make-readme prefix-data items)
  (let ((match (find (lambda (s)
                       (regexp-exec (make-regexp "^README" regexp/icase) s))
                     items)))
    (if match
        `(div (@ (class "README"))
              ,(file-view (path-append prefix-data match) match))
        '())))

(define (find-with-suffix items suffix)
  (define match (find (lambda (s)
                        (regexp-exec (make-regexp
                                      (string-append suffix "$")
                                      regexp/icase) s))
                      items))
  match)

(define (find-with-prefix items prefix)
  (define match (find (lambda (s)
                        (regexp-exec (make-regexp
                                      (string-append "^" prefix)
                                      regexp/icase) s))
                      items))
  match)

(define (raw-prefix path)
  (let* ((parts (length (string-split path #\/)))
         (steps-up parts)
         (prefix (repeat steps-up "..")))
    (if (string=? "raw" path)
        "." ;; don't go up when in /index.html
        (string-join prefix "/"))))

(define (href-to-raw prefix item)
  (string-append (raw-prefix prefix) "/" prefix "/" item))

(define* (make-anchor-target prefix-data prefix-html prefix-a item #:key (favicon #f))
  (let* ((href-data (path-append prefix-data item))
         (item-stat (lstat href-data))
         (is-dir (eq? 'directory (stat:type item-stat)))
         (is-symlink (eq? 'symlink (stat:type item-stat)))
         (href-html (path-append prefix-html
                                 (if is-dir
                                     (string-append item "/index.html")
                                     (string-append item ".html")))))
    ;; if (file-exists? href-html)
    (when is-dir
      (mkdir-p (dirname href-html)))
    (with-output-to-file href-html
      (lambda ()
        (define title (if is-dir
                          (string-append "Directory listing: " (dirname href-html))
                          (string-append "File view: " (basename href-html))))
        (set-port-encoding! (current-output-port) "utf-8")
        (sxml->xml
         (html-wrapper
          title
          (cond (is-dir
                 (directory-view href-data (dirname href-html) "." (get-files-list href-data)
                                 #:favicon favicon))
                (is-symlink
                 `("[symlink]"))
                (else (file-view href-data)))
          #:favicon (if favicon
                        ;; for every dir in prefix-html add ..
                        (let* ((parts (length (string-split prefix-html #\/)))
                               (steps-up (if is-dir
                                             (+ 1 parts)
                                             parts))
                               (prefix-lst (repeat steps-up ".."))
                               (prefix-str (string-join prefix-lst "/"))
                               (icon-path (favicon-href favicon prefix-str)))
                          ;; (warn "does this go into the root dir? above raw" steps-up href-html prefix-str icon-path)
                          icon-path)
                        #f)))))))

(define (make-anchor prefix-data prefix-html item)
  (let* ((data (path-append prefix-data item))
         (item-stat (lstat data))
         (is-dir (eq? 'directory (stat:type item-stat)))
         (is-symlink (eq? 'symlink (stat:type item-stat)))
         (href-html (path-append (basename prefix-html) (if is-dir
                                                            (string-append item "/index.html")
                                                            (string-append item ".html"))))
         (time (make-time 'time-monotonic 0 (stat:ctime item-stat)))
         (date (time-monotonic->date time)))
    `(tr
      (td (span (@ (class "icon")
                   (aria-label ,(if is-dir "Directory" "File")))
                ,(if is-dir "📁 " "🖹 ")) ;; 📁 🖹
          (a (@ (href ,href-html)) ,item))
         ;; "  |  "
      (td ,(if (and (not is-dir) (not is-symlink))
            `(a (@
                 (class "raw-link")
                 (href  ,(href-to-raw prefix-data item))) "[raw]")
            `()))
      (td (@ (class "date-row")) ,(date->string date "~Y-~m-~d ~H:~M"))
      )))

;; TODO this is mostly redundant with file-view
(define (directory-view-head prefix-html)
  (define parts (string-split prefix-html #\/))
  (define final (last parts))
  (define is-root (equal? "." (car parts)))
  (define mid (if is-root
                  (cdr (cdr parts))
                  (cdr parts)))
  (define offset 0)
  (define links
    (cdr (fold (lambda (value acc)
                 (define path (if (<= (car acc) 0)
                                  "./"
                                  (repeat-str (car acc) "../")))
                 (define file-path (string-append path "index.html"))
                 (define link `((a (@ (href ,file-path)) ,value) "/"))
                 (define links (append (cdr acc) link))
                 (cons (- (car acc) 1) links))
               (cons (- (length mid) 1) '())
               mid)))
  `(h4
    (@ (aria-description "Current directory"))
    ,(append `((a (@ (href
                         ,(if is-root
                              "index.html"
                              (string-append
                               (repeat-str (length mid) "../")
                               "../index.html"))))
                     "root")  "/")
                links)
       "    "))

(define* (directory-view-dir prefix-data prefix-html prefix-a files-list
                             #:key (favicon #f))
  (mkdir-p prefix-html)
  (map (lambda (item)
         (make-anchor-target prefix-data prefix-html prefix-a item
                             #:favicon favicon)) files-list)
  `(table
    (@ (aria-label "Directory listing"))
    ,(map (cut make-anchor prefix-data prefix-a <>) files-list)))

(define (directory-view-readme prefix-data files-list)
  (make-readme prefix-data files-list))

(define* (directory-view prefix-data prefix-html prefix-a files-list #:key (favicon #f))
  (list (directory-view-head prefix-html)
        (directory-view-dir prefix-data prefix-html prefix-a files-list
                            #:favicon favicon)
        (directory-view-readme prefix-data files-list)))