matsuri 0.0.3 → 0.0.4
raw patch · 11 files changed
+568/−227 lines, 11 filesdep +MissingHdep ~XMPP
Dependencies added: MissingH
Dependency ranges changed: XMPP
Files
- Buffers.hs +46/−24
- Cmd.hs +188/−0
- Config.hs +6/−2
- Help.hs +18/−8
- Jabber.hs +225/−82
- Main.hs +54/−104
- UI.hs +3/−1
- Utils.hs +18/−0
- Widgets/ListBox.hs +2/−3
- matsuri.cabal +4/−3
- matsurirc.example +4/−0
Buffers.hs view
@@ -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], +<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
+ Cmd.hs view
@@ -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
Config.hs view
@@ -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
Help.hs view
@@ -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 <room@service> -- join to conference\n\-\/topic -- show room topic\n\+\/connect -- connect account\n\+\/disconnect -- disconnect account\n\+\/join <room@service> -- join to conference\n\+\/topic [topic] -- show/set room topic\n\ \/names -- show room participants (like in irssi)\n\-\/q -- exit\n\+\/rank <kick/vis/part/mod/ban/none/mem/adm/own> -- set role/affiliation by nick\n\+\/rankj <ban/none/mem/adm/own> -- set affiliation by jid\n\+\/nick <nick> -- set room nick\n\+\/list <ban/mem/adm/own> -- 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\
Jabber.hs view
@@ -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 ) ---
Main.hs view
@@ -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
UI.hs view
@@ -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
Utils.hs view
@@ -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
Widgets/ListBox.hs view
@@ -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
matsuri.cabal view
@@ -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
matsurirc.example view
@@ -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