diff --git a/servant-freer-client/servant-freer-client.cabal b/servant-freer-client/servant-freer-client.cabal index deb749a8..7d79f4cb 100644 --- a/servant-freer-client/servant-freer-client.cabal +++ b/servant-freer-client/servant-freer-client.cabal @@ -25,6 +25,7 @@ source-repository head library exposed-modules: + Servant.FreerReq Servant.FreerClient build-depends: base >= 4.7 && < 4.11 diff --git a/servant-freer-client/src/Servant/FreerClient.hs b/servant-freer-client/src/Servant/FreerClient.hs index 0e6e4cd7..8bafa52c 100644 --- a/servant-freer-client/src/Servant/FreerClient.hs +++ b/servant-freer-client/src/Servant/FreerClient.hs @@ -1,69 +1,46 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE UndecidableInstances #-} module Servant.FreerClient where -import Control.Exception (toException) -import Control.Monad.Freer -import Control.Monad.Freer.Exception -import Control.Monad.Freer.Http -import Control.Monad.Freer.Reader -import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any) -import Data.String.Conversions (cs) -import Network.HTTP.Client (Response) -import Network.HTTP.Types -import Network.HTTP.Media -import Servant.Common.Req hiding (ClientM, runClientM') +import Servant.API +import Control.Monad.Freer +import Control.Monad.Freer.Exception +import Control.Monad.Freer.Http +import Control.Monad.Freer.Reader +import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any) +import Data.Proxy +import Network.HTTP.Client (Response) +import Network.HTTP.Media +import qualified Network.HTTP.Types as H +import qualified Network.HTTP.Types.Header as HTTP +import Servant.Client hiding (ClientM, clientWithRoute) +import Servant.Common.Req hiding (ClientM, runClientM', performRequest) +import Servant.FreerReq -import qualified Network.HTTP.Client as Client -import qualified Network.HTTP.Types.Header as HTTP +freeClient :: HasFreeClient r api => Proxy r -> Proxy api -> FreeClient r api +freeClient r p = clientWithRoute r p defReq -newtype ClientM r a = ClientM { runClientM' :: ( Member (Reader ClientEnv) r - , Member (Exc ServantError) r - , Member Http r) => (Eff r) a } +class HasFreeClient r api where + type FreeClient (r :: [* -> *]) api :: * + clientWithRoute :: Proxy r -> Proxy api -> Req -> FreeClient r api -instance Functor (ClientM r) where - fmap f a = ClientM $ fmap f (runClientM' a) +instance ( Member Http r + , Member (Reader ClientEnv) r + , Member (Exc ServantError) r) => HasFreeClient r Raw where + type FreeClient r Raw + = H.Method -> ClientM r ( Int + , ByteString + , MediaType + , [HTTP.Header] + , Response ByteString) -instance Applicative (ClientM r) where - pure a = ClientM $ pure a - f <*> a = ClientM $ (runClientM' f) <*> (runClientM' a) - -instance Monad (ClientM r) where - a >>= f = ClientM $ (runClientM' a) >>= (runClientM' . f) - -performRequest :: ( Member Http r - , Member (Reader ClientEnv) r - , Member (Exc ServantError) r) - => Method -> Req -> ClientM r ( Int, ByteString, MediaType - , [HTTP.Header], Response ByteString) -performRequest reqMethod req = ClientM $ do - m <- asks manager - reqHost <- asks baseUrl - response <- case (reqToRequest req reqHost) of - Left some -> throwError . ConnectionError $ toException some - Right request -> doRequest request - let status = Client.responseStatus response - body = Client.responseBody response - hdrs = Client.responseHeaders response - status_code = statusCode status - ct <- case lookup "Content-Type" $ Client.responseHeaders response of - Nothing -> pure $ "application"//"octet-stream" - Just t -> case parseAccept t of - Nothing -> throwError $ InvalidContentTypeHeader (cs t) body - Just t' -> pure t' - return (status_code, body, ct, hdrs, response) - -runClientM :: ClientM ('[ Reader ClientEnv - , Exc ServantError - , Http - , IO]) a -> ClientEnv -> IO (Either ServantError a) -runClientM cm ce@ClientEnv { manager = mgr } = - runM . (runHttp mgr) . runError . (flip runReader ce) $ runClientM' cm + clientWithRoute :: Proxy r -> Proxy Raw -> Req -> FreeClient r Raw + clientWithRoute Proxy Proxy req httpMethod = do + performRequest httpMethod req diff --git a/servant-freer-client/src/Servant/FreerReq.hs b/servant-freer-client/src/Servant/FreerReq.hs new file mode 100644 index 00000000..ff1fcc5d --- /dev/null +++ b/servant-freer-client/src/Servant/FreerReq.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RankNTypes #-} + +module Servant.FreerReq where + +import Control.Exception (toException) +import Control.Monad.Freer +import Control.Monad.Freer.Exception +import Control.Monad.Freer.Http +import Control.Monad.Freer.Reader +import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any) +import Data.String.Conversions (cs) +import Network.HTTP.Client (Response) +import qualified Network.HTTP.Client as Client +import Network.HTTP.Media +import Network.HTTP.Types +import qualified Network.HTTP.Types.Header as HTTP +import Servant.Common.Req hiding (ClientM, runClientM') + +newtype ClientM r a = ClientM { runClientM' :: ( Member (Reader ClientEnv) r + , Member (Exc ServantError) r + , Member Http r) => (Eff r) a } + +instance Functor (ClientM r) where + fmap f a = ClientM $ fmap f (runClientM' a) + +instance Applicative (ClientM r) where + pure a = ClientM $ pure a + f <*> a = ClientM $ (runClientM' f) <*> (runClientM' a) + +instance Monad (ClientM r) where + a >>= f = ClientM $ (runClientM' a) >>= (runClientM' . f) + +performRequest :: ( Member Http r + , Member (Reader ClientEnv) r + , Member (Exc ServantError) r) + => Method -> Req -> ClientM r ( Int, ByteString, MediaType + , [HTTP.Header], Response ByteString) +performRequest reqMethod req = ClientM $ do + m <- asks manager + reqHost <- asks baseUrl + response <- case (reqToRequest req reqHost) of + Left some -> throwError . ConnectionError $ toException some + Right request -> doRequest request + let status = Client.responseStatus response + body = Client.responseBody response + hdrs = Client.responseHeaders response + status_code = statusCode status + ct <- case lookup "Content-Type" $ Client.responseHeaders response of + Nothing -> pure $ "application"//"octet-stream" + Just t -> case parseAccept t of + Nothing -> throwError $ InvalidContentTypeHeader (cs t) body + Just t' -> pure t' + return (status_code, body, ct, hdrs, response) + +runClientM :: ClientM ('[ Reader ClientEnv + , Exc ServantError + , Http + , IO]) a -> ClientEnv -> IO (Either ServantError a) +runClientM cm ce@ClientEnv { manager = mgr } = + runM . (runHttp mgr) . runError . (flip runReader ce) $ runClientM' cm