WIP use fifo

Author: MarcFontaine

bench/tx-generator/src/Cardano/Benchmarking/Compiler.hs

@@ -80,7 +80,7 @@ addCollaterals src = do
     True -> do      
       tx_fee <- askNixOption _nix_tx_fee
       safeCollateral <- _safeCollateral <$> evilFeeMagic
-      collateralWallet <- newWallet "collaeral_wallet"
+      collateralWallet <- newWallet "collateral_wallet"
       emit $ CreateChange era src src LocalSocket (PayToAddr $ KeyName "pass-partout") (safeCollateral + tx_fee) 1
       emit $ CreateChange era src collateralWallet LocalSocket (PayToCollateral $ KeyName "pass-partout") safeCollateral 1
       return $ Just collateralWallet

bench/tx-generator/src/Cardano/Benchmarking/Fifo.hs

@@ -0,0 +1,31 @@
+module Cardano.Benchmarking.Fifo
+where
+import           Prelude
+
+-- This is to be used single threaded behind an MVar.
+
+data Fifo a = Fifo ![a] ![a]
+
+emptyFifo :: Fifo a
+emptyFifo = Fifo [] []
+
+toList :: Fifo a -> [a]
+toList (Fifo x y) = x ++ reverse y
+
+insert :: Fifo a -> a -> Fifo a
+insert (Fifo x y) e = Fifo x $ e:y
+
+remove :: Fifo a -> Maybe (Fifo a, a)
+remove fifo = case fifo of
+  Fifo [] [] -> Nothing
+  Fifo (h:t) y -> Just (Fifo t y, h)
+  Fifo [] y -> case reverse y of
+    (h:t) -> Just (Fifo t [], h)
+    [] -> error "unreachable"
+
+removeN :: Int -> Fifo a -> Maybe (Fifo a, [a])
+removeN 0 f = return (f, [])
+removeN n f = do
+  (a, h) <- remove f
+  (r, t) <- removeN (pred n) a
+  return (r, h:t)

bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs

@@ -14,6 +14,8 @@ import           Prelude
 
 import           Cardano.Api as Api
 
+import Cardano.Benchmarking.Fifo as Fifo
+
 -- Outputs that are available for spending.
 -- When building a new TX they provide the TxIn parts.
 
