diff --git a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs index 1a2279ff..85f0ef0c 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs @@ -38,13 +38,11 @@ groupKeyEntries :: forall c m . ( MonadUnliftIO m groupKeyEntries = do entry $ bindMatch "hbs2:groupkey:load" $ \case - [StringLike s] -> do + [HashLike h] -> do sto <- getStorage - gk <- runExceptT (readFromMerkle sto (SimpleKey (fromString s))) - >>= orThrowUser "can't load group key" - <&> deserialiseOrFail @(GroupKey 'Symm 'HBS2Basic) - >>= orThrowUser "invalid group key" + gk <- loadGroupKey h + >>= orThrowUser "can not load groupkey" pure $ mkStr (show $ pretty $ AsGroupKeyFile gk) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs index 13c48feb..8217dbb9 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs @@ -26,6 +26,7 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Cont import Control.Monad.Except +--FIXME: move-somewhere-else getGroupKeyHash :: ( IsContext c , MonadUnliftIO m , HasStorage m diff --git a/hbs2-core/lib/HBS2/Merkle/MetaData.hs b/hbs2-core/lib/HBS2/Merkle/MetaData.hs index 68bd47e9..59494f23 100644 --- a/hbs2-core/lib/HBS2/Merkle/MetaData.hs +++ b/hbs2-core/lib/HBS2/Merkle/MetaData.hs @@ -14,6 +14,9 @@ import Data.ByteString.Lazy qualified as LBS import Codec.Serialise import Data.Text.Encoding qualified as TE import Control.Monad.Except +import Control.Monad.Trans.Maybe + +import UnliftIO {- HLINT ignore "Functor law" -} @@ -53,3 +56,26 @@ extractMetaData fk sto hash = do _ -> throwError UnsupportedFormat +loadGroupKeyForTree :: ( ForGroupKeySymm s + , MonadIO m + ) + => AnyStorage + -> HashRef + -> m (Maybe (GroupKey 'Symm s)) + +loadGroupKeyForTree sto h = do + + runMaybeT do + + headBlock <- getBlock sto (fromHashRef h) + >>= toMPlus + <&> deserialiseOrFail @(MTreeAnn [HashRef]) + >>= toMPlus + + gkh <- case _mtaCrypt headBlock of + (EncryptGroupNaClSymm h1 _) -> pure (HashRef h1) + _ -> mzero + + G.loadGroupKeyMaybe sto gkh >>= toMPlus + + diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index e798ca8c..59404ee1 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs @@ -433,8 +433,8 @@ deriveGroupSecret n bs = key0 key0 = HKDF.expand prk nonceS typicalKeyLength & Saltine.decode & fromJust -loadGroupKeyMaybe :: ( MonadIO m - ) => AnyStorage -> HashRef -> m (Maybe (GroupKey 'Symm HBS2Basic)) +loadGroupKeyMaybe :: ( ForGroupKeySymm s, MonadIO m + ) => AnyStorage -> HashRef -> m (Maybe (GroupKey 'Symm s)) loadGroupKeyMaybe sto h = do runMaybeT do diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs index e18a5e72..b10d9c6b 100644 --- a/hbs2-sync/src/HBS2/Sync/Prelude.hs +++ b/hbs2-sync/src/HBS2/Sync/Prelude.hs @@ -297,6 +297,9 @@ tombLikeValue = \case LitBoolVal True -> True _ -> False +pattern WithRemoteHash :: Entry -> HashRef -> Entry +pattern WithRemoteHash e h <- e@(DirEntry (EntryDesc {entryRemoteHash = Just h}) _) + pattern TombEntry :: Entry -> Entry pattern TombEntry e <- e@(DirEntry (EntryDesc { entryType = Tomb }) _) @@ -450,6 +453,8 @@ runDirectory = do runDir = do + sto <- getStorage + path <- getRunDir env <- getRunDirEnv path >>= orThrow DirNotSet @@ -462,6 +467,13 @@ runDirectory = do local <- getStateFromDir0 True + let hasRemoteHash = [ (p, h) | (p, WithRemoteHash e h) <- local] + + hasGK0 <- HM.fromList <$> S.toList_ do + for_ hasRemoteHash $ \(p,h) -> do + mgk0 <- lift $ loadGroupKeyForTree @HBS2Basic sto h + for_ mgk0 $ \gk0 -> S.yield (p,gk0) + deleted <- findDeleted merged <- mergeState deleted local @@ -476,7 +488,7 @@ runDirectory = do N (p,TombEntry e) -> do notice $ green "removed entry" <+> pretty p - D (p,e) _ -> do + D (p,e) _ | isTomb e -> do notice $ "locally deleted file" <+> pretty p tombs <- getTombs @@ -485,7 +497,7 @@ runDirectory = do <&> fromRight (Just 0) when (n < Just 2) do - postEntryTx refchan path e + postEntryTx Nothing refchan path e Compact.putVal tombs p (maybe 0 succ n) N (_,_) -> none @@ -494,22 +506,20 @@ runDirectory = do notice $ green "move entry" <+> pretty f <+> pretty t mv (path f) (path t) notice $ green "post renamed entry tx" <+> pretty f - postEntryTx refchan path e + postEntryTx Nothing refchan path e E (p,UpdatedFileEntry _ e) -> do let fullPath = path p here <- liftIO $ doesFileExist fullPath writeEntry path e - notice $ red "updated file entry" <+> pretty here <+> pretty p - postEntryTx refchan path e + notice $ red "updated file entry" <+> pretty here <+> pretty p <+> line <+> pretty (AsSexp @C e) + postEntryTx Nothing refchan path e E (p,e@(FileEntry _)) -> do let fullPath = path p here <- liftIO $ doesFileExist fullPath d <- liftIO $ doesDirectoryExist fullPath - -- getRef tombs (SomeRef (g - older <- if here then do s <- getFileTimestamp fullPath pure $ s < getEntryTimestamp e @@ -525,7 +535,7 @@ runDirectory = do when here do tombs <- getTombs - postEntryTx refchan path e + postEntryTx Nothing refchan path e n <- Compact.getValEither @Integer tombs p <&> fromRight (Just 0) @@ -538,6 +548,8 @@ runDirectory = do E (p,_) -> do notice $ "skip entry" <+> pretty (path p) + _ -> none + findDeleted :: (MonadIO m, HasRunDir m, HasTombs m) => m [Merged] findDeleted = do @@ -573,11 +585,12 @@ postEntryTx :: ( MonadUnliftIO m , HasClientAPI StorageAPI UNIX m , HasClientAPI RefChanAPI UNIX m ) - => MyRefChan + => Maybe (GroupKey 'Symm 'HBS2Basic) + -> MyRefChan -> FilePath -> Entry -> m () -postEntryTx refchan path entry = do +postEntryTx mgk refchan path entry = do sto <- getStorage @@ -610,6 +623,8 @@ postEntryTx refchan path entry = do let members = view refChanHeadReaders rch & HS.toList + -- взять GK из дерева из стейта если там есть такая Entry + -- FIXME: support-unencrypted? when (L.null members) do throwIO EncryptionKeysNotDefined @@ -862,7 +877,7 @@ getStateFromRefChan rchan = do let tomb = or [ True | TombLikeOpt <- what ] let fullPath = loc fn - debug $ red "META" <+> pretty what + trace $ red "META" <+> pretty what if tomb then do lift $ S.yield $ @@ -895,7 +910,7 @@ getTreeContents sto href = do MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do - rcpts <- Symm.loadGroupKeyMaybe sto (HashRef gkh) + rcpts <- Symm.loadGroupKeyMaybe @'HBS2Basic sto (HashRef gkh) >>= orThrowError (GroupKeyNotFound 11) <&> HM.keys . Symm.recipients @@ -1170,14 +1185,13 @@ syncEntries = do rchan <- view dirSyncRefChan env & toMPlus - here <- liftIO (doesFileExist fullPath) guard here now <- liftIO getPOSIXTime <&> round notice $ red "ABOUT TO POST TOMB TX" <+> pretty p - lift $ postEntryTx rchan path (makeTomb now p mzero) + lift $ postEntryTx Nothing rchan path (makeTomb now p mzero) _ -> pure ()