diff --git a/docs/devlog.md b/docs/devlog.md index e79f4c9e..f63f08ad 100644 --- a/docs/devlog.md +++ b/docs/devlog.md @@ -848,5 +848,18 @@ FIXME: RPC, cli для линейных ссылок * [x] lref-update через rpc пира update * [x] lref-list через rpc пира list -* [ ] cli на запрос значений ссылки у всех нод +* [x] Удалить lref-* - команды из hbs2 +* [x] Попроще выдача ответов lref-* команд +* [x] Ключ для запуска команд cli, который меняет формат общения на сырой cbor в stdin, stdout. +* [x] Вынести функцию, которая будет подписывать новое значение ссылки? +* [x] в lref-update принимать опциональный параметр `counter` и его использовать + для формирования на клиенте нового подписанного значения ссылки +* [x] аналог lref-update, в которую передаётся готовое значение подписанной ссылки в stdin +* [x] возвращать ненулевой код ошибки приложения hbs2-peer на exitFailure + +* [ ] Формат списка ссылок ноды поменять на merkle-tree ? +* [ ] настройка ноды о том, от каких нод принимать новые ссылки и добавлять себе +* [ ] Получить список ссылок в виде хэша merkle-дерева * [ ] cli на запрос всех ссылок ноды +* [ ] cli на запрос значений ссылки у всех нод + diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index dce93461..f2ca2937 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -119,6 +119,9 @@ data instance Signed SignaturePresent (MutableRef e 'LinearRef) } deriving stock (Generic) +deriving instance Show (Signature e) => + Show (Signed 'SignaturePresent (MutableRef e 'LinearRef)) + instance Serialise (Signature e) => Serialise (Signed 'SignaturePresent (MutableRef e 'LinearRef)) diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs b/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs index 6fb1d87a..ea6ea90d 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs @@ -30,14 +30,14 @@ instance Serialise (Signature e) => Serialise (LRefProto e) data LRefI e m = LRefI { getBlockI :: GetBlockI HbSync m - , tryUpdateLinearRefI :: TryUpdateLinearRefI e HbSync m + , tryUpdateLinearRefI :: TryUpdateLinearRefI e m , getLRefValI :: GetLRefValI e HbSync m , broadcastLRefI :: BroadcastLRefI e HbSync m } type GetBlockI h m = Hash h -> m (Maybe ByteString) -type TryUpdateLinearRefI e h m = Hash h -> Signed SignatureVerified (MutableRef e 'LinearRef) -> m Bool +type TryUpdateLinearRefI e m = Signed SignatureVerified (MutableRef e 'LinearRef) -> m Bool type GetLRefValI e h m = Hash h -> m (Maybe (Signed SignaturePresent (MutableRef e 'LinearRef))) @@ -63,7 +63,7 @@ refLinearProto LRefI{..} = \case (((either (const Nothing) Just . deserialiseOrFail) =<<) <$> getBlockI h) lift $ forM_ (verifyLinearMutableRefSigned (refOwner g) lref) \vlref -> do - r <- tryUpdateLinearRefI h vlref + r <- tryUpdateLinearRefI vlref when r $ void $ runMaybeT do slref <- MaybeT (getLRefValI h) lift $ broadcastLRefI (AnnLRef @e h slref) diff --git a/hbs2-core/lib/HBS2/Refs/Linear.hs b/hbs2-core/lib/HBS2/Refs/Linear.hs index 5001c1e5..96af5d87 100644 --- a/hbs2-core/lib/HBS2/Refs/Linear.hs +++ b/hbs2-core/lib/HBS2/Refs/Linear.hs @@ -19,6 +19,7 @@ import HBS2.Prelude.Plated import HBS2.Storage import Codec.Serialise (serialise, deserialiseOrFail) +import Control.Monad.Trans.Maybe import Data.ByteString.Lazy qualified as LBS import Data.Maybe import Data.Set qualified as Set @@ -51,6 +52,7 @@ modifyLinearRef ss kr chh modIO = do , lrefVal = val } Just refvalraw -> do + -- FIXME: do not increment counter if value is the same LinearMutableRefSigned _ ref :: Signed SignaturePresent (MutableRef e 'LinearRef) <- pure ((either (const Nothing) Just . deserialiseOrFail) refvalraw) `orDie` "can not parse channel ref" @@ -61,11 +63,14 @@ modifyLinearRef ss kr chh modIO = do , lrefHeight = lrefHeight ref + 1 , lrefVal = val } - (writeLinkRaw ss chh . serialise) - (LinearMutableRefSigned @e ((makeSign @e (_peerSignSk kr) . LBS.toStrict . serialise) lmr) lmr) + (writeLinkRaw ss chh . serialise) (signLinearMutableRef @e (_peerSignSk kr) lmr) `orDie` "can not write link" pure () +signLinearMutableRef :: forall e. (Signatures e) + => PrivKey 'Sign e -> MutableRef e 'LinearRef -> Signed 'SignaturePresent (MutableRef e 'LinearRef) +signLinearMutableRef sk lmr = LinearMutableRefSigned @e ((makeSign @e sk . LBS.toStrict . serialise) lmr) lmr + verifyLinearMutableRefSigned :: forall e. (Signatures e) => PubKey 'Sign e -> Signed SignaturePresent (MutableRef e 'LinearRef) @@ -76,6 +81,24 @@ verifyLinearMutableRefSigned pk lref = do where dat = (LBS.toStrict . serialise) (lmrefSignedRef lref) +tryUpdateLinearRefSigned :: forall e. + ( Signatures e + , Serialise (Signature e) + , Serialise (PubKey 'Sign e) + , Eq (PubKey 'Sign e) + , Block LBS.ByteString ~ LBS.ByteString + ) + => AnyStorage + -> Signed SignaturePresent (MutableRef e 'LinearRef) + -> IO Bool +tryUpdateLinearRefSigned st slref = do + (maybe (pure False) pure =<<) $ runMaybeT do + g :: RefGenesis e <- MaybeT $ + (((either (const Nothing) Just . deserialiseOrFail) =<<) + <$> getBlock st ((lrefId . lmrefSignedRef) slref)) + vlref <- MaybeT . pure $ (verifyLinearMutableRefSigned (refOwner g) slref) + lift $ tryUpdateLinearRef st vlref + tryUpdateLinearRef :: forall e. ( Signatures e , Serialise (Signature e) @@ -84,10 +107,10 @@ tryUpdateLinearRef :: forall e. , Block LBS.ByteString ~ LBS.ByteString ) => AnyStorage - -> Hash HbSync -- channel id -> Signed SignatureVerified (MutableRef e 'LinearRef) -> IO Bool -tryUpdateLinearRef ss chh vlref = do +tryUpdateLinearRef ss vlref = do + let chh = lrefId . lmrefVSignedRef $ vlref g :: RefGenesis e <- (((either (const Nothing) Just . deserialiseOrFail) =<<) <$> getBlock ss chh) `orDie` "can not read channel ref genesis" @@ -176,3 +199,4 @@ nodeRefListAdd st nodeCred chh = do lrh <- (putBlock st . serialise) (nodeLinearRefsRef @e (_peerSignPk nodeCred)) `orDie` "can not create node refs genesis" modifyNodeLinearRefList st nodeCred lrh $ Set.toList . Set.insert chh . Set.fromList + diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index c48e04c4..cc761a52 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -3,6 +3,7 @@ {-# Language AllowAmbiguousTypes #-} {-# Language UndecidableInstances #-} {-# Language MultiWayIf #-} +{-# Language RankNTypes #-} module Main where import HBS2.Actors.Peer @@ -53,6 +54,7 @@ import Control.Concurrent.STM import Control.Exception as Exception import Control.Monad.Reader import Control.Monad.Trans.Maybe +import Data.ByteString qualified as BS import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy qualified as LBS import Data.List qualified as L @@ -177,11 +179,6 @@ data RPCCommand = | FETCH (Hash HbSync) | PEERS | SETLOG SetLogging - | LREFANN (Hash HbSync) - | LREFNEW (PubKey 'Sign UDP) Text - | LREFLIST - | LREFGET (Hash HbSync) - | LREFUPDATE (PrivKey 'Sign UDP) (PubKey 'Sign UDP) (Hash HbSync) (Hash HbSync) data PeerOpts = PeerOpts @@ -249,6 +246,7 @@ runCLI = join . customExecParser (prefs showHelpOnError) $ <> command "lref-list" (info pLRefList (progDesc "list node linear refs")) <> command "lref-get" (info pLRefGet (progDesc "get a linear ref")) <> command "lref-update" (info pLRefUpdate (progDesc "updates a linear ref")) + <> command "lref-update-raw" (info pLRefUpdateRaw (progDesc "updates a linear ref with already signed data")) ) confOpt = strOption ( long "config" <> short 'c' <> help "config" ) @@ -322,39 +320,64 @@ runCLI = join . customExecParser (prefs showHelpOnError) $ pLRefAnn = do rpc <- pRpcCommon h <- strArgument ( metavar "HASH" ) - pure $ runRpcCommand rpc (LREFANN h) + pure $ withRPC rpc (RPCLRefAnn h) pLRefNew = do rpc <- pRpcCommon credFile <- strOption ( short 'k' <> long "key" <> help "author keys file" ) + cbor <- switch ( long "cbor" <> help "use cbor as output format" ) t <- strArgument ( metavar "TEXT" ) - pure $ do + pure do cred <- (LBS.readFile credFile <&> parseCredentials @UDP . AsCredFile . LBS.toStrict . LBS.take 4096) `orDie` "can't parse credential file" - runRpcCommand rpc (LREFNEW (_peerSignPk cred) t) + let ofmt = if cbor then FmtCbor else FmtPretty + withRPC' ofmt rpc (RPCLRefNew (_peerSignPk cred) t) pLRefList = do rpc <- pRpcCommon pure $ do - runRpcCommand rpc (LREFLIST) + withRPC rpc RPCLRefList pLRefGet = do rpc <- pRpcCommon h <- strArgument ( metavar "REF-ID" ) - pure $ runRpcCommand rpc (LREFGET h) + cbor <- switch ( long "cbor" <> help "use cbor as output format" ) + pure do + let ofmt = if cbor then FmtCbor else FmtPretty + withRPC' ofmt rpc (RPCLRefGet h) pLRefUpdate = do rpc <- pRpcCommon credFile <- strOption ( short 'k' <> long "key" <> help "author keys file" ) lrefId <- strArgument ( metavar "REF-ID" ) hval <- strArgument ( metavar "HASH" ) + cbor <- switch ( long "cbor" <> help "use cbor as output format" ) + mcounter <- (optional . option auto) ( long "counter" <> help "explicit counter value" ) pure $ do cred <- (LBS.readFile credFile <&> parseCredentials @UDP . AsCredFile . LBS.toStrict . LBS.take 4096) `orDie` "can't parse credential file" - runRpcCommand rpc (LREFUPDATE (_peerSignSk cred) (_peerSignPk cred) lrefId hval) + let ofmt = if cbor then FmtCbor else FmtPretty + case mcounter of + Nothing -> withRPC' ofmt rpc (RPCLRefUpdate (_peerSignSk cred) (_peerSignPk cred) lrefId hval) + Just height -> do + let lref = signLinearMutableRef (_peerSignSk cred) + $ LinearMutableRef + { lrefId = lrefId + , lrefHeight = height + , lrefVal = hval + } + withRPC' ofmt rpc (RPCLRefUpdateRaw lref) + pLRefUpdateRaw = do + rpc <- pRpcCommon + cbor <- switch ( long "cbor" <> help "use cbor as output format (always on)" ) + pure $ do + raw <- LBS.hGetContents stdin + lref <- pure ((either (const Nothing) Just . deserialiseOrFail) raw) + `orDie` "can't parse Signed mutable linear ref from stdin" + withRPC' FmtPretty rpc (RPCLRefUpdateRaw lref) myException :: SomeException -> IO () myException e = die ( show e ) >> exitFailure @@ -560,7 +583,7 @@ runPeer opts = Exception.handle myException $ do st <- getStorage let getBlockI = liftIO . getBlock st - tryUpdateLinearRefI h = liftIO . tryUpdateLinearRef st h + tryUpdateLinearRefI = liftIO . tryUpdateLinearRef st broadcastLRefI = broadcastMsgAction getLRefValI = getLRefValAction st pure LRefI {..} @@ -738,13 +761,6 @@ runPeer opts = Exception.handle myException $ do withDownload denv $ do processBlock h - LREFANN h -> do - debug $ "got lrefann rpc" <+> pretty h - st <- getStorage - void $ runMaybeT do - slref <- MaybeT $ getLRefValAction st h - lift $ broadcastMsgAction' env (AnnLRef @e h slref :: LRefProto UDP) - _ -> pure () @@ -806,8 +822,12 @@ runPeer opts = Exception.handle myException $ do trace "TraceOff" setLoggingOff @TRACE - let lrefAnnAction h = do - liftIO $ atomically $ writeTQueue rpcQ (LREFANN h) + let lrefAnnAction h = void $ liftIO $ async $ withPeerM penv $ do + st <- getStorage + void $ runMaybeT do + slref <- MaybeT $ getLRefValAction st h + env <- ask + lift $ broadcastMsgAction' env (AnnLRef @e h slref :: LRefProto UDP) let lrefNewAction q@(pk, t) = do debug $ "lrefNewAction" <+> viaShow q @@ -848,13 +868,23 @@ runPeer opts = Exception.handle myException $ do void $ liftIO $ async $ withPeerM penv $ do st <- getStorage let cred = PeerCredentials @e sk pk mempty - -- FIXME: do not increment counter if value is the same liftIO $ modifyLinearRef st cred lrefId \_ -> pure valh mlref <- getLRefValAction st lrefId request who (RPCLRefUpdateAnswer @e mlref) -- FIXME: maybe fire rpc command to announce new lref value debug $ "lrefUpdateAction sent" <+> pretty mlref + let lrefUpdateRawAction slref = do + debug $ "lrefUpdateRawAction" <+> pretty slref + who <- thatPeer (Proxy @(RPC e)) + void $ liftIO $ async $ withPeerM penv $ do + st <- getStorage + liftIO $ tryUpdateLinearRefSigned st slref + mlref <- getLRefValAction st ((lrefId . lmrefSignedRef) slref) + request who (RPCLRefUpdateAnswer @e mlref) + -- FIXME: maybe fire rpc command to announce new lref value + debug $ "lrefUpdateRawAction sent" <+> pretty mlref + let arpc = RpcAdapter { rpcOnPoke = pokeAction , rpcOnPokeAnswer = dontHandle @@ -873,6 +903,7 @@ runPeer opts = Exception.handle myException $ do , rpcOnLRefGet = lrefGetAction , rpcOnLRefGetAnswer = dontHandle , rpcOnLRefUpdate = lrefUpdateAction + , rpcOnLRefUpdateRaw = lrefUpdateRawAction , rpcOnLRefUpdateAnswer = dontHandle } @@ -920,7 +951,13 @@ emitToPeer :: ( MonadIO m emitToPeer env k e = liftIO $ withPeerM env (emit k e) withRPC :: RPCOpt -> RPC UDP -> IO () -withRPC o cmd = do +withRPC o cmd = + withRPC' FmtPretty o cmd + +data Fmt = FmtPretty | FmtCbor + +withRPC' :: Fmt -> RPCOpt -> RPC UDP -> IO () +withRPC' ofmt o cmd = do setLoggingOff @DEBUG @@ -976,6 +1013,7 @@ withRPC o cmd = do , rpcOnLRefGetAnswer = liftIO . atomically . writeTQueue lrefGetQ -- , rpcOnLRefUpdate = const $ liftIO exitSuccess + , rpcOnLRefUpdateRaw = const $ liftIO exitSuccess , rpcOnLRefUpdateAnswer = liftIO . atomically . writeTQueue lrefUpdateQ } @@ -1018,40 +1056,63 @@ withRPC o cmd = do RPCLRefAnn{} -> pause @'Seconds 0.1 >> liftIO exitSuccess - RPCLRefNew{} -> do - fix \go -> do - r <- liftIO $ race (pause @'Seconds 5) - (atomically $ readTQueue lrefNewQ) - case r of + RPCLRefNew{} -> liftIO do + race (pause @'Seconds 1) + (atomically $ readTQueue lrefNewQ) + >>= either (const exitFailure) \pa -> do + case ofmt of + FmtPretty -> hPrint stdout . pretty $ pa + FmtCbor -> BS.hPut stdout . LBS.toStrict . serialise $ pa + exitSuccess + + RPCLRefList{} -> liftIO $ fix \go -> do + race (pause @'Seconds 1) + (atomically $ readTQueue lrefListQ) + >>= \case Left _ -> pure () Right pa -> do - Log.info $ "got RPCLRefNewAnswer" <+> pretty pa + case ofmt of + FmtPretty -> hPrint stdout . pretty $ pa + FmtCbor -> BS.hPut stdout . LBS.toStrict . serialise $ pa go liftIO exitSuccess - RPCLRefList{} -> - void $ liftIO $ void $ race (pause @'Seconds 5 >> exitSuccess) do - forever do - (g, lrefVal) <- liftIO $ atomically $ readTQueue lrefListQ - Log.info $ "got RPCLRefListAnswer" <+> pretty g <+> pretty lrefVal + RPCLRefGet{} -> liftIO do + race (pause @'Seconds 1) + (atomically $ readTQueue lrefGetQ) + >>= either (const exitFailure) \case + Nothing -> exitFailure + Just pa -> do + case ofmt of + FmtPretty -> hPrint stdout . pretty . lrefId . lmrefSignedRef $ pa + FmtCbor -> BS.hPut stdout . LBS.toStrict . serialise $ pa + exitSuccess - RPCLRefGet{} -> - void $ liftIO $ void $ race (pause @'Seconds 5 >> exitFailure) do - pa <- liftIO $ atomically $ readTQueue lrefGetQ - Log.info $ "got RPCLRefGetAnswer" <+> pretty pa + RPCLRefUpdate{} -> liftIO do + race (pause @'Seconds 1) + (atomically $ readTQueue lrefUpdateQ) + >>= either (const exitFailure) \pa -> do + case ofmt of + FmtPretty -> hPrint stdout . pretty $ pa + FmtCbor -> BS.hPut stdout . LBS.toStrict . serialise $ pa exitSuccess - RPCLRefUpdate{} -> - void $ liftIO $ void $ race (pause @'Seconds 5 >> exitFailure) do - pa <- liftIO $ atomically $ readTQueue lrefUpdateQ - Log.info $ "got RPCLRefUpdateAnswer" <+> pretty pa + RPCLRefUpdateRaw raw -> liftIO do + race (pause @'Seconds 1) + (atomically $ readTQueue lrefUpdateQ) + >>= either (const exitFailure) \pa -> do + case ofmt of + FmtPretty -> hPrint stdout . pretty $ pa + FmtCbor -> BS.hPut stdout . LBS.toStrict . serialise $ pa + when ((lrefVal . lmrefSignedRef <$> pa) /= Just ((lrefVal . lmrefSignedRef) raw)) + exitFailure exitSuccess _ -> pure () void $ liftIO $ waitAnyCatchCancel [proto] - void $ waitAnyCatchCancel [mrpc, prpc] + void $ waitAnyCancel [mrpc, prpc] runRpcCommand :: RPCOpt -> RPCCommand -> IO () runRpcCommand opt = \case @@ -1061,21 +1122,6 @@ runRpcCommand opt = \case FETCH h -> withRPC opt (RPCFetch h) PEERS -> withRPC opt RPCPeers SETLOG s -> withRPC opt (RPCLogLevel s) - LREFANN h -> withRPC opt (RPCLRefAnn h) - LREFNEW pk title -> withRPC opt (RPCLRefNew pk title) - LREFLIST -> withRPC opt RPCLRefList - LREFGET h -> withRPC opt (RPCLRefGet h) - LREFUPDATE sk pk lrefId h -> do - -- FIXME LREFUPDATE implementation - -- запросить текущее значение ссылки с помощью (RPCLRefGet h) - -- увеличить счётчик, обновить значение, подписать - -- выполнить (RPCLRefUpdate lref) - -- дождаться ответа - -- let - -- lref :: Signed 'SignaturePresent (MutableRef UDP 'LinearRef) - -- lref = undefined - -- withRPC opt (RPCLRefUpdate lref) - withRPC opt (RPCLRefUpdate sk pk lrefId h) _ -> pure () diff --git a/hbs2-peer/app/RPC.hs b/hbs2-peer/app/RPC.hs index dcbcda36..8c76b6c5 100644 --- a/hbs2-peer/app/RPC.hs +++ b/hbs2-peer/app/RPC.hs @@ -40,8 +40,8 @@ data RPC e = | RPCLRefListAnswer (RefGenesis [Hash HbSync], Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef))) | RPCLRefGet (Hash HbSync) | RPCLRefGetAnswer (Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef))) - -- | RPCLRefUpdate (Signed 'SignaturePresent (MutableRef e 'LinearRef)) | RPCLRefUpdate (PrivKey 'Sign UDP) (PubKey 'Sign UDP) (Hash HbSync) (Hash HbSync) + | RPCLRefUpdateRaw (Signed 'SignaturePresent (MutableRef e 'LinearRef)) | RPCLRefUpdateAnswer (Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef))) deriving stock (Generic) @@ -84,8 +84,8 @@ data RpcAdapter e m = , rpcOnLRefListAnswer :: (RefGenesis [Hash HbSync], Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef))) -> m () , rpcOnLRefGet :: Hash HbSync -> m () , rpcOnLRefGetAnswer :: Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef)) -> m () - -- , rpcOnLRefUpdate :: (Signed 'SignaturePresent (MutableRef e 'LinearRef)) -> m () , rpcOnLRefUpdate :: (PrivKey 'Sign UDP, PubKey 'Sign UDP, Hash HbSync, Hash HbSync) -> m () + , rpcOnLRefUpdateRaw :: Signed 'SignaturePresent (MutableRef e 'LinearRef) -> m () , rpcOnLRefUpdateAnswer :: Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef)) -> m () } @@ -143,6 +143,6 @@ rpcHandler adapter = \case (RPCLRefListAnswer lrefVal) -> rpcOnLRefListAnswer adapter lrefVal (RPCLRefGet h) -> rpcOnLRefGet adapter h (RPCLRefGetAnswer hval) -> rpcOnLRefGetAnswer adapter hval - -- (RPCLRefUpdate upd) -> rpcOnLRefUpdate adapter upd (RPCLRefUpdate sk pk lrefId h) -> rpcOnLRefUpdate adapter (sk, pk, lrefId, h) + (RPCLRefUpdateRaw lref) -> rpcOnLRefUpdateRaw adapter lref (RPCLRefUpdateAnswer mupd) -> rpcOnLRefUpdateAnswer adapter mupd diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 47230e17..da56084f 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -160,7 +160,7 @@ runCat opts ss = do blkc <- getBlock ss crypth `orDie` (show $ "missed block: " <+> pretty crypth) recipientKeys :: [(PubKey 'Encrypt MerkleEncryptionType, EncryptedBox)] - <- pure (deserialiseMay blkc) + <- pure ((either (const Nothing) Just . deserialiseOrFail) blkc) `orDie` "can not deserialise access key" (ourkr, box) @@ -235,7 +235,8 @@ runStore opts ss = do & S.mapM (fmap LBS.fromStrict . Encrypt.boxSeal (recipientPk gk) . LBS.toStrict) mhash <- putAsMerkle ss encryptedChunks - mtree <- (mdeserialiseMay <$> getBlock ss (fromMerkleHash mhash)) + mtree <- (((either (const Nothing) Just . deserialiseOrFail) =<<) + <$> getBlock ss (fromMerkleHash mhash)) `orDie` "merkle tree was not stored properly with `putAsMerkle`" mannh <- maybe (die "can not store MerkleAnn") pure @@ -320,68 +321,6 @@ runDumpACB inFile = do --- -runNewLRef :: FilePath -> FilePath -> Text -> SimpleStorage HbSync -> IO () -runNewLRef nf uf refName (AnyStorage -> st) = do - hPrint stderr $ "adding a new channel ref" <+> pretty nf <+> pretty uf - nodeCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile nf) - `orDie` "bad node keyring file" - ownerCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile uf) - `orDie` "bad ref owner keyring file" - hPrint stdout . pretty - =<< nodeRefListNew st nodeCred (_peerSignPk ownerCred) refName NoMetaData - -runListLRef :: FilePath -> SimpleStorage HbSync -> IO () -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 @UDP st (_peerSignPk nodeCred) - forM_ hs \chh -> do - putStrLn "" - print $ pretty 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) - readLinkRaw st chh >>= \case - Nothing -> do - print $ "empty" - Just refvalraw -> do - LinearMutableRefSigned _ ref - <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef UDP 'LinearRef)) refvalraw) - `orDie` "can not parse linear ref" - print $ "height: " <+> viaShow (lrefHeight ref) - print $ "val: " <+> pretty (lrefVal ref) - -runGetLRef :: Hash HbSync -> SimpleStorage HbSync -> IO () -runGetLRef refh (AnyStorage -> st) = do - hPrint stderr $ "getting ref value" <+> pretty refh - refvalraw <- readLinkRaw st refh - `orDie` "error reading ref val" - LinearMutableRefSigned _ ref - <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef UDP 'LinearRef)) refvalraw) - `orDie` "can not parse channel ref" - hPrint stderr $ "channel ref height: " <+> viaShow (lrefHeight ref) - print $ pretty (lrefVal ref) - -runUpdateLRef :: FilePath -> Hash HbSync -> Hash HbSync -> SimpleStorage HbSync -> IO () -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 st ownerCred refh \_ -> pure valh - ---- - -deserialiseMay :: Serialise a => ByteString -> Maybe a -deserialiseMay = either (const Nothing) Just . deserialiseOrFail - -mdeserialiseMay :: Serialise a => Maybe ByteString -> Maybe a -mdeserialiseMay = (deserialiseMay =<<) - ---- - withStore :: Data opts => opts -> ( SimpleStorage HbSync -> IO () ) -> IO () withStore opts f = do xdg <- getXdgDirectory XdgData defStorePath <&> fromString @@ -420,10 +359,6 @@ main = join . customExecParser (prefs showHelpOnError) $ <> command "groupkey-new" (info pNewGroupkey (progDesc "generates a new groupkey")) <> command "acb-gen" (info pACBGen (progDesc "generates binary ACB from text config")) <> command "acb-dump" (info pACBDump (progDesc "dumps binary ACB to text config")) - <> 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")) ) common = do @@ -489,27 +424,3 @@ main = join . customExecParser (prefs showHelpOnError) $ pACBDump = do f <- optional $ strArgument ( metavar "ACB-FILE-INPUT" ) pure (runDumpACB 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)