Merge #585

585: Ledger integration r=mrBliss a=edsko

Co-authored-by: Nicholas Clarke <[email protected]>
Co-authored-by: Thomas Winant <[email protected]>

Co-authored-by: Edsko de Vries <[email protected]>
Co-authored-by: Thomas Winant <[email protected]>

cabal.project

@@ -21,13 +21,13 @@ source-repository-package
   type: git
   location: https://github.com/input-output-hk/iohk-monitoring-framework
   subdir: iohk-monitoring
-  tag: cbe7ab32354f3838dc8c95c64109904c8f503347
+  tag: f1c4ceef7d7ea6fb4425484c2b19b84048a3549d
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/iohk-monitoring-framework
   subdir:   contra-tracer
-  tag: cbe7ab32354f3838dc8c95c64109904c8f503347
+  tag: f1c4ceef7d7ea6fb4425484c2b19b84048a3549d
 
 source-repository-package
   type: git
@@ -44,25 +44,25 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger
-  tag: 684195650722e4d337e90562fddcc5c2b0d17d34
+  tag: 761feffb241c2db934c599dc330131ddee034322
   subdir: .
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger
-  tag: 684195650722e4d337e90562fddcc5c2b0d17d34
+  tag: 761feffb241c2db934c599dc330131ddee034322
   subdir: crypto
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger
-  tag: 684195650722e4d337e90562fddcc5c2b0d17d34
+  tag: 761feffb241c2db934c599dc330131ddee034322
   subdir: test
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger
-  tag: 684195650722e4d337e90562fddcc5c2b0d17d34
+  tag: 761feffb241c2db934c599dc330131ddee034322
   subdir: crypto/test
 
 source-repository-package
@@ -85,7 +85,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-shell
-  tag: 5db8e79d319a86d48bea4cb70f1e904acae46de4
+  tag: 4e9651df29752d1205719028e288ce9e0478a373
 
 source-repository-package
   type: git

ouroboros-consensus/demo-playground/CLI.hs

@@ -1,5 +1,12 @@
+{-# LANGUAGE GADTs #-}
+
 module CLI (
-    CLI(..)
+    -- * Untyped/typed protocol boundary
+    Protocol(..)
+  , SomeProtocol(..)
+  , fromProtocol
+    -- * CLI
+  , CLI(..)
   , TopologyInfo(..)
   , Command(..)
   , parseCLI
@@ -25,14 +32,57 @@ import           Ouroboros.Consensus.Util
 import           Mock.TxSubmission (command', parseMockTx)
 import           Topology (TopologyInfo (..))
 
+import qualified Test.Cardano.Chain.Genesis.Dummy as Dummy
+
+{-------------------------------------------------------------------------------
+  Untyped/typed protocol boundary
+-------------------------------------------------------------------------------}
+
+data Protocol =
+    BFT
+  | Praos
+  | MockPBFT
+  | RealPBFT
+
+
+data SomeProtocol where
+  SomeProtocol :: RunDemo blk hdr => DemoProtocol blk hdr -> SomeProtocol
+
+fromProtocol :: Protocol -> IO SomeProtocol
+fromProtocol BFT =
+    case runDemo p of
+      Dict -> return $ SomeProtocol p
+  where
+    p = DemoBFT defaultSecurityParam
+fromProtocol Praos =
+    case runDemo p of
+      Dict -> return $ SomeProtocol p
+  where
+    p = DemoPraos defaultDemoPraosParams
+fromProtocol MockPBFT =
+    case runDemo p of
+      Dict -> return $ SomeProtocol p
+  where
+    p = DemoMockPBFT defaultDemoPBftParams
+fromProtocol RealPBFT =
+    case runDemo p of
+      Dict -> return $ SomeProtocol p
+  where
+    p = DemoRealPBFT defaultDemoPBftParams genesisConfig
+    genesisConfig = Dummy.dummyConfig
+
+{-------------------------------------------------------------------------------
+  Command line arguments
+-------------------------------------------------------------------------------}
+
 data CLI = CLI {
     systemStart  :: SystemStart
   , slotDuration :: SlotLength
   , command      :: Command
   }
 
 data Command =
-    SimpleNode  TopologyInfo (Some DemoProtocol)
+    SimpleNode  TopologyInfo Protocol
   | TxSubmitter TopologyInfo Mock.Tx
 
 parseCLI :: Parser CLI
@@ -57,19 +107,23 @@ parseSlotDuration = option (mkSlotLength <$> auto) $ mconcat [
     mkSlotLength :: Integer -> SlotLength
     mkSlotLength = slotLengthFromMillisec . (* 1000)
 
-parseProtocol :: Parser (Some DemoProtocol)
+parseProtocol :: Parser Protocol
 parseProtocol = asum [
-      flag' (Some (DemoBFT defaultSecurityParam)) $ mconcat [
+      flag' BFT $ mconcat [
           long "bft"
         , help "Use the BFT consensus algorithm"
         ]
-    , flag' (Some (DemoPraos defaultDemoPraosParams)) $ mconcat [
+    , flag' Praos $ mconcat [
           long "praos"
         , help "Use the Praos consensus algorithm"
         ]
-    , flag' (Some (DemoPBFT defaultDemoPBftParams)) $ mconcat [
-          long "pbft"
-        , help "Use the Permissive BFT consensus algorithm"
+    , flag' MockPBFT $ mconcat [
+          long "mock-pbft"
+        , help "Use the Permissive BFT consensus algorithm using a mock ledger"
+        ]
+    , flag' RealPBFT $ mconcat [
+          long "real-pbft"
+        , help "Use the Permissive BFT consensus algorithm using the real ledger"
         ]
     ]
 

