\section{DHT Operation}

\begin{code}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StrictData            #-}
module Network.Tox.DHT.Operation where

import           Control.Monad                        (guard, msum, replicateM,
                                                       unless, void, when)
import           Control.Monad.Identity               (Identity, runIdentity)
import           Control.Monad.Random                 (RandT, evalRandT)
import           Control.Monad.State                  (MonadState, StateT,
                                                       execStateT, get, gets,
                                                       modify, put, runStateT)
import           Control.Monad.Trans                  (lift)
import           Control.Monad.Trans.Maybe            (MaybeT (..), runMaybeT)
import           Control.Monad.Writer                 (MonadWriter, WriterT,
                                                       execWriterT, tell)
import           Data.Binary                          (Binary)
import           Data.Foldable                        (for_)
import           Data.Functor                         (($>))
import           Data.Map                             (Map)
import qualified Data.Map                             as Map
import           Data.Maybe                           (isNothing)
import           Lens.Family2                         (Lens')
import           Lens.Family2.State                   (zoom, (%%=), (%=))
import           System.Random                        (StdGen, mkStdGen)
import           Test.QuickCheck.Arbitrary            (Arbitrary, arbitrary)

import           Network.Tox.Crypto.Key               (PublicKey)
import           Network.Tox.Crypto.Keyed             (Keyed)
import           Network.Tox.Crypto.KeyedT            (KeyedT)
import qualified Network.Tox.Crypto.KeyedT            as KeyedT
import qualified Network.Tox.Crypto.KeyPair           as KeyPair
import           Network.Tox.DHT.ClientList           (ClientList)
import qualified Network.Tox.DHT.ClientList           as ClientList
import           Network.Tox.DHT.ClientNode           (ClientNode)
import qualified Network.Tox.DHT.ClientNode           as ClientNode
import qualified Network.Tox.DHT.DhtPacket            as DhtPacket
import           Network.Tox.DHT.DhtRequestPacket     (DhtRequestPacket (..))
import           Network.Tox.DHT.DhtState             (DhtState)
import qualified Network.Tox.DHT.DhtState             as DhtState
import           Network.Tox.DHT.NodeList             (NodeList)
import qualified Network.Tox.DHT.NodeList             as NodeList
import           Network.Tox.DHT.NodesRequest         (NodesRequest (..))
import           Network.Tox.DHT.NodesResponse        (NodesResponse (..))
import qualified Network.Tox.DHT.PendingReplies       as PendingReplies
import           Network.Tox.DHT.PingPacket           (PingPacket (..))
import           Network.Tox.DHT.RpcPacket            (RpcPacket (..))
import qualified Network.Tox.DHT.RpcPacket            as RpcPacket
import qualified Network.Tox.DHT.Stamped              as Stamped
import           Network.Tox.Network.MonadRandomBytes (MonadRandomBytes)
import qualified Network.Tox.Network.MonadRandomBytes as MonadRandomBytes
import           Network.Tox.Network.Networked        (Networked)
import qualified Network.Tox.Network.Networked        as Networked
import           Network.Tox.NodeInfo.NodeInfo        (NodeInfo)
import qualified Network.Tox.NodeInfo.NodeInfo        as NodeInfo
import           Network.Tox.Protocol.Packet          (Packet (..))
import           Network.Tox.Protocol.PacketKind      (PacketKind)
import qualified Network.Tox.Protocol.PacketKind      as PacketKind
import           Network.Tox.Time                     (TimeDiff, Timestamp)
import qualified Network.Tox.Time                     as Time
import           Network.Tox.Timed                    (Timed)
import qualified Network.Tox.Timed                    as Timed
import           Network.Tox.TimedT                   (TimedT)
import qualified Network.Tox.TimedT                   as TimedT


{-------------------------------------------------------------------------------
 -
 - :: Implementation.
 -
 ------------------------------------------------------------------------------}

class
  ( Networked m
  , Timed m
  , MonadRandomBytes m
  , MonadState DhtState m
  , Keyed m
  ) => DhtNodeMonad m where {}

data RequestInfo = RequestInfo
  { RequestInfo -> NodeInfo
requestTo     :: NodeInfo
  , RequestInfo -> PublicKey
requestSearch :: PublicKey
  }
  deriving (RequestInfo -> RequestInfo -> Bool
(RequestInfo -> RequestInfo -> Bool)
-> (RequestInfo -> RequestInfo -> Bool) -> Eq RequestInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RequestInfo -> RequestInfo -> Bool
$c/= :: RequestInfo -> RequestInfo -> Bool
== :: RequestInfo -> RequestInfo -> Bool
$c== :: RequestInfo -> RequestInfo -> Bool
Eq, ReadPrec [RequestInfo]
ReadPrec RequestInfo
Int -> ReadS RequestInfo
ReadS [RequestInfo]
(Int -> ReadS RequestInfo)
-> ReadS [RequestInfo]
-> ReadPrec RequestInfo
-> ReadPrec [RequestInfo]
-> Read RequestInfo
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RequestInfo]
$creadListPrec :: ReadPrec [RequestInfo]
readPrec :: ReadPrec RequestInfo
$creadPrec :: ReadPrec RequestInfo
readList :: ReadS [RequestInfo]
$creadList :: ReadS [RequestInfo]
readsPrec :: Int -> ReadS RequestInfo
$creadsPrec :: Int -> ReadS RequestInfo
Read, Int -> RequestInfo -> ShowS
[RequestInfo] -> ShowS
RequestInfo -> String
(Int -> RequestInfo -> ShowS)
-> (RequestInfo -> String)
-> ([RequestInfo] -> ShowS)
-> Show RequestInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestInfo] -> ShowS
$cshowList :: [RequestInfo] -> ShowS
show :: RequestInfo -> String
$cshow :: RequestInfo -> String
showsPrec :: Int -> RequestInfo -> ShowS
$cshowsPrec :: Int -> RequestInfo -> ShowS
Show)

sendDhtPacket :: (DhtNodeMonad m, Binary payload) =>
  NodeInfo -> PacketKind -> payload -> m ()
sendDhtPacket :: NodeInfo -> PacketKind -> payload -> m ()
sendDhtPacket NodeInfo
to PacketKind
kind payload
payload = do
  KeyPair
keyPair <- (DhtState -> KeyPair) -> m KeyPair
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DhtState -> KeyPair
DhtState.dhtKeyPair
  Nonce
nonce <- m Nonce
forall (m :: * -> *). MonadRandomBytes m => m Nonce
MonadRandomBytes.randomNonce
  NodeInfo -> Packet DhtPacket -> m ()
forall (m :: * -> *) payload.
(Networked m, Binary payload, Show payload) =>
NodeInfo -> Packet payload -> m ()
Networked.sendPacket NodeInfo
to (Packet DhtPacket -> m ())
-> (DhtPacket -> Packet DhtPacket) -> DhtPacket -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PacketKind -> DhtPacket -> Packet DhtPacket
forall payload. PacketKind -> payload -> Packet payload
Packet PacketKind
kind (DhtPacket -> m ()) -> m DhtPacket -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    KeyPair -> PublicKey -> Nonce -> payload -> m DhtPacket
forall payload (m :: * -> *).
(Binary payload, Keyed m) =>
KeyPair -> PublicKey -> Nonce -> payload -> m DhtPacket
DhtPacket.encodeKeyed KeyPair
keyPair (NodeInfo -> PublicKey
NodeInfo.publicKey NodeInfo
to) Nonce
nonce payload
payload

sendRpcRequest :: (DhtNodeMonad m, Binary payload) =>
  NodeInfo -> PacketKind -> payload -> m ()
sendRpcRequest :: NodeInfo -> PacketKind -> payload -> m ()
sendRpcRequest NodeInfo
to PacketKind
packetKind payload
payload = do
  RequestId
requestId <- Word64 -> RequestId
RpcPacket.RequestId (Word64 -> RequestId) -> m Word64 -> m RequestId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Word64
forall (m :: * -> *). MonadRandomBytes m => m Word64
MonadRandomBytes.randomWord64
  Timestamp
time <- m Timestamp
forall (m :: * -> *). Timed m => m Timestamp
Timed.askTime
  Lens' DhtState PendingReplies
