diff --git a/Makefile b/Makefile index 83f4ddf9..34625c22 100644 --- a/Makefile +++ b/Makefile @@ -64,7 +64,8 @@ symlinks: $(BIN_DIR) > path=`find dist-newstyle -type f -name $$bin -path "*$(GHC_VERSION)*" | head -n 1`; \ > if [ -n "$$path" ]; then \ > echo "Creating symlink for $$bin"; \ -> ln -sf $$PWD/$$path $(BIN_DIR)/$$bin; \ +> ln -sfn $$PWD/$$path $(BIN_DIR)/$$bin; \ +#> cp $$PWD/$$path $(BIN_DIR)/$$bin; \ > else \ > echo "Binary $$bin for GHC $(GHC_VERSION) not found"; \ > fi; \ diff --git a/flake.lock b/flake.lock index ffb21005..6bd43255 100644 --- a/flake.lock +++ b/flake.lock @@ -18,6 +18,24 @@ "type": "github" } }, + "flake-utils_2": { + "inputs": { + "systems": "systems_2" + }, + "locked": { + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, "haskell-flake-utils": { "inputs": { "flake-utils": [ @@ -62,6 +80,27 @@ "type": "github" } }, + "nixbwrap": { + "inputs": { + "flake-utils": "flake-utils_2", + "nixpkgs": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1667333413, + "narHash": "sha256-QGR6Src6UNXac3fgoe9PW40bAOYy0f05DGcRD2ae2S4=", + "ref": "refs/heads/master", + "rev": "a24e9553ee84d01aa2f9b35f30c75728864dfa52", + "revCount": 28, + "type": "git", + "url": "https://git.sr.ht/~fgaz/nix-bubblewrap" + }, + "original": { + "type": "git", + "url": "https://git.sr.ht/~fgaz/nix-bubblewrap" + } + }, "nixpkgs": { "locked": { "lastModified": 1727089097, @@ -83,6 +122,7 @@ "flake-utils": "flake-utils", "haskell-flake-utils": "haskell-flake-utils", "hspup": "hspup", + "nixbwrap": "nixbwrap", "nixpkgs": "nixpkgs" } }, @@ -100,6 +140,21 @@ "repo": "default", "type": "github" } + }, + "systems_2": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } } }, "root": "root", diff --git a/flake.nix b/flake.nix index d3bc6ad2..61132bc5 100644 --- a/flake.nix +++ b/flake.nix @@ -14,6 +14,9 @@ inputs = { hspup.inputs.nixpkgs.follows = "nixpkgs"; hspup.inputs.haskell-flake-utils.follows = "haskell-flake-utils"; + nixbwrap.url = "git+https://git.sr.ht/~fgaz/nix-bubblewrap"; + nixbwrap.inputs.nixpkgs.follows = "nixpkgs"; + }; outputs = { self, nixpkgs, flake-utils, ... }@inputs: @@ -159,6 +162,8 @@ outputs = { self, nixpkgs, flake-utils, ... }@inputs: pkgs.icu72 pkgs.openssl weeder + pkgs.iptables + pkgs.bridge-utils ] ++ [ pkgs.pkg-config @@ -166,6 +171,7 @@ outputs = { self, nixpkgs, flake-utils, ... }@inputs: pkgs.file pkgs.zlib inputs.hspup.packages.${pkgs.system}.default + inputs.nixbwrap.packages.${pkgs.system}.default ] ); diff --git a/hbs2-git3/app/GitRemoteHelper.hs b/hbs2-git3/app/GitRemoteHelper.hs index 38abd54b..26ab44f7 100644 --- a/hbs2-git3/app/GitRemoteHelper.hs +++ b/hbs2-git3/app/GitRemoteHelper.hs @@ -114,13 +114,9 @@ localDict DeferredOps{..} = makeDict @C do t0 <- getTimeCoarse - flip fix 0 $ \next i -> do - importGitRefLog >>= \case - Just{} -> none - Nothing -> do - notice "wait for data..." - pause @'Seconds 2.0 - next (succ i) + -- waitRepo Nothing + + importGitRefLog rrefs <- importedRefs @@ -198,16 +194,17 @@ main = flip runContT pure do cli <- parseCLI - case cli of - [ ListVal [_, RepoURL url ] ] -> do - notice $ "FUCKING REMOTE" <+> pretty (AsBase58 url) - setGitRepoKey url + url <- case cli of + [ ListVal [_, RepoURL x ] ] -> do + notice $ "FUCKING REMOTE" <+> pretty (AsBase58 x) + setGitRepoKey x + pure $ Just x - _ -> none + _ -> pure Nothing - void $ run dict conf - - recover $ connectedDo do + recover $ connectedDo $ withStateDo do + void $ run dict conf + for_ url updateRepoKey flip fix Plain $ \next -> \case Plain -> do diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index a177777d..9150c683 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -82,7 +82,6 @@ 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/lib/HBS2/Git3/Config/Local.hs b/hbs2-git3/lib/HBS2/Git3/Config/Local.hs index 534f0243..04826cef 100644 --- a/hbs2-git3/lib/HBS2/Git3/Config/Local.hs +++ b/hbs2-git3/lib/HBS2/Git3/Config/Local.hs @@ -6,43 +6,15 @@ import HBS2.System.Dir import HBS2.Git.Local.CLI -import System.Directory - -import Data.Config.Suckless.Script - -import Data.Text.IO qualified as IO +import Control.Monad.Trans.Maybe {- HLINT ignore "Functor law"-} -getConfigPath :: MonadIO m => m FilePath +getConfigPath :: MonadIO m => m (Maybe FilePath) getConfigPath = do - let name = ".hbs2-git3" - - gitDir - >>= orThrowUser ".git not found" - <&> ( name) . takeDirectory - - -getConfigRootFile :: MonadIO m => m FilePath -getConfigRootFile = do - - let name = ".hbs2-git3" - - gitDir - >>= orThrowUser ".git not found" - <&> ( name) . takeDirectory - <&> ( "config") - -readLocalConf :: MonadIO m => m [Syntax C] -readLocalConf = do - - conf <- getConfigPath <&> ( "config") - - touch conf - - liftIO (IO.readFile conf) - <&> parseTop - >>= either (const $ pure mempty) pure + 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 f355a920..bf9291f9 100644 --- a/hbs2-git3/lib/HBS2/Git3/Export.hs +++ b/hbs2-git3/lib/HBS2/Git3/Export.hs @@ -86,7 +86,7 @@ exportEntries prefix = do export (Just h) refs export :: forall m . HBS2GitPerks m => Maybe GitHash -> [(GitRef, GitHash)] -> Git3 m () -export mbh refs = do +export mbh refs = withStateDo do tn <- getNumCapabilities updateReflogIndex @@ -281,9 +281,11 @@ export mbh refs = do where writeLogEntry e = do - path <- getConfigPath <&> ( "log") - touch path - liftIO (IO.appendFile path (show $ e <> line)) + path' <- getConfigPath + for_ path' $ \path -> do + let logPath = path "log" + touch path + liftIO (IO.appendFile logPath (show $ e <> line)) writeRefSectionSome :: forall m1 . MonadIO m1 => TBQueue (Maybe LBS.ByteString) -> [(GitRef, GitHash)] -> m1 () writeRefSectionSome sourceQ refsAndCommits = do diff --git a/hbs2-git3/lib/HBS2/Git3/Import.hs b/hbs2-git3/lib/HBS2/Git3/Import.hs index 3f7c01f1..9aa9f991 100644 --- a/hbs2-git3/lib/HBS2/Git3/Import.hs +++ b/hbs2-git3/lib/HBS2/Git3/Import.hs @@ -106,15 +106,15 @@ writeAsGitPack dir href = do importGitRefLog :: forall m . ( HBS2GitPerks m - , HasStorage m - , HasClientAPI PeerAPI UNIX m - , HasClientAPI RefLogAPI UNIX m - , HasGitRemoteKey m - , MonadReader Git3Env m + -- , HasStorage m + -- , HasClientAPI PeerAPI UNIX m + -- , HasClientAPI RefLogAPI UNIX m + -- , HasGitRemoteKey m + -- , MonadReader Git3Env m ) - => m (Maybe HashRef) + => Git3 m (Maybe HashRef) -importGitRefLog = do +importGitRefLog = withStateDo do updateReflogIndex diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index 6810e56e..7c2672f2 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/hbs2-git3/lib/HBS2/Git3/Run.hs @@ -55,7 +55,7 @@ theDict = do where - myEntries = hidePrefix "test:" do + myEntries = do entry $ bindMatch "--help" $ nil_ $ \case HelpEntryBound what -> do helpEntry what @@ -432,34 +432,6 @@ compression ; prints compression level entry $ bindMatch "reflog:refs:raw" $ nil_ $ \syn -> lift $ connectedDo do refsFiles >>= readRefsRaw >>= liftIO . mapM_ (print . pretty) - -- entry $ bindMatch "reflog:refs:trimmed" $ nil_ $ \syn -> lift $ connectedDo do - -- txi <- txImported - -- raw <- readRefsRaw =<< refsFiles - - -- ni_ <- newTQueueIO - -- imp_ <- newTVarIO ( mempty :: HashMap Text (Integer, GitHash, HashRef) ) - - -- for_ raw $ \case - -- ListVal [ SymbolVal "R", HashLike seg, LitIntVal r, GitHashLike v, TextLike n ] -> do - - -- atomically do - -- if not (HS.member seg txi) then - -- writeTQueue ni_ (n, (r, v, seg)) - -- else do - -- let x = (r, v, seg) - -- let fn = HM.insertWith (\a b -> if view _1 a > view _1 b then a else b) n x - -- modifyTVar imp_ fn - - -- _ -> none - - -- result <- atomically do - -- a <- STM.flushTQueue ni_ - -- b <- readTVar imp_ <&> HM.toList - -- pure (a <> b) - - -- for_ result $ \(n, (r, h, v)) -> do - -- liftIO $ print $ "R" <+> pretty h <+> pretty r <+> pretty v <+> pretty n - entry $ bindMatch "reflog:wait" $ nil_ $ \syn -> lift $ connectedDo do let (_,argz) = splitOpts [] syn let t = headMay [ realToFrac x | LitIntVal x <- argz ] diff --git a/hbs2-git3/lib/HBS2/Git3/State.hs b/hbs2-git3/lib/HBS2/Git3/State.hs index 5d4d5c98..56fd1b60 100644 --- a/hbs2-git3/lib/HBS2/Git3/State.hs +++ b/hbs2-git3/lib/HBS2/Git3/State.hs @@ -53,6 +53,8 @@ getRefLog mf = lastMay [ x updateRepoKey :: forall m . HBS2GitPerks m => GitRepoKey -> Git3 m () updateRepoKey key = do + notice $ "updateRepoKey" <+> pretty (AsBase58 key) + setGitRepoKey key reflog <- getRepoManifest <&> getRefLog @@ -137,6 +139,11 @@ 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 action = do + waitRepo Nothing + getStatePathM >>= mkdir + action recover :: Git3 IO a -> Git3 IO a recover m = fix \again -> do @@ -170,12 +177,13 @@ recover m = fix \again -> do let sto = AnyStorage (StorageClient storageAPI) - rk <- lift $ getGitRepoKey >>= orThrow GitRepoRefNotSet + rk <- lift $ getGitRepoKey - notice $ yellow $ "REPOKEY" <+> pretty (AsBase58 rk) + -- debug $ yellow $ "REPOKEY" <+> pretty (AsBase58 rk) connected <- Git3Connected soname sto peer refLogAPI lwwAPI - <$> newTVarIO (Just rk) + <$> newTVarIO rk + <*> newTVarIO Nothing <*> newTVarIO Nothing <*> newTVarIO defSegmentSize <*> newTVarIO defCompressionLevel @@ -183,14 +191,10 @@ recover m = fix \again -> do liftIO $ withGit3Env connected do - - updateRepoKey rk - - ref <- getGitRemoteKey >>= orThrow GitRepoManifestMalformed - - state <- getStatePath (AsBase58 ref) - mkdir state - + -- updateRepoKey rk + -- ref <- getGitRemoteKey >>= orThrow GitRepoManifestMalformed + -- state <- getStatePathM + -- mkdir state again e -> throwIO e @@ -212,69 +216,89 @@ waitRepo :: forall m . HBS2GitPerks m => Maybe (Timeout 'Seconds) -> Git3 m () waitRepo timeout = do repoKey <- getGitRepoKey >>= orThrow GitRepoRefNotSet - lwwAPI <- getClientAPI @LWWRefAPI @UNIX - peerAPI <- getClientAPI @PeerAPI @UNIX - reflogAPI <- getClientAPI @RefLogAPI @UNIX - sto <- getStorage + notice $ yellow "waitRepo" - env <- ask + ask >>= \case + Git3Disconnected{} -> throwIO Git3PeerNotConnected + Git3Connected{..} -> do - flip runContT pure do + sto <- getStorage - let wait w what x = pause @'Seconds w >> what x + flip runContT pure $ callCC \done -> do - callCC \forPeer -> do + rlv <- readTVarIO gitRefLogVal <&> isJust + rlog <- readTVarIO gitRefLog <&> isJust - notice "wait for peer" + when (rlv && rlog) $ done () - lift (callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (repoKey, "lwwref", 31)) - >>= maybe (wait 1 forPeer ()) (const none) + reflog_ <- newEmptyTMVarIO - pFetch <- ContT $ withAsync $ forever do - void (callRpcWaitMay @RpcLWWRefFetch (TimeoutSec 1) lwwAPI (LWWRefKey repoKey)) - pause @'Seconds 10 + let wait w what x = pause @'Seconds w >> what x - lww <- flip fix () \next _ -> do - notice $ "wait for" <+> pretty (AsBase58 repoKey) - lift (callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (LWWRefKey repoKey)) - >>= \case - Just (Just x) -> pure x - _ -> wait 2 next () + callCC \forPeer -> do - notice $ "lwwref value" <+> pretty (lwwValue lww) + notice "wait for peer" - error "stop" + lift (callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (repoKey, "lwwref", 31)) + >>= maybe (wait 1 forPeer ()) (const none) - mf <- flip fix () $ \next _ -> do - notice $ "wait for manifest" - lift (try @_ @WalkMerkleError getRepoManifest) >>= \case - Left{} -> wait 1 next () - Right x -> pure x + pFetch <- ContT $ withAsync $ forever do + void (callRpcWaitMay @RpcLWWRefFetch (TimeoutSec 1) lwwAPI (LWWRefKey repoKey)) + pause @'Seconds 10 - reflog <- getRefLog mf & orThrow GitRepoManifestMalformed + pFetchRefLog <- ContT $ withAsync do + r <- atomically $ takeTMVar reflog_ + forever do + void (callRpcWaitMay @RpcRefLogFetch (TimeoutSec 1) reflogAPI r) + pause @'Seconds 10 - lift $ setGitRepoKey reflog + lww <- flip fix () \next _ -> do + notice $ "wait for" <+> pretty (AsBase58 repoKey) + lift (callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (LWWRefKey repoKey)) + >>= \case + Just (Just x) -> pure x + _ -> wait 2 next () - rv <- flip fix () \next _ -> do - notice $ "wait for data" <+> pretty (AsBase58 reflog) - lift (callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflogAPI reflog) - >>= \case - Just (Just x) -> pure x - _ -> wait 2 next () + notice $ "lwwref value" <+> pretty (lwwValue lww) - okay <- newEmptyTMVarIO + mf <- flip fix () $ \next _ -> do + notice $ "wait for manifest" + lift (try @_ @WalkMerkleError getRepoManifest) >>= \case + Left{} -> wait 1 next () + Right x -> pure x - flip fix () $ \next _ -> do - notice $ "wait for data (2)" <+> pretty (AsBase58 reflog) - missed <- findMissedBlocks sto rv - unless (L.null missed) $ wait 2 next () - atomically $ writeTMVar okay True - - pWait <- ContT $ withAsync $ race ( pause (fromMaybe 300 timeout) ) do - void $ atomically $ takeTMVar okay - - waitAnyCatchCancel [pWait, pFetch] - - liftIO $ print $ "reflog" <+> pretty (AsBase58 reflog) <+> pretty rv + reflog <- getRefLog mf & orThrow GitRepoManifestMalformed + + + atomically $ writeTMVar reflog_ reflog + + lift (callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (reflog, "reflog", 11)) + >>= orThrow RpcTimeout + + rv <- flip fix () \next _ -> do + notice $ "wait for data" <+> pretty (AsBase58 reflog) + lift (callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflogAPI reflog) + >>= \case + Just (Just x) -> pure x + _ -> wait 2 next () + + atomically $ writeTVar gitRefLogVal (Just rv) + + okay <- newEmptyTMVarIO + + flip fix () $ \next _ -> do + notice $ "wait for data (2)" <+> pretty (AsBase58 reflog) + missed <- findMissedBlocks sto rv + unless (L.null missed) $ wait 2 next () + atomically $ writeTMVar okay True + + pWait <- ContT $ withAsync $ race ( pause (fromMaybe 300 timeout) ) do + void $ atomically $ takeTMVar okay + + waitAnyCatchCancel [pWait, pFetch, pFetchRefLog] + + lift $ updateRepoKey repoKey + + liftIO $ print $ "reflog" <+> pretty (AsBase58 reflog) <+> pretty rv diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs index 0b452a57..ed7625be 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Index.hs @@ -73,9 +73,8 @@ indexPath :: forall m . ( Git3Perks m , MonadReader Git3Env m , HasGitRemoteKey m ) => m FilePath -indexPath = do - reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet - getStatePath (AsBase58 reflog) + +indexPath = getStatePathM data IndexEntry = IndexEntry @@ -129,8 +128,7 @@ mergeSortedFilesN getKey inputFiles outFile = do 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) + idxPath <- getStatePathM mkdir idxPath files <- listObjectIndexFiles <&> L.sortOn snd diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs index a49756da..cf21a9d4 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs @@ -9,23 +9,49 @@ import HBS2.Git3.Prelude import HBS2.Git3.Config.Local import HBS2.System.Dir +import Data.Config.Suckless.Script + import Data.Kind import Data.HashSet (HashSet) import Data.HashSet qualified as HS +import Data.Maybe +import Data.Text.IO qualified as IO +import Control.Exception qualified as E unit :: FilePath unit = "hbs2-git" -getStatePath :: (MonadIO m, Pretty ref) => ref -> m FilePath -getStatePath p = do - d <- getConfigPath +getStatePath :: (MonadIO m, Pretty ref) => ref -> m (Maybe FilePath) +getStatePath p = runMaybeT do + d <- getConfigPath >>= toMPlus pure $ d show (pretty p) +getConfigRootFile :: MonadIO m => m FilePath +getConfigRootFile = do + getConfigPath + >>= orThrow StateDirNotDefined + <&> ( "config") + +readLocalConf :: MonadIO m => m [Syntax C] +readLocalConf = do + + fromMaybe mempty <$> runMaybeT do + + conf <- liftIO (E.try @SomeException getConfigRootFile) + >>= toMPlus + + lift $ touch conf + + liftIO (IO.readFile conf) + <&> parseTop + >>= either (const $ pure mempty) pure + data HBS2GitExcepion = RefLogNotSet | GitRepoRefNotSet | GitRepoRefEmpty | GitRepoManifestMalformed + | StateDirNotDefined | RefLogCredentialsNotMatched | RefLogNotReady | RpcTimeout @@ -76,13 +102,14 @@ data Git3Env = , 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) + { peerSocket :: FilePath + , peerStorage :: AnyStorage + , peerAPI :: ServiceCaller PeerAPI UNIX + , reflogAPI :: ServiceCaller RefLogAPI UNIX + , lwwAPI :: ServiceCaller LWWRefAPI UNIX + , gitRepoKey :: TVar (Maybe GitRepoKey) + , gitRefLog :: TVar (Maybe GitRemoteKey) + , gitRefLogVal :: TVar (Maybe HashRef) , gitPackedSegmentSize :: TVar Int , gitCompressionLevel :: TVar Int , gitIndexBlockSize :: TVar Natural @@ -178,9 +205,8 @@ instance (MonadUnliftIO m) => HasClientAPI LWWRefAPI UNIX (Git3 m) where Git3Disconnected{} -> throwIO Git3PeerNotConnected Git3Connected{..} -> pure lwwAPI - getStatePathM :: forall m . (HBS2GitPerks m, HasGitRemoteKey m) => m FilePath getStatePathM = do k <- getGitRemoteKey >>= orThrow RefLogNotSet - getStatePath (AsBase58 k) + getStatePath (AsBase58 k) >>= orThrow StateDirNotDefined