Merge pull request #920 from phadej/free-client

Add Servant.Client.Free

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

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)

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,16 +19,17 @@ 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
+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 =
@@ -48,3 +50,8 @@ 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

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))

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

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