matsuri-0.0.3: Main.hs
{-# LANGUAGE RecordWildCards #-}
-- | Main.hs
-- Main program module.
import Buffers
import Config
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
import Graphics.Vty
import Graphics.Vty.Widgets.All
import qualified Widgets.ListBox as L
import qualified Widgets.EditBox as E
-- | Read configs and start main loop.
main = withSocketsDo $ do
-- read config
(config, buffers) <- readConfig ".matsurirc"
vty <- mkVty
mev <- newEmptyMVar
-- main loop
forkIO $ loopGetEvent mev vty
DisplayRegion w h <- display_bounds $ terminal vty
let ui = resizeUI (fromIntegral w) (fromIntegral h) $ defaultUI buffers
rerender mev vty ui config buffers
-- disconnect all accounts
mapM_ disconnect $ [acc | BufAccount acc <- (M.elems buffers)]
-- shutdown && exiting
shutdown vty
where
loopGetEvent mev vty = do
event <- next_event vty
putMVar mev (VtyEvent event)
loopGetEvent mev vty
-- | Get event and process it.
mainLoop mev vty st@(UIState {..}) config buffers = do
event <- takeMVar mev
case event of
InsBuffer k buffer -> insElem' k buffer
---
NewMsg k msg -> case getBuf k buffers of
BufChat chat ->
let contents = msg:(chatContents chat)
in insElem' k $ BufChat chat{chatContents=contents}
_ -> 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
---
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
-- 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 == "" ->
case getBuf cur buffers of
BufAccount acc ->
let buf = BufAccount acc{accCollapsed = not $ accCollapsed acc}
in insElem' cur buf
BufGroup grp ->
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
isShow' = if null isShow then "1"
else ""
config' = setCF "show_roster" isShow' config
in rerender mev vty st config' buffers
-- 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 }
EvKey (KASCII 'b') [MCtrl] -> rerender' $ st { edit = E.moveLeft edit }
EvKey (KASCII 'f') [MMeta] -> rerender' $ st { edit = E.moveWordRight edit }
EvKey (KASCII 'b') [MMeta] -> rerender' $ st { edit = E.moveWordLeft edit }
EvKey (KASCII 'e') [MCtrl] -> rerender' $ st { edit = E.moveToEnd edit }
EvKey KBS [] -> rerender' $ st { edit = E.backSpace edit }
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'
('/':cmd) -> do
buffers' <- parseCmd (words cmd)
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
-- other
EvResize w h -> rerender' $ resizeUI w h st
EvKey (KASCII 'q') [MCtrl] -> return ()
_ -> skip
where
skip = mainLoop mev vty st config buffers
rerender' st = rerender mev vty st config buffers
-- 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'
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
-- 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
= mkImage vty (mkUI st config buffers) >>=
update vty . pic_for_image >>
mainLoop mev vty st config buffers