module Inferno.VersionControl.Client.Cached where

import Control.Monad (forM, forM_)
import Control.Monad.Error.Lens (throwing)
import Control.Monad.Except (MonadError (..))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader (MonadReader (..))
import Data.Aeson (FromJSON, ToJSON, encode)
import qualified Data.ByteString.Lazy as BL
import Data.Either (partitionEithers)
import Data.Generics.Product (HasType, getTyped)
import Data.Generics.Sum (AsType (..))
import qualified Data.Map as Map
import GHC.Generics (Generic)
import qualified Inferno.VersionControl.Client as VCClient
import Inferno.VersionControl.Log (VCServerTrace)
import qualified Inferno.VersionControl.Operations as Ops
import qualified Inferno.VersionControl.Operations.Error as Ops
import Inferno.VersionControl.Server (VCServerError)
import Inferno.VersionControl.Types
  ( VCMeta,
    VCObject,
    VCObjectHash,
    vcObjectHashToByteString,
  )
import Plow.Logging (IOTracer)
import Servant.Client (ClientEnv, ClientError)
import Servant.Typed.Error (TypedClientM, runTypedClientM)
import System.Directory (doesFileExist)
import System.FilePath.Posix ((</>))

data CachedVCClientError
  = ClientVCStoreError VCServerError
  | ClientServantError ClientError
  | LocalVCStoreError Ops.VCStoreError
  deriving (Int -> CachedVCClientError -> ShowS
[CachedVCClientError] -> ShowS
CachedVCClientError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CachedVCClientError] -> ShowS
$cshowList :: [CachedVCClientError] -> ShowS
show :: CachedVCClientError -> String
$cshow :: CachedVCClientError -> String
showsPrec :: Int -> CachedVCClientError -> ShowS
$cshowsPrec :: Int -> CachedVCClientError -> ShowS
Show, forall x. Rep CachedVCClientError x -> CachedVCClientError
forall x. CachedVCClientError -> Rep CachedVCClientError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CachedVCClientError x -> CachedVCClientError
$cfrom :: forall x. CachedVCClientError -> Rep CachedVCClientError x
Generic)

liftServantClient ::
  ( MonadError e m,
    MonadIO m,
    MonadReader s m,
    HasType ClientEnv s,
    AsType a e,
    AsType ClientError e
  ) =>
  TypedClientM a b ->
  m b
liftServantClient :: forall e (m :: * -> *) s a b.
(MonadError e m, MonadIO m, MonadReader s m, HasType ClientEnv s,
 AsType a e, AsType ClientError e) =>
TypedClientM a b -> m b
liftServantClient TypedClientM a b
m = do
  ClientEnv
client <- forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a.
TypedClientM e a
-> ClientEnv -> IO (Either (Either ClientError e) a)
runTypedClientM TypedClientM a b
m ClientEnv
client) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (Left ClientError
clientErr) -> forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing forall a s. AsType a s => Prism' s a
_Typed forall a b. (a -> b) -> a -> b
$ ClientError
clientErr
    Left (Right a
serverErr) -> forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing forall a s. AsType a s => Prism' s a
_Typed forall a b. (a -> b) -> a -> b
$ a
serverErr
    Right b
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res

fetchVCObjectClosure ::
  ( AsType VCServerError err,
    AsType ClientError err,
    AsType Ops.VCStoreError err,
    MonadError err m,
    HasType (IOTracer VCServerTrace) env,
    HasType Ops.VCStorePath env,
    HasType ClientEnv env,
    MonadReader env m,
    MonadIO m,
    FromJSON a,
    FromJSON g,
    ToJSON a,
    ToJSON g
  ) =>
  ([VCObjectHash] -> VCClient.ClientMWithVCStoreError (Map.Map VCObjectHash (VCMeta a g VCObject))) ->
  (VCObjectHash -> VCClient.ClientMWithVCStoreError [VCObjectHash]) ->
  VCObjectHash ->
  m (Map.Map VCObjectHash (VCMeta a g VCObject))
fetchVCObjectClosure :: forall err (m :: * -> *) env a g.
(AsType VCServerError err, AsType ClientError err,
 AsType VCStoreError err, MonadError err m,
 HasType (IOTracer VCServerTrace) env, HasType VCStorePath env,
 HasType ClientEnv env, MonadReader env m, MonadIO m, FromJSON a,
 FromJSON g, ToJSON a, ToJSON g) =>
