diff --git a/Buffers.hs b/Buffers.hs --- a/Buffers.hs +++ b/Buffers.hs @@ -35,38 +35,40 @@ show (BufGroup grp) = coll++name (grpName grp) where coll = if grpCollapsed grp then " +++ " else " --- " - show (BufChat chat) = " "++(show $ status chat)++ - " "++(itemJid $ item chat) + show (BufChat chat) = " ["++(show $ status chat)++ + "] "++(itemJid $ item chat) show (BufRoom room) = " "++mark occ++" "++name (roomName room) where - mark (Just occ') = roomBrackets occ' 'C' True + -- replace +{o} to +{C} + fix (c:_:cs) = (reverse cs)++"C"++[c] + -- do conf mark (+{C}, -[C], +, etc) + mark (Just occ') = fix $ reverse $ roomBrackets occ' True mark _ = " [C]" occ = M.lookup (roomNick room) (roomOccupants room) +-- tmp name = drop 1 . dropWhile (/='|') instance Show Status where - show (Status StatusOnline _) = "[o]" - show (Status StatusAway _) = "[a]" - show (Status StatusChat _) = "[c]" - show (Status StatusDND _) = "[d]" - show (Status StatusXA _) = "[n]" - show (Status StatusOffline _) = "[_]" + show (Status StatusOnline _) = "o" + show (Status StatusAway _) = "a" + show (Status StatusChat _) = "c" + show (Status StatusDND _) = "d" + show (Status StatusXA _) = "n" + show (Status StatusOffline _) = "_" instance Show Occupant where - show occ = br ++ nick ++ jid + show occ = br ++ nick where - br = roomBrackets occ 'o' False + br = roomBrackets occ False nick | null br = occNick occ | otherwise = " " ++ occNick occ - jid = maybe "" (\j -> " ["++j++"]") (occJid occ) -- | Draw room brackets (<>, {} or []). roomBrackets :: Occupant - -> Char -- ^ char between the brackets (C, o, a, etc) -> Bool -- ^ draw or not default status ([o]) -> String -roomBrackets occ s always = +roomBrackets occ always = role++(aff (occAffiliation occ)) where role = role' (occRole occ) @@ -75,25 +77,40 @@ role' _ | always = " " | otherwise = "" --- + s = head $ show (occStatus occ) + --- aff AOwner = '<':s:'>':[] aff AAdmin = '{':s:'}':[] aff _ | always || (not $ null role) = '[':s:']':[] | otherwise = "" -- | Draw all room occupants (like /names in irssi). -showOccupants :: [Occupant] -> Int -> String +showOccupants :: Occupants -> Int -> String showOccupants occs w = "Names:\n"++ (intercalate "\n" $ map concat $ chunk row occs') where - occs' = map drawOcc occs + occs' = map drawOcc (M.elems occs) drawOcc occ - = (take' (len-1) ' ' $ roomBrackets occ 'o' True + = (take' (len-1) ' ' $ roomBrackets occ True ++ " " ++ occNick occ) ++ " " row = (w - offset) `div` len len = 23 offset = 9 +-- | Show room list (like /names, using many columns). +showRoomList :: [(String, Maybe String)] -> Int -> String +showRoomList list w = + "List:\n"++ + (intercalate "\n" $ map concat $ chunk row list') + where + list' = map drawElem list + drawElem (l, _) = take' (len-1) ' ' l ++ " " + row = (w - offset) `div` len + len = 23 + offset = 9 + + -- GDAT data Account = Account @@ -113,9 +130,15 @@ | NoConnection | Trying +-- TODO: check for connection? +getC :: Account -> TCPConnection +getC acc = let OK c _ = connection acc + in c + data Group = Group { grpName :: String , grpCollapsed :: Bool + , grpContents :: [Content] , grpItems :: [String] } @@ -131,26 +154,25 @@ , roomContents :: [Content] , roomNick :: String , roomSubject :: String - , roomOccupants :: M.Map String Occupant + , roomOccupants :: Occupants } +type Occupants = M.Map String Occupant -- | New contents goes at top for more eaiser insert. data Content = Msg String | MyMsg String | HistoryMsg String | InfoMsg String + | ErrorMsg String -- | Event which pushed/popped from/to MVar. data MEvent = VtyEvent Event | InsBuffer Key Buffer | NewMsg Key Content - | NewRoomMsg Key (Maybe String, String, Maybe String) | NewStatus Key Status - | RoomPresence REvent String Occupant Content - --- | Room presence type. -data REvent = Join - | Leave + | NewRoomMsg Key (String, String, Maybe String, String, Bool) + | RoomPresence Key (GroupchatPresence, Occupant) + | RoomList Key [(String, Maybe String)] insElem :: Key -> Buffer -> Buffers -> Buffers diff --git a/Cmd.hs b/Cmd.hs new file mode 100644 --- /dev/null +++ b/Cmd.hs @@ -0,0 +1,188 @@ +-- | Cmd.hs +-- A module which parse command from user and return answer. + +module Cmd ( + doCmd +) where + +import Buffers +import Config +import Help +import Jabber +import Utils + +import Control.Monad +import Data.List +import Data.List.Utils + +-- TODO: tab auto-completion + + +-- | Execute user command. +doCmd mev config buffers acc cur str w = + case runParseCmd str of + Left err -> ins2cur_e err + Right args -> doCmd' args + where + -- connect + doCmd' ["connect"] = do + buffer <- connect mev config acc + return $ insElem'' (accName acc) buffer + -- disconnect + doCmd' ["disconnect"] = do + buffer <- disconnect acc + let buffers' = insElem'' (accName acc) buffer + buffers'' = killBuffers (accName acc++"|") buffers' + return buffers'' + -- join room + doCmd' ["join", room] = case connection acc of + OK _ _ | not $ isBuf k buffers -> do + buffer <- joinRoom acc Nothing room + let buffers' = insElem'' k buffer + buffers'' = case conf_group of + BufGroup grp -> insElem group (new_buf grp) buffers' + conf_group = getBuf group buffers + new_buf grp = BufGroup grp{grpItems = k:(grpItems grp)} + group = accName acc++"|"++getCF "conferences_group" config + return buffers'' + _ -> ins2cur_e "account not connected" + where + k = accName acc++"|"++room + -- show/set topic + doCmd' ("topic":args) | length args < 2 + = case getBuf cur buffers of + BufRoom room | null args -> ins2cur_i (roomSubject room) + BufRoom room -> setRoomSubject acc room (head args) >> skip + _ -> ins2cur_e "not a room" + -- set new nickname + doCmd' ["nick", nick] = case getBuf cur buffers of + BufRoom room -> do + joinRoom acc (Just nick) jid + return $ insElem'' cur (BufRoom room{roomNick=nick}) + where + jid = name $ roomName room + -- show room participants + doCmd' ["names"] = case getBuf cur buffers of + BufRoom room -> + ins2cur_i (showOccupants (roomOccupants room) w) + _ -> ins2cur_e "not a room" + -- room lists + doCmd' ["list", arg] = case getBuf cur buffers of + BufRoom room -> + getRoomList acc room arg >>= maybe (return buffers) ins2cur_e + _ -> ins2cur_e "not a room" + -- admin room + doCmd' (rank:arg:nOrJ:reason) + | (rank == "rank" || rank == "rankj") && + length reason < 2 = + if rank == "rank" then admin (Left nOrJ) arg reason + else admin (Right nOrJ) arg reason + where + admin nickOrJ arg reason = + case getBuf cur buffers of + BufRoom room -> + adminRoom acc room nickOrJ arg mReason + >>= maybe (return buffers) ins2cur_e + _ -> ins2cur_e "not a room" + where mReason | length reason == 0 = Nothing + | otherwise = Just $ head reason + -- simple + doCmd' ["help"] = ins2acc_i help_all + doCmd' ["nya"] = ins2cur_i "Nya-nya nya-nya nihao nya coda tsugeraha tsude karu saa!" + -- try find alias + doCmd' (cmd:params) | not $ null $ alias cmd = + let (cmd', params') = doArgs (alias cmd, params) + in case runParseCmd cmd' of + Left err -> ins2cur_e err + Right args | not $ null $ alias $ head args -> + ins2cur_e "looping aliases forbidden" + | otherwise -> + doCmd' (args++params') + -- unknown cmd + doCmd' _ = ins2cur_e $ "unknown `/"++str++"' command, try `/help'" + + --- + skip = return buffers + alias n = getCF ("alias "++n) config + insElem'' k v = insElem k v buffers + -- insert info to acc buffer (help) + ins2acc_i = withTime " == " >=> ins2acc . InfoMsg + ins2acc_e = withTime " !! " >=> ins2acc . ErrorMsg + ins2acc msg = return $ insElem'' (accName acc) (acc' msg) + acc' msg = BufAccount acc{accContents=msg:(accContents acc)} + -- insert info to current buffer + -- FIXME: looks ugly :/ + ins2cur_i = withTime " == " >=> ins2cur . InfoMsg + ins2cur_e = withTime " !! " >=> ins2cur . ErrorMsg + ins2cur msg = return $ insElem'' cur $ case getBuf cur buffers of + BufAccount _ -> acc' msg + BufGroup grp -> BufGroup grp{grpContents=msg:(grpContents grp)} + BufChat chat -> BufChat chat{chatContents=msg:(chatContents chat)} + BufRoom room -> BufRoom room{roomContents=msg:(roomContents room)} + + +-- | Run parser. +runParseCmd :: String -> Either String [String] +runParseCmd str = parseCmd Arg str "" [] + + +-- | Parse command from user like in shell with quotes and escaping. +parseCmd :: State -> String -> String -> [String] -> Either String [String] +-- end of input +parseCmd _ "" "" [] = Left "no input" +parseCmd Arg "" arg args = Right (args++[arg]) +parseCmd Quoted1 "" _ _ = Left "unbalansed quotes" +parseCmd Quoted2 "" _ _ = Left "unbalansed quotes" +parseCmd Spaces "" _ args = Right args + +parseCmd Arg (' ':cs) "" args = Left "empty argument" +parseCmd Arg (' ':cs) arg args = parseCmd Spaces cs "" (args++[arg]) +parseCmd Arg ('\\':' ':cs) arg args = parseCmd Arg cs (arg++" ") args +parseCmd Arg ('\\':'\\':cs) arg args = parseCmd Arg cs (arg++"\\") args +parseCmd Arg ( c :cs) arg args = parseCmd Arg cs (arg++[c]) args + +parseCmd Quoted1 ('\'':cs) "" args = Left "empty argument" +parseCmd Quoted1 ('\'':cs) arg args = parseCmd Spaces cs "" (args++[arg]) +parseCmd Quoted1 ('\\':'\'':cs) arg args = parseCmd Quoted1 cs (arg++"'") args +parseCmd Quoted1 ('\\':'\\':cs) arg args = parseCmd Quoted1 cs (arg++"\\") args +parseCmd Quoted1 ( c :cs) arg args = parseCmd Quoted1 cs (arg++[c]) args + +parseCmd Quoted2 ('"':cs) "" args = Left "empty argument" +parseCmd Quoted2 ('"':cs) arg args = parseCmd Spaces cs "" (args++[arg]) +parseCmd Quoted2 ('\\':'"':cs) arg args = parseCmd Quoted2 cs (arg++"\"") args +parseCmd Quoted2 ('\\':'\\':cs) arg args = parseCmd Quoted2 cs (arg++"\\") args +parseCmd Quoted2 ( c :cs) arg args = parseCmd Quoted2 cs (arg++[c]) args + +parseCmd Spaces (' ' :cs) _ args = parseCmd Spaces cs "" args +parseCmd Spaces ('\'':cs) _ args = parseCmd Quoted1 cs "" args +parseCmd Spaces ('"' :cs) _ args = parseCmd Quoted2 cs "" args +parseCmd Spaces ('\\':'\'':cs) _ args = parseCmd Arg cs "'" args +parseCmd Spaces ('\\':'"':cs) _ args = parseCmd Arg cs "\"" args +parseCmd Spaces ( c :cs) _ args = parseCmd Arg cs [c] args + + +-- | Parser states. +data State = Arg -- ^ arg without spaces + | Quoted1 -- ^ arg quoted with ' + | Quoted2 -- ^ arg quoted with " + | Spaces -- ^ spaces + + +-- | Add arguments to alias. Replace $1..$9 in alias to appropriate +-- argument. If no such argument then simply replace $1..$9 to "". +-- Example: alias cjr = join $1@conference.jabber.ru +-- /cjr test -> /join test@conference.jabber.ru +doArgs :: (String, [String]) -> (String, [String]) +doArgs (str, args) = + foldr (\i b@(str', args') -> + if (arg i) `isInfixOf` str' + then (replace (arg i) (getArg i) str', head' args') + else b + ) (str, args) [1..9] + where + arg i = '$':(show i) + len = length args + getArg i | i <= len = args!!(i-1) + | otherwise = "" + head' [] = [] + head' (_:xs) = xs diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -9,6 +9,7 @@ ) where import Buffers +import Help import Data.ConfigFile import qualified Data.Map as M @@ -36,7 +37,8 @@ readConfig :: FilePath -> IO (Config, Buffers) readConfig filePath = do home <- getHomeDirectory - fileCnt <- handle (\_ -> return "[main]") (readFile (home++"/"++filePath)) + fileCnt <- handle (\_ -> error help_noconfig) + (readFile (home++"/"++filePath)) confs <- runErrorT $ do conf <- readstring emptyCP fileCnt @@ -67,7 +69,9 @@ config in case value' of Just _ -> config' - Nothing -> configError ("unknown `"++option++"' option") + Nothing -> if "alias " `isPrefixOf` option + then M.insert option value config + else configError ("unknown `"++option++"' option") -- | Insert new account in buffer or exit with error if wrong options. doAccount :: (String, [(OptionSpec, String)]) -> Buffers -> Buffers diff --git a/Help.hs b/Help.hs --- a/Help.hs +++ b/Help.hs @@ -1,21 +1,31 @@ module Help ( + help_noconfig, help_all ) where -help_all :: String +-- TODO: normal help strings. + +help_noconfig = "\ +\No config file found. Copy matsurirc.example (shipped with the\ +\ package or get it from http://patch-tag.com/r/Kagami/matsuri/\ +\snapshot/current/content/raw/matsurirc.example) to ~/.matsurirc\ +\ and edit for you." + help_all = "\ \Commands:\n\ -\\n\ \/help -- this help message\n\ -\/c -- connect account\n\ -\/d -- disconnect account\n\ -\/j -- join to conference\n\ -\/topic -- show room topic\n\ +\/connect -- connect account\n\ +\/disconnect -- disconnect account\n\ +\/join -- join to conference\n\ +\/topic [topic] -- show/set room topic\n\ \/names -- show room participants (like in irssi)\n\ -\/q -- exit\n\ +\/rank -- set role/affiliation by nick\n\ +\/rankj -- set affiliation by jid\n\ +\/nick -- set room nick\n\ +\/list -- show room list\n\ +\/quit -- exit\n\ \\n\ \Hotkeys:\n\ -\\n\ \C-n C-p -- moves in roster\n\ \C-a C-f C-b C-e M-f M-b -- moves in edit box\n\ \C-v -- show/hide roster\n\ diff --git a/Jabber.hs b/Jabber.hs --- a/Jabber.hs +++ b/Jabber.hs @@ -18,44 +18,49 @@ 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) +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 + 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) + 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 @@ -66,27 +71,28 @@ 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 [] + $ 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 + 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) +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. @@ -104,73 +110,210 @@ -- | 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)} +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 + 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) +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 room message. +-- | Send message to room. +-- TODO: check if not in room? 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) +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 - 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 + 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 - 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) (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' } - put mev $ NewRoomMsg (acc++"|"++room) msg' + +-- | 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 ) --- diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -5,6 +5,7 @@ import Buffers import Config +import Cmd import Help import Jabber import UI @@ -50,43 +51,39 @@ InsBuffer k buffer -> insElem' k buffer --- NewMsg k msg -> case getBuf k buffers of - BufChat chat -> + BufChat chat -> let contents = msg:(chatContents chat) in insElem' k $ BufChat chat{chatContents=contents} - _ -> skip + BufRoom room -> + let contents = msg:(roomContents room) + in insElem' k $ BufRoom room{roomContents=contents} + _ -> skip --- + NewStatus k status' -> case getBuf k buffers of + BufChat chat -> insElem' k $ BufChat chat{status=status'} + _ -> skip + --- NewRoomMsg k ev -> case getBuf k buffers of - BufRoom room -> - let (cnt, subj) = case ev of - -- history - (Nothing, msg, Nothing ) -> (HistoryMsg msg, Nothing) - -- set subject - (Nothing, msg, Just _ ) -> (InfoMsg msg, Just msg) - -- just msg - (Just nick, msg, _ ) - | nick == roomNick room -> (MyMsg msg, Nothing) - | otherwise -> (Msg msg, Nothing) - cnts = cnt:(roomContents room) - subj' = maybe (roomSubject room) id subj - in insElem' k $ BufRoom room{ roomContents = cnts - , roomSubject = subj' } - _ -> skip + BufRoom room -> insElem' k (updRoom ev room) + _ -> skip --- - NewStatus k status' -> case getBuf k buffers of - BufChat chat -> insElem' k $ BufChat chat{status=status'} - _ -> skip + RoomPresence k presence -> case getBuf k buffers of + BufRoom room -> do + (cnt, occs) <- updateRoomOccupants presence + (roomOccupants room) + (roomNick room) + let buf = BufRoom room{ roomContents=cnt++(roomContents room) + , roomOccupants=occs } + insElem' k buf + _ -> skip --- - RoomPresence ev k occupant msg -> case getBuf k buffers of - BufRoom room -> - let buf = BufRoom room{roomContents=msg:(roomContents room) - ,roomOccupants=occs' } - nick = occNick occupant - occs = roomOccupants room - occs' = case ev of - Join -> M.insert nick occupant occs - Leave -> M.delete nick occs - in insElem' k buf - _ -> skip + RoomList k list -> case getBuf k buffers of + BufRoom room -> do + w <- getW' + info <- withTime " == " (showRoomList list w) + let cnts = (InfoMsg info):(roomContents room) + insElem' k $ BufRoom room{roomContents=cnts} + _ -> skip --- VtyEvent event' -> case event' of -- roster @@ -121,25 +118,15 @@ EvKey KDel [] -> rerender' $ st { edit = E.delete edit } -- parse command || send message EvKey KEnter [] -> case E.contents edit of - "/q" -> return () - ('/':'/':msg) -> undefined --TODO: send `/msg' + content | words content == ["/quit"] -> return () + ('/':'/':msg) -> sendMsg ('/':msg) ('/':cmd) -> do - buffers' <- parseCmd (words cmd) + w <- getW' + buffers' <- doCmd mev config buffers acc cur cmd w let st' = st { edit = E.empty edit , roster = mkListBox roster buffers' } rerender mev vty st' config buffers' - msg -> case getBuf cur buffers of - BufRoom room -> do - sendRoomMessage acc room (E.contents edit) - let st' = st { edit = E.empty edit } - rerender mev vty st' config buffers - BufChat chat -> do - buffer <- sendChatMessage acc chat (E.contents edit) - let buffers' = insElem cur buffer buffers - st' = st { edit = E.empty edit } - rerender mev vty st' config buffers' - _ -> skip - + msg -> sendMsg msg -- other EvResize w h -> rerender' $ resizeUI w h st EvKey (KASCII 'q') [MCtrl] -> return () @@ -147,62 +134,25 @@ where skip = mainLoop mev vty st config buffers rerender' st = rerender mev vty st config buffers + -- send msg to chat + sendMsg msg = case getBuf cur buffers of + -- fix copypaste? + BufChat chat -> do + buffer <- sendChatMessage acc chat msg + let buffers' = insElem cur buffer buffers + st' = st { edit = E.empty edit } + rerender mev vty st' config buffers' + BufRoom room -> do + sendRoomMessage acc room msg + let st' = st { edit = E.empty edit } + rerender mev vty st' config buffers + _ -> skip -- insert new element in buffer (or simply replace old element) -- and re-create roster tree insElem' k buffer = let buffers' = insElem k buffer buffers st' = st { roster = mkListBox roster buffers' } in rerender mev vty st' config buffers' - -- connect - parseCmd ["c"] = do - buffer <- connect mev config acc - return $ insElem (accName acc) buffer buffers - -- disconnect - parseCmd ["d"] = do - buffer <- disconnect acc - let buffers' = insElem (accName acc) buffer buffers - buffers'' = killBuffers (accName acc++"|") buffers' - return buffers'' - -- join room - parseCmd ["j", room] = case connection acc of - OK _ _ | not $ isBuf k buffers -> do - buffer <- joinRoom acc room - let buffers' = insElem k buffer buffers - buffers'' = case conf_group of - BufGroup grp -> insElem group (new_buf grp) buffers' - conf_group = getBuf group buffers - new_buf grp = BufGroup grp{grpItems = k:(grpItems grp)} - group = accName acc++"|"++getCF "conferences_group" config - return buffers'' - _ -> return buffers - where - k = accName acc++"|"++room - -- show/set topic - parseCmd ["topic"] = case getBuf cur buffers of - BufRoom room -> ins2room (roomSubject room) - _ -> return buffers - -- show room participants - parseCmd ["names"] = case getBuf cur buffers of - BufRoom room -> do - -- FIXME: looks like monkey code :/ - DisplayRegion w h <- display_bounds $ terminal vty - time <- nowTime - let roster_width = if null $ getCF "show_roster" config - then 0 - else read $ getCF "roster_width" config - textbox_width = (fromIntegral w) - roster_width - occs = showOccupants (M.elems $ roomOccupants room) textbox_width - ins2room (time++" !! "++occs) - _ -> return buffers - -- simple - parseCmd ["help"] = ins2acc help_all - parseCmd ["t"] = parseCmd ["j", "matsuri@conference.jabber.ru"] - parseCmd ["nya"] = ins2acc "Nya-nya nya-nya nihao\ - \ nya coda tsugeraha\ - \ tsude karu saa!" - parseCmd unknown_cmd = ins2acc $ "unknown `/" - ++ unwords unknown_cmd - ++ "' command, try `/help'" -- current account acc = case getBuf cur buffers of BufAccount acc' -> acc' @@ -212,14 +162,14 @@ where getAcc' name = getAcc (takeWhile (/='|') name) buffers -- current buffer cur = L.cur roster - -- insert message into buffer contents - ins2acc msg = return $ insElem (accName acc) (acc' msg) buffers - acc' msg = BufAccount acc{accContents=(InfoMsg msg):(accContents acc)} - ins2room msg = return $ case getBuf cur buffers of - BufRoom room -> insElem cur (room' room msg) buffers - _ -> buffers - room' room msg - = BufRoom room{roomContents=(InfoMsg msg):(roomContents room)} + -- get textbox width + getW' = do + w <- getW vty + let roster_width = if null $ getCF "show_roster" config + then 0 + else read $ getCF "roster_width" config + textbox_width = w - roster_width - 1 + return textbox_width rerender mev vty st config buffers diff --git a/UI.hs b/UI.hs --- a/UI.hs +++ b/UI.hs @@ -42,6 +42,7 @@ where tb = case getBuf (L.cur roster) buffers of BufAccount acc -> mkTextBox (accContents acc) config + BufGroup grp -> mkTextBox (grpContents grp) config BufChat chat -> mkTextBox (chatContents chat) config BufRoom room -> mkTextBox (roomContents room) config _ -> mkTextBox [] config @@ -51,11 +52,12 @@ mkTextBox :: [Content] -> Config -> TextBox mkTextBox cnts config = TextBox $ map cnt2line cnts where - -- todo: read colors from config + -- TODO: read colors from config cnt2line (Msg msg) = (def_attr, msg) cnt2line (MyMsg msg) = (fore yellow, msg) cnt2line (HistoryMsg msg) = (fore cyan, msg) cnt2line (InfoMsg msg) = (fore cyan, msg) + cnt2line (ErrorMsg msg) = (fore magenta, msg) mkListBox :: L.ListBox -> Buffers -> L.ListBox diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -2,18 +2,35 @@ -- A module for some helper functions. module Utils ( + getW, nowTime, + withTime, utcToZoned, take' ) where +import Graphics.Vty import System.Locale import Data.Time.LocalTime import Data.Time.Format + +-- | Get vty width. +getW :: Vty -> IO Int +getW vty = do + DisplayRegion w h <- display_bounds $ terminal vty + return $ fromIntegral w + -- | Print current time. +nowTime :: IO String nowTime = getZonedTime >>= format +-- | Simple helper. +withTime :: String -> String -> IO String +withTime p str = do + time <- nowTime + return $ time++p++str + -- | Convert UTC string (from jabber:x:delay) to zoned. utcToZoned :: String -> IO String utcToZoned t = (utcToLocalZonedTime $ @@ -22,6 +39,7 @@ format = return . formatTime defaultTimeLocale "%H:%M:%S" -- | Do defined list width. +take' :: Int -> a -> [a] -> [a] take' n add lst = if length lst < n then lst ++ replicate (n - length lst) add else take n lst diff --git a/Widgets/ListBox.hs b/Widgets/ListBox.hs --- a/Widgets/ListBox.hs +++ b/Widgets/ListBox.hs @@ -4,6 +4,8 @@ -- ListBox widget. module Widgets.ListBox where +import Utils + import Graphics.Vty import Graphics.Vty.Widgets.Base @@ -66,6 +68,3 @@ --- cur l = snd $ (items l)!!(selectedIndex l) -take' n add lst = if length lst < n - then lst ++ replicate (n - length lst) add - else take n lst diff --git a/matsuri.cabal b/matsuri.cabal --- a/matsuri.cabal +++ b/matsuri.cabal @@ -1,5 +1,5 @@ Name: matsuri -Version: 0.0.3 +Version: 0.0.4 Category: Network Synopsis: ncurses XMPP client License: GPL @@ -19,10 +19,11 @@ Executable matsuri Main-Is: Main.hs - Other-Modules: Buffers, Config, Help, Jabber, UI, Utils, + Other-Modules: Buffers, Config, Cmd, Help, Jabber, UI, Utils, Widgets.EditBox, Widgets.PrettyBorders, Widgets.TextBox, Widgets.ListBox Build-Depends: base >= 4 && < 5, vty >= 4, vty-ui >= 0.2, containers, mtl, network, split, directory, - ConfigFile, XMPP==0.1.1, time, old-locale + ConfigFile, XMPP==0.1.2, time, old-locale, + MissingH diff --git a/matsurirc.example b/matsurirc.example --- a/matsurirc.example +++ b/matsurirc.example @@ -1,5 +1,9 @@ [main] client = matsuri +alias c = connect +alias d = disconnect +alias j = join +alias cjr = join $1@conference.jabber.ru [account_test] username = test_username