{-# LANGUAGE PatternSynonyms            #-}
module Network.Tox.Onion.Handlers where

import Network.Tox.DHT.Transport
import Network.Tox.DHT.Handlers hiding (Message,Client)
import Network.Tox.Onion.Transport
import Network.QueryResponse as QR hiding (Client)
import qualified Network.QueryResponse as QR (Client)
import Crypto.Tox
import qualified Data.Wrapper.PSQ             as PSQ
         ;import Data.Wrapper.PSQ             (PSQ)
import Crypto.Error.Types                     (CryptoFailable (..),
                                               throwCryptoError)

import System.IO
import qualified Data.ByteArray               as BA
import Data.Serialize as S
import qualified Data.Wrapper.PSQInt as Int
import Network.Kademlia
import Network.Address               (WantIP (..), ipFamily, testIdBit)
import qualified Network.Kademlia.Routing as R
import Control.TriadCommittee
import qualified Data.MinMaxPSQ               as MinMaxPSQ
         ;import Data.MinMaxPSQ               (MinMaxPSQ')
import Network.BitTorrent.DHT.Token           as Token

import Control.Exception hiding (Handler)
import Control.Monad
import Control.Concurrent.STM
import Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)
import Network.Socket
import Data.IP
import Data.Maybe
import Data.Bits
import Data.Ord
import Data.Functor.Identity

type Client = QR.Client String PacketKind TransactionId OnionToOwner Message
type Message = OnionMessage Identity

classify :: Message -> MessageClass String PacketKind TransactionId
classify msg = go msg
 where
    go (OnionAnnounce         announce)    = IsQuery AnnounceType
                                                $ TransactionId (snd $ runIdentity $ assymData announce)
                                                                (assymNonce announce)
    go (OnionAnnounceResponse n8 n24 resp) = IsResponse (TransactionId n8 n24)
    go (OnionToRoute          {})          = IsQuery DataRequestType (TransactionId (Nonce8 0) (Nonce24 zeros24))
    go (OnionToRouteResponse  {})          = IsResponse              (TransactionId (Nonce8 0) (Nonce24 zeros24))

-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current time,
-- some secret bytes generated when the instance is created, the current time
-- divided by a 20 second timeout, the public key of the requester and the source
-- ip/port that the packet was received from. Since the ip/port that the packet
-- was received from is in the `ping_id`, the announce packets being sent with a
-- ping id must be sent using the same path as the packet that we received the
-- `ping_id` from or announcing will fail.
--
-- The reason for this 20 second timeout in toxcore is that it gives a reasonable
-- time (20 to 40 seconds) for a peer to announce himself while taking in count
-- all the possible delays with some extra seconds.
announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionToOwner -> AnnounceRequest -> IO AnnounceResponse
announceH routing toks keydb (OnionToOwner naddr retpath) req = do
    case () of
        _ | announcePingId req == zeros32
          -> go False

        _ -> let Nonce32 bs = announcePingId req
                 tok        = fromPaddedByteString 32 bs
             in checkToken toks naddr tok >>= go
        `catch` (\(SomeException e) -> hPutStrLn stderr ("announceH Exception! "++show e) >> throw e)
 where
    go withTok = do
        ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
        tm <- getPOSIXTime
        let storing = (nodeId naddr == announceSeeking req)
        record <- atomically $ do
            when (withTok && storing) $ do
                let toxpath = OnionToOwner naddr{ nodeId = announceKey req } retpath
                    -- Note: The following distance calculation assumes that
                    -- our nodeid doesn't change and is the same for both
                    -- routing4 and routing6.
                    d = xorNodeId (nodeId (tentativeId routing))
                                  (announceSeeking req)
                modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
            ks <- readTVar keydb
            return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
        newtok <- if storing
                    then Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr
                    else return $ zeros32
        let k = case record of
                Nothing                     -> NotStored newtok
                Just (OnionToOwner {}) | storing -> Acknowledged newtok
                Just (OnionToOwner ni _)         -> SendBackKey $ id2key (nodeId ni)
        let response = AnnounceResponse k ns
        hPutStrLn stderr $ unwords ["Announce:", show req, "-reply->", show response]
        return response

dataToRouteH ::
          TVar AnnouncedKeys
          -> Transport err OnionToOwner (OnionMessage f)
          -> addr
          -> OnionMessage f
          -> IO ()
dataToRouteH keydb udp _ (OnionToRoute pub assym) = do
    let k = key2id pub
    mb <- atomically $ do
        ks <- readTVar keydb
        forM (MinMaxPSQ.lookup' k (keyAssoc ks)) $ \(p,(cnt,rpath)) -> do
            writeTVar keydb $ ks { keyAssoc = MinMaxPSQ.insert' k (cnt + 1, rpath) p (keyAssoc ks) }
            return rpath
    forM_ mb $ \rpath -> do
        -- forward
        sendMessage udp rpath $ OnionToRouteResponse assym
        hPutStrLn stderr $ "Forwarding data-to-route -->"++show k

type NodeDistance = NodeId

data AnnouncedKeys = AnnouncedKeys
    { keyByAge :: !(PSQ NodeId (Down POSIXTime)) -- timeout of 300 seconds
    , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int,OnionToOwner))
    }


insertKey :: POSIXTime -> NodeId -> OnionToOwner -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
insertKey tm pub toxpath d keydb = AnnouncedKeys
    { keyByAge = PSQ.insert pub (Down tm) (keyByAge keydb)
    , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of
                    Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb)
                    Nothing          -> MinMaxPSQ.insert' pub (0  ,toxpath) d (keyAssoc keydb)
    }

areq :: Message -> Either String AnnounceRequest
areq (OnionAnnounce assym) = Right $ fst $ runIdentity $ assymData assym
areq _                     = Left "Unexpected non-announce OnionMessage"

handlers :: Transport err OnionToOwner Message
            -> Routing
            -> TVar SessionTokens
            -> TVar AnnouncedKeys
            -> PacketKind
            -> Maybe (MethodHandler String TransactionId OnionToOwner Message)
handlers net routing toks keydb AnnounceType
    = Just
    $ MethodHandler areq (\(TransactionId n8 n24) src dst -> OnionAnnounceResponse n8 n24 . Identity)
    $ announceH routing toks keydb
handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net