([VCObjectHash]
 -> ClientMWithVCStoreError
      (Map VCObjectHash (VCMeta a g VCObject)))
-> (VCObjectHash -> ClientMWithVCStoreError [VCObjectHash])
-> VCObjectHash
-> m (Map VCObjectHash (VCMeta a g VCObject))
fetchVCObjectClosure [VCObjectHash]
-> ClientMWithVCStoreError (Map VCObjectHash (VCMeta a g VCObject))
fetchVCObjects VCObjectHash -> ClientMWithVCStoreError [VCObjectHash]
fetchVCObjectClosureHashes VCObjectHash
objHash = do
  Ops.VCStorePath String
storePath <- forall a s. HasType a s => s -> a
getTyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  [VCObjectHash]
deps <-
    (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ String
storePath String -> ShowS
</> String
"deps" String -> ShowS
</> forall a. Show a => a -> String
show VCObjectHash
objHash) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> do
        [VCObjectHash]
deps <- forall e (m :: * -> *) s a b.
(MonadError e m, MonadIO m, MonadReader s m, HasType ClientEnv s,
 AsType a e, AsType ClientError e) =>
TypedClientM a b -> m b
liftServantClient forall a b. (a -> b) -> a -> b
$ VCObjectHash -> ClientMWithVCStoreError [VCObjectHash]
fetchVCObjectClosureHashes VCObjectHash
objHash
        forall env (m :: * -> *).
VCStoreLogM env m =>
String -> ByteString -> m ()
Ops.writeBS
          (String
storePath String -> ShowS
</> String
"deps" String -> ShowS
</> forall a. Show a => a -> String
show VCObjectHash
objHash)
          forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BL.concat [ByteString -> ByteString
BL.fromStrict (VCObjectHash -> ByteString
vcObjectHashToByteString VCObjectHash
h) forall a. Semigroup a => a -> a -> a
<> ByteString
"\n" | VCObjectHash
h <- [VCObjectHash]
deps]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [VCObjectHash]
deps
      Bool
True -> forall env (m :: * -> *) err.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m) =>
VCObjectHash -> m [VCObjectHash]
Ops.fetchVCObjectClosureHashes VCObjectHash
objHash
  ([VCObjectHash]
nonLocalHashes, [VCObjectHash]
localHashes) <-
    forall a b. [Either a b] -> ([a], [b])
partitionEithers
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (VCObjectHash
objHash forall a. a -> [a] -> [a]
: [VCObjectHash]
deps) forall a b. (a -> b) -> a -> b
$ \VCObjectHash
depHash -> do
              (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ String
storePath String -> ShowS
</> forall a. Show a => a -> String
show VCObjectHash
depHash) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right VCObjectHash
depHash
                Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left VCObjectHash
depHash
          )
  Map VCObjectHash (VCMeta a g VCObject)
localObjs <-
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [VCObjectHash]
localHashes forall a b. (a -> b) -> a -> b
$ \VCObjectHash
h ->
              (VCObjectHash
h,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env (m :: * -> *) err a g.
(VCStoreLogM env m, VCStoreErrM err m, VCStoreEnvM env m,
 FromJSON a, FromJSON g) =>
VCObjectHash -> m (VCMeta a g VCObject)
Ops.fetchVCObject VCObjectHash
h
          )

  Map VCObjectHash (VCMeta a g VCObject)
nonLocalObjs <- forall e (m :: * -> *) s a b.
(MonadError e m, MonadIO m, MonadReader s m, HasType ClientEnv s,
 AsType a e, AsType ClientError e) =>
TypedClientM a b -> m b
liftServantClient forall a b. (a -> b) -> a -> b
$ [VCObjectHash]
-> ClientMWithVCStoreError (Map VCObjectHash (VCMeta a g VCObject))
fetchVCObjects [VCObjectHash]
nonLocalHashes
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map VCObjectHash (VCMeta a g VCObject)
nonLocalObjs) forall a b. (a -> b) -> a -> b
$ \(VCObjectHash
h, VCMeta a g VCObject
o) ->
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BL.writeFile (String
storePath String -> ShowS
</> forall a. Show a => a -> String
show VCObjectHash
h) forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode VCMeta a g VCObject
o
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map VCObjectHash (VCMeta a g VCObject)
localObjs forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map VCObjectHash (VCMeta a g VCObject)
nonLocalObjs