{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Inferno.VersionControl.Client where
import Codec.Compression.GZip (compress)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.ByteString.Lazy as BSL
import Data.Proxy (Proxy (..))
import Inferno.VersionControl.Server (VCServerError, VersionControlAPI)
import Network.HTTP.Client (Request (..), RequestBody (..))
import Network.HTTP.Client.Internal (Manager (..))
import Network.HTTP.Types.Header (hContentEncoding)
import Servant.Client (BaseUrl, Client, ClientEnv, ClientM, client, mkClientEnv)
import Servant.Typed.Error (TypedClientM)
mkVCClientEnv :: Manager -> BaseUrl -> ClientEnv
mkVCClientEnv :: Manager -> BaseUrl -> ClientEnv
mkVCClientEnv man :: Manager
man@Manager {mModifyRequest :: Manager -> Request -> IO Request
mModifyRequest = Request -> IO Request
modReq} BaseUrl
baseUrl =
Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
man {mModifyRequest :: Request -> IO Request
mModifyRequest = Request -> IO Request
modReq'} BaseUrl
baseUrl
where
modReq' :: Request -> IO Request
modReq' :: Request -> IO Request
modReq' Request
r = do
Request
x <- Request -> IO Request
modReq Request
r
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
if ((HeaderName
hContentEncoding, ByteString
"gzip") forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Request -> RequestHeaders
requestHeaders Request
x)
then Request
x
else
let new_hdrs :: RequestHeaders
new_hdrs = (HeaderName
hContentEncoding, ByteString
"gzip") forall a. a -> [a] -> [a]
: Request -> RequestHeaders
requestHeaders Request
x
(RequestHeaders
hrds, RequestBody
body) = case Request -> RequestBody
requestBody Request
x of
RequestBodyBuilder Int64
_ Builder
_ -> (Request -> RequestHeaders
requestHeaders Request
x, Request -> RequestBody
requestBody Request
x)
RequestBodyStream Int64
_ GivesPopper ()
_ -> (Request -> RequestHeaders
requestHeaders Request
x, Request -> RequestBody
requestBody Request
x)
RequestBodyStreamChunked GivesPopper ()
_ -> (Request -> RequestHeaders
requestHeaders Request
x, Request -> RequestBody
requestBody Request
x)
RequestBody
b -> (RequestHeaders
new_hdrs, RequestBody -> RequestBody
compressBody RequestBody
b)
in Request
x {requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
hrds, requestBody :: RequestBody
requestBody = RequestBody
body}
compressBody :: RequestBody -> RequestBody
compressBody :: RequestBody -> RequestBody
compressBody = \case
RequestBodyLBS ByteString
bsl -> ByteString -> RequestBody
RequestBodyLBS forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
compress ByteString
bsl
RequestBodyBS ByteString
bs -> ByteString -> RequestBody
RequestBodyLBS forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
compress forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict ByteString
bs
RequestBodyIO IO RequestBody
iob -> IO RequestBody -> RequestBody
RequestBodyIO forall a b. (a -> b) -> a -> b
$ RequestBody -> RequestBody
compressBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO RequestBody
iob
RequestBody
b -> RequestBody
b
api :: Proxy (VersionControlAPI a g)
api :: forall a g. Proxy (VersionControlAPI a g)
api = forall {k} (t :: k). Proxy t
Proxy
infernoVcClient :: (FromJSON a, FromJSON g, ToJSON a, ToJSON g) => Client ClientM (VersionControlAPI a g)
infernoVcClient :: forall a g.
(FromJSON a, FromJSON g, ToJSON a, ToJSON g) =>
Client ClientM (VersionControlAPI a g)
infernoVcClient = forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client forall a g. Proxy (VersionControlAPI a g)
api
type ClientMWithVCStoreError a = TypedClientM VCServerError a