From b5410825c37dedce44dffb9e1ebe5944b9b159da Mon Sep 17 00:00:00 2001 From: voidlizard Date: Sun, 19 Jan 2025 18:22:29 +0300 Subject: [PATCH] wip --- hbs2-git3/app/GitRemoteHelper.hs | 2 +- hbs2-git3/app/Main.hs | 4 +- hbs2-git3/hbs2-git3.cabal | 11 +- hbs2-git3/lib/HBS2/Git3/Export.hs | 2 +- hbs2-git3/lib/HBS2/Git3/Git.hs | 8 +- hbs2-git3/lib/HBS2/Git3/Import.hs | 5 +- hbs2-git3/lib/HBS2/Git3/Prelude.hs | 257 +------------- hbs2-git3/lib/HBS2/Git3/Run.hs | 32 +- hbs2-git3/lib/HBS2/Git3/State.hs | 27 ++ .../HBS2/Git3/State/{ => Internal}/Index.hs | 19 +- .../lib/HBS2/Git3/State/Internal/LWWBlock.hs | 7 + .../HBS2/Git3/State/{ => Internal}/RefLog.hs | 8 +- .../HBS2/Git3/State/{ => Internal}/Segment.hs | 2 +- .../lib/HBS2/Git3/State/Internal/Types.hs | 328 ++++++++++++++++++ hbs2-git3/lib/HBS2/Git3/State/LWWBlock.hs | 7 - hbs2-git3/lib/HBS2/Git3/State/Types.hs | 29 -- 16 files changed, 434 insertions(+), 314 deletions(-) create mode 100644 hbs2-git3/lib/HBS2/Git3/State.hs rename hbs2-git3/lib/HBS2/Git3/State/{ => Internal}/Index.hs (95%) create mode 100644 hbs2-git3/lib/HBS2/Git3/State/Internal/LWWBlock.hs rename hbs2-git3/lib/HBS2/Git3/State/{ => Internal}/RefLog.hs (94%) rename hbs2-git3/lib/HBS2/Git3/State/{ => Internal}/Segment.hs (94%) create mode 100644 hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs delete mode 100644 hbs2-git3/lib/HBS2/Git3/State/LWWBlock.hs delete mode 100644 hbs2-git3/lib/HBS2/Git3/State/Types.hs diff --git a/hbs2-git3/app/GitRemoteHelper.hs b/hbs2-git3/app/GitRemoteHelper.hs index f8d694a3..5d6c54d1 100644 --- a/hbs2-git3/app/GitRemoteHelper.hs +++ b/hbs2-git3/app/GitRemoteHelper.hs @@ -6,7 +6,7 @@ import Prelude hiding (getLine) import HBS2.Git3.Prelude import HBS2.Git3.Run import HBS2.Git3.Config.Local -import HBS2.Git3.State.Index +import HBS2.Git3.State import HBS2.Git3.Import import HBS2.Git3.Export import HBS2.Git3.Git diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index f54ce68a..a177777d 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -3,6 +3,7 @@ module Main where import HBS2.Git3.Prelude import HBS2.Git3.Run +import HBS2.Git3.State import HBS2.Data.Log.Structured @@ -55,7 +56,7 @@ setupLogger = do -- setLogging @DEBUG $ toStderr . logPrefix "[debug] " setLogging @ERROR $ toStderr . logPrefix "[error] " setLogging @WARN $ toStderr . logPrefix "[warn] " - setLogging @NOTICE $ toStdout . logPrefix "" + setLogging @NOTICE $ toStderr . logPrefix "" pure () flushLoggers :: MonadIO m => m () @@ -81,6 +82,7 @@ main = flip runContT pure do cli <- parseTop (unlines $ unwords <$> splitForms argz) & either (error.show) pure + env <- nullGit3Env void $ lift $ withGit3Env env do diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal index 07eaeae0..eca1b959 100644 --- a/hbs2-git3/hbs2-git3.cabal +++ b/hbs2-git3/hbs2-git3.cabal @@ -127,12 +127,13 @@ library HBS2.Git3.Import HBS2.Git3.Repo HBS2.Git3.Run - HBS2.Git3.State.Types - HBS2.Git3.State.RefLog - HBS2.Git3.State.Index - HBS2.Git3.State.Segment + HBS2.Git3.State + HBS2.Git3.State.Internal.Types + HBS2.Git3.State.Internal.RefLog + HBS2.Git3.State.Internal.Index + HBS2.Git3.State.Internal.Segment + HBS2.Git3.State.Internal.LWWBlock HBS2.Git3.Config.Local - HBS2.Git3.State.LWWBlock HBS2.Git3.Git HBS2.Git3.Git.Pack diff --git a/hbs2-git3/lib/HBS2/Git3/Export.hs b/hbs2-git3/lib/HBS2/Git3/Export.hs index 42fd2188..4a132f53 100644 --- a/hbs2-git3/lib/HBS2/Git3/Export.hs +++ b/hbs2-git3/lib/HBS2/Git3/Export.hs @@ -4,7 +4,7 @@ module HBS2.Git3.Export (exportEntries,export) where import HBS2.Git3.Prelude -import HBS2.Git3.State.Index +import HBS2.Git3.State import HBS2.Git3.Git import HBS2.Data.Detect diff --git a/hbs2-git3/lib/HBS2/Git3/Git.hs b/hbs2-git3/lib/HBS2/Git3/Git.hs index ddb78282..d3d1a0a0 100644 --- a/hbs2-git3/lib/HBS2/Git3/Git.hs +++ b/hbs2-git3/lib/HBS2/Git3/Git.hs @@ -8,6 +8,7 @@ import HBS2.Git3.Prelude import HBS2.OrDie import HBS2.Git3.Types +import HBS2.Git3.State.Internal.Types import HBS2.Git.Local import HBS2.Git.Local.CLI @@ -39,13 +40,6 @@ import UnliftIO {-HLINT Ignore "Functor law"-} -pattern GitHashLike:: forall {c} . GitHash -> Syntax c -pattern GitHashLike x <- ( - \case - StringLike s -> fromStringMay @GitHash s - LitIntVal 0 -> Just $ GitHash (BS.replicate 20 0) - _ -> Nothing - -> Just x ) data GitException = CompressionError String diff --git a/hbs2-git3/lib/HBS2/Git3/Import.hs b/hbs2-git3/lib/HBS2/Git3/Import.hs index 4a0ebe18..84996feb 100644 --- a/hbs2-git3/lib/HBS2/Git3/Import.hs +++ b/hbs2-git3/lib/HBS2/Git3/Import.hs @@ -3,11 +3,9 @@ module HBS2.Git3.Import where import HBS2.Git3.Prelude -import HBS2.Git3.State.Index +import HBS2.Git3.State import HBS2.Git3.Git import HBS2.Git3.Git.Pack -import HBS2.Git3.State.RefLog -import HBS2.Git3.State.Segment import HBS2.Storage.Operations.Missed import HBS2.CLI.Run.Internal.Merkle (getTreeContents) @@ -111,6 +109,7 @@ importGitRefLog :: forall m . ( HBS2GitPerks m , HasStorage m , HasClientAPI PeerAPI UNIX m , HasClientAPI RefLogAPI UNIX m + , HasGitRemoteKey m , MonadReader Git3Env m ) => m () diff --git a/hbs2-git3/lib/HBS2/Git3/Prelude.hs b/hbs2-git3/lib/HBS2/Git3/Prelude.hs index 742e5a30..664d0320 100644 --- a/hbs2-git3/lib/HBS2/Git3/Prelude.hs +++ b/hbs2-git3/lib/HBS2/Git3/Prelude.hs @@ -12,6 +12,8 @@ module HBS2.Git3.Prelude , module Codec.Serialise , runExceptT , pattern SignPubKeyLike + , pattern GitHashLike + , maxCLevel ) where import HBS2.Prelude.Plated as Exported @@ -31,26 +33,26 @@ import HBS2.Peer.RPC.API.Storage as Exported import HBS2.Peer.RPC.Client hiding (encode,decode) import HBS2.Peer.RPC.Client.Unix hiding (encode,decode) import HBS2.Peer.RPC.Client.StorageClient -import HBS2.Peer.CLI.Detect import HBS2.Data.Types.SignedBox as Exported import HBS2.Storage as Exported import HBS2.Storage.Operations.Class as Exported import HBS2.System.Logger.Simple.ANSI as Exported import HBS2.Git3.Types as Exported -import HBS2.Git3.State.Types as Exported +-- import HBS2.Git3.State.Types as Exported import HBS2.System.Dir +import Data.Config.Suckless.Syntax + import Codec.Compression.Zstd (maxCLevel) import Codec.Serialise import Control.Monad.Except (runExceptT) import Control.Monad.Reader as Exported import Control.Monad.Trans.Cont as Exported import Control.Monad.Trans.Maybe as Exported +import Data.ByteString qualified as BS import Data.Coerce as Exported -import Data.HashSet (HashSet) -import Data.HashSet qualified as HS import Data.HashPSQ qualified as HPSQ import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM @@ -63,241 +65,6 @@ import System.FilePattern as Exported import GHC.Natural as Exported import UnliftIO as Exported -data RefLogNotSetException = - RefLogNotSetException - deriving stock (Show,Typeable) - -instance Exception RefLogNotSetException - -defSegmentSize :: Int -defSegmentSize = 50 * 1024 * 1024 - -defCompressionLevel :: Int -defCompressionLevel = maxCLevel - -defIndexBlockSize :: Natural -defIndexBlockSize = 32 * 1024 * 1024 - -type HBS2GitPerks m = (MonadUnliftIO m) - - -quit :: MonadUnliftIO m => m () -quit = liftIO Q.exitSuccess - - -class GitWritePacksOpts a where - excludeParents :: a -> Bool - -instance GitWritePacksOpts () where - excludeParents = const True - -data GitWritePacksOptVal = - WriteFullPack - deriving stock (Eq,Ord,Show,Generic) - -instance Hashable GitWritePacksOptVal - -instance GitWritePacksOpts (HashSet GitWritePacksOptVal) where - excludeParents o = not $ HS.member WriteFullPack o - -data Git3Exception = - Git3PeerNotConnected - | Git3ReflogNotSet - | Git3RpcTimeout - deriving (Show,Typeable,Generic) - -instance Exception Git3Exception - -data Git3Env = - Git3Disconnected - { gitRefLog :: TVar (Maybe GitRemoteKey) - , gitPackedSegmentSize :: TVar Int - , gitCompressionLevel :: TVar Int - , gitIndexBlockSize :: TVar Natural - } - | Git3Connected - { peerSocket :: FilePath - , peerStorage :: AnyStorage - , peerAPI :: ServiceCaller PeerAPI UNIX - , reflogAPI :: ServiceCaller RefLogAPI UNIX - , lwwAPI :: ServiceCaller LWWRefAPI UNIX - , gitRefLog :: TVar (Maybe GitRemoteKey) - , gitRepoKey :: TVar (Maybe GitRepoKey) - , gitPackedSegmentSize :: TVar Int - , gitCompressionLevel :: TVar Int - , gitIndexBlockSize :: TVar Natural - } - -class HasExportOpts m where - setPackedSegmedSize :: Int -> m () - getPackedSegmetSize :: m Int - getCompressionLevel :: m Int - setCompressionLevel :: Int -> m () - -class HasGitRemoteKey m where - getGitRemoteKey :: m (Maybe GitRemoteKey) - setGitRemoteKey :: GitRemoteKey -> m () - getGitRepoKey :: m (Maybe GitRepoKey) - setGitRepoKey :: GitRepoKey -> m () - -instance (MonadIO m, MonadReader Git3Env m) => HasGitRemoteKey m where - getGitRemoteKey = do - e <- ask - liftIO $ readTVarIO (gitRefLog e) - - setGitRemoteKey k = do - e <- ask - liftIO $ atomically $ writeTVar (gitRefLog e) (Just k) - - getGitRepoKey = do - e <- ask - liftIO $ readTVarIO (gitRepoKey e) - - setGitRepoKey k = do - e <- ask - liftIO $ atomically $ writeTVar (gitRepoKey e) (Just k) - -instance (MonadIO m, MonadReader Git3Env m) => HasExportOpts m where - getPackedSegmetSize = asks gitPackedSegmentSize >>= readTVarIO - setPackedSegmedSize x = do - e <- asks gitPackedSegmentSize - atomically $ writeTVar e x - - getCompressionLevel = asks gitCompressionLevel >>= readTVarIO - setCompressionLevel x = do - e <- asks gitCompressionLevel - atomically $ writeTVar e (min maxCLevel x) - -instance (MonadIO m, MonadReader Git3Env m) => HasStorage m where - getStorage = do - e <- ask - case e of - Git3Disconnected{} -> throwIO Git3PeerNotConnected - Git3Connected{..} -> pure peerStorage - -class MonadIO m => HasIndexOptions m where - getIndexBlockSize :: m Natural - setIndexBlockSize :: Natural -> m () - -instance (MonadIO m, MonadReader Git3Env m) => HasIndexOptions m where - getIndexBlockSize = asks gitIndexBlockSize >>= readTVarIO - - setIndexBlockSize n = do - e <- asks gitIndexBlockSize - atomically $ writeTVar e n - -newtype Git3 (m :: Type -> Type) a = Git3M { fromGit3 :: ReaderT Git3Env m a } - deriving newtype ( Applicative - , Functor - , Monad - , MonadIO - , MonadUnliftIO - , MonadReader Git3Env - , MonadTrans - ) - -type Git3Perks m = ( MonadIO m - , MonadUnliftIO m - ) - - -instance MonadUnliftIO m => HasClientAPI PeerAPI UNIX (Git3 m) where - getClientAPI = do - ask >>= \case - Git3Disconnected{} -> throwIO Git3PeerNotConnected - Git3Connected{..} -> pure peerAPI - -instance (MonadUnliftIO m) => HasClientAPI RefLogAPI UNIX (Git3 m) where - getClientAPI = do - ask >>= \case - Git3Disconnected{} -> throwIO Git3PeerNotConnected - Git3Connected{..} -> pure reflogAPI - - -instance (MonadUnliftIO m) => HasClientAPI LWWRefAPI UNIX (Git3 m) where - getClientAPI = do - ask >>= \case - Git3Disconnected{} -> throwIO Git3PeerNotConnected - Git3Connected{..} -> pure lwwAPI - -nullGit3Env :: MonadIO m => m Git3Env -nullGit3Env = Git3Disconnected - <$> newTVarIO Nothing - <*> newTVarIO defSegmentSize - <*> newTVarIO defCompressionLevel - <*> newTVarIO defIndexBlockSize - -connectedDo :: (MonadIO m) => Git3 m a -> Git3 m a -connectedDo what = do - env <- ask - debug $ red "connectedDo" - case env of - Git3Disconnected{} -> do - throwIO Git3PeerNotConnected - - _ -> what - -withGit3Env :: Git3Perks m => Git3Env -> Git3 m a -> m a -withGit3Env env a = runReaderT (fromGit3 a) env - -runGit3 :: Git3Perks m => Git3Env -> Git3 m b -> m b -runGit3 env action = withGit3Env env action - - -getStatePathM :: forall m . (HBS2GitPerks m, HasGitRemoteKey m) => m FilePath -getStatePathM = do - k <- getGitRemoteKey >>= orThrow RefLogNotSetException - getStatePath (AsBase58 k) - - -recover :: Git3 IO a -> Git3 IO a -recover m = fix \again -> do - catch m $ \case - Git3PeerNotConnected -> do - - soname <- detectRPC - `orDie` "can't locate hbs2-peer rpc" - - flip runContT pure do - - client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname) - >>= orThrowUser ("can't connect to" <+> pretty soname) - - void $ ContT $ withAsync $ runMessagingUnix client - - peerAPI <- makeServiceCaller @PeerAPI (fromString soname) - refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname) - storageAPI <- makeServiceCaller @StorageAPI (fromString soname) - lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname) - - -- let sto = AnyStorage (StorageClient storageAPI) - - let endpoints = [ Endpoint @UNIX peerAPI - , Endpoint @UNIX refLogAPI - , Endpoint @UNIX lwwAPI - , Endpoint @UNIX storageAPI - ] - - void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client - - ref <- getGitRemoteKey >>= orThrowUser "remote ref not set" - - state <- getStatePath (AsBase58 ref) - - mkdir state - - let sto = AnyStorage (StorageClient storageAPI) - - connected <- Git3Connected soname sto peerAPI refLogAPI lwwAPI - <$> newTVarIO (Just ref) - <*> newTVarIO Nothing - <*> newTVarIO defSegmentSize - <*> newTVarIO defCompressionLevel - <*> newTVarIO defIndexBlockSize - - liftIO $ withGit3Env connected again - - e -> throwIO e class Cached cache k v | cache -> k, cache -> v where @@ -354,3 +121,15 @@ instance (Ord k, Hashable k) => Cached (CacheFixedHPSQ k v) k v where pure v +quit :: MonadUnliftIO m => m () +quit = liftIO Q.exitSuccess + + +pattern GitHashLike:: forall {c} . GitHash -> Syntax c +pattern GitHashLike x <- ( + \case + StringLike s -> fromStringMay @GitHash s + LitIntVal 0 -> Just $ GitHash (BS.replicate 20 0) + _ -> Nothing + -> Just x ) + diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index 0d35abdf..fc3888a2 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/hbs2-git3/lib/HBS2/Git3/Run.hs @@ -1,7 +1,6 @@ module HBS2.Git3.Run where import HBS2.Git3.Prelude -import HBS2.Git3.State.Index import HBS2.Git3.Git.Pack import HBS2.Peer.CLI.Detect @@ -23,7 +22,7 @@ import HBS2.Git3.Config.Local import HBS2.Git3.Git import HBS2.Git3.Export import HBS2.Git3.Import -import HBS2.Git3.State.RefLog +import HBS2.Git3.State import HBS2.Git3.Repo qualified as Repo import Data.Config.Suckless.Script @@ -144,13 +143,6 @@ theDict = do <+> pretty gitEntrySize <+> pretty gitEntryName - entry $ bindMatch "reflog" $ nil_ $ \case - [ SignPubKeyLike what ] -> do - debug $ "set reflog" <+> pretty (AsBase58 what) - lift $ setGitRemoteKey what - - _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "debug" $ nil_ $ const do setLogging @DEBUG $ toStderr . logPrefix "[debug] " @@ -569,7 +561,6 @@ theDict = do rrefs <- importedRefs liftIO $ print $ pretty rrefs - entry $ bindMatch "reflog:imported" $ nil_ $ \syn -> lift $ connectedDo do p <- importedCheckpoint liftIO $ print $ pretty p @@ -577,13 +568,32 @@ theDict = do entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do importGitRefLog + entry $ bindMatch "repo:manifest:show" $ nil_ $ const $ lift $ connectedDo do + manifest <- Repo.getRepoManifest + liftIO $ print $ pretty $ mkForm "manifest" manifest + + entry $ bindMatch "repo:reflog:show" $ nil_ $ const $ lift $ connectedDo do + repo <- Repo.getRepoManifest + + reflog <- [ x | x@(ListVal [SymbolVal "reflog", SignPubKeyLike _]) <- repo ] + & headMay & orThrow GitRepoManifestMalformed + + liftIO $ print $ pretty reflog + + entry $ bindMatch "repo:key:show" $ nil_ $ const $ lift do + r <- getGitRepoKey >>= orThrow GitRepoRefNotSet + liftIO $ print $ pretty (AsBase58 r) entry $ bindMatch "repo:key" $ nil_ $ \case - [ SignPubKeyLike k ] -> lift $ connectedDo do + [ SignPubKeyLike k ] -> lift do setGitRepoKey k _ -> throwIO (BadFormException @C nil) + entry $ bindMatch "repo:ref:value"$ nil_ $ const $ lift $ connectedDo do + val <- Repo.getRepoRefMaybe >>= orThrowUser "can't read ref value" + liftIO $ print $ pretty val + entry $ bindMatch "repo:init" $ nil_ $ \syn -> lift $ connectedDo do Repo.initRepo syn -- conf <- getConfigRootFile diff --git a/hbs2-git3/lib/HBS2/Git3/State.hs b/hbs2-git3/lib/HBS2/Git3/State.hs new file mode 100644 index 00000000..88a4fac9 --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/State.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module HBS2.Git3.State + ( module HBS2.Git3.State + , module Exported + ) where + +import HBS2.Git3.Prelude + +import HBS2.Git3.State.Internal.Types as Exported +import HBS2.Git3.State.Internal.LWWBlock as Exported +import HBS2.Git3.State.Internal.RefLog as Exported +import HBS2.Git3.State.Internal.Segment as Exported +import HBS2.Git3.State.Internal.Index as Exported + +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.Client.StorageClient +import HBS2.System.Dir +import HBS2.Peer.CLI.Detect + +import Data.HashSet (HashSet) +import Data.HashSet qualified as HS +import Data.Kind + +import Codec.Compression.Zstd (maxCLevel) + diff --git a/hbs2-git3/lib/HBS2/Git3/State/Index.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs similarity index 95% rename from hbs2-git3/lib/HBS2/Git3/State/Index.hs rename to hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs index e39fd22b..d6d3e1ab 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Index.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs @@ -1,11 +1,12 @@ -module HBS2.Git3.State.Index where +module HBS2.Git3.State.Internal.Index where import HBS2.Git3.Prelude import HBS2.System.Dir import HBS2.CLI.Run.Internal.Merkle (getTreeContents) -import HBS2.Git3.State.Types -import HBS2.Git3.State.Segment -import HBS2.Git3.State.RefLog + +import HBS2.Git3.State.Internal.Types +import HBS2.Git3.State.Internal.Segment +import HBS2.Git3.State.Internal.RefLog import HBS2.Git3.Git import HBS2.Data.Log.Structured @@ -66,6 +67,7 @@ readLogFileLBS _ action = flip fix 0 \go n -> do indexPath :: forall m . ( Git3Perks m , MonadReader Git3Env m + , HasGitRemoteKey m ) => m FilePath indexPath = do reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet @@ -121,7 +123,7 @@ mergeSortedFilesN getKey inputFiles outFile = do mkState [] = Nothing mkState (x:xs) = Just (Entry (getKey x) (x:xs)) -compactIndex :: forall m . (Git3Perks m, MonadReader Git3Env m) => Natural -> m () +compactIndex :: forall m . (Git3Perks m, HasGitRemoteKey m, MonadReader Git3Env m) => Natural -> m () compactIndex maxSize = do reflog <- getGitRemoteKey >>= orThrowUser "reflog not set" idxPath <- getStatePath (AsBase58 reflog) @@ -139,7 +141,7 @@ compactIndex maxSize = do out <- liftIO $ emptyTempFile idxPath "objects-.idx" mergeSortedFilesN (BS.take 20) (map fst block) out -openIndex :: forall a m . (Git3Perks m, MonadReader Git3Env m) +openIndex :: forall a m . (Git3Perks m, HasGitRemoteKey m, MonadReader Git3Env m) => m (Index a) openIndex = do @@ -207,6 +209,7 @@ indexFilterNewObjectsMem idx@Index{..} hashes = do listObjectIndexFiles :: forall m . ( Git3Perks m , MonadReader Git3Env m + , HasGitRemoteKey m ) => m [(FilePath, Natural)] listObjectIndexFiles = do @@ -273,6 +276,7 @@ updateReflogIndex :: forall m . ( Git3Perks m , HasClientAPI PeerAPI UNIX m , HasClientAPI RefLogAPI UNIX m , HasStorage m + , HasGitRemoteKey m , HasIndexOptions m ) => m () updateReflogIndex = do @@ -386,6 +390,7 @@ importedCheckpoint :: forall m . ( Git3Perks m , MonadReader Git3Env m , HasClientAPI RefLogAPI UNIX m , HasStorage m + , HasGitRemoteKey m ) => m (Maybe HashRef) importedCheckpoint = do @@ -406,6 +411,7 @@ importedRefs :: forall m . ( Git3Perks m , MonadReader Git3Env m , HasClientAPI RefLogAPI UNIX m , HasStorage m + , HasGitRemoteKey m ) => m [(GitRef, GitHash)] importedRefs = do @@ -441,6 +447,7 @@ updateImportedCheckpoint :: forall m . ( Git3Perks m , MonadReader Git3Env m , HasClientAPI RefLogAPI UNIX m , HasStorage m + , HasGitRemoteKey m ) => HashRef -> m () updateImportedCheckpoint cp = do diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/LWWBlock.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/LWWBlock.hs new file mode 100644 index 00000000..a9c891e7 --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/LWWBlock.hs @@ -0,0 +1,7 @@ +module HBS2.Git3.State.Internal.LWWBlock where + +import HBS2.Git3.Prelude + + + + diff --git a/hbs2-git3/lib/HBS2/Git3/State/RefLog.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/RefLog.hs similarity index 94% rename from hbs2-git3/lib/HBS2/Git3/State/RefLog.hs rename to hbs2-git3/lib/HBS2/Git3/State/Internal/RefLog.hs index e746fcd1..7be46729 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/RefLog.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/RefLog.hs @@ -1,7 +1,9 @@ -module HBS2.Git3.State.RefLog where +module HBS2.Git3.State.Internal.RefLog where import HBS2.Git3.Prelude +import HBS2.Git3.State.Internal.Types + import Control.Applicative import Data.ByteString.Lazy qualified as LBS import Data.Maybe @@ -55,10 +57,10 @@ refLogRef :: forall m . ( HBS2GitPerks m refLogRef = do refLogAPI <- getClientAPI @RefLogAPI @UNIX - reflog <- getGitRemoteKey >>= orThrow RefLogNotSetException + reflog <- getGitRemoteKey >>= orThrow RefLogNotSet callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) refLogAPI reflog - >>= orThrow RefLogNotSetException + >>= orThrow RefLogNotSet txList :: forall m . ( HBS2GitPerks m , HasStorage m diff --git a/hbs2-git3/lib/HBS2/Git3/State/Segment.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Segment.hs similarity index 94% rename from hbs2-git3/lib/HBS2/Git3/State/Segment.hs rename to hbs2-git3/lib/HBS2/Git3/State/Internal/Segment.hs index 2be18c63..37482fb3 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Segment.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Segment.hs @@ -1,4 +1,4 @@ -module HBS2.Git3.State.Segment where +module HBS2.Git3.State.Internal.Segment where import HBS2.Git3.Prelude import Data.ByteString.Lazy ( ByteString ) diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs new file mode 100644 index 00000000..18bb7e9f --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs @@ -0,0 +1,328 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} +module HBS2.Git3.State.Internal.Types + ( module HBS2.Git3.State.Internal.Types + , pattern SignPubKeyLike + ) where + + +import HBS2.Git3.Prelude +import HBS2.Git3.Config.Local +import HBS2.Net.Auth.Credentials +import HBS2.System.Dir +import HBS2.Data.Detect (readLogThrow) +import HBS2.CLI.Run.MetaData (getTreeContents) + +import Data.Config.Suckless + +import HBS2.Defaults as Exported +import HBS2.OrDie as Exported +import HBS2.Data.Types.Refs as Exported +import HBS2.Base58 as Exported +import HBS2.Merkle as Exported +import HBS2.Misc.PrettyStuff as Exported +import HBS2.Net.Auth.Credentials +import HBS2.Peer.Proto.LWWRef as Exported +import HBS2.Peer.Proto.RefLog as Exported +import HBS2.Peer.RPC.API.RefLog as Exported +import HBS2.Peer.RPC.API.Peer as Exported +import HBS2.Peer.RPC.API.LWWRef as Exported +import HBS2.Peer.RPC.API.Storage as Exported +import HBS2.Peer.RPC.Client hiding (encode,decode) +import HBS2.Peer.RPC.Client.Unix hiding (encode,decode) +import HBS2.Peer.RPC.Client.StorageClient +import HBS2.Peer.CLI.Detect (detectRPC) +import HBS2.Data.Types.SignedBox as Exported +import HBS2.Storage as Exported +import HBS2.Storage.Operations.Class as Exported +import HBS2.System.Logger.Simple.ANSI as Exported + +import Data.Text.Encoding qualified as TE +import Data.Text.Encoding.Error qualified as TE +import Data.ByteString.Lazy qualified as LBS + +import Data.Kind +import Data.HashSet (HashSet) +import Data.HashSet qualified as HS + +import System.FilePath + +unit :: FilePath +unit = "hbs2-git" + +getStatePath :: (MonadIO m, Pretty ref) => ref -> m FilePath +getStatePath p = do + d <- getConfigPath + pure $ d show (pretty p) + +data HBS2GitExcepion = + RefLogNotSet + | GitRepoRefNotSet + | GitRepoRefEmpty + | GitRepoManifestMalformed + | RpcTimeout + deriving stock (Show,Typeable) + +instance Exception HBS2GitExcepion + +defSegmentSize :: Int +defSegmentSize = 50 * 1024 * 1024 + +defCompressionLevel :: Int +defCompressionLevel = maxCLevel + +defIndexBlockSize :: Natural +defIndexBlockSize = 32 * 1024 * 1024 + +type HBS2GitPerks m = (MonadUnliftIO m) + + +class GitWritePacksOpts a where + excludeParents :: a -> Bool + +instance GitWritePacksOpts () where + excludeParents = const True + +data GitWritePacksOptVal = + WriteFullPack + deriving stock (Eq,Ord,Show,Generic) + +instance Hashable GitWritePacksOptVal + +instance GitWritePacksOpts (HashSet GitWritePacksOptVal) where + excludeParents o = not $ HS.member WriteFullPack o + +data Git3Exception = + Git3PeerNotConnected + | Git3ReflogNotSet + | Git3RpcTimeout + deriving (Show,Typeable,Generic) + +instance Exception Git3Exception + +data Git3Env = + Git3Disconnected + { gitPackedSegmentSize :: TVar Int + , gitCompressionLevel :: TVar Int + , gitIndexBlockSize :: TVar Natural + , gitRepoKey :: TVar (Maybe GitRepoKey) + } + | Git3Connected + { peerSocket :: FilePath + , peerStorage :: AnyStorage + , peerAPI :: ServiceCaller PeerAPI UNIX + , reflogAPI :: ServiceCaller RefLogAPI UNIX + , lwwAPI :: ServiceCaller LWWRefAPI UNIX + , gitRepoKey :: TVar (Maybe GitRepoKey) + , gitRefLog :: TVar (Maybe GitRemoteKey) + , gitPackedSegmentSize :: TVar Int + , gitCompressionLevel :: TVar Int + , gitIndexBlockSize :: TVar Natural + } + +class HasExportOpts m where + setPackedSegmedSize :: Int -> m () + getPackedSegmetSize :: m Int + getCompressionLevel :: m Int + setCompressionLevel :: Int -> m () + + +instance (MonadIO m, MonadReader Git3Env m) => HasExportOpts m where + getPackedSegmetSize = asks gitPackedSegmentSize >>= readTVarIO + setPackedSegmedSize x = do + e <- asks gitPackedSegmentSize + atomically $ writeTVar e x + + getCompressionLevel = asks gitCompressionLevel >>= readTVarIO + setCompressionLevel x = do + e <- asks gitCompressionLevel + atomically $ writeTVar e (min maxCLevel x) + +instance (MonadIO m, MonadReader Git3Env m) => HasStorage m where + getStorage = do + e <- ask + case e of + Git3Disconnected{} -> throwIO Git3PeerNotConnected + Git3Connected{..} -> pure peerStorage + +class MonadIO m => HasIndexOptions m where + getIndexBlockSize :: m Natural + setIndexBlockSize :: Natural -> m () + +instance (MonadIO m, MonadReader Git3Env m) => HasIndexOptions m where + getIndexBlockSize = asks gitIndexBlockSize >>= readTVarIO + + setIndexBlockSize n = do + e <- asks gitIndexBlockSize + atomically $ writeTVar e n + +class HasGitRemoteKey m where + getGitRemoteKey :: m (Maybe GitRemoteKey) + getGitRepoKey :: m (Maybe GitRepoKey) + setGitRepoKey :: GitRepoKey -> m () + +instance (MonadIO m) => HasGitRemoteKey (Git3 m) where + getGitRemoteKey = + ask >>= \case + Git3Connected{..} -> readTVarIO gitRefLog + _ -> pure Nothing + + getGitRepoKey = do + e <- ask + liftIO $ readTVarIO (gitRepoKey e) + + setGitRepoKey k = do + e <- ask + liftIO $ atomically $ writeTVar (gitRepoKey e) (Just k) + +getStatePathM :: forall m . (HBS2GitPerks m, HasGitRemoteKey m) => m FilePath +getStatePathM = do + k <- getGitRemoteKey >>= orThrow RefLogNotSet + getStatePath (AsBase58 k) + +getRepoRefMaybe :: forall m . HBS2GitPerks m => Git3 m (Maybe (LWWRef 'HBS2Basic)) +getRepoRefMaybe = do + lwwAPI <- getClientAPI @LWWRefAPI @UNIX + + pk <- getGitRepoKey >>= orThrow GitRepoRefNotSet + + callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (LWWRefKey pk) + >>= orThrow RpcTimeout + +getRepoManifest :: forall m . HBS2GitPerks m => Git3 m [Syntax C] +getRepoManifest = do + + sto <- getStorage + + LWWRef{..} <- getRepoRefMaybe >>= orThrow GitRepoRefEmpty + + mfref <- readLogThrow (getBlock sto) lwwValue + <&> headMay + >>= orThrow GitRepoManifestMalformed + + runExceptT (getTreeContents sto mfref) + >>= orThrowPassIO + <&> TE.decodeUtf8With TE.lenientDecode . LBS.toStrict + <&> parseTop + >>= orThrow GitRepoManifestMalformed + +newtype Git3 (m :: Type -> Type) a = Git3M { fromGit3 :: ReaderT Git3Env m a } + deriving newtype ( Applicative + , Functor + , Monad + , MonadIO + , MonadUnliftIO + , MonadReader Git3Env + , MonadTrans + ) + +type Git3Perks m = ( MonadIO m + , MonadUnliftIO m + ) + + +instance MonadUnliftIO m => HasClientAPI PeerAPI UNIX (Git3 m) where + getClientAPI = do + ask >>= \case + Git3Disconnected{} -> throwIO Git3PeerNotConnected + Git3Connected{..} -> pure peerAPI + +instance (MonadUnliftIO m) => HasClientAPI RefLogAPI UNIX (Git3 m) where + getClientAPI = do + ask >>= \case + Git3Disconnected{} -> throwIO Git3PeerNotConnected + Git3Connected{..} -> pure reflogAPI + + +instance (MonadUnliftIO m) => HasClientAPI LWWRefAPI UNIX (Git3 m) where + getClientAPI = do + ask >>= \case + Git3Disconnected{} -> throwIO Git3PeerNotConnected + Git3Connected{..} -> pure lwwAPI + +nullGit3Env :: MonadIO m => m Git3Env +nullGit3Env = Git3Disconnected + <$> newTVarIO defSegmentSize + <*> newTVarIO defCompressionLevel + <*> newTVarIO defIndexBlockSize + <*> newTVarIO Nothing + +connectedDo :: (MonadIO m) => Git3 m a -> Git3 m a +connectedDo what = do + env <- ask + debug $ red "connectedDo" + case env of + Git3Disconnected{} -> do + throwIO Git3PeerNotConnected + + _ -> what + +withGit3Env :: Git3Perks m => Git3Env -> Git3 m a -> m a +withGit3Env env a = runReaderT (fromGit3 a) env + +runGit3 :: Git3Perks m => Git3Env -> Git3 m b -> m b +runGit3 env action = withGit3Env env action + + +recover :: Git3 IO a -> Git3 IO a +recover m = fix \again -> do + catch m $ \case + Git3PeerNotConnected -> do + + soname <- detectRPC + `orDie` "can't locate hbs2-peer rpc" + + flip runContT pure do + + client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname) + >>= orThrowUser ("can't connect to" <+> pretty soname) + + void $ ContT $ withAsync $ runMessagingUnix client + + peer <- makeServiceCaller @PeerAPI (fromString soname) + refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname) + storageAPI <- makeServiceCaller @StorageAPI (fromString soname) + lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname) + + -- let sto = AnyStorage (StorageClient storageAPI) + + let endpoints = [ Endpoint @UNIX peer + , Endpoint @UNIX refLogAPI + , Endpoint @UNIX lwwAPI + , Endpoint @UNIX storageAPI + ] + + void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client + + let sto = AnyStorage (StorageClient storageAPI) + + rk <- lift getGitRepoKey + + connected <- Git3Connected soname sto peer refLogAPI lwwAPI + <$> newTVarIO rk + <*> newTVarIO Nothing + <*> newTVarIO defSegmentSize + <*> newTVarIO defCompressionLevel + <*> newTVarIO defIndexBlockSize + + liftIO $ withGit3Env connected do + + mf <- getRepoManifest + + let reflog = lastMay [ x + | ListVal [SymbolVal "reflog", SignPubKeyLike x] <- mf + ] + + ask >>= \case + Git3Connected{..} -> atomically $ writeTVar gitRefLog reflog + _ -> none + + ref <- getGitRemoteKey >>= orThrow GitRepoManifestMalformed + + state <- getStatePath (AsBase58 ref) + mkdir state + + again + + e -> throwIO e + diff --git a/hbs2-git3/lib/HBS2/Git3/State/LWWBlock.hs b/hbs2-git3/lib/HBS2/Git3/State/LWWBlock.hs deleted file mode 100644 index e0524cbb..00000000 --- a/hbs2-git3/lib/HBS2/Git3/State/LWWBlock.hs +++ /dev/null @@ -1,7 +0,0 @@ -module HBS2.Git3.State.LWWBlock where - -import HBS2.Git3.Prelude - - - - diff --git a/hbs2-git3/lib/HBS2/Git3/State/Types.hs b/hbs2-git3/lib/HBS2/Git3/State/Types.hs deleted file mode 100644 index 75708231..00000000 --- a/hbs2-git3/lib/HBS2/Git3/State/Types.hs +++ /dev/null @@ -1,29 +0,0 @@ -module HBS2.Git3.State.Types - ( module HBS2.Git3.State.Types - , pattern SignPubKeyLike - ) where - - -import HBS2.Prelude.Plated -import HBS2.Git3.Config.Local -import HBS2.Net.Auth.Credentials - -import DBPipe.SQLite - -import System.FilePath - -type DBRef w = ( Pretty w ) - -class MonadIO m => HasStateDB m where - getStateDB :: m DBPipeEnv - - -unit :: FilePath -unit = "hbs2-git" - -getStatePath :: (MonadIO m, DBRef db) => db -> m FilePath -getStatePath p = do - d <- getConfigPath - pure $ d show (pretty p) - -