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

import Control.Arrow
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.List
import Data.Maybe
import Data.Ord
import Data.Time.Clock.POSIX

import Connection
import DebugTag
import DPut
import Network.Tox.DHT.Transport   as DHT
import Network.Tox.NodeId          (id2key)
import Network.Tox.Onion.Transport as Onion

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)
    }

contactDHTKey :: Contact -> STM (Maybe PublicKey)
contactDHTKey c = do
    mkeypkt <- fmap (second dhtpk) <$> readTVar (contactKeyPacket c)
    mseen <- fmap (second $ id2key . nodeId) <$> readTVar (contactLastSeenAddr c)
    return $ fmap snd $ listToMaybe $ sortOn (Down . fst) $ catMaybes [mkeypkt,mseen]

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