balance condition implemented in SybilLimit

1 files changed, 63 insertions, 29 deletions

diff --git a/SybilLimit.hs b/SybilLimit.hs
index bb0a54f..91433ba 100644
--- a/SybilLimit.hs
+++ b/SybilLimit.hs
@@ -1,7 +1,9 @@
 {-# LANGUAGE StandaloneDeriving #-}
 module SybilLimit where
 
-import Data.List ( foldl' )
+import Data.List ( foldl', minimumBy )
+import Data.Maybe ( fromMaybe )
+import Data.Ord ( comparing )
 import Data.IntMap.Strict ( IntMap, (!) )
 import qualified Data.IntMap.Strict as IntMap
 import Data.Traversable ( sequenceA )
@@ -45,9 +47,9 @@ data FriendNode = FriendNode
 -- | When 'iPendingTails' is empty, the intersection condition is passed if and
 -- only if 'iVerifiedTails' is not empty.
 data PendingIntersection = PendingIntersection
-    { iSuspect :: NodeId
-    , iPendingTails :: Map (NodeId,NodeId) ()
-    , iVerifiedTails :: Map (NodeId,NodeId) ()
+    { iSuspect :: NodeId -- todo: neccessary?
+    , iPendingTails :: Map (NodeId,NodeId) [Int]
+    , iVerifiedTails :: Map (NodeId,NodeId) [Int]
     }
 
 data PeerMessage
@@ -63,13 +65,16 @@ data PeerMessage
                            , rrRegisteredFrom :: NodeId
                            , rrValidRegistration :: Bool }
 
-{-
-    | CredMessage SuspectCred
 
-data SuspectCred = SuspectCred { suspectId :: NodeId
-                               , suspectTails :: IntMap (NodeId,NodeId) }
+data SybilCheck
+    = SybilCheck { chkSuspect :: NodeId
+                 , chkAccepted :: Bool }
 
--}
+data MessageReaction = MessageReaction
+    { changedState :: ThisNode
+    , outgoingMessages :: [(NodeId, PeerMessage)]
+    , sybilChecks :: [SybilCheck]
+    }
 
 friendNode :: NodeId -> FriendNode
 friendNode nid = FriendNode nid IntMap.empty IntMap.empty Nothing
@@ -136,21 +141,34 @@ forwardMessage me next (srcId,msg) = msg'
             destno = next (friends me ! srcno) ! rrRoute msg
             dest = friendId (friends me ! destno)
 
-reactToMessage :: Int -> (NodeId,PeerMessage) -> ThisNode -> (ThisNode, [(NodeId,PeerMessage)])
-reactToMessage w (srcId, msg@(RegistrationResponse {})) me = (me', [])
+reactToMessage :: Int -> (NodeId,PeerMessage) -> ThisNode -> MessageReaction
+reactToMessage w (srcId, msg@(RegistrationResponse {})) me =
+    MessageReaction me' [] sybils
  where
-    me' = me { pendingVerifications = vs' }
+    me0 = me { pendingVerifications = vs' }
     vs' :: Map NodeId PendingIntersection
     vs' = Map.adjust adj (rrSuspect msg) $ pendingVerifications me
-    adj p = p { iPendingTails = Map.delete (rrRegisteredFrom msg, srcId)
-                                    $ iPendingTails p
+    tail = (rrRegisteredFrom msg, srcId)
+    adj p = p { iPendingTails = Map.delete tail $ iPendingTails p
               , iVerifiedTails =
-                    if rrValidRegistration msg then v' else iVerifiedTails p
+                    if rrValidRegistration msg then goodTail else iVerifiedTails p
               }
-        where v' = Map.insert (rrRegisteredFrom msg, srcId) ()
-                            $ iVerifiedTails p
-
-reactToMessage w (srcId, msg@(RegistrationQuery {})) me = (me, [(srcId,resp)])
+        where goodTail = Map.insert tail indexes
+                                    $ iVerifiedTails p
+              indexes = fromMaybe [] $ Map.lookup tail $ iPendingTails p
+    icheck = pendingVerifications me0 Map.! rrSuspect msg
+    (me',sybils) = if Map.null (iPendingTails icheck) then bcheck else (me0, [])
+        where bcheck = if Map.null (iVerifiedTails icheck)
+                        then (me0, dishonest)
+                        else balanceCheck
+              dishonest = [SybilCheck (rrSuspect msg) False]
+              indexes = fromMaybe [] $ Map.lookup tail $ iVerifiedTails icheck
+              balanceCheck = second chk $ balanceCondition tail indexes me0
+                where chk = (:[]) . SybilCheck (rrSuspect msg)
+                      second f (x,y) = (x,f y)
+
+reactToMessage w (srcId, msg@(RegistrationQuery {})) me =
+    MessageReaction me [(srcId,resp)] []
  where
     resp = RegistrationResponse { rrSuspect = rrSuspect msg
                                 , rrRegisteredFrom = rrRegisteredFrom msg
@@ -159,13 +177,16 @@ reactToMessage w (srcId, msg@(RegistrationQuery {})) me = (me, [(srcId,resp)])
     check = registeredTerminal (friends me ! key) == Just (rrSuspect msg)
 
 reactToMessage w (srcId, msg) me =
-    if rrCount msg == w then terminate else (me, [forwardMessage me next (srcId,msg)])
+    if rrCount msg == w then terminate
+                        else MessageReaction me [forwardMessage me next (srcId,msg)] []
  where
     (terminate,next) = case msg of
                         ForwardRRMessage {} -> ( terminateForward, routesTo )
                         BackwardRRMessage {} -> ( terminateBackward, routesFrom )
 
-    terminateForward = ( me { friends = friends' }, [pong] )
+    terminateForward = MessageReaction me { friends = friends' }
+                                       [pong]
+                                       []
       where pong =( srcId, BackwardRRMessage { rrCount = 1
                                              , rrRoute = rrRoute msg
                                              , rrTail = (srcId, selfId me)
@@ -174,18 +195,31 @@ reactToMessage w (srcId, msg) me =
             suspectNo = friendById me Map.! rrSuspect msg
             adj f = f { registeredTerminal = Just $ rrSuspect msg }
 
-    terminateBackward = ( me', [])
+    terminateBackward = MessageReaction me' [] []
       where me' = me { routeTails =
                         IntMap.insert (rrRoute msg) (rrTail msg)
                                      $ routeTails me
                      }
 
-{-
-intersectionSatisfied :: SuspectCred -> ThisNode -> Bool
-intersectionSatisfied suspect me = todo
+balanceCondition :: (NodeId,NodeId) -> [Int] -> ThisNode -> (ThisNode, Bool)
+balanceCondition (ka,kb) routeNums me = (me',didPass)
  where
-    x = IntMap.filter isSuspectTail $ routeTails me
-    stails = IntMap.elems $ suspectTails suspect
-    isSuspectTail tl = tl `elem` stails
--}
+    me' = me { tailCounters = counters' }
+     where
+        counters' = if didPass then incremented else tailCounters me
+        incremented = IntMap.adjust (+1) cmin $ tailCounters me
 
+    didPass = fromIntegral (cmin + 1) <= b
+
+    b = h * max (logBase 2 r) a :: Double
+     where
+        r = fromIntegral $ routeCount me
+        a = fromIntegral ( 1 + sum (IntMap.elems $ tailCounters me) ) / r
+        h = 4 -- h > 1 is some universal constant that is not too small (they used
+              -- h = 4 in their experiments).
+    cmin = minimumBy indexCompare routeNums
+     where
+        indexCompare ca cb = tieBreak $ comparing (tailCounters me !) ca cb
+         where
+            tieBreak EQ = compare ca cb
+            tieBreak x = x