{-# 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

-- TODO Generate this block below using TH given a and g:

type ClientMWithVCStoreError a = TypedClientM VCServerError a

-- fetchFunction :: forall a g. VCObjectHash -> ClientMWithVCStoreError (VCMeta a g (Expr (Pinned VCObjectHash) (), TCScheme))
-- fetchFunctionsForGroups :: forall a g. Set g -> ClientMWithVCStoreError [VCMeta a g VCObjectHash]
-- fetchVCObject :: forall a g. VCObjectHash -> ClientMWithVCStoreError (VCMeta a g VCObject)
-- fetchVCObjectHistory :: forall a g. VCObjectHash -> ClientMWithVCStoreError [VCMeta a g VCObjectHash]
-- fetchVCObjects :: forall a g. [VCObjectHash] -> ClientMWithVCStoreError (Map.Map VCObjectHash (VCMeta a g VCObject))
-- fetchVCObjectClosureHashes :: VCObjectHash -> ClientMWithVCStoreError [VCObjectHash]
-- pushFunction :: forall a g. VCMeta a g (Expr (Pinned VCObjectHash) (), TCScheme) -> ClientMWithVCStoreError VCObjectHash
-- deleteAutosavedFunction :: VCObjectHash -> ClientMWithVCStoreError ()
-- deleteVCObjects :: VCObjectHash -> ClientMWithVCStoreError ()
-- fetchFunction
--   :<|> fetchFunctionsForGroups
--   :<|> fetchVCObject
--   :<|> fetchVCObjectHistory
--   :<|> fetchVCObjects
--   :<|> fetchVCObjectClosureHashes
--   :<|> pushFunction
--   :<|> deleteAutosavedFunction
--   :<|> deleteVCObjects = typedClient $ client api