-- | 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