{-# LANGUAGE StandaloneDeriving #-}
module SybilLimit where

import Data.List ( foldl' )
import Data.IntMap.Strict ( IntMap, (!) )
import qualified Data.IntMap.Strict as IntMap
import Data.Traversable ( sequenceA )
import Control.Applicative
-- import System.Random
import Data.Map.Strict ( Map )
import qualified Data.Map as Map

import Stochastic

data NodeId

deriving instance Ord NodeId
deriving instance Eq NodeId

data ThisNode = ThisNode
    { selfId :: NodeId
    , friends :: IntMap FriendNode
    , friendById :: Map NodeId Int
    , routeTails :: IntMap (NodeId,NodeId)
    -- ^ Terminal edge by instance number.
    , tailCounters :: IntMap Int
    -- ^ verificaiton counter by instance number.
    , routeCount :: Int
    -- ^ The r parameter of SybilLimit.
    , pendingVerifications :: Map NodeId PendingIntersection
    }

data FriendNode = FriendNode
    { friendId :: NodeId
    , routesTo :: IntMap Int
    -- ^ Forward random-route hop by instance number.
    , routesFrom :: IntMap Int
    -- ^ Backward random-route hop by instance number.
    , registeredTerminal :: Maybe NodeId
    -- ^ Currently registered terminal edge.
    -- The NodeId indicates the source vertex, friendId is the destination vertex.
    }


-- | 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) ()
    }

data PeerMessage
    = ForwardRRMessage { rrRoute :: Int
                       , rrCount :: Int
                       , rrSuspect :: NodeId }
    | BackwardRRMessage { rrRoute :: Int
                        , rrCount :: Int
                        , rrTail :: (NodeId,NodeId) }
    | RegistrationQuery { rrSuspect :: NodeId
                        , rrRegisteredFrom :: NodeId }
    | RegistrationResponse { rrSuspect :: NodeId
                           , rrRegisteredFrom :: NodeId
                           , rrValidRegistration :: Bool }

{-
    | CredMessage SuspectCred

data SuspectCred = SuspectCred { suspectId :: NodeId
                               , suspectTails :: IntMap (NodeId,NodeId) }

-}

friendNode :: NodeId -> FriendNode
friendNode nid = FriendNode nid IntMap.empty IntMap.empty Nothing

friendCount :: ThisNode -> Int
friendCount me = IntMap.size $ friends me

todo :: a
todo = error "unimplemented"

-- | @ addFriend @ adds a friend and updates the random route instances.
--
-- Arguments:
--
--   [@them@] The 'NodeId' of the friend being added.
--
--   [@me@]   'ThisNode' prior to the friend being added.
--
-- Returns the altered 'ThisNode' and the list of friend numbers
-- for which we should send notifications about the change.
--
addFriend :: NodeId -> ThisNode -> Stochastic ( ThisNode, [Int] )
addFriend them me = fmap (\ks -> (addFriend' ks them me,ks)) mks
 where
    d   = friendCount me
    mks = sequenceA $ replicate (routeCount me) $ random 0 d

    addFriend' :: [Int] -> NodeId -> ThisNode -> ThisNode
    addFriend' ks them me = me { friends = fs, friendById = ids }
     where
        d   = friendCount me
        fs0 = IntMap.insert d (friendNode them) $ friends me
        ids = Map.insert them d (friendById me)
        fs  = foldl' (flip $ uncurry updateRoute) fs0 edges
            where edges = zip [0..] (map mkEdge ks)
                  mkEdge k = if k==d then (d,d) else (k,d)

-- | @ updateRoute @ updates one of the random routes used by SybilLimit.
--
--  [@i@]     The random route instance number.
--
--  [@(k,j)@] A pair of friend numbers.  The routes inbound from friend @k@
--            will be routed out to friend @j@ for the s-direction (forwards)
--            and vice versa for the v-direction (backwards).
--
--  [@fs@]    The current friend map prior to changed route.
--
-- Returns:  The friend map with changes applied.
--
updateRoute :: Int -> (Int,Int) -> IntMap FriendNode -> IntMap FriendNode
updateRoute i (k,j) fs = jfromk $ ktoj fs
 where
    ktoj fs   = IntMap.insert k (setTo   i j (fs!k)) fs
    jfromk fs = IntMap.insert j (setFrom i k (fs!j)) fs

    setTo i x f   = f { routesTo   = IntMap.insert i x (routesTo f)}
    setFrom i x f = f { routesFrom = IntMap.insert i x (routesFrom f)}


forwardMessage :: ThisNode -> (FriendNode -> IntMap Int) -> (NodeId,PeerMessage) -> (NodeId, PeerMessage)
forwardMessage me next (srcId,msg) = msg'
      where msg' = ( dest, msg { rrCount = rrCount msg + 1 } )
            srcno = friendById me Map.! srcId
            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', [])
 where
    me' = 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
              , iVerifiedTails =
                    if rrValidRegistration msg then v' else iVerifiedTails p
              }
        where v' = Map.insert (rrRegisteredFrom msg, srcId) ()
                            $ iVerifiedTails p

reactToMessage w (srcId, msg@(RegistrationQuery {})) me = (me, [(srcId,resp)])
 where
    resp = RegistrationResponse { rrSuspect = rrSuspect msg
                                , rrRegisteredFrom = rrRegisteredFrom msg
                                , rrValidRegistration = check }
    key = friendById me Map.! rrRegisteredFrom msg
    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)])
 where
    (terminate,next) = case msg of
                        ForwardRRMessage {} -> ( terminateForward, routesTo )
                        BackwardRRMessage {} -> ( terminateBackward, routesFrom )

    terminateForward = ( me { friends = friends' }, [pong] )
      where pong =( srcId, BackwardRRMessage { rrCount = 1
                                             , rrRoute = rrRoute msg
                                             , rrTail = (srcId, selfId me)
                                             } )
            friends' = IntMap.adjust adj suspectNo $ friends me
            suspectNo = friendById me Map.! rrSuspect msg
            adj f = f { registeredTerminal = Just $ rrSuspect msg }

    terminateBackward = ( me', [])
      where me' = me { routeTails =
                        IntMap.insert (rrRoute msg) (rrTail msg)
                                     $ routeTails me
                     }

{-
intersectionSatisfied :: SuspectCred -> ThisNode -> Bool
intersectionSatisfied suspect me = todo
 where
    x = IntMap.filter isSuspectTail $ routeTails me
    stails = IntMap.elems $ suspectTails suspect
    isSuspectTail tl = tl `elem` stails
-}