blob: a7721331eca8c217bf7ff33e464c022f0f54f0a9 (
plain)
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
|
(in-package #:lazybones.decoders)
;;; HELPERS
(defun read-body-to-string (stream content-length)
"Reads CONTENT-LENGTH characters from STREAM and returns a string."
(let ((string (make-string content-length)))
(read-sequence string stream)
string))
(defun binary-content-p (content-type)
(or (alexandria:starts-with-subseq "image" content-type)
(alexandria:starts-with-subseq "audio" content-type)
(and (alexandria:starts-with-subseq "application" content-type)
(not (equal content-type "application/json")))
(alexandria:starts-with-subseq "video" content-type)))
(defun butlast-to-string (res)
(map 'string 'identity (butlast res)))
(defun make-keyword (str)
(read-from-string (format nil ":~a" str)))
(defun write-binary-to-tmp-file (body)
(cl-fad:with-output-to-temporary-file (out-file :element-type '(unsigned-byte 8))
(loop :for char :across body :do (write-byte (char-int char) out-file))))
;;; PLAIN TEXT DECODER
(defun decode-plain-text (stream content-type content-length)
(declare (ignore content-type))
(read-body-to-string stream content-length))
(add-decoder "text/plain" #'decode-plain-text)
;;; JSON DECODER
(defun decode-json-body (stream content-type content-length)
"Reads LEN characters from stream and decodes them as JSON, returning a PLIST"
(declare (ignore content-type))
(jonathan:parse (read-body-to-string stream content-length)))
(add-decoder "application/json" #'decode-json-body)
;;; MULTIPART/FORM-DATA DECODER
(<<def <crlf< (<<and (<<char #\Return)
(<<char #\Newline))
"Matches the standard CRLF line ending used by HTTP")
(<<def <word-plus<
(<<to-string (<<+ (<<or <alphanum< (<<any-char "-_/. "))))
"parses a word like foo-bar or foo-bar-zoo4")
(<<def <key-equal-val<
(<<let ((key (<<and <whitespace< <word-plus<))
(val (<<and (<<char #\=)
(<<char-brackets #\" <word-plus< #\"))))
(<<result (list (make-keyword key) val)))
"Parses strings that look like foo-bar=\"goo\" and returns a list (:foo-bar \"goo\")")
(<<def <multipart-header-content-disposition<
(<<map
(lambda (pairs) (apply 'append pairs))
(<<and (<<string "Content-Disposition: form-data; ")
(<<sep-by <key-equal-val< (<<string "; "))))
"Parses a Content-Disposition header in a multipart/form-data block.
Returns a PLIST with one property, the value of which is also a PLIST.
E.g. Content-Disposition: form-data; name=\"file\"; filename=\"mypic.png\"
becomes (:content-disposition (:name \"file\" :filename \"mypic.png\"))")
(<<def <multipart-header<
(<<let ((header <word-plus<)
(value (<<map #'butlast-to-string
(<<and (<<char #\:)
(<<until <crlf<)))))
(<<result (list (make-keyword header)
(string-trim '(#\Space) value)))))
(defun <<multipart/form-data-part (stop-seq)
(<<let ((disp (<<and (<<? <crlf<)
<multipart-header-content-disposition<))
(headers (<<and <crlf< (<<* <multipart-header<)))
(body (<<and <crlf<
(<<map #'butlast-to-string
(<<until (<<and <crlf<
(<<string stop-seq)))))))
(<<result
(let ((all-headers (nconc disp (apply 'append headers))))
(if (binary-content-p (getf all-headers :content-type))
(nconc all-headers (list :body (write-binary-to-tmp-file body)))
(nconc all-headers (list :body body)))))))
(defun <<multipart/form-data (boundary)
(<<let ((parts (<<and (<<string boundary)
<crlf<
(<<+ (<<multipart/form-data-part boundary))))
(ending (<<and (<<string "--") <crlf<)) )
(<<result parts)))
(defun decode-multipart/form-data (stream content-type content-length)
(declare (ignore content-length))
(let* ((boundary (concatenate 'string "--"
(second (split-sequence:split-sequence #\= content-type))))
(stream (make-instance 'replay-streams:static-text-replay-stream
:text (read-body-to-string stream content-length)))) ; Wouldn't work with raw stream
(parse stream (<<multipart/form-data boundary))))
(add-decoder "multipart/form-data" #'decode-multipart/form-data)
|
