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

rename ServerCombinator

Browse source
This commit is contained in:
Sönke Hahn 2016-10-23 23:52:13 -04:00
parent a4bb467446
commit 397815fe06
2 changed files with 24 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
servant-server/src/Servant/Server/Utils/CustomCombinators.hs
View file

@ -10,8 +10,8 @@
-- fixme: document dependency problem -- fixme: document dependency problem
module Servant.Server.Utils.CustomCombinators ( module Servant.Server.Utils.CustomCombinators (
CombinatorImplementation, ServerCombinator,
runCI, runServerCombinator,
makeCaptureCombinator, makeCaptureCombinator,
makeRequestCheckCombinator, makeRequestCheckCombinator,
makeAuthCombinator, makeAuthCombinator,
@ -34,31 +34,31 @@ import Servant.API
import Servant.Server import Servant.Server
import Servant.Server.Internal import Servant.Server.Internal
data CombinatorImplementation combinator arg api context where data ServerCombinator combinator arg api context where
CI :: (forall env . CI :: (forall env .
Proxy (combinator :> api) Proxy (combinator :> api)
-> Context context -> Context context
-> Delayed env (WithArg arg (Server api)) -> Delayed env (WithArg arg (Server api))
-> Router' env RoutingApplication) -> Router' env RoutingApplication)
-> CombinatorImplementation combinator arg api context -> ServerCombinator combinator arg api context
-- fixme: get rid of WithArg? -- fixme: get rid of WithArg?
type family WithArg arg rest where type family WithArg arg rest where
WithArg () rest = rest WithArg () rest = rest
WithArg arg rest = arg -> rest WithArg arg rest = arg -> rest
runCI :: CombinatorImplementation combinator arg api context runServerCombinator :: ServerCombinator combinator arg api context
-> Proxy (combinator :> api) -> Proxy (combinator :> api)
-> Context context -> Context context
-> Delayed env (WithArg arg (Server api)) -> Delayed env (WithArg arg (Server api))
-> Router' env RoutingApplication -> Router' env RoutingApplication
runCI (CI i) = i runServerCombinator (CI i) = i
makeCaptureCombinator :: makeCaptureCombinator ::
(HasServer api context, (HasServer api context,
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) => WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) =>
(Context context -> Text -> IO (RouteResult arg)) (Context context -> Text -> IO (RouteResult arg))
-> CombinatorImplementation combinator arg api context -> ServerCombinator combinator arg api context
makeCaptureCombinator = inner -- we use 'inner' to avoid having 'forall' show up in haddock docs makeCaptureCombinator = inner -- we use 'inner' to avoid having 'forall' show up in haddock docs
where where
inner :: inner ::
@ -66,7 +66,7 @@ makeCaptureCombinator = inner -- we use 'inner' to avoid having 'forall' show up
(HasServer api context, (HasServer api context,
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) => WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) =>
(Context context -> Text -> IO (RouteResult arg)) (Context context -> Text -> IO (RouteResult arg))
-> CombinatorImplementation combinator arg api context -> ServerCombinator combinator arg api context
inner getArg = CI $ \ Proxy context delayed -> inner getArg = CI $ \ Proxy context delayed ->
CaptureRouter $ CaptureRouter $
route (Proxy :: Proxy api) context $ addCapture delayed $ \ captured -> route (Proxy :: Proxy api) context $ addCapture delayed $ \ captured ->
@ -76,7 +76,7 @@ makeRequestCheckCombinator ::
(HasServer api context, (HasServer api context,
WithArg () (ServerT api Handler) ~ ServerT api Handler) => WithArg () (ServerT api Handler) ~ ServerT api Handler) =>
(Context context -> Request -> IO (RouteResult ())) (Context context -> Request -> IO (RouteResult ()))
-> CombinatorImplementation combinator () api context -> ServerCombinator combinator () api context
makeRequestCheckCombinator = inner makeRequestCheckCombinator = inner
where where
inner :: inner ::
@ -84,7 +84,7 @@ makeRequestCheckCombinator = inner
(HasServer api context, (HasServer api context,
WithArg () (ServerT api Handler) ~ ServerT api Handler) => WithArg () (ServerT api Handler) ~ ServerT api Handler) =>
(Context context -> Request -> IO (RouteResult ())) (Context context -> Request -> IO (RouteResult ()))
-> CombinatorImplementation combinator () api context -> ServerCombinator combinator () api context
inner check = CI $ \ Proxy context delayed -> inner check = CI $ \ Proxy context delayed ->
route (Proxy :: Proxy api) context $ addMethodCheck delayed $ route (Proxy :: Proxy api) context $ addMethodCheck delayed $
withRequest $ \ request -> withRequest $ \ request ->
@ -94,7 +94,7 @@ makeAuthCombinator ::
(HasServer api context, (HasServer api context,
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) => WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) =>
(Context context -> Request -> IO (RouteResult arg)) (Context context -> Request -> IO (RouteResult arg))
-> CombinatorImplementation combinator arg api context -> ServerCombinator combinator arg api context
makeAuthCombinator = inner makeAuthCombinator = inner
where where
inner :: inner ::
@ -102,7 +102,7 @@ makeAuthCombinator = inner
(HasServer api context, (HasServer api context,
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) => WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) =>
(Context context -> Request -> IO (RouteResult arg)) (Context context -> Request -> IO (RouteResult arg))
-> CombinatorImplementation combinator arg api context -> ServerCombinator combinator arg api context
inner authCheck = CI $ \ Proxy context delayed -> inner authCheck = CI $ \ Proxy context delayed ->
route (Proxy :: Proxy api) context $ addAuthCheck delayed $ route (Proxy :: Proxy api) context $ addAuthCheck delayed $
withRequest $ \ request -> withRequest $ \ request ->
@ -113,7 +113,7 @@ makeReqBodyCombinator ::
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler), WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler),
HasServer api context) => HasServer api context) =>
(Context context -> IO ByteString -> arg) (Context context -> IO ByteString -> arg)
-> CombinatorImplementation combinator arg api context -> ServerCombinator combinator arg api context
makeReqBodyCombinator = inner makeReqBodyCombinator = inner
where where
inner :: inner ::
@ -122,7 +122,7 @@ makeReqBodyCombinator = inner
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler), WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler),
HasServer api context) => HasServer api context) =>
(Context context -> IO ByteString -> arg) (Context context -> IO ByteString -> arg)
-> CombinatorImplementation combinator arg api context -> ServerCombinator combinator arg api context
inner getArg = CI $ \ Proxy context delayed -> inner getArg = CI $ \ Proxy context delayed ->
route (Proxy :: Proxy api) context $ addBodyCheck delayed route (Proxy :: Proxy api) context $ addBodyCheck delayed
(return ()) (return ())
@ -134,7 +134,7 @@ makeCombinator ::
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler), WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler),
HasServer api context) => HasServer api context) =>
(Context context -> Request -> IO (RouteResult arg)) (Context context -> Request -> IO (RouteResult arg))
-> CombinatorImplementation combinator arg api context -> ServerCombinator combinator arg api context
makeCombinator = inner makeCombinator = inner
where where
inner :: inner ::
@ -143,7 +143,7 @@ makeCombinator = inner
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler), WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler),
HasServer api context) => HasServer api context) =>
(Context context -> Request -> IO (RouteResult arg)) (Context context -> Request -> IO (RouteResult arg))
-> CombinatorImplementation combinator arg api context -> ServerCombinator combinator arg api context
inner getArg = CI $ \ Proxy context delayed -> inner getArg = CI $ \ Proxy context delayed ->
route (Proxy :: Proxy api) context $ addBodyCheck delayed route (Proxy :: Proxy api) context $ addBodyCheck delayed
(return ()) (return ())