forall (f :: * -> *).
Identical f =>
LensLike' f DhtState PendingReplies
DhtState._dhtPendingReplies (forall (f :: * -> *).
 Identical f =>
 LensLike' f DhtState PendingReplies)
-> (PendingReplies -> PendingReplies) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
Setter s s a b -> (a -> b) -> m ()
%= Timestamp
-> NodeInfo -> RequestId -> PendingReplies -> PendingReplies
PendingReplies.expectReply Timestamp
time NodeInfo
to RequestId
requestId
  NodeInfo -> PacketKind -> RpcPacket payload -> m ()
forall (m :: * -> *) payload.
(DhtNodeMonad m, Binary payload) =>
NodeInfo -> PacketKind -> payload -> m ()
sendDhtPacket NodeInfo
to PacketKind
packetKind (RpcPacket payload -> m ()) -> RpcPacket payload -> m ()
forall a b. (a -> b) -> a -> b
$
    payload -> RequestId -> RpcPacket payload
forall payload. payload -> RequestId -> RpcPacket payload
RpcPacket payload
payload RequestId
requestId

sendNodesRequest :: DhtNodeMonad m => RequestInfo -> m ()
sendNodesRequest :: RequestInfo -> m ()
sendNodesRequest (RequestInfo NodeInfo
to PublicKey
key) =
  NodeInfo -> PacketKind -> NodesRequest -> m ()
forall (m :: * -> *) payload.
(DhtNodeMonad m, Binary payload) =>
NodeInfo -> PacketKind -> payload -> m ()
sendRpcRequest NodeInfo
to PacketKind
PacketKind.NodesRequest (NodesRequest -> m ()) -> NodesRequest -> m ()
forall a b. (a -> b) -> a -> b
$ PublicKey -> NodesRequest
NodesRequest PublicKey
key

sendNodesResponse ::
  DhtNodeMonad m => NodeInfo -> RpcPacket.RequestId -> [NodeInfo] -> m ()
sendNodesResponse :: NodeInfo -> RequestId -> [NodeInfo] -> m ()
sendNodesResponse NodeInfo
to RequestId
requestId [NodeInfo]
nodes =
  NodeInfo -> PacketKind -> RpcPacket NodesResponse -> m ()
forall (m :: * -> *) payload.
(DhtNodeMonad m, Binary payload) =>
NodeInfo -> PacketKind -> payload -> m ()
sendDhtPacket NodeInfo
to PacketKind
PacketKind.NodesResponse (RpcPacket NodesResponse -> m ())
-> RpcPacket NodesResponse -> m ()
forall a b. (a -> b) -> a -> b
$
    NodesResponse -> RequestId -> RpcPacket NodesResponse
forall payload. payload -> RequestId -> RpcPacket payload
RpcPacket ([NodeInfo] -> NodesResponse
NodesResponse [NodeInfo]
nodes) RequestId
requestId

sendPingRequest :: DhtNodeMonad m => NodeInfo -> m ()
sendPingRequest :: NodeInfo -> m ()
sendPingRequest NodeInfo
to =
  NodeInfo -> PacketKind -> PingPacket -> m ()
forall (m :: * -> *) payload.
(DhtNodeMonad m, Binary payload) =>
NodeInfo -> PacketKind -> payload -> m ()
sendRpcRequest NodeInfo
to PacketKind
PacketKind.PingRequest PingPacket
PingRequest

sendPingResponse ::
  DhtNodeMonad m => NodeInfo -> RpcPacket.RequestId -> m ()
sendPingResponse :: NodeInfo -> RequestId -> m ()
sendPingResponse NodeInfo
to RequestId
requestId =
  NodeInfo -> PacketKind -> RpcPacket PingPacket -> m ()
forall (m :: * -> *) payload.
(DhtNodeMonad m, Binary payload) =>
NodeInfo -> PacketKind -> payload -> m ()
sendDhtPacket NodeInfo
to PacketKind
PacketKind.PingResponse (RpcPacket PingPacket -> m ()) -> RpcPacket PingPacket -> m ()
forall a b. (a -> b) -> a -> b
$
    PingPacket -> RequestId -> RpcPacket PingPacket
forall payload. payload -> RequestId -> RpcPacket payload
RpcPacket PingPacket
PingResponse RequestId
requestId

modifyM :: MonadState s m => (s -> m s) -> m ()
modifyM :: (s -> m s) -> m ()
modifyM = (s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (s -> m ()) -> m s -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (m s -> m ()) -> ((s -> m s) -> m s) -> (s -> m s) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m s
forall s (m :: * -> *). MonadState s m => m s
get m s -> (s -> m s) -> m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)

-- | adapted from michaelt's lens-simple:
-- zoom_ is like zoom but for convenience returns an mtl style
-- abstracted MonadState state, rather than a concrete StateT, recapturing
-- a bit more of the abstractness of Control.Lens.zoom
zoom_ :: MonadState s' m => Lens' s' s -> StateT s m a -> m a
-- full signature:
-- zoom_ :: MonadState s' m =>
--   LensLike' (Zooming m a) s' s -> StateT s m a -> m a
zoom_ :: Lens' s' s -> StateT s m a -> m a
zoom_ Lens' s' s
l StateT s m a
f = StateT s' m a -> m a
forall s (m :: * -> *) a. MonadState s m => StateT s m a -> m a
abstract (StateT s' m a -> m a) -> StateT s' m a -> m a
forall a b. (a -> b) -> a -> b
$ LensLike' (Zooming m a) s' s -> StateT s m a -> StateT s' m a
forall (m :: * -> *) c s a.
Monad m =>
LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c
zoom LensLike' (Zooming m a) s' s
Lens' s' s
l StateT s m a
f
  where
    abstract :: MonadState s m => StateT s m a -> m a
    abstract :: StateT s m a -> m a
abstract StateT s m a
st = do
      (a
a,s
s') <- StateT s m a -> s -> m (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT s m a
st (s -> m (a, s)) -> m s -> m (a, s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m s
forall s (m :: * -> *). MonadState s m => m s
get
      s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
s'
      a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

\end{code}

\subsection{DHT Initialisation}
A new DHT node is initialised with a DHT State with a fresh random key pair, an
empty close list, and a search list containing 2 empty search entries searching
for the public keys of fresh random key pairs.

\begin{code}

initRandomSearches :: Int
initRandomSearches :: Int
initRandomSearches = Int
2

initDht :: (MonadRandomBytes m, Timed m) => m DhtState
initDht :: m DhtState
initDht = do
  DhtState
dhtState <- Timestamp -> KeyPair -> DhtState
DhtState.empty (Timestamp -> KeyPair -> DhtState)
-> m Timestamp -> m (KeyPair -> DhtState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Timestamp
forall (m :: * -> *). Timed m => m Timestamp
Timed.askTime m (KeyPair -> DhtState) -> m KeyPair -> m DhtState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m KeyPair
forall (m :: * -> *). MonadRandomBytes m => m KeyPair
MonadRandomBytes.newKeyPair
  Timestamp
time <- m Timestamp
forall (m :: * -> *). Timed m => m Timestamp
Timed.askTime
  (StateT DhtState m [()] -> DhtState -> m DhtState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
`execStateT` DhtState
dhtState) (StateT DhtState m [()] -> m DhtState)
-> StateT DhtState m [()] -> m DhtState
forall a b. (a -> b) -> a -> b
$ Int -> StateT DhtState m () -> StateT DhtState m [()]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
initRandomSearches (StateT DhtState m () -> StateT DhtState m [()])
-> StateT DhtState m () -> StateT DhtState m [()]
forall a b. (a -> b) -> a -> b
$ do
    PublicKey
publicKey <- KeyPair -> PublicKey
KeyPair.publicKey (KeyPair -> PublicKey)
-> StateT DhtState m KeyPair -> StateT DhtState m PublicKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT DhtState m KeyPair
forall (m :: * -> *). MonadRandomBytes m => m KeyPair
MonadRandomBytes.newKeyPair
    Lens' DhtState (Map PublicKey DhtSearchEntry)
forall (f :: * -> *).
Identical f =>
LensLike' f DhtState (Map PublicKey DhtSearchEntry)
DhtState._dhtSearchList (forall (f :: * -> *).
 Identical f =>
 LensLike' f DhtState (Map PublicKey DhtSearchEntry))
-> (Map PublicKey DhtSearchEntry -> Map PublicKey DhtSearchEntry)
-> StateT DhtState m ()
forall s (m :: * -> *) a b.
MonadState s m =>
Setter s s a b -> (a -> b) -> m ()
%=
      PublicKey
-> DhtSearchEntry
-> Map PublicKey DhtSearchEntry
-> Map PublicKey DhtSearchEntry
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PublicKey
publicKey (Timestamp -> PublicKey -> DhtSearchEntry
DhtState.emptySearchEntry Timestamp
time PublicKey
publicKey)

bootstrapNode :: DhtNodeMonad m => NodeInfo -> m ()
bootstrapNode :: NodeInfo -> m ()
bootstrapNode NodeInfo
nodeInfo =
  RequestInfo -> m ()
forall (m :: * -> *). DhtNodeMonad m => RequestInfo -> m ()
sendNodesRequest (RequestInfo -> m ())
-> (PublicKey -> RequestInfo) -> PublicKey -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo -> PublicKey -> RequestInfo
RequestInfo NodeInfo
nodeInfo (PublicKey -> m ()) -> m PublicKey -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    KeyPair -> PublicKey
KeyPair.publicKey (KeyPair -> PublicKey) -> m KeyPair -> m PublicKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DhtState -> KeyPair) -> m KeyPair
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DhtState -> KeyPair
DhtState.dhtKeyPair

-- TODO
--loadDHT :: ??

\end{code}

\subsection{Periodic sending of Nodes Requests}
For each Nodes List in the DHT State, every 20 seconds we send a Nodes Request
to a random node on the list, searching for the base key of the list.

When a Nodes List first becomes populated with nodes, we send 5 such random
Nodes Requests in quick succession.

Random nodes are chosen since being able to predict which node a node will
send a request to next could make some attacks that disrupt the network
easier, as it adds a possible attack vector.

\begin{code}

randomRequestPeriod :: TimeDiff
randomRequestPeriod :: TimeDiff
randomRequestPeriod = Integer -> TimeDiff
Time.seconds Integer
20

maxBootstrapTimes :: Int
maxBootstrapTimes :: Int
maxBootstrapTimes = Int
5

randomRequests :: DhtNodeMonad m => WriterT [RequestInfo] m ()
randomRequests :: WriterT [RequestInfo] m ()
randomRequests = do
  KBuckets
closeList <- (DhtState -> KBuckets) -> WriterT [RequestInfo] m KBuckets
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DhtState -> KBuckets
DhtState.dhtCloseList
  Lens' DhtState ListStamp
-> StateT ListStamp (WriterT [RequestInfo] m) ()
-> WriterT [RequestInfo] m ()
forall s' (m :: * -> *) s a.
MonadState s' m =>
Lens' s' s -> StateT s m a -> m a
zoom_ Lens' DhtState ListStamp
DhtState._dhtCloseListStamp (StateT ListStamp (WriterT [RequestInfo] m) ()
 -> WriterT [RequestInfo] m ())
-> StateT ListStamp (WriterT [RequestInfo] m) ()
-> WriterT [RequestInfo] m ()
forall a b. (a -> b) -> a -> b
$ KBuckets -> StateT ListStamp (WriterT [RequestInfo] m) ()
forall l (m :: * -> *).
(NodeList l, Timed m, MonadRandomBytes m, MonadState ListStamp m,
 MonadWriter [RequestInfo] m) =>
l -> m ()
doList KBuckets
closeList
  Lens' DhtState (Map PublicKey DhtSearchEntry)
-> StateT
     (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m) ()
-> WriterT [RequestInfo] m ()
forall s' (m :: * -> *) s a.
MonadState s' m =>
Lens' s' s -> StateT s m a -> m a
zoom_ Lens' DhtState (Map PublicKey DhtSearchEntry)
DhtState._dhtSearchList (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m) ()
 -> WriterT [RequestInfo] m ())
-> (StateT
      DhtSearchEntry
      (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m))
      ()
    -> StateT
         (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m) ())
-> StateT
     DhtSearchEntry
     (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m))
     ()
-> WriterT [RequestInfo] m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Map PublicKey DhtSearchEntry
 -> StateT
      (Map PublicKey DhtSearchEntry)
      (WriterT [RequestInfo] m)
      (Map PublicKey DhtSearchEntry))
-> StateT
     (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m) ()
forall s (m :: * -> *). MonadState s m => (s -> m s) -> m ()
modifyM ((Map PublicKey DhtSearchEntry
  -> StateT
       (Map PublicKey DhtSearchEntry)
       (WriterT [RequestInfo] m)
       (Map PublicKey DhtSearchEntry))
 -> StateT
      (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m) ())
-> (StateT
      DhtSearchEntry
      (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m))
      ()
    -> Map PublicKey DhtSearchEntry
    -> StateT
         (Map PublicKey DhtSearchEntry)
         (WriterT [RequestInfo] m)
         (Map PublicKey DhtSearchEntry))
