mirror of https://github.com/voidlizard/hbs2
wip, decryptBlock + findMatchedGroupKeySecret
This commit is contained in:
Dmitry Zuikov
parent
cd694def6d
commit
791d2d1888
|
|
@ -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
|
||||
flip runContT pure $ do
|
||||
void $ ContT $ bracket (async (runPipe db)) cancel
|
||||
|
||||
here <- doesPathExist dbPath
|
||||
|
||||
unless here do
|
||||
withDB db $ populateState
|
||||
|
||||
flip runContT pure $ do
|
||||
void $ ContT $ bracket (async (runPipe db)) cancel
|
||||
lift $ withDB db (fromKeyManClient action)
|
||||
|
||||
|
||||
loadCredentials :: forall a m .
|
||||
( MonadIO m
|
||||
, SomePubKeyPerks a
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -119,6 +122,7 @@ data SyncEnv =
|
|||
, 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] "
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue