From fbb723512bae62fa388a1d29acbdc1a26932453d Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sun, 4 Aug 2024 15:07:08 +0300 Subject: [PATCH] wip, test sync --- hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs | 13 +- hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs | 15 ++ hbs2-sync/src/HBS2/Sync/Prelude.hs | 158 ++++++++++++++------ 3 files changed, 132 insertions(+), 54 deletions(-) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs index bba86b8c..1a2279ff 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs @@ -1,9 +1,11 @@ -module HBS2.CLI.Run.GroupKey where +module HBS2.CLI.Run.GroupKey + ( module HBS2.CLI.Run.GroupKey + , loadGroupKey + ) where import HBS2.CLI.Prelude hiding (mapMaybe) import HBS2.Data.Types.Refs -import HBS2.System.Logger.Simple.ANSI as All import HBS2.Storage.Operations.Class import HBS2.Storage.Operations.ByteString import HBS2.Base58 @@ -12,25 +14,18 @@ import HBS2.CLI.Run.Internal.GroupKey as G import HBS2.Net.Auth.GroupKeySymm as Symm import HBS2.Storage -import HBS2.Net.Auth.Credentials -import HBS2.KeyMan.Keys.Direct import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client import HBS2.Peer.RPC.Client.Unix -import Data.List qualified as L -import Data.Maybe import Data.Text qualified as Text import Data.ByteString.Lazy.Char8 as LBS8 import Data.ByteString.Lazy as LBS import Data.ByteString.Char8 as BS8 import Data.HashMap.Strict qualified as HM -import Data.HashSet qualified as HS -import Control.Monad.Trans.Cont import Control.Monad.Except import Codec.Serialise -import Lens.Micro.Platform {- HLINT ignore "Functor law" -} diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index a09bbc07..c54625cb 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs @@ -19,6 +19,7 @@ import HBS2.Merkle import HBS2.Data.Detect import HBS2.Net.Auth.Credentials import HBS2.Net.Proto.Types +import HBS2.Storage hiding (Key) import HBS2.Storage.Operations.Class import HBS2.Storage.Operations.ByteString import HBS2.Storage(Storage(..)) @@ -433,3 +434,17 @@ deriveGroupSecret n bs = key0 prk = HKDF.extractSkip @_ @HbSyncHash bs key0 = HKDF.expand prk nonceS typicalKeyLength & Saltine.decode & fromJust + +loadGroupKeyMaybe :: ( MonadIO m + ) => AnyStorage -> HashRef -> m (Maybe (GroupKey 'Symm HBS2Basic)) +loadGroupKeyMaybe sto h = do + + runMaybeT do + + bs <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef h))) + <&> either (const Nothing) Just + >>= toMPlus + + deserialiseOrFail bs + & toMPlus + diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs index 4a7c6de2..d385f2a8 100644 --- a/hbs2-sync/src/HBS2/Sync/Prelude.hs +++ b/hbs2-sync/src/HBS2/Sync/Prelude.hs @@ -5,19 +5,22 @@ module HBS2.Sync.Prelude import HBS2.Prelude.Plated as Exported +import HBS2.Clock import HBS2.Base58 +import HBS2.Data.Detect import HBS2.Merkle import HBS2.Merkle.MetaData import HBS2.OrDie as Exported import HBS2.Data.Types.Refs as Exported import HBS2.Data.Types.SignedBox import HBS2.Net.Auth.Credentials -import HBS2.Net.Auth.GroupKeySymm qualified as Symm +import HBS2.Net.Auth.GroupKeySymm as Symm import HBS2.Net.Auth.Schema import HBS2.Clock as Exported import HBS2.Net.Proto.Service import HBS2.Storage import HBS2.Storage.Operations.Class +import HBS2.Storage.Operations.ByteString import HBS2.Peer.Proto.RefChan import HBS2.Peer.CLI.Detect import HBS2.Peer.RPC.Client @@ -33,6 +36,7 @@ import HBS2.Misc.PrettyStuff as Exported import HBS2.CLI.Run hiding (PeerException(..)) import HBS2.CLI.Run.MetaData +-- import HBS2.CLI.Run.GroupKey import HBS2.KeyMan.Keys.Direct @@ -66,10 +70,12 @@ import Data.Time.LocalTime (utcToLocalTime, getCurrentTimeZone, utc) import Data.Word import Lens.Micro.Platform import Streaming.Prelude qualified as S -import System.Directory (getModificationTime) +import System.Directory (getModificationTime,setModificationTime) import System.FilePath.Posix import UnliftIO +import UnliftIO.IO.File qualified as UIO + {- HLINT ignore "Functor law" -} {- HLINT ignore "Eta reduce" -} @@ -181,32 +187,37 @@ data EntryType = File | Dir | Tomb data EntryDesc = EntryDesc - { entryType :: EntryType - , entryTimestamp :: Word64 + { entryType :: EntryType + , entryTimestamp :: Word64 + , entryRemoteHash :: Maybe HashRef } deriving stock (Eq,Ord,Show,Data,Generic) -data DirEntry = DirEntry EntryDesc FilePath - deriving stock (Eq,Ord,Show,Data,Generic) +data Entry = + DirEntry EntryDesc FilePath + deriving stock (Eq,Ord,Show,Data,Generic) -getEntryTimestamp :: DirEntry -> Word64 +getEntryTimestamp :: Entry -> Word64 getEntryTimestamp (DirEntry d _) = entryTimestamp d -isFile :: DirEntry -> Bool +getEntryHash :: Entry -> Maybe HashRef +getEntryHash (DirEntry d _) = entryRemoteHash d + +isFile :: Entry -> Bool isFile = \case DirEntry (EntryDesc { entryType = File}) _ -> True _ -> False -entriesFromLocalFile :: MonadUnliftIO m => FilePath -> FilePath -> m (Map FilePath DirEntry) +entriesFromLocalFile :: MonadUnliftIO m => FilePath -> FilePath -> m (Map FilePath Entry) entriesFromLocalFile prefix fn' = do let fn0 = removePrefix prefix fn ts <- getFileTimestamp fn - pure $ entriesFromFile ts fn0 + pure $ entriesFromFile Nothing ts fn0 where fn = normalise fn' -entriesFromFile :: Word64 -> FilePath -> Map FilePath DirEntry -entriesFromFile ts fn0 = do +entriesFromFile :: Maybe HashRef -> Word64 -> FilePath -> Map FilePath Entry +entriesFromFile h ts fn0 = do let dirs = splitDirectories (dropFileName fn0) & dropWhile (== ".") let es = flip L.unfoldr ("",dirs) $ \case @@ -217,8 +228,8 @@ entriesFromFile ts fn0 = do | e@(DirEntry _ p) <- fileEntry fn0 : es ] where - dirEntry p = DirEntry (EntryDesc Dir ts) p - fileEntry p = DirEntry (EntryDesc File ts) p + dirEntry p = DirEntry (EntryDesc Dir ts Nothing) p + fileEntry p = DirEntry (EntryDesc File ts h) p runDirectory :: ( IsContext c , SyncAppPerks m @@ -253,9 +264,15 @@ runDirectory path = do where - merge :: DirEntry -> DirEntry -> DirEntry + merge :: Entry -> Entry -> Entry merge a b = if getEntryTimestamp a > getEntryTimestamp b then a else b + freshIn :: FilePath -> Entry -> Map FilePath Entry -> Bool + freshIn p e state = do + let remote = Map.lookup p state + maybe1 remote True $ \r -> do + getEntryTimestamp e > getEntryTimestamp r + runDir = do notice $ yellow "run directory" <+> pretty path @@ -306,6 +323,7 @@ runDirectory path = do _ -> pure () + debug $ pretty ins evalTop ins incl <- atomically (flushTQueue tincl) <&> HS.fromList <&> HS.toList @@ -353,50 +371,67 @@ runDirectory path = do let merged = Map.unionWith merge local remote - for_ (Map.toList merged) $ \(p,e) -> do - debug $ yellow "entry" <+> pretty p <+> viaShow e + flip runContT pure do - -- warn $ red "POSTING IS SWITCHED OFF" + for_ (Map.toList merged) $ \(p,e) -> do + debug $ yellow "entry" <+> pretty p <+> viaShow e - when (not (Map.member p remote) && isFile e) do + callCC $ \next -> do - -- FIXME: dangerous! - lbs <- liftIO (LBS.readFile (path p)) + when (freshIn p e remote) do - let (dir,file) = splitFileName p + -- FIXME: dangerous! + lbs <- liftIO (LBS.readFile (path p)) - let meta = HM.fromList [ ("file-name", fromString file) - ] - <> case dir of - "./" -> mempty - d -> HM.singleton "location" (fromString d) + let (dir,file) = splitFileName p - let members = view refChanHeadReaders rch & HS.toList + let meta = HM.fromList [ ("file-name", fromString file) + ] + <> case dir of + "./" -> mempty + d -> HM.singleton "location" (fromString d) - -- FIXME: support-unencrypted? - when (L.null members) do - throwIO EncryptionKeysNotDefined + let members = view refChanHeadReaders rch & HS.toList - gk <- Symm.generateGroupKey @'HBS2Basic Nothing members + -- FIXME: support-unencrypted? + when (L.null members) do + throwIO EncryptionKeysNotDefined - -- FIXME: survive-this-error? - href <- createTreeWithMetadata sto (Just gk) meta lbs - >>= orThrowPassIO + gk <- Symm.generateGroupKey @'HBS2Basic Nothing members - let tx = AnnotatedHashRef Nothing href - let spk = view peerSignPk creds - let ssk = view peerSignSk creds + -- FIXME: survive-this-error? + href <- lift $ createTreeWithMetadata sto (Just gk) meta lbs + >>= orThrowPassIO - let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx) + let tx = AnnotatedHashRef Nothing href + let spk = view peerSignPk creds + let ssk = view peerSignSk creds - postRefChanTx @UNIX refchan box + let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx) - notice $ red "POST NEW REMOTE ENTRY" <+> pretty p <+> pretty href + notice $ red "POST NEW REMOTE ENTRY" <+> pretty p <+> pretty href - unless (Map.member p local) do - notice $ red "WRITE NEW LOCAL ENTRY" <+> pretty p + lift $ postRefChanTx @UNIX refchan box + + when (freshIn p e local) do + h <- ContT $ maybe1 (getEntryHash e) none + -- let h = getEntryHash e + + notice $ red "WRITE NEW LOCAL ENTRY" <+> pretty path <+> pretty p <+> pretty (getEntryHash e) + + lbs' <- lift (runExceptT (getTreeContents sto h)) + <&> either (const Nothing) Just + + lbs <- ContT $ maybe1 lbs' none + + liftIO $ UIO.withBinaryFileAtomic (path p) WriteMode $ \fh -> do + LBS.hPutStr fh lbs + + let ts = getEntryTimestamp e + let timestamp = posixSecondsToUTCTime (fromIntegral ts) + + liftIO $ setModificationTime (path p) timestamp - debug $ pretty ins getStateFromRefChan rchan = do @@ -435,12 +470,45 @@ runDirectory path = do void $ runMaybeT do fn <- toMPlus $ headMay [ l | ListVal [StringLike "file-name:", StringLike l] <- what ] ts <- toMPlus $ HM.lookup txh tsmap - let r = entriesFromFile ts (loc fn) + let r = entriesFromFile (Just tree) ts (loc fn) lift $ S.yield r pure $ Map.unionsWith merge ess0 +getTreeContents :: ( MonadUnliftIO 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 sto (HashRef gkh) + >>= orThrowError (GroupKeyNotFound 11) + <&> HM.keys . Symm.recipients + + kre <- runKeymanClient do + loadKeyRingEntries rcpts <&> fmap snd + + readFromMerkle sto (ToDecryptBS kre (coerce href)) + + _ -> throwError UnsupportedFormat + + syncEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m () syncEntries = do