From 0ea0b90a9d5914778da4c8271c062a733c7eddb3 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sun, 4 Aug 2024 13:24:30 +0300 Subject: [PATCH] wip --- hbs2-core/hbs2-core.cabal | 1 + hbs2-core/lib/HBS2/Merkle/MetaData.hs | 55 +++++++ hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs | 2 - .../HBS2/Peer/Proto/RefChan/RefChanUpdate.hs | 1 + hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs | 125 ++++++++++++++++ hbs2-sync/src/HBS2/Sync/Prelude.hs | 138 +++++++++++++++--- 6 files changed, 300 insertions(+), 22 deletions(-) create mode 100644 hbs2-core/lib/HBS2/Merkle/MetaData.hs diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index ad555ea6..680caf41 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -94,6 +94,7 @@ library , HBS2.Polling , HBS2.Hash , HBS2.Merkle + , HBS2.Merkle.MetaData , HBS2.Net.Auth.Schema , HBS2.Net.Auth.GroupKeyAsymm , HBS2.Net.Auth.GroupKeySymm diff --git a/hbs2-core/lib/HBS2/Merkle/MetaData.hs b/hbs2-core/lib/HBS2/Merkle/MetaData.hs new file mode 100644 index 00000000..68bd47e9 --- /dev/null +++ b/hbs2-core/lib/HBS2/Merkle/MetaData.hs @@ -0,0 +1,55 @@ +module HBS2.Merkle.MetaData where + +import HBS2.Prelude +import HBS2.OrDie +import HBS2.Data.Types.Refs +import HBS2.Merkle +import HBS2.Storage +import HBS2.Data.Types.SmallEncryptedBlock +import HBS2.Net.Auth.GroupKeySymm as G +import HBS2.Storage.Operations.Class + +import Data.Coerce +import Data.ByteString.Lazy qualified as LBS +import Codec.Serialise +import Data.Text.Encoding qualified as TE +import Control.Monad.Except + +{- HLINT ignore "Functor law" -} + +extractMetaData :: forall s m . (MonadIO m, ForGroupKeySymm s, MonadError OperationError m) + + => (GroupKey 'Symm s -> m (Maybe GroupSecret)) + -> AnyStorage + -> HashRef + -> m Text +extractMetaData fk sto hash = do + + headBlock <- getBlock sto (coerce hash) + >>= orThrowError MissedBlockError + <&> deserialiseOrFail @(MTreeAnn [HashRef]) + >>= orThrowError UnsupportedFormat + + case headBlock of + MTreeAnn { _mtaMeta = ShortMetadata s } -> do + pure s + + MTreeAnn { _mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption } -> do + getBlock sto h + >>= orThrowError MissedBlockError + <&> LBS.toStrict + <&> TE.decodeUtf8 + + MTreeAnn { _mtaMeta = AnnHashRef h } -> do + getBlock sto h + >>= orThrowError MissedBlockError + <&> deserialiseOrFail @(SmallEncryptedBlock AnnMetaData) + >>= orThrowError UnsupportedFormat + >>= G.decryptBlock @_ @s sto fk + >>= \case + ShortMetadata s -> pure s + _ -> throwError UnsupportedFormat + + _ -> throwError UnsupportedFormat + + diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index 0ef0649e..a09bbc07 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs @@ -396,8 +396,6 @@ decryptBlock :: forall t s sto h m . ( MonadIO m , MonadError OperationError m , Storage sto h ByteString m , ForGroupKeySymm s - , PubKey 'Encrypt s ~ AK.PublicKey - , PrivKey 'Encrypt s ~ AK.SecretKey , h ~ HbSync , Serialise t ) diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs index 7fe938c7..d949074c 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs @@ -71,6 +71,7 @@ pattern AcceptTran t a b <- (unpackAcceptTran -> (t, a, b)) where AcceptTran Nothing a b = AcceptTran1 a b AcceptTran (Just t) a b = AcceptTran2 (Just t) a b +{-# COMPLETE AcceptTran #-} instance ForRefChans e => Serialise (ProposeTran e) instance ForRefChans e => Serialise (AcceptTran e) diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs index a97b630c..a0083178 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs @@ -3,6 +3,7 @@ module HBS2.Peer.RPC.Client.RefChan where import HBS2.OrDie import HBS2.Storage +import HBS2.Merkle import HBS2.Storage.Operations.ByteString import HBS2.Data.Types.SignedBox @@ -13,9 +14,13 @@ import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client.Internal import HBS2.Peer.RPC.Client.StorageClient +import Data.ByteString (ByteString) import Data.Coerce import Control.Monad.Except import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Cont +import Control.Monad.Reader +import Codec.Serialise import UnliftIO @@ -55,3 +60,123 @@ getRefChanHead puk = do pure hdblk +postRefChanTx :: forall proto s m . ( MonadUnliftIO m + , HasClientAPI RefChanAPI proto m + , HasClientAPI StorageAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + , HasProtocol proto (ServiceProto StorageAPI proto) + , ForSignedBox s + , s ~ HBS2Basic + ) + => PubKey 'Sign s + -> SignedBox ByteString s + -> m () +postRefChanTx puk box = do + api <- getClientAPI @RefChanAPI @proto + callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) api (puk, box) >>= \case + Nothing -> throwIO RpcTimeoutError + Just e -> pure e + +fetchRefChanHead :: forall proto m . ( MonadUnliftIO m + , HasClientAPI RefChanAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + ) + => PubKey 'Sign 'HBS2Basic + -> m () +fetchRefChanHead puk = do + api <- getClientAPI @RefChanAPI @proto + callRpcWaitMay @RpcRefChanHeadFetch (TimeoutSec 1) api puk >>= \case + Nothing -> throwIO RpcTimeoutError + _ -> pure () + +fetchRefChan :: forall proto m . ( MonadUnliftIO m + , HasClientAPI RefChanAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + ) + => PubKey 'Sign 'HBS2Basic + -> m () +fetchRefChan puk = do + api <- getClientAPI @RefChanAPI @proto + callRpcWaitMay @RpcRefChanFetch (TimeoutSec 1) api puk >>= \case + Nothing -> throwIO RpcTimeoutError + _ -> pure () + + +getRefChanValue :: forall proto m . ( MonadUnliftIO m + , HasClientAPI RefChanAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + ) + => PubKey 'Sign 'HBS2Basic + -> m (Maybe HashRef) +getRefChanValue puk = do + api <- getClientAPI @RefChanAPI @proto + callRpcWaitMay @RpcRefChanGet (TimeoutSec 1) api puk >>= \case + Nothing -> throwIO RpcTimeoutError + Just e -> pure e + + + + +-- this is not MonadUnliftIO to be compatible with +-- streaming +-- + +data RScanEnv proto = + RScanEnv { + rchanAPI :: ServiceCaller RefChanAPI proto + } + + +instance Monad m => HasClientAPI RefChanAPI proto (ReaderT (RScanEnv proto) m) where + getClientAPI = asks rchanAPI + +data RefChanUpdateUnpacked e = + A (AcceptTran e) | P HashRef (ProposeTran e) + deriving stock (Generic) + +{-# COMPLETE A,P #-} + +walkRefChanTx :: forall proto m . ( MonadIO m + , HasClientAPI RefChanAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + , HasStorage m + ) + => PubKey 'Sign 'HBS2Basic + -> (RefChanUpdateUnpacked L4Proto -> m ()) + -> m () +walkRefChanTx puk action = do + sto <- getStorage + api <- getClientAPI @RefChanAPI @proto + + let env = RScanEnv api + + flip runContT pure $ callCC $ \exit -> do + + rcv' <- liftIO (runReaderT (getRefChanValue @proto puk) env) + + rcv <- ContT $ maybe1 rcv' none + + walkMerkle (coerce rcv) (getBlock sto) $ \case + -- FIXME: error-handling + Left _ -> exit () + + Right (hs :: [HashRef]) -> do + for_ hs $ \h -> do + lbs' <- getBlock sto (coerce h) + lbs <- ContT $ maybe1 lbs' none + + let txraw = deserialiseOrFail @(RefChanUpdate L4Proto) lbs + & either (const Nothing) Just + + tx <- ContT $ maybe1 txraw none + + case tx of + + Accept _ box -> do + (_, txx) <- ContT $ maybe1 (unboxSignedBox0 box) none + lift $ action (A txx) + + Propose _ box -> do + (_, txx) <- ContT $ maybe1 (unboxSignedBox0 box) none + lift $ action (P h txx) + diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs index f243fb68..d10105b8 100644 --- a/hbs2-sync/src/HBS2/Sync/Prelude.hs +++ b/hbs2-sync/src/HBS2/Sync/Prelude.hs @@ -6,9 +6,14 @@ module HBS2.Sync.Prelude import HBS2.Prelude.Plated as Exported import HBS2.Base58 +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.Schema import HBS2.Clock as Exported import HBS2.Net.Proto.Service import HBS2.Storage @@ -29,6 +34,8 @@ import HBS2.Misc.PrettyStuff as Exported import HBS2.CLI.Run hiding (PeerException(..)) import HBS2.CLI.Run.MetaData +import HBS2.KeyMan.Keys.Direct + import Data.Config.Suckless as Exported import Data.Config.Suckless.Script as Exported import Data.Config.Suckless.Script.File @@ -37,7 +44,11 @@ import Codec.Serialise as Exported import Control.Concurrent.STM (flushTQueue) import Control.Monad.Reader as Exported import Control.Monad.Trans.Cont as Exported +import Control.Monad.Trans.Maybe +import Control.Monad.Except +import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as LBS +import Data.Coerce import Data.Either import Data.HashMap.Strict qualified as HM import Data.HashSet qualified as HS @@ -93,6 +104,11 @@ instance MonadIO m => HasClientAPI PeerAPI UNIX (SyncApp m) where getClientAPI = ask >>= orThrow PeerNotConnectedException <&> peerAPI +instance MonadIO m => HasStorage (SyncApp m) where + getStorage = do + api <- getClientAPI @StorageAPI @UNIX + pure $ AnyStorage (StorageClient api) + withSyncApp :: SyncAppPerks m => Maybe SyncEnv -> SyncApp m a -> m a withSyncApp env action = runReaderT (fromSyncApp action) env @@ -143,6 +159,7 @@ data RunDirectoryException = RefChanNotSetException | RefChanHeadNotFoundException | EncryptionKeysNotDefined + | SignKeyNotSet deriving stock (Show,Typeable) instance Exception RunDirectoryException @@ -159,7 +176,7 @@ getFileTimestamp filePath = do pure (round $ utcTimeToPOSIXSeconds t0) -data EntryType = File | Dir +data EntryType = File | Dir | Tomb deriving stock (Eq,Ord,Show,Data,Generic) data EntryDesc = @@ -182,32 +199,32 @@ isFile = \case entriesFromLocalFile :: MonadUnliftIO m => FilePath -> FilePath -> m (Map FilePath DirEntry) entriesFromLocalFile prefix fn' = do - let fn0 = removePrefix prefix fn ts <- getFileTimestamp fn - - let dirs = splitDirectories (dropFileName fn0) - & dropWhile (== ".") - - debug $ red "SOURCE" <+> pretty fn0 <+> pretty fn <+> pretty dirs - - let es = flip L.unfoldr ("",dirs) $ \case - (_,[]) -> Nothing - (p,d:ds) -> Just (dirEntry ts (p d), (p d, ds) ) - - pure $ Map.fromList [ (p, e) - | e@(DirEntry _ p) <- fileEntry ts fn0 : es - ] - + pure $ entriesFromFile ts fn0 where fn = normalise fn' - dirEntry ts p = DirEntry (EntryDesc Dir ts) p - fileEntry ts p = DirEntry (EntryDesc File ts) p + +entriesFromFile :: Word64 -> FilePath -> Map FilePath DirEntry +entriesFromFile ts fn0 = do + let dirs = splitDirectories (dropFileName fn0) + & dropWhile (== ".") + let es = flip L.unfoldr ("",dirs) $ \case + (_,[]) -> Nothing + (p,d:ds) -> Just (dirEntry (p d), (p d, ds) ) + + Map.fromList [ (p, e) + | e@(DirEntry _ p) <- fileEntry fn0 : es + ] + where + dirEntry p = DirEntry (EntryDesc Dir ts) p + fileEntry p = DirEntry (EntryDesc File ts) p runDirectory :: ( IsContext c , SyncAppPerks m , HasClientAPI RefChanAPI UNIX m , HasClientAPI StorageAPI UNIX m + , HasStorage m , Exception (BadFormException c) ) => FilePath -> RunM c m () runDirectory path = do @@ -223,6 +240,8 @@ runDirectory path = do err $ "no refchan head found for" <+> pretty path EncryptionKeysNotDefined -> do err $ "no readers defined in the refchan for " <+> pretty path + SignKeyNotSet -> do + err $ "sign key not set or not found " <+> pretty path `catch` \case (e :: OperationError) -> do @@ -242,6 +261,7 @@ runDirectory path = do notice $ yellow "run directory" <+> pretty path trc <- newTVarIO Nothing + tsign <- newTVarIO Nothing texcl <- newTQueueIO tincl <- newTQueueIO @@ -273,6 +293,19 @@ runDirectory path = do _ -> pure () + + bindBuiltins $ bindMatch "sign" $ nil_ $ \case + [SignPubKeyLike s] -> do + debug $ red "SIGN" <+> pretty (AsBase58 s) + + runMaybeT do + creds <- MaybeT $ runKeymanClient $ loadCredentials s + atomically $ writeTVar tsign (Just creds) + + pure () + + _ -> pure () + evalTop ins incl <- atomically (flushTQueue tincl) <&> HS.fromList <&> HS.toList @@ -281,9 +314,14 @@ runDirectory path = do refchan <- readTVarIO trc >>= orThrow RefChanNotSetException + fetchRefChan @UNIX refchan + rch <- Client.getRefChanHead @UNIX refchan >>= orThrow RefChanHeadNotFoundException + creds <- readTVarIO tsign + >>= orThrow SignKeyNotSet + sto <- getClientAPI @StorageAPI @UNIX <&> AnyStorage . StorageClient @@ -310,14 +348,18 @@ runDirectory path = do debug "FUCKING GOT REFCHAN HEAD" let local = Map.fromList [ (p,e) | e@(DirEntry _ p) <- es' ] - let remote = Map.empty + + remote <- getStateFromRefChan refchan let merged = Map.unionWith merge local remote for_ (Map.toList merged) $ \(p,e) -> do debug $ yellow "entry" <+> pretty p <+> viaShow e - when (not (Map.member p remote) && isFile e) do + warn $ red "POSTING IS SWITCHED OFF" + + + when (not (Map.member p remote) && isFile e && False) do -- FIXME: dangerous! lbs <- liftIO (LBS.readFile (path p)) @@ -342,6 +384,14 @@ runDirectory path = do href <- createTreeWithMetadata sto (Just gk) meta lbs >>= orThrowPassIO + let tx = AnnotatedHashRef Nothing href + let spk = view peerSignPk creds + let ssk = view peerSignSk creds + + let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx) + + postRefChanTx @UNIX refchan box + notice $ red "POST NEW REMOTE ENTRY" <+> pretty p <+> pretty href pure () @@ -351,6 +401,53 @@ runDirectory path = do debug $ pretty ins + getStateFromRefChan rchan = do + + debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan) + + sto <- getStorage + + outq <- newTQueueIO + tss <- newTVarIO mempty + + walkRefChanTx @UNIX rchan $ \case + A (AcceptTran ts _ what) -> do + debug $ red "ACCEPT" <+> pretty ts <+> pretty what + for_ ts $ \w -> do + atomically $ modifyTVar tss (HM.insertWith max what (coerce @_ @Word64 w)) + + P orig (ProposeTran _ box) -> void $ runMaybeT do + (_, bs) <- unboxSignedBox0 box & toMPlus + AnnotatedHashRef w href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs) + & toMPlus . either (const Nothing) Just + + let findKey gk = liftIO (runKeymanClient (extractGroupKeySecret gk)) + + runExceptT (extractMetaData @'HBS2Basic findKey sto href) + >>= either (const none) ( \meta -> atomically $ writeTQueue outq (orig, (href, meta)) ) + + trees <- atomically (flushTQueue outq) + + tsmap <- readTVarIO tss + + ess0 <- S.toList_ do + for_ trees $ \(txh, (tree, meta)) -> do + let what = parseTop meta & fromRight mempty + let loc = headDef "" [ l | ListVal [StringLike "location:", StringLike l] <- what ] + + 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) + lift $ S.yield r + + let ess = Map.unionsWith merge ess0 + + for_ (Map.toList ess) $ \(p,e) -> do + debug $ "REMOTE ENTRY" <+> pretty p <+> viaShow e + + pure mempty + syncEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m () syncEntries = do @@ -362,6 +459,7 @@ syncEntries = do _ -> do setLogging @DEBUG debugPrefix +-- debugPrefix :: LoggerEntry -> LoggerEntry debugPrefix = toStderr . logPrefix "[debug] " setupLogger :: MonadIO m => m ()