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

Merge pull request #920 from phadej/free-client

Browse source 
Add Servant.Client.Free
This commit is contained in:
Oleg Grenrus 2018-03-11 21:07:09 +02:00 committed by GitHub
commit fe20b5a38a
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
6 changed files with 37 additions and 4 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)

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

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

1
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
View file

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

1
servant-client/src/Servant/Client/Internal/HttpClient.hs
View file

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