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