mirror of https://github.com/voidlizard/hbs2
basic tool for hbs2 repo syncronization
This commit is contained in:
Dmitry Zuikov
parent
374f7bdea2
commit
6661006974
|
|
@ -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": {
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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")
|
||||
]
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue