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

import ConnectionKey
import Connection

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 qualified Data.Set            as Set
         ;import Data.Set            (Set)
import Network.Socket
import Network.Tox.DHT.Transport     as DHT
import Network.Tox.NodeId            (id2key)
import Network.Tox.Onion.Transport   as Onion
import System.IO

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

data Account = Account
    { userSecret :: SecretKey                     -- local secret key
    , contacts   :: TVar (HashMap NodeId{-friend's userkey-} Contact) -- received contact info
    , clientRefs :: TVar (Set ConnectionKey) -- reference count so we know when to send offline etc
    , eventChan  :: TChan ContactEvent
    }

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

data Contact = Contact
    { contactKeyPacket     :: TVar (Maybe (DHT.DHTPublicKey))
    , contactLastSeenAddr  :: TVar (Maybe SockAddr)
    , contactFriendRequest :: TVar (Maybe (DHT.FriendRequest))
    , contactPolicy        :: TVar (Maybe (Connection.Policy))
        -- Possible semantics
        --  RefusingToConnect : rejected friend-request or blocked or unknown.
        --  OpenToConnect     : pending friend-request.
        --  TryingToConnect   : roster entry.
    }

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

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

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

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

updateAccount' :: PublicKey -> Account -> (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 :: PublicKey -> Onion.OnionData -> Account -> STM ()
updateAccount remoteUserKey omsg acc = do
    updateAccount' remoteUserKey acc $ onionUpdate omsg
    writeTChan (eventChan acc) $ OnionRouted remoteUserKey omsg

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

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

addrUpdate :: SockAddr -> Contact -> STM ()
addrUpdate addr contact = writeTVar (contactLastSeenAddr contact) $ Just addr

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

setContactAddr :: PublicKey -> SockAddr -> Account -> STM ()
setContactAddr remoteUserKey addr acc = do
    updateAccount' remoteUserKey acc $ addrUpdate addr
    writeTChan (eventChan acc) $ AddrChange remoteUserKey addr



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

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

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

dnsPresentation :: ContactInfo -> 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 ((,) nid) 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 -> 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 ((,) nid) mfr
        return $ catMaybes rs