Skip to content

Commit d0f0bb9

Browse files
author
Renate Eilers
committed
Add simple FFD implementation
1 parent bc5049b commit d0f0bb9

File tree

3 files changed

+105
-30
lines changed

3 files changed

+105
-30
lines changed

‎leios-sim/leios-sim.cabal‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -22,7 +22,7 @@ library
2222
-- Crypto
2323
-- Simulation
2424
-- Node
25-
-- Types
25+
Types
2626
hs-source-dirs: src
2727
build-depends:
2828
base
@@ -50,6 +50,7 @@ test-suite leios-sim-test
5050
-- other-extensions:
5151
build-depends:
5252
base
53+
, containers
5354
, leios-sim
5455
, hspec
5556
, QuickCheck

‎leios-sim/src/Network/FFD.hs‎

Lines changed: 85 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -1,30 +1,37 @@
11
{-# LANGUAGE DerivingStrategies #-}
22
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+
{-# LANGUAGE LambdaCase #-}
34
{-# LANGUAGE NamedFieldPuns #-}
45
module Network.FFD where
56
import Data.Map (Map)
67
import qualified Data.Map as Map
78
import Data.Set (Set)
89
import qualified Data.Set as Set
9-
import Data.Time (UTCTime)
1010
import GHC.Conc (Signal)
11-
import GHC.Natural (Natural)
11+
import GHC.Natural (Natural, naturalFromInteger)
1212
import Node.Types (NodeId)
1313
import Types (SlotNumber)
1414

15+
type Time = Natural
16+
1517
data NetworkParameters = NetworkParameters {
16-
deltaHdr :: Natural
17-
, diameter :: Natural
18-
, capacity :: Natural -- capacity of links
18+
deltaHdr :: Natural
19+
, diameter :: Natural
20+
, capacity :: Natural -- capacity of links
21+
, singleHopTime :: Natural -- |b|/C
1922
}
2023

2124
data Network = Network {
22-
headers :: Map MessageId [(Header, UTCTime, Set NodeId)]
23-
, bodies :: Map MessageId [(Header, Body, UTCTime, Set NodeId)]
24-
, sutOutput :: [NetworkRequestMsg]
25+
headers :: Map MessageId [(Header, Time, Set NodeId)]
26+
, bodies :: Map MessageId [(Header, Body, Time, Set NodeId)]
27+
, prefHdr :: Map (NodeId, MessageId) Header
28+
, currentTime :: Time
29+
, sutOutput :: [NetworkRequestMsg]
30+
, params :: NetworkParameters
2531
}
2632

2733
data Hash = Hash
34+
deriving (Eq,Show, Ord)
2835

2936
data VrfLotteryProof = VrfLotteryProof
3037

@@ -34,29 +41,86 @@ data Header = Header {
3441
slotNumber :: SlotNumber
3542
, creator :: NodeId
3643
-- , vrfLotteryProof :: VrfLotteryProof
37-
-- , hash :: Hash
44+
, hash :: Hash
3845
-- , signature :: Signature
39-
} deriving (Eq, Show)
46+
} deriving (Eq, Show, Ord)
4047

4148
data Body = Body
49+
deriving (Eq, Ord)
4250

4351
newtype MessageId = MessageId (SlotNumber, NodeId)
4452
deriving newtype (Ord, Eq, Show)
4553

4654
data NetworkRequestMsg =
4755
DiffFB Header Body NodeId
4856
| DiffHdr Header NodeId
49-
| FetchHdrs
50-
| FetchBdys
57+
| FetchHdrs NodeId
58+
| FetchBdys NodeId
5159

5260
data NetworkResponseMsg =
53-
DeliverHdrs [Header]
54-
| DeliverBdys [Body]
61+
DeliverHdrs (Set Header)
62+
| DeliverBdys (Set (Header, Body))
63+
64+
newtype NetworkError = NetworkError String
65+
66+
stepNetwork :: Network -> Adversary -> NetworkRequestMsg -> Either NetworkError (Maybe NetworkResponseMsg, Network)
67+
stepNetwork nw@Network {currentTime, headers, params, bodies} Adversary{mkHdrs, mkBdys} = \case
68+
DiffFB hdr bdy nid
69+
| not (match hdr bdy) -> Left $ NetworkError "Header doesn't match body"
70+
| hasHdr nw nid (getMessageId hdr) -> Left $ NetworkError "Node already has header"
71+
| otherwise -> let
72+
networkWithHeader = hdrsAdd nw hdr currentTime nid
73+
networkWithBody = bdysAdd networkWithHeader hdr bdy currentTime nid
74+
networkWithPrefHdr = networkWithBody {prefHdr = Map.insert (nid,getMessageId hdr) hdr (prefHdr networkWithBody) }
75+
in Right (Nothing, networkWithPrefHdr)
76+
DiffHdr hdr nid
77+
| hasPoE nw nid (getMessageId hdr) -> Left $ NetworkError "Found proof of equivocation"
78+
| otherwise -> let
79+
networkWithHeader = hdrsAdd nw hdr currentTime nid
80+
networkWithPrefHdr = networkWithHeader {prefHdr = Map.insertWith (\_ oldVal -> oldVal) (nid,getMessageId hdr) hdr (prefHdr networkWithHeader) }
81+
f newVal oldVal = oldVal
82+
in Right (Nothing, networkWithPrefHdr)
83+
FetchHdrs nid -> let
84+
honestHdrs = Set.fromList [ h | hdrs <- Map.elems headers
85+
, (h,t,nids) <- hdrs
86+
, nid `notElem` nids
87+
, currentTime >= t + deltaHdr params
88+
, not $ hasPoE nw nid (getMessageId h)]
89+
adversarialHdrs = Set.filter (hasPoE nw nid . getMessageId) $ mkHdrs honestHdrs
90+
-- TODO:
91+
-- addHeaders and set preferred header if empty(not in paper, check with research)
92+
in Right (Just $ DeliverHdrs $ Set.union honestHdrs adversarialHdrs, nw)
93+
FetchBdys nid -> let
94+
honestBodies = Set.fromList [ (h,b) | bdys <- Map.elems bodies
95+
, (h,b,t,nids) <- bdys
96+
, nid `notElem` nids
97+
, prefersHeader nid h
98+
, all (== h) $ Map.filterWithKey (\(_,mid') _ -> mid' == getMessageId h) (prefHdr nw)
99+
, let k = naturalFromInteger $ toInteger $ newerBdys nw h
100+
in currentTime >= t + (k + diameter params) * singleHopTime params]
101+
adversarialBodies = Set.filter (\(h,b) -> match h b
102+
&& not (hasBdy nw nid (getMessageId h))
103+
&& prefersHeader nid h)
104+
$ mkBdys honestBodies
105+
allBodies = Set.union honestBodies adversarialBodies
106+
prefersHeader nid' h' = (Just h' ==) $ Map.lookup (nid', getMessageId h') (prefHdr nw)
107+
updatedNetwork = Set.foldl (\nw' (h',b') -> bdysAdd nw' h' b' currentTime nid) nw allBodies
108+
in Right (Just $ DeliverBdys allBodies, updatedNetwork)
109+
110+
data Adversary = Adversary {
111+
mkHdrs :: Set Header -> Set Header
112+
, mkBdys :: Set (Header, Body) -> Set (Header, Body)
113+
}
114+
55115

56116
--- auxilliary functions
57117

58-
-- match :: Header -> Body -> Bool
59-
-- match Header {hash} _ = True
118+
getMessageId :: Header -> MessageId
119+
getMessageId Header {slotNumber, creator} =
120+
MessageId (slotNumber, creator)
121+
122+
match :: Header -> Body -> Bool
123+
match Header {hash} _ = True
60124

61125
hasHdr :: Network -> NodeId -> MessageId -> Bool
62126
hasHdr Network {headers} nid mid =
@@ -70,7 +134,7 @@ hasBdy :: Network -> NodeId -> MessageId -> Bool
70134
hasBdy Network {bodies} nid mid =
71135
maybe False (any $ \(_,_,_,nids) -> nid `elem` nids) $ Map.lookup mid bodies
72136

73-
hdrsAdd :: Network -> Header -> UTCTime -> NodeId -> Network
137+
hdrsAdd :: Network -> Header -> Time -> NodeId -> Network
74138
hdrsAdd nw@Network {headers} hdr@Header {slotNumber, creator} t nid = nw {
75139
headers = Map.alter f mid headers
76140
}
@@ -85,7 +149,7 @@ hdrsAdd nw@Network {headers} hdr@Header {slotNumber, creator} t nid = nw {
85149
else (h,t',nids): go xs
86150

87151

88-
bdysAdd :: Network -> Header -> Body -> UTCTime -> NodeId -> Network
152+
bdysAdd :: Network -> Header -> Body -> Time -> NodeId -> Network
89153
bdysAdd nw@Network {headers, bodies} hdr@Header {slotNumber, creator} b t nid = nw {
90154
bodies = Map.alter f mid bodies
91155
}
@@ -100,6 +164,8 @@ bdysAdd nw@Network {headers, bodies} hdr@Header {slotNumber, creator} b t nid =
100164
else (h,b,t',nids): go xs
101165

102166
newerBdys :: Network -> Header -> Int
103-
newerBdys = undefined
167+
newerBdys Network {bodies} h =
168+
Map.size $ snd $ Map.split (getMessageId h) bodies
169+
104170

105171

‎leios-sim/test/Main.hs‎

Lines changed: 18 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -2,13 +2,13 @@
22
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
33
module Main where
44

5-
import Control.Exception (evaluate)
6-
import GHC.Natural (Natural)
7-
import Node.Types (EndorsementBlock, Node, initializeNode)
5+
import qualified Data.Map as Map
6+
import GHC.Natural (Natural)
7+
import Network.FFD (Network (..), NetworkParameters (..))
8+
import Node.Types (EndorsementBlock, Node, initializeNode)
89
import Test.Hspec
910
import Test.QuickCheck
1011

11-
1212
main :: IO ()
1313
main = hspec $ do
1414
describe "Simple network" $ do
@@ -17,8 +17,8 @@ main = hspec $ do
1717
controller <- defaultController $ Bandwidth 10
1818
sut <- initializeNode defaultNodeParameters
1919
nodeOutput <- runNetwork defaultNetworkParameters load controller sut
20-
-- without bounds on the flow of traffic, all input IBs should end up in an EB
21-
length (ebs nodeOutput) `shouldBe` 1
20+
-- without bounds on the flow of traffic, all input IBs should end up in an EB )
21+
length (ebs nodeOutput) `shouldNotBe` 0 -- provided >0 IBs were put in and enough time has passed
2222

2323
where
2424
defaultGenerator :: IO Generator
@@ -29,13 +29,21 @@ main = hspec $ do
2929
defaultNetworkParameters = undefined
3030

3131
runNetwork :: NetworkParameters -> Generator -> Controller -> Node -> IO NodeOutput
32-
runNetwork = undefined
32+
runNetwork nwParams gen ctrlr node = undefined
33+
where
34+
initialNetwork = Network {
35+
headers = Map.empty
36+
, bodies = Map.empty
37+
, prefHdr = Map.empty
38+
, currentTime = 0
39+
, sutOutput = []
40+
, params = nwParams
41+
}
3342

3443
data NodeOutput = NodeOutput {
3544
ebs :: [EndorsementBlock]
3645
}
37-
data NetworkParameters = NetworkParameters
38-
data Generator = Generator ()
39-
data Controller = Controller ()
46+
data Generator = Generator
47+
data Controller = Controller
4048
newtype Bandwidth = Bandwidth Natural
4149
deriving newtype (Eq, Show, Num)

0 commit comments

Comments
 (0)