From 19fe110fee1712524a89548c199d6b90c8d41834 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Sun, 19 Jan 2025 22:49:52 +0300 Subject: [PATCH] wip, missed --- hbs2-git3/lib/HBS2/Git3/Repo.hs | 231 ++++++++++++++++++++++++++++++++ 1 file changed, 231 insertions(+) create mode 100644 hbs2-git3/lib/HBS2/Git3/Repo.hs diff --git a/hbs2-git3/lib/HBS2/Git3/Repo.hs b/hbs2-git3/lib/HBS2/Git3/Repo.hs new file mode 100644 index 00000000..cb38b408 --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/Repo.hs @@ -0,0 +1,231 @@ +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module HBS2.Git3.Repo ( initRepo, waitRepo + , getRepoRefMaybe + , getRepoManifest + , HasGitRemoteKey(..) + ) where + +import HBS2.Git3.Prelude +import HBS2.Git3.State + +import HBS2.CLI.Run.MetaData +import HBS2.Net.Auth.Credentials + +import HBS2.Data.Detect ( readLogThrow ) +import HBS2.CLI.Run.Internal.Merkle (getTreeContents) +import HBS2.CLI.Run.RefLog (getCredentialsForReflog,mkRefLogUpdateFrom) + +import HBS2.Git3.Config.Local + +import HBS2.KeyMan.Keys.Direct + +import Data.Config.Suckless.Script +import Data.Config.Suckless.Almost.RPC + +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString.Lazy qualified as LBS +import Data.Text.Encoding qualified as TE +import Data.Text.Encoding.Error qualified as TE +import Data.Word +import Lens.Micro.Platform + +import System.Random hiding (next) + +{- HLINT ignore "Functor law"-} + +data CInit = + CheckRepoKeyExist + | CreateRepoKey + | CheckRepoKeyStart GitRepoKey + | CheckRepoKeyWait TimeSpec (Timeout 'Seconds) GitRepoKey + | CheckRepoDefBlock GitRepoKey (LWWRef 'HBS2Basic) + | CreateRepoDefBlock GitRepoKey + + +data ReflogWaitTimeout = + ReflogWaitTimeout + deriving stock (Show,Typeable) + +instance Exception ReflogWaitTimeout + +waitRepo :: forall m . HBS2GitPerks m => Git3 m () +waitRepo = do + repoKey <- getGitRepoKey >>= orThrow GitRepoRefNotSet + + lwwAPI <- getClientAPI @LWWRefAPI @UNIX + peerAPI <- getClientAPI @PeerAPI @UNIX + reflogAPI <- getClientAPI @RefLogAPI @UNIX + + env <- ask + + callRpcWaitMay @RpcLWWRefFetch (TimeoutSec 1) lwwAPI (LWWRefKey repoKey) + >>= orThrowUser "rpc timeout while subscribing to LWWRef" + + let maxTimeout = ceiling 30e9 -- Максимальное время ожидания (30 секунд) + startTime <- getTimeCoarse + + flip runContT pure do + + let periodicFetch reflog = forever $ do + callRpcWaitMay @RpcRefLogFetch (TimeoutSec 1) reflogAPI reflog + >>= orThrowUser "rpc timeout while fetching reflog" + pause @'Seconds 10 -- Засыпаем на 10 секунд + + let waitForReflog till reflog = do + now <- getTimeCoarse + + if now > till + then throwIO ReflogWaitTimeout + else do + mhead <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflogAPI (coerce reflog) + case mhead of + Just headVal -> do + debug $ "waitRepo: Reflog data arrived" <+> pretty headVal + + Nothing -> pause @'Seconds 1 >> waitForReflog till reflog + + let waitForLWWRef till = liftIO $ withGit3Env env do + now <- getTimeCoarse + + if now > till + then throwIO RpcTimeout + else do + rv <- getRepoRefMaybe + maybe1 rv (pause @'Seconds 1 >> waitForLWWRef till) $ \LWWRef{..} -> do + debug $ "waitRepo: LWWRef arrived" <+> pretty lwwValue + + -- Парсим манифест репозитория + repo <- getRepoManifest + + -- Достаём `reflog` + reflog <- [ x | ListVal [SymbolVal "reflog", SignPubKeyLike x] <- repo ] + & headMay + & orThrowUser "malformed repo manifest" + + -- Подписываемся на `reflog` + callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (reflog, "reflog", 17) + >>= orThrowUser "rpc timeout while subscribing to reflog" + + debug $ "waitRepo: Subscribed to reflog" <+> pretty (AsBase58 reflog) + + -- Запускаем асинхронную задачу для периодического вызова RpcRefLogFetch + withAsync (periodicFetch reflog) $ \_ -> do + -- Ждём появления значений в `reflog` + waitForReflog till reflog + + liftIO $ withGit3Env env $ waitForLWWRef (startTime + fromNanoSecs maxTimeout) + +initRepo :: forall m . HBS2GitPerks m => [Syntax C] -> Git3 m () +initRepo syn = do + + let (opts, _) = splitOpts [("--new",0)] syn + + let new = or [ True | ListVal [SymbolVal "--new"] <- opts ] + + root <- getConfigRootFile + + sto <- getStorage + lwwAPI <- getClientAPI @LWWRefAPI @UNIX + refLogAPI <- getClientAPI @RefLogAPI @UNIX + peerAPI <- getClientAPI @PeerAPI @UNIX + + flip fix CheckRepoKeyExist $ \next -> \case + CheckRepoKeyExist -> do + debug "initRepo:CheckRepoKey" + mbk <- getGitRepoKey + next $ maybe CreateRepoKey CheckRepoKeyStart mbk + + CreateRepoKey -> do + debug "initRepo:CreateRepoKey" + + answ <- callProc "hbs2-cli" [] [mkSym "hbs2:lwwref:create"] + + pk <- [ x | ListVal [SymbolVal "pk", SignPubKeyLike x] <- answ ] + & lastMay + & orThrowUser "can't create new lwwref" + + liftIO $ appendFile root (show $ pretty $ mkForm "repo:key" [mkSym @C (show $ pretty (AsBase58 pk))]) + + CheckRepoKeyStart pk -> do + debug $ "initRepo:CheckRepoKeyStart" <+> pretty (AsBase58 pk) + + callRpcWaitMay @RpcLWWRefFetch (TimeoutSec 1) lwwAPI (LWWRefKey pk) + >>= orThrowUser "rpc timeout" + + now <- getTimeCoarse + + let waity = if new then ceiling 0.5e9 else ceiling 30e9 + + let till = TimeoutTS (now + fromNanoSecs waity ) + + next $ CheckRepoKeyWait (coerce till) 1.0 pk + + CheckRepoKeyWait till w pk -> do + + debug $ "initRepo:CheckRepoKeyWait" <+> pretty (AsBase58 pk) + + rv <- getRepoRefMaybe + + now <- getTimeCoarse + + if now > till then do + next $ CreateRepoDefBlock pk + else do + maybe1 rv (pause w >> next (CheckRepoKeyWait till (1.10 * w) pk)) + (next . CheckRepoDefBlock pk) + + CheckRepoDefBlock pk LWWRef{..} -> do + debug $ "init:CheckRepoDefBlock" <+> pretty (AsBase58 pk) <+> pretty lwwValue + + repo <- getRepoManifest + + reflog <- [ x | ListVal [SymbolVal "reflog", SignPubKeyLike x] <- repo ] + & headMay & orThrowUser "malformed repo manifest" + + callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (reflog, "reflog", 17) + >>= orThrowUser "rpc timeout" + + liftIO $ print $ pretty repo + + CreateRepoDefBlock pk -> do + + debug $ "init:CreateRepoDefBlock" <+> pretty (AsBase58 pk) + + seed <- randomIO @Word64 + + creds <- runKeymanClientRO (loadCredentials pk) + >>= orThrowUser ("not found credentials for" <+> pretty (AsBase58 pk)) + + let (wsk,wpk) = (view peerSignSk creds, view peerSignPk creds) + + let sk = view peerSignSk creds + (rpk,rsk) <- derivedKey @'HBS2Basic @'Sign seed sk + + let manifest = [ + mkForm @C "hbs2-git" [mkInt 3] + , mkForm "seed" [mkInt seed] + , mkForm "public" [] + , mkForm "reflog" [mkSym (show $ pretty (AsBase58 rpk))] + ] & vcat . fmap pretty + + tree <- createTreeWithMetadata sto Nothing mempty (LBS8.pack (show $ manifest)) + >>= orThrowPassIO + + liftIO $ print tree + + let pt = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) [tree] + + blk <- makeMerkle 0 pt $ \(_,_,bs) -> do + void $ putBlock sto bs + + notice $ "current root" <+> pretty blk <+> pretty tree + + let box = makeSignedBox wpk wsk (LWWRef 3 (coerce blk) Nothing) + + callRpcWaitMay @RpcLWWRefUpdate (TimeoutSec 1) lwwAPI box + >>= orThrowUser "rpc timeout" + + callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (rpk, "reflog", 17) + >>= orThrowUser "rpc timeout" +