ouroboros-consensus/demo-playground/Mock/TxSubmission.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
@@ -10,7 +12,7 @@ module Mock.TxSubmission (
     , spawnMempoolListener
     ) where
 
-import           Codec.Serialise (hPutSerialise)
+import           Codec.Serialise (decode, hPutSerialise)
 import qualified Control.Concurrent.Async as Async
 import           Control.Monad.Except
 import           Control.Tracer
@@ -22,6 +24,7 @@ import           System.IO (IOMode (..))
 
 import           Ouroboros.Consensus.Crypto.Hash (ShortHash)
 import qualified Ouroboros.Consensus.Crypto.Hash as H
+import           Ouroboros.Consensus.Demo
 import qualified Ouroboros.Consensus.Ledger.Mock as Mock
 import           Ouroboros.Consensus.Mempool
 import           Ouroboros.Consensus.Node (NodeId (..), NodeKernel (..))
@@ -80,7 +83,6 @@ command' c descr p =
   Main logic
 -------------------------------------------------------------------------------}
 
-
 handleTxSubmission :: TopologyInfo -> Mock.Tx -> IO ()
 handleTxSubmission tinfo tx = do
     topoE <- readTopologyFile (topologyFile tinfo)
@@ -97,21 +99,23 @@ submitTx n tx = do
     putStrLn $ "The Id for this transaction is: " <> condense (H.hash @ShortHash tx)
 
 -- | Auxiliary to 'spawnMempoolListener'
-readIncomingTx :: Tracer IO String
-               -> NodeKernel IO NodeId (Mock.SimpleBlock p c) (Mock.SimpleHeader p c)
+readIncomingTx :: RunDemo blk hdr
+               => Tracer IO String
+               -> NodeKernel IO NodeId blk hdr
                -> Decoder IO
                -> IO ()
 readIncomingTx tracer kernel Decoder{..} = forever $ do
-    newTx :: Mock.Tx <- decodeNext
-    rejected <- addTxs (getMempool kernel) [newTx]
+    newTx :: Mock.Tx <- decodeNext decode
+    rejected <- addTxs (getMempool kernel) [demoMockTx (getNodeConfig kernel) newTx]
     traceWith tracer $
       (if null rejected then "Accepted" else "Rejected") <>
       " transaction: " <> show newTx
 
 -- | Listen for transactions coming a named pipe and add them to the mempool
-spawnMempoolListener :: Tracer IO String
+spawnMempoolListener :: RunDemo blk hdr
+                     => Tracer IO String
                      -> NodeId
-                     -> NodeKernel IO NodeId (Mock.SimpleBlock p c) (Mock.SimpleHeader p c)
+                     -> NodeKernel IO NodeId blk hdr
                      -> IO (Async.Async ())
 spawnMempoolListener tracer myNodeId kernel = do
     Async.async $ do