From 791d2d18883f9b7a2d7984a2ed3e36207148d1b4 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 27 Aug 2024 08:18:54 +0300 Subject: [PATCH] wip, decryptBlock + findMatchedGroupKeySecret --- .../HBS2/KeyMan/Keys/Direct.hs | 38 +++++++++------- hbs2-sync/src/HBS2/Sync/Internal.hs | 1 + hbs2-sync/src/HBS2/Sync/Prelude.hs | 44 +++++++++++++++---- hbs2-sync/src/HBS2/Sync/State.hs | 17 +++---- 4 files changed, 68 insertions(+), 32 deletions(-) diff --git a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs b/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs index 15c01d58..5fb1eb81 100644 --- a/hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs +++ b/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 <- liftIO newAppEnv - let db = appDb env - withDB db (fromKeyManClient action) + env <- newKeymanClientEnv + withKeymanClientRO env 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 diff --git a/hbs2-sync/src/HBS2/Sync/Internal.hs b/hbs2-sync/src/HBS2/Sync/Internal.hs index 489cb5fc..4b0a62f0 100644 --- a/hbs2-sync/src/HBS2/Sync/Internal.hs +++ b/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 () diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs index bbb64ab4..efaa8c03 100644 --- a/hbs2-sync/src/HBS2/Sync/Prelude.hs +++ b/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 - , storageAPI :: ServiceCaller StorageAPI UNIX - , peerAPI :: ServiceCaller PeerAPI UNIX - , dirSyncEnv :: TVar (Map FilePath DirSyncEnv) - , dirThis :: TVar (Maybe FilePath) - , dirTombs :: TVar (Map FilePath (CompactStorage HbSync)) - , dirCache :: TVar (Map FilePath (CompactStorage HbSync)) + { refchanAPI :: ServiceCaller RefChanAPI UNIX + , storageAPI :: ServiceCaller StorageAPI UNIX + , peerAPI :: ServiceCaller PeerAPI UNIX + , dirSyncEnv :: TVar (Map FilePath DirSyncEnv) + , dirThis :: TVar (Maybe FilePath) + , dirTombs :: 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] " diff --git a/hbs2-sync/src/HBS2/Sync/State.hs b/hbs2-sync/src/HBS2/Sync/State.hs index b416f542..b05b5cbf 100644 --- a/hbs2-sync/src/HBS2/Sync/State.hs +++ b/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 - r <- S.toList_ do - 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 findKey gk = lift $ lift $ withKeymanClientRO keEnv do + findMatchedGroupKeySecret sto gk -- 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