Initial commit

This commit is contained in:
Julian Ospald 2021-07-03 17:17:02 +02:00
commit 482967b019
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
6 changed files with 820 additions and 0 deletions

5
CHANGELOG.md Normal file
View File

@ -0,0 +1,5 @@
# Revision history for iohk-challenge
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

310
Tasks.hs Normal file
View File

@ -0,0 +1,310 @@
{-# 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"

56
iohk-challenge.cabal Normal file
View File

@ -0,0 +1,56 @@
cabal-version: 3.0
name: iohk-challenge
version: 0.1.0.0
-- synopsis:
-- description:
-- bug-reports:
license: LGPL-3.0-only
author: Julian Ospald
maintainer: hasufell@posteo.de
-- copyright:
-- category:
extra-source-files: CHANGELOG.md
common async
build-depends: async ^>= 2.2.2
common base
build-depends: base ^>= 4.13.0.0
common containers
buid-depends: containers ^>= 0.6.2.1
common doctest
build-depends: doctest ^>= 0.17
common stm
build-depends: stm ^>= 2.5.0.0
common config
default-language: Haskell2010
ghc-options:
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-fwarn-incomplete-record-updates -threaded
default-extensions:
LambdaCase
MultiWayIf
RecordWildCards
ScopedTypeVariables
TupleSections
library
import: config,
async,
base,
containers,
stm
exposed-modules: HDT.Tasks
hs-source-dirs: lib
test-suite doctests
import: config,
async,
base,
doctest
type: exitcode-stdio-1.0
main-is: test/doctest.hs

443
lib/HDT/Tasks.hs Normal file
View File

@ -0,0 +1,443 @@
{-# OPTIONS_HADDOCK show-extensions #-}
{-# OPTIONS_GHC -Wno-dodgy-exports #-}
{-# OPTIONS_GHC -Wno-missing-methods #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-|
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
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Concurrent.STM.TChan
import Control.Monad
import GHC.IO.Handle.Lock
import Numeric.Natural ( Natural )
import Text.Printf ( printf )
import System.IO
import Debug.Trace
-- |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 = Return a
| Delay (Agent msg a)
| Send msg (Agent msg a)
| Receive (msg -> Agent msg a)
instance Functor (Agent msg) where
fmap f (Return a ) = Return (f a)
fmap f (Delay agent ) = Delay (fmap f agent)
fmap f (Send msg agent) = Send msg (fmap f agent)
fmap f (Receive g ) = Receive (fmap f . g)
instance Applicative (Agent msg) where
pure = Return
(Return f ) <*> m = fmap f m
(Delay f ) <*> m = Delay (f <*> m)
(Send msg f) <*> m = Send msg (f <*> m)
(Receive f ) <*> m = Receive ((<*> m) . f)
-- The resulting monad should be /free/ and support operations
-- @'delay'@, @'broadcast'@ and @'receive'@ described below.
instance Monad (Agent msg) where
return = Return
m >>= ma = case m of
Return a -> ma a
Delay agent -> Delay (agent >>= ma)
Send msg agent -> Send msg (agent >>= ma)
Receive g -> Receive ((>>= ma) . g)
-- |Delay for one timestep.
delay :: Agent msg ()
delay = Delay (Return ())
-- |Broadcast a message.
broadcast :: msg -- ^The message to broadcast.
-> Agent msg ()
broadcast = flip Send (Return ())
-- |Wait for a broadcast and return the received message.
receive :: Agent msg msg
receive = Receive Return
-- |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'@.
--
runIO :: forall msg
. Show msg
=> [Agent msg ()] -- ^ The agents to run concurrently.
-> IO ()
runIO agents = do
-- start broadcast channel
bchan <- newBroadcastTChanIO
-- for blocking stdout actions
mvar <- newTMVarIO ()
-- concurrently start agents
forConcurrently_ agents $ \agent -> do
-- broadcast channel needs to be duped for each thread
tchan <- atomically $ dupTChan bchan
runAgent agent tchan mvar
where
runAgent :: Agent msg () -> TChan msg -> TMVar () -> IO ()
runAgent agent tchan mvar =
-- unix write(2) is atomic too, but less portable
let printAtomic :: msg -> IO ()
printAtomic msg = do
void $ atomically $ takeTMVar mvar
hPutStrLn stdout (show msg)
hFlush stdout
atomically $ putTMVar mvar ()
run :: Agent msg () -> IO ()
run a = runAgent a tchan mvar
-- the IO interpreter
in case agent of
Return x -> return x
Delay next -> threadDelay 1000000 >> run next
Send msg next -> do
printAtomic msg
(atomically $ writeTChan tchan msg) >> run next
Receive f -> do
msg <- atomically $ readTChan tchan
run (f msg)
-- |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'@.
--
-- >>> chainLength Genesis
-- 0
-- >>> chainLength $ Genesis :> Block 2 2 :> Block 3 0
-- 2
chainLength :: Chain -> Int
chainLength = go 0
where
-- strict accumulator
go i c = case c of
Genesis -> i
(chain :> Block{}) -> let !acc = i + 1 in go acc chain
-- |Computes the slot leader.
--
-- >>> 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 n s =
-- Not safe with n <= 0
-- Make sure this is efficient with large slot values.
let n' = fromIntegral n in (s + n') `rem` n'
-- |Determines whether a chain is valid.
--
-- >>> 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 _ _ Genesis = True
chainValid n s c@(_ :> bl) = slot bl <= s && val c
where
-- make sure we can short circuit and traverse only once
val :: Chain -> Bool
val Genesis = True
val (Genesis :> b1) = valSlotLeader b1
val (chain :> b1 :> b2) =
((slot b1) < (slot b2) && valSlotLeader b2) && val (chain :> b1)
valSlotLeader :: Block -> Bool
valSlotLeader Block {..} = slotLeader n slot == creator
-- |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.
clock :: Agent BftMessage a
clock = broadcast (Time 0) >> go 1
where go i = delay >> broadcast (Time i) >> go (i + 1)
-- |A @'node'@ participating in the BFT-protocol. It should start with the @'Genesis'@
-- chain at @'Slot' 0@ and run forever.
node :: forall a
. Int -- ^Total number of nodes.
-> NodeId -- ^Identifier of /this/ node.
-> Agent BftMessage a
node i n = go Genesis 0
where
go c t = do
msg <- receive
case msg of
Time 0 -> go c t
Time x -> newBlock c x
NewChain nc@(_ :> Block {..})
| chainValid i t nc
, chainLength nc > chainLength c
-- don't recurse on our own broadcast
-- and don't accept fake broadcasts
, creator /= n -> go nc t
NewChain _ -> go c t
-- create a new block if we are the slot leader
-- or recurse
newBlock :: Chain -> Slot -> Agent BftMessage a
newBlock c t
| slotLeader i t == n
= let nc = (c :> Block { slot = t, creator = n })
in broadcast (NewChain nc) >> go nc t
| otherwise
= go c t
-- |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.
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 agents = zip [1 ..] $ go agents [] [] []
where
go :: [Agent msg ()] -- ^active agents
-> [Agent msg ()] -- ^delayed agents
-> [Agent msg ()] -- ^waiting agents
-> [msg] -- ^broadcast channel
-> [msg] -- ^all broadcasts
go [] [] [] _ = []
go [] [] _ _ = [] -- deadlock
-- if there are no active agents left, make all delayed agents active
go [] delayed waiting chan = go delayed [] waiting chan
-- there are active agents, run the first agent
go (a : as) delayed waiting chan = case a of
-- TODO: multiple inefficiencies. Complexity grows with number of agents.
Return _ -> go as delayed waiting chan
Delay next -> go as (delayed ++ [next]) waiting chan
-- we model the broadcast channel by just duplicating the message
-- for `length agents` and then making sure the sender does not
-- consume all of them by prioritizing waiting agents
Send msg next ->
msg
: (go (as ++ waiting ++ [next]) -- these are run next
delayed
[]
(chan ++ replicate numAgents msg)
)
ag@(Receive f) -> case chan of
[] -> go as delayed (waiting ++ [ag]) chan
(c : cs) -> go (as ++ [f c]) delayed waiting cs
numAgents = length agents

4
test/doctest.hs Normal file
View File

@ -0,0 +1,4 @@
import Test.DocTest
main :: IO ()
main = doctest ["-ilib", "lib/HDT/Tasks.hs"]