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

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