@@ -26,14 +28,11 @@ data FundInEra era = FundInEra {
 
 newtype Fund = Fund {unFund :: InAnyCardanoEra FundInEra}
 
-type FundSet = [ Fund ]
+type FundSet = Fifo Fund
 
 type FundSource m = m (Either String [Fund])
 type FundToStore m = [Fund] -> m ()
 
-newtype SeqNumber = SeqNumber Int
-  deriving  (Show, Eq, Ord, Enum)
-
 getFundTxIn :: Fund -> TxIn
 getFundTxIn (Fund (InAnyCardanoEra _ a)) = _fundTxIn a
 
@@ -73,11 +72,11 @@ instance Ord Fund where
   compare a b = compare (getFundTxIn a) (getFundTxIn b)
 
 
-emptyFunds :: FundSet
-emptyFunds = [ ]
+emptyFundSet :: FundSet
+emptyFundSet = Fifo.emptyFifo
 
 insertFund :: FundSet -> Fund -> FundSet
-insertFund s f = f : s
+insertFund = Fifo.insert
 
 liftAnyEra :: ( forall era. IsCardanoEra era => f1 era -> f2 era ) -> InAnyCardanoEra f1 -> InAnyCardanoEra f2
 liftAnyEra f x = case x of

bench/tx-generator/src/Cardano/Benchmarking/ListBufferedSelector.hs

@@ -33,6 +33,7 @@ import           Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult
 import           Cardano.Benchmarking.FundSet (FundInEra (..),
                    liftAnyEra)
 
+import qualified Cardano.Benchmarking.Fifo as Fifo
 import qualified Cardano.Benchmarking.FundSet as FundSet
 import           Cardano.Benchmarking.FundSet as FundSet (getFundTxIn)
 import           Cardano.Benchmarking.GeneratorTx as GeneratorTx (AsyncBenchmarkControl, TxGenError)
@@ -44,7 +45,6 @@ import           Cardano.Benchmarking.GeneratorTx.NodeToNode (ConnectClient,
 import           Cardano.Benchmarking.GeneratorTx.SizedMetadata (mkMetadata)
 import           Cardano.Benchmarking.GeneratorTx.Tx as Core (keyAddress, mkFee, txInModeCardano)
 
-import           Cardano.Benchmarking.ListBufferedSelector
 import           Cardano.Benchmarking.OuroborosImports as Core (LocalSubmitTx, SigningKeyFile,
                    makeLocalConnectInfo, protocolToCodecConfig)
 import           Cardano.Benchmarking.PlutusExample as PlutusExample
@@ -231,11 +231,17 @@ localSubmitTx tx = do
   submit <- getLocalSubmitTx
   ret <- liftIO $ submit tx
   case ret of
-    SubmitSuccess -> return ()
-    SubmitFail e -> traceDebug $ concat
-                        [ "local submit failed: " , show e , " (" , show tx , ")"]
-  return ret
-
+    SubmitSuccess -> return ret
+    SubmitFail e -> do
+      let msg = concat [ "local submit failed: " , show e , " (" , show tx , ")" ]
+      traceDebug msg
+      return ret      
+--      throwE $ ApiError msg
+
+-- TODO:
+-- It should be possible to exit the tx-generator with an exception and also get the log messages.
+-- Problem 1: When doing throwE $ ApiError msg logmessages get lost !
+-- Problem 2: Workbench restarts the tx-generator -> this may be the reason for loss of messages
 makeMetadata :: forall era. IsShelleyBasedEra era => ActionM (TxMetadataInEra era)
 makeMetadata = do
   payloadSize <- getUser TTxAdditionalSize
@@ -273,7 +279,7 @@ runBenchmarkInEra sourceWallet submitMode (ThreadName threadName) shape collater
   let walletRefDst = walletRefSrc
   metadata <- makeMetadata
 
-  fundSource <- liftIO (mkBufferedSource walletRefSrc (auxInputsPerTx shape))
+  let fundSource = walletSource walletRefSrc (auxInputsPerTx shape)
 
   collaterals <- selectCollateralFunds collateralWallet
 
@@ -311,7 +317,7 @@ selectCollateralFunds :: forall era. IsShelleyBasedEra era
 selectCollateralFunds Nothing = return (TxInsCollateralNone, [])
 selectCollateralFunds (Just walletName) = do
   cw <- getName walletName
-  collateralFunds <- liftIO ( askWalletRef cw walletFunds) >>= \case
+  collateralFunds <- liftIO ( askWalletRef cw Fifo.toList ) >>= \case
     [] -> throwE $ WalletError "selectCollateralFunds: emptylist"
     l -> return l
   case collateralSupportedInEra (cardanoEra @ era) of
@@ -428,7 +434,7 @@ createChangeGeneric sourceWallet submitMode createCoins addressMsg value count =
                   , " address: ", addressMsg
                   ]
   traceDebug msg
-  fundSource <- liftIO (mkBufferedSource walletRef 1)
+  let fundSource = walletSource walletRef 1
 
   forM_ chunks $ \coins -> do
     gen <- createCoins fundSource coins

bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs

@@ -13,53 +13,45 @@ import           Control.Concurrent.MVar
 import           Cardano.Api
 
 import           Cardano.Benchmarking.FundSet as FundSet
+import           Cardano.Benchmarking.Fifo as Fifo
 import           Cardano.Benchmarking.Types (NumberOfTxs (..))
 import           Cardano.Api.Shelley (ProtocolParameters, ReferenceScript(..))
-type WalletRef = MVar Wallet
+
+-- All the actual functionality of Wallet / WalletRef has been removed
+-- and WalletRef has been stripped down to MVar FundSet.
+-- The implementation of Wallet has become trivial.
+-- Todo: Remove trivial wrapper functions.
+
+type WalletRef = MVar FundSet
 
 type TxGenerator era = [Fund] -> [TxOut CtxTx era] -> Either String (Tx era, TxId)
 
 type ToUTxO era = Lovelace -> (TxOut CtxTx era, TxIx -> TxId -> Fund)
 
+--todo: inline inToOut :: [Lovelace] -> [Lovelace] and FundToStore
 type ToUTxOList era = [Lovelace] -> ([TxOut CtxTx era], TxId -> [Fund])
 -- 'ToUTxOList era' is more powerful than '[ ToUTxO era ]' but
 -- '[ ToUTxO era ]` is easier to construct.
 
-data Wallet = Wallet {
-    walletSeqNumber :: !SeqNumber
-  , walletFunds :: !FundSet
-  }
-
-initWallet :: IO (MVar Wallet)
-initWallet = newMVar $ Wallet {
-    walletSeqNumber = SeqNumber 1
-  , walletFunds = emptyFunds
-  }
+initWallet :: IO WalletRef
+initWallet = newMVar emptyFundSet
 
-askWalletRef :: WalletRef -> (Wallet -> a) -> IO a
+askWalletRef :: WalletRef -> (FundSet -> a) -> IO a
 askWalletRef r f = do
   w <- readMVar r
   return $ f w
 
-modifyWalletRef :: WalletRef -> (Wallet -> IO (Wallet, a)) -> IO a
-modifyWalletRef = modifyMVar
-
-modifyWalletRefEither :: WalletRef -> (Wallet -> IO (Either err (Wallet,a))) -> IO (Either err a)
-modifyWalletRefEither ref action
-  = modifyMVar ref $ \w -> action w >>= \case
-     Right (newWallet, res) -> return (newWallet, Right res)
-     Left err -> return (w, Left err)
-
 walletRefInsertFund :: WalletRef -> Fund -> IO ()
-walletRefInsertFund ref fund = modifyMVar_  ref $ \w -> return $ walletInsertFund fund w
-
-walletInsertFund :: Fund -> Wallet -> Wallet
-walletInsertFund f w
-  = w { walletFunds = FundSet.insertFund (walletFunds w) f }
+walletRefInsertFund ref fund = modifyMVar_  ref $ \w -> return $ FundSet.insertFund w fund
 
 mkWalletFundStore :: WalletRef -> FundToStore IO
-mkWalletFundStore walletRef funds = modifyWalletRef walletRef
-  $ \wallet -> return (foldl (flip walletInsertFund) wallet funds, ())
+mkWalletFundStore walletRef funds = modifyMVar_  walletRef
+  $ \wallet -> return (foldl FundSet.insertFund wallet funds)
+
+walletSource :: WalletRef -> Int -> FundSource IO
+walletSource ref munch = modifyMVar ref $ \fifo -> return $ case Fifo.removeN munch fifo of
+  Nothing -> (fifo, Left "WalletSource: out of funds")
+  Just (newFifo, funds) -> (newFifo, Right funds) 
 
 makeToUTxOList :: [ ToUTxO era ] -> ToUTxOList era
 makeToUTxOList fkts values 
@@ -71,12 +63,13 @@ makeToUTxOList fkts values
          in  (o, f idx) 
 
 --TODO use Error monad
+--TODO need to break this up
 sourceToStoreTransaction ::
      TxGenerator era
-  -> FundSource IO
-  -> ([Lovelace] -> [Lovelace])
+  -> FundSource IO         
+  -> ([Lovelace] -> [Lovelace]) --inline to ToUTxOList
   -> ToUTxOList era
-  -> FundToStore IO
+  -> FundToStore IO                --inline to ToUTxOList
   -> IO (Either String (Tx era))
 sourceToStoreTransaction txGenerator fundSource inToOut mkTxOut fundToStore = do
   fundSource >>= \case

bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs

@@ -27,6 +27,7 @@ library
   exposed-modules:
                        Cardano.Benchmarking.Command
                        Cardano.Benchmarking.Compiler                       
+                       Cardano.Benchmarking.Fifo
                        Cardano.Benchmarking.FundSet
                        Cardano.Benchmarking.GeneratorTx
                        Cardano.Benchmarking.GeneratorTx.Error
@@ -55,7 +56,6 @@ library
                        Cardano.Benchmarking.Types
                        Cardano.Benchmarking.Version
                        Cardano.Benchmarking.Wallet
-                       Cardano.Benchmarking.ListBufferedSelector
                        Cardano.Benchmarking.PlutusExample
 
   other-modules:       Paths_tx_generator