matsuri 0.0.2 → 0.0.3
raw patch · 10 files changed
+385/−154 lines, 10 filesdep ~XMPP
Dependency ranges changed: XMPP
Files
- Buffers.hs +91/−28
- Config.hs +40/−31
- Help.hs +7/−4
- Jabber.hs +97/−32
- Main.hs +110/−34
- UI.hs +14/−5
- Utils.hs +7/−1
- Widgets/TextBox.hs +16/−16
- matsuri.cabal +2/−2
- matsurirc.example +1/−1
Buffers.hs view
@@ -4,57 +4,109 @@ module Buffers where -import Network.XMPP (TCPConnection)-import Network.XMPP.Roster (RosterItem(..))-import Network.XMPP.Presence (Status(..), StatusType(..))+import Utils++import Network.XMPP+import Network.XMPP.MUC import Control.Concurrent (ThreadId) import Graphics.Vty (Event) import qualified Data.Map as M import Data.List+import Data.List.Split+import Data.Maybe type Buffers = M.Map Key Buffer type Key = String-data Buffer = BufHelp [Content]- | BufAccount Account+data Buffer = BufAccount Account | BufChat Chat | BufGroup Group- | BufGroupchat Groupchat+ | BufRoom Room+ | BufUnknown -- ^ fallback buffer --- Show instances+-- show instances instance Show Buffer where- show (BufHelp _) = "[help]" show (BufAccount acc) = case connection acc of OK _ _ -> c:" [o] "++accName acc NoConnection -> c:" [_] "++accName acc Trying -> c:" [!] "++accName acc where c = if accCollapsed acc then '+' else '-'- show (BufGroup grp) = coll++grpName grp+ show (BufGroup grp) = coll++name (grpName grp) where coll = if grpCollapsed grp then " +++ " else " --- " show (BufChat chat) = " "++(show $ status chat)++ " "++(itemJid $ item chat)- show (BufGroupchat _) = ""+ show (BufRoom room)+ = " "++mark occ++" "++name (roomName room)+ where+ mark (Just occ') = roomBrackets occ' 'C' True+ mark _ = " [C]"+ occ = M.lookup (roomNick room) (roomOccupants room) +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 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+ where+ br = roomBrackets occ 'o' 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 =+ role++(aff (occAffiliation occ))+ where+ role = role' (occRole occ)+ role' RModerator = "+"+ role' RVisitor = "-"+ role' _ | always = " "+ | otherwise = ""+ ---+ 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 occs w =+ "Names:\n"+++ (intercalate "\n" $ map concat $ chunk row occs')+ where+ occs' = map drawOcc occs+ drawOcc occ+ = (take' (len-1) ' ' $ roomBrackets occ 'o' True+ ++ " " ++ occNick occ)+ ++ " "+ row = (w - offset) `div` len+ len = 23+ offset = 9 +-- GDAT+ data Account = Account { accName :: String , username :: String , server :: String , password :: String , resource :: String+ , priority :: Integer , defaultNick :: String , connection :: Connection , accCollapsed :: Bool+ , accContents :: [Content] } data Connection = OK TCPConnection ThreadId@@ -71,13 +123,15 @@ { item :: RosterItem , status :: Status , chatName :: String- , chatConn :: TCPConnection , chatContents :: [Content] } -data Groupchat = Groupchat- { groupchatContents :: [Content]- , groupchatNick :: String+data Room = Room+ { roomName :: String+ , roomContents :: [Content]+ , roomNick :: String+ , roomSubject :: String+ , roomOccupants :: M.Map String Occupant } -- | New contents goes at top for more eaiser insert.@@ -86,28 +140,37 @@ | HistoryMsg String | InfoMsg 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 + insElem :: Key -> Buffer -> Buffers -> Buffers insElem k = M.insert k -getAccount :: Key -> Buffers -> Maybe Account-getAccount cur buffers =- case M.lookup cur buffers of- Just (BufAccount account) -> Just account- _ -> Nothing+getAcc :: Key -> Buffers -> Account+getAcc k buffers =+ case M.lookup k buffers of+ Just (BufAccount acc) -> acc getBuf :: Key -> Buffers -> Buffer-getBuf cur buffers =- case M.lookup cur buffers of+getBuf k buffers =+ case M.lookup k buffers of Just buf -> buf- _ -> BufHelp []+ _ -> BufUnknown +isBuf :: Key -> Buffers -> Bool+isBuf k = isJust . M.lookup k++-- | Kill room should run leaveGroupchat killBuffers :: String -> Buffers -> Buffers killBuffers startswith = M.filterWithKey (\k _ -> not $ startswith `isPrefixOf` k)
Config.hs view
@@ -1,6 +1,5 @@ -- | Config.hs--- A module which parse config file and contain Config structure for--- further usage.+-- Config file reading; functions for working with config structure. module Config ( Config,@@ -24,10 +23,12 @@ -- | Default config. If no value in config file, then default value -- will be used. defaultConfig = [ ("client", "matsuri")- , ("version", "unknown")- , ("OS", "unknown")- , ("roster_width", "30")+ , ("version", "0.0.x")+ , ("OS", "LEENOOPS OS")+ , ("roster_width", "20") , ("show_roster", "1")+ , ("default_group", "other")+ , ("conferences_group", "conferences") ] @@ -36,28 +37,28 @@ readConfig filePath = do home <- getHomeDirectory fileCnt <- handle (\_ -> return "[main]") (readFile (home++"/"++filePath))- let def_conf = M.fromList defaultConfig confs <- runErrorT $ do conf <- readstring emptyCP fileCnt -- reading and updating main options mainOptions <- items conf "main"- let config = foldr updateValue def_conf mainOptions+ let def_conf = M.fromList defaultConfig+ config = foldr updateValue def_conf mainOptions -- reading account_* sections- let sects = filter (\acc -> take 8 acc == "account_") (sections conf)- accountsList <- forM sects $ \account -> do- accountItems <- items conf account- return (drop 8 account, accountItems)- let start = M.singleton "help" (BufHelp [])- accounts = foldr updateAccount start accountsList+ let sects' = filter ("account_" `isPrefixOf`) (sections conf)+ sects | length sects' == 0 = configError "no accounts"+ | otherwise = sects'+ readAcc acc = liftM2 (,) (return $ drop 8 acc) (items conf acc) - return (config, accounts)+ liftM2 (,)+ (return config)+ (mapM readAcc sects >>= return . foldr doAccount M.empty) case confs of- Left _ -> error "can't parse config file (wrong format)"+ Left _ -> configError "wrong format" Right conf -> return conf --- | Update option's value or exit with error if no such option.+-- | Update option's value or exit with error if find unknown option. updateValue :: (OptionSpec, String) -> Config -> Config updateValue (option, value) config = let (value', config') = M.updateLookupWithKey@@ -66,29 +67,37 @@ config in case value' of Just _ -> config'- Nothing -> error $ "can't parse config file\- \ (unknown \"" ++ option ++ "\" option)"+ Nothing -> configError ("unknown `"++option++"' option") --- | Update account in HashTable or exit with error if wrong options.-updateAccount :: (String, [(OptionSpec, String)]) -> Buffers -> Buffers-updateAccount (accountName, accountItems) =+-- | Insert new account in buffer or exit with error if wrong options.+doAccount :: (String, [(OptionSpec, String)]) -> Buffers -> Buffers+doAccount (accountName, accountOpts) = M.insert accountName (BufAccount Account { accName = accountName- , username = findItem "username"- , server = findItem "server"- , password = findItem "password"- , resource = findItem "resource"- , defaultNick = findItem "nick"+ , username = username'+ , server = findOpt "server"+ , password = findOpt "password"+ , resource = resource'+ , priority = priority'+ , defaultNick = defaultNick' , connection = NoConnection , accCollapsed = False+ , accContents = [] })- where findItem itemName =- case find (\(name, _) -> name == itemName) accountItems of- Just value -> snd value- _ -> error $ "can't parse config file\- \ (wrong \"" ++ accountName ++ "\" account options)"+ where+ username' = findOpt "username"+ resource' = maybe "matsuri" snd $ findOpt' "resource"+ priority' = maybe 0 (read . snd) $ findOpt' "priority"+ defaultNick' = maybe username' snd $ findOpt' "nick"++ findOpt opt = maybe (noOpt opt) snd $ findOpt' opt+ findOpt' optName = find (\(name, _) -> name == optName) accountOpts+ noOpt opt = configError ("can't find `'"++opt++"' option\+ \ for `"++accountName++"' account")++configError err = error ("can't read config file ("++err++")") getCF :: String -> Config -> String
Help.hs view
@@ -6,10 +6,13 @@ help_all = "\ \Commands:\n\ \\n\-\/help -- this help message\n\-\/c -- connect account\n\-\/d -- disconnect account\n\-\/q -- exit\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\+\/names -- show room participants (like in irssi)\n\+\/q -- exit\n\ \\n\ \Hotkeys:\n\ \\n\
Jabber.hs view
@@ -9,13 +9,12 @@ 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+import qualified Data.Map as M connect :: MVar MEvent -> Config -> Account -> IO Buffer@@ -33,42 +32,48 @@ if err == 0 then do tId <- liftIO $ myThreadId- put $ insConn (OK c tId)+ put mev $ insConn (OK c tId) items <- getRoster- mapM_ (put . insChat c) items+ mapM_ (put mev . insChat) 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+ -- 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+ sendPresence Nothing (Just $ priority acc) -- set handlers handleVersion (getCF "client" config) (getCF "version" config) (getCF "OS" config)- addHandler isChat (chatCB mev k) True 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 $ insConn NoConnection+ else put mev $ 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 [])+ 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- insOtherGroup items = insGroup' null items "other"+ 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 name False . grpItems' p name+ grp p name = BufGroup . Group (k++"|"++name) False . grpItems' p name grpItems' p name = map chatName' . filter (p . itemGroups) @@ -94,30 +99,90 @@ Unavailable status' -> putStatus jid status' _ -> return () where- putStatus jid = liftIO . putMVar mev . NewStatus (acc++"|"++jid)+ putStatus jid = put 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)}+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- 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+ (jid, res, body, time, isHistory) <- liftIO $ readStanza stanza+ let msg = time++" <= "++body msg' = if isHistory then HistoryMsg msg else Msg msg - liftIO $ putMVar mev $ NewMsg (acc++"|"++jid) 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
Main.hs view
@@ -8,8 +8,10 @@ import Help import Jabber import UI+import Utils import Network+import Network.XMPP.MUC import Control.Concurrent import Control.Concurrent.MVar import qualified Data.Map as M@@ -47,20 +49,47 @@ case event of InsBuffer k buffer -> insElem' k buffer ---- NewMsg k msg ->- case getBuf k buffers of- BufChat chat -> do+ NewMsg k msg -> case getBuf k buffers of+ BufChat chat -> let contents = msg:(chatContents chat)- insElem' k $ BufChat chat{chatContents=contents}+ in insElem' k $ BufChat chat{chatContents=contents} _ -> skip ---- NewStatus k status' ->- case getBuf k buffers of+ 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+ ---+ NewStatus k status' -> case getBuf k buffers of BufChat chat -> insElem' k $ BufChat chat{status=status'} _ -> 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+ --- VtyEvent event' -> case event' of- -- tree+ -- roster EvKey (KASCII 'p') [MCtrl] -> rerender' $ st { roster = L.moveUp roster } EvKey (KASCII 'n') [MCtrl] -> rerender' $ st { roster = L.moveDn roster } EvKey KEnter [] | E.contents edit == "" ->@@ -72,7 +101,6 @@ let buf = BufGroup grp{grpCollapsed = not $ grpCollapsed grp} in insElem' cur buf _ -> skip- -- show/hide EvKey (KASCII 'v') [MCtrl] -> let isShow = getCF "show_roster" config@@ -81,7 +109,7 @@ config' = setCF "show_roster" isShow' config in rerender mev vty st config' buffers - -- edit box+ -- editbox EvKey (KASCII c ) [] -> rerender' $ st { edit = E.insert c edit } EvKey (KASCII 'a') [MCtrl] -> rerender' $ st { edit = E.moveToHome edit } EvKey (KASCII 'f') [MCtrl] -> rerender' $ st { edit = E.moveRight edit }@@ -94,18 +122,22 @@ -- parse command || send message EvKey KEnter [] -> case E.contents edit of "/q" -> return ()+ ('/':'/':msg) -> undefined --TODO: send `/msg' ('/':cmd) -> do- buffers' <- parseCmd cmd+ buffers' <- parseCmd (words cmd) let st' = st { edit = E.empty edit- , roster = mkListBox roster buffers'- }+ , 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 chat (E.contents edit)- let buffers' = insElem cur buffer buffers- st' = st { edit = E.empty edit }- rerender mev vty st' config buffers'+ 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 -- other@@ -122,28 +154,72 @@ st' = st { roster = mkListBox roster buffers' } in rerender mev vty st' config buffers' -- connect- parseCmd "c" = case getAccount cur buffers of- Just acc -> do- buffer <- connect mev config acc- return $ insElem (accName acc) buffer buffers- _ -> ins2help (InfoMsg "can't connect: not an account")+ parseCmd ["c"] = do+ buffer <- connect mev config acc+ return $ insElem (accName acc) buffer buffers -- disconnect- parseCmd "d" = case getAccount cur buffers of- Just acc -> do- buffer <- disconnect acc- let buffers' = insElem cur buffer buffers- buffers'' = killBuffers (accName acc++"|") buffers'+ 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''- _ -> ins2help (InfoMsg "can't disconnect: not an account")- -- help- parseCmd "help" = ins2help (InfoMsg help_all)- parseCmd unknown_cmd = ins2help (InfoMsg $ "unknown `"++unknown_cmd++- "' command, try `/help'")- ---+ _ -> 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'+ BufGroup grp -> getAcc' (grpName grp)+ BufChat chat -> getAcc' (chatName chat)+ BufRoom room -> getAcc' (roomName room)+ where getAcc' name = getAcc (takeWhile (/='|') name) buffers+ -- current buffer cur = L.cur roster- ins2help cnt = return $ case getBuf "help" buffers of- BufHelp cnts -> insElem "help" (BufHelp $ cnt:cnts) buffers+ -- 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)} rerender mev vty st config buffers
UI.hs view
@@ -36,14 +36,16 @@ mkUI (UIState {..}) config buffers = (if null $ getCF "show_roster" config then tb <--> text def_attr ""- else roster <++> pVBorder def_attr <++> tb)+ else roster{L.listWidth=size} <++> pVBorder def_attr <++> tb) <--> text (back blue) "info" <--> edit where tb = case getBuf (L.cur roster) buffers of- BufHelp cnts -> mkTextBox cnts config+ BufAccount acc -> mkTextBox (accContents acc) config BufChat chat -> mkTextBox (chatContents chat) config+ BufRoom room -> mkTextBox (roomContents room) config _ -> mkTextBox [] config+ size = read $ getCF "roster_width" config mkTextBox :: [Content] -> Config -> TextBox@@ -58,10 +60,15 @@ mkListBox :: L.ListBox -> Buffers -> L.ListBox mkListBox roster buffers =- roster { L.items = items }+ roster { L.items = items+ , L.selectedIndex = newIndex } where+ -- new index+ newIndex = if L.selectedIndex roster < length items+ then L.selectedIndex roster+ else 0 -- all items- items = ("[help]", "help"):(concat $ map mkAcc accs)+ items = concat $ map mkAcc accs -- accounts accs = [ buf | buf@(BufAccount _) <- M.elems buffers ] ---@@ -71,12 +78,14 @@ then [] else concat $ map (mkGroup (accName acc)) (groups acc)) mkGroup k buf@(BufGroup grp)- = (show buf, k++"|"++grpName grp):+ = (show buf, grpName grp): (if grpCollapsed grp then [] else map mkChat $ grpBufs $ grpItems grp) mkChat buf@(BufChat chat) = (show buf, chatName chat)+ mkChat buf@(BufRoom room)+ = (show buf, roomName room) -- get acc groups groups acc = [ buf | buf@(BufGroup _) <- els ] where els = M.elems
Utils.hs view
@@ -3,7 +3,8 @@ module Utils ( nowTime,- utcToZoned+ utcToZoned,+ take' ) where import System.Locale@@ -19,3 +20,8 @@ readTime defaultTimeLocale "%Y%m%dT%H:%M:%S" t) >>= format format = return . formatTime defaultTimeLocale "%H:%M:%S"++-- | Do defined list width.+take' n add lst = if length lst < n+ then lst ++ replicate (n - length lst) add+ else take n lst
Widgets/TextBox.hs view
@@ -14,9 +14,9 @@ -- | At first goes bottom lines of text for more efficience insert. ----- line3--- [line1, line2, line3] -> line2 -- line1+-- [line3, line2, line1] -> line2+-- line3 -- -- TODO: scrolling, box sizes data TextBox = TextBox [TextLine]@@ -35,20 +35,20 @@ where fill = char_fill def_attr ' ' w (h - (length ls')) ls' = reverse $ take h $ concat $ map wrapLine ls- -- do text lines with fixed width- wrapLine (a, str) =- reverse $ map (\s -> (a, doLong s w)) $ wrapped str+ wrapLine (attr, str)+ = reverse $ zip (repeat attr) (wrapStr $ sepBy "\n" str) -- wrap on newlines then wrap long lines- wrapped = concat . map (chunk w) . map processNull . sepBy "\n"-- processNull "" = replicate w ' '- processNull s = s+ -- Example:+ -- 15:08:12 ** Topic: ExplicitCall+ -- Don't fear monads - they will sense it and f#ck+ -- you up | клуб любителей (молчать о) Haskell...+ -- ^^^^^^^^^ -- offset+ wrapStr [""] = [" "]+ wrapStr (s:ss) = s1:(concat $ map (map shift . chunk w') (s2:ss'))+ where (s1, s2) = splitAt w s+ ss' = map (\str -> if null str then " " else str) ss+ shift = (replicate offset ' ' ++)+ offset = 9+ w' = w - offset w = fromIntegral (region_width rgn) h = fromIntegral (region_height rgn)------doLong s w =- let len = length s- in if len < w- then s ++ replicate (w-len) ' '- else s
matsuri.cabal view
@@ -1,5 +1,5 @@ Name: matsuri-Version: 0.0.2+Version: 0.0.3 Category: Network Synopsis: ncurses XMPP client License: GPL@@ -25,4 +25,4 @@ Build-Depends: base >= 4 && < 5, vty >= 4, vty-ui >= 0.2, containers, mtl, network, split, directory,- ConfigFile, XMPP==0.0.4, time, old-locale+ ConfigFile, XMPP==0.1.1, time, old-locale
matsurirc.example view
@@ -1,5 +1,5 @@ [main]-version = 0.0.1+client = matsuri [account_test] username = test_username