16
servant-server/test/Servant/Server/Utils/CustomCombinatorsSpec.hs
View file

@ -186,7 +186,7 @@ data StringCapture
instance HasServer api context => HasServer (StringCapture :> api) context where instance HasServer api context => HasServer (StringCapture :> api) context where
type ServerT (StringCapture :> api) m = String -> ServerT api m type ServerT (StringCapture :> api) m = String -> ServerT api m
route = runCI $ makeCaptureCombinator (const getCapture) route = runServerCombinator $ makeCaptureCombinator (const getCapture)
getCapture :: Text -> IO (RouteResult String) getCapture :: Text -> IO (RouteResult String)
getCapture snippet = return $ case snippet of getCapture snippet = return $ case snippet of
@ -199,7 +199,7 @@ data CheckFooHeader
instance HasServer api context => HasServer (CheckFooHeader :> api) context where instance HasServer api context => HasServer (CheckFooHeader :> api) context where
type ServerT (CheckFooHeader :> api) m = ServerT api m type ServerT (CheckFooHeader :> api) m = ServerT api m
route = runCI $ makeRequestCheckCombinator (const checkFooHeader) route = runServerCombinator $ makeRequestCheckCombinator (const checkFooHeader)
checkFooHeader :: Request -> IO (RouteResult ()) checkFooHeader :: Request -> IO (RouteResult ())
checkFooHeader request = return $ checkFooHeader request = return $
@ -212,7 +212,7 @@ data InvalidRequestCheckCombinator
instance HasServer api context => HasServer (InvalidRequestCheckCombinator :> api) context where instance HasServer api context => HasServer (InvalidRequestCheckCombinator :> api) context where
type ServerT (InvalidRequestCheckCombinator :> api) m = ServerT api m type ServerT (InvalidRequestCheckCombinator :> api) m = ServerT api m
route = runCI $ makeRequestCheckCombinator (const accessReqBody) route = runServerCombinator $ makeRequestCheckCombinator (const accessReqBody)
accessReqBody :: Request -> IO (RouteResult ()) accessReqBody :: Request -> IO (RouteResult ())
accessReqBody request = do accessReqBody request = do
@ -228,7 +228,7 @@ data User = User String
instance HasServer api context => HasServer (AuthCombinator :> api) context where instance HasServer api context => HasServer (AuthCombinator :> api) context where
type ServerT (AuthCombinator :> api) m = User -> ServerT api m type ServerT (AuthCombinator :> api) m = User -> ServerT api m
route = runCI $ makeAuthCombinator (const checkAuth) route = runServerCombinator $ makeAuthCombinator (const checkAuth)
checkAuth :: Request -> IO (RouteResult User) checkAuth :: Request -> IO (RouteResult User)
checkAuth request = return $ case lookup "Auth" (requestHeaders request) of checkAuth request = return $ case lookup "Auth" (requestHeaders request) of
@ -241,7 +241,7 @@ data InvalidAuthCombinator
instance HasServer api context => HasServer (InvalidAuthCombinator :> api) context where instance HasServer api context => HasServer (InvalidAuthCombinator :> api) context where
type ServerT (InvalidAuthCombinator :> api) m = User -> ServerT api m type ServerT (InvalidAuthCombinator :> api) m = User -> ServerT api m
route = runCI $ makeAuthCombinator (const authWithReqBody) route = runServerCombinator $ makeAuthCombinator (const authWithReqBody)
authWithReqBody :: Request -> IO (RouteResult User) authWithReqBody :: Request -> IO (RouteResult User)
authWithReqBody request = do authWithReqBody request = do
@ -253,7 +253,7 @@ data AuthWithContext
instance (HasContextEntry context [(SBS.ByteString, User)], HasServer api context) => instance (HasContextEntry context [(SBS.ByteString, User)], HasServer api context) =>
HasServer (AuthWithContext :> api) context where HasServer (AuthWithContext :> api) context where
type ServerT (AuthWithContext :> api) m = User -> ServerT api m type ServerT (AuthWithContext :> api) m = User -> ServerT api m
route = runCI $ makeAuthCombinator authWithContext route = runServerCombinator $ makeAuthCombinator authWithContext
authWithContext :: (HasContextEntry context [(SBS.ByteString, User)]) => authWithContext :: (HasContextEntry context [(SBS.ByteString, User)]) =>
Context context -> Request -> IO (RouteResult User) Context context -> Request -> IO (RouteResult User)
@ -269,7 +269,7 @@ data FooHeader
instance HasServer api context => HasServer (FooHeader :> api) context where instance HasServer api context => HasServer (FooHeader :> api) context where
type ServerT (FooHeader :> api) m = String -> ServerT api m type ServerT (FooHeader :> api) m = String -> ServerT api m
route = runCI $ makeCombinator (const getCustom) route = runServerCombinator $ makeCombinator (const getCustom)
getCustom :: Request -> IO (RouteResult String) getCustom :: Request -> IO (RouteResult String)
getCustom request = return $ case lookup "Foo" (requestHeaders request) of getCustom request = return $ case lookup "Foo" (requestHeaders request) of
@ -284,7 +284,7 @@ data Source = Source (IO SBS.ByteString)
instance HasServer api context => HasServer (StreamRequest :> api) context where instance HasServer api context => HasServer (StreamRequest :> api) context where
type ServerT (StreamRequest :> api) m = Source -> ServerT api m type ServerT (StreamRequest :> api) m = Source -> ServerT api m
route = runCI $ makeReqBodyCombinator (const getSource) route = runServerCombinator $ makeReqBodyCombinator (const getSource)
getSource :: IO SBS.ByteString -> Source getSource :: IO SBS.ByteString -> Source
getSource = Source getSource = Source