From 7b7e44414f5395dab3612cca44be00749f8e237d Mon Sep 17 00:00:00 2001 From: voidlizard Date: Thu, 30 Jan 2025 12:07:21 +0300 Subject: [PATCH] wip --- hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs | 29 ++++--- hbs2-git3/hbs2-git3.cabal | 3 + hbs2-git3/lib/HBS2/Git3/Repo.hs | 32 +------ hbs2-git3/lib/HBS2/Git3/Repo/Init.hs | 27 ++++-- hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs | 84 +++++++++++++++++++ hbs2-git3/lib/HBS2/Git3/Run.hs | 31 ++----- .../lib/HBS2/Git3/State/Internal/Types.hs | 2 + 7 files changed, 134 insertions(+), 74 deletions(-) create mode 100644 hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs diff --git a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs index a3de23e6..2ca6ae06 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs @@ -105,23 +105,26 @@ groupKeyEntries = do _ -> throwIO $ BadFormException @C nil - entry $ bindMatch "hbs2:groupkey:create" $ \syn -> do - case syn of - [ListVal (StringLikeList keys)] -> do - s <- groupKeyFromKeyList keys - <&> AsGroupKeyFile - <&> show . pretty + brief "create group key" $ + args [ arg "keys" "list" ] $ + desc "list of encryption public keys of members" $ + entry $ bindMatch "hbs2:groupkey:create" $ \syn -> do + case syn of + [ListVal (StringLikeList keys)] -> do + s <- groupKeyFromKeyList keys + <&> AsGroupKeyFile + <&> show . pretty - pure $ mkStr s + pure $ mkStr s - StringLikeList keys -> do - s <- groupKeyFromKeyList keys - <&> AsGroupKeyFile - <&> show . pretty + StringLikeList keys -> do + s <- groupKeyFromKeyList keys + <&> AsGroupKeyFile + <&> show . pretty - pure $ mkStr s + pure $ mkStr s - _ -> throwIO $ BadFormException @C nil + _ -> throwIO $ BadFormException @C nil entry $ bindMatch "hbs2:groupkey:dump" $ nil_ $ \syn -> do diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal index 42e22afd..d82f880f 100644 --- a/hbs2-git3/hbs2-git3.cabal +++ b/hbs2-git3/hbs2-git3.cabal @@ -126,6 +126,7 @@ library HBS2.Git3.Export HBS2.Git3.Import HBS2.Git3.Repo.Init + HBS2.Git3.Repo.Tools HBS2.Git3.Repo.Types HBS2.Git3.Repo HBS2.Git3.Run @@ -142,6 +143,8 @@ library HBS2.Data.Log.Structured + Crypto.Bip39 + build-depends: base , base16-bytestring , binary diff --git a/hbs2-git3/lib/HBS2/Git3/Repo.hs b/hbs2-git3/lib/HBS2/Git3/Repo.hs index 8afdc23d..0395e96a 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo.hs @@ -1,44 +1,14 @@ module HBS2.Git3.Repo ( waitRepo , getRepoRefMaybe , getRepoManifest - , listRemotes , HasGitRemoteKey(..) , module Exported ) where -import HBS2.Git3.Prelude -import HBS2.System.Dir - -import HBS2.Git.Local.CLI import HBS2.Git3.State import HBS2.Git3.Repo.Types as Exported import HBS2.Git3.Repo.Init as Exported +import HBS2.Git3.Repo.Tools as Exported -import Data.Config.Suckless -import Data.Either - -{- HLINT ignore "Functor law" -} - -listRemotes :: MonadIO m => m [(GitRef, GitRepoKey)] -listRemotes = do - - git <- findGitDir >>= orThrow NoGitDir - - conf <- liftIO (readFile (git "config")) - <&> parseTop - <&> fromRight mempty - - let urls = flip fix (mempty,Nothing,conf) $ \next -> \case - (acc,_, ListVal [SymbolVal "remote", StringLike x] : rest) -> - next (acc,Just x, rest) - - (acc, Just x, ListVal [SymbolVal "url", _, RepoURL3 u] : rest) -> - next ( (fromString x, u) : acc, Nothing, rest) - - (acc, x, _ : rest) -> next ( acc, x, rest) - - (acc,_,[]) -> acc - - pure urls diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs index 162c229b..e564c7c0 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo/Init.hs @@ -5,11 +5,13 @@ module HBS2.Git3.Repo.Init (initRepo,newRepoOpt,encryptedNewOpt) where import HBS2.Git3.Prelude import HBS2.Git3.State import HBS2.Git3.Repo.Types +import HBS2.Git3.Repo.Tools import HBS2.System.Dir import HBS2.CLI.Run.MetaData import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.GroupKeySymm import HBS2.KeyMan.Keys.Direct @@ -18,7 +20,9 @@ import Data.Config.Suckless.Almost.RPC import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.Word +import Data.Maybe import Data.Text qualified as Text +import Data.HashMap.Strict qualified as HM import Lens.Micro.Platform import System.Random hiding (next) @@ -40,13 +44,15 @@ newRepoOpt = mkSym "--new" encryptedNewOpt :: Syntax C encryptedNewOpt = mkSym "--encrypted" + + initRepo :: forall m . HBS2GitPerks m => [Syntax C] -> Git3 m () initRepo syn = do - let (opts, _) = splitOpts [("--new",0)] syn + let (opts, _) = splitOpts [("--new",0),("--encrypted",1)] syn let new = or [ True | ListVal [SymbolVal "--new"] <- opts ] - let encrypted = or [ True | ListVal [SymbolVal "--encrypted"] <- opts ] + let gkh = lastMay [ gk | ListVal [SymbolVal "--encrypted", HashLike gk] <- opts ] callProc "git" ["init"] [] @@ -142,12 +148,23 @@ initRepo syn = do callRpcWaitMay @RpcPollAdd (TimeoutSec 1) peerAPI (rpk, "reflog", 17) >>= orThrowUser "rpc timeout" + (gkf, gkblk) <- case gkh of + Nothing -> pure mempty + Just h -> do + _ <- loadGroupKeyMaybe @'HBS2Basic sto h >>= orThrow (GroupKeyNotFound 1) + + let gkPart = maybeToList gkh + let gkTree = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) gkPart + gkblk <- makeMerkle 0 gkTree $ \(_,_,bs) -> do + void $ putBlock sto bs + pure ([ mkForm "gk" [mkSym (show $ pretty (AsBase58 h)) ] ], [HashRef gkblk] ) + let manifest = [ mkForm @C "hbs2-git" [mkInt 3] , mkForm "seed" [mkInt seed] , mkForm "public" [] , mkForm "reflog" [mkSym (show $ pretty (AsBase58 rpk))] - ] + ] <> gkf let mfs = vcat $ fmap pretty manifest @@ -156,7 +173,7 @@ initRepo syn = do liftIO $ print $ pretty $ mkForm "manifest" manifest - let pt = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) [tree] + let pt = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) ( tree : gkblk ) blk <- makeMerkle 0 pt $ \(_,_,bs) -> do void $ putBlock sto bs @@ -170,7 +187,7 @@ initRepo syn = do callRpcWaitMay @RpcLWWRefUpdate (TimeoutSec 1) lwwAPI box >>= orThrowUser "rpc timeout" - let remoteName = "repo-" <> take 4 (show $ pretty (AsBase58 pk)) + remoteName <- newRemoteName pk <&> show .pretty let remoteVal = Text.unpack $ remoteRepoURL pk r <- callProc "git" ["remote", "add", remoteName, remoteVal] mempty diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs new file mode 100644 index 00000000..1a936376 --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs @@ -0,0 +1,84 @@ +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module HBS2.Git3.Repo.Tools where + +import HBS2.Git3.Prelude +import HBS2.Git3.State +import HBS2.Git3.Repo.Types + +import HBS2.System.Dir + +import HBS2.Git.Local.CLI + +import Data.Config.Suckless.Script + +import Control.Applicative +import Crypto.Bip39 +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString.Lazy qualified as LBS +import Data.Either +import Data.HashMap.Strict qualified as HM +import Data.Maybe +import Data.Text qualified as Text +import Data.Word +import Lens.Micro.Platform +import System.Random hiding (next) + + +{- HLINT ignore "Functor law" -} + +listRemotes :: MonadIO m => m [(GitRef, GitRepoKey)] +listRemotes = do + + git <- findGitDir >>= orThrow NoGitDir + + conf <- liftIO (readFile (git "config")) + <&> parseTop + <&> fromRight mempty + + let urls = flip fix (mempty,Nothing,conf) $ \next -> \case + (acc,_, ListVal [SymbolVal "remote", StringLike x] : rest) -> + next (acc,Just x, rest) + + (acc, Just x, ListVal [SymbolVal "url", _, RepoURL3 u] : rest) -> + next ( (fromString x, u) : acc, Nothing, rest) + + (acc, x, _ : rest) -> next ( acc, x, rest) + + (acc,_,[]) -> acc + + pure urls + +resolveRepoKeyThrow :: MonadIO m => [Syntax C] -> m GitRepoKey +resolveRepoKeyThrow = \case + [ SignPubKeyLike url ] -> pure url + [ RepoURL url ] -> pure url + [ StringLike x ] -> do + refs <- listRemotes + lookup (fromString x) refs & orThrow (GitRemoteKeyNotResolved x) + x -> throwIO (GitRemoteKeyNotResolved (show $ pretty (mkList x))) + +newRemoteName :: MonadIO m => GitRepoKey -> m GitRef +newRemoteName key = do + refs <- listRemotes <&> HM.fromList + + flip fix Nothing $ \again i -> do + + when (i > Just 128) $ throwIO GitCantGenerateRemoteName + + suff <- case i of + Nothing -> pure mempty + Just _ -> do + p <- randomIO @Word8 <&> Text.pack . show + pure $ "-" <> p + + name <- toMnemonic (LBS.toStrict . LBS.drop 8 $ serialise key) + & orThrow GitCantGenerateRemoteName + <&> Text.intercalate "-" . take 2 . Text.words + <&> (<> suff) + <&> fromString @GitRef . Text.unpack + + if not (HM.member name refs) then pure name + else again (succ <$> ( i <|> Just 0) ) + + diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index cfd5edb1..8f5580e7 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/hbs2-git3/lib/HBS2/Git3/Run.hs @@ -411,14 +411,17 @@ compression ; prints compression level print $ fill 44 (pretty (AsBase58 k)) <+> pretty r entry $ bindMatch "reflog:imported" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepoKeyThrow syn >>= setGitRepoKey p <- importedCheckpoint liftIO $ print $ pretty p entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepoKeyThrow syn >>= setGitRepoKey importGitRefLog brief "shows repo manifest" $ - entry $ bindMatch "repo:manifest" $ nil_ $ const $ lift $ connectedDo do + entry $ bindMatch "repo:manifest" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepoKeyThrow syn >>= setGitRepoKey manifest <- Repo.getRepoManifest liftIO $ print $ pretty $ mkForm "manifest" (coerce manifest) @@ -430,35 +433,13 @@ compression ; prints compression level liftIO $ print $ pretty (AsBase58 reflog) - entry $ bindMatch "repo:credentials" $ nil_ $ const $ lift $ connectedDo $ do - + entry $ bindMatch "repo:credentials" $ nil_ $ \syn -> lift $ connectedDo $ do + resolveRepoKeyThrow syn >>= setGitRepoKey waitRepo (Just 10) =<< getGitRepoKeyThrow (p,_) <- getRepoRefLogCredentials liftIO $ print $ pretty $ mkForm @C "matched" [mkSym (show $ pretty ( AsBase58 p) )] - brief "set default repository key" - $ desc "needed when you call hbs2-git command directly" - $ examples [qc| -; in config: -repo:ref EvP3kskPVuKuKVMUc3LnfdW7GcFYjz6f5fFU1EGzrdgk - -repo:ref ; shows current repo key - |] $ - entry $ bindMatch "repo:ref" $ nil_ $ \case - [ SignPubKeyLike k ] -> lift do - setGitRepoKey k - - [] -> lift do - r <- getGitRepoKey >>= orThrow GitRepoRefNotSet - liftIO $ print $ pretty (AsBase58 r) - - _ -> throwIO (BadFormException @C nil) - - entry $ bindMatch "repo:ref:value"$ nil_ $ const $ lift $ connectedDo do - val <- Repo.getRepoRefMaybe >>= orThrowUser "can't read ref value" - liftIO $ print $ pretty val - entry $ bindMatch "repo:init" $ nil_ $ \syn -> lift $ connectedDo do Repo.initRepo syn diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs index 4d0b6057..4fd945d6 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs @@ -58,6 +58,8 @@ data HBS2GitExcepion = | Git3PeerNotConnected | Git3ReflogNotSet | NoGitDir + | GitRemoteKeyNotResolved String + | GitCantGenerateRemoteName deriving stock (Show,Typeable) instance Exception HBS2GitExcepion