rename ServerCombinator
This commit is contained in:
Sönke Hahn
parent
a4bb467446
commit
397815fe06
2 changed files with 24 additions and 24 deletions
|
|
@ -10,8 +10,8 @@
|
|||
-- fixme: document dependency problem
|
||||
|
||||
module Servant.Server.Utils.CustomCombinators (
|
||||
CombinatorImplementation,
|
||||
runCI,
|
||||
ServerCombinator,
|
||||
runServerCombinator,
|
||||
makeCaptureCombinator,
|
||||
makeRequestCheckCombinator,
|
||||
makeAuthCombinator,
|
||||
|
|
@ -34,31 +34,31 @@ import Servant.API
|
|||
import Servant.Server
|
||||
import Servant.Server.Internal
|
||||
|
||||
data CombinatorImplementation combinator arg api context where
|
||||
data ServerCombinator combinator arg api context where
|
||||
CI :: (forall env .
|
||||
Proxy (combinator :> api)
|
||||
-> Context context
|
||||
-> Delayed env (WithArg arg (Server api))
|
||||
-> Router' env RoutingApplication)
|
||||
-> CombinatorImplementation combinator arg api context
|
||||
-> ServerCombinator combinator arg api context
|
||||
|
||||
-- fixme: get rid of WithArg?
|
||||
type family WithArg arg rest where
|
||||
WithArg () rest = rest
|
||||
WithArg arg rest = arg -> rest
|
||||
|
||||
runCI :: CombinatorImplementation combinator arg api context
|
||||
runServerCombinator :: ServerCombinator combinator arg api context
|
||||
-> Proxy (combinator :> api)
|
||||
-> Context context
|
||||
-> Delayed env (WithArg arg (Server api))
|
||||
-> Router' env RoutingApplication
|
||||
runCI (CI i) = i
|
||||
runServerCombinator (CI i) = i
|
||||
|
||||
makeCaptureCombinator ::
|
||||
(HasServer api context,
|
||||
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) =>
|
||||
(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
|
||||
where
|
||||
inner ::
|
||||
|
|
@ -66,7 +66,7 @@ makeCaptureCombinator = inner -- we use 'inner' to avoid having 'forall' show up
|
|||
(HasServer api context,
|
||||
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) =>
|
||||
(Context context -> Text -> IO (RouteResult arg))
|
||||
-> CombinatorImplementation combinator arg api context
|
||||
-> ServerCombinator combinator arg api context
|
||||
inner getArg = CI $ \ Proxy context delayed ->
|
||||
CaptureRouter $
|
||||
route (Proxy :: Proxy api) context $ addCapture delayed $ \ captured ->
|
||||
|
|
@ -76,7 +76,7 @@ makeRequestCheckCombinator ::
|
|||
(HasServer api context,
|
||||
WithArg () (ServerT api Handler) ~ ServerT api Handler) =>
|
||||
(Context context -> Request -> IO (RouteResult ()))
|
||||
-> CombinatorImplementation combinator () api context
|
||||
-> ServerCombinator combinator () api context
|
||||
makeRequestCheckCombinator = inner
|
||||
where
|
||||
inner ::
|
||||
|
|
@ -84,7 +84,7 @@ makeRequestCheckCombinator = inner
|
|||
(HasServer api context,
|
||||
WithArg () (ServerT api Handler) ~ ServerT api Handler) =>
|
||||
(Context context -> Request -> IO (RouteResult ()))
|
||||
-> CombinatorImplementation combinator () api context
|
||||
-> ServerCombinator combinator () api context
|
||||
inner check = CI $ \ Proxy context delayed ->
|
||||
route (Proxy :: Proxy api) context $ addMethodCheck delayed $
|
||||
withRequest $ \ request ->
|
||||
|
|
@ -94,7 +94,7 @@ makeAuthCombinator ::
|
|||
(HasServer api context,
|
||||
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) =>
|
||||
(Context context -> Request -> IO (RouteResult arg))
|
||||
-> CombinatorImplementation combinator arg api context
|
||||
-> ServerCombinator combinator arg api context
|
||||
makeAuthCombinator = inner
|
||||
where
|
||||
inner ::
|
||||
|
|
@ -102,7 +102,7 @@ makeAuthCombinator = inner
|
|||
(HasServer api context,
|
||||
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler)) =>
|
||||
(Context context -> Request -> IO (RouteResult arg))
|
||||
-> CombinatorImplementation combinator arg api context
|
||||
-> ServerCombinator combinator arg api context
|
||||
inner authCheck = CI $ \ Proxy context delayed ->
|
||||
route (Proxy :: Proxy api) context $ addAuthCheck delayed $
|
||||
withRequest $ \ request ->
|
||||
|
|
@ -113,7 +113,7 @@ makeReqBodyCombinator ::
|
|||
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler),
|
||||
HasServer api context) =>
|
||||
(Context context -> IO ByteString -> arg)
|
||||
-> CombinatorImplementation combinator arg api context
|
||||
-> ServerCombinator combinator arg api context
|
||||
makeReqBodyCombinator = inner
|
||||
where
|
||||
inner ::
|
||||
|
|
@ -122,7 +122,7 @@ makeReqBodyCombinator = inner
|
|||
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler),
|
||||
HasServer api context) =>
|
||||
(Context context -> IO ByteString -> arg)
|
||||
-> CombinatorImplementation combinator arg api context
|
||||
-> ServerCombinator combinator arg api context
|
||||
inner getArg = CI $ \ Proxy context delayed ->
|
||||
route (Proxy :: Proxy api) context $ addBodyCheck delayed
|
||||
(return ())
|
||||
|
|
@ -134,7 +134,7 @@ makeCombinator ::
|
|||
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler),
|
||||
HasServer api context) =>
|
||||
(Context context -> Request -> IO (RouteResult arg))
|
||||
-> CombinatorImplementation combinator arg api context
|
||||
-> ServerCombinator combinator arg api context
|
||||
makeCombinator = inner
|
||||
where
|
||||
inner ::
|
||||
|
|
@ -143,7 +143,7 @@ makeCombinator = inner
|
|||
WithArg arg (ServerT api Handler) ~ (arg -> ServerT api Handler),
|
||||
HasServer api context) =>
|
||||
(Context context -> Request -> IO (RouteResult arg))
|
||||
-> CombinatorImplementation combinator arg api context
|
||||
-> ServerCombinator combinator arg api context
|
||||
inner getArg = CI $ \ Proxy context delayed ->
|
||||
route (Proxy :: Proxy api) context $ addBodyCheck delayed
|
||||
(return ())
|
||||
|
|
|
|||
|
|
@ -186,7 +186,7 @@ data StringCapture
|
|||
|
||||
instance HasServer api context => HasServer (StringCapture :> api) context where
|
||||
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 snippet = return $ case snippet of
|
||||
|
|
@ -199,7 +199,7 @@ data CheckFooHeader
|
|||
|
||||
instance HasServer api context => HasServer (CheckFooHeader :> api) context where
|
||||
type ServerT (CheckFooHeader :> api) m = ServerT api m
|
||||
route = runCI $ makeRequestCheckCombinator (const checkFooHeader)
|
||||
route = runServerCombinator $ makeRequestCheckCombinator (const checkFooHeader)
|
||||
|
||||
checkFooHeader :: Request -> IO (RouteResult ())
|
||||
checkFooHeader request = return $
|
||||
|
|
@ -212,7 +212,7 @@ data InvalidRequestCheckCombinator
|
|||
|
||||
instance HasServer api context => HasServer (InvalidRequestCheckCombinator :> api) context where
|
||||
type ServerT (InvalidRequestCheckCombinator :> api) m = ServerT api m
|
||||
route = runCI $ makeRequestCheckCombinator (const accessReqBody)
|
||||
route = runServerCombinator $ makeRequestCheckCombinator (const accessReqBody)
|
||||
|
||||
accessReqBody :: Request -> IO (RouteResult ())
|
||||
accessReqBody request = do
|
||||
|
|
@ -228,7 +228,7 @@ data User = User String
|
|||
|
||||
instance HasServer api context => HasServer (AuthCombinator :> api) context where
|
||||
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 = return $ case lookup "Auth" (requestHeaders request) of
|
||||
|
|
@ -241,7 +241,7 @@ data InvalidAuthCombinator
|
|||
|
||||
instance HasServer api context => HasServer (InvalidAuthCombinator :> api) context where
|
||||
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 = do
|
||||
|
|
@ -253,7 +253,7 @@ data AuthWithContext
|
|||
instance (HasContextEntry context [(SBS.ByteString, User)], HasServer api context) =>
|
||||
HasServer (AuthWithContext :> api) context where
|
||||
type ServerT (AuthWithContext :> api) m = User -> ServerT api m
|
||||
route = runCI $ makeAuthCombinator authWithContext
|
||||
route = runServerCombinator $ makeAuthCombinator authWithContext
|
||||
|
||||
authWithContext :: (HasContextEntry context [(SBS.ByteString, User)]) =>
|
||||
Context context -> Request -> IO (RouteResult User)
|
||||
|
|
@ -269,7 +269,7 @@ data FooHeader
|
|||
|
||||
instance HasServer api context => HasServer (FooHeader :> api) context where
|
||||
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 = 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
|
||||
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 = Source
|
||||
|
|
|
|||
Loading…
Reference in a new issue