lref corrections

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 на запрос значений ссылки у всех нод
+

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))
 

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)

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)
+    (writeLinkRaw ss chh . serialise) (signLinearMutableRef @e (_peerSignSk kr) lmr)
-      (LinearMutableRefSigned @e ((makeSign @e (_peerSignSk kr) . LBS.toStrict . serialise) lmr) 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
+

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
+  let lrefAnnAction h = void $ liftIO $ async $ withPeerM penv $ do
-        liftIO $ atomically $ writeTQueue rpcQ (LREFANN h)
+        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
+                      RPCLRefNew{} -> liftIO do
-                          fix \go -> do
+                          race (pause @'Seconds 1)
-                              r <- liftIO $ race (pause @'Seconds 5)
                                (atomically $ readTQueue lrefNewQ)
-                              case r of
+                            >>= 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{} ->
+                      RPCLRefGet{} -> liftIO do
-                        void $ liftIO $ void $ race (pause @'Seconds 5 >> exitSuccess) do
+                          race (pause @'Seconds 1)
-                            forever do
+                               (atomically $ readTQueue lrefGetQ)
-                                 (g, lrefVal) <- liftIO $ atomically $ readTQueue lrefListQ
+                            >>= either (const exitFailure) \case
-                                 Log.info $ "got RPCLRefListAnswer" <+> pretty g <+> pretty lrefVal
+                                Nothing -> exitFailure
-
+                                Just pa -> do
-                      RPCLRefGet{} ->
+                                  case ofmt of
-                        void $ liftIO $ void $ race (pause @'Seconds 5 >> exitFailure) do
+                                        FmtPretty -> hPrint stdout . pretty . lrefId . lmrefSignedRef $ pa
-                                 pa <- liftIO $ atomically $ readTQueue lrefGetQ
+                                        FmtCbor -> BS.hPut stdout . LBS.toStrict . serialise $ pa
-                                 Log.info $ "got RPCLRefGetAnswer" <+> pretty pa
                                   exitSuccess
 
-                      RPCLRefUpdate{} ->
+                      RPCLRefUpdate{} -> liftIO do
-                        void $ liftIO $ void $ race (pause @'Seconds 5 >> exitFailure) do
+                          race (pause @'Seconds 1)
-                                 pa <- liftIO $ atomically $ readTQueue lrefUpdateQ
+                               (atomically $ readTQueue lrefUpdateQ)
-                                 Log.info $ "got RPCLRefUpdateAnswer" <+> pretty pa
+                            >>= either (const exitFailure) \pa -> do
+                                 case ofmt of
+                                       FmtPretty -> hPrint stdout . pretty $ pa
+                                       FmtCbor -> BS.hPut stdout . LBS.toStrict . serialise $ pa
+                                 exitSuccess
+
+                      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 ()
 

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

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)