{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE UndecidableInstances       #-}
module Tox.Conduit.DHT where

import           Control.Monad                    (forever)
import           Control.Monad.IO.Class           (MonadIO)
import           Control.Monad.State              (MonadState (..))
import           Control.Monad.Trans              (MonadTrans, lift)
import           Data.Binary                      (Binary)
import qualified Data.ByteString                  as BS
import           Data.Conduit                     (ConduitT, await, yield)

import           Tox.Core.Timed                   (Timed (..))
import           Tox.Crypto.Core.Keyed            (Keyed (..))
import           Tox.Crypto.Core.MonadRandomBytes (MonadRandomBytes (..))
import           Tox.DHT.DhtState                 (DhtState)
import           Tox.DHT.Node                     (handleBootstrap,
                                                   handleIncomingPacket,
                                                   handleMaintenance)
import           Tox.DHT.Operation                (DhtNodeMonad)
import qualified Tox.Network.Core.Encoding        as Encoding
import           Tox.Network.Core.Networked       (Networked (..))
import           Tox.Network.Core.NodeInfo        (NodeInfo)
import           Tox.Network.Core.Packet          (Packet (..))

-- | A wrapper around 'ConduitT' to provide the necessary instances for DHT logic
-- without requiring orphan instances.
newtype DhtConduit i o m a = DhtConduit { DhtConduit i o m a -> ConduitT i o m a
unDhtConduit :: ConduitT i o m a }
    deriving (a -> DhtConduit i o m b -> DhtConduit i o m a
(a -> b) -> DhtConduit i o m a -> DhtConduit i o m b
(forall a b. (a -> b) -> DhtConduit i o m a -> DhtConduit i o m b)
-> (forall a b. a -> DhtConduit i o m b -> DhtConduit i o m a)
-> Functor (DhtConduit i o m)
forall a b. a -> DhtConduit i o m b -> DhtConduit i o m a
forall a b. (a -> b) -> DhtConduit i o m a -> DhtConduit i o m b
forall i o (m :: * -> *) a b.
a -> DhtConduit i o m b -> DhtConduit i o m a
forall i o (m :: * -> *) a b.
(a -> b) -> DhtConduit i o m a -> DhtConduit i o m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> DhtConduit i o m b -> DhtConduit i o m a
$c<$ :: forall i o (m :: * -> *) a b.
a -> DhtConduit i o m b -> DhtConduit i o m a
fmap :: (a -> b) -> DhtConduit i o m a -> DhtConduit i o m b
$cfmap :: forall i o (m :: * -> *) a b.
(a -> b) -> DhtConduit i o m a -> DhtConduit i o m b
Functor, Functor (DhtConduit i o m)
a -> DhtConduit i o m a
Functor (DhtConduit i o m)
-> (forall a. a -> DhtConduit i o m a)
-> (forall a b.
    DhtConduit i o m (a -> b)
    -> DhtConduit i o m a -> DhtConduit i o m b)
-> (forall a b c.
    (a -> b -> c)
    -> DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m c)
-> (forall a b.
    DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m b)
-> (forall a b.
    DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m a)
-> Applicative (DhtConduit i o m)
DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m b
DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m a
DhtConduit i o m (a -> b)
-> DhtConduit i o m a -> DhtConduit i o m b
(a -> b -> c)
-> DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m c
forall a. a -> DhtConduit i o m a
forall a b.
DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m a
forall a b.
DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m b
forall a b.
DhtConduit i o m (a -> b)
-> DhtConduit i o m a -> DhtConduit i o m b
forall a b c.
(a -> b -> c)
-> DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m c
forall i o (m :: * -> *). Functor (DhtConduit i o m)
forall i o (m :: * -> *) a. a -> DhtConduit i o m a
forall i o (m :: * -> *) a b.
DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m a
forall i o (m :: * -> *) a b.
DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m b
forall i o (m :: * -> *) a b.
DhtConduit i o m (a -> b)
-> DhtConduit i o m a -> DhtConduit i o m b
forall i o (m :: * -> *) a b c.
(a -> b -> c)
-> DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m a
$c<* :: forall i o (m :: * -> *) a b.
DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m a
*> :: DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m b
$c*> :: forall i o (m :: * -> *) a b.
DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m b
liftA2 :: (a -> b -> c)
-> DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m c
$cliftA2 :: forall i o (m :: * -> *) a b c.
(a -> b -> c)
-> DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m c
<*> :: DhtConduit i o m (a -> b)
-> DhtConduit i o m a -> DhtConduit i o m b
$c<*> :: forall i o (m :: * -> *) a b.
DhtConduit i o m (a -> b)
-> DhtConduit i o m a -> DhtConduit i o m b
pure :: a -> DhtConduit i o m a
$cpure :: forall i o (m :: * -> *) a. a -> DhtConduit i o m a
$cp1Applicative :: forall i o (m :: * -> *). Functor (DhtConduit i o m)
Applicative, Applicative (DhtConduit i o m)
a -> DhtConduit i o m a
Applicative (DhtConduit i o m)
-> (forall a b.
    DhtConduit i o m a
    -> (a -> DhtConduit i o m b) -> DhtConduit i o m b)
-> (forall a b.
    DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m b)
-> (forall a. a -> DhtConduit i o m a)
-> Monad (DhtConduit i o m)
DhtConduit i o m a
-> (a -> DhtConduit i o m b) -> DhtConduit i o m b
DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m b
forall a. a -> DhtConduit i o m a
forall a b.
DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m b
forall a b.
DhtConduit i o m a
-> (a -> DhtConduit i o m b) -> DhtConduit i o m b
forall i o (m :: * -> *). Applicative (DhtConduit i o m)
forall i o (m :: * -> *) a. a -> DhtConduit i o m a
forall i o (m :: * -> *) a b.
DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m b
forall i o (m :: * -> *) a b.
DhtConduit i o m a
-> (a -> DhtConduit i o m b) -> DhtConduit i o m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> DhtConduit i o m a
$creturn :: forall i o (m :: * -> *) a. a -> DhtConduit i o m a
>> :: DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m b
$c>> :: forall i o (m :: * -> *) a b.
DhtConduit i o m a -> DhtConduit i o m b -> DhtConduit i o m b
>>= :: DhtConduit i o m a
-> (a -> DhtConduit i o m b) -> DhtConduit i o m b
$c>>= :: forall i o (m :: * -> *) a b.
DhtConduit i o m a
-> (a -> DhtConduit i o m b) -> DhtConduit i o m b
$cp1Monad :: forall i o (m :: * -> *). Applicative (DhtConduit i o m)
Monad, Monad (DhtConduit i o m)
Monad (DhtConduit i o m)
-> (forall a. IO a -> DhtConduit i o m a)
-> MonadIO (DhtConduit i o m)
IO a -> DhtConduit i o m a
forall a. IO a -> DhtConduit i o m a
forall i o (m :: * -> *). MonadIO m => Monad (DhtConduit i o m)
forall i o (m :: * -> *) a. MonadIO m => IO a -> DhtConduit i o m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> DhtConduit i o m a
$cliftIO :: forall i o (m :: * -> *) a. MonadIO m => IO a -> DhtConduit i o m a
$cp1MonadIO :: forall i o (m :: * -> *). MonadIO m => Monad (DhtConduit i o m)
MonadIO, m a -> DhtConduit i o m a
(forall (m :: * -> *) a. Monad m => m a -> DhtConduit i o m a)
-> MonadTrans (DhtConduit i o)
forall i o (m :: * -> *) a. Monad m => m a -> DhtConduit i o m a
forall (m :: * -> *) a. Monad m => m a -> DhtConduit i o m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> DhtConduit i o m a
$clift :: forall i o (m :: * -> *) a. Monad m => m a -> DhtConduit i o m a
MonadTrans, MonadState s)

instance Timed m => Timed (DhtConduit i o m) where
    askTime :: DhtConduit i o m Timestamp
askTime = m Timestamp -> DhtConduit i o m Timestamp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Timestamp
forall (m :: * -> *). Timed m => m Timestamp
askTime

instance MonadRandomBytes m => MonadRandomBytes (DhtConduit i o m) where
    randomBytes :: Int -> DhtConduit i o m ByteString
randomBytes = m ByteString -> DhtConduit i o m ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ByteString -> DhtConduit i o m ByteString)
-> (Int -> m ByteString) -> Int -> DhtConduit i o m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m ByteString
forall (m :: * -> *). MonadRandomBytes m => Int -> m ByteString
randomBytes
    newKeyPair :: DhtConduit i o m KeyPair
