{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource (runResourceT)
import Data.Monoid
import System.Environment
import System.Posix.Signals

import ConsoleWriter
import Presence
import XMPPServer

main :: IO ()
main = runResourceT $ do
    args <- liftIO getArgs
    let verbosity = getSum $ flip foldMap args $ \case
            ('-':xs) -> Sum $ length (filter (=='-') xs)
            _        -> mempty
    cw    <- liftIO newConsoleWriter
    state <- liftIO $ newPresenceState cw
    sv    <- xmppServer (presenceHooks state verbosity)
    liftIO $ do
    atomically $ putTMVar (server state) sv

    quitVar <- newEmptyTMVarIO
    installHandler sigTERM (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
    installHandler sigINT (CatchOnce (atomically $ putTMVar quitVar True)) Nothing

    forkIO $ do
        let console = cwPresenceChan $ consoleWriter state
        fix $ \loop -> do
        what <- atomically
            $ orElse (do (client,stanza) <- takeTMVar console
                         return $ do informClientPresence0 state Nothing client stanza
                                     loop)
                     (do readTMVar quitVar
                         return $ return ())
        what

    quitMessage <- atomically $ takeTMVar quitVar

    putStrLn "goodbye."
    return ()