matsuri-0.0.2: 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
import Data.List


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
                  put $ insConn (OK c tId)

                  items <- getRoster
                  mapM_ (put . insChat c) items
                  -- create groups; if roster item doesn't have any
                  -- groups then it's element of "other" group
                  mapM_ (put . insGroup items) (groups items)
                  put $ insOtherGroup items

                  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 put $ insConn NoConnection
        return $ doBuf Trying
      _ -> return (BufAccount acc)
  where
    put = liftIO . putMVar mev
    k = accName acc
    insConn = InsBuffer k . doBuf
    doBuf conn = BufAccount acc{connection=conn}

    insChat c item = InsBuffer (chatName' item) (item2chat c item)
    item2chat c item = BufChat (Chat item offline (chatName' item) c [])
    offline = Status StatusOffline []
    chatName' item = k++"|"++itemJid item

    insGroup items name = insGroup' (name `elem`) items name
    insOtherGroup items = insGroup' null items "other"
    groups = nub . concat . map itemGroups
    insGroup' p items name = InsBuffer (k++"|"++name) (grp p name items)
    grp p name = BufGroup . Group name False . grpItems' p name
    grpItems' p name
      = map chatName' . filter (p . itemGroups)


-- | 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'