eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

refactor servant.server.internal to consolidate functions (#837)

Browse source 
refactor servant.server.internal to consolidate functions
This commit is contained in:
gbaz 2017-10-28 11:17:24 -07:00 committed by Alp Mestanogullari
parent ec8c99372d
commit da98c94e2f
1 changed files with 14 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

47
servant-server/src/Servant/Server/Internal.hs
View file

@ -10,6 +10,7 @@
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
@ -41,7 +42,7 @@ import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
symbolVal) symbolVal)
import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Socket (SockAddr) import Network.Socket (SockAddr)
import Network.Wai (Application, Request, Response, import Network.Wai (Application, Request,
httpVersion, isSecure, httpVersion, isSecure,
lazyRequestBody, lazyRequestBody,
rawQueryString, remoteHost, rawQueryString, remoteHost,
@ -197,16 +198,6 @@ allowedMethodHead method request = method == methodGet && requestMethod request
allowedMethod :: Method -> Request -> Bool allowedMethod :: Method -> Request -> Bool
allowedMethod method request = allowedMethodHead method request || requestMethod request == method allowedMethod method request = allowedMethodHead method request || requestMethod request == method
processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method
-> Maybe [(HeaderName, B.ByteString)]
-> Request -> RouteResult Response
processMethodRouter handleA status method headers request = case handleA of
Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
Just (contentT, body) -> Route $ responseLBS status hdrs bdy
where
bdy = if allowedMethodHead method request then "" else body
hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
methodCheck :: Method -> Request -> DelayedIO () methodCheck :: Method -> Request -> DelayedIO ()
methodCheck method request methodCheck method request
| allowedMethod method request = return () | allowedMethod method request = return ()
@ -225,33 +216,23 @@ acceptCheck proxy accH
| otherwise = delayedFail err406 | otherwise = delayedFail err406
methodRouter :: (AllCTRender ctypes a) methodRouter :: (AllCTRender ctypes a)
=> Method -> Proxy ctypes -> Status => (b -> ([(HeaderName, B.ByteString)], a))
-> Delayed env (Handler a) -> Method -> Proxy ctypes -> Status
-> Delayed env (Handler b)
-> Router env -> Router env
methodRouter method proxy status action = leafRouter route' methodRouter splitHeaders method proxy status action = leafRouter route'
where where
route' env request respond = route' env request respond =
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
in runAction (action `addMethodCheck` methodCheck method request in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH `addAcceptCheck` acceptCheck proxy accH
) env request respond $ \ output -> do ) env request respond $ \ output -> do
let handleA = handleAcceptH proxy (AcceptHeader accH) output let (headers, b) = splitHeaders output
processMethodRouter handleA status method Nothing request case handleAcceptH proxy (AcceptHeader accH) b of
Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) Just (contentT, body) ->
=> Method -> Proxy ctypes -> Status let bdy = if allowedMethodHead method request then "" else body
-> Delayed env (Handler (Headers h v)) in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
-> Router env
methodRouterHeaders method proxy status action = leafRouter route'
where
route' env request respond =
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH
) env request respond $ \ output -> do
let headers = getHeaders output
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
processMethodRouter handleA status method (Just headers) request
instance OVERLAPPABLE_ instance OVERLAPPABLE_
( AllCTRender ctypes a, ReflectMethod method, KnownNat status ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@ -260,7 +241,7 @@ instance OVERLAPPABLE_
type ServerT (Verb method status ctypes a) m = m a type ServerT (Verb method status ctypes a) m = m a
hoistServerWithContext _ _ nt s = nt s hoistServerWithContext _ _ nt s = nt s
route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
@ -272,7 +253,7 @@ instance OVERLAPPING_
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
hoistServerWithContext _ _ nt s = nt s hoistServerWithContext _ _ nt s = nt s
route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)