wip, decryptBlock + findMatchedGroupKeySecret

hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs

@@ -7,16 +7,13 @@ import HBS2.KeyMan.Config
 
 import HBS2.Storage
 import HBS2.Data.Types.Refs
-import HBS2.Prelude.Plated
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Auth.GroupKeySymm as Symm
-import HBS2.Net.Proto.Types
 
 
 import HBS2.System.Dir
 
 import Control.Monad.Cont
-import UnliftIO
 import DBPipe.SQLite
 import Text.InterpolatedString.Perl6 (qc)
 import Data.Maybe
@@ -31,6 +28,8 @@ import Streaming.Prelude qualified as S
 
 data KeyManClientError = KeyManClientSomeError
 
+newtype KeyManClientEnv = KeyManClientEnv AppEnv
+
 newtype KeyManClient m a = KeyManClient { fromKeyManClient :: DBPipeM m a }
                            deriving newtype ( Applicative
                                             , Functor
@@ -39,29 +38,38 @@ newtype KeyManClient m a = KeyManClient { fromKeyManClient :: DBPipeM m a }
                                             , MonadUnliftIO
                                             )
 
+newKeymanClientEnv :: MonadUnliftIO m => m KeyManClientEnv
+newKeymanClientEnv = KeyManClientEnv <$> liftIO newAppEnv
+
+withKeymanClientRO :: MonadUnliftIO m => KeyManClientEnv -> KeyManClient m a -> m a
+withKeymanClientRO env action = do
+  let db = appDb (coerce env)
+  withDB db (fromKeyManClient action)
+
 runKeymanClientRO :: MonadUnliftIO m => KeyManClient m a -> m a
 runKeymanClientRO action = do
-  dbPath <- getStatePath
+  env <- newKeymanClientEnv
-  env <- liftIO newAppEnv
+  withKeymanClientRO env action
-  let db = appDb env
-  withDB db (fromKeyManClient action)
 
 runKeymanClient :: MonadUnliftIO m => KeyManClient m a -> m a
 runKeymanClient action = do
+  KeyManClientEnv env <- newKeymanClientEnv
+  -- FIXME: dbpath-to-appstatenv
+  --  сейчас dbPath берётся из конфига, а db из стейта
+  --  и хотя они должны быть одинаковы, это не гарантируется
   dbPath <- getStatePath
-  env <- liftIO newAppEnv
+
   let db = appDb env
+
+  here <- doesPathExist dbPath
+
+  unless here do
+    withDB db $ populateState
+
   flip runContT pure $ do
     void $ ContT $ bracket (async (runPipe db)) cancel
-
-    here <- doesPathExist dbPath
-
-    unless here do
-      withDB db $ populateState
-
     lift $ withDB db (fromKeyManClient action)
 