-> StateT
     DhtSearchEntry
     (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m))
     ()
-> StateT
     (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DhtSearchEntry
 -> StateT
      (Map PublicKey DhtSearchEntry)
      (WriterT [RequestInfo] m)
      DhtSearchEntry)
-> Map PublicKey DhtSearchEntry
-> StateT
     (Map PublicKey DhtSearchEntry)
     (WriterT [RequestInfo] m)
     (Map PublicKey DhtSearchEntry)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((DhtSearchEntry
  -> StateT
       (Map PublicKey DhtSearchEntry)
       (WriterT [RequestInfo] m)
       DhtSearchEntry)
 -> Map PublicKey DhtSearchEntry
 -> StateT
      (Map PublicKey DhtSearchEntry)
      (WriterT [RequestInfo] m)
      (Map PublicKey DhtSearchEntry))
-> (StateT
      DhtSearchEntry
      (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m))
      ()
    -> DhtSearchEntry
    -> StateT
         (Map PublicKey DhtSearchEntry)
         (WriterT [RequestInfo] m)
         DhtSearchEntry)
-> StateT
     DhtSearchEntry
     (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m))
     ()
-> Map PublicKey DhtSearchEntry
-> StateT
     (Map PublicKey DhtSearchEntry)
     (WriterT [RequestInfo] m)
     (Map PublicKey DhtSearchEntry)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT
  DhtSearchEntry
  (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m))
  ()
-> DhtSearchEntry
-> StateT
     (Map PublicKey DhtSearchEntry)
     (WriterT [RequestInfo] m)
     DhtSearchEntry
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (StateT
   DhtSearchEntry
   (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m))
   ()
 -> WriterT [RequestInfo] m ())
-> StateT
     DhtSearchEntry
     (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m))
     ()
-> WriterT [RequestInfo] m ()
forall a b. (a -> b) -> a -> b
$ do
      ClientList
searchList <- (DhtSearchEntry -> ClientList)
-> StateT
     DhtSearchEntry
     (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m))
     ClientList
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DhtSearchEntry -> ClientList
DhtState.searchClientList
      Lens' DhtSearchEntry ListStamp
-> StateT
     ListStamp
     (StateT
        DhtSearchEntry
        (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m)))
     ()
-> StateT
     DhtSearchEntry
     (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m))
     ()
forall s' (m :: * -> *) s a.
MonadState s' m =>
Lens' s' s -> StateT s m a -> m a
zoom_ Lens' DhtSearchEntry ListStamp
DhtState._searchStamp (StateT
   ListStamp
   (StateT
      DhtSearchEntry
      (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m)))
   ()
 -> StateT
      DhtSearchEntry
      (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m))
      ())
-> StateT
     ListStamp
     (StateT
        DhtSearchEntry
        (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m)))
     ()
-> StateT
     DhtSearchEntry
     (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m))
     ()
forall a b. (a -> b) -> a -> b
$ ClientList
-> StateT
     ListStamp
     (StateT
        DhtSearchEntry
        (StateT (Map PublicKey DhtSearchEntry) (WriterT [RequestInfo] m)))
     ()
