{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
module Network.Tox.ContactInfo where

import Connection

import Data.Time.Clock.POSIX
import Control.Concurrent.STM
import Control.Monad
import Crypto.PubKey.Curve25519
import qualified Data.HashMap.Strict as HashMap
         ;import Data.HashMap.Strict (HashMap)
import Data.Maybe
import Network.Tox.DHT.Transport     as DHT
import Network.Tox.NodeId            (id2key)
import Network.Tox.Onion.Transport   as Onion
import DPut
import DebugTag

newtype ContactInfo extra = ContactInfo
    {
      -- | Map our toxid public key to an Account record.
      accounts :: TVar (HashMap NodeId{-my userkey-} (Account extra))
    }

data Account extra = Account
    { userSecret   :: SecretKey                     -- local secret key
    , contacts     :: TVar (HashMap NodeId{-friend's userkey-} Contact) -- received contact info
    , accountExtra :: TVar extra
    , eventChan    :: TChan ContactEvent
    }

data ContactEvent = OnionRouted  { contact :: PublicKey, onionRouted :: OnionData }
                  | PolicyChange { contact :: PublicKey, policyChange :: Policy }
                  | AddrChange   { contact :: PublicKey, addrChange :: NodeInfo }
                  | SessionEstablished { contact :: PublicKey }
                  | SessionTerminated  { contact :: PublicKey }

data Contact = Contact
    { contactKeyPacket     :: TVar (Maybe (POSIXTime,DHT.DHTPublicKey))
    , contactLastSeenAddr  :: TVar (Maybe (POSIXTime,NodeInfo))
    , contactFriendRequest :: TVar (Maybe (POSIXTime,DHT.FriendRequest))
    , contactPolicy        :: TVar (Maybe Connection.Policy)
    }

newContactInfo :: IO (ContactInfo extra)
newContactInfo = atomically $ ContactInfo <$> newTVar HashMap.empty

myKeyPairs :: ContactInfo extra -> STM [(SecretKey,PublicKey)]
myKeyPairs (ContactInfo accounts) = do
    acnts <- readTVar accounts
    forM (HashMap.toList acnts) $ \(nid, Account{userSecret}) -> do
        return (userSecret,id2key nid)

updateContactInfo :: ContactInfo extra -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO ()
updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do
    dput XMisc "updateContactInfo!!!"
    now <- getPOSIXTime
    atomically $ do
        as <- readTVar (accounts roster)
        maybe (return ())
              (updateAccount now remoteUserKey omsg)
              $ HashMap.lookup (key2id localUserKey) as

initContact :: STM Contact
initContact = Contact <$> newTVar Nothing
                      <*> newTVar Nothing
                      <*> newTVar Nothing
                      <*> newTVar Nothing

getContact :: PublicKey -> Account extra -> STM (Maybe Contact)
getContact remoteUserKey acc = do
    let rkey = key2id remoteUserKey
    cmap <- readTVar (contacts acc)
    return $ HashMap.lookup rkey cmap

updateAccount' :: PublicKey -> Account extra -> (Contact -> STM ()) -> STM ()
updateAccount' remoteUserKey acc updater = do
    let rkey = key2id remoteUserKey
    cmap <- readTVar (contacts acc)
    contact <- case HashMap.lookup rkey cmap of
        Just contact -> return contact
        Nothing      -> do contact <- initContact
                           writeTVar (contacts acc) $ HashMap.insert rkey contact cmap
                           return contact
    updater contact

updateAccount :: POSIXTime -> PublicKey -> Onion.OnionData -> Account extra -> STM ()
updateAccount now remoteUserKey omsg acc = do
    updateAccount' remoteUserKey acc $ onionUpdate now omsg
    writeTChan (eventChan acc) $ OnionRouted remoteUserKey omsg

onionUpdate :: POSIXTime -> OnionData -> Contact -> STM ()
onionUpdate now (Onion.OnionDHTPublicKey dhtpk) contact
                = writeTVar (contactKeyPacket contact)     $ Just (now,dhtpk)
onionUpdate now (Onion.OnionFriendRequest fr)   contact
                = writeTVar (contactFriendRequest contact) $ Just (now,fr)

policyUpdate :: Policy -> Contact -> STM ()
policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy

addrUpdate :: POSIXTime -> NodeInfo -> Contact -> STM ()
addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr)

setContactPolicy :: PublicKey -> Policy -> Account extra -> STM ()
setContactPolicy remoteUserKey policy acc = do
    updateAccount' remoteUserKey acc $ policyUpdate policy
    writeTChan (eventChan acc) $ PolicyChange remoteUserKey policy

setContactAddr :: POSIXTime -> PublicKey -> NodeInfo -> Account extra -> STM ()
setContactAddr now remoteUserKey addr acc = do
    contact <- getContact remoteUserKey acc
    let update = updateAccount' remoteUserKey acc $ addrUpdate now addr
    let notify = writeTChan (eventChan acc) $ AddrChange remoteUserKey addr
    join <$> traverse (readTVar . contactLastSeenAddr) contact >>= \case
      Just (_, a) | addr == a    -> update -- updates time only
      Just (t, _) | now > t + 60 -> update >> notify -- update IP if existing one is old
      Nothing                    -> update >> notify -- or if we don't have any
      _                          -> return () -- otherwise just wait

setEstablished :: PublicKey -> Account extra -> STM ()
setEstablished remoteUserKey acc =
    writeTChan (eventChan acc) $ SessionEstablished remoteUserKey

setTerminated :: PublicKey -> Account extra -> STM ()
setTerminated remoteUserKey acc =
    writeTChan (eventChan acc) $ SessionTerminated remoteUserKey


addContactInfo :: ContactInfo extra -> SecretKey -> extra -> STM ()
addContactInfo (ContactInfo as) sk extra = do
    a <- newAccount sk extra
    modifyTVar' as $ HashMap.insert (key2id $ toPublic sk) a

delContactInfo :: ContactInfo extra -> PublicKey -> STM ()
delContactInfo (ContactInfo as) pk = modifyTVar' as $ HashMap.delete (key2id pk)

newAccount :: SecretKey -> extra -> STM (Account extra)
newAccount sk extra = Account sk <$> newTVar HashMap.empty
                                 <*> newTVar extra
                                 <*> newBroadcastTChan

dnsPresentation :: ContactInfo extra -> STM String
dnsPresentation (ContactInfo accsvar) = do
    accs <- readTVar accsvar
    ms <- forM accs $ \Account { userSecret = sec, contacts = cvar } -> do
        cs <- readTVar cvar
        rs <- forM (HashMap.toList cs) $ \(nid,c) -> do
            mkpkt <- readTVar (contactKeyPacket c)
            return $ fmap (\(_,d) -> (nid,d)) mkpkt
        return $
            "; local key = " ++ show (key2id $ toPublic sec) ++ "\n"
             ++ concatMap dnsPresentation1 (catMaybes rs)
    return $ concat ms

dnsPresentation1 :: (NodeId,DHTPublicKey) -> String
dnsPresentation1 (nid,dk) = unlines
    [ concat [ show nid, ".tox. IN CNAME ", show (key2id $ dhtpk dk), ".dht." ]
    ]

type LocalKey = NodeId
type RemoteKey = NodeId

friendRequests :: ContactInfo extra -> STM (HashMap LocalKey [(RemoteKey,DHT.FriendRequest)])
friendRequests (ContactInfo roster) = do
    accs <- readTVar roster
    forM accs $ \Account { userSecret = sec, contacts = cvar } -> do
        cs <- readTVar cvar
        rs <- forM (HashMap.toList cs) $ \(nid,c) -> do
            mfr <- readTVar (contactFriendRequest c)
            return $ fmap (\(_,x) -> (nid,x)) mfr
        return $ catMaybes rs