qblf update

examples/refchan-qblf/app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import RefChanQBLF.CLI qualified as CLI
+
+main :: IO ()
+main = CLI.main

examples/refchan-qblf/lib/Demo/QBLF/Transactions.hs

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

examples/refchan-qblf/lib/RefChanQBLF/App.hs

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

examples/refchan-qblf/lib/RefChanQBLF/CLI.hs

@@ -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 {..}

examples/refchan-qblf/lib/RefChanQBLF/Common.hs

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

examples/refchan-qblf/lib/RefChanQBLF/Impl.hs

@@ -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 RefChanQBLF.Common
-
+import RefChanQBLF.Transactions
-import Demo.QBLF.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
+instance HasCfgKey AppSocketOpt (Maybe String) where
-  key = "http"
+  key = "app-socket"
-
-
-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 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
+runMyAppT :: (MonadIO m, PeerMessaging UNIX) => MyEnv -> MyAppT m a -> m a
-runApp env m = runReaderT (fromApp  m) env
+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 _sk = view peerSignSk creds
-    let pk = view peerSignPk 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
+    tx1 <- mapM (readLogThrow readFn) (fmap fromDAppState s1) <&> mconcat
-    tx0 <- readLog readFn (fromDAppState s0) <&> HashSet.fromList
+    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
+                  (pk', e@(EmitTx a q _)) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx 'HBS2Basic) box
-                  guard ( chan == pk )
+                  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
-

examples/refchan-qblf/lib/RefChanQBLF/RPCServer.hs

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

examples/refchan-qblf/lib/RefChanQBLF/Transactions.hs

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

examples/refchan-qblf/refchan-qblf.cabal

@@ -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
+    hs-source-dirs:   app
-    main-is:          RefChanQBLFMain.hs
+    main-is:          Main.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
-
 
 test-suite refchan-qblf-proto-test
     import:           shared-properties
-    default-language: Haskell2010
+    import:           common-deps
 
     other-modules: