basic tool for hbs2 repo syncronization

flake.lock

@@ -295,11 +295,11 @@
         ]
       },
       "locked": {
-        "lastModified": 1696297671,
+        "lastModified": 1697251648,
-        "narHash": "sha256-jPWuqQlXKRnkU2A19nwtzDHI6bnICzFwDffx2qj/sCM=",
+        "narHash": "sha256-dT305J8wIJLIbuVi4YhtaeaquNtVxFhutbB2tgsu938=",
         "owner": "voidlizard",
         "repo": "suckless-conf",
-        "rev": "a0919addd3f43b7cfddb6c35568495b4a295f1f2",
+        "rev": "a79097e5b28da8a098405dc9c15235a57f887160",
         "type": "github"
       },
       "original": {

hbs2-git/git-hbs2-http/GitHttpDumbMain.hs

@@ -1,249 +0,0 @@
-module Main where
-
-import HBS2.Prelude.Plated
-import HBS2.Clock
-
-import HBS2Git.App
-import HBS2Git.State
-import HBS2Git.Import (getLogFlags, importRefLogNew)
-import HBS2Git.GitRepoLog
-import HBS2.Git.Types
-import HBS2.Data.Types.Refs
-import HBS2.Data.Detect (deepScan,ScanLevel(..))
-import HBS2.OrDie
-
-import HBS2.System.Logger.Simple
-
-import Codec.Compression.Zlib (compress)
-import Control.Concurrent
-import Control.Exception
-import Control.Monad
-import Control.Monad.Trans.Maybe
-import Control.Monad.Trans.Resource
-import Data.ByteString.Lazy.Char8 qualified as LBS
-import Data.Function
-import Data.Functor
-import Data.HashMap.Strict as HashMap
-import Data.List (sortOn)
-import Data.Text.Lazy qualified as Text
-import Lens.Micro.Platform
-import Network.HTTP.Types.Status
-import Network.Wai.Handler.Warp (Port)
-import Network.Wai.Middleware.RequestLogger
-import System.Directory
-import System.FilePath.Posix
-import System.IO.Temp
-import System.Timeout (timeout)
-import Text.InterpolatedString.Perl6 (qc)
-import UnliftIO.Async
-
-import Streaming.ByteString qualified as SB
-import Streaming.Zip qualified as SZip
-
-import Web.Scotty
-
-instance Parsable RepoRef where
-  parseParam txt = fromStringMay @RepoRef (Text.unpack txt)
-                    & maybe (Left [qc|{txt}|]) Right
-
-instance Parsable GitRef where
-  parseParam txt = Right $ fromString (Text.unpack txt)
-
-getAppStatePath :: MonadIO m => RepoRef -> m FilePath
-getAppStatePath repo = do
-  stateDir <- getAppStateDir
-  pure $ stateDir </> show (pretty repo)
-
-
-blockSource :: MonadIO m => API -> HashRef -> SB.ByteStream m ()
-blockSource api h = do
-  deepScan ScanDeep (const none) (fromHashRef h) (readBlockFrom api . HashRef) $ \ha -> do
-    sec <- lift $ readBlockFrom api (HashRef ha) `orDie` [qc|missed block {pretty ha}|]
-    when (h /= HashRef ha) do
-      SB.fromLazy sec
-
-unpackObjects :: MonadIO m => API -> HashRef -> FilePath -> m ()
-unpackObjects catApi lo path = do
-
-  let logPath = path </> show (pretty lo)
-  let logFile = logPath </> "data"
-
-  liftIO $ createDirectoryIfMissing True logPath
-
-  flags <- getLogFlags (readBlockFrom catApi) lo
-  let gzipped = or $ False : [ True | "gz" <- universeBi flags ]
-  let unzipped = if gzipped then SZip.gunzip else id
-  debug $ "GOT FLAGS:" <+> pretty lo <+> pretty flags
-
-  liftIO $ do
-    runResourceT $ SB.writeFile logFile $ unzipped $ blockSource catApi lo
-
-    gitRepoLogScan True logFile $ \entry mlbs -> do
-
-      let tp = case view gitLogEntryType entry of
-                 GitLogEntryCommit -> Just Commit
-                 GitLogEntryTree   -> Just Tree
-                 GitLogEntryBlob   -> Just Blob
-                 _                 -> Nothing
-
-
-      let r = (,,) <$> tp
-                   <*> view gitLogEntryHash entry
-                   <*> mlbs
-
-      maybe1 r none $ \(t, eh, lbs) -> do
-        let fname = logPath </> show (pretty eh)
-        let pref = fromString (show (pretty t) <> " " <> show (LBS.length lbs) <> "\0")
-        -- debug $ "writing object" <+> pretty eh <+> pretty (LBS.unpack $ LBS.takeWhile (/= '\0') pref)
-        let co = compress (pref <> lbs)
-        liftIO $ LBS.writeFile fname co
-
-retryFor :: RealFrac r => Int -> r -> Timeout 'Seconds  -> IO a -> IO (Maybe a)
-retryFor num waity sleep action = timeout (ceiling $ waity * 1000000) $ go num
-  where
-    go 0 = action
-    go n = ( (Just <$> action) `catch` handler ) >>= maybe (go (n-1)) pure
-    handler (_ :: SomeException) = pause @'Seconds sleep >> pure Nothing
-
-dumbHttpServe :: MonadUnliftIO m => Port -> m ()
-dumbHttpServe pnum = do
-
-  locks <- liftIO $ newMVar (HashMap.empty @HashRef @(MVar ()))
-
-  catApi <- liftIO (retryFor 100 30 0.5 detectHBS2PeerCatAPI) `orDie` [qc|Can't locate hbs2-peer API|]
-
-  notice $ "hbs2-peer API:" <+> pretty catApi
-
-  -- TODO: lru-like-cache-for-unpacked-logs
-  --  Деражть кэш, обновлять в нём таймстемпы
-  --  доступа к логам.
-  --  как только запись протухла - сносить каталог
-  --  с логом, тогда в следующий раз будет обратно
-  --  распакован
-
-  updater <- async $ forever do
-    pause @'Seconds 300
-    pure ()
-
-  runResourceT do
-
-    let myTempDir = "hbs-git-http"
-    temp <- liftIO getCanonicalTemporaryDirectory
-
-    (_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive
-
-
-    liftIO $ scotty pnum $ do
-
-      middleware logStdoutDev
-
-      get "/:repo/info/refs" $ do
-        repo <- param @RepoRef "repo"
-        res <- liftIO do
-          db <- makeDbPath repo >>= dbEnvReadOnly
-          refs <- withDB db stateGetActualRefs
-          let answ = Text.unlines $ Text.pack <$> [ show (pretty h) <> "\t" <> show (pretty r) | (r,h) <- refs  ]
-          shutdownDB db
-          pure answ
-
-        text res
-
-      -- | REPO OBJECT REF
-      get (regex "^/(.+)/(refs/.+)$") $ do
-        repo <-  fromString <$> param "1"   -- reflog
-        ref  <- param "2"  -- refname
-        val <- liftIO do
-          db <- makeDbPath repo >>= dbEnvReadOnly
-          debug $ "QUERY: " <+> pretty ref
-          val <- withDB db $ stateGetActualRefValue ref
-          shutdownDB db
-          pure val
-
-        maybe1 val (status status404) $ \x -> do
-          text $ Text.pack $ show $ pretty x
-
-      get "/:repo/objects/:dd/:rest" $ do
-        repo <- param @RepoRef "repo"
-        dd   <- param @String "dd"
-        rest <- param @String "rest"
-        let ha = fromString ( dd <> rest )
-
-        res <- runMaybeT do
-                 db <- liftIO $ makeDbPath repo >>= dbEnvReadOnly
-                 lo <- MaybeT $ liftIO $ withDB db $ stateGetGitLogObject ha
-                 shutdownDB db
-
-                 let logDir = dir </> show (pretty lo)
-                 let fname = logDir </> show (pretty ha)
-
-                 here <- liftIO $ doesFileExist fname
-
-                 if here then do
-                   pure fname
-                 else do
-                    lock <- liftIO $ getLock locks lo
-                    MaybeT $ liftIO $ withMVar lock $ \_ -> do
-                      unpackObjects catApi lo dir
-                      here1 <- liftIO $ doesFileExist fname
-                      if here1 then do
-                        pure (Just fname)
-                      else do
-                        pure Nothing
-
-        maybe1 res (status status404) $ \r -> do
-          addHeader "content-type" "application/octet-stream"
-          file r
-
-      get "/:topic/HEAD" $ do
-        repo <- fromString <$> param "topic"
-        headRef <- liftIO $ do
-          db <- liftIO $ makeDbPath repo >>= dbEnvReadOnly
-          re <- withDB db stateGetActualRefs <&> headMay . sortOn guessHead . fmap (view _1)
-          shutdownDB db
-          pure re
-
-        case headRef of
-          Nothing -> status status404
-          Just hd -> do
-            text [qc|ref: {show $ pretty $ hd}|]
-
-  cancel updater
-
-  where
-    getLock locks k = modifyMVar locks $ \m -> do
-        case HashMap.lookup k m of
-            Just lock -> return (m, lock)
-            Nothing -> do
-                lock <- newMVar ()
-                pure (HashMap.insert k lock m, lock)
-
-
-
-  -- TODO: hbs2-peer-http-api-reflog-fetch
-  --  Ручка, что бы сделать reflog fetch
-
-  -- TODO: hbs2-peer-dyn-reflog-subscribe
-  --   Возможность динамически подписываться на рефлоги
-
-  -- TODO: hbs2-peer-hook-on-reflog-update
-  --  нужен хук, который даст возможность обрабатывать апдейты
-  --  по нужному рефлогу. нужно много где
-
-
-main :: IO ()
-main = do
-
-  setLogging @DEBUG  debugPrefix
-  setLogging @INFO   defLog
-  setLogging @ERROR  errorPrefix
-  setLogging @WARN   warnPrefix
-  setLogging @NOTICE noticePrefix
-  setLoggingOff @TRACE
-
-  -- TODO: hbs2-git-own-config
-
-  -- FIXME: port-number-to-config
-  dumbHttpServe 4017
-
-
-

hbs2-git/hbs2-git.cabal

@@ -184,29 +184,32 @@ executable git-remote-hbs2
     hs-source-dirs:   git-hbs2
     default-language: Haskell2010
 
--- FIXME: make-git-hbs2-http-work-again
--- executable git-hbs2-http
---     import:           shared-properties
---     main-is:          GitHttpDumbMain.hs
 
---     ghc-options:
+executable hbs2-reposync
---         -threaded
+    import:           shared-properties
---         -rtsopts
+    main-is:          ReposyncMain.hs
---         "-with-rtsopts=-N4 -A64m -AL256m -I0"
 
---     other-modules:
+    ghc-options:
+        -threaded
+        -rtsopts
+        "-with-rtsopts=-N4 -A64m -AL256m -I0"
 
---     -- other-extensions:
+    other-modules:
---     build-depends:
+
---         base, hbs2-git
+    -- other-extensions:
---       , http-types
+    build-depends:
---       , optparse-applicative
+        base, hbs2-git, hbs2-core, hbs2-peer
---       , scotty
+      , optparse-applicative
---       , wai-extra
+      , unliftio
---       , warp
+      , terminal-progress-bar
---       , zlib
+      , http-types
+      , scotty
+      , wai
+      , wai-middleware-static
+      , wai-extra
+
+    hs-source-dirs:   reposync
+    default-language: Haskell2010
 
---     hs-source-dirs:   git-hbs2-http
---     default-language: Haskell2010
 
 

hbs2-git/lib/HBS2Git/Config.hs

@@ -3,7 +3,7 @@ module HBS2Git.Config
   , module Data.Config.Suckless
   ) where
 
-import HBS2.Prelude
+import HBS2.Prelude.Plated
 import HBS2.Base58
 import HBS2.System.Logger.Simple
 import HBS2.OrDie
@@ -17,6 +17,8 @@ import Control.Applicative
 import Data.Functor
 import System.FilePath
 import System.Directory
+import Data.Maybe
+import Data.Either
 
 import System.Environment
 
@@ -36,12 +38,6 @@ findGitDir dir = liftIO do
                then return Nothing
                else findGitDir parentDir
 
--- Finds .git dir inside current directory moving upwards
-findWorkingGitDir :: MonadIO m => m FilePath
-findWorkingGitDir = do
-  this <- liftIO getCurrentDirectory
-  findGitDir this `orDie` ".git directory not found"
-
 configPathOld :: MonadIO m => FilePath -> m FilePath
 configPathOld pwd = liftIO do
   xdg <- liftIO $ getXdgDirectory XdgConfig appName
@@ -55,9 +51,27 @@ configPath _ = liftIO do
   pwd <- liftIO getCurrentDirectory
   git <- findGitDir pwd
   byEnv <- lookupEnv "GIT_DIR"
-  -- hPrint stderr ("BY-ENV", byEnv)
+
+  bare <- if isJust (git <|> byEnv) then do
+            pure Nothing
+          else do
+            -- check may be it's a bare git repo
+            gitConf <- readFile "config"
+                         <&> parseTop
+                         <&> fromRight mempty
+
+            let core = or [True | SymbolVal @C "core" <- universeBi gitConf]
+            let bare = or [True | ListVal @C [SymbolVal @C "bare", _, SymbolVal @C "true"] <- universeBi gitConf ]
+            let repo = or [True | SymbolVal @C "repositoryformatversion" <- universeBi gitConf ]
+
+            if core && bare && repo then do
+                pure $ Just (pwd </> ".hbs2")
+            else
+                pure Nothing
+
+  -- hPrint stderr appName
   -- hPrint stderr =<< getEnvironment
-  path <- pure (git <|> byEnv) `orDie`  "*** hbs2-git: .git directory not found"
+  path <- pure (git <|> byEnv <|> bare) `orDie`  "*** hbs2-git: .git directory not found"
   pure (takeDirectory path </> ".hbs2")
 
 data ConfigPathInfo = ConfigPathInfo {

hbs2-git/reposync/ReposyncMain.hs

@@ -0,0 +1,400 @@
+{-# Language TemplateHaskell #-}
+module Main where
+
+import HBS2.Prelude.Plated
+import HBS2.OrDie
+import HBS2.Data.Types.Refs (HashRef(..))
+import HBS2.Net.Proto.Types
+import HBS2.Net.Proto.RefLog
+import HBS2.Peer.RPC.Client.Unix hiding (Cookie)
+import HBS2.Peer.RPC.API.RefLog
+import HBS2.Clock
+
+-- import HBS2Git.PrettyStuff
+import HBS2.System.Logger.Simple hiding (info)
+import HBS2.System.Logger.Simple qualified as Log
+
+import Data.Config.Suckless
+import Data.Config.Suckless.Syntax
+import Data.Config.Suckless.KeyValue
+
+
+import Control.Monad.Catch
+import Control.Monad.Except
+import Control.Monad.Reader
+import Data.ByteString.Lazy.Char8 qualified as LBS
+import Data.Either
+import Data.List qualified as List
+import Data.Maybe
+import Data.Text qualified as Text
+import Lens.Micro.Platform
+import Network.Wai (Middleware, pathInfo, rawPathInfo, lazyRequestBody)
+import Network.Wai.Middleware.Static (staticPolicy, addBase)
+import Network.Wai.Middleware.RequestLogger (logStdoutDev)
+import Options.Applicative
+import qualified Data.Text.Encoding as TE
+import System.Directory
+import System.FilePath
+import System.Process.Typed
+import Text.InterpolatedString.Perl6 (qc)
+import UnliftIO
+import Web.Scotty hiding (header,next)
+
+-- import Control.Monad
+import System.Exit qualified as Exit
+import System.IO.Unsafe (unsafePerformIO)
+
+-- TODO: support-encrypted-repoes
+
+die :: (MonadIO m, Show msg) => msg -> m a
+die msg = liftIO $ Exit.die [qc|{msg}|]
+
+data RepoInitException = RepoInitException FilePath deriving (Show, Typeable)
+instance Exception RepoInitException
+
+debugPrefix :: SetLoggerEntry
+debugPrefix  = toStdout . logPrefix "[debug] "
+
+errorPrefix :: SetLoggerEntry
+errorPrefix  = toStdout . logPrefix "[error] "
+
+warnPrefix :: SetLoggerEntry
+warnPrefix  = toStdout . logPrefix "[warn] "
+
+noticePrefix :: SetLoggerEntry
+noticePrefix  = toStdout . logPrefix "[notice] "
+
+data ReposyncRootKey
+data ReposyncHttpPort
+
+instance Monad m => HasCfgKey ReposyncRootKey (Maybe String) m where
+  key = "root"
+
+instance Monad m => HasCfgKey ReposyncHttpPort (Maybe Int) m where
+  key = "http-port"
+
+data RepoEntry =
+  RepoEntry
+  { repoPath :: FilePath
+  , repoRef  :: RefLogKey HBS2Basic
+  , repoKeys :: [FilePath]
+  , repoHash :: TVar (Maybe HashRef)
+  }
+  deriving stock (Eq)
+
+
+data ReposyncState =
+
+  ReposyncState
+  { _rpcSoname         :: FilePath
+  , _rpcRefLog         :: ServiceCaller RefLogAPI UNIX
+  , _reposyncBaseDir   :: FilePath
+  , _reposyncPort      :: Int
+  , _reposyncEntries   :: TVar [RepoEntry]
+  }
+
+makeLenses 'ReposyncState
+
+newtype ReposyncM m a =
+  App { unReposyncM :: ReaderT ReposyncState m a }
+  deriving newtype ( Applicative
+                   , Functor
+                   , Monad
+                   , MonadIO
+                   , MonadThrow
+                   , MonadReader ReposyncState
+                   , MonadUnliftIO
+                   , MonadTrans
+                   )
+
+
+myName :: FilePath
+myName = "hbs2-reposync"
+
+reposyncDefaultDir :: FilePath
+reposyncDefaultDir = unsafePerformIO do
+  getXdgDirectory XdgData (myName </> "repo")
+{-# NOINLINE reposyncDefaultDir #-}
+
+newState :: MonadUnliftIO m
+         => FilePath
+         -> ServiceCaller RefLogAPI UNIX
+         -> m ReposyncState
+
+newState so refLog =
+  ReposyncState so refLog reposyncDefaultDir 4017 <$> newTVarIO mempty
+
+withConfig :: forall a m . (MonadUnliftIO m) => Maybe FilePath -> ReposyncM m a -> ReposyncM m ()
+withConfig cfg m = do
+
+  let defDir  = reposyncDefaultDir
+  defConfDir <- liftIO $ getXdgDirectory XdgConfig myName
+
+  realCfg <- case cfg of
+             Just f -> pure f
+             Nothing -> do
+                liftIO do
+                  let conf = defConfDir </> "config"
+                  createDirectoryIfMissing True defConfDir
+                  appendFile conf ""
+                  pure conf
+
+  syn <- liftIO (readFile realCfg) <&> parseTop
+                                   <&> fromRight mempty
+
+  ev <- asks (view reposyncEntries)
+
+  let root = runReader (cfgValue @ReposyncRootKey) syn
+              & fromMaybe defDir
+
+  let port = runReader (cfgValue @ReposyncHttpPort) syn
+              & fromMaybe 4017
+
+  es <- entries root syn
+  atomically $ modifyTVar ev (\x -> List.nub ( x <> es))
+
+  local ( set reposyncBaseDir root .
+          set reposyncPort port
+        ) (void m)
+
+  where
+    entries root syn = do
+
+      let findKeys w = [ Text.unpack p
+                       | ListVal @C (Key "decrypt" [LitStrVal p]) <- w
+                       ]
+
+      let reflogs = catMaybes [ (,) <$> fromStringMay @(RefLogKey HBS2Basic) (Text.unpack o)
+                                    <*> pure (findKeys args)
+                              | ListVal @C (Key "reflog" (LitStrVal o : args)) <- syn
+                              ]
+
+      forM reflogs $ \(repo, keys) -> do
+        let path = show $ pretty repo
+        mt <- newTVarIO Nothing
+        pure $ RepoEntry (root </> path) repo keys mt
+
+
+-- WTF1?
+runSync :: (MonadUnliftIO m, MonadThrow m) => ReposyncM m ()
+runSync = do
+  es <- asks (view reposyncEntries) >>= readTVarIO
+  so <- asks (view rpcSoname)
+
+  refLogRPC <- asks (view rpcRefLog)
+
+  root <- asks (view reposyncBaseDir)
+  port <- asks (view reposyncPort) <&> fromIntegral
+
+  http <- async $ liftIO $ scotty port $ do
+              middleware $ staticPolicy (addBase root)
+              middleware logStdoutDev
+              get "/" $ do
+                text "This is hbs2-reposync"
+
+  r <- forM es $ \entry -> async $ void $ do
+          let rk = fromRefLogKey $ repoRef entry
+          tv <- newTVarIO Nothing
+
+          debug $ "STARTED WITH" <+> pretty (repoPath entry)
+
+          initRepo entry
+
+          fix \next -> do
+
+            rr' <- race (pause @'Seconds 1) do
+                      callService @RpcRefLogGet refLogRPC rk
+                          <&> fromRight Nothing
+
+            rr <- either (const $ pause @'Seconds 10 >> warn "rpc call timeout" >>  next) pure rr'
+
+            debug $ "REFLOG VALUE:" <+> pretty rr
+
+            r0 <- readTVarIO tv
+
+            if rr == r0 then do
+              pause @'Seconds 60
+            else do
+              debug $ "Syncronize repoes!" <+> pretty (repoPath entry)
+              syncRepo entry >>= \case
+                Left{} -> pause @'Seconds 60
+                Right{} -> do
+                  atomically $ writeTVar tv rr
+                  pause @'Seconds 10
+
+            next
+
+  mapM_ waitCatch (http : r)
+
+
+data SyncError = SyncError
+
+syncRepo :: (MonadUnliftIO m, MonadThrow m) => RepoEntry -> m (Either SyncError ())
+syncRepo (RepoEntry{..}) = runExceptT do
+
+  -- let cfg = shell [qc|git fetch origin && git remote update origin|] & setWorkingDir repoPath
+  let cfg = shell [qc|git remote update origin && git remote prune origin|] & setWorkingDir repoPath
+  code <- runProcess cfg
+
+  case code of
+    ExitFailure{} -> do
+      err $ "Unable to sync repo" <+> pretty repoPath
+      throwError SyncError
+
+    _             -> debug $ "synced" <+> pretty repoPath
+
+
+  let readLocalBranches = shell [qc|git for-each-ref refs/heads|]
+                            & setWorkingDir repoPath
+
+  let readBranches = shell [qc|git ls-remote origin|]
+                       & setWorkingDir repoPath
+
+  (_, o, _) <- readProcess readBranches
+
+  let txt = TE.decodeUtf8 (LBS.toStrict o)
+
+  let ls = Text.lines txt & fmap Text.words
+
+  let refs = [ (b,a) | [a,b] <- ls ]
+
+  -- TODO: remove-only-vanished-refs
+  unless (null refs) do
+
+    (_, o, _) <- readProcess readLocalBranches
+    let out = TE.decodeUtf8 (LBS.toStrict o)
+                 & Text.lines
+                 & fmap Text.words
+
+    let refs = [ r | [_,_,r] <- out ]
+    forM_ refs $ \r -> do
+      -- debug $ "REMOVING REF" <+> pretty r
+      let cmd = shell [qc|git update-ref -d {r}|] & setWorkingDir repoPath
+      void $ runProcess cmd
+
+  forM_ refs $ \(ref, val) -> do
+    -- debug $ "SET REFERENCE" <+> pretty ref <+> pretty val
+    let updateBranch = shell [qc|git update-ref {ref} {val}|]
+                        & setWorkingDir repoPath
+                        & setStdout closed
+                        & setStderr closed
+
+    void $ readProcess updateBranch
+
+    void $ runProcess (shell "git update-server-info" & setWorkingDir repoPath)
+
+  -- let gc = shell [qc|git gc|] & setWorkingDir repoPath
+  -- void $ runProcess gc
+
+regenConfig :: MonadUnliftIO m => RepoEntry -> ReposyncM m ()
+regenConfig RepoEntry{..} = do
+
+  let hbs2conf = repoPath </> ".hbs2/config"
+  rpc <- asks (view rpcSoname)
+
+  let config = ";; generated by hbs2-reposync" <> line
+               <> "rpc" <+> "unix" <+> viaShow rpc <> line
+               <> line
+               <> vcat (fmap (("decrypt"<+>) . dquotes.pretty) repoKeys)
+
+  liftIO $ writeFile hbs2conf (show config)
+
+initRepo :: (MonadUnliftIO m, MonadThrow m) => RepoEntry -> ReposyncM m ()
+initRepo e@(RepoEntry{..}) = do
+  debug $ "initRepo" <+> pretty repoPath
+
+  let gitDir = repoPath
+  gitHere <- liftIO $ doesDirectoryExist gitDir
+
+  liftIO $ createDirectoryIfMissing True gitDir
+  debug $ "create dir" <+> pretty gitDir
+
+  let hbs2 = gitDir </> ".hbs2"
+  liftIO $ createDirectoryIfMissing True hbs2
+
+  regenConfig e
+
+  unless gitHere do
+
+    let cfg = shell [qc|git init --bare && git remote add origin hbs2://{pretty repoRef}|]
+                 & setWorkingDir repoPath
+
+    code <- runProcess cfg
+
+    case code of
+      ExitFailure{} -> do
+        err $ "Unable to init git repository:" <+> pretty gitDir
+        throwM $ RepoInitException gitDir
+
+      _ -> pure ()
+
+
+detectRPC :: (MonadUnliftIO m) => m (Maybe FilePath)
+detectRPC = do
+  (_, o, _) <- readProcess (shell [qc|hbs2-peer poke|])
+  let answ = parseTop (LBS.unpack o) & fromRight mempty
+
+  pure (headMay [ Text.unpack r | ListVal (Key "rpc:" [LitStrVal r]) <- answ  ])
+
+
+withApp :: forall a m . MonadUnliftIO m
+        => Maybe FilePath
+        -> ReposyncM m a
+        -> m ()
+
+withApp cfg m = do
+
+  setLogging @DEBUG  debugPrefix
+  setLogging @INFO   defLog
+  setLogging @ERROR  errorPrefix
+  setLogging @WARN   warnPrefix
+  setLogging @NOTICE noticePrefix
+
+  soname <- detectRPC `orDie` "RPC not found"
+
+  client <- race ( pause @'Seconds 1) (newMessagingUnix False 1.0 soname) `orDie` "hbs2-peer rpc timeout!"
+
+  rpc <- makeServiceCaller (fromString soname)
+
+  messaging <- async $ runMessagingUnix client
+  link messaging
+
+  let endpoints = [ Endpoint @UNIX  rpc
+                  ]
+
+  c1 <- async $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
+
+  state <- newState soname rpc
+
+  r <- async $ void $ runReaderT (unReposyncM $ withConfig cfg m) state
+
+  waitAnyCatchCancel [c1, messaging, r]
+
+  setLoggingOff @DEBUG
+  setLoggingOff @INFO
+  setLoggingOff @ERROR
+  setLoggingOff @WARN
+  setLoggingOff @NOTICE
+
+
+main :: IO ()
+main = runMe .  customExecParser (prefs showHelpOnError) $
+  info (helper <*> ((,) <$> opts <*> parser))
+  (  fullDesc
+  <> header "hbs2-reposync"
+  <> progDesc "syncronizes hbs2-git repositories"
+  )
+  where
+    -- parser ::  Parser (IO ())
+    parser = hsubparser (  command "run" (info pRun (progDesc "run syncronization"))
+                        )
+
+    runMe x = do
+      (o, run) <- x
+      withApp o run
+
+    opts = optional $ strOption (short 'c' <> long "config")
+
+    pRun = do
+      pure runSync
+

hbs2-git/reposync/examples/config

@@ -0,0 +1,19 @@
+
+rpc unix "/tmp/hbs2-rpc.socket"
+
+; http-port 4017
+
+; root "/home/dmz/.local/share/hbs2-reposync/repo"
+
+;; single reflog
+
+[ reflog "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
+;; options may go here if any
+]
+
+[ reflog  "JCVvyFfj1C21QfFkcjrFN6CoarykfAf6jLFpCNNKjP7E"
+  (decrypt "/home/dmz/w/hbs2/owner.key")
+]
+
+
+