import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.Trans (lift)
import Control.Monad.Fix (fix)
import Control.Concurrent (forkIO)
import Control.Concurrent.STM
-- import Control.Concurrent.STM.TChan
import Network.Socket
import XMPPTypes (withPort)
import Text.Printf

import Server

wlog s = putStrLn s

control sv = atomically . putTMVar (serverCommand sv)

monitor sv params = do
    chan <- return $ serverEvent sv
    fix $ \loop -> do
    (k,e) <- atomically $ readTChan chan
    case e of
        Connection -> wlog $ tomsg k "Connection"
        EOF        -> wlog $ tomsg k "EOF"
        HalfConnection In -> do
            wlog $ tomsg k "ReadOnly"
            control sv (Connect (callBackAddress k) params)
        HalfConnection Out -> wlog $ tomsg k "WriteOnly"
        RequiresPing -> wlog $ tomsg k "RequiresPing"
        _ -> return ()
    loop
 where
    tomsg k str =  printf "%12s %s" str (show k)

data ConnectionKey
       = PeerKey { callBackAddress :: SockAddr }
       | ClientKey { localAddress :: SockAddr }
 deriving (Show, Ord, Eq)

peerKey (sock,addr) = do
    peer <- getPeerName sock
    return $ PeerKey (peer `withPort` fromIntegral peerport)

clientKey (sock,addr) = return $ ClientKey addr

peerport = 5269
clientport = 5222

main = runResourceT $ do
    sv <- server
    lift $ do
    peer_params <- return (connectionDefaults peerKey)
                          { duplex = False }
    client_params <- return $ connectionDefaults clientKey
    forkIO $ monitor sv peer_params
    control sv (Listen peerport peer_params)
    control sv (Listen clientport client_params)

    atomically $ newEmptyTMVar >>= readTMVar -- Wait for control-c

    return ()