matsuri-0.0.1: Jabber.hs

-- | Jabber.hs
-- A module for interaction with XMPP.

module Jabber where

import Buffers
import Config
import Utils

import Network
import Network.XMPP
import Network.XMPP.Presence
import Network.XMPP.Roster
import Network.XMPP.MUC
import Control.Concurrent
import Control.Concurrent.MVar
import Data.Maybe


connect :: MVar MEvent -> Config -> Account -> IO Buffer
connect mev config acc =
    case connection acc of
      NoConnection -> do
        forkIO $ do
            c <- openStream (server acc)
            getStreamStart c
            runXMPP c $ do
              err <- startAuth (username acc)
                               (server acc)
                               (password acc)
                               (resource acc)
              if err == 0
                then do
                  tId <- liftIO $ myThreadId
                  insConn (OK c tId)

                  mapM_ (liftIO . putMVar mev . insBuf c) =<< getRoster
                  sendPresence
                  -- set handlers
                  handleVersion (getCF "client" config)
                                (getCF "version" config)
                                (getCF "OS" config)
                  addHandler isChat (chatCB mev k) True
                  addHandler isPresence (presenceCB mev k) True
                  ---
                else insConn NoConnection
        return $ doBuf Trying
      _ -> return (BufAccount acc)
  where
    insConn = liftIO . putMVar mev . InsBuffer (accName acc) . doBuf
    doBuf conn = BufAccount acc{connection=conn}

    k = accName acc
    insBuf c item = InsBuffer (chatName' item) (item2buf c item)
    item2buf c item = BufChat (Chat item offline (chatName' item) c [])
    offline = Status StatusOffline []
    chatName' item = k++"|"++itemJid item


-- | Close account connection.
disconnect :: Account -> IO Buffer
disconnect account =
    case connection account of
      OK c tId -> do
        killThread tId
        closeConnection c
        return (BufAccount account{connection=NoConnection})
      _ -> return (BufAccount account)


-- | Status changes.
presenceCB :: MVar MEvent -> String -> StanzaHandler
presenceCB mev acc stanza = do
    let (jid, res) = getJidRes stanza
        presence = doPresence stanza
    case presence of
      Available status' -> putStatus jid status'
      Unavailable status' -> putStatus jid status'
      _ -> return ()
  where
    putStatus jid = liftIO . putMVar mev . NewStatus (acc++"|"++jid)


-- | Send chat message.
sendChatMessage :: Chat -> String -> IO Buffer
sendChatMessage chat msg = do
    runXMPP (chatConn chat) $ sendMessage (itemJid $ item chat) msg
    time <- nowTime
    let msg' = MyMsg $ time++" => "++msg
    return $ BufChat chat{chatContents=msg':(chatContents chat)}


-- | Callback for chat messages.
chatCB :: MVar MEvent -> String -> StanzaHandler
chatCB mev acc stanza = do
    let stamp = getMessageStamp stanza
        isHistory = isJust stamp
    time <- liftIO $ if isHistory
                     then utcToZoned $ maybe "" id stamp
                     else nowTime

    let (jid, res) = getJidRes stanza
        body = maybe "" id (getMessageBody stanza)
        msg = time++" <= "++body
        msg' = if isHistory then HistoryMsg msg else Msg msg

    liftIO $ putMVar mev $ NewMsg (acc++"|"++jid) msg'