newKeyPair = m KeyPair -> DhtConduit i o m KeyPair
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m KeyPair
forall (m :: * -> *). MonadRandomBytes m => m KeyPair
newKeyPair

instance Keyed m => Keyed (DhtConduit i o m) where
    getCombinedKey :: SecretKey -> PublicKey -> DhtConduit i o m CombinedKey
getCombinedKey SecretKey
sk PublicKey
pk = m CombinedKey -> DhtConduit i o m CombinedKey
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m CombinedKey -> DhtConduit i o m CombinedKey)
-> m CombinedKey -> DhtConduit i o m CombinedKey
forall a b. (a -> b) -> a -> b
$ SecretKey -> PublicKey -> m CombinedKey
forall (m :: * -> *).
Keyed m =>
SecretKey -> PublicKey -> m CombinedKey
getCombinedKey SecretKey
sk PublicKey
pk

-- | The 'Networked' instance for 'DhtConduit' yields outgoing packets.
instance (Monad m) => Networked (DhtConduit i (NodeInfo, Packet BS.ByteString) m) where
    sendPacket :: NodeInfo
-> Packet payload
-> DhtConduit i (NodeInfo, Packet ByteString) m ()
sendPacket NodeInfo
to Packet payload
packet = ConduitT i (NodeInfo, Packet ByteString) m ()
-> DhtConduit i (NodeInfo, Packet ByteString) m ()
forall i o (m :: * -> *) a. ConduitT i o m a -> DhtConduit i o m a
DhtConduit (ConduitT i (NodeInfo, Packet ByteString) m ()
 -> DhtConduit i (NodeInfo, Packet ByteString) m ())
