Add parameter-supplying operator
Renamed `(/:)` to `(//)`, and used `(/:)` for supplying parameters to client functions. Should close #1442.
This commit is contained in:
parent
6718752b4a
commit
d81c8d9911
4 changed files with 55 additions and 13 deletions
|
@ -27,6 +27,7 @@ module Servant.Client.Core.HasClient (
|
||||||
HasClient (..),
|
HasClient (..),
|
||||||
EmptyClient (..),
|
EmptyClient (..),
|
||||||
AsClientT,
|
AsClientT,
|
||||||
|
(//),
|
||||||
(/:),
|
(/:),
|
||||||
foldMapUnion,
|
foldMapUnion,
|
||||||
matchUnion,
|
matchUnion,
|
||||||
|
@ -54,7 +55,8 @@ import Data.Sequence
|
||||||
(fromList)
|
(fromList)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Network.HTTP.Media
|
import Network.HTTP.Media
|
||||||
(MediaType, matches, parseAccept, (//))
|
(MediaType, matches, parseAccept)
|
||||||
|
import qualified Network.HTTP.Media as Media
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
import Data.SOP.BasicFunctors
|
import Data.SOP.BasicFunctors
|
||||||
(I (I), (:.:) (Comp))
|
(I (I), (:.:) (Comp))
|
||||||
|
@ -873,9 +875,12 @@ instance
|
||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
infixl 1 /:
|
infixl 1 //
|
||||||
|
infixl 2 /:
|
||||||
|
|
||||||
-- | Convenience function for working with nested record-clients.
|
-- | Helper to make code using records of clients more readable.
|
||||||
|
--
|
||||||
|
-- Can be mixed with (/:) for supplying arguments.
|
||||||
--
|
--
|
||||||
-- Example:
|
-- Example:
|
||||||
--
|
--
|
||||||
|
@ -899,10 +904,46 @@ infixl 1 /:
|
||||||
-- rootClient = client api
|
-- rootClient = client api
|
||||||
--
|
--
|
||||||
-- endpointClient :: ClientM Person
|
-- endpointClient :: ClientM Person
|
||||||
-- endpointClient = client /: subApi /: endpoint
|
-- endpointClient = client // subApi // endpoint
|
||||||
-- @@
|
-- @@
|
||||||
(/:) :: a -> (a -> b) -> b
|
(//) :: a -> (a -> b) -> b
|
||||||
x /: f = f x
|
x // f = f x
|
||||||
|
|
||||||
|
-- | Convenience function for supplying arguments to client functions when
|
||||||
|
-- working with records of clients.
|
||||||
|
--
|
||||||
|
-- Intended to be use in conjunction with '(//)'.
|
||||||
|
--
|
||||||
|
-- Example:
|
||||||
|
--
|
||||||
|
-- @@
|
||||||
|
-- type Api = NamedAPI RootApi
|
||||||
|
--
|
||||||
|
-- data RootApi mode = RootApi
|
||||||
|
-- { subApi :: mode :- Capture "token" String :> NamedAPI SubApi
|
||||||
|
-- , hello :: mode :- Capture "name" String :> Get '[JSON] String
|
||||||
|
-- , …
|
||||||
|
-- } deriving Generic
|
||||||
|
--
|
||||||
|
-- data SubAmi mode = SubApi
|
||||||
|
-- { endpoint :: mode :- Get '[JSON] Person
|
||||||
|
-- , …
|
||||||
|
-- } deriving Generic
|
||||||
|
--
|
||||||
|
-- api :: Proxy API
|
||||||
|
-- api = Proxy
|
||||||
|
--
|
||||||
|
-- rootClient :: RootApi (AsClientT ClientM)
|
||||||
|
-- rootClient = client api
|
||||||
|
--
|
||||||
|
-- hello :: String -> ClientM String
|
||||||
|
-- hello name = rootClient // hello /: name
|
||||||
|
--
|
||||||
|
-- endpointClient :: ClientM Person
|
||||||
|
-- endpointClient = client // subApi /: "foobar123" // endpoint
|
||||||
|
-- @@
|
||||||
|
(/:) :: (a -> b -> c) -> b -> a -> c
|
||||||
|
(/:) = flip
|
||||||
|
|
||||||
|
|
||||||
{- Note [Non-Empty Content Types]
|
{- Note [Non-Empty Content Types]
|
||||||
|
@ -928,7 +969,7 @@ for empty and one for non-empty lists).
|
||||||
checkContentTypeHeader :: RunClient m => Response -> m MediaType
|
checkContentTypeHeader :: RunClient m => Response -> m MediaType
|
||||||
checkContentTypeHeader response =
|
checkContentTypeHeader response =
|
||||||
case lookup "Content-Type" $ toList $ responseHeaders response of
|
case lookup "Content-Type" $ toList $ responseHeaders response of
|
||||||
Nothing -> return $ "application"//"octet-stream"
|
Nothing -> return $ "application" Media.// "octet-stream"
|
||||||
Just t -> case parseAccept t of
|
Just t -> case parseAccept t of
|
||||||
Nothing -> throwClientError $ InvalidContentTypeHeader response
|
Nothing -> throwClientError $ InvalidContentTypeHeader response
|
||||||
Just t' -> return t'
|
Just t' -> return t'
|
||||||
|
|
|
@ -8,6 +8,7 @@ module Servant.Client.Core.Reexport
|
||||||
, foldMapUnion
|
, foldMapUnion
|
||||||
, matchUnion
|
, matchUnion
|
||||||
, AsClientT
|
, AsClientT
|
||||||
|
, (//)
|
||||||
, (/:)
|
, (/:)
|
||||||
|
|
||||||
-- * Response (for @Raw@)
|
-- * Response (for @Raw@)
|
||||||
|
|
|
@ -111,7 +111,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
|
||||||
data RecordRoutes mode = RecordRoutes
|
data RecordRoutes mode = RecordRoutes
|
||||||
{ version :: mode :- "version" :> Get '[JSON] Int
|
{ version :: mode :- "version" :> Get '[JSON] Int
|
||||||
, echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String
|
, echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String
|
||||||
, otherRoutes :: mode :- "other" :> NamedRoutes OtherRoutes
|
, otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes
|
||||||
} deriving Generic
|
} deriving Generic
|
||||||
|
|
||||||
data OtherRoutes mode = OtherRoutes
|
data OtherRoutes mode = OtherRoutes
|
||||||
|
@ -246,7 +246,7 @@ server = serve api (
|
||||||
:<|> RecordRoutes
|
:<|> RecordRoutes
|
||||||
{ version = pure 42
|
{ version = pure 42
|
||||||
, echo = pure
|
, echo = pure
|
||||||
, otherRoutes = OtherRoutes
|
, otherRoutes = \_ -> OtherRoutes
|
||||||
{ something = pure ["foo", "bar", "pweet"]
|
{ something = pure ["foo", "bar", "pweet"]
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
|
@ -19,7 +19,7 @@ module Servant.GenericSpec (spec) where
|
||||||
|
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
|
||||||
import Servant.Client ((/:))
|
import Servant.Client ((//), (/:))
|
||||||
import Servant.ClientTestUtils
|
import Servant.ClientTestUtils
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
|
@ -31,7 +31,7 @@ genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
||||||
context "Record clients work as expected" $ do
|
context "Record clients work as expected" $ do
|
||||||
|
|
||||||
it "Client functions return expected values" $ \(_,baseUrl) -> do
|
it "Client functions return expected values" $ \(_,baseUrl) -> do
|
||||||
runClient (recordRoutes /: version) baseUrl `shouldReturn` Right 42
|
runClient (recordRoutes // version) baseUrl `shouldReturn` Right 42
|
||||||
runClient (recordRoutes /: echo $ "foo") baseUrl `shouldReturn` Right "foo"
|
runClient (recordRoutes // echo /: "foo") baseUrl `shouldReturn` Right "foo"
|
||||||
it "Clients can be nested" $ \(_,baseUrl) -> do
|
it "Clients can be nested" $ \(_,baseUrl) -> do
|
||||||
runClient (recordRoutes /: otherRoutes /: something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]
|
runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]
|
||||||
|
|
Loading…
Reference in a new issue