voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

removing excess constraints

This commit is contained in:
voidlizard 2025-02-05 12:45:08 +03:00
parent b91f0323e6
commit 227f29e8bb
8 changed files with 71 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
hbs2-git3/app/GitRemoteHelper.hs
View File

@ -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

7
hbs2-git3/app/Main.hs
View File

@ -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

7
hbs2-git3/lib/HBS2/Git3/Config/Local.hs
View File

@ -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

21
hbs2-git3/lib/HBS2/Git3/Export.hs
View File

@ -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

9
hbs2-git3/lib/HBS2/Git3/Import.hs
View File

@ -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

12
hbs2-git3/lib/HBS2/Git3/State.hs
View File

@ -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

65
hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs
View File

@ -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

29
hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs
View File

@ -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