From c52be7cf5e435c969079571ef655e45c2c11b878 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 27 Jul 2023 10:00:01 +0300 Subject: [PATCH] merged PR 8ey8Fnr4c4 remove-lref-commands --- hbs2-core/lib/HBS2/System/Logger/Simple.hs | 3 + hbs2-git/lib/HBS2Git/App.hs | 2 - hbs2-peer/app/PeerMain.hs | 2 - hbs2-tests/test/TestConcurrentWrite.hs | 2 - hbs2-tests/test/TestTCP.hs | 2 - hbs2-tests/test/TestTCPNet.hs | 2 - hbs2/Main.hs | 176 +-------------------- 7 files changed, 10 insertions(+), 179 deletions(-) diff --git a/hbs2-core/lib/HBS2/System/Logger/Simple.hs b/hbs2-core/lib/HBS2/System/Logger/Simple.hs index 63d1562c..3955dc3e 100644 --- a/hbs2-core/lib/HBS2/System/Logger/Simple.hs +++ b/hbs2-core/lib/HBS2/System/Logger/Simple.hs @@ -17,6 +17,7 @@ module HBS2.System.Logger.Simple , loggerTr , toStderr , toStdout + , logPrefix , SetLoggerEntry , module HBS2.System.Logger.Simple.Class ) where @@ -144,3 +145,5 @@ info = log @INFO instance {-# OVERLAPPABLE #-} ToLogStr (Doc ann) where toLogStr p = toLogStr (show p) +logPrefix :: LogStr -> LoggerEntry-> LoggerEntry +logPrefix s = set loggerTr (s <>) diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index 05bd7878..7c230ebe 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/hbs2-git/lib/HBS2Git/App.hs @@ -72,8 +72,6 @@ instance MonadIO m => HasCfgKey KeyRingFiles (Set FilePath) m where instance MonadIO m => HasCfgKey StoragePref (Maybe FilePath) m where key = "storage" -logPrefix s = set loggerTr (s <>) - tracePrefix :: SetLoggerEntry tracePrefix = toStderr . logPrefix "[trace] " diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 72662735..ff9ebe17 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -184,8 +184,6 @@ data PeerOpts = makeLenses 'PeerOpts -logPrefix s = set loggerTr (s <>) - tracePrefix :: SetLoggerEntry tracePrefix = logPrefix "[trace] " diff --git a/hbs2-tests/test/TestConcurrentWrite.hs b/hbs2-tests/test/TestConcurrentWrite.hs index 84df46aa..aba998e5 100644 --- a/hbs2-tests/test/TestConcurrentWrite.hs +++ b/hbs2-tests/test/TestConcurrentWrite.hs @@ -117,8 +117,6 @@ testSimpleStorageRandomReadWrite = do assertEqual "errors1" e1 0 assertEqual "errors2" e2 0 -logPrefix s = set loggerTr (s <>) - tracePrefix :: SetLoggerEntry tracePrefix = logPrefix "[trace] " diff --git a/hbs2-tests/test/TestTCP.hs b/hbs2-tests/test/TestTCP.hs index c2dbe1a8..08f81479 100644 --- a/hbs2-tests/test/TestTCP.hs +++ b/hbs2-tests/test/TestTCP.hs @@ -20,8 +20,6 @@ import Control.Concurrent.Async import Lens.Micro.Platform import Codec.Serialise -logPrefix s = set loggerTr (s <>) - tracePrefix :: SetLoggerEntry tracePrefix = logPrefix "[trace] " diff --git a/hbs2-tests/test/TestTCPNet.hs b/hbs2-tests/test/TestTCPNet.hs index fcf3611c..e57fcd37 100644 --- a/hbs2-tests/test/TestTCPNet.hs +++ b/hbs2-tests/test/TestTCPNet.hs @@ -21,8 +21,6 @@ import Lens.Micro.Platform import Codec.Serialise import System.Environment -logPrefix s = set loggerTr (s <>) - tracePrefix :: SetLoggerEntry tracePrefix = logPrefix "[trace] " diff --git a/hbs2/Main.hs b/hbs2/Main.hs index f8de7b97..c177cc6a 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -16,7 +16,6 @@ import HBS2.OrDie import HBS2.System.Logger.Simple hiding (info) -import HBS2.System.Logger.Simple qualified as Log import Control.Concurrent.Async import Control.Concurrent.STM @@ -32,7 +31,6 @@ import Data.Functor import Data.List qualified as List import Data.Map.Strict qualified as Map import Data.Monoid qualified as Monoid -import Data.Set qualified as Set import Options.Applicative import System.Directory import Data.Maybe @@ -47,8 +45,6 @@ import Streaming.Prelude qualified as S -- import Streaming qualified as S -logPrefix s = set loggerTr (s <>) - tracePrefix :: SetLoggerEntry tracePrefix = logPrefix "[trace] " @@ -124,7 +120,7 @@ newtype NewRefOpts = runHash :: HashOpts -> SimpleStorage HbSync -> IO () -runHash opts ss = do +runHash opts _ = do withBinaryFile (hashFp opts) ReadMode $ \h -> do LBS.hGetContents h >>= print . pretty . hashObject @HbSync @@ -190,7 +186,7 @@ runCat opts ss = do (ourkr, box) <- pure (Monoid.getFirst - (foldMap (\kr@(KeyringEntry pk sk _) + (foldMap (\kr@(KeyringEntry pk _ _) -> Monoid.First ((kr, ) <$> Map.lookup pk (Map.fromList recipientKeys))) ourKeys)) @@ -221,10 +217,10 @@ runCat opts ss = do MerkleAnn ann -> walkAnn ann -- FIXME: what-if-multiple-seq-ref-? - SeqRef (SequentialRef n (AnnotatedHashRef _ h)) -> do + SeqRef (SequentialRef _ (AnnotatedHashRef _ h)) -> do walk (fromHashRef h) - AnnRef h -> do + AnnRef _ -> do let lnk = either (error . ("Deserialise AnnotatedHashRef: " <>) . show) id $ deserialiseOrFail @AnnotatedHashRef obj let mbHead = headMay [ h @@ -235,7 +231,7 @@ runCat opts ss = do runStore :: StoreOpts -> SimpleStorage HbSync -> IO () -runStore opts ss | justInit = do +runStore opts _ | justInit = do putStrLn "initialized" where @@ -337,136 +333,6 @@ runShowPeerKey fp = do maybe1 cred' exitFailure $ \cred -> do print $ pretty $ AsBase58 (view peerSignPk cred) - - ---- - - -runNewLRef :: forall s . ( ForHBS2Basic s ) => FilePath -> FilePath -> Text -> SimpleStorage HbSync -> IO () -runNewLRef nf uf refName ss = do - hPrint stderr $ "adding a new channel ref" <+> pretty nf <+> pretty uf - nodeCred <- (parseCredentials @s . AsCredFile <$> BS.readFile nf) - `orDie` "bad node keyring file" - ownerCred <- (parseCredentials @s . AsCredFile <$> BS.readFile uf) - `orDie` "bad ref owner keyring file" - -- FIXME: extract reusable functions - -- полученный хэш будет хэшем ссылки на список референсов ноды - lrh <- (putBlock ss . serialise) (nodeLinearRefsRef @s (_peerSignPk nodeCred)) - `orDie` "can not create node refs genesis" - -- полученный хэш будет хэшем ссылки на созданный канал владельца c ownerCred - chh <- (putBlock ss . serialise) (RefGenesis @s (_peerSignPk ownerCred) refName NoMetaData) - `orDie` "can not put channel genesis block" - modifyNodeLinearRefList ss nodeCred lrh $ Set.toList . Set.insert chh . Set.fromList - print $ "channel ref:" <+> pretty chh - -modifyNodeLinearRefList :: forall s . (ForHBS2Basic s) - => SimpleStorage HbSync -> PeerCredentials s -> Hash HbSync -> ([Hash HbSync] -> [Hash HbSync]) -> IO () -modifyNodeLinearRefList ss kr chh f = - modifyLinearRef ss kr chh \mh -> do - v <- case mh of - Nothing -> pure mempty - Just h -> fromMaybe mempty . mdeserialiseMay <$> getBlock ss h - (putBlock ss . serialise) (f v) - `orDie` "can not put new node channel list block" - -runListLRef :: forall s . ( ForHBS2Basic s ) => FilePath -> SimpleStorage HbSync -> IO () -runListLRef nf ss = do - hPrint stderr $ "listing node channels" <+> pretty nf - nodeCred <- (parseCredentials @s . AsCredFile <$> BS.readFile nf) - `orDie` "bad node keyring file" - hs :: [Hash HbSync] <- readNodeLinearRefList ss (_peerSignPk nodeCred) - forM_ hs \chh -> do - putStrLn "" - print $ pretty chh - mg <- (mdeserialiseMay @(RefGenesis s) <$> getBlock ss chh) - forM_ mg \g -> do - print $ "owner:" <+> viaShow (refOwner g) - print $ "title:" <+> viaShow (refName g) - print $ "meta:" <+> viaShow (refMeta g) - simpleReadLinkVal ss chh >>= \case - Nothing -> do - print $ "empty" - Just refvalraw -> do - LinearMutableRefSigned _ ref - <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef s 'LinearRef)) refvalraw) - `orDie` "can not parse linear ref" - print $ "height: " <+> viaShow (lrefHeight ref) - print $ "val: " <+> pretty (lrefVal ref) - -readNodeLinearRefList :: forall s . (ForHBS2Basic s) - => SimpleStorage HbSync -> PubKey 'Sign s -> IO [Hash HbSync] -readNodeLinearRefList ss pk = do - -- полученный хэш будет хэшем ссылки на список референсов ноды - lrh :: Hash HbSync <- pure do - (hashObject . serialise) (nodeLinearRefsRef @s pk) - simpleReadLinkVal ss lrh >>= \case - Nothing -> pure [] - Just refvalraw -> do - LinearMutableRefSigned _ ref - <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef s 'LinearRef)) refvalraw) - `orDie` "can not parse channel ref" - fromMaybe mempty . mdeserialiseMay <$> getBlock ss (lrefVal ref) - -modifyLinearRef :: forall s. ( ForHBS2Basic s ) - => SimpleStorage HbSync - -> PeerCredentials s -- owner keyring - -> Hash HbSync -- channel id - -> (Maybe (Hash HbSync) -> IO (Hash HbSync)) - -> IO () -modifyLinearRef ss kr chh modIO = do - g :: RefGenesis s <- (mdeserialiseMay <$> getBlock ss chh) - `orDie` "can not read channel ref genesis" - when (refOwner g /= _peerSignPk kr) do - (pure Nothing) `orDie` "channel ref owner does not match genesis owner" - mrefvalraw <- simpleReadLinkVal ss chh - lmr <- case mrefvalraw of - Nothing -> do - val <- modIO Nothing - pure LinearMutableRef - { lrefId = chh - , lrefHeight = 0 - , lrefVal = val - } - Just refvalraw -> do - -- assert lrefId == h - LinearMutableRefSigned _ ref :: Signed SignaturePresent (MutableRef s 'LinearRef) - <- pure (deserialiseMay refvalraw) - `orDie` "can not parse channel ref" - val <- modIO (Just (lrefVal ref)) - pure LinearMutableRef - { lrefId = chh - , lrefHeight = lrefHeight ref + 1 - , lrefVal = val - } - (simpleWriteLinkRaw ss chh . serialise) - (LinearMutableRefSigned @s ((makeSign @s (_peerSignSk kr) . LBS.toStrict . serialise) lmr) lmr) - `orDie` "can not write link" - pure () - -runGetLRef :: forall s . ForHBS2Basic s => Hash HbSync -> SimpleStorage HbSync -> IO () -runGetLRef refh ss = do - hPrint stderr $ "getting ref value" <+> pretty refh - refvalraw <- simpleReadLinkVal ss refh - `orDie` "error reading ref val" - LinearMutableRefSigned _ ref - <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef s 'LinearRef)) refvalraw) - `orDie` "can not parse channel ref" - hPrint stderr $ "channel ref height: " <+> viaShow (lrefHeight ref) - print $ pretty (lrefVal ref) - -runUpdateLRef :: forall s . (ForHBS2Basic s) - => FilePath - -> Hash HbSync - -> Hash HbSync - -> SimpleStorage HbSync - -> IO () - -runUpdateLRef uf refh valh ss = do - hPrint stderr $ "updating channel" <+> pretty refh <+> "with value" <+> pretty valh - ownerCred <- (parseCredentials @s . AsCredFile <$> BS.readFile uf) - `orDie` "bad ref owner keyring file" - modifyLinearRef ss ownerCred refh \_ -> pure valh - --- deserialiseMay :: Serialise a => ByteString -> Maybe a @@ -542,10 +408,6 @@ main = join . customExecParser (prefs showHelpOnError) $ <> command "keyring-key-del" (info pKeyDel (progDesc "removes a keypair from the keyring")) <> command "show-peer-key" (info pShowPeerKey (progDesc "show peer key from credential file")) <> command "groupkey-new" (info pNewGroupkey (progDesc "generates a new groupkey")) - <> command "lref-new" (info pNewLRef (progDesc "generates a new linear ref")) - <> command "lref-list" (info pListLRef (progDesc "list node linear refs")) - <> command "lref-get" (info pGetLRef (progDesc "get a linear ref")) - <> command "lref-update" (info pUpdateLRef (progDesc "updates a linear ref")) <> command "reflog" (info pReflog (progDesc "reflog commands")) ) @@ -556,10 +418,10 @@ main = join . customExecParser (prefs showHelpOnError) $ pStore = do o <- common file <- optional $ strArgument ( metavar "FILE" ) - init <- optional $ flag' True ( long "init" <> help "just init storage") <&> OptInit + init' <- optional $ flag' True ( long "init" <> help "just init storage") <&> OptInit groupkeyFile <- optional $ strOption ( long "groupkey" <> help "path to groupkey file" ) b58meta <- optional $ strOption ( long "short-meta-base58" <> help "pass escaped metadata string") - pure $ withStore o (runStore ( StoreOpts init file (OptGroupkeyFile <$> groupkeyFile) b58meta)) + pure $ withStore o (runStore ( StoreOpts init' file (OptGroupkeyFile <$> groupkeyFile) b58meta)) pCat = do o <- common @@ -600,30 +462,6 @@ main = join . customExecParser (prefs showHelpOnError) $ f <- strArgument ( metavar "KEYRING-FILE" ) pure (runKeyDel s f) - pNewLRef = do - nodeCredFile <- strArgument ( metavar "NODE-KEYRING-FILE" ) - ownerCredFile <- strArgument ( metavar "REF-OWNER-KEYRING-FILE" ) - refName <- strArgument ( metavar "REF-NAME" ) - o <- common - pure $ withStore o (runNewLRef nodeCredFile ownerCredFile refName) - - pListLRef = do - nodeCredFile <- strArgument ( metavar "NODE-KEYRING-FILE" ) - o <- common - pure $ withStore o (runListLRef nodeCredFile) - - pGetLRef = do - refh <- strArgument ( metavar "REF-ID" ) - o <- common - pure $ withStore o (runGetLRef refh) - - pUpdateLRef = do - ownerCredFile <- strArgument ( metavar "REF-OWNER-KEYRING-FILE" ) - refh <- strArgument ( metavar "REF-ID" ) - valh <- strArgument ( metavar "HASH" ) - o <- common - pure $ withStore o (runUpdateLRef ownerCredFile refh valh) - pReflog = hsubparser ( command "get" (info pRefLogGet (progDesc "get reflog root") ) ) -- FIXME: only-for-hbs2-basic-encryption