311 lines
12 KiB
Haskell
311 lines
12 KiB
Haskell
{-# OPTIONS_HADDOCK show-extensions #-}
|
|
|
|
{-# OPTIONS_GHC -Wno-dodgy-exports #-}
|
|
|
|
{-# OPTIONS_GHC -Wno-missing-methods #-}
|
|
|
|
{-# OPTIONS_GHC -Wno-unused-imports #-}
|
|
|
|
|
|
|
|
{-|
|
|
|
|
Module : HDT.Tasks
|
|
|
|
Description : IOHK Haskell Developer Test
|
|
|
|
Copyright : (c) Lars Brünjes, 2020
|
|
|
|
Maintainer : lars.bruenjes@iohk.io
|
|
|
|
Stability : experimental
|
|
|
|
Portability : portable
|
|
|
|
|
|
|
|
This module contains the IOHK Haskell Developer Test. Please complete all the
|
|
|
|
to-do's!
|
|
|
|
-}
|
|
|
|
module HDT.Tasks
|
|
|
|
( -- * @Agent@s
|
|
|
|
-- | We start by implementing a free monad,
|
|
|
|
-- which we will use to model a concurrent agent than
|
|
|
|
-- can communicate and coordinate with other agents by
|
|
|
|
-- exchanging broadcast messages.
|
|
|
|
Agent (..)
|
|
|
|
, delay
|
|
|
|
, broadcast
|
|
|
|
, receive
|
|
|
|
-- * Ping-pong example
|
|
|
|
-- |As an example of using agents, agents @'ping'@ and @'pong'@ defined below
|
|
|
|
-- keep sending @'Ping'@ and @'Pong'@ messages back and forth between themselves.
|
|
|
|
, PingPongMessage (..)
|
|
|
|
, ping
|
|
|
|
, pong
|
|
|
|
-- * An @'IO'@-interpreter for agents.
|
|
|
|
-- |In order to actually /run/ agents, we need to /interpret/ the free
|
|
|
|
-- @'Agent'@ monad. We start with an interpreter in @'IO'@,
|
|
|
|
-- which runs each agent in a list of agents in its own thread
|
|
|
|
-- and implements messaging by utilizing a shared @'TChan'@ broadcast channel.
|
|
|
|
--
|
|
|
|
-- We will then be able to run our ping-pong example:
|
|
|
|
--
|
|
|
|
-- >>> runIO [ping, pong]
|
|
|
|
-- Ping
|
|
|
|
-- Pong
|
|
|
|
-- Ping
|
|
|
|
-- Pong
|
|
|
|
-- Ping
|
|
|
|
-- ...
|
|
|
|
, runIO
|
|
|
|
-- * Ouroboros Bft
|
|
|
|
-- | We use agents to implement a simplified version of the
|
|
|
|
-- <https://iohk.io/en/research/library/papers/ouroboros-bfta-simple-byzantine-fault-tolerant-consensus-protocol/ Ouroboros-BFT>
|
|
|
|
-- blockchain consensus protocol.
|
|
|
|
--
|
|
|
|
-- Ouroboros-BFT works as follows: A fixed number of @n@ /nodes/ participate in the
|
|
|
|
-- protocol. They collaborate on building a /blockchain/ by adding /blocks/,
|
|
|
|
-- and the protocol ensures that the nodes will agree on a /common prefix/
|
|
|
|
-- (all nodes agree on the prefix of the chain, but may disagree on a few blocks
|
|
|
|
-- towards the end).
|
|
|
|
-- This will work as long as at least two thirds of the nodes follow the protocol.
|
|
|
|
--
|
|
|
|
-- Time is divided in /slots/ of a fixed length, and in each slot, one node is the
|
|
|
|
-- /slot leader/ with the right to create the next block.
|
|
|
|
-- Slots leaders are determined in a round-robin fashion: Node 0
|
|
|
|
-- can create a block in Slot 0, Node 1 in Slot 1, Node @(n-1)@ in Slot @(n-1)@,
|
|
|
|
-- Node 0 in Slot @n@ and so on.
|
|
|
|
-- When a node is slot leader, it adds a block to its current chain and
|
|
|
|
-- broadcasts the new chain to the other nodes.
|
|
|
|
--
|
|
|
|
-- Each node holds on to a current chain (all nodes start with the chain
|
|
|
|
-- just consisting of the /genesis block/). When a node receives a new chain
|
|
|
|
-- from another node, it checks the new chain for /validity/ and
|
|
|
|
-- adopts it as its own chain /if it is longer than its own chain/.
|
|
|
|
--
|
|
|
|
-- A chain is /valid/ if
|
|
|
|
--
|
|
|
|
-- * The timestamps are stricly increasing,
|
|
|
|
-- * All blocks have been created by the slot leader of that slot and
|
|
|
|
-- * The newest block's timestamp is not from the future.
|
|
|
|
--
|
|
|
|
-- In reality, nodes would use digital signatures to sign the blocks
|
|
|
|
-- they create, and each block would contain a /payload/, but we
|
|
|
|
-- want to keep matters as simple as possible.
|
|
|
|
--
|
|
|
|
-- >>> runIO $ clock : [node 3 nid | nid <- [0,1,2]]
|
|
|
|
-- Time 0
|
|
|
|
-- Time 1
|
|
|
|
-- NewChain (Genesis :> {1 1})
|
|
|
|
-- Time 2
|
|
|
|
-- NewChain (Genesis :> {1 1} :> {2 2})
|
|
|
|
-- Time 3
|
|
|
|
-- NewChain (Genesis :> {1 1} :> {2 2} :> {3 0})
|
|
|
|
-- Time 4
|
|
|
|
-- NewChain (Genesis :> {1 1} :> {2 2} :> {3 0} :> {4 1})
|
|
|
|
-- Time 5
|
|
|
|
-- NewChain (Genesis :> {1 1} :> {2 2} :> {3 0} :> {4 1} :> {5 2})
|
|
|
|
-- Time 6
|
|
|
|
-- NewChain (Genesis :> {1 1} :> {2 2} :> {3 0} :> {4 1} :> {5 2} :> {6 0})
|
|
|
|
-- ...
|
|
|
|
, Slot
|
|
|
|
, NodeId
|
|
|
|
, Block (..)
|
|
|
|
, Chain (..)
|
|
|
|
, chainLength
|
|
|
|
, slotLeader
|
|
|
|
, chainValid
|
|
|
|
, clock
|
|
|
|
, node
|
|
|
|
-- * A /pure/ interpreter for agents.
|
|
|
|
-- |We also want to be able to interpret a list of agents in a
|
|
|
|
-- /pure and deterministic/ fashion.
|
|
|
|
--
|
|
|
|
-- When we try this with our ping-pong example, we will be able to do:
|
|
|
|
--
|
|
|
|
-- >>> take 5 $ runPure [ping, pong]
|
|
|
|
-- [(1,Ping),(2,Pong),(3,Ping),(4,Pong),(5,Ping)]
|
|
|
|
, runPure
|
|
|
|
) where
|
|
|
|
|
|
|
|
import Control.Concurrent.STM
|
|
|
|
import Numeric.Natural (Natural)
|
|
|
|
import Text.Printf (printf)
|
|
|
|
|
|
|
|
-- |An @'Agent' msg a@ is an abstract process that can send and receive broadcast
|
|
|
|
-- messages of type @msg@ and will eventually return a result of type @a@.
|
|
|
|
-- Define the type such that @'Agent' msg@ is a /free monad/ supporting the operations
|
|
|
|
-- @'delay'@, @'broadcast'@ and @'receive'@ below.
|
|
|
|
--
|
|
|
|
-- Agents can be used to model concurrent agents that communicate and coordinate
|
|
|
|
-- via message exchange over a broadcast channel.
|
|
|
|
data Agent msg a
|
|
|
|
|
|
|
|
-- |__TODO:__ Provide a @'Functor'@ instance for @'Agent' msg@.
|
|
|
|
instance Functor (Agent msg) where
|
|
|
|
|
|
|
|
-- |__TODO:__ Provide an @'Applicative'@ instance for @'Agent' msg@.
|
|
|
|
instance Applicative (Agent msg) where
|
|
|
|
|
|
|
|
-- |__TODO:__ Provide a @'Monad'@ instance for @'Agent' msg@.
|
|
|
|
-- The resulting monad should be /free/ and support operations
|
|
|
|
-- @'delay'@, @'broadcast'@ and @'receive'@ described below.
|
|
|
|
instance Monad (Agent msg) where
|
|
|
|
|
|
|
|
-- |Delay for one timestep.
|
|
|
|
-- __TODO:__ Implement @'delay'@.
|
|
|
|
delay :: Agent msg ()
|
|
|
|
delay = error "TODO: implement delay"
|
|
|
|
|
|
|
|
-- |Broadcast a message.
|
|
|
|
-- __TODO:__ Implement @'broadcast'@.
|
|
|
|
broadcast :: msg -- ^The message to broadcast.
|
|
|
|
-> Agent msg ()
|
|
|
|
broadcast = error "TODO: implement broadcast"
|
|
|
|
|
|
|
|
-- |Wait for a broadcast and return the received message.
|
|
|
|
-- __TODO:__ Implement @'receive'@.
|
|
|
|
receive :: Agent msg msg
|
|
|
|
receive = error "TODO: implement receive"
|
|
|
|
|
|
|
|
-- |The message type used by agents @'ping'@ and @'pong'@.
|
|
|
|
data PingPongMessage =
|
|
|
|
Ping -- ^Message used by the @'ping'@ agent, which the @'pong'@ agent waits for.
|
|
|
|
| Pong -- ^Message used by the @'pong'@ agent, which the @'ping'@ agent waits for.
|
|
|
|
deriving (Show)
|
|
|
|
|
|
|
|
-- |Agent @'ping'@ starts by broadcasting a @'Ping'@ message, then
|
|
|
|
-- waits for a @'Pong'@ message and repeats.
|
|
|
|
-- Note how it guards against the possibility of receiving its own broadcasts!
|
|
|
|
ping :: Agent PingPongMessage ()
|
|
|
|
ping = delay >> broadcast Ping >> go
|
|
|
|
where
|
|
|
|
go = do
|
|
|
|
msg <- receive
|
|
|
|
case msg of
|
|
|
|
Ping -> go
|
|
|
|
Pong -> ping
|
|
|
|
|
|
|
|
-- |Agent @'pong'@ waits for a @'Ping'@ message, the broadcasts a @'Pong'@ message
|
|
|
|
-- and repeats.
|
|
|
|
pong :: Agent PingPongMessage ()
|
|
|
|
pong = do
|
|
|
|
msg <- receive
|
|
|
|
case msg of
|
|
|
|
Ping -> delay >> broadcast Pong >> pong
|
|
|
|
Pong -> pong
|
|
|
|
|
|
|
|
-- |Function @'runIO' agents@ runs each agent in the given list
|
|
|
|
-- concurrently in the @'IO'@-monad.
|
|
|
|
-- Broadcast should be realized using a @'TChan' msg@ which is shared amongst
|
|
|
|
-- the threads running each agent,
|
|
|
|
-- and @'runIO'@ should only return if and when every agent has returned.
|
|
|
|
--
|
|
|
|
-- The operations should be interpreted as follows:
|
|
|
|
--
|
|
|
|
-- * @'delay'@ should delay execution for one second.
|
|
|
|
-- * @'broadcast' msg@ should broadcast @msg@ via the shared @'TChan'@
|
|
|
|
-- and additionally log the message to the console. Doing this naively
|
|
|
|
-- could lead to garbled output, so care must be taken to ensure sequential access
|
|
|
|
-- to the console.
|
|
|
|
-- * @'receive'@ should block the thread until a message is received on the
|
|
|
|
-- shared @'TChan'@.
|
|
|
|
--
|
|
|
|
-- __TODO:__ Implement @'runIO'@.
|
|
|
|
runIO :: Show msg
|
|
|
|
=> [Agent msg ()] -- ^The agents to run concurrently.
|
|
|
|
-> IO ()
|
|
|
|
runIO = error "TODO: implement runIO"
|
|
|
|
|
|
|
|
-- |Time is divided into @'Slot'@s.
|
|
|
|
type Slot = Natural
|
|
|
|
|
|
|
|
-- |Each node has a @'NodeId'@.
|
|
-- If there are @n@ nodes, their id's will be 0, 1, 2,...,@(n-1)@.
|
|
|
|
type NodeId = Natural
|
|
|
|
|
|
|
|
-- |The blockchain is built from @'Block'@s.
|
|
|
|
data Block = Block
|
|
|
|
{ slot :: Slot -- ^Timestamp indicating when the block was created.
|
|
|
|
, creator :: NodeId -- ^Identifies the node that created the block.
|
|
|
|
}
|
|
|
|
|
|
|
|
instance Show Block where
|
|
|
|
show b = printf "{%d %d}" (slot b) (creator b)
|
|
|
|
|
|
|
|
infixl 5 :>
|
|
|
|
|
|
|
|
-- |A blockchain can either be empty (just the genesis block) or contain @'Block'@s.
|
|
|
|
data Chain =
|
|
|
|
Genesis
|
|
|
|
| Chain :> Block
|
|
|
|
|
|
|
|
instance Show Chain where
|
|
|
|
showsPrec _ Genesis = showString "Genesis"
|
|
|
|
showsPrec d (c :> b) = showParen (d > 10) $ showsPrec 0 c . showString " :> " . showString (show b)
|
|
|
|
|
|
|
|
-- |Computes the length of a @'Chain'@. __TODO:__ Implement @'chainLength'@.
|
|
|
|
--
|
|
|
|
-- >>> chainLength Genesis
|
|
|
|
-- 0
|
|
|
|
-- >>> chainLength $ Genesis :> Block 2 2 :> Block 3 0
|
|
|
|
-- 2
|
|
|
|
chainLength :: Chain -> Int
|
|
|
|
chainLength = error "TODO: implement chainLength"
|
|
|
|
|
|
|
|
-- |Computes the slot leader. __TODO:__ Implement @'slotLeader'@.
|
|
|
|
--
|
|
|
|
-- >>> slotLeader 3 0
|
|
|
|
-- 0
|
|
|
|
-- >>> slotLeader 3 1
|
|
|
|
-- 1
|
|
|
|
-- >>> slotLeader 3 3
|
|
|
|
-- 0
|
|
|
|
slotLeader :: Int -- ^Total number of nodes.
|
|
|
|
-> Slot -- ^The @'Slot'@.
|
|
|
|
-> NodeId -- ^Identifies the node that has the right to create a block
|
|
|
|
-- in the given @'Slot'@.
|
|
|
|
slotLeader = error "TODO: implement slotLeader"
|
|
|
|
|
|
|
|
-- |Determines whether a chain is valid. __TODO:__ Implement @'chainValid'@.
|
|
|
|
--
|
|
|
|
-- >>> chainValid 3 4 $ Genesis :> Block 10 1
|
|
|
|
-- False
|
|
|
|
-- >>> chainValid 3 14 $ Genesis :> Block 10 1
|
|
|
|
-- True
|
|
|
|
-- >>> chainValid 3 14 $ Genesis :> Block 10 2
|
|
|
|
-- False
|
|
|
|
-- >>> chainValid 3 14 $ Genesis :> Block 3 1 :> Block 10 1
|
|
|
|
-- False
|
|
|
|
-- >>> chainValid 3 14 $ Genesis :> Block 3 0 :> Block 10 1
|
|
|
|
-- True
|
|
|
|
chainValid :: Int -- ^Total number of nodes.
|
|
|
|
-> Slot -- ^Current slot.
|
|
|
|
-> Chain -- ^Chain to validate.
|
|
|
|
-> Bool
|
|
|
|
chainValid = error "TODO: implement chainValid"
|
|
|
|
|
|
|
|
-- |The type of messages used for communication in the BFT-protocol.
|
|
|
|
data BftMessage =
|
|
|
|
Time Slot -- ^Message used by the @'clock'@ to broadcast the current time.
|
|
|
|
| NewChain Chain -- ^Message used by a @'node'@ to announce a new @'Chain'@.
|
|
|
|
deriving Show
|
|
|
|
|
|
|
|
-- |The nodes do not keep track of time by themselves, but instead rely on
|
|
|
|
-- the @'clock'@ agent, which broadcasts the beginning of each new @'Slot'@
|
|
|
|
-- using @'Time'@-messages. The agent should start with @'Slot' 0@ and run forever.
|
|
|
|
-- __TODO:__ Implement @'clock'@.
|
|
|
|
clock :: Agent BftMessage a
|
|
|
|
clock = error "TODO: implement clock"
|
|
|
|
|
|
|
|
-- |A @'node'@ participating in the BFT-protocol. It should start with the @'Genesis'@
|
|
|
|
-- chain at @'Slot' 0@ and run forever.
|
|
|
|
-- __TODO:__ Implement @'node'@.
|
|
|
|
node :: Int -- ^Total number of nodes.
|
|
|
|
-> NodeId -- ^Identifier of /this/ node.
|
|
|
|
-> Agent BftMessage a
|
|
|
|
node = error "TODO: implement node"
|
|
|
|
|
|
|
|
-- |Interprets a list of agents in a /pure/ fashion,
|
|
|
|
-- returning the list of all broadcasts (with their timestamps).
|
|
|
|
--
|
|
|
|
-- __Hint:__ It might be helpful to keep track of
|
|
|
|
--
|
|
|
|
-- * all active agents,
|
|
|
|
-- * all delayed agents and
|
|
|
|
-- * all agents waiting for a broadcast.
|
|
|
|
--
|
|
|
|
-- __TODO:__ Implement @'runPure'@.
|
|
|
|
runPure :: [Agent msg ()] -- ^The agents to run.
|
|
|
|
-> [(Natural, msg)] -- ^A list of all broadcasts, represented by
|
|
|
|
-- pairs containing a timestamp and the message that was sent.
|
|
|
|
runPure = error "TODO: implement runPure"
|