forall l (m :: * -> *).
(NodeList l, Timed m, MonadRandomBytes m, MonadState ListStamp m,
 MonadWriter [RequestInfo] m) =>
l -> m ()
doList ClientList
searchList
  where
    doList ::
      ( NodeList l
      , Timed m
      , MonadRandomBytes m
      , MonadState DhtState.ListStamp m
      , MonadWriter [RequestInfo] m
      ) => l -> m ()
    doList :: l -> m ()
doList l
nodeList =
      case l -> [NodeInfo]
forall l. NodeList l => l -> [NodeInfo]
NodeList.nodeListList l
nodeList of
        [] -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [NodeInfo]
nodes -> do
          Timestamp
time <- m Timestamp
forall (m :: * -> *). Timed m => m Timestamp
Timed.askTime
          DhtState.ListStamp Timestamp
lastTime Int
bootstrapped <- m ListStamp
forall s (m :: * -> *). MonadState s m => m s
get
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Timestamp
time Timestamp -> Timestamp -> TimeDiff
Time.- Timestamp
lastTime TimeDiff -> TimeDiff -> Bool
forall a. Ord a => a -> a -> Bool
>= TimeDiff
randomRequestPeriod
              Bool -> Bool -> Bool
|| Int
bootstrapped Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxBootstrapTimes) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            NodeInfo
node <- [NodeInfo] -> m NodeInfo
forall (m :: * -> *) a. MonadRandomBytes m => [a] -> m a
MonadRandomBytes.uniform [NodeInfo]
nodes
            [RequestInfo] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [NodeInfo -> PublicKey -> RequestInfo
RequestInfo NodeInfo
node (PublicKey -> RequestInfo) -> PublicKey -> RequestInfo
forall a b. (a -> b) -> a -> b
$ l -> PublicKey
forall l. NodeList l => l -> PublicKey
NodeList.baseKey l
nodeList]
            ListStamp -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ListStamp -> m ()) -> ListStamp -> m ()
forall a b. (a -> b) -> a -> b
$ Timestamp -> Int -> ListStamp
DhtState.ListStamp Timestamp
time (Int
bootstrapped Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

\end{code}

Furthermore, we periodically check every node for responsiveness by sending it a
Nodes Request: for each Nodes List in the DHT State, we send each node on the
list a Nodes Request every 60 seconds, searching for the base key of the list.
We remove from the DHT State any node from which we persistently fail to receive
Nodes Responses.

c-toxcore's implementation of checking and timeouts:
A Last Checked time is maintained for each node in each list. When a node is
added to a list, if doing so evicts a node from the list then the Last Checked
time is set to that of the evicted node, and otherwise it is set to 0. This
includes updating an already present node. Nodes from which we have not
received a Nodes Response for 122 seconds are considered Bad; they remain in the
DHT State, but are preferentially overwritten when adding to the DHT State, and
are ignored for all operations except the once-per-60s checking described above.
If we have not received a Nodes Response for 182 seconds, the node is not even
checked. So one check is sent after the node becomes Bad. In the special case
that every node in the Close List is Bad, they are all checked once more.)

hs-toxcore implementation of checking and timeouts:
We maintain a Last Checked timestamp and a Checks Counter on each node on each
Nodes List in the Dht State. When a node is added to a list, these are set
respectively to the current time and to 0. This includes updating an already
present node. We periodically pass through the nodes on the lists, and for each
which is due a check, we: check it, update the timestamp, increment the counter,
and, if the counter is then 2, remove the node from the list. This is pretty
close to the behaviour of c-toxcore, but much simpler. TODO: currently hs-toxcore
doesn't do anything to try to recover if the Close List becomes empty. We could
maintain a separate list of the most recently heard from nodes, and repopulate
the Close List with that if the Close List becomes empty.

\begin{code}

checkPeriod :: TimeDiff
checkPeriod :: TimeDiff
checkPeriod = Integer -> TimeDiff
Time.seconds Integer
60

maxChecks :: Int
maxChecks :: Int
maxChecks = Int
2

checkNodes :: forall m. DhtNodeMonad m => WriterT [RequestInfo] m ()
checkNodes :: WriterT [RequestInfo] m ()
checkNodes = (DhtState -> WriterT [RequestInfo] m DhtState)
-> WriterT [RequestInfo] m ()
forall s (m :: * -> *). MonadState s m => (s -> m s) -> m ()
modifyM ((DhtState -> WriterT [RequestInfo] m DhtState)
 -> WriterT [RequestInfo] m ())
-> (DhtState -> WriterT [RequestInfo] m DhtState)
-> WriterT [RequestInfo] m ()
forall a b. (a -> b) -> a -> b
$ (ClientList -> WriterT [RequestInfo] m ClientList)
-> DhtState -> WriterT [RequestInfo] m DhtState
forall (f :: * -> *).
Applicative f =>
(ClientList -> f ClientList) -> DhtState -> f DhtState
DhtState.traverseClientLists ClientList -> WriterT [RequestInfo] m ClientList
checkNodes'
  where
    checkNodes' :: ClientList -> WriterT [RequestInfo] m ClientList
    checkNodes' :: ClientList -> WriterT [RequestInfo] m ClientList
checkNodes' ClientList
clientList =
      (\ClientNodes
x -> ClientList
clientList{ nodes :: ClientNodes
ClientList.nodes = ClientNodes
x }) (ClientNodes -> ClientList)
-> WriterT [RequestInfo] m ClientNodes
-> WriterT [RequestInfo] m ClientList
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (ClientNode -> WriterT [RequestInfo] m (Maybe ClientNode))
-> ClientNodes -> WriterT [RequestInfo] m ClientNodes
forall (f :: * -> *) a b k.
Applicative f =>
(a -> f (Maybe b)) -> Map k a -> f (Map k b)
traverseMaybe ClientNode -> WriterT [RequestInfo] m (Maybe ClientNode)
checkNode (ClientList -> ClientNodes
ClientList.nodes ClientList
clientList)
      where
        traverseMaybe :: Applicative f =>
          (a -> f (Maybe b)) -> Map k a -> f (Map k b)
        traverseMaybe :: (a -> f (Maybe b)) -> Map k a -> f (Map k b)
