matsuri-0.0.4: 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
                addHandler (iqError "http://jabber.org/protocol/muc#admin")
                           (roomIqErrorsCB mev k)
                           True
                addHandler (iqResult "http://jabber.org/protocol/muc#admin")
                           (roomIqListCB 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

    -- FIXME: monkey code
    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
    -- TODO: ability for disconnect 'Trying connection'
    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 = do
    runXMPP (getC acc) $ 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 -> Maybe String -> String -> IO Buffer
joinRoom acc mNick room = do
    let name = accName acc++"|"++room
        nick = maybe (defaultNick acc) id mNick
    runXMPP (getC acc) $ joinGroupchat nick room Nothing
    return $ BufRoom $ Room name [] nick "" (M.empty)


-- | Send message to room.
-- TODO: check if not in room?
sendRoomMessage :: Account -> Room -> String -> IO ()
sendRoomMessage acc room msg =
    runXMPP (getC acc) $ sendGroupchatMessage jid msg
  where
    jid = name (roomName room)


-- | Set room's subject.
-- TODO: check if not in room?
setRoomSubject :: Account -> Room -> String -> IO ()
setRoomSubject acc room subj =
    runXMPP (getC acc) $ setGroupchatSubject jid subj
  where
    jid = name (roomName room)


-- | Callback for room presences.
roomPresenceCB :: MVar MEvent -> String -> StanzaHandler
roomPresenceCB mev acc stanza = do
    let k = acc++"|"++(fst $ getJidRes stanza)
    put mev $ RoomPresence k (doGroupchatPresence stanza)
-- | Update occupants with new presence.
updateRoomOccupants :: (GroupchatPresence, Occupant)
                    -> Occupants
                    -> String
                    -> IO ([Content], Occupants)
updateRoomOccupants (presence, occ) occs mynick = do
    time <- liftIO $ nowTime
    let header = time++prefix
        prefix | nick == mynick = " @@ "
               | otherwise      = " ** "
        nick = occNick occ
        -- ban or kick reason: " (reason)"
        r = maybe "" (\r' -> " ("++r'++")")
        -- jid: " [user@server/resource]"
        j = maybe "" (\j -> " ["++j++"]")
        jid = j (occJid occ)
        jid' = case M.lookup nick occs of
          Just old_occ -> j (occJid old_occ)
          _            -> ""
        Status _ ss = occStatus occ
        -- offline status: " (status)"
        stat | length ss == 0 = ""
             | otherwise      = " ("++head ss++")"
        del_occ msg1 msg2 =
          ( [InfoMsg $ header++msg1++show occ++jid'++msg2]
          , M.delete nick occs )

    return $ case presence of
      Leave -> del_occ "Leave: " stat
      Kick reason -> del_occ "Kick: " (r reason)
      Ban reason -> del_occ "Ban: " (r reason)
      NickChange new_nick ->
          let new_occ = occ{occNick = new_nick}
              header' | new_nick == mynick = time++" @@ "
                      | otherwise          = time++" ** "
          in ( [InfoMsg $ header'++"Nick: "++nick++" -> "++new_nick]
             , M.insert new_nick new_occ $ M.delete nick occs )
      RoleChange reason ->
          let cnt = case M.lookup nick occs of
                Just old_occ ->
                  if (occRole old_occ) == (occRole occ) &&
                     (occAffiliation old_occ) == (occAffiliation occ)
                  then [] -- no role changes
                  else [InfoMsg $ header++"Role: "++show old_occ++" -> "
                        ++show occ++r reason]
                Nothing -> [InfoMsg $ header++"Join: "++show occ++jid]
          in ( cnt
             , M.insert nick occ $ M.delete nick occs )


-- | 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
    put mev $ NewRoomMsg (acc++"|"++room) (nick, time, subj, msg, isHistory)
-- | Update room (new msg or new subject). Parse MyMsg or messages
-- with hightlight.
-- FIXME: signature looks ugly.
updRoom :: (String, String, Maybe String, String, Bool) -> Room -> Buffer
updRoom (from, time, subj, msg, isHistory) room =
    let subj' = maybe (roomSubject room) (("Topic: "++from++"\n")++) subj
        topic_prefix | roomNick room == from = " @@ "
                     | otherwise             = " ** "
        topic = time++topic_prefix++subj'
        fmsg | isHistory             = HistoryMsg
             | roomNick room == from = MyMsg
             | otherwise             = Msg
        -- topic or simple msg
        cnt | isJust subj = InfoMsg topic
            | otherwise   = fmsg msg
    in BufRoom room{ roomContents = cnt:(roomContents room)
                   , roomSubject = subj' }


-- | Do admin actions in room, such of kick or ban.
adminRoom :: Account
          -> Room
          -> Either Nick JID
          -> String -- ^Argument for affiliation or role
          -> Maybe String -- ^Reason
          -> IO (Maybe String) -- ^Error message
adminRoom acc room nickOrJid arg mReason =
    case arg of
        "kick" -> role "none"
        "vis"  -> role "visitor"
        "part" -> role "participant"
        "mod"  -> role "moderator"
        "ban"  -> affil "outcast"
        "none" -> affil "none"
        "mem"  -> affil "member"
        "adm"  -> affil "admin"
        "own"  -> affil "owner"
        _ -> return $ Just "unknown role/affiliation"
  where
    role r = case nickOrJid of
        Left nick -> admin nickOrJid r
        Right _ -> return $ Just "use nick instead of jid"
    affil a = case nickOrJid of
        -- find nick for jid
        Left nick -> maybe (return $ Just "no such member in room")
                           (\occ -> case occJid occ of
                                Just jid -> admin (Right jid) a
                                _ -> return $ Just "don't know nick's jid")
                           (nick2jid nick)
        -- just do admin
        Right _ -> admin nickOrJid a
    nick2jid nick = M.lookup nick (roomOccupants room)
    roomJid = name (roomName room)
    admin nickOrJid' arg = do
        runXMPP (getC acc) $ adminGroupchat nickOrJid' roomJid arg mReason
        return Nothing


-- | Callback for room iq errors.
roomIqErrorsCB :: MVar MEvent -> String -> StanzaHandler
roomIqErrorsCB mev acc stanza
  = liftIO $ withTime " !! server: " msg >>= put mev . NewMsg k . ErrorMsg
  where
    k = acc++"|"++(fst $ getJidRes stanza)
    msg = case getErrorCode stanza of
            403 -> "not allowed (403)"
            405 -> "not allowed (405)"
            406 -> "not in room (406)"
            err -> "unknown error ("++show err++")"


-- | Send iq for gettings room members/admins/owners/ban list.
-- TODO: move XML to XMPP library?
getRoomList :: Account -> Room -> String -> IO (Maybe String)
getRoomList acc room arg =
    case arg of
        "ban" -> iq "outcast"
        "mem" -> iq "member"
        "adm" -> iq "admin"
        "own" -> iq "owner"
        _     -> return $ Just "unknown list argument"
  where
    iq aff = (runXMPP (getC acc) $
               sendIq jid "get" [XML "query"
                                  [("xmlns","http://jabber.org/protocol/muc#admin")]
                                  [XML "item" [("affiliation",aff)] []]]
               >> return ())
             >> return Nothing
    jid = name (roomName room)
-- | Callback for getting room lists.
roomIqListCB :: MVar MEvent -> String -> StanzaHandler
roomIqListCB mev acc stanza | null list = return ()
                            | otherwise = liftIO $ put mev $ RoomList k list
  where
    k = acc++"|"++(fst $ getJidRes stanza)
    list = map listElem $ xmlPath' ["query","item"] [stanza]
    listElem xml = ( maybe "" id $ getAttr "jid" xml
                   , cdata' $ xmlPath ["reason"] xml )


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