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 library
exposed-modules: exposed-modules:
Servant.FreerReq
Servant.FreerClient Servant.FreerClient
build-depends: build-depends:
base >= 4.7 && < 4.11 base >= 4.7 && < 4.11

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

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

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