path: root/Connection/Tox/Threads.hs

-- |
--
-- This module defines three tasks intended to be run in separate threads:
--
--  * 'acceptContact'
--
--  * 'persueContact'
--
--  * 'freshenContact'
--
{-# LANGUAGE LambdaCase #-}
module Connection.Tox.Threads where

import Connection
-- import Connection.Tox
import Data.IP (IP)
import Network.Tox.Crypto.Transport
import Network.Tox.Crypto.Handlers
import Network.Tox.NodeId
import Network.Tox.ContactInfo
import Network.Tox.DHT.Handlers {- (nodeSearch) -} as DHT
import Network.Socket
import Network.Kademlia.Search
import Network.Kademlia.Routing (BucketList)

import Control.Concurrent.STM
import Control.Monad
import Data.Function
import Data.Functor.Identity
import System.Timeout


-- | This type indicates the progress of a tox encrypted friend link
-- connection.  Two scenarios are illustrated below.  The parenthesis show the
-- current 'G.Status' 'ToxProgress' of the session.
--
--
-- Perfect handshake scenario:
--
--  Peer 1                                  Peer 2
--  (InProgress AcquiringCookie)            (Dormant/InProgress AcquiringCookie)
--                     Cookie request ->
--                                       <- Cookie response
--  (InProgress AwaitingHandshake)          (Dormant/InProgress AcquiringCookie)
--                   Handshake packet ->
--                                          * accepts connection
--                                          (InProgress AwaitingSessionPacket)
--                                       <- Handshake packet
--  *accepts connection
--  (InProgress AwaitingSessionPacket)
--                   Encrypted packet -> <- Encrypted packet
--  *confirms connection                    *confirms connection
--  (Established)                           (Established)
--
--                           Connection successful.
--
--                  Encrypted packets -> <- Encrypted packets
--
--
--
--
--  More realistic handshake scenario:
--  Peer 1                                  Peer 2
--  (InProgress AcquiringCookie)            (Dormant/InProgress AcquiringCookie)
--                      Cookie request ->   *packet lost*
--                      Cookie request ->
--                                        <- Cookie response
--  (InProgress AwaitingHandshake)           (Dormant/InProgress AcquiringCookie)
--
--                                           *Peer 2 randomly starts new connection to peer 1
--                                           (InProgress AcquiringCookie)
--                                        <- Cookie request
--                     Cookie response ->
--                                           (InProgress AwaitingHandshake)
--
--                    Handshake packet -> <- Handshake packet
--  *accepts connection                      * accepts connection
--  (InProgress AwaitingSessionPacket)      (InProgress AwaitingSessionPacket)
--
--                    Encrypted packet -> <- Encrypted packet
--  *confirms connection                     *confirms connection
--  (Established)                           (Established)
--
--                              Connection successful.
--
--                   Encrypted packets -> <- Encrypted packets
data ToxProgress
    = AwaitingDHTKey        -- ^ Waiting to receive their DHT key.
    | AcquiringIPAddress    -- ^ Searching DHT to obtain their node's IP & port.
    | AcquiringCookie       -- ^ Attempting to obtain a cookie.
    | AwaitingHandshake     -- ^ Waiting to receive a handshake.
    | AwaitingSessionPacket -- ^ Connection is "accepted" but not yet "confirmed".
    deriving (Eq,Ord,Enum,Show)


type NodeSearch = Search NodeId (IP,PortNumber) () NodeInfo NodeInfo

data AcceptContactMethods = AcceptContactMethods
    { getHandshake        :: STM (Handshake Identity)
    , handshakeIsSuitable :: Handshake Identity -> STM Bool
    , transitionToState   :: Status ToxProgress -> STM ()
    }

-- | Invokes an STM action on each incoming handshake.
--
-- Does not return until getPolicy yields RefusingToConnect.
acceptContact :: STM Policy -> AcceptContactMethods -> (Status ToxProgress -> STM ()) -> IO ()
acceptContact getPolicy AcceptContactMethods{..} writeState = fix $ \loop -> do
    join $ atomically $ do
        orElse
            (getPolicy >>= \case
                RefusingToConnect -> do writeState Dormant
                                        return $ return () -- QUIT Dormant/Established
                _                 -> retry)
            (do hs <- getHandshake
                handshakeIsSuitable hs >>= \case
                    True -> do
                        -- Here we allocate a NetCrypto session for handling CryptoPacket.
                        writeState (InProgress AwaitingSessionPacket)
                        transitionToState (InProgress AwaitingSessionPacket)
                        return loop
                    False -> return loop)

whileTryingAndNotEstablished :: STM Policy
                                -> STM (Status t)
                                -> (Status ToxProgress -> STM ())
                                -> ((Int -> IO ()) -> STM (IO ()))
                                -> IO ()
whileTryingAndNotEstablished getPolicy getStatus writeStatus body = fix $ \loop -> do
    let retryWhileTrying k = getPolicy >>= \case
            TryingToConnect -> retry
            _               -> do writeStatus Dormant
                                  return k
        ifEstablished t e = getStatus >>= \case
            Established -> t
            _           -> e
        retryAfterTimeout interval = do
            timeout interval $ atomically
                $ orElse
                     (retryWhileTrying ())
                     (ifEstablished (return ()) retry)
            loop
    join $ atomically $ orElse
        (retryWhileTrying (return ())) -- QUIT Dormant/Established
        (ifEstablished retry
                       (body retryAfterTimeout))

data PersueContactMethods params = PersueContactMethods
    { allsessions        :: NetCryptoSessions
    , myseckey           :: SecretKey
    , theirpubkey        :: PublicKey
    , client             :: DHT.Client
    , retryInterval      :: Int
    , contact            :: Contact
    }

retryUntilJust :: TVar (Maybe a) -> STM a
retryUntilJust tvar = do
    mb <- readTVar tvar
    case mb of
        mempty -> retry
        Just x -> return x

-- | Continuously attempt to send handshake packets until a connection is
-- established.
--
-- As long as getPolicy is TryingToConnect and there is no established
-- connection, this function will continue.
persueContact :: STM Policy
                 -> STM (Status t)
                 -> PersueContactMethods a
                 -> (Status ToxProgress -> STM ())
                 -> IO ()
persueContact getPolicy getStatus PersueContactMethods{..} writeStatus
    = whileTryingAndNotEstablished getPolicy getStatus writeStatus
        $ \retryAfterTimeout -> do
            -- AwaitingDHTKey
            atomically $ writeStatus (InProgress AwaitingDHTKey)
            keypkt <- atomically $ retryUntilJust (contactKeyPacket contact)
            let theirDhtKey = DHT.dhtpk keypkt
            -- AcquiringIPAddress
            atomically $ writeStatus (InProgress AcquiringIPAddress)
            ni <- atomically $ do
                 saddr <- retryUntilJust (contactLastSeenAddr contact)
                 either retry return $ nodeInfo (key2id theirDhtKey) saddr
            let mykeyAsId    = key2id (toPublic myseckey)
                theirkeyAsId = key2id theirpubkey
            atomically $ writeStatus (InProgress AcquiringCookie)
            -- if no session:
            -- Convert to NodeInfo, so we can send cookieRequest
            let crypto = transportCrypto allsessions
            case nodeInfo (key2id theirDhtKey) saddr of
             Left e   -> hPutStrLn stderr ("persueContact: nodeInfo fail... " ++ e)
             Right ni -> do
                -- AcquiringCookie
                mbCookie <- DHT.cookieRequest crypto client (toPublic myseckey) ni
                case mbCookie of
                  Nothing -> do
                    hPutStrLn stderr ("persueContact: (" ++ show mykeyAsId ++") <--> (" ++ show theirkeyAsId ++ ").")
                    hPutStrLn stderr ("persueContact: CookieRequest failed. TODO: dhtpkNodes thingy")
                  Just cookie -> do
                    hPutStrLn stderr "Have cookie, creating handshake packet..."
                    let hp = HParam { hpOtherCookie = cookie
                                    , hpMySecretKey = myseckey
                                    , hpCookieRemotePubkey = theirpubkey
                                    , hpCookieRemoteDhtkey = theirDhtKey
                                    , hpTheirBaseNonce = Nothing
                                    , hpTheirSessionKeyPublic = Nothing
                                    }
                    newsession <- generateSecretKey
                    timestamp <- getPOSIXTime
                    (myhandshake,ioAction)
                            <- atomically $ freshCryptoSession allsessions saddr newsession timestamp hp
                    ioAction
                    -- send handshake
                    forM myhandshake $ \response_handshake -> do
                            sendHandshake (toxCryptoSessions tox) saddr response_handshake
                    atomically $ writeStatus $ InProgress AwaitingHandshake
            -- AwaitingHandshake
            -- AwaitingSessionPacket
            retryAfterTimeout retryInterval

data FreshenContactMethods = FreshenContactMethods
    { dhtkeyInterval   :: Int
    , sockAddrInterval :: Int
    , nodeSch          :: NodeSearch
    , getDHTKey        :: STM (Maybe NodeId)
    , getSockAddr      :: STM (Maybe SockAddr)
    , getBuckets       :: STM (BucketList NodeInfo)
    }

-- send my dht key
-- search for their sockaddr
-- monitor new dht key
-- monitor new sockaddr
--
-- Keep going while TryingToConnect
-- pause while Established

-- Useful:
--   toxidSearch onionTimeout
--   newSearch
--   searchLoop
--   searchCancel
--   -> (r -> STM Bool) -- ^ Invoked on each result.  Return False to quit searching.

-- | Continuously search the DHT to obtain ip addresses and to send your dht
-- key to contacts.
--
-- As long as getPolicy is TryingToConnect and there is no established
-- connection, this function will continue.
freshenContact :: STM Policy -> STM (Status t) -> FreshenContactMethods
                  -> (Status ToxProgress -> STM ())
                  -> IO ()
freshenContact getPolicy getStatus FreshenContactMethods{..} writeStatus
    = whileTryingAndNotEstablished getPolicy getStatus writeStatus
         -- retryAfterTimeout :: Int -> IO ()
        $ \retryAfterTimeout ->
            getDHTKey >>= \case
                Nothing -> -- AwaitingDHTKey
                           retry
                Just dk -> getSockAddr >>= \case
                    Nothing -> do -- AcquiringIPAddress
                           writeStatus (InProgress AcquiringIPAddress)
                           return $
                               do bkts <- atomically $ getBuckets
                                  st <- search nodeSch bkts dk $
                                            \r -> do -- TODO: store saddr, check for finish
                                                     return True
                                  atomically $ searchIsFinished st >>= check
                                               -- TODO: searchCancel on stop condition
                                  retryAfterTimeout sockAddrInterval
                    Just a  -> do
                            writeStatus (InProgress AcquiringCookie)
                            return $
                               -- AcquiringCookie
                               -- AwaitingHandshake
                               -- AwaitingSessionPacket
                               do _todo_search_toxid_send_dhtkey -- 123 _todo_search_toxid_send_dhtkey :: IO a0
                                  retryAfterTimeout dhtkeyInterval