-
Notifications
You must be signed in to change notification settings - Fork 517
/
servlet.clj
158 lines (143 loc) · 5.63 KB
/
servlet.clj
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
(ns ring.util.servlet
"Compatibility functions for turning a ring handler into a Java servlet."
(:require [clojure.string :as string]
[ring.core.protocols :as protocols])
(:import [java.util Locale]
[javax.servlet AsyncContext]
[javax.servlet.http
HttpServlet
HttpServletRequest
HttpServletResponse]))
(defn- get-headers [^HttpServletRequest request]
(reduce
(fn [headers ^String name]
(assoc headers
(.toLowerCase name Locale/ENGLISH)
(->> (.getHeaders request name)
(enumeration-seq)
(string/join ","))))
{}
(enumeration-seq (.getHeaderNames request))))
(defn- get-content-length [^HttpServletRequest request]
(let [length (.getContentLength request)]
(when (>= length 0) length)))
(defn- get-client-cert [^HttpServletRequest request]
(first (.getAttribute request "javax.servlet.request.X509Certificate")))
(defn build-request-map
"Create the request map from the HttpServletRequest object."
[^HttpServletRequest request]
{:server-port (.getServerPort request)
:server-name (.getServerName request)
:remote-addr (.getRemoteAddr request)
:uri (.getRequestURI request)
:query-string (.getQueryString request)
:scheme (keyword (.getScheme request))
:request-method (keyword (.toLowerCase (.getMethod request) Locale/ENGLISH))
:protocol (.getProtocol request)
:headers (get-headers request)
:content-type (.getContentType request)
:content-length (get-content-length request)
:character-encoding (.getCharacterEncoding request)
:ssl-client-cert (get-client-cert request)
:body (.getInputStream request)})
(defn merge-servlet-keys
"Associate servlet-specific keys with the request map for use with legacy
systems."
[request-map
^HttpServlet servlet
^HttpServletRequest request
^HttpServletResponse response]
(merge request-map
{:servlet servlet
:servlet-request request
:servlet-response response
:servlet-context (.getServletContext servlet)
:servlet-context-path (.getContextPath request)}))
(defn- set-headers [^HttpServletResponse response, headers]
(doseq [[key val-or-vals] headers]
(if (string? val-or-vals)
(.setHeader response key val-or-vals)
(doseq [val val-or-vals]
(.addHeader response key val))))
; Some headers must be set through specific methods
(when-let [content-type (get headers "Content-Type")]
(.setContentType response content-type)))
(defn- make-output-stream
[^HttpServletResponse response ^AsyncContext context]
(let [os (.getOutputStream response)]
(if (nil? context)
os
(proxy [java.io.FilterOutputStream] [os]
(close []
(.close os)
(.complete context))))))
(defn update-servlet-response
"Update the HttpServletResponse using a response map. Takes an optional
AsyncContext."
([response response-map]
(update-servlet-response response nil response-map))
([^HttpServletResponse response context response-map]
(let [{:keys [status headers body]} response-map]
(when (nil? response)
(throw (NullPointerException. "HttpServletResponse is nil")))
(when (nil? response-map)
(throw (NullPointerException. "Response map is nil")))
(when status
(.setStatus response status))
(set-headers response headers)
(let [output-stream (make-output-stream response context)]
(protocols/write-body-to-stream body response-map output-stream)))))
(defn- make-blocking-service-method [handler]
(fn [servlet request response]
(-> request
(build-request-map)
(merge-servlet-keys servlet request response)
(handler)
(->> (update-servlet-response response)))))
(defn- make-async-service-method [handler]
(fn [servlet ^HttpServletRequest request ^HttpServletResponse response]
(let [^AsyncContext context (.startAsync request)]
(handler
(-> request
(build-request-map)
(merge-servlet-keys servlet request response))
(fn [response-map]
(update-servlet-response response context response-map))
(fn [^Throwable exception]
(.sendError response 500 (.getMessage exception))
(.complete context))))))
(defn make-service-method
"Turns a handler into a function that takes the same arguments and has the
same return value as the service method in the HttpServlet class."
([handler]
(make-service-method handler {}))
([handler options]
(if (:async? options)
(make-async-service-method handler)
(make-blocking-service-method handler))))
(defn servlet
"Create a servlet from a Ring handler."
([handler]
(servlet handler {}))
([handler options]
(let [service-method (make-service-method handler options)]
(proxy [HttpServlet] []
(service [request response]
(service-method this request response))))))
(defmacro defservice
"Defines a service method with an optional prefix suitable for being used by
genclass to compile a HttpServlet class.
For example:
(defservice my-handler)
(defservice \"my-prefix-\" my-handler)"
([handler]
`(defservice "-" ~handler))
([prefix handler]
(if (map? handler)
`(defservice "-" ~prefix ~handler)
`(defservice ~prefix ~handler {})))
([prefix handler options]
`(let [service-method# (make-service-method ~handler ~options)]
(defn ~(symbol (str prefix "service"))
[servlet# request# response#]
(service-method# servlet# request# response#)))))