From afa4bb8247a5e7404295f3acf09dfdbafd21187b Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Wed, 8 Mar 2023 19:29:28 +0400 Subject: [PATCH] wip --- hbs2-core/lib/HBS2/Refs/Linear.hs | 35 +++++++++++++------------------ hbs2-peer/app/PeerMain.hs | 6 +----- hbs2/Main.hs | 27 ++++++++++++------------ hbs2/hbs2.cabal | 1 + 4 files changed, 31 insertions(+), 38 deletions(-) diff --git a/hbs2-core/lib/HBS2/Refs/Linear.hs b/hbs2-core/lib/HBS2/Refs/Linear.hs index 57c243a3..f7c2d9b4 100644 --- a/hbs2-core/lib/HBS2/Refs/Linear.hs +++ b/hbs2-core/lib/HBS2/Refs/Linear.hs @@ -22,15 +22,14 @@ import Data.ByteString.Lazy qualified as LBS import Data.Maybe import Data.Set qualified as Set -modifyLinearRef :: forall e st block. +modifyLinearRef :: forall e. ( Signatures e , Serialise (Signature e) , Serialise (PubKey 'Sign e) , Eq (PubKey 'Sign e) - , Block block ~ LBS.ByteString - , Storage (st HbSync) HbSync block IO + , Block LBS.ByteString ~ LBS.ByteString ) - => st HbSync + => AnyStorage -> PeerCredentials e -- owner keyring -> Hash HbSync -- channel id -> (Maybe (Hash HbSync) -> IO (Hash HbSync)) @@ -76,15 +75,14 @@ verifyLinearMutableRefSigned pk lref = do where dat = (LBS.toStrict . serialise) (lmrefSignedRef lref) -tryUpdateLinearRef :: forall e st block. +tryUpdateLinearRef :: forall e. ( Signatures e , Serialise (Signature e) , Serialise (PubKey 'Sign e) , Eq (PubKey 'Sign e) - , Block block ~ LBS.ByteString - , Storage (st HbSync) HbSync block IO + , Block LBS.ByteString ~ LBS.ByteString ) - => st HbSync + => AnyStorage -> Hash HbSync -- channel id -> Signed SignatureVerified (MutableRef e 'LinearRef) -> IO Bool @@ -112,15 +110,14 @@ tryUpdateLinearRef ss chh vlref = do pure True else (pure False) -modifyNodeLinearRefList :: forall e st block. +modifyNodeLinearRefList :: forall e. ( Signatures e , Serialise (Signature e) , Serialise (PubKey 'Sign e) , Eq (PubKey 'Sign e) - , Block block ~ LBS.ByteString - , Storage (st HbSync) HbSync block IO + , Block LBS.ByteString ~ LBS.ByteString ) - => st HbSync -> PeerCredentials e -> Hash HbSync -> ([Hash HbSync] -> [Hash HbSync]) -> IO () + => AnyStorage -> PeerCredentials e -> Hash HbSync -> ([Hash HbSync] -> [Hash HbSync]) -> IO () modifyNodeLinearRefList ss kr chh f = modifyLinearRef ss kr chh \mh -> do v <- case mh of @@ -130,15 +127,14 @@ modifyNodeLinearRefList ss kr chh f = (putBlock ss . serialise) (f v) `orDie` "can not put new node channel list block" -readNodeLinearRefList :: forall e st block. +readNodeLinearRefList :: forall e. ( Signatures e , Serialise (Signature e) , Serialise (PubKey 'Sign e) , Eq (PubKey 'Sign e) - , Block block ~ LBS.ByteString - , Storage (st HbSync) HbSync block IO + , Block LBS.ByteString ~ LBS.ByteString ) - => st HbSync -> PubKey 'Sign e -> IO [Hash HbSync] + => AnyStorage -> PubKey 'Sign e -> IO [Hash HbSync] readNodeLinearRefList ss pk = do -- полученный хэш будет хэшем ссылки на список референсов ноды lrh :: h <- pure $ (hashObject . serialise) (nodeLinearRefsRef @e pk) @@ -151,15 +147,14 @@ readNodeLinearRefList ss pk = do fromMaybe mempty . ((either (const Nothing) Just . deserialiseOrFail) =<<) <$> getBlock ss (lrefVal ref) -nodeRefListAdd :: forall e st block. +nodeRefListAdd :: forall e. ( Signatures e , Serialise (Signature e) , Serialise (PubKey 'Sign e) , Eq (PubKey 'Sign e) - , Block block ~ LBS.ByteString - , Storage (st HbSync) HbSync block IO + , Block LBS.ByteString ~ LBS.ByteString ) - => st HbSync -> PeerCredentials e -> Hash HbSync -> IO () + => AnyStorage -> PeerCredentials e -> Hash HbSync -> IO () nodeRefListAdd ss nodeCred chh = do -- полученный хэш будет хэшем ссылки на список референсов ноды lrh <- (putBlock ss . serialise) (nodeLinearRefsRef @e (_peerSignPk nodeCred)) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 3545af73..247bd1c5 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -26,6 +26,7 @@ import HBS2.Net.Proto.Sessions import HBS2.OrDie import HBS2.Prelude.Plated import HBS2.Refs.Linear +import HBS2.Storage import HBS2.Storage.Simple import HBS2.System.Logger.Simple hiding (info) @@ -367,11 +368,6 @@ mkLRefAdapter :: forall e st block m . , Serialise (Signature e) , Serialise (PubKey 'Sign e) , Eq (PubKey 'Sign e) - -- , Block block ~ LBS.ByteString - -- , Storage (st HbSync) HbSync block IO - -- ( m ~ LRefI e (CredentialsM e (ResponseM e (PeerM e IO))) - -- , Pretty (Peer e) - -- , Block ByteString ~ ByteString ) => m (LRefI e (CredentialsM e (ResponseM e m))) mkLRefAdapter = do diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 14a6bb70..22900e0f 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -15,6 +15,7 @@ import HBS2.OrDie import HBS2.Prelude import HBS2.Prelude.Plated import HBS2.Refs.Linear +import HBS2.Storage import HBS2.Storage.Simple import HBS2.Storage.Simple.Extra @@ -320,33 +321,33 @@ runDumpACB inFile = do --- runNewLRef :: FilePath -> FilePath -> Text -> SimpleStorage HbSync -> IO () -runNewLRef nf uf refName ss = do +runNewLRef nf uf refName (AnyStorage -> st) = do hPrint stderr $ "adding a new channel ref" <+> pretty nf <+> pretty uf - nodeCred <- (parseCredentials . AsCredFile <$> BS.readFile nf) + nodeCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile nf) `orDie` "bad node keyring file" - ownerCred <- (parseCredentials @[Hash HbSync] . AsCredFile <$> BS.readFile uf) + ownerCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile uf) `orDie` "bad ref owner keyring file" -- полученный хэш будет хэшем ссылки на созданный канал владельца c ownerCred -- Это тоже перенести в Refs.hs ? - chh <- (putBlock ss . serialise) (RefGenesis (_peerSignPk ownerCred) refName NoMetaData) + chh <- (putBlock st . serialise) (RefGenesis (_peerSignPk ownerCred) refName NoMetaData) `orDie` "can not put channel genesis block" - nodeRefListAdd ss nodeCred chh + nodeRefListAdd st nodeCred chh runListLRef :: FilePath -> SimpleStorage HbSync -> IO () -runListLRef nf ss = do +runListLRef nf (AnyStorage -> st) = do hPrint stderr $ "listing node channels" <+> pretty nf nodeCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile nf) `orDie` "bad node keyring file" - hs :: [Hash HbSync] <- readNodeLinearRefList ss (_peerSignPk nodeCred) + hs :: [Hash HbSync] <- readNodeLinearRefList @UDP st (_peerSignPk nodeCred) forM_ hs \chh -> do putStrLn "" print $ pretty chh - mg <- (mdeserialiseMay @(RefGenesis [Hash HbSync]) <$> getBlock ss chh) + mg <- (mdeserialiseMay @(RefGenesis [Hash HbSync]) <$> getBlock st chh) forM_ mg \g -> do print $ "owner:" <+> viaShow (refOwner g) print $ "title:" <+> viaShow (refName g) print $ "meta:" <+> viaShow (refMeta g) - simpleReadLinkRaw ss chh >>= \case + readLinkRaw st chh >>= \case Nothing -> do print $ "empty" Just refvalraw -> do @@ -357,9 +358,9 @@ runListLRef nf ss = do print $ "val: " <+> pretty (lrefVal ref) runGetLRef :: Hash HbSync -> SimpleStorage HbSync -> IO () -runGetLRef refh ss = do +runGetLRef refh (AnyStorage -> st) = do hPrint stderr $ "getting ref value" <+> pretty refh - refvalraw <- readLinkRaw ss refh + refvalraw <- readLinkRaw st refh `orDie` "error reading ref val" LinearMutableRefSigned _ ref <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef UDP 'LinearRef)) refvalraw) @@ -368,11 +369,11 @@ runGetLRef refh ss = do print $ pretty (lrefVal ref) runUpdateLRef :: FilePath -> Hash HbSync -> Hash HbSync -> SimpleStorage HbSync -> IO () -runUpdateLRef uf refh valh ss = do +runUpdateLRef uf refh valh (AnyStorage -> st) = do hPrint stderr $ "updating channel" <+> pretty refh <+> "with value" <+> pretty valh ownerCred <- (parseCredentials @[Hash HbSync] . AsCredFile <$> BS.readFile uf) `orDie` "bad ref owner keyring file" - modifyLinearRef ss ownerCred refh \_ -> pure valh + modifyLinearRef st ownerCred refh \_ -> pure valh --- diff --git a/hbs2/hbs2.cabal b/hbs2/hbs2.cabal index 39b4e654..9785e46d 100644 --- a/hbs2/hbs2.cabal +++ b/hbs2/hbs2.cabal @@ -55,6 +55,7 @@ common shared-properties , TupleSections , TypeApplications , TypeFamilies + , ViewPatterns executable hbs2