/
request.lisp
132 lines (118 loc) · 4.04 KB
/
request.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
(in-package :cl-user)
(defpackage lack.request
(:use :cl)
(:import-from :quri
:url-decode-params)
(:import-from :http-body
:parse)
(:import-from :circular-streams
:circular-input-stream
:make-circular-input-stream)
(:import-from :cl-ppcre
:split)
(:export :request
:make-request
:request-env
:request-method
:request-script-name
:request-path-info
:request-server-name
:request-server-port
:request-server-protocol
:request-uri
:request-uri-scheme
:request-remote-addr
:request-remote-port
:request-query-string
:request-raw-body
:request-content-length
:request-content-type
:request-headers
:request-cookies
:request-body-parameters
:request-query-parameters
:request-parameters
:request-content
:request-has-body-p))
(in-package :lack.request)
(defstruct (request (:constructor %make-request))
env
method
script-name
path-info
server-name
server-port
server-protocol
uri
uri-scheme
remote-addr
remote-port
query-string
raw-body
content-length
content-type
headers
cookies
body-parameters
query-parameters)
(declaim (inline request-has-body-p))
(defun request-has-body-p (req)
(or (request-content-length req)
(string= (gethash "transfer-encoding" (request-headers req)) "chunked")))
(defun make-request (env)
(let ((req (apply #'%make-request :env env :allow-other-keys t env)))
(with-slots (method uri uri-scheme content-type) req
(unless method
(setf method (getf env :request-method)))
(unless uri
(setf uri (getf env :request-uri)))
(unless uri-scheme
;; for some reason, it is called url-scheme in the environment plist :(
(setf uri-scheme (getf env :url-scheme)))
(unless content-type
(setf content-type "application/octet-stream")))
;; Cookies
(unless (request-cookies req)
(let* ((headers (request-headers req))
(cookie (and (hash-table-p headers)
(gethash "cookie" headers))))
(when cookie
(setf (request-cookies req)
(loop for kv in (ppcre:split "\\s*[,;]\\s*" cookie)
append (quri:url-decode-params kv :lenient t)))
(rplacd (last env) (list :cookies (request-cookies req))))))
;; GET parameters
(with-slots (query-parameters query-string) req
(when (and (null query-parameters)
query-string)
(setf query-parameters
(quri:url-decode-params query-string :lenient t))
(rplacd (last env) (list :query-parameters query-parameters))))
(with-slots (body-parameters raw-body content-length content-type) req
(when raw-body
(unless (typep raw-body 'circular-input-stream)
(setf raw-body (make-circular-input-stream raw-body)))
;; POST parameters
(when (and (null body-parameters)
(request-has-body-p req)
(stringp content-type))
(let ((parsed (http-body:parse content-type content-length raw-body)))
(when (and (consp parsed)
(every #'consp parsed))
(setf body-parameters parsed)))
(file-position raw-body 0)
(setf (getf env :raw-body) raw-body)
(rplacd (last env) (list :body-parameters body-parameters)))))
(setf (request-env req) env)
req))
(defun request-parameters (req)
(append (request-query-parameters req)
(request-body-parameters req)))
(defun request-content (req)
(if (request-has-body-p req)
(let ((raw-body (request-raw-body req)))
(prog1
(http-body.util:slurp-stream raw-body (request-content-length req))
(file-position raw-body 0)))
#.(make-array 0 :element-type '(unsigned-byte 8))))
(declaim (notinline request-has-body-p))