eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Add Servant.Client.Free

Browse source
This commit is contained in:
Oleg Grenrus 2018-03-11 14:03:27 +02:00
parent bcca635151
commit 80188e024e
4 changed files with 40 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
servant-client-core/servant-client-core.cabal
View file

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

10
servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs Normal file
View file

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

12
servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs
View file

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

15
servant-client-core/src/Servant/Client/Free.hs Normal file
View file

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