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

Begin writing actual client generation code

Browse source
This commit is contained in:
Sid Raval 2017-06-30 13:18:14 -04:00
parent f5d938287a
commit 4e10ac14c5
3 changed files with 108 additions and 62 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-freer-client/servant-freer-client.cabal
View file

@ -25,6 +25,7 @@ source-repository head
library
exposed-modules:
Servant.FreerReq
Servant.FreerClient
build-depends:
base >= 4.7 && < 4.11

79
servant-freer-client/src/Servant/FreerClient.hs
View file

@ -1,69 +1,46 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE UndecidableInstances #-}
module Servant.FreerClient where
import Control.Exception (toException)
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.String.Conversions (cs)
import Data.Proxy
import Network.HTTP.Client (Response)
import Network.HTTP.Types
import Network.HTTP.Media
import Servant.Common.Req hiding (ClientM, runClientM')
import qualified Network.HTTP.Client as Client
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
newtype ClientM r a = ClientM { runClientM' :: ( Member (Reader ClientEnv) r
, Member (Exc ServantError) r
, Member Http r) => (Eff r) a }
freeClient :: HasFreeClient r api => Proxy r -> Proxy api -> FreeClient r api
freeClient r p = clientWithRoute r p defReq
instance Functor (ClientM r) where
fmap f a = ClientM $ fmap f (runClientM' a)
class HasFreeClient r api where
type FreeClient (r :: [* -> *]) api :: *
clientWithRoute :: Proxy r -> Proxy api -> Req -> FreeClient r api
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
instance ( 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)
, Member (Exc ServantError) r) => HasFreeClient r Raw where
type FreeClient r Raw
= H.Method -> ClientM r ( Int
, ByteString
, MediaType
, [HTTP.Header]
, Response ByteString)
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

68
servant-freer-client/src/Servant/FreerReq.hs Normal file
View file

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