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
(define-module (file-view)
#:use-module (html-wrapper)
#:use-module (path-utils)
#:use-module (file-utils)
#:use-module (utils)
#:use-module (system-utils)
#:use-module (sxml simple)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (ice-9 regex)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:export (file-view
file-view-text-raw))
(define (count-lines str)
(+ (string-fold (lambda (c acc) (if (char=? c #\newline)
(+ 1 acc)
acc)) 0 str)
;; missing new line at the end of file
(if (or
(string-null? str)
(char=? (string-ref str (- (string-length str) 1)) #\newline))
0
1)))
(define* (file-view file-path #:optional (title (title-links file-path)))
((or (file-view-for-too-big file-path)
(file-view-for-name file-path)
(file-view-for-type file-path)
file-view-text) file-path title))
(define LIMIT (* 10 1024 1024)) ; 10 MB
(define (file-view-for-too-big file-path)
(define stats (stat file-path))
(define size (or (and stats (stat:size stats)) 0))
(if (> size LIMIT)
(file-view-too-big size)
#f))
(define (file-view-for-name file-path)
(let ((ext (path-extension file-path)))
(cond ((string-ci=? ext ".org") file-view-org)
((string-ci=? ext ".svg") file-view-image)
(else #f))))
(define (file-view-for-type file-path)
(let ((output (shell-command-to-string* "file" "-b" "--mime" file-path)))
(cond ((string-match "\\bimage\\b" output) file-view-image)
((string-match "\\bvideo\\b" output) file-view-video)
(else #f))))
(define (file-view-text file-path title)
(let* ((contents (get-file-contents file-path)))
(file-view-text-raw contents title)))
(define (file-view-text-raw contents title)
(define lines (count-lines contents))
`(div (@ (class "file-view text"))
(h4 ,title)
(div (@ (class "contents"))
(pre (@ (class "line-numbers") (aria-hidden "true"))
,(let ((numbers '()))
(do ((i lines (- i 1)))
((<= i 0))
(set! numbers (cons (string-append
(number->string i)
"\n") numbers)))
numbers))
(pre (@ (class "file-content")
(aria-description "File content: "))
,contents))))
;; (define (regex-replace-sxml str rules)
;; (map (lambda (r)
;; (let* ((regex (car r))
;; (sxml-pattern (cadr r))
;; (match (regexp-exec (make-regexp regex regexp/icase) str)))
;; (if match
;; (sxml-map (lambda (name value)))
;; (match:substring match)
;; "")))
;; rules))
;;; https://spec.commonmark.org/0.29/ wtf that is a lot
;; (define (md->sxml content)
;; ;; just implemented what i need right now
;; ("!\[([^\]+])\]\(([^\)]+)\)" `(img (@ (alt $1) (src $2))))
;; content)
;; (define (file-view-md file-path title)
;; (define md-sxml (md->sxml (get-file-contents file-path)))
;; `(div (@ (class "file-view md rendered-markup"))
;; (h4 ,title)
;; (div (@ (class "contents"))
;; (div (@ (class "file-content")) ,md-sxml))))
(define (file-view-org file-path title)
(define org-raw (shell-command-to-string*
"emacs"
file-path
"--batch"
"--eval"
;; TODO figure out the emacs version
;; and use appropriate elisp
;; only valid with emacs 23
;; "(progn
;; (setq org-export-preserve-breaks t)
;; (princ (org-export-region-as-html
;; (point-min) (point-max) t 'string)))"
;; only tested with emacs 25
"(progn
(require 'org)
(setq org-export-preserve-breaks t)
(org-html-export-as-html nil nil nil t)
(switch-to-buffer \"*Org HTML Export*\")
(princ (buffer-substring-no-properties
(point-min) (point-max))))"
"--kill"))
;; There is a bug with simple sxml not parsing &hellip and &ndash
(define org-fix1 (string-substitute org-raw "–" "-" #t))
(define org-contents (string-substitute org-fix1 "…" "..." #t))
(define org-sxml (if (string=? org-contents "\n")
'()
(xml->sxml (string-append "<div>"
org-contents
"</div>\n"))))
`(div (@ (class "file-view org rendered-markup"))
(h4 ,title)
(div (@ (class "contents"))
(div (@ (class "file-content")) ,org-sxml))))
(define (file-view-too-big size)
(lambda (file-path title)
(define rel-path (to-relative-raw-path file-path))
`(div (@ (class "file-view too-big"))
(h4 ,title)
(div (@ (class "contents"))
(span "File too big to generate preview")
(a (@ (href ,rel-path))
"[view raw "
,(human-file-size size)
"]")))))
(define (human-file-size bytes)
(cond ((< bytes (* 1 1024)) (string-append (number->string bytes) "Byte"))
((< bytes (* 1024 1024)) (string-append (number->string (/ bytes 1024)) "KiB"))
((< bytes (* 1024 1024 1024)) (string-append (number->string (/ bytes (* 1024 1024))) "MiB"))
((< bytes (* 1024 1024 1024 1024)) (string-append (number->string (/ bytes (* 1024 1024 1024))) "GiB"))
(#t (string-append (number->string (/ bytes (* 1024 1024 1024 1024))) "TiB"))))
(define (file-view-image file-path title)
(define rel-path (to-relative-raw-path file-path))
`(div (@ (class "file-view image"))
(h4 ,title)
(div (@ (class "contents"))
(img (@ (src ,rel-path))))))
(define (file-view-video file-path title)
(define rel-path (to-relative-raw-path file-path))
`(div (@ (class "file-view video"))
(h4 ,title)
(div (@ (class "contents"))
(video (@ (src ,rel-path) (loop "loop") (autoplay "autoplay")
(controls "controls") (muted "muted"))
(string-append "Can not play video" ,rel-path)))))
(define (title-links file-path)
(define parts (string-split file-path #\/))
(define final (last parts))
(define mid (cdr (reverse (cdr (reverse parts)))))
(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)))
(append `((a (@ (href ,(string-append
(repeat-str (length mid) "../")
"../index.html")))
"root") "/")
links
`((a (@ (href ,(string-append final ".html")))
,final))))
(define (to-relative-raw-path file-path)
(define slash-count (string-count file-path #\/))
(define result #f)
(do ((i 0 (1+ i))
(acc file-path (string-append "../" acc)))
((> i slash-count))
(set! result acc))
result)