-> ConduitT i (NodeInfo, Packet ByteString) m ()
-> DhtConduit i (NodeInfo, Packet ByteString) m ()
forall a b. (a -> b) -> a -> b
$ (NodeInfo, Packet ByteString)
-> ConduitT i (NodeInfo, Packet ByteString) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (NodeInfo
to, (payload -> ByteString) -> Packet payload -> Packet ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap payload -> ByteString
forall a. Binary a => a -> ByteString
Encoding.encode Packet payload
packet)

-- | 'DhtConduit' is a 'DhtNodeMonad' if the underlying monad 'm' provides state and other effects.
instance (Timed m, MonadRandomBytes m, MonadState DhtState m, Keyed m)
    => DhtNodeMonad (DhtConduit i (NodeInfo, Packet BS.ByteString) m)

-- | Conduit that handles incoming DHT packets.
dhtPacketHandler :: forall m. (Timed m, MonadRandomBytes m, MonadState DhtState m, Keyed m)
                 => ConduitT (NodeInfo, Packet BS.ByteString) (NodeInfo, Packet BS.ByteString) m ()
dhtPacketHandler :: ConduitT
  (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ()
dhtPacketHandler = DhtConduit
  (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ()
-> ConduitT
     (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ()
forall i o (m :: * -> *) a. DhtConduit i o m a -> ConduitT i o m a
unDhtConduit (DhtConduit
   (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ()
 -> ConduitT
      (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ())
-> DhtConduit
     (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ()
-> ConduitT
     (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ()
forall a b. (a -> b) -> a -> b
$ DhtConduit
  (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ()
-> DhtConduit
     (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (DhtConduit
   (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ()
 -> DhtConduit
      (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ())
-> DhtConduit
     (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ()
-> DhtConduit
     (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (NodeInfo, Packet ByteString)
mInp <- ConduitT
  (NodeInfo, Packet ByteString)
  (NodeInfo, Packet ByteString)
  m
  (Maybe (NodeInfo, Packet ByteString))
-> DhtConduit
     (NodeInfo, Packet ByteString)
     (NodeInfo, Packet ByteString)
     m
     (Maybe (NodeInfo, Packet ByteString))
forall i o (m :: * -> *) a. ConduitT i o m a -> DhtConduit i o m a
DhtConduit ConduitT
  (NodeInfo, Packet ByteString)
  (NodeInfo, Packet ByteString)
  m
  (Maybe (NodeInfo, Packet ByteString))
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
    case Maybe (NodeInfo, Packet ByteString)
mInp of
        Maybe (NodeInfo, Packet ByteString)
Nothing          -> ()
-> DhtConduit
     (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (NodeInfo
from, Packet ByteString
pkt) -> NodeInfo
-> Packet ByteString
-> DhtConduit
     (NodeInfo, Packet ByteString) (NodeInfo, Packet ByteString) m ()
forall (m :: * -> *).
DhtNodeMonad m =>
NodeInfo -> Packet ByteString -> m ()
handleIncomingPacket NodeInfo
from Packet ByteString
pkt

-- | Run maintenance operations within a conduit.
dhtMaintenanceLoop :: forall i m. (Timed m, MonadRandomBytes m, MonadState DhtState m, Keyed m)
                   => ConduitT i (NodeInfo, Packet BS.ByteString) m ()
dhtMaintenanceLoop :: ConduitT i (NodeInfo, Packet ByteString) m ()
dhtMaintenanceLoop = DhtConduit i (NodeInfo, Packet ByteString) m ()
-> ConduitT i (NodeInfo, Packet ByteString) m ()
forall i o (m :: * -> *) a. DhtConduit i o m a -> ConduitT i o m a
unDhtConduit DhtConduit i (NodeInfo, Packet ByteString) m ()
forall (m :: * -> *). DhtNodeMonad m => m ()
handleMaintenance

-- | Bootstrap from a node within a conduit.
dhtBootstrapFrom :: forall i m. (Timed m, MonadRandomBytes m, MonadState DhtState m, Keyed m)
                 => NodeInfo -> ConduitT i (NodeInfo, Packet BS.ByteString) m ()
dhtBootstrapFrom :: NodeInfo -> ConduitT i (NodeInfo, Packet ByteString) m ()
dhtBootstrapFrom NodeInfo
node = DhtConduit i (NodeInfo, Packet ByteString) m ()
-> ConduitT i (NodeInfo, Packet ByteString) m ()
forall i o (m :: * -> *) a. DhtConduit i o m a -> ConduitT i o m a
unDhtConduit (DhtConduit i (NodeInfo, Packet ByteString) m ()
 -> ConduitT i (NodeInfo, Packet ByteString) m ())
-> DhtConduit i (NodeInfo, Packet ByteString) m ()
-> ConduitT i (NodeInfo, Packet ByteString) m ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> DhtConduit i (NodeInfo, Packet ByteString) m ()
forall (m :: * -> *). DhtNodeMonad m => NodeInfo -> m ()
handleBootstrap NodeInfo
node