diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 5d0ce62f..08dc6f37 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -31,10 +31,12 @@ source-repository head library exposed-modules: Servant.Client.Core + Servant.Client.Free Servant.Client.Core.Reexport Servant.Client.Core.Internal.Auth Servant.Client.Core.Internal.BaseUrl Servant.Client.Core.Internal.BasicAuth + Servant.Client.Core.Internal.ClientF Servant.Client.Core.Internal.Generic Servant.Client.Core.Internal.HasClient Servant.Client.Core.Internal.Request @@ -65,6 +67,7 @@ library base-compat >= 0.9.3 && < 0.10 , base64-bytestring >= 1.0.0.1 && < 1.1 , exceptions >= 0.8.3 && < 0.9 + , free >= 5.0.1 && < 5.1 , generics-sop >= 0.3.1.0 && < 0.4 , http-api-data >= 0.3.7.1 && < 0.4 , http-media >= 0.7.1.1 && < 0.8 diff --git a/servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs b/servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs new file mode 100644 index 00000000..19099e0b --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DeriveFunctor #-} +module Servant.Client.Core.Internal.ClientF where + +import Servant.Client.Core.Internal.Request + +data ClientF a + = RunRequest Request (Response -> a) + | StreamingRequest Request (StreamingResponse -> a) + | Throw ServantError + deriving (Functor) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs index 1c959998..82d2858a 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs @@ -10,6 +10,7 @@ import Prelude () import Prelude.Compat import Control.Monad (unless) +import Control.Monad.Free (Free (..), liftF) import Data.Foldable (toList) import Data.Proxy (Proxy) import qualified Data.Text as T @@ -18,9 +19,11 @@ import Network.HTTP.Media (MediaType, matches, import Servant.API (MimeUnrender, contentTypes, mimeUnrender) + import Servant.Client.Core.Internal.Request (Request, Response, GenResponse (..), StreamingResponse (..), ServantError (..)) +import Servant.Client.Core.Internal.ClientF class (Monad m) => RunClient m where -- | How to make a request. @@ -48,3 +51,12 @@ decodedAs response contentType = do Right val -> return val where accept = toList $ contentTypes contentType + +instance ClientF ~ f => RunClient (Free f) where + runRequest req = liftF (RunRequest req id) + streamingRequest req = liftF (StreamingRequest req id) + throwServantError = liftF . Throw + catchServantError x h = go x where + go (Pure a) = Pure a + go (Free (Throw e)) = h e + go (Free f) = Free (fmap go f) diff --git a/servant-client-core/src/Servant/Client/Free.hs b/servant-client-core/src/Servant/Client/Free.hs new file mode 100644 index 00000000..bca39aba --- /dev/null +++ b/servant-client-core/src/Servant/Client/Free.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, GADTs #-} +module Servant.Client.Free ( + client, + ClientF (..), + module Servant.Client.Core.Reexport, + ) where + +import Data.Proxy (Proxy (..)) +import Control.Monad.Free +import Servant.Client.Core +import Servant.Client.Core.Reexport +import Servant.Client.Core.Internal.ClientF + +client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api +client api = api `clientIn` (Proxy :: Proxy (Free ClientF))