-
 loadCredentials :: forall a m .
                      ( MonadIO m
                      , SomePubKeyPerks a

hbs2-sync/src/HBS2/Sync/Internal.hs

@@ -35,6 +35,7 @@ syncEntries :: forall c m . ( MonadUnliftIO m
                             , HasRunDir m
                             , HasTombs m
                             , HasCache m
+                            , HasKeyManClient m
                             , MonadReader (Maybe SyncEnv) m
                             )
             => MakeDictM c m ()

hbs2-sync/src/HBS2/Sync/Prelude.hs

@@ -37,8 +37,11 @@ import HBS2.KeyMan.Keys.Direct as Exported ( runKeymanClient
                                            , loadCredentials
                                            , loadKeyRingEntries
                                            , extractGroupKeySecret
+                                           , KeyManClientEnv
                                            )
 
+import HBS2.KeyMan.Keys.Direct qualified as KE
+
 import Data.Config.Suckless as Exported
 import Data.Config.Suckless.Script as Exported
 
@@ -112,13 +115,14 @@ instance Pretty DirSyncEnv where
 
 data SyncEnv =
   SyncEnv
-  { refchanAPI  :: ServiceCaller RefChanAPI UNIX
+  { refchanAPI      :: ServiceCaller RefChanAPI UNIX
-  , storageAPI  :: ServiceCaller StorageAPI UNIX
+  , storageAPI      :: ServiceCaller StorageAPI UNIX
-  , peerAPI     :: ServiceCaller PeerAPI UNIX
+  , peerAPI         :: ServiceCaller PeerAPI UNIX
-  , dirSyncEnv  :: TVar (Map FilePath DirSyncEnv)
+  , dirSyncEnv      :: TVar (Map FilePath DirSyncEnv)
-  , dirThis     :: TVar (Maybe FilePath)
+  , dirThis         :: TVar (Maybe FilePath)
-  , dirTombs    :: TVar (Map FilePath (CompactStorage HbSync))
+  , dirTombs        :: TVar (Map FilePath (CompactStorage HbSync))
-  , dirCache    :: TVar (Map FilePath (CompactStorage HbSync))
+  , dirCache        :: TVar (Map FilePath (CompactStorage HbSync))
+  , keymanClientEnv :: TVar (Maybe KeyManClientEnv)
   }
 
 newtype SyncApp m a =
@@ -142,6 +146,9 @@ class Monad m => HasCache m where
   getCache :: m (CompactStorage HbSync)
   closeCache :: m ()
 
+class Monad m => HasKeyManClient m where
+  getKeyManClientEnv :: m KeyManClientEnv
+
 instance MonadUnliftIO m => HasTombs (SyncApp m) where
   getTombs = do
     SyncEnv{..} <- ask >>= orThrow PeerNotConnectedException
@@ -205,6 +212,23 @@ instance MonadUnliftIO m => HasCache (SyncApp m) where
       compactStorageClose cache
 
 
+instance MonadUnliftIO m => HasKeyManClient (SyncApp m) where
+  getKeyManClientEnv = do
+    SyncEnv{..} <- ask >>= orThrow PeerNotConnectedException
+    e <- readTVarIO keymanClientEnv
+
+    case e of
+      Just env -> pure env
+      -- NOTE: race-but-harmless
+      --   если у нас в двух потоках позовут этот метод,
+      --   то будет открыто два соединения, и сохранено
+      --   последнее. Поскольку соединение readonly это
+      --   безобидно. В целом, надо навести с этим порядок
+      Nothing -> do
+        env <- KE.newKeymanClientEnv
+        atomically  $ writeTVar keymanClientEnv (Just env)
+        pure env
+
 instance MonadIO m => HasClientAPI StorageAPI UNIX (SyncApp m) where
   getClientAPI = ask >>= orThrow PeerNotConnectedException
                      <&> storageAPI
@@ -262,8 +286,9 @@ recover what = do
         this  <- newTVarIO Nothing
         tombs <- newTVarIO mempty
         cache <- newTVarIO mempty
+        dummyKeyman <- newTVarIO Nothing
 
-        let env = Just (SyncEnv refChanAPI storageAPI peerAPI dsync this tombs cache)
+        let env = Just (SyncEnv refChanAPI storageAPI peerAPI dsync this tombs cache dummyKeyman)
 
         liftIO $ withSyncApp env what
 
@@ -391,7 +416,8 @@ instance (Monad m, HasCache m) => HasCache (RunM c m) where
   getCache = lift getCache
   closeCache = lift closeCache
 
-
+instance (MonadUnliftIO m, HasKeyManClient m) => HasKeyManClient (RunM c m) where
+  getKeyManClientEnv = lift getKeyManClientEnv
 
 -- debugPrefix :: LoggerEntry -> LoggerEntry
 debugPrefix = toStderr . logPrefix "[debug] "

hbs2-sync/src/HBS2/Sync/State.hs

@@ -182,6 +182,7 @@ getStateFromDir0 :: ( MonadUnliftIO m
                    , HasStorage m
                    , HasRunDir m
                    , HasCache m
+                   , HasKeyManClient m
                    )
                 => Bool
                 -> m [(FilePath, Entry)]
@@ -202,6 +203,7 @@ getStateFromDir :: ( MonadUnliftIO m
                    , HasStorage m
                    , HasRunDir m
                    , HasCache m
+                   , HasKeyManClient m
                    )
                 => Bool           -- ^ use remote state as seed
                 -> FilePath       -- ^ dir
@@ -245,6 +247,7 @@ getStateFromRefChan :: forall m . ( MonadUnliftIO  m
                                   , HasStorage m
                                   , HasRunDir m
                                   , HasCache m
+                                  , HasKeyManClient m
                                   )
                     => MyRefChan
                     -> m [(FilePath, Entry)]
@@ -265,6 +268,8 @@ getStateFromRefChan rchan = do
 
   unless here $ mkdir statePath
 
+  keEnv <- getKeyManClientEnv
+
   flip runContT pure do
 
     void $ ContT $ bracket (async (runPipe db)) cancel
@@ -282,20 +287,15 @@ getStateFromRefChan rchan = do
 
     let members = view refChanHeadReaders rch & HS.toList
 
-    krl <- liftIO $ runKeymanClientRO $ loadKeyRingEntries members
+    krl <- liftIO $ withKeymanClientRO keEnv $ loadKeyRingEntries members
                 <&> L.sortOn (Down . fst)
                 <&> fmap snd
 
     let krs = HM.fromList [ (pk,e) | e@(KeyringEntry pk _ _) <- krl ]
 
     -- FIXME: asap-insert-findMatchedGroupKey
-    let findKey gk = do
+    let findKey gk = lift $ lift $ withKeymanClientRO keEnv do
-          r <- S.toList_ do
+          findMatchedGroupKeySecret sto gk
-                forM_ (HM.toList $ recipients gk) $ \(pk,box) -> runMaybeT do
-                  (KeyringEntry ppk ssk _) <- toMPlus $ HM.lookup pk krs
-                  let s = Symm.lookupGroupKey @'HBS2Basic ssk ppk gk
-                  for_ s $ lift . S.yield
-          pure $ headMay r
 
     -- let check hx = pure True
     hseen <- withDB db (select_ [qc|select txhash from seen|])
@@ -641,6 +641,7 @@ runDirectory :: ( IsContext c
                 , HasRunDir m
                 , HasTombs m
                 , HasCache m
+                , HasKeyManClient m
                 , Exception (BadFormException c)
                 ) =>  RunM c m ()
 runDirectory = do