wip

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; \

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",

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
         ]
       );
 

hbs2-git3/app/GitRemoteHelper.hs

@@ -114,13 +114,9 @@ localDict DeferredOps{..} = makeDict @C do
 
       t0 <- getTimeCoarse
 
-      flip fix 0 $ \next i -> do
+      -- waitRepo Nothing
-        importGitRefLog >>= \case
+
-          Just{} -> none
+      importGitRefLog
-          Nothing -> do
-            notice "wait for data..."
-            pause @'Seconds 2.0
-            next (succ i)
 
       rrefs <- importedRefs
 
@@ -198,16 +194,17 @@ main =  flip runContT pure do
 
     cli <- parseCLI
 
-    case cli of
+    url <- case cli of
-      [ ListVal [_, RepoURL url ] ] -> do
+      [ ListVal [_, RepoURL x ] ] -> do
-        notice $ "FUCKING REMOTE" <+> pretty (AsBase58 url)
+        notice $ "FUCKING REMOTE" <+> pretty (AsBase58 x)
-        setGitRepoKey url
+        setGitRepoKey x
+        pure $ Just x
 
-      _ -> none
+      _ -> pure Nothing
 
-    void $ run dict conf
+    recover $ connectedDo $ withStateDo do
-
+      void $ run dict conf
-    recover $ connectedDo do
+      for_ url updateRepoKey
 
       flip fix Plain $ \next -> \case
         Plain -> do

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

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 Control.Monad.Trans.Maybe
-
-import Data.Config.Suckless.Script
-
-import Data.Text.IO qualified as IO
 
 {- HLINT ignore "Functor law"-}
 
-getConfigPath :: MonadIO m => m FilePath
+getConfigPath :: MonadIO m => m (Maybe FilePath)
 getConfigPath = do
-
   let name = ".hbs2-git3"
-
+  runMaybeT do
-  gitDir
+    gitDir
-    >>= orThrowUser ".git not found"
+      >>= toMPlus <&> (</> name) . takeDirectory
-    <&> (</> 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
 
 

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")
+     path' <- getConfigPath
-     touch path
+     for_ path' $ \path -> do
-     liftIO (IO.appendFile path (show $ e <> line))
+       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

hbs2-git3/lib/HBS2/Git3/Import.hs

@@ -106,15 +106,15 @@ writeAsGitPack dir href = do
 
 
 importGitRefLog :: forall m . ( HBS2GitPerks m
-                              , HasStorage m
+                              -- , HasStorage m
-                              , HasClientAPI PeerAPI UNIX m
+                              -- , HasClientAPI PeerAPI UNIX m
-                              , HasClientAPI RefLogAPI UNIX m
+                              -- , HasClientAPI RefLogAPI UNIX m
-                              , HasGitRemoteKey m
+                              -- , HasGitRemoteKey m
-                              , MonadReader Git3Env m
+                              -- , MonadReader Git3Env m
                               )
-             => m (Maybe HashRef)
+             => Git3 m (Maybe HashRef)
 
-importGitRefLog = do
+importGitRefLog = withStateDo do
 
   updateReflogIndex
 

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 ]

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
-          updateRepoKey rk
+          -- ref <- getGitRemoteKey >>= orThrow GitRepoManifestMalformed
-
+          -- state <- getStatePathM
-          ref <- getGitRemoteKey >>= orThrow GitRepoManifestMalformed
+          -- mkdir state
-
-          state <- getStatePath (AsBase58 ref)
-          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
+  notice $ yellow "waitRepo"
-  peerAPI  <- getClientAPI @PeerAPI @UNIX
-  reflogAPI <- getClientAPI @RefLogAPI @UNIX
-  sto <- getStorage
 
-  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))
+        reflog_ <- newEmptyTMVarIO
-               >>= maybe (wait 1 forPeer ()) (const none)
 
-    pFetch <- ContT $ withAsync $ forever do
+        let wait w what x = pause @'Seconds w >> what x
-                void  (callRpcWaitMay @RpcLWWRefFetch (TimeoutSec 1) lwwAPI (LWWRefKey repoKey))
-                pause @'Seconds 10
 
-    lww <- flip fix () \next _ -> do
+        callCC \forPeer -> do
-              notice $ "wait for" <+> pretty (AsBase58 repoKey)
-              lift (callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (LWWRefKey repoKey))
-                >>= \case
-                       Just (Just x)  -> pure x
-                       _              -> wait 2 next ()
 
-    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
+        pFetch <- ContT $ withAsync $ forever do
-              notice $ "wait for manifest"
+                    void  (callRpcWaitMay @RpcLWWRefFetch (TimeoutSec 1) lwwAPI (LWWRefKey repoKey))
-              lift (try @_ @WalkMerkleError getRepoManifest) >>= \case
+                    pause @'Seconds 10
-                Left{}  -> wait 1 next ()
-                Right x -> pure x
 
-    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 $ "lwwref value" <+> pretty (lwwValue lww)
-              notice $ "wait for data" <+> pretty (AsBase58 reflog)
-              lift (callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflogAPI reflog)
-                >>= \case
-                       Just (Just x)  -> pure x
-                       _              -> wait 2 next ()
 
-    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
+        reflog <- getRefLog mf & orThrow GitRepoManifestMalformed
-       notice $ "wait for data (2)" <+> pretty (AsBase58 reflog)
+
-       missed <- findMissedBlocks sto rv
+
-       unless (L.null missed) $ wait 2 next ()
+        atomically $ writeTMVar reflog_ reflog
-       atomically $ writeTMVar okay True
+
-
+        lift (callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (reflog, "reflog", 11))
-    pWait <- ContT $ withAsync $ race ( pause (fromMaybe 300 timeout) ) do
+                 >>= orThrow RpcTimeout
-               void $ atomically $ takeTMVar okay
+
-
+        rv <- flip fix () \next _ -> do
-    waitAnyCatchCancel [pWait, pFetch]
+                  notice $ "wait for data" <+> pretty (AsBase58 reflog)
-
+                  lift (callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflogAPI reflog)
-    liftIO $ print $ "reflog" <+> pretty (AsBase58 reflog) <+> pretty rv
+                    >>= \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
 
 

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
+indexPath = getStatePathM
-  getStatePath (AsBase58 reflog)
 
 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 <- getStatePathM
-  idxPath <- getStatePath (AsBase58 reflog)
   mkdir idxPath
   files <- listObjectIndexFiles <&> L.sortOn snd
 

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 :: (MonadIO m, Pretty ref) => ref -> m (Maybe FilePath)
-getStatePath p = do
+getStatePath p = runMaybeT do
-  d <- getConfigPath
+  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
+    { peerSocket   :: FilePath
-    , peerStorage :: AnyStorage
+    , peerStorage  :: AnyStorage
-    , peerAPI     :: ServiceCaller PeerAPI UNIX
+    , peerAPI      :: ServiceCaller PeerAPI UNIX
-    , reflogAPI   :: ServiceCaller RefLogAPI UNIX
+    , reflogAPI    :: ServiceCaller RefLogAPI UNIX
-    , lwwAPI      :: ServiceCaller LWWRefAPI UNIX
+    , lwwAPI       :: ServiceCaller LWWRefAPI UNIX
-    , gitRepoKey  :: TVar (Maybe GitRepoKey)
+    , gitRepoKey   :: TVar (Maybe GitRepoKey)
-    , gitRefLog   :: TVar (Maybe GitRemoteKey)
+    , 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