@@ -10,6 +10,7 @@
10{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TupleSections #-}
13{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE TypeOperators #-}
@@ -41,7 +42,7 @@ import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
41 symbolVal)
42 symbolVal)
42import Network.HTTP.Types hiding (Header, ResponseHeaders)
43import Network.HTTP.Types hiding (Header, ResponseHeaders)
43import Network.Socket (SockAddr)
44import Network.Socket (SockAddr)
44−import Network.Wai (Application, Request, Response,
45+import Network.Wai (Application, Request,
45 httpVersion, isSecure,
46 httpVersion, isSecure,
46 lazyRequestBody,
47 lazyRequestBody,
47 rawQueryString, remoteHost,
48 rawQueryString, remoteHost,
@@ -197,16 +198,6 @@ allowedMethodHead method request = method == methodGet && requestMethod request
197allowedMethod :: Method -> Request -> Bool
198allowedMethod :: Method -> Request -> Bool
198allowedMethod method request = allowedMethodHead method request || requestMethod request == method
199allowedMethod method request = allowedMethodHead method request || requestMethod request == method
200−processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method
201− -> Maybe [(HeaderName, B.ByteString)]
202− -> Request -> RouteResult Response
203−processMethodRouter handleA status method headers request = case handleA of
204− Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
205− Just (contentT, body) -> Route $ responseLBS status hdrs bdy
207− bdy = if allowedMethodHead method request then "" else body
208− hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
210methodCheck :: Method -> Request -> DelayedIO ()
201methodCheck :: Method -> Request -> DelayedIO ()
211methodCheck method request
202methodCheck method request
212 | allowedMethod method request = return ()
203 | allowedMethod method request = return ()
@@ -225,33 +216,23 @@ acceptCheck proxy accH
225 | otherwise = delayedFail err406
216 | otherwise = delayedFail err406
227methodRouter :: (AllCTRender ctypes a)
218methodRouter :: (AllCTRender ctypes a)
219+ => (b -> ([(HeaderName, B.ByteString)], a))
228− => Method -> Proxy ctypes -> Status
220+ -> Method -> Proxy ctypes -> Status
229− -> Delayed env (Handler a)
221+ -> Delayed env (Handler b)
230 -> Router env
222 -> Router env
231−methodRouter method proxy status action = leafRouter route'
223+methodRouter splitHeaders method proxy status action = leafRouter route'
233 route' env request respond =
225 route' env request respond =
234 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
226 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
235 in runAction (action `addMethodCheck` methodCheck method request
227 in runAction (action `addMethodCheck` methodCheck method request
236 `addAcceptCheck` acceptCheck proxy accH
228 `addAcceptCheck` acceptCheck proxy accH
237 ) env request respond $ \ output -> do
229 ) env request respond $ \ output -> do
230+ let (headers, b) = splitHeaders output
238− let handleA = handleAcceptH proxy (AcceptHeader accH) output
231+ case handleAcceptH proxy (AcceptHeader accH) b of
239− processMethodRouter handleA status method Nothing request
232+ Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
240−
233+ Just (contentT, body) ->
241−methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
234+ let bdy = if allowedMethodHead method request then "" else body
242− => Method -> Proxy ctypes -> Status
235+ in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
243− -> Delayed env (Handler (Headers h v))
245−methodRouterHeaders method proxy status action = leafRouter route'
247− route' env request respond =
248− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
249− in runAction (action `addMethodCheck` methodCheck method request
250− `addAcceptCheck` acceptCheck proxy accH
251− ) env request respond $ \ output -> do
252− let headers = getHeaders output
253− handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
254− processMethodRouter handleA status method (Just headers) request
256instance OVERLAPPABLE_
237instance OVERLAPPABLE_
257 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
238 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -260,7 +241,7 @@ instance OVERLAPPABLE_
260 type ServerT (Verb method status ctypes a) m = m a
241 type ServerT (Verb method status ctypes a) m = m a
261 hoistServerWithContext _ _ nt s = nt s
242 hoistServerWithContext _ _ nt s = nt s
263− route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
244+ route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
264 where method = reflectMethod (Proxy :: Proxy method)
245 where method = reflectMethod (Proxy :: Proxy method)
265 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
246 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
@@ -272,7 +253,7 @@ instance OVERLAPPING_
272 type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
253 type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
273 hoistServerWithContext _ _ nt s = nt s
254 hoistServerWithContext _ _ nt s = nt s
275− route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
256+ route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
276 where method = reflectMethod (Proxy :: Proxy method)
257 where method = reflectMethod (Proxy :: Proxy method)
277 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
258 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)