{-# LANGUAGE CPP                   #-}
{-# LANGUAGE PartialTypeSignatures #-}
module ToxChat
    ( module Chat
    , module ToxChat
    ) where

import Control.Concurrent.STM
import Control.Monad
import Data.Char
import Data.Dependent.Sum
import Data.Function
import qualified Data.Map     as Map
         ;import Data.Map     (Map)
import Data.Maybe
import qualified Data.Text    as T
         ;import Data.Text    (Text)
import Debug.Trace

#ifdef THREAD_DEBUG
import Control.Concurrent.Lifted.Instrument
#else
import Control.Concurrent.Lifted
import GHC.Conc                  (labelThread)
#endif

import Chat
import ConnectionKey
import Data.Tox.Msg
import DebugTag
import DPut
import MUC
import Network.Tox.AggregateSession

forkUntilSignaled :: String -> STM (IO ()) -> IO (IO ())
forkUntilSignaled lbl action = do
    quitSignal <- newTVarIO False
    t <- forkIO $ do
        fix $ \loop -> join $ atomically
            $ orElse (do readTVar quitSignal >>= check
                         return $ return ())
                     (fmap (>> loop) $ action)
    labelThread t lbl
    return $ atomically (writeTVar quitSignal True)

data RoomData k = RoomData
    { room           :: Maybe (Room k)
    , pendingInvites :: [(AggregateSession,Int,Maybe Text,Invite)]
    }

chatevents :: (Ord conkey, Show conkey) => TVar (Map Text (RoomData conkey)) -> STM (IO ())
chatevents rsvar = do
    rs <- readTVar rsvar
    if Map.null rs
      then retry
      else do
        ios <- flip Map.traverseWithKey rs $ \rkey r -> do
            ps <- maybe (return mempty) roomPending $ room r
            trace ("roomPending " ++ show ps) $ return ()
            case Map.toList ps of
                (k,t):ts -> do
                    roomCommit (fromJust $ room r) k t
                    modifyTVar' rsvar
                        $ Map.adjust (\d -> d { pendingInvites = take 1 (pendingInvites d)})
                                     rkey
                    return $ do
                        dput XJabber $ "toxchat-committed " ++ show (rkey,length ts,k,t)
                        case membershipEffect $ chatMessage t of
                            MembershipEffect Outside Inside -> do
                                forM_ (pendingInvites r) $ \(c,i,jid,inv) -> do
                                    -- TODO b <- checkCompatible me them c
                                    dput XJabber $ "Replying to invite " ++ show inv
                                    dispatchMessage c (Just i)
                                        $ Pkt INVITE_GROUPCHAT ==> inv { invite = AcceptedInvite }
                            _ -> return ()
                _ -> retry
        return $ foldl1 (>>) ios

data InviteCache m = InviteCache
    { rememberInvite :: AggregateSession -> Int {- session ID -} -> Maybe Text {- origin -} -> Invite -> m ()
    , lookupInvite   :: Text {- chatroom JID -} -> m (Maybe Invite)
    }

forkToxChat :: MUC -> IO (IO (), InviteCache IO)
forkToxChat muc = do
    (chan, rs) <- atomically $ do
        c <- dupTChan (mucChan muc)
        rs <- newTVar Map.empty -- TODO: This seems to redundantly duplicate MUC{mucRooms}.
        return (c,rs)
    quit <- forkUntilSignaled "toxchat" $ orElse (chatevents rs) $ do
        e <- readTChan chan
        case e of
            MUCCreate room jid nick r -> modifyTVar' rs $
                Map.alter (\d -> Just $ RoomData (Just r) (maybe [] pendingInvites d))
                          (T.toLower room)
        return $ case e of
            MUCCreate room jid nick _ ->
                dput XJabber $ unwords $ map T.unpack
                    [ "MUCCreate", room, jid, nick ]
    return $ (,) quit InviteCache
        { rememberInvite = \c i jid inv -> do
            dput XJabber $ "remember invite " ++ show (T.pack $ show $ inviteChatID inv, i, jid )
            atomically $ do
              modifyTVar' rs $ Map.alter (\d -> Just $ RoomData (room =<< (d:: Maybe (RoomData ClientAddress)))
                                                                ( ((c,i,jid,inv) :) $ maybe [] pendingInvites d))
                                       (T.pack $ map toLower $ show $ inviteChatID inv)
        , lookupInvite = \_ -> return Nothing
        }