matsuri-0.0.3: 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.MUC
import Control.Concurrent
import Control.Concurrent.MVar
import Data.Maybe
import Data.List
import qualified Data.Map as M


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

                  items <- getRoster
                  mapM_ (put mev . insChat) items
                  -- create groups; if roster item doesn't have any
                  -- groups then it's element of default group from
                  -- config
                  mapM_ (put mev . insGroup items) (groups items)
                  put mev $ insDefaultGroup items
                  put mev $ insConferencesGroup

                  sendPresence Nothing (Just $ priority acc)
                  -- set handlers
                  handleVersion (getCF "client" config)
                                (getCF "version" config)
                                (getCF "OS" config)
                  addHandler isPresence (presenceCB mev k) True
                  addHandler isChat (chatCB mev k) True
                  addHandler isGroupchatPresence (roomPresenceCB mev k) True
                  addHandler isGroupchatMessage (roomCB mev k) True
                  ---
                else put mev $ insConn NoConnection
        return $ doBuf Trying
      _ -> return (BufAccount acc)
  where
    k = accName acc
    insConn = InsBuffer k . doBuf
    doBuf conn = BufAccount acc{connection=conn}

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

    insGroup items name = insGroup' (name `elem`) items name
    insDefaultGroup items = insGroup' null items (getCF "default_group" config)
    insConferencesGroup = InsBuffer conf_group
                          $ BufGroup $ Group conf_group False []
      where conf_group = k++"|"++getCF "conferences_group" config
    groups = nub . concat . map itemGroups
    insGroup' p items name = InsBuffer (k++"|"++name) (grp p name items)
    grp p name = BufGroup . Group (k++"|"++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 = put mev . NewStatus (acc++"|"++jid)


-- | Send chat message.
sendChatMessage :: Account -> Chat -> String -> IO Buffer
sendChatMessage acc chat msg = case connection acc of
    OK c _ -> do
      runXMPP c $ 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
    (jid, res, body, time, isHistory) <- liftIO $ readStanza stanza
    let msg = time++" <= "++body
        msg' = if isHistory then HistoryMsg msg else Msg msg

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


-- | Join room.
joinRoom :: Account -> String -> IO Buffer
joinRoom acc room = case connection acc of
    OK c _ -> do
      let name = accName acc++"|"++room
          nick = defaultNick acc
      runXMPP c $ joinGroupchat nick room Nothing
      return $ BufRoom $ Room name [] nick "" (M.empty)


-- | Send room message.
sendRoomMessage :: Account -> Room -> String -> IO ()
sendRoomMessage acc room msg = case connection acc of
    OK c _ -> runXMPP c $ sendGroupchatMessage jid msg
    where
      jid = name (roomName room)


-- | Callback for room presences.
roomPresenceCB :: MVar MEvent -> String -> StanzaHandler
roomPresenceCB mev acc stanza = do
    time <- liftIO $ nowTime
    case getAttr "type" stanza of
      Nothing ->
          let msg = InfoMsg (time++" ** Join: "++show occ)
          in put mev $ RoomPresence Join k occ msg
      Just "unavailable" ->
          let msg = InfoMsg (time++" ** Leave: "++show occ)
          in put mev $ RoomPresence Leave k occ msg
      _ -> return ()
  where
    occ = doOccupant stanza
    (conf_jid, _) = getJidRes stanza
    k = acc++"|"++conf_jid


-- | Callback for room messages.
roomCB :: MVar MEvent -> String -> StanzaHandler
roomCB mev acc stanza = do
    (room, nick, body, time, isHistory) <- liftIO $ readStanza stanza
    let msg = time++" <"++nick++"> "++body
        subj = getMessageSubject stanza
        header = time++" ** Topic: "++nick++"\n"
        msg_subj = header++fromMaybe "" subj
        msg' | isJust subj = (Nothing,   msg_subj, Just msg_subj)
             | isHistory   = (Nothing,   msg,      Nothing      )
             | otherwise   = (Just nick, msg,      Nothing      )

    put mev $ NewRoomMsg (acc++"|"++room) msg'


---
readStanza stanza = do
    time <- time'
    return (jid, res, body, time, isHistory)
  where
    (jid, res) = getJidRes stanza
    body = maybe "" id (getMessageBody stanza)
    stamp = getMessageStamp stanza
    isHistory = isJust stamp
    time' | isHistory = utcToZoned $ maybe "" id stamp
          | otherwise = nowTime

put m = liftIO . putMVar m