traverseMaybe a -> f (Maybe b)
f = ((Maybe b -> Maybe b) -> Map k (Maybe b) -> Map k b
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Maybe b -> Maybe b
forall a. a -> a
id (Map k (Maybe b) -> Map k b) -> f (Map k (Maybe b)) -> f (Map k b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (f (Map k (Maybe b)) -> f (Map k b))
-> (Map k a -> f (Map k (Maybe b))) -> Map k a -> f (Map k b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f (Maybe b)) -> Map k a -> f (Map k (Maybe b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f (Maybe b)
f

        checkNode :: ClientNode -> WriterT [RequestInfo] m (Maybe ClientNode)
        checkNode :: ClientNode -> WriterT [RequestInfo] m (Maybe ClientNode)
checkNode ClientNode
clientNode = WriterT [RequestInfo] m Timestamp
forall (m :: * -> *). Timed m => m Timestamp
Timed.askTime WriterT [RequestInfo] m Timestamp
-> (Timestamp -> WriterT [RequestInfo] m (Maybe ClientNode))
-> WriterT [RequestInfo] m (Maybe ClientNode)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Timestamp
time ->
          if Timestamp
time Timestamp -> Timestamp -> TimeDiff
Time.- Timestamp
lastCheck TimeDiff -> TimeDiff -> Bool
forall a. Ord a => a -> a -> Bool
< TimeDiff
checkPeriod
          then Maybe ClientNode -> WriterT [RequestInfo] m (Maybe ClientNode)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ClientNode -> WriterT [RequestInfo] m (Maybe ClientNode))
-> Maybe ClientNode -> WriterT [RequestInfo] m (Maybe ClientNode)
forall a b. (a -> b) -> a -> b
$ ClientNode -> Maybe ClientNode
forall a. a -> Maybe a
Just ClientNode
clientNode
          else ([RequestInfo] -> WriterT [RequestInfo] m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [RequestInfo
requestInfo] WriterT [RequestInfo] m ()
-> Maybe ClientNode -> WriterT [RequestInfo] m (Maybe ClientNode)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>) (Maybe ClientNode -> WriterT [RequestInfo] m (Maybe ClientNode))
-> Maybe ClientNode -> WriterT [RequestInfo] m (Maybe ClientNode)
forall a b. (a -> b) -> a -> b
$
            if Int
checkCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxChecks
            then ClientNode -> Maybe ClientNode
forall a. a -> Maybe a
Just (ClientNode -> Maybe ClientNode) -> ClientNode -> Maybe ClientNode
forall a b. (a -> b) -> a -> b
$ ClientNode
clientNode
              { lastCheck :: Timestamp
ClientNode.lastCheck = Timestamp
time
              , checkCount :: Int
ClientNode.checkCount = Int
checkCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
              }
            else Maybe ClientNode
forall a. Maybe a
Nothing
          where
            nodeInfo :: NodeInfo
nodeInfo = ClientNode -> NodeInfo
ClientNode.nodeInfo ClientNode
clientNode
            lastCheck :: Timestamp
lastCheck = ClientNode -> Timestamp
ClientNode.lastCheck ClientNode
clientNode
            checkCount :: Int
checkCount = ClientNode -> Int
ClientNode.checkCount ClientNode
clientNode
            requestInfo :: RequestInfo
requestInfo = NodeInfo -> PublicKey -> RequestInfo
RequestInfo NodeInfo
nodeInfo (PublicKey -> RequestInfo) -> PublicKey -> RequestInfo
forall a b. (a -> b) -> a -> b
$ ClientList -> PublicKey
forall l. NodeList l => l -> PublicKey
NodeList.baseKey ClientList
clientList

doDHT :: DhtNodeMonad m => m ()
doDHT :: m ()
doDHT =
  WriterT [RequestInfo] m () -> m [RequestInfo]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT [RequestInfo] m ()
forall (m :: * -> *). DhtNodeMonad m => WriterT [RequestInfo] m ()
randomRequests WriterT [RequestInfo] m ()
-> WriterT [RequestInfo] m () -> WriterT [RequestInfo] m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriterT [RequestInfo] m ()
forall (m :: * -> *). DhtNodeMonad m => WriterT [RequestInfo] m ()
checkNodes) m [RequestInfo] -> ([RequestInfo] -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (RequestInfo -> m ()) -> [RequestInfo] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RequestInfo -> m ()
forall (m :: * -> *). DhtNodeMonad m => RequestInfo -> m ()
sendNodesRequest


\end{code}

\subsection{Handling Nodes Response packets}
When we receive a valid Nodes Response packet, we first check that it is a reply
to a Nodes Request which we sent within the last 60 seconds to the node from
which we received the response, and that no previous reply has been received. If
this check fails, the packet is ignored. If the check succeeds, first we add to
the DHT State the node from which the response was sent. Then, for each node
listed in the response and for each Nodes List in the DHT State which does not
currently contain the node and to which the node is viable for entry, we send a
Nodes Request to the node with the requested public key being the base key of
the Nodes List.

An implementation may choose not to send every such Nodes Request.
(c-toxcore only sends so many per list (8 for the Close List, 4 for a Search
Entry) per 50ms, prioritising the closest to the base key).

\begin{code}

requireNodesResponseWithin :: TimeDiff
requireNodesResponseWithin :: TimeDiff
requireNodesResponseWithin = Integer -> TimeDiff
Time.seconds Integer
60

handleNodesResponse ::
  DhtNodeMonad m => NodeInfo -> RpcPacket NodesResponse -> m ()
handleNodesResponse :: NodeInfo -> RpcPacket NodesResponse -> m ()
handleNodesResponse NodeInfo
from (RpcPacket (NodesResponse [NodeInfo]
nodes) RequestId
requestId) = do
  Bool
isReply <- TimeDiff -> NodeInfo -> RequestId -> m Bool
forall (m :: * -> *).
DhtNodeMonad m =>
TimeDiff -> NodeInfo -> RequestId -> m Bool
checkPending TimeDiff
requireNodesResponseWithin NodeInfo
from RequestId
requestId
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isReply (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Timestamp
time <- m Timestamp
forall (m :: * -> *). Timed m => m Timestamp
Timed.askTime
    (DhtState -> DhtState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((DhtState -> DhtState) -> m ()) -> (DhtState -> DhtState) -> m ()
forall a b. (a -> b) -> a -> b
$ Timestamp -> NodeInfo -> DhtState -> DhtState
DhtState.addNode Timestamp
time NodeInfo
from
    [NodeInfo] -> (NodeInfo -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [NodeInfo]
nodes ((NodeInfo -> m ()) -> m ()) -> (NodeInfo -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \NodeInfo
node ->
      (m [RequestInfo] -> ([RequestInfo] -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (RequestInfo -> m ()) -> [RequestInfo] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RequestInfo -> m ()
forall (m :: * -> *). DhtNodeMonad m => RequestInfo -> m ()
sendNodesRequest) (m [RequestInfo] -> m ()) -> m [RequestInfo] -> m ()
forall a b. (a -> b) -> a -> b
$ ((DhtState -> [RequestInfo]) -> m DhtState -> m [RequestInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m DhtState
forall s (m :: * -> *). MonadState s m => m s
get) ((DhtState -> [RequestInfo]) -> m [RequestInfo])
-> (DhtState -> [RequestInfo]) -> m [RequestInfo]
forall a b. (a -> b) -> a -> b
$ (forall l. NodeList l => l -> [RequestInfo])
-> DhtState -> [RequestInfo]
forall m.
Monoid m =>
(forall l. NodeList l => l -> m) -> DhtState -> m
DhtState.foldMapNodeLists ((forall l. NodeList l => l -> [RequestInfo])
 -> DhtState -> [RequestInfo])
-> (forall l. NodeList l => l -> [RequestInfo])
-> DhtState
-> [RequestInfo]
forall a b. (a -> b) -> a -> b
$
        \l
nodeList ->
          Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Maybe NodeInfo -> Bool
forall a. Maybe a -> Bool
isNothing (PublicKey -> l -> Maybe NodeInfo
forall l. NodeList l => PublicKey -> l -> Maybe NodeInfo
NodeList.lookupPublicKey
              (NodeInfo -> PublicKey
NodeInfo.publicKey NodeInfo
node) l
nodeList)
            Bool -> Bool -> Bool
&& NodeInfo -> l -> Bool
forall l. NodeList l => NodeInfo -> l -> Bool
NodeList.viable NodeInfo
node l
nodeList) [()] -> [RequestInfo] -> [RequestInfo]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
          [ NodeInfo -> PublicKey -> RequestInfo
RequestInfo NodeInfo
node (PublicKey -> RequestInfo) -> PublicKey -> RequestInfo
forall a b. (a -> b) -> a -> b
$ l -> PublicKey
forall l. NodeList l => l -> PublicKey
NodeList.baseKey l
nodeList ]

\end{code}

\subsection{Handling Nodes Request packets}
When we receive a Nodes Request packet from another node, we reply with a Nodes
Response packet containing the 4 nodes in the DHT State which are the closest to
the public key in the packet. If there are fewer than 4 nodes in the state, we
reply with all the nodes in the state. If there are no nodes in the state, no
reply is sent.

We also send a Ping Request when this is appropriate; see below.

\begin{code}

responseMaxNodes :: Int
responseMaxNodes :: Int
responseMaxNodes = Int
4

handleNodesRequest ::
  DhtNodeMonad m => NodeInfo -> RpcPacket NodesRequest -> m ()
handleNodesRequest :: NodeInfo -> RpcPacket NodesRequest -> m ()
handleNodesRequest NodeInfo
from (RpcPacket (NodesRequest PublicKey
key) RequestId
requestId) = do
  PublicKey
ourPublicKey <- (DhtState -> PublicKey) -> m PublicKey
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((DhtState -> PublicKey) -> m PublicKey)
-> (DhtState -> PublicKey) -> m PublicKey
forall a b. (a -> b) -> a -> b
$ KeyPair -> PublicKey
KeyPair.publicKey (KeyPair -> PublicKey)
-> (DhtState -> KeyPair) -> DhtState -> PublicKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DhtState -> KeyPair
DhtState.dhtKeyPair
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PublicKey
ourPublicKey PublicKey -> PublicKey -> Bool
forall a. Eq a => a -> a -> Bool
/= NodeInfo -> PublicKey
NodeInfo.publicKey NodeInfo
from) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    [NodeInfo]
nodes <- (DhtState -> [NodeInfo]) -> m [NodeInfo]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Int -> PublicKey -> DhtState -> [NodeInfo]
DhtState.takeClosestNodesTo Int
responseMaxNodes PublicKey
key)
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([NodeInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeInfo]
nodes) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> RequestId -> [NodeInfo] -> m ()
forall (m :: * -> *).
DhtNodeMonad m =>
NodeInfo -> RequestId -> [NodeInfo] -> m ()
sendNodesResponse NodeInfo
from RequestId
requestId [NodeInfo]
nodes
    NodeInfo -> m ()
forall (m :: * -> *). DhtNodeMonad m => NodeInfo -> m ()
sendPingRequestIfAppropriate NodeInfo
from

\end{code}

\subsection{Handling Ping Request packets}
When a valid Ping Request packet is received, we reply with a Ping Response.

We also send a Ping Request when this is appropriate; see below.

\begin{code}

handlePingRequest ::
  DhtNodeMonad m => NodeInfo -> RpcPacket PingPacket -> m ()
handlePingRequest :: NodeInfo -> RpcPacket PingPacket -> m ()
handlePingRequest NodeInfo
from (RpcPacket PingPacket
PingRequest RequestId
requestId) = do
  NodeInfo -> RequestId -> m ()
forall (m :: * -> *).
DhtNodeMonad m =>
NodeInfo -> RequestId -> m ()
sendPingResponse NodeInfo
from RequestId
requestId
  NodeInfo -> m ()
forall (m :: * -> *). DhtNodeMonad m => NodeInfo -> m ()
sendPingRequestIfAppropriate NodeInfo
from
handlePingRequest NodeInfo
_ RpcPacket PingPacket
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

\end{code}

\subsection{Handling Ping Response packets}
When we receive a valid Ping Response packet, we first check that it is a reply
to a Ping Request which we sent within the last 5 seconds to the node from
which we received the response, and that no previous reply has been received. If
this check fails, the packet is ignored. If the check succeeds, we add to the
DHT State the node from which the response was sent.

\begin{code}

requirePingResponseWithin :: TimeDiff
requirePingResponseWithin :: TimeDiff
requirePingResponseWithin = Integer -> TimeDiff
Time.seconds Integer
5

maxPendingTime :: TimeDiff
maxPendingTime :: TimeDiff
maxPendingTime = [TimeDiff] -> TimeDiff
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum
  [ TimeDiff
requireNodesResponseWithin
  , TimeDiff
requirePingResponseWithin
  ]

checkPending :: DhtNodeMonad m =>
  TimeDiff -> NodeInfo -> RpcPacket.RequestId -> m Bool
checkPending :: TimeDiff -> NodeInfo -> RequestId -> m Bool
checkPending TimeDiff
timeLimit NodeInfo
from RequestId
requestId = do
  Timestamp
oldTime <- (Timestamp -> TimeDiff -> Timestamp
Time.+ TimeDiff -> TimeDiff
forall a. Num a => a -> a
negate TimeDiff
maxPendingTime) (Timestamp -> Timestamp) -> m Timestamp -> m Timestamp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Timestamp
forall (m :: * -> *). Timed m => m Timestamp
Timed.askTime
  Lens' DhtState PendingReplies
forall (f :: * -> *).
Identical f =>
LensLike' f DhtState PendingReplies
DhtState._dhtPendingReplies (forall (f :: * -> *).
 Identical f =>
 LensLike' f DhtState PendingReplies)
-> (PendingReplies -> PendingReplies) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
Setter s s a b -> (a -> b) -> m ()
%= Timestamp -> PendingReplies -> PendingReplies
forall a. Timestamp -> Stamped a -> Stamped a
Stamped.dropOlder Timestamp
oldTime
  Timestamp
recentCutoff <- (Timestamp -> TimeDiff -> Timestamp
Time.+ TimeDiff -> TimeDiff
forall a. Num a => a -> a
negate TimeDiff
timeLimit) (Timestamp -> Timestamp) -> m Timestamp -> m Timestamp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Timestamp
forall (m :: * -> *). Timed m => m Timestamp
Timed.askTime
  LensLike' (WriterT Bool Identity) DhtState PendingReplies
Lens' DhtState PendingReplies
DhtState._dhtPendingReplies LensLike' (WriterT Bool Identity) DhtState PendingReplies
-> (PendingReplies -> (Bool, PendingReplies)) -> m Bool
forall s (m :: * -> *) c a b.
MonadState s m =>
LensLike (Writer c) s s a b -> (a -> (c, b)) -> m c
%%=
    Timestamp
-> NodeInfo
-> RequestId
-> PendingReplies
-> (Bool, PendingReplies)
PendingReplies.checkExpectedReply Timestamp
recentCutoff NodeInfo
from RequestId
requestId

handlePingResponse ::
  DhtNodeMonad m => NodeInfo -> RpcPacket PingPacket -> m ()
handlePingResponse :: NodeInfo -> RpcPacket PingPacket -> m ()
handlePingResponse NodeInfo
from (RpcPacket PingPacket
PingResponse RequestId
requestId) = do
  Bool
isReply <- TimeDiff -> NodeInfo -> RequestId -> m Bool
forall (m :: * -> *).
DhtNodeMonad m =>
TimeDiff -> NodeInfo -> RequestId -> m Bool
checkPending TimeDiff
requirePingResponseWithin NodeInfo
from RequestId
requestId
  PublicKey
ourPublicKey <- (DhtState -> PublicKey) -> m PublicKey
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((DhtState -> PublicKey) -> m PublicKey)
-> (DhtState -> PublicKey) -> m PublicKey
forall a b. (a -> b) -> a -> b
$ KeyPair -> PublicKey
KeyPair.publicKey (KeyPair -> PublicKey)
-> (DhtState -> KeyPair) -> DhtState -> PublicKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DhtState -> KeyPair
DhtState.dhtKeyPair
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isReply Bool -> Bool -> Bool
&& PublicKey
ourPublicKey PublicKey -> PublicKey -> Bool
forall a. Eq a => a -> a -> Bool
/= NodeInfo -> PublicKey
NodeInfo.publicKey NodeInfo
from) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Timestamp
time <- m Timestamp
forall (m :: * -> *). Timed m => m Timestamp
Timed.askTime
    (DhtState -> DhtState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((DhtState -> DhtState) -> m ()) -> (DhtState -> DhtState) -> m ()
forall a b. (a -> b) -> a -> b
$ Timestamp -> NodeInfo -> DhtState -> DhtState
DhtState.addNode Timestamp
time NodeInfo
from
handlePingResponse NodeInfo
_ RpcPacket PingPacket
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

\end{code}

\subsection{Sending Ping Requests}
When we receive a Nodes Request or a Ping Request, in addition to the handling
described above, we sometimes send a Ping Request.
Namely, we send a Ping Request to the node which sent the packet if the node is
viable for entry to the Close List and is not already in the Close List.
An implementation may (TODO: should?) choose not to send every such Ping
Request.
(c-toxcore sends at most 32 every 2 seconds, preferring closer nodes.)

\begin{code}

sendPingRequestIfAppropriate :: DhtNodeMonad m => NodeInfo -> m ()
sendPingRequestIfAppropriate :: NodeInfo -> m ()
sendPingRequestIfAppropriate NodeInfo
from = do
  KBuckets
closeList <- (DhtState -> KBuckets) -> m KBuckets
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DhtState -> KBuckets
DhtState.dhtCloseList
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Maybe NodeInfo -> Bool
forall a. Maybe a -> Bool
isNothing (PublicKey -> KBuckets -> Maybe NodeInfo
forall l. NodeList l => PublicKey -> l -> Maybe NodeInfo
NodeList.lookupPublicKey (NodeInfo -> PublicKey
NodeInfo.publicKey NodeInfo
from) KBuckets
closeList)
      Bool -> Bool -> Bool
&& NodeInfo -> KBuckets -> Bool
forall l. NodeList l => NodeInfo -> l -> Bool
NodeList.viable NodeInfo
from KBuckets
closeList) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    NodeInfo -> m ()
forall (m :: * -> *). DhtNodeMonad m => NodeInfo -> m ()
sendPingRequest NodeInfo
from

\end{code}

\input{src/Network/Tox/DHT/DhtRequestPacket.lhs}
\subsection{Handling DHT Request packets}

A DHT node that receives a DHT request packet checks whether the addressee
public key is their DHT public key. If it is, they will decrypt and handle
the packet.  Otherwise, they will check whether the addressee DHT public key
is the DHT public key of one of the nodes in their Close List.  If it isn't,
they will drop the packet.  If it is they will resend the packet, unaltered, to
that DHT node.

DHT request packets are used for DHT public key packets (see
\href{#onion}{onion}) and NAT ping packets.

\begin{code}

handleDhtRequestPacket :: DhtNodeMonad m => NodeInfo -> DhtRequestPacket -> m ()
handleDhtRequestPacket :: NodeInfo -> DhtRequestPacket -> m ()
handleDhtRequestPacket NodeInfo
_from packet :: DhtRequestPacket
packet@DhtRequestPacket{ PublicKey
addresseePublicKey :: DhtRequestPacket -> PublicKey
addresseePublicKey :: PublicKey
addresseePublicKey, DhtPacket
dhtPacket :: DhtRequestPacket -> DhtPacket
dhtPacket :: DhtPacket
dhtPacket } = do
  KeyPair
keyPair <- (DhtState -> KeyPair) -> m KeyPair
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DhtState -> KeyPair
DhtState.dhtKeyPair
  if PublicKey
addresseePublicKey PublicKey -> PublicKey -> Bool
forall a. Eq a => a -> a -> Bool
== KeyPair -> PublicKey
KeyPair.publicKey KeyPair
keyPair
  then m (Maybe ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe ()) -> m ())
-> (MaybeT m () -> m (Maybe ())) -> MaybeT m () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT m () -> m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m () -> m ()) -> MaybeT m () -> m ()
forall a b. (a -> b) -> a -> b
$ [MaybeT m ()] -> MaybeT m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
    [ m (Maybe ()) -> MaybeT m ()
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (KeyPair -> DhtPacket -> m (Maybe ())
forall payload (m :: * -> *).
(Binary payload, Keyed m) =>
KeyPair -> DhtPacket -> m (Maybe payload)
DhtPacket.decodeKeyed KeyPair
keyPair DhtPacket
dhtPacket) MaybeT m () -> (() -> MaybeT m ()) -> MaybeT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m () -> MaybeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> MaybeT m ()) -> (() -> m ()) -> () -> MaybeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> m ()
forall (m :: * -> *). DhtNodeMonad m => () -> m ()
handleNatPingPacket
    , m (Maybe ()) -> MaybeT m ()
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (KeyPair -> DhtPacket -> m (Maybe ())
forall payload (m :: * -> *).
(Binary payload, Keyed m) =>
KeyPair -> DhtPacket -> m (Maybe payload)
DhtPacket.decodeKeyed KeyPair
keyPair DhtPacket
dhtPacket) MaybeT m () -> (() -> MaybeT m ()) -> MaybeT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m () -> MaybeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> MaybeT m ()) -> (() -> m ()) -> () -> MaybeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> m ()
forall (m :: * -> *). DhtNodeMonad m => () -> m ()
handleDhtPKPacket
    ]
  else m (Maybe ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe ()) -> m ())
-> (MaybeT m () -> m (Maybe ())) -> MaybeT m () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT m () -> m (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m () -> m ()) -> MaybeT m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    NodeInfo
node :: NodeInfo <- m (Maybe NodeInfo) -> MaybeT m NodeInfo
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe NodeInfo) -> MaybeT m NodeInfo)
-> m (Maybe NodeInfo) -> MaybeT m NodeInfo
forall a b. (a -> b) -> a -> b
$
      PublicKey -> KBuckets -> Maybe NodeInfo
forall l. NodeList l => PublicKey -> l -> Maybe NodeInfo
NodeList.lookupPublicKey PublicKey
addresseePublicKey (KBuckets -> Maybe NodeInfo) -> m KBuckets -> m (Maybe NodeInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DhtState -> KBuckets) -> m KBuckets
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DhtState -> KBuckets
DhtState.dhtCloseList
    m () -> MaybeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> MaybeT m ())
