diff options
-rw-r--r-- | SybilLimit.hs | 136 |
1 files changed, 136 insertions, 0 deletions
diff --git a/SybilLimit.hs b/SybilLimit.hs new file mode 100644 index 0000000..8324b85 --- /dev/null +++ b/SybilLimit.hs | |||
@@ -0,0 +1,136 @@ | |||
1 | {-# LANGUAGE StandaloneDeriving #-} | ||
2 | module SybilLimit where | ||
3 | |||
4 | import Data.List | ||
5 | import Data.IntMap.Strict ( IntMap, (!) ) | ||
6 | import qualified Data.IntMap.Strict as IntMap | ||
7 | import Data.Traversable | ||
8 | import Control.Applicative | ||
9 | -- import System.Random | ||
10 | import Stochastic | ||
11 | import Data.Map.Strict ( Map ) | ||
12 | import qualified Data.Map as Map | ||
13 | |||
14 | data NodeId | ||
15 | |||
16 | deriving instance Ord NodeId | ||
17 | deriving instance Eq NodeId | ||
18 | |||
19 | data ThisNode = ThisNode | ||
20 | { selfId :: NodeId | ||
21 | , friends :: IntMap FriendNode | ||
22 | , friendById :: Map NodeId Int | ||
23 | , routeTails :: IntMap (NodeId,NodeId) | ||
24 | -- ^ Terminal edge by instance number. | ||
25 | , routeCount :: Int | ||
26 | } | ||
27 | |||
28 | data FriendNode = FriendNode | ||
29 | { friendId :: NodeId | ||
30 | , routesTo :: IntMap Int | ||
31 | -- ^ Forward random-route hop by instance number. | ||
32 | , routesFrom :: IntMap Int | ||
33 | -- ^ Backward random-route hop by instance number. | ||
34 | , registeredTerminal :: Maybe NodeId | ||
35 | -- ^ Currently registered terminal edge. | ||
36 | -- The NodeId indicates the source vertex, friendId is the destination vertex. | ||
37 | } | ||
38 | |||
39 | |||
40 | data PeerMessage | ||
41 | = ForwardRRMessage { rrRoute :: Int | ||
42 | , rrCount :: Int | ||
43 | , rrSuspect :: NodeId } | ||
44 | | BackwardRRMessage { rrRoute :: Int | ||
45 | , rrCount :: Int | ||
46 | , rrTail :: (NodeId,NodeId) } | ||
47 | |||
48 | |||
49 | |||
50 | friendNode :: NodeId -> FriendNode | ||
51 | friendNode nid = FriendNode nid IntMap.empty IntMap.empty Nothing | ||
52 | |||
53 | friendCount :: ThisNode -> Int | ||
54 | friendCount me = IntMap.size $ friends me | ||
55 | |||
56 | todo :: a | ||
57 | todo = error "unimplemented" | ||
58 | |||
59 | -- | @ addFriend @ adds a friend and updates the random route instances. | ||
60 | -- | ||
61 | -- Arguments: | ||
62 | -- | ||
63 | -- [@them@] The 'NodeId' of the friend being added. | ||
64 | -- | ||
65 | -- [@me@] 'ThisNode' prior to the friend being added. | ||
66 | -- | ||
67 | -- Returns the altered 'ThisNode' and the list of friend numbers | ||
68 | -- for which we should send notifications about the change. | ||
69 | -- | ||
70 | addFriend :: NodeId -> ThisNode -> Stochastic ( ThisNode, [Int] ) | ||
71 | addFriend them me = fmap (\ks -> (addFriend' ks them me,ks)) mks | ||
72 | where | ||
73 | d = friendCount me | ||
74 | mks = sequenceA $ replicate (routeCount me) $ random 0 d | ||
75 | |||
76 | addFriend' :: [Int] -> NodeId -> ThisNode -> ThisNode | ||
77 | addFriend' ks them me = me { friends = fs, friendById = ids } | ||
78 | where | ||
79 | d = friendCount me | ||
80 | fs0 = IntMap.insert d (friendNode them) $ friends me | ||
81 | ids = Map.insert them d (friendById me) | ||
82 | fs = foldl' (flip $ uncurry updateRoute) fs0 edges | ||
83 | where edges = zip [0..] (map mkEdge ks) | ||
84 | mkEdge k = if k==d then (d,d) else (k,d) | ||
85 | |||
86 | -- | @ updateRoute @ updates one of the random routes used by SybilLimit. | ||
87 | -- | ||
88 | -- [@i@] The random route instance number. | ||
89 | -- | ||
90 | -- [@(k,j)@] A pair of friend numbers. The routes inbound from friend @k@ | ||
91 | -- will be routed out to friend @j@ for the s-direction (forwards) | ||
92 | -- and vice versa for the v-direction (backwards). | ||
93 | -- | ||
94 | -- [@fs@] The current friend map prior to changed route. | ||
95 | -- | ||
96 | -- Returns: The friend map with changes applied. | ||
97 | -- | ||
98 | updateRoute :: Int -> (Int,Int) -> IntMap FriendNode -> IntMap FriendNode | ||
99 | updateRoute i (k,j) fs = jfromk $ ktoj fs | ||
100 | where | ||
101 | ktoj fs = IntMap.insert k (setTo i j (fs!k)) fs | ||
102 | jfromk fs = IntMap.insert j (setFrom i k (fs!j)) fs | ||
103 | |||
104 | setTo i x f = f { routesTo = IntMap.insert i x (routesTo f)} | ||
105 | setFrom i x f = f { routesFrom = IntMap.insert i x (routesFrom f)} | ||
106 | |||
107 | |||
108 | forwardMessage me next (srcId,msg) = msg' | ||
109 | where msg' = ( dest, msg { rrCount = rrCount msg + 1 } ) | ||
110 | srcno = friendById me Map.! srcId | ||
111 | destno = next (friends me ! srcno) ! rrRoute msg | ||
112 | dest = friendId (friends me ! destno) | ||
113 | |||
114 | reactToMessage :: Int -> (NodeId,PeerMessage) -> ThisNode -> (ThisNode, [(NodeId,PeerMessage)]) | ||
115 | reactToMessage w (srcId, msg) me = | ||
116 | if rrCount msg == w then terminate else (me, [forwardMessage me next (srcId,msg)]) | ||
117 | where | ||
118 | (terminate,next) = case msg of | ||
119 | ForwardRRMessage {} -> ( terminateForward, routesTo ) | ||
120 | BackwardRRMessage {} -> ( terminateBackward, routesFrom ) | ||
121 | |||
122 | terminateForward = ( me { friends = friends' }, [pong] ) | ||
123 | where pong =( srcId, BackwardRRMessage { rrCount = 1 | ||
124 | , rrRoute = rrRoute msg | ||
125 | , rrTail = (srcId, selfId me) | ||
126 | } ) | ||
127 | friends' = IntMap.adjust adj suspectNo $ friends me | ||
128 | suspectNo = friendById me Map.! rrSuspect msg | ||
129 | adj f = f { registeredTerminal = Just $ rrSuspect msg } | ||
130 | |||
131 | terminateBackward = ( me', []) | ||
132 | where me' = me { routeTails = | ||
133 | IntMap.insert (rrRoute msg) (rrTail msg) | ||
134 | $ routeTails me | ||
135 | } | ||
136 | |||