{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE FlexibleContexts    #-}
module XMPP 
    ( module XMPPTypes
    , listenForXmppClients
    , listenForRemotePeers
    , seekRemotePeers
    , quitListening
    )  where

import ServerC
import XMPPTypes
import SocketLike
import ByteStringOperators

import Data.HList
import Network.Socket (Family)
import Network.BSD (PortNumber)
import Control.Concurrent.STM
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.ByteString (ByteString)
import Data.ByteString.Char8 (pack)
import qualified Data.ByteString.Lazy.Char8 as L
    ( putStrLn
    , fromChunks
    )
import Control.Concurrent (forkIO,killThread)
import Control.Concurrent.Async
import Control.Exception (handle,SomeException(..),finally)
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Todo
import Control.Monad as Monad
import Text.XML.Stream.Parse
import Text.XML.Stream.Render
import Data.XML.Types as XML
import Network.BSD (getHostName,hostName,hostAliases)
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Text.Lazy (toStrict)
import GetHostByAddr

data Commands = Send [XML.Event] | QuitThread
 deriving Prelude.Show

getNamesForPeer :: Peer -> IO [ByteString]
getNamesForPeer LocalHost = fmap ((:[]) . pack) getHostName
getNamesForPeer peer@(RemotePeer addr) = do
    ent <- getHostByAddr addr --  AF_UNSPEC addr
    let names = hostName ent : hostAliases ent
    return . map pack $ names


xmlifyPresenceForClient :: Presence -> IO [XML.Event]
xmlifyPresenceForClient (Presence jid stat) = do
    let n   = name jid
        rsc = resource jid
    names <- getNamesForPeer (peer jid)
    let tostr p = decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?>  "/" <++$> rsc
        jidstrs = fmap (toStrict . tostr) names
    return (concatMap presenceEvents jidstrs)
 where
    presenceEvents jidstr =
      [ EventBeginElement "presence" (("from",[ContentText jidstr]):typ stat)
      , EventBeginElement "show" []
      , EventContent (ContentText . shw $ stat)
      , EventEndElement "show"
      , EventEndElement "presence"
      ]
    typ Offline = [("type",[ContentText "unavailable"])]
    typ _       = []
    shw Available = "chat"
    shw Away      = "away"
    shw Offline   = "away" -- Is this right?



fromClient :: MonadIO m => TChan Commands -> Sink XML.Event m ()
fromClient cmdChan = fix $ \loop -> do
    mb <- await
    maybe (return ())
          (\packet -> do
                liftIO (L.putStrLn $ "client-in: " <++> bshow packet)
                loop)
          mb

toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m XML.Event
toClient pchan cmdChan = fix $ \loop -> do
    event <- liftIO . atomically $ 
              orElse (fmap Left $ readTChan pchan)
                     (fmap Right $ readTChan cmdChan)
    case event of
      Right QuitThread -> 
        return ()
      Left  presence   -> do 
        xs <- liftIO $ xmlifyPresenceForClient presence
        Monad.mapM_ yield xs
        loop
    

handleClient
  :: (SocketLike sock, HHead l (XMPPClass session),
      XMPPSession session) =>
     HCons sock (HCons t l) -> Source IO ByteString -> Sink ByteString IO () -> IO ()
handleClient st src snk = do
    let HCons sock (HCons _ st') = st
        session_factory = hHead st'
    pname <- getPeerName sock
    session <- newSession session_factory sock
    Prelude.putStrLn $ "PEER NAME: "++Prelude.show pname
    pchan <- subscribe session Nothing
    cmdChan <- atomically newTChan

    writer <- async ( toClient pchan cmdChan $$ renderBytes def =$ snk )
    finally         ( src $= parseBytes def $$ fromClient cmdChan )
        $ do
            atomically $ writeTChan cmdChan QuitThread
            wait writer
            closeSession session

listenForXmppClients ::
  (HList l, HHead l (XMPPClass session), HExtend e1 l2 l1,
   HExtend e l1 (HCons PortNumber l), XMPPSession session) =>
  Family -> e1 -> e -> l2 -> IO ServerHandle
listenForXmppClients addr_family session_factory port st = do
    doServer (addr_family .*. port .*. session_factory .*. st) handleClient

listenForRemotePeers
  :: (HList t1, HExtend e l (HCons PortNumber t1), XMPPSession t) =>
     Family -> XMPPClass t -> e -> l -> IO ServerHandle
listenForRemotePeers addrfamily session_factory port st = do
    putStrLn "unimplemented: listenForRemotePeers"
    dummyServerHandle
    -- TODO

seekRemotePeers :: XMPPConfig config =>
     config -> TChan Presence -> IO ()
seekRemotePeers config chan = do
    putStrLn "unimplemented: seekRemotePeers"
    -- TODO
    return ()