@@ -10,6 +10,7 @@
1010{-# LANGUAGE PolyKinds #-}
1111{-# LANGUAGE RankNTypes #-}
1212{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TupleSections #-}
1314{-# LANGUAGE TypeFamilies #-}
1415{-# LANGUAGE TypeOperators #-}
1516
@@ -41,7 +42,7 @@ import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
4142 symbolVal)
4243import Network.HTTP.Types hiding (Header, ResponseHeaders)
4344import Network.Socket (SockAddr)
44−import Network.Wai (Application, Request, Response,
45+import Network.Wai (Application, Request,
4546 httpVersion, isSecure,
4647 lazyRequestBody,
4748 rawQueryString, remoteHost,
@@ -197,16 +198,6 @@ allowedMethodHead method request = method == methodGet && requestMethod request
197198allowedMethod :: Method -> Request -> Bool
198199allowedMethod method request = allowedMethodHead method request || requestMethod request == method
199200
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
206− where
207− bdy = if allowedMethodHead method request then "" else body
208− hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
209−
210201methodCheck :: Method -> Request -> DelayedIO ()
211202methodCheck method request
212203 | allowedMethod method request = return ()
@@ -225,33 +216,23 @@ acceptCheck proxy accH
225216 | otherwise = delayedFail err406
226217
227218methodRouter :: (AllCTRender ctypes a)
228− => Method -> Proxy ctypes -> Status
229− -> Delayed env (Handler a)
219+ => (b -> ([(HeaderName, B.ByteString)], a))
220+ -> Method -> Proxy ctypes -> Status
221+ -> Delayed env (Handler b)
230222 -> Router env
231−methodRouter method proxy status action = leafRouter route'
223+methodRouter splitHeaders method proxy status action = leafRouter route'
232224 where
233225 route' env request respond =
234226 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
235227 in runAction (action `addMethodCheck` methodCheck method request
236228 `addAcceptCheck` acceptCheck proxy accH
237229 ) env request respond $ \ output -> do
238− let handleA = handleAcceptH proxy (AcceptHeader accH) output
239− processMethodRouter handleA status method Nothing request
240−
241−methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
242− => Method -> Proxy ctypes -> Status
243− -> Delayed env (Handler (Headers h v))
244− -> Router env
245−methodRouterHeaders method proxy status action = leafRouter route'
246− where
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
230+ let (headers, b) = splitHeaders output
231+ case handleAcceptH proxy (AcceptHeader accH) b of
232+ Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
233+ Just (contentT, body) ->
234+ let bdy = if allowedMethodHead method request then "" else body
235+ in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
255236
256237instance OVERLAPPABLE_
257238 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -260,7 +241,7 @@ instance OVERLAPPABLE_
260241 type ServerT (Verb method status ctypes a) m = m a
261242 hoistServerWithContext _ _ nt s = nt s
262243
263− route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
244+ route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
264245 where method = reflectMethod (Proxy :: Proxy method)
265246 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
266247
@@ -272,7 +253,7 @@ instance OVERLAPPING_
272253 type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
273254 hoistServerWithContext _ _ nt s = nt s
274255
275− route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
256+ route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
276257 where method = reflectMethod (Proxy :: Proxy method)
277258 status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
278259