mirror of https://github.com/voidlizard/hbs2
lref corrections
This commit is contained in:
Sergey Ivanov
parent
3207a48968
commit
d096c49fbb
|
|
@ -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 на запрос значений ссылки у всех нод
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
RPCLRefNew{} -> liftIO do
|
||||
race (pause @'Seconds 1)
|
||||
(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{} ->
|
||||
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{} ->
|
||||
void $ liftIO $ void $ race (pause @'Seconds 5 >> exitFailure) do
|
||||
pa <- liftIO $ atomically $ readTQueue lrefGetQ
|
||||
Log.info $ "got RPCLRefGetAnswer" <+> pretty pa
|
||||
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
|
||||
|
||||
RPCLRefUpdate{} ->
|
||||
void $ liftIO $ void $ race (pause @'Seconds 5 >> exitFailure) do
|
||||
pa <- liftIO $ atomically $ readTQueue lrefUpdateQ
|
||||
Log.info $ "got RPCLRefUpdateAnswer" <+> 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
|
||||
|
||||
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 ()
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
95
hbs2/Main.hs
95
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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue