root/directory-view.scm

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
(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 regex)
  #:use-module (path-utils)
  #:use-module (system-utils)
  #:use-module (utils)
  #:use-module (html-wrapper)
  #:use-module (file-view)
  #:use-module (sxml simple)
  #:export (directory-view
            directory-view-head
            directory-view-dir
            directory-view-readme
            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 (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)
  (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 ()
        (set-port-encoding! (current-output-port) "utf-8")
        (sxml->xml
         (html-wrapper
          (cond (is-dir
                 (directory-view href-data (dirname href-html) "." (get-files-list href-data)))
                (is-symlink
                 `("[symlink]"))
                (else (file-view href-data)))))))))

(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)))
    `(li ,(date->string date "~Y-~m-~d ~H:~M")
         "  |  "
         ,(if is-dir "[d] " "[f] ") ;; 📁 🖹
         (a (@ (href ,href-html)) ,item)
         "  |  "
         ,(if (and (not is-dir) (not is-symlink))
              `(a (@ (href ,(href-to-raw prefix-data item))) "[raw]")
              `()))))

;; 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 ,(append `((a (@ (href
                         ,(if is-root
                              "index.html"
                              (string-append
                               (repeat-str (length mid) "../")
                               "../index.html"))))
                     "root")  "/")
                links)
       "    \" - files\""))

(define (directory-view-dir prefix-data prefix-html prefix-a files-list)
  (mkdir-p prefix-html)
  (map (cut make-anchor-target prefix-data prefix-html prefix-a <>) files-list)
  `(ul
    ,(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)
  (list (directory-view-head prefix-html)
        (directory-view-dir prefix-data prefix-html prefix-a files-list)
        (directory-view-readme prefix-data files-list)))