diff --git a/hbs2-git3/app/GitRemoteHelper.hs b/hbs2-git3/app/GitRemoteHelper.hs index 4f256642..59db3456 100644 --- a/hbs2-git3/app/GitRemoteHelper.hs +++ b/hbs2-git3/app/GitRemoteHelper.hs @@ -175,6 +175,9 @@ main = flip runContT pure do void $ lift $ withGit3Env env do + -- d_ <- asks gitRuntimeDict + -- atomically $ writeTVar d_ (Just (RuntimeDict fuck)) + conf <- readLocalConf cli <- parseCLI diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index 8e5faac3..c669ce5e 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -21,11 +21,12 @@ main = flip runContT pure do cli <- parseTop (unlines $ unwords <$> splitForms argz) & either (error.show) pure - env <- nullGit3Env + tvd <- newTVarIO theDict + env' <- nullGit3Env + let env = env' { gitRuntimeDict = Just (RuntimeDict tvd) } void $ lift $ withGit3Env env do conf <- readLocalConf - let dict = theDict - recover $ setupLogger >> run dict (conf <> cli) + recover $ setupLogger >> runEval tvd (conf <> cli) `finally` silence diff --git a/hbs2-git3/lib/HBS2/Git3/Config/Local.hs b/hbs2-git3/lib/HBS2/Git3/Config/Local.hs index 04826cef..d8f3788a 100644 --- a/hbs2-git3/lib/HBS2/Git3/Config/Local.hs +++ b/hbs2-git3/lib/HBS2/Git3/Config/Local.hs @@ -10,11 +10,4 @@ import Control.Monad.Trans.Maybe {- HLINT ignore "Functor law"-} -getConfigPath :: MonadIO m => m (Maybe FilePath) -getConfigPath = do - let name = ".hbs2-git3" - runMaybeT do - gitDir - >>= toMPlus <&> ( name) . takeDirectory - diff --git a/hbs2-git3/lib/HBS2/Git3/Export.hs b/hbs2-git3/lib/HBS2/Git3/Export.hs index 8e3c0d63..a07b0617 100644 --- a/hbs2-git3/lib/HBS2/Git3/Export.hs +++ b/hbs2-git3/lib/HBS2/Git3/Export.hs @@ -100,7 +100,9 @@ exportEntries prefix = do let refs = HM.toList $ HM.fromList refs' export (Just h) refs -export :: forall m . HBS2GitPerks m => Maybe GitHash -> [(GitRef, GitHash)] -> Git3 m () +export :: forall m . ( Git3Perks m + ) + => Maybe GitHash -> [(GitRef, GitHash)] -> Git3 m () export mbh refs = withStateDo do tn <- getNumCapabilities @@ -169,18 +171,19 @@ export mbh refs = withStateDo do when (exported > 0) do href <- createTreeWithMetadata sto gk meta lbs >>= orThrowPassIO - writeLogEntry ("tree" <+> pretty ts <+> pretty href ) - debug $ "SENDING" <+> pretty href <+> pretty fn - let payload = LBS.toStrict $ serialise (AnnotatedHashRef Nothing href) - tx <- withGit3Env env $ genRefLogUpdate payload - let txh = hashObject @HbSync (serialise tx) & HashRef + withGit3Env env do + debug $ "SENDING" <+> pretty href <+> pretty fn + writeLogEntry ("tree" <+> pretty ts <+> pretty href ) + tx <- genRefLogUpdate payload - atomically (modifyTVar txCheckQ (HS.insert txh)) + let txh = hashObject @HbSync (serialise tx) & HashRef - callRpcWaitMay @RpcRefLogPost (TimeoutSec 2) reflogAPI tx - >>= orThrowUser "rpc timeout" + atomically (modifyTVar txCheckQ (HS.insert txh)) + + callRpcWaitMay @RpcRefLogPost (TimeoutSec 2) reflogAPI tx + >>= orThrowUser "rpc timeout" rm fn next diff --git a/hbs2-git3/lib/HBS2/Git3/Import.hs b/hbs2-git3/lib/HBS2/Git3/Import.hs index 71185adf..a284a0b1 100644 --- a/hbs2-git3/lib/HBS2/Git3/Import.hs +++ b/hbs2-git3/lib/HBS2/Git3/Import.hs @@ -123,11 +123,6 @@ data ImportStage = {- HLINT ignore "Functor law" -} importGitRefLog :: forall m . ( HBS2GitPerks m - -- , HasStorage m - -- , HasClientAPI PeerAPI UNIX m - -- , HasClientAPI RefLogAPI UNIX m - -- , HasGitRemoteKey m - -- , MonadReader Git3Env m ) => Git3 m (Maybe HashRef) @@ -257,10 +252,10 @@ importGitRefLog = withStateDo $ ask >>= \case Left e -> err (viaShow e) >> throwIO e -groupKeysFile :: MonadIO m => Git3 m FilePath +groupKeysFile :: (MonadIO m) => Git3 m FilePath groupKeysFile = getStatePathM <&> ( "groupkeys") -readGroupKeyFile :: MonadIO m => Git3 m (Maybe HashRef) +readGroupKeyFile :: (MonadIO m) => Git3 m (Maybe HashRef) readGroupKeyFile = do file <- groupKeysFile debug $ "readGroupKeyFile" <+> pretty file diff --git a/hbs2-git3/lib/HBS2/Git3/State.hs b/hbs2-git3/lib/HBS2/Git3/State.hs index 6be90ed8..443fd002 100644 --- a/hbs2-git3/lib/HBS2/Git3/State.hs +++ b/hbs2-git3/lib/HBS2/Git3/State.hs @@ -23,7 +23,7 @@ import HBS2.KeyMan.Keys.Direct import HBS2.Data.Detect import HBS2.CLI.Run.MetaData (getTreeContents) -import Data.Config.Suckless +import Data.Config.Suckless.Script import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client.StorageClient @@ -130,12 +130,14 @@ getRepoManifest = do >>= orThrow GitRepoManifestMalformed <&> RepoManifest -nullGit3Env :: MonadIO m => m Git3Env +nullGit3Env :: forall m . MonadIO m => m Git3Env nullGit3Env = Git3Disconnected <$> newTVarIO defSegmentSize <*> newTVarIO defCompressionLevel <*> newTVarIO defIndexBlockSize <*> newTVarIO Nothing + <*> pure Nothing + connectedDo :: (MonadIO m) => Git3 m a -> Git3 m a connectedDo what = do @@ -153,7 +155,7 @@ withGit3Env env a = runReaderT (fromGit3 a) env runGit3 :: Git3Perks m => Git3Env -> Git3 m b -> m b runGit3 env action = withGit3Env env action -withStateDo :: MonadUnliftIO m => Git3 m a -> Git3 m a +withStateDo :: (MonadUnliftIO m) => Git3 m a -> Git3 m a withStateDo action = do waitRepo Nothing =<< getGitRepoKeyThrow @@ -169,6 +171,7 @@ recover m = fix \again -> 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) @@ -197,6 +200,8 @@ recover m = fix \again -> do -- debug $ yellow $ "REPOKEY" <+> pretty (AsBase58 rk) + dict <- asks gitRuntimeDict + connected <- Git3Connected soname sto peer refLogAPI lwwAPI <$> newTVarIO rk <*> newTVarIO Nothing @@ -204,6 +209,7 @@ recover m = fix \again -> do <*> newTVarIO defSegmentSize <*> newTVarIO defCompressionLevel <*> newTVarIO defIndexBlockSize + <*> pure dict liftIO $ withGit3Env connected do diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs index f37634d4..31508755 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs @@ -71,9 +71,7 @@ readLogFileLBS _ action = flip fix 0 \go n -> do go (succ n) indexPath :: forall m . ( Git3Perks m - , MonadReader Git3Env m - , HasGitRemoteKey m - ) => m FilePath + ) => Git3 m FilePath indexPath = getStatePathM @@ -127,7 +125,7 @@ mergeSortedFilesN getKey inputFiles outFile = do mkState [] = Nothing mkState (x:xs) = Just (Entry (getKey x) (x:xs)) -compactIndex :: forall m . (Git3Perks m, HasGitRemoteKey m, MonadReader Git3Env m) => Natural -> m () +compactIndex :: forall m . (Git3Perks m) => Natural -> Git3 m () compactIndex maxSize = do idxPath <- getStatePathM mkdir idxPath @@ -144,8 +142,8 @@ compactIndex maxSize = do out <- liftIO $ emptyTempFile idxPath "objects-.idx" mergeSortedFilesN (BS.take 20) (map fst block) out -openIndex :: forall a m . (Git3Perks m, HasGitRemoteKey m, MonadReader Git3Env m) - => m (Index a) +openIndex :: forall a m . (Git3Perks m) + => Git3 m (Index a) openIndex = do files <- listObjectIndexFiles @@ -211,9 +209,7 @@ indexFilterNewObjectsMem idx@Index{..} hashes = do listObjectIndexFiles :: forall m . ( Git3Perks m - , MonadReader Git3Env m - , HasGitRemoteKey m - ) => m [(FilePath, Natural)] + ) => Git3 m [(FilePath, Natural)] listObjectIndexFiles = do path <- indexPath @@ -275,13 +271,12 @@ bloomFilterSize n k p updateReflogIndex :: forall m . ( Git3Perks m - , MonadReader Git3Env m - , HasClientAPI PeerAPI UNIX m - , HasClientAPI RefLogAPI UNIX m - , HasStorage m - , HasGitRemoteKey m - , HasIndexOptions m - ) => m () + -- , HasClientAPI PeerAPI UNIX m + -- , HasClientAPI RefLogAPI UNIX m + -- , HasStorage m + -- , HasGitRemoteKey m + -- , HasIndexOptions m + ) => Git3 m () updateReflogIndex = do reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet @@ -398,11 +393,7 @@ updateReflogIndex = do trimRefs :: forall m . ( Git3Perks m - , MonadReader Git3Env m - , HasGitRemoteKey m - , HasStorage m - , HasClientAPI RefLogAPI UNIX m - ) => m () + ) => Git3 m () trimRefs = do idxPath <- indexPath files <- refsFiles @@ -439,11 +430,7 @@ trimRefs = do mapM_ rm files importedCheckpoint :: forall m . ( MonadIO m - , MonadReader Git3Env m - , HasClientAPI RefLogAPI UNIX m - , HasStorage m - , HasGitRemoteKey m - ) => m (Maybe HashRef) + ) => Git3 m (Maybe HashRef) importedCheckpoint = do state <- getStatePathM @@ -459,30 +446,22 @@ nullHash :: GitHash nullHash = GitHash (BS.replicate 20 0) txImported :: forall m . ( Git3Perks m - , MonadReader Git3Env m - , HasClientAPI RefLogAPI UNIX m - , HasStorage m - , HasGitRemoteKey m - ) => m (HashSet HashRef) + ) => Git3 m (HashSet HashRef) txImported = maybe mempty HS.fromList <$> runMaybeT do cp <- lift importedCheckpoint >>= toMPlus fmap fst <$> lift (txListAll (Just cp)) -refsFiles :: forall m . (Git3Perks m, HasGitRemoteKey m) => m [FilePath] +refsFiles :: forall m . (Git3Perks m) => Git3 m [FilePath] refsFiles = do state <- getStatePathM dirFiles state <&> filter ( (== ".ref") . takeExtension ) readRefsRaw :: forall m . ( Git3Perks m - , MonadReader Git3Env m - , HasClientAPI RefLogAPI UNIX m - , HasStorage m - , HasGitRemoteKey m ) - => [FilePath] -> m [Syntax C] + => [FilePath] -> Git3 m [Syntax C] readRefsRaw files = do mapM (liftIO . E.try @IOError . readFile) files @@ -492,11 +471,7 @@ readRefsRaw files = do {- HLINT ignore "Functor law"-} importedRefs :: forall m . ( Git3Perks m - , MonadReader Git3Env m - , HasClientAPI RefLogAPI UNIX m - , HasStorage m - , HasGitRemoteKey m - ) => m [(GitRef, GitHash)] + ) => Git3 m [(GitRef, GitHash)] importedRefs = do @@ -521,11 +496,7 @@ importedRefs = do pure rrefs updateImportedCheckpoint :: forall m . ( Git3Perks m - , MonadReader Git3Env m - , HasClientAPI RefLogAPI UNIX m - , HasStorage m - , HasGitRemoteKey m - ) => HashRef -> m () + ) => HashRef -> Git3 m () updateImportedCheckpoint cp = do state <- getStatePathM diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs index 07f6a216..4351c62f 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs @@ -7,6 +7,7 @@ module HBS2.Git3.State.Internal.Types import HBS2.Git3.Prelude import HBS2.Git3.Config.Local +import HBS2.Git.Local.CLI import HBS2.System.Dir import Data.Config.Suckless.Script @@ -21,23 +22,30 @@ import Control.Exception qualified as E unit :: FilePath unit = "hbs2-git" -getStatePath :: (MonadIO m, Pretty ref) => ref -> m (Maybe FilePath) +getConfigPath :: MonadIO m => Git3 m (Maybe FilePath) +getConfigPath = do + let name = ".hbs2-git3" + runMaybeT do + gitDir + >>= toMPlus <&> ( name) . takeDirectory + +getStatePath :: (MonadIO m, Pretty ref) => ref -> Git3 m (Maybe FilePath) getStatePath p = runMaybeT do - d <- getConfigPath >>= toMPlus + d <- lift getConfigPath >>= toMPlus pure $ d show (pretty p) -getConfigRootFile :: MonadIO m => m FilePath +getConfigRootFile :: MonadIO m => Git3 m FilePath getConfigRootFile = do getConfigPath >>= orThrow StateDirNotDefined <&> ( "config") -readLocalConf :: MonadIO m => m [Syntax C] +readLocalConf :: forall m . HBS2GitPerks m => Git3 m [Syntax C] readLocalConf = do fromMaybe mempty <$> runMaybeT do - conf <- liftIO (E.try @SomeException getConfigRootFile) + conf <- lift (try @_ @SomeException getConfigRootFile) >>= toMPlus lift $ touch conf @@ -93,12 +101,16 @@ instance Hashable GitWritePacksOptVal instance GitWritePacksOpts (HashSet GitWritePacksOptVal) where excludeParents o = not $ HS.member WriteFullPack o +data RuntimeDict = forall c m . (IsContext c, HBS2GitPerks m) + => RuntimeDict { fromRuntimeDict :: TVar (Dict c m) } + data Git3Env = Git3Disconnected { gitPackedSegmentSize :: TVar Int , gitCompressionLevel :: TVar Int , gitIndexBlockSize :: TVar Natural , gitRepoKey :: TVar (Maybe GitRepoKey) + , gitRuntimeDict :: Maybe RuntimeDict } | Git3Connected { peerSocket :: FilePath @@ -112,6 +124,7 @@ data Git3Env = , gitPackedSegmentSize :: TVar Int , gitCompressionLevel :: TVar Int , gitIndexBlockSize :: TVar Natural + , gitRuntimeDict :: Maybe RuntimeDict } class HasExportOpts m where @@ -169,6 +182,10 @@ instance (MonadIO m) => HasGitRemoteKey (Git3 m) where e <- ask liftIO $ atomically $ writeTVar (gitRepoKey e) (Just k) +class IsContext c => HasRuntimeDict c m where + getRuntimeDict :: m (TVar (Dict c m)) + + getGitRepoKeyThrow :: (MonadIO m, HasGitRemoteKey m) => m GitRepoKey getGitRepoKeyThrow = getGitRepoKey >>= orThrow GitRepoRefNotSet @@ -216,7 +233,7 @@ instance HasClientAPI api UNIX (Git3 m) => HasClientAPI api UNIX (ContT whatever instance HasClientAPI api UNIX (Git3 m) => HasClientAPI api UNIX (MaybeT (Git3 m)) where getClientAPI = lift getClientAPI -getStatePathM :: forall m . (MonadIO m, HasGitRemoteKey m) => m FilePath +getStatePathM :: forall m . (MonadIO m) => Git3 m FilePath getStatePathM = do k <- getGitRemoteKey >>= orThrow RefLogNotSet getStatePath (AsBase58 k) >>= orThrow StateDirNotDefined