diff --git a/flake.lock b/flake.lock index cba1b7bc..297ddfe5 100644 --- a/flake.lock +++ b/flake.lock @@ -295,11 +295,11 @@ ] }, "locked": { - "lastModified": 1696297671, - "narHash": "sha256-jPWuqQlXKRnkU2A19nwtzDHI6bnICzFwDffx2qj/sCM=", + "lastModified": 1697251648, + "narHash": "sha256-dT305J8wIJLIbuVi4YhtaeaquNtVxFhutbB2tgsu938=", "owner": "voidlizard", "repo": "suckless-conf", - "rev": "a0919addd3f43b7cfddb6c35568495b4a295f1f2", + "rev": "a79097e5b28da8a098405dc9c15235a57f887160", "type": "github" }, "original": { diff --git a/hbs2-git/git-hbs2-http/GitHttpDumbMain.hs b/hbs2-git/git-hbs2-http/GitHttpDumbMain.hs deleted file mode 100644 index 53537a2b..00000000 --- a/hbs2-git/git-hbs2-http/GitHttpDumbMain.hs +++ /dev/null @@ -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 - - - diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index b354fb45..023ab257 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/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: --- -threaded --- -rtsopts --- "-with-rtsopts=-N4 -A64m -AL256m -I0" +executable hbs2-reposync + import: shared-properties + main-is: ReposyncMain.hs --- other-modules: + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N4 -A64m -AL256m -I0" --- -- other-extensions: --- build-depends: --- base, hbs2-git --- , http-types --- , optparse-applicative --- , scotty --- , wai-extra --- , warp --- , zlib + other-modules: + + -- other-extensions: + build-depends: + base, hbs2-git, hbs2-core, hbs2-peer + , optparse-applicative + , unliftio + , terminal-progress-bar + , 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 diff --git a/hbs2-git/lib/HBS2Git/Config.hs b/hbs2-git/lib/HBS2Git/Config.hs index 508c613f..e1c8126a 100644 --- a/hbs2-git/lib/HBS2Git/Config.hs +++ b/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 { diff --git a/hbs2-git/reposync/ReposyncMain.hs b/hbs2-git/reposync/ReposyncMain.hs new file mode 100644 index 00000000..fdd24054 --- /dev/null +++ b/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 + diff --git a/hbs2-git/reposync/examples/config b/hbs2-git/reposync/examples/config new file mode 100644 index 00000000..eed546cb --- /dev/null +++ b/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") +] + + +