From 80188e024e54b37c21bc44ee315773cde9757477 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 11 Mar 2018 14:03:27 +0200 Subject: [PATCH 1/2] Add Servant.Client.Free --- servant-client-core/servant-client-core.cabal | 3 +++ .../src/Servant/Client/Core/Internal/ClientF.hs | 10 ++++++++++ .../src/Servant/Client/Core/Internal/RunClient.hs | 12 ++++++++++++ servant-client-core/src/Servant/Client/Free.hs | 15 +++++++++++++++ 4 files changed, 40 insertions(+) create mode 100644 servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs create mode 100644 servant-client-core/src/Servant/Client/Free.hs 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)) From 454f53315f6c98ab1bc21702bc20bd77428f2803 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 11 Mar 2018 16:50:14 +0200 Subject: [PATCH 2/2] Remove catchServantError --- .../src/Servant/Client/Core/Internal/RunClient.hs | 7 +------ .../src/Servant/Client/Internal/XhrClient.hs | 1 - servant-client/src/Servant/Client/Internal/HttpClient.hs | 1 - 3 files changed, 1 insertion(+), 8 deletions(-) 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 82d2858a..ac6e02ac 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs @@ -25,12 +25,11 @@ import Servant.Client.Core.Internal.Request (Request, Response, GenRes ServantError (..)) import Servant.Client.Core.Internal.ClientF -class (Monad m) => RunClient m where +class Monad m => RunClient m where -- | How to make a request. runRequest :: Request -> m Response streamingRequest :: Request -> m StreamingResponse throwServantError :: ServantError -> m a - catchServantError :: m a -> (ServantError -> m a) -> m a checkContentTypeHeader :: RunClient m => Response -> m MediaType checkContentTypeHeader response = @@ -56,7 +55,3 @@ 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-ghcjs/src/Servant/Client/Internal/XhrClient.hs b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs index 8cb77d22..27f09008 100644 --- a/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs +++ b/servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs @@ -78,7 +78,6 @@ instance Alt ClientM where instance RunClient ClientM where runRequest = performRequest throwServantError = throwError - catchServantError = catchError instance ClientLike (ClientM a) (ClientM a) where mkClient = id diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index d3613650..f976deed 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -96,7 +96,6 @@ instance RunClient ClientM where runRequest = performRequest streamingRequest = performStreamingRequest throwServantError = throwError - catchServantError = catchError instance ClientLike (ClientM a) (ClientM a) where mkClient = id