{-# 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 qualified Data.ByteString.Lazy.Char8 as L
    ( putStrLn
    )
import Control.Concurrent (forkIO,killThread)
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

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

xmlifyPresenceForClient :: Presence -> IO [x]
xmlifyPresenceForClient presence = todo

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


    {-
    reader <- forkIO $ do
        flip ($$) snk $
            handle (\(SomeException e) -> liftIO (L.putStrLn $ "quit reader via exception: "<++>bshow e) >> return ()) $
             fix $ \loop -> do
                event <- liftIO . atomically $ 
                    (fmap Left $ readTChan pchan)
                  `orElse`
                    (fmap Right $ readTChan cmdChan)
                case event of
                    Left presence -> do
                        liftIO (L.putStrLn $ "PRESENCE: " <++> bshow presence)
                        -- TODO: it violates spec to send presence information before
                        --  a resource is bound.
                        -- r <- xmlifyPresenceForClient presence
                        -- yield r
                        -- -- hPutStrLn h r
                        -- liftIO (L.putStrLn $ "\nOUT client:\n" <++> r)
                    Right (Send r) ->
                        mapM_ yield r
                        -- yield r
                        -- -- hPutStrLn h r
                loop
    -}
    let outgoing = do
            event <- liftIO . atomically $ 
                (fmap Left $ readTChan pchan)
              `orElse`
                (fmap Right $ readTChan cmdChan)
            case event of
              Right QuitThread -> return ()
              Left presence -> do 
                xs <- liftIO $ xmlifyPresenceForClient presence
                Monad.mapM_ yield xs
                outgoing

        incomming = do
            mb <- await
            maybe (return ())
                  (\packet -> do
                        liftIO (L.putStrLn $ "client-in: " <++> bshow packet)
                        incomming)
                  mb
            
    sendingThread <- forkIO (outgoing $$ snk)
    let quit = do
            atomically $ writeTChan cmdChan QuitThread
            closeSession session
            -- killThread sendingThread
    finally ( src $= parseBytes def $$ incomming )
            quit

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"
    return ()