/
core.lisp
260 lines (218 loc) · 8.54 KB
/
core.lisp
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
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
(defpackage #:reblocks-file-server/core
(:nicknames #:reblocks-file-server)
(:use #:cl)
(:import-from #:log)
(:import-from #:trivial-mimes)
(:import-from #:reblocks/request)
(:import-from #:reblocks/html
#:with-html
#:with-html-string)
(:import-from #:reblocks/utils/misc
#:relative-path)
(:import-from #:reblocks/routes
#:route
#:add-route
#:serve)
(:import-from #:routes
#:parse-template)
(:import-from #:cl-fad)
(:import-from #:cl-ppcre)
(:export #:make-route
#:static-files-route
#:serve-file
#:serve-directory
#:render-directory
#:render-404
#:render-styles
#:list-directory
#:get-dir-listing
#:get-filter
#:get-filter-type
#:get-root
#:get-uri))
(in-package reblocks-file-server/core)
(defclass static-files-route (route)
((root :type pathname
:initarg :root
:reader get-root)
(uri :type pathname
:initarg :uri
:reader get-uri)
(dir-listing :type t
:initform t
:initarg :dir-listing
:documentation "When nil, directory contents is not shown."
:reader get-dir-listing)
(filter :type string
:initarg :filter
:documentation "A regular expression."
:reader get-filter)
;; UPDATE: regexps can contain negation so filter-type is not really needed... Too lazy to remove it now.
(filter-type :type t
:initform t
:initarg :filter-type
:documentation "T means show files that match the filter regexp. NIL means hide files that match the filter regexp"
:reader get-filter-type)))
(defun make-route (&key
(route-class 'static-files-route)
(uri "/")
(root "./")
(dir-listing t)
(filter ".*")
(filter-type t))
(log:info "Making a route for serving files from a directory" root)
(let* ((real-root (uiop:truename* root))
(route (make-instance route-class
:uri (pathname uri)
:template (parse-template (concatenate 'string uri "*"))
:root (or real-root
(error "Directory ~S does not exist."
root))
:dir-listing dir-listing
:filter filter
:filter-type filter-type)))
(add-route route)
(values route)))
(defgeneric serve-directory (route uri full-path)
(:documentation "Returns a Lack response with a rendered directory listing."))
(defgeneric serve-file (route full-path)
(:documentation "Returns content of the file."))
(defgeneric render-directory (route uri children)
(:documentation "Renders a list of files in a directory"))
(defgeneric render-404 (route uri)
(:documentation "Returns a string with HTML for a case when `uri' wasn't found on the disk."))
(defgeneric render-styles (route)
(:documentation "This method should use reblocks/html:with-html and output a :style element."))
(defun list-directory (full-path filter filter-type)
"Returns a list of files in the directory.
All items of the list are relative."
(loop for file in (cl-fad:list-directory full-path)
for relative-file = (relative-path file full-path)
for filtered-p = (ppcre:scan filter (namestring file))
if (or (and filtered-p filter-type)
(and (null filtered-p)
(null filter-type)))
collect relative-file))
(defmethod render-styles ((route t))
(with-html
(:style
"
.file-server-body {
margin-left: 100px;
margin-right: 100px;
}
.file-server-body ul.children {
padding-left: 1em;
list-style-position: inside;
}
"
)))
(defmethod render-directory ((route t) uri children)
(let* ((route-root (get-uri route))
(parent-directory-uri
(unless (equal uri
(princ-to-string route-root))
(cl-fad:pathname-parent-directory uri))))
(with-html-string
(render-styles route)
(:div :class "file-server-body"
(:h1 :class "current-directory"
(princ-to-string uri))
(:ul :class "children"
(when parent-directory-uri
(:li :class "parent-directory"
(:a :href parent-directory-uri
"..")))
(loop for relative-file in children
for file-uri = (merge-pathnames relative-file uri)
do (:li :class "file-or-directory"
(:a :href (princ-to-string file-uri)
relative-file))))))))
(defmethod serve-directory ((route t) uri full-path)
(log:info "Serving directory" full-path)
(let ((children (list-directory full-path (get-filter route) (get-filter-type route))))
(list 200
(list :content-type "text/html")
(list (render-directory route uri children)))))
(defmethod render-404 ((route t) uri)
(with-html-string
(render-styles route)
(:div :class "file-server-body"
(:h1 :class "file-not-found"
(format nil "File \"~A\" not found!"
uri)))))
(defmethod serve-file ((route t) full-path)
(log:info "Serving file" full-path)
(let ((content-type (trivial-mimes:mime full-path)))
(list 200
(list :content-type content-type)
full-path)))
(defun make-full-path (root route-uri request-path)
"Returns a pathname pointing to the file on the filesystem.
Root, is a base directory of the route, route-uri is a path
on the webserver, where files should be served from
and request-path is a requested path from the webrowser.
Request-path is always have a route-uri as a prefix.
For example, if:
root = \"/app/build/dist/\"
route-uri = \"/dist/\"
request-path = \"/dist/the-file.txt\"
Then this function should return a pathname
pointing to \"/app/build/dist/the-file.txt\""
(let* ((relative (relative-path request-path route-uri))
(new-path (merge-pathnames relative root)))
new-path))
(defmethod serve ((route static-files-route) env)
"Returns a robots of the site."
(declare (ignorable env))
(restart-case
(let* ((uri (reblocks/request:get-path))
(dir-listing (get-dir-listing route))
(filter-type (get-filter-type route))
;; A path to the file on the hard drive
(original-full-path (make-full-path (get-root route)
(get-uri route)
uri))
;; Here cl-fad will add a missing / if
;; full-path is pointing to a directory but
;; does not contains / on the end
(full-path (cl-fad:file-exists-p original-full-path))
(is-directory (when full-path
(cl-fad:directory-pathname-p full-path)))
(not-exists-p (null full-path))
filtered-p)
(when full-path
(setf filtered-p (ppcre:scan (get-filter route) (namestring full-path))))
(cond ((or not-exists-p
(and is-directory (null dir-listing))
(and (not is-directory)
(not (or (and filtered-p filter-type)
(and (null filtered-p)
(null filter-type))))))
(log:warn "File not found: ~A" uri)
(list 404
(list :content-type "text/html")
(list (render-404 route uri))))
(is-directory
(serve-directory route
uri
full-path))
(t
(serve-file route full-path))))
(abort ()
:report "Ignore error and return HTTP 500"
(log:error "Unhandled error")
(list 500
(list :content-type "text/html")
;; Use method to render an Error page
(list "Unhandled error")))))
#|
example:
(reblocks-file-server:make-route :uri "/static/" :root "/tmp/" :dir-listing nil :filter ".*.txt")
; now access 127.0.0.1/static/1.txt
(reblocks-file-server:make-route :uri "/static/" :root "/tmp/" :dir-listing t :filter ".*.gif")
; now access 127.0.0.1/static/2.gif
and 127.0.0.1/static/
; in this example, we display and give access to all files except for .txt :
(reblocks-file-server:make-route :uri "/static/" :root "/tmp/" :dir-listing t :filter ".*.txt" :filter-type nil)
|#