diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal index 3b9038e8..360f9b03 100644 --- a/hbs2-git3/hbs2-git3.cabal +++ b/hbs2-git3/hbs2-git3.cabal @@ -125,8 +125,10 @@ library HBS2.Git3.Prelude HBS2.Git3.Export HBS2.Git3.Import - HBS2.Git3.Repo HBS2.Git3.Repo.Fork + HBS2.Git3.Repo.Init + HBS2.Git3.Repo.Types + HBS2.Git3.Repo HBS2.Git3.Run HBS2.Git3.Logger HBS2.Git3.State diff --git a/hbs2-git3/lib/HBS2/Git3/Repo.hs b/hbs2-git3/lib/HBS2/Git3/Repo.hs index 3bd7e491..d667da71 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo.hs @@ -1,170 +1,12 @@ -{-# Language UndecidableInstances #-} -{-# Language AllowAmbiguousTypes #-} -{-# Language PatternSynonyms #-} -{-# Language ViewPatterns #-} -module HBS2.Git3.Repo ( initRepo, waitRepo +module HBS2.Git3.Repo ( waitRepo , getRepoRefMaybe , getRepoManifest , HasGitRemoteKey(..) - , pattern RepoURL + , module Exported ) where -import HBS2.Git3.Prelude import HBS2.Git3.State -import HBS2.CLI.Run.MetaData -import HBS2.Net.Auth.Credentials - -import HBS2.KeyMan.Keys.Direct - -import Data.Config.Suckless.Script -import Data.Config.Suckless.Almost.RPC - -import Data.HashSet qualified as HS -import Data.Text qualified as Text -import Data.ByteString.Lazy.Char8 qualified as LBS8 -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 - - -pattern RepoURL :: GitRemoteKey -> Syntax C -pattern RepoURL x <- (isRepoURL -> Just x) - -isRepoURL :: Syntax C -> Maybe GitRemoteKey -isRepoURL = \case - TextLike xs -> case mkList @C (fmap mkStr (Text.splitOn "://" xs)) of - ListVal [TextLike pref, SignPubKeyLike puk] | pref `HS.member` prefixes -> Just puk - _ -> Nothing - - _ -> Nothing - - where - prefixes = HS.fromList [ "hbs2", "hbs23" ] - -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:ref" [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 <- getRefLog repo & orThrow GitRepoManifestMalformed - - callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (reflog, "reflog", 17) - >>= orThrowUser "rpc timeout" - - -- FIXME: remove-this - liftIO $ print $ pretty $ mkForm "manifest" (coerce 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))] - ] - - let mfs = vcat $ fmap pretty manifest - - tree <- createTreeWithMetadata sto Nothing mempty (LBS8.pack (show $ mfs)) - >>= orThrowPassIO - - liftIO $ print $ pretty $ mkForm "manifest" manifest - - 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" +import HBS2.Git3.Repo.Types as Exported +import HBS2.Git3.Repo.Init as Exported diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Fork.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Fork.hs index 72d57373..92e54f9c 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo/Fork.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo/Fork.hs @@ -2,6 +2,7 @@ module HBS2.Git3.Repo.Fork (forkEntries) where import HBS2.Git3.Prelude import HBS2.Git3.State +import HBS2.Git3.Repo.Init import HBS2.Git3.Git import HBS2.Data.Detect @@ -41,15 +42,30 @@ import System.IO qualified as IO import System.IO.Temp as Temp import UnliftIO.Concurrent +import Text.InterpolatedString.Perl6 (qc) forkEntries :: forall m . (HBS2GitPerks m) => Id -> MakeDictM C (Git3 m) () forkEntries prefix = do - entry $ bindMatch (prefix <> "fork") $ nil_ $ \case - [ SignPubKeyLike what ] -> lift $ connectedDo do - error $ show $ "not yet" <+> pretty (AsBase58 what) - r <- callProc "git" ["--init"] [] - none + brief "forks hbs2-git repository" + $ desc ("All new repo creation boilerplate:" <> line + <> "creates a new sign key," + <+> "creates a new lww reference," + <+> "adds this key to hbs2-keyman," <> line + <> "creates default repo manifest") + $ args [ arg "key" "repo-ref" ] + $ examples [qc| +hbs2-git repo:fork EvP3kskPVuKuKVMUc3LnfdW7GcFYjz6f5fFU1EGzrdgk +|] $ + entry $ bindMatch (prefix <> "fork") $ nil_ $ \case + [ SignPubKeyLike what ] -> lift do + + r <- callProc "git" ["--init", "."] [] + + none + + -- initRepo [newRepoOpt] + + _ -> throwIO $ BadFormException @C nil - _ -> throwIO $ BadFormException @C nil diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs new file mode 100644 index 00000000..ada2ba9d --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs @@ -0,0 +1,152 @@ +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module HBS2.Git3.Repo.Init (initRepo,newRepoOpt) where + +import HBS2.Git3.Prelude +import HBS2.Git3.State + +import HBS2.CLI.Run.MetaData +import HBS2.Net.Auth.Credentials + +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.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 + +newRepoOpt :: Syntax C +newRepoOpt = mkList [mkSym "--new"] + +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:ref" [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 <- getRefLog repo & orThrow GitRepoManifestMalformed + + callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (reflog, "reflog", 17) + >>= orThrowUser "rpc timeout" + + -- FIXME: remove-this + liftIO $ print $ pretty $ mkForm "manifest" (coerce 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))] + ] + + let mfs = vcat $ fmap pretty manifest + + tree <- createTreeWithMetadata sto Nothing mempty (LBS8.pack (show $ mfs)) + >>= orThrowPassIO + + liftIO $ print $ pretty $ mkForm "manifest" manifest + + 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 + + now <- liftIO getPOSIXTime <&> round + + let box = makeSignedBox wpk wsk (LWWRef now (coerce blk) Nothing) + + callRpcWaitMay @RpcLWWRefUpdate (TimeoutSec 1) lwwAPI box + >>= orThrowUser "rpc timeout" + + callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (rpk, "reflog", 17) + >>= orThrowUser "rpc timeout" + diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Types.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Types.hs new file mode 100644 index 00000000..066cc7cb --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/Repo/Types.hs @@ -0,0 +1,24 @@ +module HBS2.Git3.Repo.Types where + +import HBS2.Git3.Prelude + +import Data.Config.Suckless.Script + +import Data.HashSet qualified as HS +import Data.Text qualified as Text + +pattern RepoURL :: GitRemoteKey -> Syntax C +pattern RepoURL x <- (isRepoURL -> Just x) + +isRepoURL :: Syntax C -> Maybe GitRemoteKey +isRepoURL = \case + TextLike xs -> case mkList @C (fmap mkStr (Text.splitOn "://" xs)) of + ListVal [TextLike pref, SignPubKeyLike puk] | pref `HS.member` prefixes -> Just puk + _ -> Nothing + + _ -> Nothing + + where + prefixes = HS.fromList [ "hbs2", "hbs23" ] + +