diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index f21bfb3d..d053af2c 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -12,6 +12,7 @@ import Fixme.Scan as Scan import Fixme.GK import HBS2.Git.Local.CLI +import HBS2.CLI.Run.MetaData (createTreeWithMetadata,getTreeContents) import HBS2.Polling import HBS2.OrDie @@ -479,21 +480,19 @@ refchanExport opts = do for_ chu $ \x -> callCC \next -> do -- FIXME: encrypt-tree - -- 1. откуда ключ взять - -- 2. куда его положить - - - -- - -- 3. один на всех? - -- 4. по одному на каждого? - -- 5. как будет устроена ротация -- 6. как делать доступ к историческим данным -- 6.1 новые ключи в этот же рефчан -- 6.2 или новые ключи в какой-то еще рефчан - h <- writeAsMerkle sto (serialise x) - let tx = AnnotatedHashRef Nothing (HashRef h) + let s = maybe "[ ]" (const $ yellow "[@]") gk0 + + let gk = snd <$> gk0 + + href <- liftIO $ createTreeWithMetadata sto gk mempty (serialise x) + >>= orThrowPassIO + + let tx = AnnotatedHashRef Nothing href lift do @@ -501,7 +500,7 @@ refchanExport opts = do let box = makeSignedBox @'HBS2Basic @BS.ByteString pk sk (LBS.toStrict lbs) - warn $ "POST" <+> red "unencrypted!" <+> pretty (length x) <+> pretty (hashObject @HbSync (serialise box)) + warn $ "POST" <+> pretty (length x) <+> s <> "tree" <+> pretty href <+> pretty (hashObject @HbSync (serialise box)) unless dry do r <- callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) rchanAPI (chan, box) @@ -511,6 +510,7 @@ refchanExport opts = do pure $ length what + refchanUpdate :: FixmePerks m => FixmeM m () refchanUpdate = do @@ -610,7 +610,7 @@ refchanImport = do else do -- FIXME: decrypt-tree - what <- runExceptT (readFromMerkle sto (SimpleKey (coerce href))) + what <- liftIO (runExceptT $ getTreeContents sto href) <&> either (const Nothing) Just >>= toMPlus diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs index 8217dbb9..dfc9dc14 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs @@ -8,6 +8,7 @@ import HBS2.CLI.Run.Internal.GroupKey as G import HBS2.Hash import HBS2.Net.Auth.GroupKeySymm as Symm import HBS2.Data.Types.Refs +import HBS2.Data.Detect import HBS2.Merkle import HBS2.Storage import HBS2.Storage.Operations.ByteString @@ -19,6 +20,7 @@ import HBS2.KeyMan.Keys.Direct import HBS2.Net.Auth.Schema() import Codec.Serialise +import Data.Coerce import Data.ByteString.Lazy qualified as LBS import Data.HashMap.Strict qualified as HM import Data.Text qualified as Text @@ -115,3 +117,39 @@ createTreeWithMetadata sto mgk meta lbs = do -- flip runContT pure do runExceptT $ writeAsMerkle sto source <&> HashRef +getTreeContents :: forall m . ( MonadUnliftIO m + , MonadIO m + , MonadError OperationError m + ) + => AnyStorage + -> HashRef + -> m LBS.ByteString + +getTreeContents sto href = do + + blk <- getBlock sto (coerce href) + >>= orThrowError MissedBlockError + + let q = tryDetect (coerce href) blk + + case q of + + Merkle _ -> do + readFromMerkle sto (SimpleKey (coerce href)) + + MerkleAnn (MTreeAnn {_mtaCrypt = NullEncryption }) -> do + readFromMerkle sto (SimpleKey (coerce href)) + + MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do + + rcpts <- Symm.loadGroupKeyMaybe @'HBS2Basic sto (HashRef gkh) + >>= orThrowError (GroupKeyNotFound 11) + <&> HM.keys . Symm.recipients + + let findStuff g = do + runKeymanClientRO @IO $ findMatchedGroupKeySecret sto g + + readFromMerkle sto (ToDecryptBS (coerce href) (liftIO . findStuff)) + + _ -> throwError UnsupportedFormat + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs index 599f6759..4a3a3d5b 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs @@ -3,6 +3,7 @@ module HBS2.CLI.Run.MetaData ( metaDataEntries , createTreeWithMetadata + , getTreeContents ) where import HBS2.CLI.Prelude diff --git a/hbs2-sync/src/HBS2/Sync/Internal.hs b/hbs2-sync/src/HBS2/Sync/Internal.hs index 4b0a62f0..4d518f5c 100644 --- a/hbs2-sync/src/HBS2/Sync/Internal.hs +++ b/hbs2-sync/src/HBS2/Sync/Internal.hs @@ -11,6 +11,8 @@ import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client.Unix (UNIX) import HBS2.Peer.RPC.Client +import HBS2.CLI.Run.MetaData (getTreeContents) + import HBS2.CLI.Run.Internal hiding (PeerNotConnectedException) import Control.Monad.Trans.Maybe diff --git a/hbs2-sync/src/HBS2/Sync/State.hs b/hbs2-sync/src/HBS2/Sync/State.hs index b05b5cbf..137e2128 100644 --- a/hbs2-sync/src/HBS2/Sync/State.hs +++ b/hbs2-sync/src/HBS2/Sync/State.hs @@ -24,7 +24,7 @@ import HBS2.Peer.RPC.Client.RefChan as Client import HBS2.KeyMan.Keys.Direct -import HBS2.CLI.Run.MetaData (createTreeWithMetadata) +import HBS2.CLI.Run.MetaData (createTreeWithMetadata, getTreeContents) import DBPipe.SQLite import Data.Config.Suckless.Script.File @@ -599,39 +599,6 @@ mergeState seed orig = do else new -getTreeContents :: forall m . ( MonadUnliftIO m - , MonadIO m - , MonadError OperationError m - ) - => AnyStorage - -> HashRef - -> m LBS.ByteString - -getTreeContents sto href = do - - blk <- getBlock sto (coerce href) - >>= orThrowError MissedBlockError - - let q = tryDetect (coerce href) blk - - case q of - - MerkleAnn (MTreeAnn {_mtaCrypt = NullEncryption }) -> do - readFromMerkle sto (SimpleKey (coerce href)) - - MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do - - rcpts <- Symm.loadGroupKeyMaybe @'HBS2Basic sto (HashRef gkh) - >>= orThrowError (GroupKeyNotFound 11) - <&> HM.keys . Symm.recipients - - let findStuff g = do - runKeymanClientRO @IO $ findMatchedGroupKeySecret sto g - - readFromMerkle sto (ToDecryptBS (coerce href) (liftIO . findStuff)) - - _ -> throwError UnsupportedFormat - runDirectory :: ( IsContext c , SyncAppPerks m