diff --git a/Buffers.hs b/Buffers.hs --- a/Buffers.hs +++ b/Buffers.hs @@ -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) diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -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 diff --git a/Help.hs b/Help.hs --- a/Help.hs +++ b/Help.hs @@ -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 -- join to conference\n\ +\/topic -- show room topic\n\ +\/names -- show room participants (like in irssi)\n\ +\/q -- exit\n\ \\n\ \Hotkeys:\n\ \\n\ diff --git a/Jabber.hs b/Jabber.hs --- a/Jabber.hs +++ b/Jabber.hs @@ -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 diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/UI.hs b/UI.hs --- a/UI.hs +++ b/UI.hs @@ -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 diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -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 diff --git a/Widgets/TextBox.hs b/Widgets/TextBox.hs --- a/Widgets/TextBox.hs +++ b/Widgets/TextBox.hs @@ -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 diff --git a/matsuri.cabal b/matsuri.cabal --- a/matsuri.cabal +++ b/matsuri.cabal @@ -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 diff --git a/matsurirc.example b/matsurirc.example --- a/matsurirc.example +++ b/matsurirc.example @@ -1,5 +1,5 @@ [main] -version = 0.0.1 +client = matsuri [account_test] username = test_username