wip, gk indexing

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)
+

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 ()