module Xmpp where

import Control.Concurrent
import Control.Exception
import Control.Monad.Trans ( MonadIO, liftIO )
import Data.Maybe
import System.IO

import Text.XML.HaXml.SAX
import Text.Regex

import qualified Config
import Lib.Serial (readM)

import Message


import Network.Protocol.XMPP as XMPP
import Control.Monad.Consumer
import Text.XML.HaXml.Types
import Text.XML.HaXml.Combinators hiding (find)
import IRC

-- FIXME: fromJust == bad
-- FIXME: handleAuth should be using the information from Config.config
readerLoop :: ThreadId -> Pipe IrcMessage -> Pipe IrcMessage -> Handle -> MVar () -> MVar () -> IO ()
readerLoop th chanr chanw h _ _ = 
    handleIO th $ do
      io (putStrLn "Forking Xmpp.readerLoop thread ...")
      inStr <- hGetContents h
      let (elements, error) = saxParse "xmpp" inStr
          stanzas = parseXmpp (Handlers defaultMsgHandlers jabberIqAuthHandlers) (filter isNotPI elements)
--      forkIO $ mapM_ (print . ppSaxElement) elements
      runConsumerT readerLoop' stanzas
      return ()
    where
      isNotPI (SaxProcessingInstruction _) = False
      isNotPI _ = True
      readerLoop' =
          do (Just s) <- next
             case s of
               Stream ->
                   let jid = (JID (Just (Config.userinfo Config.config)) (Config.host Config.config) (Just (Config.name Config.config)))
                   in
                     do mpasswd <- liftIO (handleJust ioErrors (const (return "")) $
                                                      readFile ("State/" ++ (Config.host Config.config) ++"-passwd"))
                        handleAuth h jid (fromMaybe "" (readM mpasswd)) (Config.host Config.config)
                        liftIO $ mapM_ (\r -> (putStrLn $  "joining " ++ r) >> let j = (join_ r) in (print (j :: CFilter ()) >> send h j)) (Config.autojoin Config.config)
               (Message mTo mFrom mMT mLang children) ->
                   case msgBody children of
                     Nothing -> return ()
                     (Just msg) -> 
                         io $ do putStrLn $ "<" ++ maybe "unknown" formatJID mFrom ++ "> " ++ msg
                                 case xNode children of
                                   Nothing -> 
                                       do writeChan chanr (Just (toIrcMessage (fromJust mTo) (fromJust mFrom) mMT msg))
                                          print ("as irc message: " ++ show (Just (toIrcMessage (fromJust mTo) (fromJust mFrom) mMT msg)))
                                   (Just attrs) -> putStrLn "ignoring msg with x node"
               o -> return () -- liftIO $ putStrLn $ "Received: " ++ show o
             readerLoop'
{-# INLINE readerLoop #-}


toIrcMessage :: JID -> JID -> Maybe MessageType -> String -> IRC.IrcMessage
toIrcMessage to from mMT msg =
    IRC.IrcMessage { IRC.msgPrefix = fromAsIrcName from
                   , IRC.msgCommand = "PRIVMSG"
                   , IRC.msgParams = [(toAsIrcName to from mMT), ':':msg]
                   }
    where
      fromAsIrcName :: JID -> String
      fromAsIrcName (JID node domain resource) =
          (maybe "" (\r -> r ++ "!") resource) ++ (fromMaybe "" node) ++ ('@' : domain)
      -- needs to escape/unescape spaces, etc ?

      -- this is a bit of a hack, in IRC-land tell if a message was
      -- sent to a channel or a single user by looking at who it was
      -- sent to.
      -- but in jabber-land we look at who it came from and what the
      -- message type is.

      -- the code in doPRIVMSG' does checks to figure out if a message
      -- was sent to just the bot or to a whole channel and replies
      -- appropriately. I believe the check works by looking to see if
      -- lambdabot is in to reciever list or not. This check currently
      -- always fails after the jabber<->irc conversion. It will
      -- always think it is replying to a channel (aka, it should send
      -- its reply to the receiver, not the send). So, we hack it by
      -- sticking the appropriate reply address in the to field.
      toAsIrcName :: JID -> JID -> Maybe MessageType -> String
      toAsIrcName _ (JID node domain resource) (Just GroupChat) =
          (fromMaybe "" node) ++ ('@' : domain)
      toAsIrcName _ (JID node domain resource) _ =
          (maybe "" (\r -> r ++ "!") resource) ++ (fromMaybe "" node) ++ ('@' : domain)
{-# INLINE toIrcMessage #-}

-- FIXME: use Config.config for myJID
-- FIXME: don't use head and tail
sendIrcMessage :: Handle -> IRC.IrcMessage -> IO ()
sendIrcMessage h msg =
    let (to, msgType) = ircNickToJID (head (IRC.msgParams msg))
        from = (JID (Just (Config.userinfo Config.config)) (Config.host Config.config) (Just (Config.name Config.config)))
    in
      XMPP.send h $ message to from (Just msgType) Nothing [mkBody (tail (concat (tail ((IRC.msgParams msg) :: [String])))) ]
    where
      -- FIXME: handle other cases
      ircNickToJID :: String -> (JID, MessageType)
      ircNickToJID str =
          case matchRegex (mkRegex "(.*)!(.*)@(.*)") str of
            Just [nick,user,domain] -> (JID (Just user) domain (Just nick), Chat)
            _ -> case matchRegex (mkRegex "(.*)@(.*)") str of
                   Just [user,domain] -> (JID (Just user) domain Nothing, GroupChat)
                   _ -> error $ "Could not convert " ++ str ++ " into a jabber id"

writerLoop :: ThreadId -> Pipe IrcMessage -> Handle -> MVar () -> MVar () -> IO ()
writerLoop th chanw h _ _ = 
    handleIO th $ 
             do hPutStrLn h "<stream:stream xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' to='chat.linspire.com'>"
                writerLoop'
    where
      writerLoop' = do    
        mmsg <- readChan chanw
        putStrLn $ "writerLoop " ++ show mmsg
        case mmsg of
          Nothing -> return ()
          Just msg ->
              case IRC.msgCommand msg of
                "PRIVMSG" -> 
                  do -- print (IRC.msgParams msg)
                     sendIrcMessage h msg
                "JOIN" ->
                  case IRC.msgParams msg of
                    [loc] -> send h $ join_ loc
                    _ -> putStrLn $ "JOIN message seems malformed: " ++ show msg
                o -> putStrLn $ "unhandled irc command " ++ o
        writerLoop'
{-# INLINE writerLoop #-}

-- | convenience:
io :: forall a (m :: * -> *). (MonadIO m) => IO a -> m a
io = liftIO
{-# INLINE io #-}

-- Thread handler, just catch particular things we want to throw out to
-- the main thread, to force an exit. errorCalls are used by the
-- reader/writer loops to exit. ioErrors are probably sockets closing.
handleIO :: ThreadId -> IO () -> IO ()
handleIO th = handleJust
    (\e -> case () of { _
                | Just _ <- errorCalls e -> Just e
                | Just _ <- ioErrors   e -> Just e
                | otherwise              -> Nothing
    }) (\e -> throwTo th (error (show e)))

-- * Helper functions

-- |join chatroom
join :: String -> String -> String -> CFilter i
join room server nick =
    presence (Just (JID (Just room) server (Just nick))) myJID Nothing Nothing [xnode  [ ("xmlns", "http://jabber.org/protocol/muc")] []]

join_ :: String -> CFilter i
join_ loc =
    let (room, server) = extractRoomServer loc
    in
      join room server (Config.name Config.config)
    where
      extractRoomServer str =
          let (room, server) = span (/= '@') str
          in (room, dropWhile (== '@') server)

myJID = (JID (Just (Config.userinfo Config.config)) (Config.host Config.config) (Just (Config.name Config.config)))