From d993501b1f30550fccbb7f94b1e68eb88ddfcc41 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Fri, 31 Jan 2025 10:41:02 +0300 Subject: [PATCH] wip, updateRepoHead --- hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs | 1 + hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs | 110 ++++++++++++++++++ hbs2-git3/lib/HBS2/Git3/Run.hs | 53 +++++++-- .../lib/HBS2/Git3/State/Internal/Types.hs | 6 +- .../HBS2/KeyMan/App/Types.hs | 17 +++ hbs2-keyman/hbs2-keyman/Main.hs | 87 +++++++++++++- 6 files changed, 262 insertions(+), 12 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index 9646b282..dbf8173a 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs @@ -94,6 +94,7 @@ data GroupKeyIdScheme = GroupKeyIdBasic1 -- encrypt zeroes then hash newtype GroupKeyId = GroupKeyId N.ByteString deriving stock (Eq,Ord,Generic,Show) + deriving newtype Hashable instance Pretty GroupKeyId where pretty what = pretty (AsBase58 (coerce @_ @N.ByteString what)) diff --git a/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs b/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs index 1a936376..448b6dcc 100644 --- a/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs +++ b/hbs2-git3/lib/HBS2/Git3/Repo/Tools.hs @@ -6,7 +6,12 @@ import HBS2.Git3.Prelude import HBS2.Git3.State import HBS2.Git3.Repo.Types +import HBS2.Data.Detect import HBS2.System.Dir +import HBS2.Net.Auth.GroupKeySymm +import HBS2.CLI.Run.MetaData +import HBS2.Net.Auth.Credentials +import HBS2.KeyMan.Keys.Direct import HBS2.Git.Local.CLI @@ -18,12 +23,14 @@ 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.HashSet qualified as HS import Data.Maybe import Data.Text qualified as Text import Data.Word import Lens.Micro.Platform import System.Random hiding (next) +import Streaming.Prelude qualified as S {- HLINT ignore "Functor law" -} @@ -81,4 +88,107 @@ newRemoteName key = do if not (HM.member name refs) then pure name else again (succ <$> ( i <|> Just 0) ) +updateRepoHead :: (HBS2GitPerks m) + => GitRepoKey + -> [Syntax C] + -> [HashRef] + -> Git3 m () +updateRepoHead repo manifest gkRefs' = do + + sto <- getStorage + lwwAPI <- getClientAPI @LWWRefAPI @UNIX + + creds <- liftIO $ runKeymanClientRO (loadCredentials repo) + >>= orThrow GitRepoNoAccess + + let (wsk, wpk) = (view peerSignSk creds, view peerSignPk creds) + + let mfs = vcat $ fmap pretty manifest + manifestTree <- createTreeWithMetadata sto Nothing mempty (LBS8.pack (show mfs)) + >>= orThrowPassIO + + LWWRef{..} <- getRepoRefMaybe >>= orThrow GitRepoRefEmpty + + repoHead <- readLogThrow (getBlock sto) lwwValue + + oldKeys <- fromMaybe mempty <$> runMaybeT do + h <- headMay (tailSafe repoHead) & toMPlus + readLogThrow (getBlock sto) h + + + let gkRefs = HS.toList $ HS.fromList (gkRefs' <> oldKeys) + + gkTree <- if null gkRefs + then pure Nothing + else do + tree <- makeMerkle 0 (toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) gkRefs) + (\(_,_,bs) -> void $ putBlock sto bs) + pure $ Just (HashRef tree) + + let refs = manifestTree : maybeToList gkTree + + blk <- makeMerkle 0 (toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) refs) + (\(_,_,bs) -> void $ putBlock sto bs) + + now <- liftIO getPOSIXTime <&> round + let box = makeSignedBox wpk wsk (LWWRef now (coerce blk) Nothing) + + callRpcWaitMay @RpcLWWRefUpdate (TimeoutSec 1) lwwAPI box + >>= orThrow RpcTimeout + +updateGroupKey :: HBS2GitPerks m => GitRepoKey -> HashRef -> Git3 m () +updateGroupKey repo new = do + waitRepo (Just 10) repo + sto <- getStorage + LWWRef{..} <- getRepoRefMaybe >>= orThrow GitRepoRefEmpty + RepoManifest manifest <- getRepoManifest + deps <- readLogThrow (getBlock sto) (coerce lwwValue) + + gkNew <- loadGroupKeyMaybe @HBS2Basic sto new + >>= orThrow (GitRepoNoGroupKey new) + + flip runContT pure do + + gkth <- ContT $ maybe1 (headMay (tailSafe deps)) none + gkTree <- readLogThrow (getBlock sto) gkth + + r <- newTVarIO mempty + lift $ for_ gkTree $ \gh -> void $ runMaybeT do + gk <- loadGroupKeyMaybe @HBS2Basic sto gh >>= toMPlus + gkId <- groupKeyId gk & toMPlus + liftIO $ print $ "gk" <+> pretty gh <+> pretty gkId + + let missed = HM.keysSet $ recipients gkNew `HM.difference` recipients gk + + unless (HS.null missed) do + atomically $ modifyTVar r (HM.insert gkId (gk,missed)) + none + + keys <- readTVarIO r <&> HM.elems + + oldKeys <- liftIO $ runKeymanClientRO do + for keys $ \(gk, missed) -> do + -- FIXME: what-if-no-access? + -- предполагается, что это делает owner. + -- owner имеет все ключи. + -- но это может сделать и чел, который просто имеет все ключи, + -- но нет, т.к. он не сможет записать lwwref + gks <- extractGroupKeySecret gk >>= orThrow GitRepoNoAccess + gkNew <- generateGroupKey @'HBS2Basic (Just gks) (HS.toList missed) + writeAsMerkle sto (serialise gkNew) <&> HashRef + + let newKeys = HS.toList $ HS.fromList ( new : oldKeys ) + + for_ newKeys $ \k -> do + liftIO $ print $ "new gk" <+> pretty k + + -- + let newManifest0 = flip mapMaybe manifest $ \case + ListVal [StringLike "gk", HashLike x] -> Nothing + x -> Just x + let newManifest = newManifest0 <> [ mkForm "gk" [ mkSym (show $ pretty new) ] ] + + lift do + updateRepoHead repo newManifest newKeys + updateRepoKey repo diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index c06255d9..8af91c6c 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/hbs2-git3/lib/HBS2/Git3/Run.hs @@ -4,7 +4,7 @@ import HBS2.Git3.Prelude import HBS2.Data.Log.Structured import HBS2.CLI.Run.Internal.Merkle (getTreeContents) - +import HBS2.Data.Detect hiding (Blob) import HBS2.System.Dir import HBS2.Git3.Git @@ -251,7 +251,9 @@ compression ; prints compression level let f = makeRelative cur f' liftIO $ print $ fill 10 (pretty s) <+> pretty f - entry $ bindMatch "reflog:index:list:tx" $ nil_ $ const $ lift $ connectedDo do + entry $ bindMatch "reflog:index:list:tx" $ nil_ $ \syn -> lift $ connectedDo do + resolveRepoKeyThrow syn >>= setGitRepoKey + waitRepo Nothing =<< getGitRepoKeyThrow r <- newIORef ( mempty :: HashSet HashRef ) index <- openIndex enumEntries index $ \bs -> do @@ -315,6 +317,7 @@ compression ; prints compression level let (opts,argz) = splitOpts [] syn let what = headDef "HEAD" [ x | StringLike x <- argz ] + h0 <- gitRevParseThrow what no_ <- newTVarIO 0 @@ -360,16 +363,16 @@ compression ; prints compression level entry $ bindMatch "reflog:tx:list" $ nil_ $ \syn -> lift $ connectedDo do - resolveRepoKeyThrow syn >>= setGitRepoKey - waitRepo Nothing =<< getGitRepoKeyThrow - - let (opts, _) = splitOpts [ ("--checkpoints",0) + let (opts, argz) = splitOpts [ ("--checkpoints",0) , ("--segments",0) ] syn let cpOnly = or [ True | ListVal [StringLike "--checkpoints"] <- opts ] let sOnly = or [ True | ListVal [StringLike "--segments"] <- opts ] + resolveRepoKeyThrow argz >>= setGitRepoKey + waitRepo Nothing =<< getGitRepoKeyThrow + hxs <- txListAll Nothing liftIO $ forM_ hxs $ \(h,tx) -> do @@ -413,11 +416,13 @@ compression ; prints compression level entry $ bindMatch "reflog:imported" $ nil_ $ \syn -> lift $ connectedDo do resolveRepoKeyThrow syn >>= setGitRepoKey + waitRepo Nothing =<< getGitRepoKeyThrow p <- importedCheckpoint liftIO $ print $ pretty p entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do resolveRepoKeyThrow syn >>= setGitRepoKey + waitRepo Nothing =<< getGitRepoKeyThrow importGitRefLog brief "shows repo manifest" $ @@ -447,13 +452,46 @@ compression ; prints compression level for_ gk' $ \(gkh, _) -> do liftIO $ print $ pretty $ mkForm @C "gk" [ mkSym (show $ pretty gkh) ] + brief "updates group key for repo" $ + args [arg "string" "repo", arg "hash" "group-key-hash" ] $ + entry $ bindMatch "repo:gk:update" $ nil_ $ \case + [ x@(StringLike{}), HashLike h ] -> lift $ connectedDo do + repo <- resolveRepoKeyThrow [x] + updateGroupKey repo h + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "repo:gk:journal" $ nil_ $ \syn -> lift $ connectedDo $ do + resolveRepoKeyThrow syn >>= setGitRepoKey + waitRepo Nothing =<< getGitRepoKeyThrow + + ref <- getGitRepoKeyThrow + + lwwAPI <- getClientAPI @LWWRefAPI @UNIX + + sto <- getStorage + + runMaybeT do + + LWWRef{..} <- liftIO (callRpcWaitMay @RpcLWWRefGet (TimeoutSec 1) lwwAPI (coerce ref)) + >>= orThrow RpcTimeout + >>= toMPlus + + hrefs <- lift $ readLogThrow (getBlock sto) lwwValue + + journal <- headMay (tail hrefs) & toMPlus + + keys <- lift $ readLogThrow (getBlock sto) journal + + liftIO $ for_ keys $ \k -> do + liftIO $ print $ pretty k + entry $ bindMatch "repo:init" $ nil_ $ \syn -> lift $ connectedDo do Repo.initRepo syn entry $ bindMatch "repo:relay-only" $ nil_ $ \case [ SignPubKeyLike repo ] -> lift $ connectedDo do setGitRepoKey repo - waitRepo (Just 2) =<< getGitRepoKeyThrow _ -> throwIO (BadFormException @C nil) @@ -461,4 +499,3 @@ compression ; prints compression level exportEntries "reflog:" - diff --git a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs index 4fd945d6..07f6a216 100644 --- a/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs +++ b/hbs2-git3/lib/HBS2/Git3/State/Internal/Types.hs @@ -46,7 +46,7 @@ readLocalConf = do <&> parseTop >>= either (const $ pure mempty) pure -data HBS2GitExcepion = +data HBS2GitException = RefLogNotSet | GitRepoRefNotSet | GitRepoRefEmpty @@ -60,9 +60,11 @@ data HBS2GitExcepion = | NoGitDir | GitRemoteKeyNotResolved String | GitCantGenerateRemoteName + | GitRepoNoGroupKey HashRef + | GitRepoNoAccess deriving stock (Show,Typeable) -instance Exception HBS2GitExcepion +instance Exception HBS2GitException defSegmentSize :: Int defSegmentSize = 50 * 1024 * 1024 diff --git a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/App/Types.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/App/Types.hs index 159daa1c..9bc0a242 100644 --- a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/App/Types.hs +++ b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/App/Types.hs @@ -12,6 +12,7 @@ import HBS2.KeyMan.State import HBS2.Prelude import HBS2.Base58 +import HBS2.Storage -- FIXME: remove-this import HBS2.Net.Auth.Credentials() @@ -27,10 +28,18 @@ import Prettyprinter import Lens.Micro.Platform import UnliftIO +data StorageNotBound = + StorageNotBound + deriving stock (Show, Typeable) + +instance Exception StorageNotBound + + data AppEnv = AppEnv { appConf :: [Syntax C] , appDb :: DBPipeEnv + , appSto :: TVar (Maybe AnyStorage) } newtype KeyManCLI m a = KeyManCLI { fromKeyManCLI :: ReaderT AppEnv m a } @@ -48,6 +57,7 @@ newAppEnv = do let dbOpts = dbPipeOptsDef AppEnv <$> readConfig <*> (getStatePath >>= newDBPipeEnv dbOpts) + <*> newTVarIO Nothing runApp :: MonadUnliftIO m => KeyManCLI m () -> m () runApp action = do @@ -92,4 +102,11 @@ instance MonadIO m => HasConf (ReaderT AppEnv m) where instance MonadIO m => HasConf (KeyManCLI m) where getConf = asks appConf +-- instance MonadIO m => HasStorage (KeyManCLI m) where +-- getStorage = do +-- msto <- asks appSto >>= readTVarIO +-- case msto of +-- Just x -> pure x +-- Nothing -> do +-- throwIO StorageNotBound diff --git a/hbs2-keyman/hbs2-keyman/Main.hs b/hbs2-keyman/hbs2-keyman/Main.hs index e6b9495e..598b3ac1 100644 --- a/hbs2-keyman/hbs2-keyman/Main.hs +++ b/hbs2-keyman/hbs2-keyman/Main.hs @@ -1,3 +1,5 @@ +{-# Language AllowAmbiguousTypes #-} +{-# Language UndecidableInstances #-} module Main where import HBS2.KeyMan.Prelude @@ -5,7 +7,9 @@ import HBS2.KeyMan.App.Types import HBS2.KeyMan.Config import HBS2.KeyMan.State +import HBS2.OrDie import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.GroupKeySymm import HBS2.Data.KeyRing qualified as KeyRing @@ -42,6 +46,7 @@ import Control.Monad.Reader import Control.Monad.Except import Codec.Serialise import Data.Coerce +import System.Exit (exitSuccess) import Streaming.Prelude qualified as S @@ -55,7 +60,12 @@ type Command m = m () globalOptions :: Parser GlobalOptions globalOptions = pure GlobalOptions -type AppPerks m = (MonadIO m, MonadUnliftIO m, MonadReader AppEnv m, HasConf m, SerialisedCredentials 'HBS2Basic) +type AppPerks m = ( MonadIO m + , MonadUnliftIO m + , MonadReader AppEnv m + , HasConf m + , SerialisedCredentials 'HBS2Basic + ) -- TODO: key-mamagement-command-about-to-move-here @@ -67,6 +77,7 @@ commands = hsubparser <> command "set-weight" (O.info (setWeightCmd <**> helper) (progDesc "set weight for a key")) <> command "add-mask" (O.info (addPath <**> helper) (progDesc "add path/mask to search keys, ex. '/home/user/keys/*.key'")) <> command "config" (O.info (showConfig <**> helper) (progDesc "show hbs2-keyman config")) + <> command "run" (O.info (runScript <**> helper) (progDesc "run command")) ) opts :: (AppPerks m) => ParserInfo (GlobalOptions, Command m) @@ -75,6 +86,79 @@ opts = O.info (liftA2 (,) globalOptions commands <**> helper) <> header "hbs2-keyman" ) +quit :: MonadIO m => m () +quit = liftIO exitSuccess + +theDict :: forall m . ( AppPerks m + ) => AnyStorage -> Dict C m + +theDict sto = do + makeDict @C do + -- TODO: write-man-entries + myHelpEntry + myEntries + + -- entry $ bindValue "internal:storage" $ mkOpaque (22 ::Int ) + + where + + myHelpEntry = do + entry $ bindMatch "help" $ nil_ $ \case + HelpEntryBound what -> do + helpEntry what + quit + + [StringLike s] -> helpList False (Just s) >> quit + + _ -> helpList False Nothing >> quit + + myEntries = do + + entry $ bindMatch "stdin" $ nil_ $ const do + + co <- liftIO getContents + <&> parseTop + >>= either (error.show) pure + + lift $ run (theDict sto) co + + entry $ bindMatch "gk:track" $ nil_ $ \case + [HashLike gkhash] -> lift do + + runMaybeT do + gk <- loadGroupKeyMaybe @'HBS2Basic sto gkhash + >>= toMPlus + + gkId <- groupKeyId gk & toMPlus + + -- notice $ "fuck?" + lift $ withState $ transactional do + insertGKTrack gkId gkhash + insertGKAccess gkhash gk + + liftIO $ print $ pretty $ mkForm @C "gk:added" [mkSym (show $ pretty gkhash)] + + _ -> throwIO (BadFormException @C nil) + + +runScript :: (AppPerks m, MonadReader AppEnv m) => Parser (Command m) +runScript = do + argz <- some (argument str (metavar "TERM")) + pure do + + AppEnv{..} <- ask + + flip runContT pure do + so' <- detectRPC + so <- ContT $ maybe1 so' (err $ red "peer is down") + sto <- ContT (withRPC2 @StorageAPI so) <&> AnyStorage . StorageClient + atomically $ writeTVar appSto(Just sto) + + cli <- parseTop (unlines $ unwords <$> splitForms argz) + & either (error.show) pure + + lift $ run (theDict sto) cli >>= display + showConfig :: (AppPerks m) => Parser (Command m) showConfig = do pure do @@ -242,7 +326,6 @@ updateKeys = do commitAll - setWeightCmd :: (AppPerks m) => Parser (Command m) setWeightCmd = do k <- argument str (metavar "KEY" <> help "Key identifier")