diff --git a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/State.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/State.hs index dfa8e7f9..1b4bb330 100644 --- a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/State.hs +++ b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/State.hs @@ -4,12 +4,16 @@ module HBS2.KeyMan.State ( module HBS2.KeyMan.State , commitAll + , transactional + , module Exported ) where import HBS2.Prelude.Plated import HBS2.Base58 import HBS2.Net.Auth.Credentials import HBS2.Net.Proto.Types +import HBS2.Data.Types.Refs +import HBS2.Net.Auth.GroupKeySymm as Exported import HBS2.KeyMan.Config @@ -22,9 +26,26 @@ import System.FilePath import Control.Monad.Trans.Maybe import Text.InterpolatedString.Perl6 (qc) import Data.Maybe +import Data.HashSet (HashSet) +import Data.HashSet qualified as HS +import Data.HashMap.Strict qualified as HM +import Data.Coerce import UnliftIO + +newtype SomeHash a = SomeHash a + deriving stock Generic + +instance ToField (SomeHash HashRef) where + toField (SomeHash x) = toField $ show $ pretty x + +instance FromField (SomeHash HashRef) where + fromField = fmap (SomeHash . fromString @HashRef) . fromField @String + +instance ToField (SomeHash GroupKeyId) where + toField (SomeHash x) = toField $ show $ pretty x + -- newtype ToDB a = ToDB a class SomePubKeyType a where somePubKeyType :: a -> String @@ -84,6 +105,14 @@ populateState = do ) |] + + ddl [qc| + create table if not exists gkseentx + ( hash text not null + , primary key (hash) + ) + |] + ddl [qc| create table if not exists gktrack ( secret text not null @@ -222,3 +251,37 @@ selectKeyWeight key = do |] (Only (SomePubKey key)) <&> maybe 0 fromOnly . listToMaybe +deleteAllSeenGKTx :: MonadIO m => DBPipeM m () +deleteAllSeenGKTx = do + insert_ [qc|delete from gkseentx|] + +insertSeenGKTx :: (MonadIO m) => HashRef -> DBPipeM m () +insertSeenGKTx hash = do + insert [qc| + insert into gkseentx (hash) values(?) + on conflict (hash) do nothing + |] (Only (SomeHash hash)) + +selectAllSeenGKTx :: (MonadIO m) => DBPipeM m (HashSet HashRef) +selectAllSeenGKTx = do + select_ [qc|select hash from gkseentx|] <&> HS.fromList . fmap (coerce . fromOnly @(SomeHash HashRef)) + + +insertGKTrack :: MonadIO m => GroupKeyId -> HashRef -> DBPipeM m () +insertGKTrack s g = do + insert [qc| + insert into gktrack (secret,gkhash) + values(?,?) + on conflict (secret,gkhash) do nothing + |] (SomeHash s, SomeHash g) + +insertGKAccess:: MonadIO m => HashRef -> GroupKey 'Symm 'HBS2Basic -> DBPipeM m () +insertGKAccess gkh gk = do + let rcpt = recipients gk & HM.keys + for_ rcpt $ \k -> do + insert [qc| + insert into gkaccess (gkhash,key) + values(?,?) + on conflict (gkhash,key) do nothing + |] (SomeHash gkh, SomePubKey k) + diff --git a/hbs2-keyman/hbs2-keyman/Main.hs b/hbs2-keyman/hbs2-keyman/Main.hs index db567fc3..47e7aa2a 100644 --- a/hbs2-keyman/hbs2-keyman/Main.hs +++ b/hbs2-keyman/hbs2-keyman/Main.hs @@ -11,7 +11,6 @@ import HBS2.Data.KeyRing qualified as KeyRing import HBS2.System.Dir -import HBS2.Net.Auth.GroupKeySymm import HBS2.Storage import HBS2.Storage.Operations.ByteString import HBS2.Data.Types.SignedBox @@ -32,9 +31,11 @@ import Options.Applicative qualified as O import Data.Text qualified as Text import Options.Applicative hiding (info,action) import Data.Set qualified as Set +import Data.HashSet qualified as HS import Data.ByteString qualified as BS import Data.ByteString qualified as LBS import Data.Maybe +import Data.Either import Control.Monad.Trans.Maybe import Control.Monad.Trans.Cont import Control.Monad.Reader @@ -135,6 +136,8 @@ updateKeys = do conf <- getConf let rchans = [ r | ListVal [SymbolVal "refchan", SignPubKeyLike r] <- conf ] + seen <- withState selectAllSeenGKTx + flip runContT pure $ callCC \exit -> do when (List.null rchans) $ exit () so' <- detectRPC @@ -143,15 +146,16 @@ updateKeys = do rpc <- ContT $ withRPC2 @RefChanAPI so sto <- ContT (withRPC2 @StorageAPI so) <&> AnyStorage . StorageClient + txs <- S.toList_ do runScan (RChanScanEnv sto rpc) do for_ rchans $ \r -> do - walkRefChanTx @proto (const $ pure True) r $ \tx0 -> \case + walkRefChanTx @proto (pure . not . flip HS.member seen) r $ \tx0 -> \case P _ (ProposeTran _ box) -> do - notice $ green "got the fucking tx" <+> pretty tx0 + trace $ "got the fucking tx" <+> pretty tx0 void $ runMaybeT do (_,bs) <- unboxSignedBox0 box & toMPlus @@ -176,17 +180,18 @@ updateKeys = do --TODO: verify-group-key-id-if-possible - notice $ green "found gk0" <+> pretty gkId <+> pretty gkh + notice $ green "found new gk0" <+> pretty gkId <+> pretty gkh - pure () - -- here <- hasBlock sto (coerce gkh) - - -- when (isJust here) do - -- notice $ green "got the fucking GK" <+> pretty gkh + lift $ lift $ S.yield (Right (gkId, gkh, gk) ) _ -> do lift $ S.yield (Left tx0) - trace $ "ignore accept tx" <+> pretty tx0 + + lift $ withState $ transactional do + for_ (lefts txs) insertSeenGKTx + for_ (rights txs) $ \(gkId, h, gh) -> do + insertGKTrack gkId h + insertGKAccess h gh pure ()