-> (DhtRequestPacket -> m ()) -> DhtRequestPacket -> MaybeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo -> Packet DhtRequestPacket -> m ()
forall (m :: * -> *) payload.
(Networked m, Binary payload, Show payload) =>
NodeInfo -> Packet payload -> m ()
Networked.sendPacket NodeInfo
node (Packet DhtRequestPacket -> m ())
-> (DhtRequestPacket -> Packet DhtRequestPacket)
-> DhtRequestPacket
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PacketKind -> DhtRequestPacket -> Packet DhtRequestPacket
forall payload. PacketKind -> payload -> Packet payload
Packet PacketKind
PacketKind.Crypto (DhtRequestPacket -> MaybeT m ())
-> DhtRequestPacket -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ DhtRequestPacket
packet

\end{code}

\subsection{NAT ping packets}

A NAT ping packet is sent as the payload of a DHT request packet.

We use NAT ping packets to see if a friend we are not connected to directly is
online and ready to do the hole punching.

\subsubsection{NAT ping request}

\begin{tabular}{l|l}
  Length             & Contents \\
  \hline
  \texttt{1}         & \texttt{uint8\_t} (0xfe) \\
  \texttt{1}         & \texttt{uint8\_t} (0x00) \\
  \texttt{8}         & \texttt{uint64\_t} random number \\
