mirror of https://github.com/voidlizard/hbs2
qblf update
This commit is contained in:
Snail
voidlizard
parent
304ff22718
commit
5a57da4334
|
|
@ -0,0 +1,6 @@
|
|||
module Main where
|
||||
|
||||
import RefChanQBLF.CLI qualified as CLI
|
||||
|
||||
main :: IO ()
|
||||
main = CLI.main
|
||||
|
|
@ -1,137 +0,0 @@
|
|||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
{-# Language TypeOperators #-}
|
||||
module Demo.QBLF.Transactions where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Hash
|
||||
import HBS2.Base58
|
||||
import HBS2.Peer.Proto
|
||||
import HBS2.Data.Types.Refs (HashRef(..))
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Messaging.Unix (UNIX)
|
||||
|
||||
import Data.Hashable(Hashable(..))
|
||||
import Codec.Serialise
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Word (Word64)
|
||||
import System.Random
|
||||
|
||||
newtype Actor s =
|
||||
Actor { fromActor :: PubKey 'Sign s }
|
||||
deriving stock (Generic)
|
||||
|
||||
deriving stock instance Eq (PubKey 'Sign s) => Eq (Actor s)
|
||||
deriving newtype instance Hashable (PubKey 'Sign s) => Hashable (Actor s)
|
||||
|
||||
instance Pretty (AsBase58 (PubKey 'Sign s)) => Pretty (Actor s) where
|
||||
pretty (Actor a) = pretty (AsBase58 a)
|
||||
|
||||
type Account s = PubKey 'Sign s
|
||||
|
||||
newtype Amount = Amount Integer
|
||||
deriving stock (Eq,Show,Ord,Data,Generic)
|
||||
deriving newtype (Read,Enum,Num,Integral,Real,Pretty)
|
||||
|
||||
newtype DAppState = DAppState { fromDAppState :: HashRef }
|
||||
deriving stock (Eq,Show,Ord,Data,Generic)
|
||||
deriving newtype (Hashable,Pretty)
|
||||
|
||||
instance Hashed HbSync DAppState where
|
||||
hashObject (DAppState (HashRef h)) = h
|
||||
|
||||
data EmitTx s = EmitTx (Account s) Amount Word64
|
||||
deriving stock (Generic)
|
||||
|
||||
data MoveTx s = MoveTx (Account s) (Account s) Amount Word64
|
||||
deriving stock (Generic)
|
||||
|
||||
data QBLFDemoToken s =
|
||||
Emit (SignedBox (EmitTx s) s) -- proof: owner's key
|
||||
| Move (SignedBox (MoveTx s) s) -- proof: wallet's key
|
||||
deriving stock (Generic)
|
||||
|
||||
instance ForQBLFDemoToken s => Serialise (Actor s)
|
||||
|
||||
instance Serialise DAppState
|
||||
|
||||
instance Serialise Amount
|
||||
|
||||
instance ForQBLFDemoToken s => Serialise (EmitTx s)
|
||||
|
||||
instance ForQBLFDemoToken s => Serialise (MoveTx s)
|
||||
|
||||
instance ForQBLFDemoToken s => Serialise (QBLFDemoToken s)
|
||||
|
||||
type ForQBLFDemoToken s = ( Eq (PubKey 'Sign s)
|
||||
, Eq (Signature s)
|
||||
, Pretty (AsBase58 (PubKey 'Sign s))
|
||||
, ForSignedBox s
|
||||
, FromStringMaybe (PubKey 'Sign s)
|
||||
, Serialise (PubKey 'Sign s)
|
||||
, Serialise (Signature s)
|
||||
, Hashable (PubKey 'Sign s)
|
||||
)
|
||||
|
||||
deriving stock instance (ForQBLFDemoToken s) => Eq (QBLFDemoToken s)
|
||||
|
||||
instance ForQBLFDemoToken s => Hashable (QBLFDemoToken s) where
|
||||
hashWithSalt salt = \case
|
||||
Emit box -> hashWithSalt salt box
|
||||
Move box -> hashWithSalt salt box
|
||||
|
||||
newtype QBLFDemoTran e =
|
||||
QBLFDemoTran (SignedBox (QBLFDemoToken (Encryption e)) (Encryption e))
|
||||
deriving stock Generic
|
||||
|
||||
instance ForRefChans e => Serialise (QBLFDemoTran e)
|
||||
|
||||
deriving newtype instance
|
||||
(Eq (PubKey 'Sign (Encryption e)), Eq (Signature (Encryption e)))
|
||||
=> Eq (QBLFDemoTran e)
|
||||
|
||||
deriving newtype instance
|
||||
(Eq (Signature (Encryption e)), ForRefChans e)
|
||||
=> Hashable (QBLFDemoTran e)
|
||||
|
||||
instance HasProtocol UNIX (QBLFDemoTran UNIX) where
|
||||
type instance ProtocolId (QBLFDemoTran UNIX) = 0xFFFF0001
|
||||
type instance Encoded UNIX = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
encode = serialise
|
||||
|
||||
makeEmitTx :: forall s e m . ( MonadIO m
|
||||
, ForRefChans e
|
||||
, ForQBLFDemoToken s
|
||||
, Signatures (Encryption e)
|
||||
, s ~ Encryption e
|
||||
)
|
||||
=> PubKey 'Sign s
|
||||
-> PrivKey 'Sign s
|
||||
-> Account s
|
||||
-> Amount
|
||||
-> m (QBLFDemoToken s)
|
||||
|
||||
makeEmitTx pk sk acc amount = do
|
||||
nonce <- randomIO
|
||||
let box = makeSignedBox @s pk sk (EmitTx acc amount nonce)
|
||||
pure (Emit @s box)
|
||||
|
||||
makeMoveTx :: forall s e m . ( MonadIO m
|
||||
, ForQBLFDemoToken s
|
||||
, ForRefChans e
|
||||
, Signatures s
|
||||
, s ~ Encryption e
|
||||
)
|
||||
=> PubKey 'Sign s -- from pk
|
||||
-> PrivKey 'Sign s -- from sk
|
||||
-> Account s
|
||||
-> Amount -- amount
|
||||
-> m (QBLFDemoToken s)
|
||||
|
||||
makeMoveTx pk sk acc amount = do
|
||||
nonce <- randomIO
|
||||
let box = makeSignedBox @s pk sk (MoveTx pk acc amount nonce)
|
||||
pure (Move @s box)
|
||||
|
||||
|
|
@ -0,0 +1,182 @@
|
|||
module RefChanQBLF.App where
|
||||
|
||||
import Codec.Serialise
|
||||
import Control.Monad.Cont
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Cache qualified as Cache
|
||||
import Data.HashSet qualified as HashSet
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Actors.Peer.Types ()
|
||||
import HBS2.Clock
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Defaults
|
||||
import HBS2.Hash
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Messaging.Unix
|
||||
import HBS2.Net.Proto.QBLF
|
||||
import HBS2.Net.Proto.Service
|
||||
import HBS2.OrDie
|
||||
import HBS2.Peer.Proto.RefChan
|
||||
import HBS2.Prelude
|
||||
import HBS2.Storage.Simple
|
||||
import HBS2.System.Logger.Simple
|
||||
import Lens.Micro.Platform hiding ((.=))
|
||||
import System.Directory
|
||||
|
||||
import RefChanQBLF.Common
|
||||
import RefChanQBLF.Impl
|
||||
import RefChanQBLF.RPCServer
|
||||
import RefChanQBLF.Transactions
|
||||
|
||||
data QBLFAppConf = QBLFAppConf
|
||||
{ qapActorKeyring :: FilePath
|
||||
, qapRefchanID :: RefChanId L4Proto
|
||||
, qapSocket :: FilePath
|
||||
, qapAppSocket :: FilePath
|
||||
, qapDefState :: Maybe (Hash HbSync)
|
||||
, qapStateRef :: MyRefKey
|
||||
}
|
||||
|
||||
withSimpleAnyStorage :: FilePath -> (AnyStorage -> IO r) -> IO r
|
||||
withSimpleAnyStorage storepath go = do
|
||||
-- FIXME: fix-default-storage
|
||||
xdg <- getXdgDirectory XdgData storepath <&> fromString
|
||||
sto' <- simpleStorageInit @HbSync [StoragePrefix xdg]
|
||||
flip runContT go do
|
||||
replicateM 4 $ contAsync $ simpleStorageWorker sto'
|
||||
pure $ AnyStorage sto'
|
||||
|
||||
loadCreds :: FilePath -> IO (PeerCredentials 'HBS2Basic)
|
||||
loadCreds fpath = do
|
||||
bs <- BS.readFile fpath
|
||||
pure (parseCredentials @'HBS2Basic (AsCredFile bs)) `orDie` "bad keyring file"
|
||||
|
||||
runQBLFApp :: (ForConsensus IO) => QBLFAppConf -> IO ()
|
||||
runQBLFApp QBLFAppConf {..} = withLogging do
|
||||
creds <- loadCreds qapActorKeyring
|
||||
|
||||
whenM (doesFileExist qapSocket) $ removeFile qapSocket
|
||||
|
||||
-- FIXME: fix-hardcoded-timeout
|
||||
fetches <- Cache.newCache (Just (toTimeSpec (TimeoutSec 30)))
|
||||
|
||||
flip runContT pure do
|
||||
sto <- ContT $ withSimpleAnyStorage defStorePath
|
||||
|
||||
server <- newMessagingUnixOpts [MUNoFork] True 1.0 qapSocket
|
||||
contAsync $ runMessagingUnix server
|
||||
|
||||
s0 <- lift $ readOrCreateStateRef qapDefState sto qapStateRef
|
||||
debug $ "STATE0:" <+> pretty s0
|
||||
|
||||
let myEnv =
|
||||
MyEnv
|
||||
{ mySelf = fromString qapSocket -- Peer UNIX
|
||||
, myFab = (Fabriq server) -- Fabriq UNIX
|
||||
, myChan = qapRefchanID -- RefChanId UNIX
|
||||
, myRef = qapStateRef -- MyRefKey
|
||||
, mySto = sto -- AnyStorage
|
||||
, myCred = creds -- PeerCredentials 'HBS2Basic
|
||||
-- , myAppSoPath = appso -- TODO ?
|
||||
, myFetch = fetches -- Cache HashRef ()
|
||||
}
|
||||
|
||||
lift $ runMyAppT myEnv do
|
||||
-- FIXME: timeout-hardcode
|
||||
let w = realToFrac 5
|
||||
|
||||
-- получить голову
|
||||
-- из головы получить акторов
|
||||
headBlk <-
|
||||
getRefChanHead @L4Proto sto (RefChanHeadKey qapRefchanID)
|
||||
`orDie` "can't read head block"
|
||||
|
||||
-- FIXME: use-actors-asap
|
||||
let self = Actor $ view peerSignPk creds
|
||||
let actors = fmap Actor $ HashSet.toList $ view refChanHeadAuthors headBlk
|
||||
qblf <- qblfInit @ConsensusQBLF self actors (DAppState (HashRef s0)) w
|
||||
|
||||
flip runContT pure do
|
||||
contAsync do
|
||||
pause @'Seconds 0.5
|
||||
qblfRun qblf
|
||||
|
||||
do
|
||||
srv <- liftIO $ newMessagingUnix True 1.0 qapAppSocket
|
||||
contAsync $ runMessagingUnix srv
|
||||
let qenv =
|
||||
QRPCEnv
|
||||
{ qrpcenvQConsensus = qblf
|
||||
, qrpcenvRefchanId = qapRefchanID
|
||||
, qrpcenvFabriq = Fabriq srv
|
||||
, qrpcenvOwnPeer = fromString qapAppSocket
|
||||
}
|
||||
|
||||
contAsync $ liftIO $ runQRPCT qenv do
|
||||
runProto @UNIX
|
||||
[ makeResponse (makeServer @QBLFAppRPC)
|
||||
]
|
||||
|
||||
lift $ runProto [makeResponse (myProto myEnv qblf qapRefchanID)]
|
||||
where
|
||||
myProto
|
||||
:: forall e m
|
||||
. ( MonadIO m
|
||||
, Request e (RefChanNotify e) m
|
||||
, e ~ UNIX
|
||||
)
|
||||
=> MyEnv
|
||||
-> QBLF ConsensusQBLF
|
||||
-> RefChanId e
|
||||
-> RefChanNotify e
|
||||
-> m ()
|
||||
|
||||
myProto _ _qblf _ (ActionRequest {}) = do
|
||||
pure ()
|
||||
myProto env qblf _chan (Notify _ msg) = do
|
||||
void $ runMaybeT do
|
||||
(_, wrapped) <- MaybeT $ pure $ unboxSignedBox0 msg
|
||||
qbmess <-
|
||||
MaybeT $
|
||||
pure $
|
||||
deserialiseOrFail @(QBLFMessage ConsensusQBLF) (LBS.fromStrict wrapped)
|
||||
& either (const Nothing) Just
|
||||
|
||||
states <- case qbmess of
|
||||
QBLFMsgAnn _ (QBLFAnnounce s0 s1) -> do
|
||||
pure [s0, s1]
|
||||
QBLFMsgHeartBeat _ _ s0 _ -> do
|
||||
pure [s0]
|
||||
_ -> do
|
||||
pure mempty
|
||||
|
||||
-- FIXME: full-download-guarantee
|
||||
lift $ forM_ states (fetchMissed env)
|
||||
|
||||
qblfAcceptMessage qblf qbmess
|
||||
-- debug $ "RefChanQBLFMain(3)" <+> "got message" <+> pretty (AsBase58 chan) <+> pretty coco
|
||||
|
||||
readOrCreateStateRef :: Maybe (Hash HbSync) -> AnyStorage -> MyRefKey -> IO (Hash HbSync)
|
||||
readOrCreateStateRef mbDs sto ref = do
|
||||
debug $ "MyRef:" <+> pretty (hashObject @HbSync ref)
|
||||
fix \spin -> do
|
||||
mbref <- readStateHashMay sto ref
|
||||
case mbref of
|
||||
Nothing -> do
|
||||
debug "STATE is empty"
|
||||
mbDs & maybe none \ds -> do
|
||||
debug $ "UPDATE REF" <+> pretty (hashObject @HbSync ref) <+> pretty (HashRef ds)
|
||||
updateRef sto ref ds
|
||||
|
||||
pause @'Seconds 0.25
|
||||
|
||||
spin
|
||||
Just val -> do
|
||||
pure val
|
||||
|
||||
readStateHashMay :: AnyStorage -> MyRefKey -> IO (Maybe (Hash HbSync))
|
||||
readStateHashMay sto ref =
|
||||
getRef @_ @HbSync sto ref
|
||||
|
|
@ -0,0 +1,214 @@
|
|||
module RefChanQBLF.CLI where
|
||||
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Actors.Peer.Types ()
|
||||
import HBS2.Base58
|
||||
import HBS2.Clock
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Defaults
|
||||
import HBS2.Hash
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Messaging.Unix
|
||||
import HBS2.Net.Proto.Service
|
||||
import HBS2.OrDie
|
||||
import HBS2.Peer.Proto.AnyRef
|
||||
import HBS2.Peer.Proto.RefChan
|
||||
import HBS2.Prelude
|
||||
import HBS2.Storage.Simple
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Codec.Serialise
|
||||
import Control.Arrow hiding ((<+>))
|
||||
import Control.Monad.Cont
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Char8 qualified as BS8
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Config.Suckless
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
import Data.String.Conversions (cs)
|
||||
import Lens.Micro.Platform hiding ((.=))
|
||||
import Options.Applicative hiding (info)
|
||||
import Options.Applicative qualified as O
|
||||
import System.Directory
|
||||
import System.Exit qualified as Exit
|
||||
import UnliftIO
|
||||
|
||||
import RefChanQBLF.App
|
||||
import RefChanQBLF.Common
|
||||
import RefChanQBLF.Impl
|
||||
import RefChanQBLF.RPCServer
|
||||
import RefChanQBLF.Transactions
|
||||
|
||||
|
||||
type Config = [Syntax C]
|
||||
|
||||
main :: IO ()
|
||||
main = join . customExecParser (prefs showHelpOnError) $
|
||||
O.info (helper <*> globalOptions)
|
||||
( fullDesc
|
||||
<> header "refchan-qblf-worker"
|
||||
<> progDesc "for test and demo purposed"
|
||||
)
|
||||
where
|
||||
|
||||
globalOptions = applyConfig <$> commonOpts <*> cli
|
||||
|
||||
applyConfig :: Maybe FilePath -> (Config -> IO ()) -> IO ()
|
||||
applyConfig config m = do
|
||||
maybe1 config (m mempty) $ \conf -> do
|
||||
top <- readFile conf <&> parseTop <&> either (pure mempty) id
|
||||
m top
|
||||
|
||||
commonOpts = optional $ strOption (long "config" <> short 'c' <> help "Config file")
|
||||
|
||||
cli = hsubparser ( command "run" (O.info pRun (progDesc "run qblf servant" ) )
|
||||
<> command "gen" (O.info pGen (progDesc "generate transcation") )
|
||||
<> command "post" (O.info pPostTx (progDesc "post transaction") )
|
||||
<> command "check" (O.info pCheckTx (progDesc "check transaction") )
|
||||
<> command "balances" (O.info pBalances (progDesc "show balances") )
|
||||
)
|
||||
|
||||
pGen = hsubparser
|
||||
( command "tx-emit" ( O.info pGenEmit (progDesc "generate emit") )
|
||||
<> command "tx-move" ( O.info pGenMove (progDesc "generate move") )
|
||||
)
|
||||
|
||||
pGenEmit = do
|
||||
kr <- strOption ( long "keyring" <> short 'k' <> help "keyring file" )
|
||||
amnt <- option @Amount auto ( long "amount" <> short 'n' <> help "amount" )
|
||||
dest <- strArgument ( metavar "ADDRESS" )
|
||||
pure $ const $ silently do
|
||||
sc <- BS.readFile kr
|
||||
creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
let pk = view peerSignPk creds
|
||||
let sk = view peerSignSk creds
|
||||
acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address"
|
||||
tx <- makeEmitDemoToken @_ @L4Proto pk sk acc amnt
|
||||
LBS.putStr $ serialise tx
|
||||
|
||||
pGenMove = do
|
||||
kr <- strOption ( long "wallet" <> short 'w' <> help "wallet (keyring) file" )
|
||||
amnt <- option @Amount auto ( long "amount" <> short 'n' <> help "amount" )
|
||||
dest <- strArgument ( metavar "ADDRESS" )
|
||||
pure $ const $ silently do
|
||||
sc <- BS.readFile kr
|
||||
creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
let pk = view peerSignPk creds
|
||||
let sk = view peerSignSk creds
|
||||
acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address"
|
||||
tx <- makeMoveDemoToken @_ @L4Proto pk sk acc amnt
|
||||
LBS.putStr $ serialise tx
|
||||
|
||||
pCheckTx = do
|
||||
pure $ const do
|
||||
tx <- either (Exit.die . ("QBLFDemoToken deserialise error: " <>) . show) pure
|
||||
. deserialiseOrFail @(QBLFDemoToken 'HBS2Basic)
|
||||
=<< LBS.getContents
|
||||
|
||||
case tx of
|
||||
Emit box ->
|
||||
BS8.hPutStrLn stderr . cs . show . pretty . first AsBase58
|
||||
=<< pure (unboxSignedBox0 box) `orDie` "bad emit tx"
|
||||
|
||||
Move box ->
|
||||
BS8.hPutStrLn stderr . cs . show . pretty . first AsBase58
|
||||
=<< pure (unboxSignedBox0 box) `orDie` "bad move tx"
|
||||
|
||||
pure ()
|
||||
|
||||
pBalances :: Parser (Config -> IO ())
|
||||
pBalances = do
|
||||
mstateref <- optional do
|
||||
option (fromStringP @HashRef "qblf state hash")
|
||||
(long "state-hash" <> metavar "HASH-REF")
|
||||
pure \syn -> withLogging do
|
||||
bal <- flip runContT pure do
|
||||
sto <- ContT $ withSimpleAnyStorage defStorePath
|
||||
lift do
|
||||
stateHashRef :: HashRef
|
||||
<- mstateref & flip maybe pure do
|
||||
either Exit.die pure =<< runExceptT do
|
||||
stref <- (flip runReader syn $ cfgValue @StateRefOpt @(Maybe String))
|
||||
& orE "state-ref key not found in config"
|
||||
<&> fromStringMay
|
||||
& orEM "state-ref key parse error"
|
||||
HashRef <$> do
|
||||
liftIO (readStateHashMay sto stref)
|
||||
& orEM "State is not created yed"
|
||||
flip runReaderT sto $ do
|
||||
debug $ "calculating balances for" <+> pretty stateHashRef
|
||||
balances stateHashRef
|
||||
|
||||
forM_ (HashMap.toList bal) $ \(acc, qty) -> do
|
||||
liftIO $ print $ pretty (AsBase58 acc) <+> pretty qty
|
||||
|
||||
fromStringP :: (FromStringMaybe a) => String -> ReadM a
|
||||
fromStringP msg = eitherReader $
|
||||
maybe (Left ("Can not parse " <> msg)) Right . fromStringMay . cs
|
||||
|
||||
refchanP :: ReadM (RefChanId L4Proto)
|
||||
refchanP = fromStringP "refchan id"
|
||||
|
||||
pPostTx :: Parser (Config -> IO ())
|
||||
pPostTx = do
|
||||
pure \syn -> withLogging do
|
||||
debug $ "runQBLFApp" <+> pretty syn
|
||||
|
||||
appsopath <- maybe (Exit.die "app-socket path not found in config") pure do
|
||||
flip runReader syn do
|
||||
cfgValue @AppSocketOpt @(Maybe String)
|
||||
|
||||
tx <- either (Exit.die . ("QBLFDemoToken deserialise error: " <>) . show) pure
|
||||
. deserialiseOrFail @(QBLFDemoToken 'HBS2Basic)
|
||||
=<< LBS.getContents
|
||||
|
||||
messagingUnix :: MessagingUnix <- newMessagingUnix False 1.0 appsopath
|
||||
ep <- makeServiceCaller @QBLFAppRPC @UNIX (msgUnixSelf messagingUnix)
|
||||
flip runContT pure do
|
||||
contAsync $ runMessagingUnix messagingUnix
|
||||
contAsync $ runReaderT (runServiceClient ep) messagingUnix
|
||||
lift do
|
||||
|
||||
maybe (Exit.die "RPC server is not available") pure
|
||||
=<< callRpcWaitMay @PingRPC (TimeoutSec 0.42) ep ()
|
||||
|
||||
r :: Text
|
||||
<- callRpcWaitMay @PostTxRPC (TimeoutSec 3) ep tx
|
||||
& peelMWith Exit.die do
|
||||
orE "RPC server timeout" >>> leftEM show >>> leftEM show
|
||||
|
||||
LBS.putStr . cs $ r
|
||||
|
||||
pRun :: Parser (Config -> IO ())
|
||||
pRun = pure \conf -> withLogging do
|
||||
debug $ "runQBLFApp" <+> pretty conf
|
||||
runQBLFApp =<< (either Exit.die pure . parseQBLFAppConf) conf
|
||||
|
||||
parseQBLFAppConf :: Config -> Either String QBLFAppConf
|
||||
parseQBLFAppConf = runReaderT do
|
||||
qapActorKeyring <- cfgValue @ActorOpt @(Maybe String)
|
||||
& orEM "actor's key not set"
|
||||
|
||||
qapRefchanID <- cfgValue @RefChanOpt @(Maybe String)
|
||||
& orEM "refchan not set"
|
||||
<&> fromStringMay @(RefChanId L4Proto)
|
||||
& orEM "invalid REFCHAN value in config"
|
||||
|
||||
qapSocket <- cfgValue @SocketOpt @(Maybe String)
|
||||
& orEM "socket not set"
|
||||
|
||||
qapAppSocket <- cfgValue @AppSocketOpt @(Maybe String)
|
||||
& orEM "app socket not set"
|
||||
|
||||
qapDefState <- cfgValue @DefStateOpt @(Maybe String)
|
||||
<&> (>>= fromStringMay)
|
||||
|
||||
qapStateRef <- cfgValue @StateRefOpt @(Maybe String)
|
||||
& orEM "state-ref key not found in config"
|
||||
<&> fromStringMay
|
||||
& orEM "state-ref key parse error"
|
||||
|
||||
pure QBLFAppConf {..}
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
module RefChanQBLF.Common where
|
||||
|
||||
import HBS2.Data.Types
|
||||
import HBS2.Peer.RPC.Client.Unix ()
|
||||
|
||||
import Control.Monad.Cont
|
||||
import Control.Monad.Except
|
||||
import Data.Bool
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics (Generic)
|
||||
import Prettyprinter
|
||||
import UnliftIO
|
||||
|
||||
data MyError
|
||||
= DeserializationError
|
||||
| SignatureError
|
||||
| SignerDoesNotMatchRefchan Text Text
|
||||
| TxUnsupported
|
||||
| SomeOtherError
|
||||
deriving stock (Generic, Show)
|
||||
instance Serialise MyError
|
||||
instance Exception MyError
|
||||
|
||||
whenM :: (Monad m) => m Bool -> m () -> m ()
|
||||
whenM mb mu = bool (pure ()) mu =<< mb
|
||||
|
||||
contAsync :: (MonadUnliftIO m) => m a -> ContT r m ()
|
||||
contAsync = (link =<<) . ContT . withAsync
|
||||
|
||||
orE :: (MonadError e m) => e -> Maybe b -> m b
|
||||
orE msg = maybe (throwError msg) pure
|
||||
|
||||
orEM :: (MonadError e m) => e -> m (Maybe b) -> m b
|
||||
orEM msg mb = orE msg =<< mb
|
||||
|
||||
leftE :: (MonadError e m) => (a -> e) -> Either a b -> m b
|
||||
leftE toe = either (throwError . toe) pure
|
||||
|
||||
leftEM :: (MonadError e m) => (a -> e) -> m (Either a b) -> m b
|
||||
leftEM toe meab = leftE toe =<< meab
|
||||
|
||||
peelMWith
|
||||
:: (Monad m)
|
||||
=> (e -> m a)
|
||||
-> (b -> Either e a)
|
||||
-> m b
|
||||
-> m a
|
||||
peelMWith ema bea mb = either ema pure . bea =<< mb
|
||||
|
||||
newtype PrettyEither e a = PrettyEither (Either e a)
|
||||
|
||||
instance
|
||||
(Pretty e, Pretty a)
|
||||
=> Pretty (PrettyEither e a)
|
||||
where
|
||||
pretty (PrettyEither ea) = case ea of
|
||||
Left e -> "Left" <+> pretty e
|
||||
Right a -> "Right" <+> pretty a
|
||||
|
|
@ -1,47 +1,38 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# Language TemplateHaskell #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
module Main where
|
||||
module RefChanQBLF.Impl where
|
||||
|
||||
import HBS2.Prelude
|
||||
import HBS2.Defaults
|
||||
import HBS2.Merkle
|
||||
import HBS2.Hash
|
||||
import HBS2.Clock
|
||||
import HBS2.Base58
|
||||
import HBS2.OrDie
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Peer.Proto.RefChan
|
||||
import HBS2.Peer.Proto.AnyRef
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Net.Messaging.Unix
|
||||
import HBS2.Data.Bundle
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Data.Detect
|
||||
import HBS2.Actors.Peer.Types()
|
||||
|
||||
import HBS2.Base58
|
||||
import HBS2.Data.Bundle
|
||||
import HBS2.Data.Detect
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Hash
|
||||
import HBS2.Merkle
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Messaging.Unix
|
||||
import HBS2.Net.Proto.QBLF
|
||||
import HBS2.Peer.Proto.AnyRef
|
||||
import HBS2.Peer.Proto.RefChan
|
||||
import HBS2.Prelude
|
||||
import HBS2.Storage.Simple
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import HBS2.Net.Proto.QBLF
|
||||
|
||||
import Demo.QBLF.Transactions
|
||||
import RefChanQBLF.Common
|
||||
import RefChanQBLF.Transactions
|
||||
import Data.Config.Suckless
|
||||
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Codec.Serialise
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString(ByteString)
|
||||
import Data.ByteString.Char8 qualified as BS
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.List qualified as List
|
||||
import Lens.Micro.Platform hiding ((.=))
|
||||
import Options.Applicative hiding (info)
|
||||
import Options.Applicative qualified as O
|
||||
import System.Directory
|
||||
import Data.HashSet qualified as HashSet
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
|
|
@ -50,19 +41,15 @@ import Data.Word
|
|||
import System.Random
|
||||
import UnliftIO
|
||||
|
||||
import Web.Scotty hiding (request,header)
|
||||
import Network.HTTP.Types.Status
|
||||
import Data.Cache (Cache)
|
||||
import Data.Cache qualified as Cache
|
||||
|
||||
import Control.Monad.Except
|
||||
|
||||
{- HLINT ignore "Use newtype instead of data" -}
|
||||
|
||||
-- TODO: config
|
||||
-- сделать конфиг, а то слишком много уже параметров в CLI
|
||||
|
||||
data HttpPortOpt
|
||||
data AppSocketOpt
|
||||
data RefChanOpt
|
||||
data SocketOpt
|
||||
data ActorOpt
|
||||
|
|
@ -72,16 +59,8 @@ data StateRefOpt
|
|||
data QBLFRefKey
|
||||
type MyRefKey = AnyRefKey QBLFRefKey 'HBS2Basic
|
||||
|
||||
instance HasCfgKey HttpPortOpt (Maybe Int) where
|
||||
key = "http"
|
||||
|
||||
|
||||
instance {-# OVERLAPPING #-} (HasConf m, HasCfgKey HttpPortOpt (Maybe Int)) => HasCfgValue HttpPortOpt (Maybe Int) m where
|
||||
cfgValue = val <$> getConf
|
||||
where
|
||||
val syn = lastMay [ fromIntegral e
|
||||
| ListVal (Key s [LitIntVal e]) <- syn, s == key @HttpPortOpt @(Maybe Int)
|
||||
]
|
||||
instance HasCfgKey AppSocketOpt (Maybe String) where
|
||||
key = "app-socket"
|
||||
|
||||
instance HasCfgKey RefChanOpt (Maybe String) where
|
||||
key = "refchan"
|
||||
|
|
@ -154,11 +133,11 @@ data MyEnv =
|
|||
, myRef :: MyRefKey
|
||||
, mySto :: AnyStorage
|
||||
, myCred :: PeerCredentials 'HBS2Basic
|
||||
, myHttpPort :: Int
|
||||
-- , myHttpPort :: Int
|
||||
, myFetch :: Cache HashRef ()
|
||||
}
|
||||
|
||||
newtype App m a = App { fromApp :: ReaderT MyEnv m a }
|
||||
newtype MyAppT m a = MyAppT { fromQAppT :: ReaderT MyEnv m a }
|
||||
deriving newtype ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
|
|
@ -168,26 +147,22 @@ newtype App m a = App { fromApp :: ReaderT MyEnv m a }
|
|||
, MonadTrans
|
||||
)
|
||||
|
||||
runApp :: (MonadIO m, PeerMessaging UNIX) => MyEnv -> App m a -> m a
|
||||
runApp env m = runReaderT (fromApp m) env
|
||||
runMyAppT :: (MonadIO m, PeerMessaging UNIX) => MyEnv -> MyAppT m a -> m a
|
||||
runMyAppT env m = runReaderT (fromQAppT m) env
|
||||
|
||||
instance Monad m => HasFabriq UNIX (App m) where
|
||||
instance Monad m => HasFabriq UNIX (MyAppT m) where
|
||||
getFabriq = asks myFab
|
||||
|
||||
instance Monad m => HasOwnPeer UNIX (App m) where
|
||||
instance Monad m => HasOwnPeer UNIX (MyAppT m) where
|
||||
ownPeer = asks mySelf
|
||||
|
||||
instance Monad m => HasStorage (App m) where
|
||||
instance Monad m => HasStorage (MyAppT m) where
|
||||
getStorage = asks mySto
|
||||
|
||||
data ConsensusQBLF
|
||||
|
||||
data StateQBLF = StateQBLF { fromStateQBLF :: HashRef }
|
||||
|
||||
data MyError =
|
||||
DeserializationError | SignatureError | TxUnsupported | SomeOtherError
|
||||
deriving stock (Eq,Ord,Show)
|
||||
|
||||
check :: MonadIO m => MyError -> Either e a -> ExceptT MyError m a
|
||||
check w = \case
|
||||
Right x -> ExceptT $ pure (Right x)
|
||||
|
|
@ -207,10 +182,10 @@ instance Serialise (QBLFMessage ConsensusQBLF)
|
|||
instance Serialise (QBLFAnnounce ConsensusQBLF)
|
||||
instance Serialise (QBLFCommit ConsensusQBLF)
|
||||
|
||||
instance Monad m => HasTimeLimits UNIX (RefChanNotify UNIX) (App m) where
|
||||
instance Monad m => HasTimeLimits UNIX (RefChanNotify UNIX) (MyAppT m) where
|
||||
tryLockForPeriod _ _ = pure True
|
||||
|
||||
instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) where
|
||||
instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (MyAppT m) where
|
||||
type QBLFActor ConsensusQBLF = Actor 'HBS2Basic
|
||||
type QBLFTransaction ConsensusQBLF = QBLFDemoToken 'HBS2Basic
|
||||
type QBLFState ConsensusQBLF = DAppState
|
||||
|
|
@ -238,7 +213,7 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher
|
|||
else do
|
||||
hashes <- liftIO $ mapM (putBlock sto . serialise) txs <&> catMaybes
|
||||
|
||||
current <- readLog (getBlock sto) h0
|
||||
current <- readLogThrow (getBlock sto) h0
|
||||
|
||||
let new = HashSet.fromList ( current <> fmap HashRef hashes )
|
||||
|
||||
|
|
@ -252,7 +227,7 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher
|
|||
lift $ request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r)))
|
||||
|
||||
r <- makeMerkle 0 pt $ \(hx,_,bs) -> do
|
||||
th <- liftIO (enqueueBlock sto bs)
|
||||
_th <- liftIO (enqueueBlock sto bs)
|
||||
debug $ "WRITE TX" <+> pretty hx
|
||||
|
||||
request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r)))
|
||||
|
|
@ -265,7 +240,7 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher
|
|||
qblfCommit s0 s1 = do
|
||||
debug $ "COMMIT:" <+> pretty s0 <+> pretty s1
|
||||
sto <- asks mySto
|
||||
chan <- asks myChan
|
||||
_chan <- asks myChan
|
||||
ref <- asks myRef
|
||||
|
||||
debug $ "UPDATING REF" <+> pretty ref <+> pretty s1
|
||||
|
|
@ -299,19 +274,19 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher
|
|||
-- 2. кэшировать всё, что можно
|
||||
qblfMerge s0 s1 = do
|
||||
chan <- asks myChan
|
||||
self <- asks mySelf
|
||||
_self <- asks mySelf
|
||||
|
||||
creds <- asks myCred
|
||||
let sk = view peerSignSk creds
|
||||
let pk = view peerSignPk creds
|
||||
let _sk = view peerSignSk creds
|
||||
let _pk = view peerSignPk creds
|
||||
|
||||
debug $ "MERGE. Proposed state:" <+> pretty s1
|
||||
|
||||
sto <- asks mySto
|
||||
let readFn = liftIO . getBlock sto
|
||||
|
||||
tx1 <- mapM (readLog readFn) (fmap fromDAppState s1) <&> mconcat
|
||||
tx0 <- readLog readFn (fromDAppState s0) <&> HashSet.fromList
|
||||
tx1 <- mapM (readLogThrow readFn) (fmap fromDAppState s1) <&> mconcat
|
||||
tx0 <- readLogThrow readFn (fromDAppState s0) <&> HashSet.fromList
|
||||
|
||||
let txNew = HashSet.fromList tx1 `HashSet.difference` tx0
|
||||
|
||||
|
|
@ -331,8 +306,8 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher
|
|||
|
||||
case tx of
|
||||
Emit box -> do
|
||||
(pk, e@(EmitTx a q _)) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx 'HBS2Basic) box
|
||||
guard ( chan == pk )
|
||||
(pk', e@(EmitTx a q _)) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx 'HBS2Basic) box
|
||||
guard ( chan == pk' )
|
||||
debug $ "VALID EMIT TRANSACTION" <+> pretty t <+> pretty (AsBase58 a) <+> pretty q
|
||||
pure ([(t,e)], mempty)
|
||||
|
||||
|
|
@ -413,7 +388,7 @@ balances root = do
|
|||
Just bal -> pure bal
|
||||
Nothing -> do
|
||||
|
||||
txs <- readLog (liftIO . getBlock sto) root
|
||||
txs <- readLogThrow (liftIO . getBlock sto) root
|
||||
|
||||
r <- forM txs $ \h -> runMaybeT do
|
||||
blk <- MaybeT $ liftIO $ getBlock sto (fromHashRef h)
|
||||
|
|
@ -457,7 +432,7 @@ updBalances :: forall e s a tx . (ForRefChans e, ToBalance s tx, s ~ Encryption
|
|||
|
||||
updBalances = go
|
||||
where
|
||||
go bal [] = empty
|
||||
go _bal [] = empty
|
||||
|
||||
go bal (t:rest) =
|
||||
|
||||
|
|
@ -499,308 +474,3 @@ fetchMissed env s = do
|
|||
liftIO $ Cache.insert cache href ()
|
||||
request @UNIX tube (ActionRequest @UNIX chan (RefChanFetch (fromDAppState s)))
|
||||
|
||||
runMe :: ForConsensus IO => Config -> IO ()
|
||||
runMe conf = withLogging $ flip runReaderT conf do
|
||||
|
||||
debug $ "runMe" <+> pretty conf
|
||||
|
||||
kr <- cfgValue @ActorOpt @(Maybe String) `orDie` "actor's key not set"
|
||||
chan' <- cfgValue @RefChanOpt @(Maybe String) `orDie` "refchan not set"
|
||||
sa <- cfgValue @SocketOpt @(Maybe String) `orDie` "socket not set"
|
||||
pno <- cfgValue @HttpPortOpt @(Maybe Int) <&> fromMaybe 3011
|
||||
ds <- cfgValue @DefStateOpt @(Maybe String)
|
||||
|
||||
ref <- ( cfgValue @StateRefOpt @(Maybe String)
|
||||
<&> maybe Nothing fromStringMay
|
||||
) `orDie` "state-ref not set"
|
||||
|
||||
sc <- liftIO $ BS.readFile kr
|
||||
creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
|
||||
chan <- pure (fromStringMay @(RefChanId L4Proto) chan') `orDie` "invalid REFCHAN"
|
||||
|
||||
here <- liftIO $ doesFileExist sa
|
||||
|
||||
when here do
|
||||
liftIO $ removeFile sa
|
||||
|
||||
server <- newMessagingUnixOpts [MUNoFork] True 1.0 sa
|
||||
|
||||
abus <- async $ runMessagingUnix server
|
||||
|
||||
let tube = fromString sa
|
||||
|
||||
-- FIXME: fix-default-storage
|
||||
xdg <- liftIO $ getXdgDirectory XdgData defStorePath <&> fromString
|
||||
sto' <- simpleStorageInit @HbSync [StoragePrefix xdg]
|
||||
|
||||
let sto = AnyStorage sto'
|
||||
sw <- liftIO $ replicateM 4 $ async $ simpleStorageWorker sto'
|
||||
|
||||
-- FIXME: fix-hardcoded-timeout
|
||||
fetches <- liftIO $ Cache.newCache (Just (toTimeSpec (TimeoutSec 30)))
|
||||
|
||||
let myEnv = MyEnv tube
|
||||
(Fabriq server)
|
||||
chan
|
||||
ref
|
||||
sto
|
||||
creds
|
||||
pno
|
||||
fetches
|
||||
|
||||
let dss = ds >>= fromStringMay
|
||||
|
||||
s0 <- readOrCreateStateRef dss sto ref
|
||||
|
||||
debug $ "STATE0:" <+> pretty s0
|
||||
|
||||
-- получить голову
|
||||
-- из головы получить акторов
|
||||
|
||||
headBlk <- getRefChanHead @L4Proto sto (RefChanHeadKey chan) `orDie` "can't read head block"
|
||||
|
||||
let self = view peerSignPk creds & Actor
|
||||
|
||||
let actors = view refChanHeadAuthors headBlk
|
||||
& HashSet.toList
|
||||
& fmap Actor
|
||||
|
||||
runApp myEnv do
|
||||
|
||||
-- FIXME: timeout-hardcode
|
||||
let w = realToFrac 5
|
||||
|
||||
-- FIXME: use-actors-asap
|
||||
qblf <- qblfInit @ConsensusQBLF self actors (DAppState (HashRef s0)) w
|
||||
|
||||
consensus <- async do
|
||||
pause @'Seconds 0.5
|
||||
qblfRun qblf
|
||||
|
||||
|
||||
-- FIXME: web-port-to-config
|
||||
web <- async $ liftIO $ scotty (fromIntegral (myHttpPort myEnv)) $ do
|
||||
post "/tx" $ do
|
||||
|
||||
r <- runExceptT do
|
||||
|
||||
bin <- lift body
|
||||
let hBin = hashObject @HbSync bin
|
||||
|
||||
debug $ "GOT TX" <+> pretty hBin
|
||||
|
||||
tok <- check DeserializationError =<< pure (deserialiseOrFail @(QBLFDemoToken 'HBS2Basic) bin)
|
||||
|
||||
tx <- case tok of
|
||||
(Emit box) -> do
|
||||
(sign, tx) <- maybe (ExceptT $ pure $ Left SignatureError) pure $ unboxSignedBox0 box
|
||||
|
||||
if sign == chan then
|
||||
pure hBin
|
||||
else
|
||||
fiasco SignatureError
|
||||
|
||||
(Move box) -> do
|
||||
(sign, tx) <- maybe (ExceptT $ pure $ Left SignatureError) pure $ unboxSignedBox0 box
|
||||
pure hBin
|
||||
|
||||
qblfEnqueue qblf tok
|
||||
pure hBin
|
||||
|
||||
case r of
|
||||
Left SignatureError -> do
|
||||
err $ viaShow SignatureError
|
||||
status status401
|
||||
|
||||
Left e -> do
|
||||
err $ viaShow e
|
||||
status status400
|
||||
|
||||
Right tx -> do
|
||||
debug $ "TX ENQUEUED OK" <+> pretty tx
|
||||
status status200
|
||||
|
||||
link web
|
||||
|
||||
runProto $ List.singleton $ makeResponse (myProto myEnv qblf chan)
|
||||
|
||||
void $ waitAnyCatchCancel $ [abus] <> sw
|
||||
|
||||
where
|
||||
|
||||
myProto :: forall e m . ( MonadIO m
|
||||
, Request e (RefChanNotify e) m
|
||||
, e ~ UNIX
|
||||
)
|
||||
=> MyEnv
|
||||
-> QBLF ConsensusQBLF
|
||||
-> RefChanId e
|
||||
-> RefChanNotify e
|
||||
-> m ()
|
||||
|
||||
myProto _ qblf _ (ActionRequest{}) = do
|
||||
pure ()
|
||||
|
||||
myProto env qblf chan (Notify _ msg) = do
|
||||
|
||||
let sto = mySto env
|
||||
let tube = mySelf env
|
||||
|
||||
let coco = hashObject @HbSync $ serialise msg
|
||||
void $ runMaybeT do
|
||||
(_, wrapped) <- MaybeT $ pure $ unboxSignedBox0 msg
|
||||
qbmess <- MaybeT $ pure $ deserialiseOrFail @(QBLFMessage ConsensusQBLF) (LBS.fromStrict wrapped)
|
||||
& either (const Nothing) Just
|
||||
|
||||
states <- case qbmess of
|
||||
QBLFMsgAnn _ (QBLFAnnounce s0 s1) -> do
|
||||
pure [s0, s1]
|
||||
|
||||
QBLFMsgHeartBeat _ _ s0 _-> do
|
||||
pure [s0]
|
||||
|
||||
_ -> do
|
||||
pure mempty
|
||||
|
||||
-- FIXME: full-download-guarantee
|
||||
lift $ forM_ states (fetchMissed env)
|
||||
|
||||
qblfAcceptMessage qblf qbmess
|
||||
-- debug $ "RefChanQBLFMain(3)" <+> "got message" <+> pretty (AsBase58 chan) <+> pretty coco
|
||||
|
||||
readOrCreateStateRef mbDs sto ref = do
|
||||
debug $ "MyRef:" <+> pretty (hashObject @HbSync ref)
|
||||
fix \spin -> do
|
||||
mbref <- liftIO $ getRef @_ @HbSync sto ref
|
||||
case mbref of
|
||||
Nothing -> do
|
||||
debug "STATE is empty"
|
||||
maybe1 mbDs none $ \ds -> do
|
||||
debug $ "UPDATE REF" <+> pretty (hashObject @HbSync ref) <+> pretty (HashRef ds)
|
||||
liftIO $ updateRef sto ref ds
|
||||
|
||||
pause @'Seconds 0.25
|
||||
|
||||
spin
|
||||
|
||||
Just val -> do
|
||||
pure val
|
||||
|
||||
type Config = [Syntax C]
|
||||
|
||||
main :: IO ()
|
||||
main = join . customExecParser (prefs showHelpOnError) $
|
||||
O.info (helper <*> globalOptions)
|
||||
( fullDesc
|
||||
<> header "refchan-qblf-worker"
|
||||
<> progDesc "for test and demo purposed"
|
||||
)
|
||||
where
|
||||
|
||||
globalOptions = applyConfig <$> commonOpts <*> cli
|
||||
|
||||
applyConfig :: Maybe FilePath -> (Config -> IO ()) -> IO ()
|
||||
applyConfig config m = do
|
||||
maybe1 config (m mempty) $ \conf -> do
|
||||
top <- readFile conf <&> parseTop <&> either (pure mempty) id
|
||||
m top
|
||||
|
||||
commonOpts = optional $ strOption (long "config" <> short 'c' <> help "Config file")
|
||||
|
||||
cli = hsubparser ( command "run" (O.info pRun (progDesc "run qblf servant" ) )
|
||||
<> command "gen" (O.info pGen (progDesc "generate transcation") )
|
||||
<> command "post" (O.info pPostTx (progDesc "post transaction") )
|
||||
<> command "check" (O.info pCheckTx (progDesc "check transaction") )
|
||||
<> command "balances" (O.info pBalances (progDesc "show balances") )
|
||||
)
|
||||
|
||||
pRun = do
|
||||
pure runMe
|
||||
|
||||
pGen = hsubparser
|
||||
( command "tx-emit" ( O.info pGenEmit (progDesc "generate emit") )
|
||||
<> command "tx-move" ( O.info pGenMove (progDesc "generate move") )
|
||||
)
|
||||
|
||||
pGenEmit = do
|
||||
kr <- strOption ( long "keyring" <> short 'k' <> help "keyring file" )
|
||||
amnt <- option @Amount auto ( long "amount" <> short 'n' <> help "amount" )
|
||||
dest <- strArgument ( metavar "ADDRESS" )
|
||||
pure $ const $ silently do
|
||||
sc <- BS.readFile kr
|
||||
creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
let pk = view peerSignPk creds
|
||||
let sk = view peerSignSk creds
|
||||
acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address"
|
||||
tx <- makeEmitTx @_ @L4Proto pk sk acc amnt
|
||||
LBS.putStr $ serialise tx
|
||||
|
||||
pGenMove = do
|
||||
kr <- strOption ( long "wallet" <> short 'w' <> help "wallet (keyring) file" )
|
||||
amnt <- option @Amount auto ( long "amount" <> short 'n' <> help "amount" )
|
||||
dest <- strArgument ( metavar "ADDRESS" )
|
||||
pure $ const $ silently do
|
||||
sc <- BS.readFile kr
|
||||
creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
let pk = view peerSignPk creds
|
||||
let sk = view peerSignSk creds
|
||||
acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address"
|
||||
tx <- makeMoveTx @_ @L4Proto pk sk acc amnt
|
||||
LBS.putStr $ serialise tx
|
||||
|
||||
pCheckTx = do
|
||||
kr <- strOption ( long "keyring" <> short 'k' <> help "keyring file" )
|
||||
pure $ const do
|
||||
sc <- BS.readFile kr
|
||||
creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file"
|
||||
let pk = view peerSignPk creds
|
||||
let sk = view peerSignSk creds
|
||||
|
||||
tx <- LBS.getContents <&> deserialise @(QBLFDemoToken 'HBS2Basic)
|
||||
|
||||
case tx of
|
||||
Emit box -> do
|
||||
void $ pure (unboxSignedBox0 box) `orDie` "bad emit tx"
|
||||
|
||||
Move box -> do
|
||||
void $ pure (unboxSignedBox0 box) `orDie` "bad move tx"
|
||||
|
||||
pure ()
|
||||
|
||||
pPostTx = pure $ const do
|
||||
error "not supported anymore / TODO via http"
|
||||
-- rc <- strArgument ( metavar "REFCHAN" )
|
||||
-- sa <- strArgument ( metavar "UNIX-SOCKET" ) <&> fromString
|
||||
-- pure $ withLogging do
|
||||
-- rchan <- pure (fromStringMay @(RefChanId L4Proto) rc) `orDie` "bad refchan"
|
||||
-- print "JOPA"
|
||||
-- -- FIXME: wrap-client-boilerplate
|
||||
-- inbox <- newMessagingUnix False 1.0 sa
|
||||
-- wInbox <- async $ runMessagingUnix inbox
|
||||
-- let env = MyEnv (fromString sa) (Fabriq inbox) rchan
|
||||
-- msg <- (LBS.getContents <&> deserialiseOrFail) `orDie` "transaction decode error"
|
||||
-- runApp env do
|
||||
-- request (mySelf env) (msg :: QBLFDemoTran UNIX)
|
||||
-- pause @'Seconds 0.1
|
||||
-- cancel wInbox
|
||||
|
||||
pBalances = do
|
||||
state <- strArgument ( metavar "STATE" )
|
||||
pure $ const $ withLogging do
|
||||
|
||||
xdg <- liftIO $ getXdgDirectory XdgData defStorePath <&> fromString
|
||||
sto' <- simpleStorageInit @HbSync [StoragePrefix xdg]
|
||||
|
||||
let sto = AnyStorage sto'
|
||||
sw <- liftIO $ replicateM 4 $ async $ simpleStorageWorker sto'
|
||||
|
||||
root <- pure (fromStringMay @HashRef state) `orDie` "Bad STATE reference"
|
||||
|
||||
flip runReaderT sto $ do
|
||||
debug $ "calculating balances for" <+> pretty root
|
||||
bal <- balances root
|
||||
|
||||
forM_ (HashMap.toList bal) $ \(acc, qty) -> do
|
||||
liftIO $ print $ pretty (AsBase58 acc) <+> pretty qty
|
||||
|
||||
|
|
@ -0,0 +1,141 @@
|
|||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module RefChanQBLF.RPCServer where
|
||||
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Base58
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Hash
|
||||
import HBS2.Net.Messaging.Unix
|
||||
import HBS2.Net.Proto.QBLF
|
||||
import HBS2.Net.Proto.Service
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Codec.Serialise
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Function
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import GHC.Generics (Generic)
|
||||
import Prettyprinter
|
||||
import UnliftIO
|
||||
|
||||
import RefChanQBLF.Common
|
||||
import RefChanQBLF.Impl
|
||||
import RefChanQBLF.Transactions
|
||||
|
||||
data PingRPC
|
||||
data PostTxRPC
|
||||
|
||||
type QBLFAppRPC =
|
||||
'[ PingRPC
|
||||
, PostTxRPC
|
||||
]
|
||||
|
||||
instance HasProtocol UNIX (ServiceProto QBLFAppRPC UNIX) where
|
||||
type ProtocolId (ServiceProto QBLFAppRPC UNIX) = 0x0B1F0B1F
|
||||
type Encoded UNIX = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
encode = serialise
|
||||
|
||||
type instance Input PingRPC = ()
|
||||
type instance Output PingRPC = Text
|
||||
|
||||
type instance Input PostTxRPC = QBLFDemoToken 'HBS2Basic
|
||||
type instance Output PostTxRPC = Either RPCServerError (Either MyError Text)
|
||||
|
||||
data QRPCEnv = QRPCEnv
|
||||
{ qrpcenvQConsensus :: QBLF ConsensusQBLF
|
||||
, qrpcenvRefchanId :: PubKey 'Sign 'HBS2Basic
|
||||
, qrpcenvFabriq :: Fabriq UNIX
|
||||
, qrpcenvOwnPeer :: Peer UNIX
|
||||
}
|
||||
|
||||
newtype QRPCAppT m a = QRPCAppT {fromQRPCAppT :: ReaderT QRPCEnv m a}
|
||||
deriving newtype
|
||||
( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadUnliftIO
|
||||
, MonadReader QRPCEnv
|
||||
, MonadTrans
|
||||
)
|
||||
|
||||
instance (Monad m) => HasFabriq UNIX (QRPCAppT m) where
|
||||
getFabriq = asks qrpcenvFabriq
|
||||
|
||||
instance (Monad m) => HasOwnPeer UNIX (QRPCAppT m) where
|
||||
ownPeer = asks qrpcenvOwnPeer
|
||||
|
||||
instance (Monad m) => HasQBLFEnv (ResponseM UNIX (QRPCAppT m)) where
|
||||
getQBLFEnv = lift ask
|
||||
|
||||
runQRPCT
|
||||
:: (MonadIO m, PeerMessaging UNIX)
|
||||
=> QRPCEnv
|
||||
-> QRPCAppT m a
|
||||
-> m a
|
||||
runQRPCT env m = runReaderT (fromQRPCAppT m) env
|
||||
|
||||
class HasQBLFEnv m where
|
||||
getQBLFEnv :: m QRPCEnv
|
||||
|
||||
data RPCServerError = RPCServerError Text
|
||||
deriving (Generic, Show)
|
||||
instance Serialise RPCServerError
|
||||
|
||||
wrapErrors :: (MonadUnliftIO m) => m a -> m (Either RPCServerError a)
|
||||
wrapErrors =
|
||||
UnliftIO.tryAny >=> flip either (pure . Right) \e -> do
|
||||
debug $ "RPC ServerError" <+> viaShow e
|
||||
pure $ (Left . RPCServerError . T.pack . show) e
|
||||
|
||||
instance (MonadIO m, HasQBLFEnv m) => HandleMethod m PingRPC where
|
||||
handleMethod _ = do
|
||||
debug $ "RPC PING"
|
||||
pure "pong"
|
||||
|
||||
instance
|
||||
( MonadUnliftIO m
|
||||
, HasQBLFEnv m
|
||||
)
|
||||
=> HandleMethod m PostTxRPC
|
||||
where
|
||||
handleMethod tok = wrapErrors $ UnliftIO.try do
|
||||
let txhash = (hashObject @HbSync . serialise) tok
|
||||
ptok = pretty tok
|
||||
|
||||
debug $ "RPC got post tx" <+> pretty txhash <+> ptok
|
||||
|
||||
refchanId <- qrpcenvRefchanId <$> getQBLFEnv
|
||||
validateQBLFToken refchanId tok
|
||||
& either throwIO pure
|
||||
|
||||
qblf <- qrpcenvQConsensus <$> getQBLFEnv
|
||||
qblfEnqueue qblf tok
|
||||
|
||||
debug $ "TX ENQUEUED OK" <+> ptok
|
||||
pure $ "Enqueued: " <> (cs . show) ptok
|
||||
|
||||
validateQBLFToken
|
||||
:: (MonadError MyError m)
|
||||
=> PubKey 'Sign 'HBS2Basic
|
||||
-> QBLFDemoToken 'HBS2Basic
|
||||
-> m ()
|
||||
validateQBLFToken chan = \case
|
||||
Emit box -> do
|
||||
(signer, _tx) <- orE SignatureError $ unboxSignedBox0 box
|
||||
unless (signer == chan) do
|
||||
throwError
|
||||
( SignerDoesNotMatchRefchan
|
||||
((cs . show . pretty . AsBase58) signer)
|
||||
((cs . show . pretty . AsBase58) chan)
|
||||
)
|
||||
Move box -> do
|
||||
(_sign, _tx) <- orE SignatureError $ unboxSignedBox0 box
|
||||
pure ()
|
||||
|
|
@ -0,0 +1,199 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module RefChanQBLF.Transactions where
|
||||
|
||||
import Data.String.Conversions (cs)
|
||||
import HBS2.Base58
|
||||
import HBS2.Data.Types.Refs (HashRef (..))
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Hash
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Messaging.Unix (UNIX)
|
||||
import HBS2.Peer.Proto
|
||||
import HBS2.Prelude.Plated
|
||||
|
||||
import Codec.Serialise
|
||||
import Control.Arrow hiding ((<+>))
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Hashable (Hashable (..))
|
||||
import Data.Word (Word64)
|
||||
import System.Random
|
||||
|
||||
import RefChanQBLF.Common
|
||||
|
||||
newtype Actor s = Actor {fromActor :: PubKey 'Sign s}
|
||||
deriving stock (Generic)
|
||||
|
||||
deriving stock instance (Eq (PubKey 'Sign s)) => Eq (Actor s)
|
||||
deriving newtype instance (Hashable (PubKey 'Sign s)) => Hashable (Actor s)
|
||||
|
||||
instance (Pretty (AsBase58 (PubKey 'Sign s))) => Pretty (Actor s) where
|
||||
pretty (Actor a) = pretty (AsBase58 a)
|
||||
|
||||
type Account s = PubKey 'Sign s
|
||||
|
||||
newtype Amount = Amount Integer
|
||||
deriving stock (Eq, Show, Ord, Data, Generic)
|
||||
deriving newtype (Read, Enum, Num, Integral, Real, Pretty)
|
||||
|
||||
newtype DAppState = DAppState {fromDAppState :: HashRef}
|
||||
deriving stock (Eq, Show, Ord, Data, Generic)
|
||||
deriving newtype (Hashable, Pretty)
|
||||
|
||||
instance Hashed HbSync DAppState where
|
||||
hashObject (DAppState (HashRef h)) = h
|
||||
|
||||
data EmitTx s = EmitTx (Account s) Amount Word64
|
||||
deriving stock (Generic)
|
||||
|
||||
instance (Pretty (AsBase58 (PubKey 'Sign s))) => Pretty (EmitTx s) where
|
||||
pretty (EmitTx acc amount n) =
|
||||
"Emit"
|
||||
<+> "to:"
|
||||
<> pretty (AsBase58 acc)
|
||||
<+> "amount:"
|
||||
<> pretty amount
|
||||
<+> "nonce:"
|
||||
<> pretty n
|
||||
|
||||
data MoveTx s = MoveTx (Account s) (Account s) Amount Word64
|
||||
deriving stock (Generic)
|
||||
|
||||
instance (Pretty (AsBase58 (PubKey 'Sign s))) => Pretty (MoveTx s) where
|
||||
pretty (MoveTx accfrom accto amount n) =
|
||||
"Move"
|
||||
<+> "from:"
|
||||
<> pretty (AsBase58 accfrom)
|
||||
<+> "to:"
|
||||
<> pretty (AsBase58 accto)
|
||||
<+> "amount:"
|
||||
<> pretty amount
|
||||
<+> "nonce:"
|
||||
<> pretty n
|
||||
|
||||
data QBLFDemoToken s
|
||||
= Emit (SignedBox (EmitTx s) s) -- proof: owner's key
|
||||
| Move (SignedBox (MoveTx s) s) -- proof: wallet's key
|
||||
deriving stock (Generic)
|
||||
|
||||
instance
|
||||
( Pretty (AsBase58 (PubKey 'Sign s))
|
||||
, Signatures s
|
||||
, Eq (Signature s)
|
||||
, FromStringMaybe (PubKey 'Sign s)
|
||||
, Serialise (PubKey 'Sign s)
|
||||
, Serialise (Signature s)
|
||||
, Hashable (PubKey 'Sign s)
|
||||
)
|
||||
=> Pretty (QBLFDemoToken s)
|
||||
where
|
||||
pretty = \case
|
||||
Emit box -> pretty (WhiteSignedBox @s box)
|
||||
Move box -> pretty (WhiteSignedBox @s box)
|
||||
|
||||
newtype WhiteSignedBox s a = WhiteSignedBox (SignedBox a s)
|
||||
|
||||
instance
|
||||
( Pretty (AsBase58 (PubKey 'Sign s))
|
||||
, Pretty a
|
||||
, Serialise a
|
||||
)
|
||||
=> Pretty (WhiteSignedBox s a)
|
||||
where
|
||||
pretty (WhiteSignedBox (SignedBox pk bs _sign)) =
|
||||
"SignedBox"
|
||||
<+> "Hash:"
|
||||
<+> pretty ((hashObject @HbSync . serialise) bs)
|
||||
<+> "SignedBy:"
|
||||
<+> pretty (AsBase58 pk)
|
||||
<+> "("
|
||||
<> pretty ((PrettyEither . left show . deserialiseOrFail @a . cs) bs)
|
||||
<> ")"
|
||||
|
||||
instance (ForQBLFDemoToken s) => Serialise (Actor s)
|
||||
|
||||
instance Serialise DAppState
|
||||
|
||||
instance Serialise Amount
|
||||
|
||||
instance (ForQBLFDemoToken s) => Serialise (EmitTx s)
|
||||
|
||||
instance (ForQBLFDemoToken s) => Serialise (MoveTx s)
|
||||
|
||||
instance (ForQBLFDemoToken s) => Serialise (QBLFDemoToken s)
|
||||
|
||||
type ForQBLFDemoToken s =
|
||||
( Eq (PubKey 'Sign s)
|
||||
, Eq (Signature s)
|
||||
, Pretty (AsBase58 (PubKey 'Sign s))
|
||||
, ForSignedBox s
|
||||
, FromStringMaybe (PubKey 'Sign s)
|
||||
, Serialise (PubKey 'Sign s)
|
||||
, Serialise (Signature s)
|
||||
, Hashable (PubKey 'Sign s)
|
||||
)
|
||||
|
||||
deriving stock instance (ForQBLFDemoToken s) => Eq (QBLFDemoToken s)
|
||||
|
||||
instance (ForQBLFDemoToken s) => Hashable (QBLFDemoToken s) where
|
||||
hashWithSalt salt = \case
|
||||
Emit box -> hashWithSalt salt box
|
||||
Move box -> hashWithSalt salt box
|
||||
|
||||
newtype QBLFDemoTran e
|
||||
= QBLFDemoTran (SignedBox (QBLFDemoToken (Encryption e)) (Encryption e))
|
||||
deriving stock (Generic)
|
||||
|
||||
instance (ForRefChans e) => Serialise (QBLFDemoTran e)
|
||||
|
||||
deriving newtype instance
|
||||
(Eq (PubKey 'Sign (Encryption e)), Eq (Signature (Encryption e)))
|
||||
=> Eq (QBLFDemoTran e)
|
||||
|
||||
deriving newtype instance
|
||||
(Eq (Signature (Encryption e)), ForRefChans e)
|
||||
=> Hashable (QBLFDemoTran e)
|
||||
|
||||
instance HasProtocol UNIX (QBLFDemoTran UNIX) where
|
||||
type ProtocolId (QBLFDemoTran UNIX) = 0xFFFF0001
|
||||
type Encoded UNIX = ByteString
|
||||
decode = either (const Nothing) Just . deserialiseOrFail
|
||||
encode = serialise
|
||||
|
||||
makeEmitDemoToken
|
||||
:: forall s e m
|
||||
. ( MonadIO m
|
||||
, ForRefChans e
|
||||
, ForQBLFDemoToken s
|
||||
, Signatures (Encryption e)
|
||||
, s ~ Encryption e
|
||||
)
|
||||
=> PubKey 'Sign s
|
||||
-> PrivKey 'Sign s
|
||||
-> Account s
|
||||
-> Amount
|
||||
-> m (QBLFDemoToken s)
|
||||
makeEmitDemoToken pk sk acc amount = do
|
||||
nonce <- randomIO
|
||||
let box = makeSignedBox @s pk sk (EmitTx acc amount nonce)
|
||||
pure (Emit @s box)
|
||||
|
||||
makeMoveDemoToken
|
||||
:: forall s e m
|
||||
. ( MonadIO m
|
||||
, ForQBLFDemoToken s
|
||||
, ForRefChans e
|
||||
, Signatures s
|
||||
, s ~ Encryption e
|
||||
)
|
||||
=> PubKey 'Sign s -- from pk
|
||||
-> PrivKey 'Sign s -- from sk
|
||||
-> Account s
|
||||
-> Amount -- amount
|
||||
-> m (QBLFDemoToken s)
|
||||
makeMoveDemoToken pk sk acc amount = do
|
||||
nonce <- randomIO
|
||||
let box = makeSignedBox @s pk sk (MoveTx pk acc amount nonce)
|
||||
pure (Move @s box)
|
||||
|
|
@ -19,6 +19,7 @@ common warnings
|
|||
common common-deps
|
||||
build-depends:
|
||||
base, hbs2-core, hbs2-peer, hbs2-storage-simple, hbs2-qblf
|
||||
, hbs2-qblf
|
||||
, aeson
|
||||
, async
|
||||
, bytestring
|
||||
|
|
@ -57,6 +58,18 @@ common common-deps
|
|||
, interpolatedstring-perl6
|
||||
, unliftio
|
||||
|
||||
, attoparsec
|
||||
, clock
|
||||
, data-textual
|
||||
, network
|
||||
, network-ip
|
||||
, optparse-applicative
|
||||
, string-conversions
|
||||
, text
|
||||
, time
|
||||
|
||||
|
||||
|
||||
common shared-properties
|
||||
ghc-options:
|
||||
-Wall
|
||||
|
|
@ -94,68 +107,48 @@ common shared-properties
|
|||
, MultiParamTypeClasses
|
||||
, OverloadedStrings
|
||||
, QuasiQuotes
|
||||
, RecordWildCards
|
||||
, ScopedTypeVariables
|
||||
, StandaloneDeriving
|
||||
, TupleSections
|
||||
, TypeApplications
|
||||
, TypeOperators
|
||||
, TypeFamilies
|
||||
|
||||
library
|
||||
import: shared-properties
|
||||
import: common-deps
|
||||
|
||||
hs-source-dirs: lib
|
||||
|
||||
exposed-modules:
|
||||
RefChanQBLF.App
|
||||
RefChanQBLF.CLI
|
||||
RefChanQBLF.Common
|
||||
RefChanQBLF.Impl
|
||||
RefChanQBLF.RPCServer
|
||||
RefChanQBLF.Transactions
|
||||
|
||||
executable refchan-qblf
|
||||
import: shared-properties
|
||||
import: common-deps
|
||||
default-language: Haskell2010
|
||||
|
||||
build-depends:
|
||||
refchan-qblf
|
||||
|
||||
ghc-options:
|
||||
-- -prof
|
||||
-- -fprof-auto
|
||||
|
||||
other-modules:
|
||||
Demo.QBLF.Transactions
|
||||
|
||||
-- other-extensions:
|
||||
|
||||
-- type: exitcode-stdio-1.0
|
||||
hs-source-dirs: app lib
|
||||
main-is: RefChanQBLFMain.hs
|
||||
|
||||
build-depends:
|
||||
base, hbs2-core, hbs2-qblf, hbs2-storage-simple
|
||||
, async
|
||||
, attoparsec
|
||||
, bytestring
|
||||
, cache
|
||||
, clock
|
||||
, containers
|
||||
, data-default
|
||||
, data-textual
|
||||
, directory
|
||||
, hashable
|
||||
, microlens-platform
|
||||
, mtl
|
||||
, mwc-random
|
||||
, network
|
||||
, network-ip
|
||||
, optparse-applicative
|
||||
, prettyprinter
|
||||
, QuickCheck
|
||||
, random
|
||||
, safe
|
||||
, serialise
|
||||
, stm
|
||||
, streaming
|
||||
, tasty
|
||||
, tasty-hunit
|
||||
, text
|
||||
, time
|
||||
, transformers
|
||||
, uniplate
|
||||
, vector
|
||||
, unliftio
|
||||
|
||||
hs-source-dirs: app
|
||||
main-is: Main.hs
|
||||
|
||||
test-suite refchan-qblf-proto-test
|
||||
import: shared-properties
|
||||
default-language: Haskell2010
|
||||
import: common-deps
|
||||
|
||||
other-modules:
|
||||
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ import HBS2.Prelude.Plated
|
|||
import HBS2.Hash
|
||||
import HBS2.Data.Types
|
||||
import HBS2.Merkle
|
||||
import HBS2.Merkle.Walk
|
||||
import HBS2.Storage
|
||||
|
||||
-- import HBS2.System.Logger.Simple
|
||||
|
|
@ -22,6 +23,7 @@ import Control.Concurrent.STM
|
|||
import Data.HashMap.Strict qualified as HashMap
|
||||
-- import Data.HashMap.Strict (HashMap)
|
||||
import Data.List qualified as List
|
||||
import UnliftIO qualified
|
||||
|
||||
import Streaming.Prelude qualified as S
|
||||
-- import Streaming qualified as S
|
||||
|
|
@ -159,6 +161,15 @@ readLog getBlk (HashRef h) =
|
|||
Left{} -> pure ()
|
||||
Right (hrr :: [HashRef]) -> S.each hrr
|
||||
|
||||
readLogThrow :: forall m . ( MonadIO m )
|
||||
=> ( Hash HbSync -> IO (Maybe ByteString) )
|
||||
-> HashRef
|
||||
-> m [HashRef]
|
||||
readLogThrow getBlk (HashRef h) =
|
||||
S.toList_ do
|
||||
either UnliftIO.throwIO pure =<<
|
||||
streamMerkle (liftIO . getBlk) h
|
||||
|
||||
|
||||
-- FIXME: make-it-stop-after-first-missed-block
|
||||
checkComplete :: forall sto m . (MonadIO m, Storage sto HbSync ByteString IO)
|
||||
|
|
|
|||
Loading…
Reference in New Issue