\end{tabular}

\subsubsection{NAT ping response}

\begin{tabular}{l|l}
  Length             & Contents \\
  \hline
  \texttt{1}         & \texttt{uint8\_t} (0xfe) \\
  \texttt{1}         & \texttt{uint8\_t} (0x01) \\
  \texttt{8}         & \texttt{uint64\_t} random number (the same that was received in request) \\
\end{tabular}

TODO: handling these packets.

\begin{code}

-- | TODO
type NatPingPacket = ()
handleNatPingPacket :: DhtNodeMonad m => NatPingPacket -> m ()
handleNatPingPacket :: () -> m ()
handleNatPingPacket ()
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | TODO
type DhtPKPacket = ()
handleDhtPKPacket :: DhtNodeMonad m => DhtPKPacket -> m ()
handleDhtPKPacket :: () -> m ()
handleDhtPKPacket ()
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

\end{code}

\subsection{Effects of chosen constants on performance}
If the bucket size of the k-buckets were increased, it would increase the
amount of packets needed to check if each node is still alive, which would
increase the bandwidth usage, but reliability would go up.  If the number of
nodes were decreased, reliability would go down along with bandwidth usage.
The reason for this relationship between reliability and number of nodes is
that if we assume that not every node has its UDP ports open or is behind a
cone NAT it means that each of these nodes must be able to store a certain
number of nodes behind restrictive NATs in order for others to be able to find
those nodes behind restrictive NATs.  For example if 7/8 nodes were behind
restrictive NATs, using 8 nodes would not be enough because the chances of
some of these nodes being impossible to find in the network would be too high.

TODO(zugz): this seems a rather wasteful solution to this problem.

If the ping timeouts and delays between pings were higher it would decrease the
bandwidth usage but increase the amount of disconnected nodes that are still
being stored in the lists.  Decreasing these delays would do the opposite.

If the maximum size 8 of the DHT Search Entry Client Lists were increased
would increase the bandwidth usage, might increase hole punching efficiency on
symmetric NATs (more ports to guess from, see Hole punching) and might increase
the reliability.  Lowering this number would have the opposite effect.

The timeouts and number of nodes in lists for toxcore were picked by feeling
alone and are probably not the best values.  This also applies to the behavior
which is simple and should be improved in order to make the network resist
better to sybil attacks.

TODO: consider giving min and max values for the constants.

\begin{code}

{-------------------------------------------------------------------------------
 -
 - :: Tests.
 -
 ------------------------------------------------------------------------------}

type TestDhtNodeMonad = KeyedT (TimedT (RandT StdGen (StateT DhtState (Networked.NetworkLogged Identity))))
instance DhtNodeMonad TestDhtNodeMonad

runTestDhtNode :: ArbStdGen -> Timestamp -> DhtState -> TestDhtNodeMonad a -> (a, DhtState)
runTestDhtNode :: ArbStdGen
-> Timestamp -> DhtState -> TestDhtNodeMonad a -> (a, DhtState)
runTestDhtNode ArbStdGen
seed Timestamp
time DhtState
s =
  Identity (a, DhtState) -> (a, DhtState)
forall a. Identity a -> a
runIdentity
    (Identity (a, DhtState) -> (a, DhtState))
-> (TestDhtNodeMonad a -> Identity (a, DhtState))
-> TestDhtNodeMonad a
-> (a, DhtState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkLogged Identity (a, DhtState) -> Identity (a, DhtState)
forall (m :: * -> *) a.
(Monad m, Applicative m) =>
NetworkLogged m a -> m a
Networked.evalNetworkLogged
    (NetworkLogged Identity (a, DhtState) -> Identity (a, DhtState))
-> (TestDhtNodeMonad a -> NetworkLogged Identity (a, DhtState))
-> TestDhtNodeMonad a
-> Identity (a, DhtState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT DhtState (NetworkLogged Identity) a
-> DhtState -> NetworkLogged Identity (a, DhtState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
`runStateT` DhtState
s)
    (StateT DhtState (NetworkLogged Identity) a
 -> NetworkLogged Identity (a, DhtState))
-> (TestDhtNodeMonad a
    -> StateT DhtState (NetworkLogged Identity) a)
-> TestDhtNodeMonad a
-> NetworkLogged Identity (a, DhtState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RandT StdGen (StateT DhtState (NetworkLogged Identity)) a
-> StdGen -> StateT DhtState (NetworkLogged Identity) a
forall (m :: * -> *) g a. Monad m => RandT g m a -> g -> m a
`evalRandT` ArbStdGen -> StdGen
unwrapArbStdGen ArbStdGen
seed)
    (RandT StdGen (StateT DhtState (NetworkLogged Identity)) a
 -> StateT DhtState (NetworkLogged Identity) a)
-> (TestDhtNodeMonad a
    -> RandT StdGen (StateT DhtState (NetworkLogged Identity)) a)
-> TestDhtNodeMonad a
-> StateT DhtState (NetworkLogged Identity) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimedT (RandT StdGen (StateT DhtState (NetworkLogged Identity))) a
-> Timestamp
-> RandT StdGen (StateT DhtState (NetworkLogged Identity)) a
forall (m :: * -> *) a. TimedT m a -> Timestamp -> m a
`TimedT.runTimedT` Timestamp
time)
    (TimedT (RandT StdGen (StateT DhtState (NetworkLogged Identity))) a
 -> RandT StdGen (StateT DhtState (NetworkLogged Identity)) a)
-> (TestDhtNodeMonad a
    -> TimedT
         (RandT StdGen (StateT DhtState (NetworkLogged Identity))) a)
-> TestDhtNodeMonad a
-> RandT StdGen (StateT DhtState (NetworkLogged Identity)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestDhtNodeMonad a
-> KeyRing
-> TimedT
     (RandT StdGen (StateT DhtState (NetworkLogged Identity))) a
forall (m :: * -> *) a. Monad m => KeyedT m a -> KeyRing -> m a
`KeyedT.evalKeyedT` KeyRing
forall k a. Map k a
Map.empty)

evalTestDhtNode :: ArbStdGen -> Timestamp -> DhtState -> TestDhtNodeMonad a -> a
evalTestDhtNode :: ArbStdGen -> Timestamp -> DhtState -> TestDhtNodeMonad a -> a
evalTestDhtNode ArbStdGen
seed Timestamp
time DhtState
s = (a, DhtState) -> a
forall a b. (a, b) -> a
fst ((a, DhtState) -> a)
-> (TestDhtNodeMonad a -> (a, DhtState)) -> TestDhtNodeMonad a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArbStdGen
-> Timestamp -> DhtState -> TestDhtNodeMonad a -> (a, DhtState)
forall a.
ArbStdGen
-> Timestamp -> DhtState -> TestDhtNodeMonad a -> (a, DhtState)
runTestDhtNode ArbStdGen
seed Timestamp
time DhtState
s
execTestDhtNode :: ArbStdGen -> Timestamp -> DhtState -> TestDhtNodeMonad a -> DhtState
execTestDhtNode :: ArbStdGen
-> Timestamp -> DhtState -> TestDhtNodeMonad a -> DhtState
execTestDhtNode ArbStdGen
seed Timestamp
time DhtState
s = (a, DhtState) -> DhtState
forall a b. (a, b) -> b
snd ((a, DhtState) -> DhtState)
-> (TestDhtNodeMonad a -> (a, DhtState))
-> TestDhtNodeMonad a
-> DhtState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArbStdGen
-> Timestamp -> DhtState -> TestDhtNodeMonad a -> (a, DhtState)
forall a.
ArbStdGen
-> Timestamp -> DhtState -> TestDhtNodeMonad a -> (a, DhtState)
runTestDhtNode ArbStdGen
seed Timestamp
time DhtState
s

initTestDhtState :: ArbStdGen -> Timestamp -> DhtState
initTestDhtState :: ArbStdGen -> Timestamp -> DhtState
initTestDhtState ArbStdGen
seed Timestamp
time =
  Identity DhtState -> DhtState
forall a. Identity a -> a
runIdentity
    (Identity DhtState -> DhtState)
-> (TimedT (RandT StdGen Identity) DhtState -> Identity DhtState)
-> TimedT (RandT StdGen Identity) DhtState
-> DhtState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RandT StdGen Identity DhtState -> StdGen -> Identity DhtState
forall (m :: * -> *) g a. Monad m => RandT g m a -> g -> m a
`evalRandT` ArbStdGen -> StdGen
unwrapArbStdGen ArbStdGen
seed)
    (RandT StdGen Identity DhtState -> Identity DhtState)
-> (TimedT (RandT StdGen Identity) DhtState
    -> RandT StdGen Identity DhtState)
-> TimedT (RandT StdGen Identity) DhtState
-> Identity DhtState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimedT (RandT StdGen Identity) DhtState
-> Timestamp -> RandT StdGen Identity DhtState
forall (m :: * -> *) a. TimedT m a -> Timestamp -> m a
`TimedT.runTimedT` Timestamp
time)
    (TimedT (RandT StdGen Identity) DhtState -> DhtState)
-> TimedT (RandT StdGen Identity) DhtState -> DhtState
forall a b. (a -> b) -> a -> b
$ TimedT (RandT StdGen Identity) DhtState
forall (m :: * -> *). (MonadRandomBytes m, Timed m) => m DhtState
initDht

-- | wrap StdGen so the Arbitrary instance isn't an orphan
newtype ArbStdGen = ArbStdGen { ArbStdGen -> StdGen
unwrapArbStdGen :: StdGen }
  deriving (Int -> ArbStdGen -> ShowS
[ArbStdGen] -> ShowS
ArbStdGen -> String
(Int -> ArbStdGen -> ShowS)
-> (ArbStdGen -> String)
-> ([ArbStdGen] -> ShowS)
-> Show ArbStdGen
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArbStdGen] -> ShowS
$cshowList :: [ArbStdGen] -> ShowS
show :: ArbStdGen -> String
$cshow :: ArbStdGen -> String
showsPrec :: Int -> ArbStdGen -> ShowS
$cshowsPrec :: Int -> ArbStdGen -> ShowS
Show)

instance Arbitrary ArbStdGen
  where arbitrary :: Gen ArbStdGen
arbitrary = StdGen -> ArbStdGen
ArbStdGen (StdGen -> ArbStdGen) -> (Int -> StdGen) -> Int -> ArbStdGen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> StdGen
mkStdGen (Int -> ArbStdGen) -> Gen Int -> Gen ArbStdGen
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary

\end{code}