kevin-0.11.0: src/Kevin/Damn/Protocol.hs
{-# LANGUAGE OverloadedStrings #-}
module Kevin.Damn.Protocol (
initialize,
cleanup,
listen,
errHandlers
) where
import Control.Applicative ((<$>), (<$))
import Control.Concurrent
import Control.Exception as E (throw)
import Control.Exception.Lens
import Data.List (delete, nub, minimumBy)
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Ord (comparing)
import qualified Data.Text as T
import Data.Time.Clock.POSIX (getPOSIXTime)
import Kevin.Base
import Kevin.Damn.Protocol.Send
import qualified Kevin.IRC.Protocol.Send as I
import Kevin.Util.Entity
import Kevin.Util.Logger
import Kevin.Util.Tablump
import Text.Damn.Packet hiding (parse)
import qualified Text.Damn.Packet as D (parse)
okay :: Packet -> Bool
okay p = let e = pktArgs p ^. at "e" in e == Nothing || e == Just "ok"
notNull_ :: Prism' T.Text T.Text
notNull_ = prism' id $ toMaybe (not . T.null)
where toMaybe f x = x <$ guard (f x)
parsePrivclasses :: T.Text -> [Privclass]
parsePrivclasses = map (liftM2 (,) (!! 1) (read . T.unpack . head) . T.splitOn ":")
. filter (not . T.null)
. T.splitOn "\n"
parse :: T.Text -> Packet
parse m = case D.parse (fromMaybe m $ T.stripSuffix "\n" m) of
Left err -> E.throw $ ServerParseFailure err m
Right x -> x
initialize :: KevinIO ()
initialize = sendHandshake
cleanup :: KevinIO ()
cleanup = do
klog Blue "cleanup server"
k <- gets_ clientMv
tid <- liftIO $ readMVar k
liftIO $ killThread tid
listen :: KevinIO ()
listen = fix (\f -> flip catches errHandlers $ do
k <- get_
pkt <- io $ parse <$> readServer k
respond pkt (pktCommand pkt)
f)
-- main responder
respond :: Packet -> T.Text -> KevinIO ()
respond _ "dAmnServer" = do
s <- use_ settings
sendLogin (s^.name) (s^.authtoken)
respond pkt "login" =
if okay pkt
then do
j <- kevin $ do
loggedIn .= True
use joining
mapM_ sendJoin j
else I.sendNotice $ "Login failed: " <> pktArgs pkt ^. ix "e"
respond pkt "join" = do
roomname <- deformatRoom $ pktParameter pkt ^. _Just
if okay pkt
then do
kevin $ joining %= (roomname:)
uname <- use_ name
I.sendJoin uname roomname
else I.sendNotice $ T.concat ["Couldn't join ", roomname, ": ", pktArgs pkt ^. ix "e"]
respond pkt "part" = do
roomname <- deformatRoom $ pktParameter pkt ^. _Just
if okay pkt
then do
uname <- use_ name
removeRoom roomname
I.sendPart uname roomname Nothing
else I.sendNotice $ T.concat ["Couldn't part ", roomname, ": ", pktArgs pkt ^. ix "e"]
respond pkt "property" = do
roomname <- deformatRoom $ pktParameter pkt ^. _Just
case pktArgs pkt ^. ix "p" of
"privclasses" -> setPrivclasses roomname . parsePrivclasses $ pktBody pkt ^. _Just
"topic" -> do
uname <- use_ name
let setter = fromMaybe uname $ pktArgs pkt ^. at "by"
topic = T.replace "\n" " - " . entityDecode . tablumpDecode $ pktBody pkt ^. _Just
time = pktArgs pkt ^. ix "ts"
I.sendTopic uname roomname setter topic time
"title" -> setTitle roomname (T.replace "\n" " - " . entityDecode . tablumpDecode $ pktBody pkt ^. _Just)
"members" -> do
k <- get_
let members =map (mkUser roomname (k^.privclasses) . parse)
. init . T.splitOn "\n\n"
$ pktBody pkt ^. _Just
pc = privclass . head . filter (\x -> username x == k^.name) $ members
n = nub members
setUsers roomname members
when (roomname `elem` k^.joining) $ do
I.sendUserList (k^.name) n roomname
pclevel <- getPrivclassLevel roomname pc
I.sendSetUserMode (k^.name) roomname pclevel
kevin $ joining %= delete roomname
"info" -> do
us <- use_ name
curtime <- io $ floor <$> getPOSIXTime
let fixedPacket = parse . T.init
. T.replace "\n\nusericon" "\nusericon"
. render $ pkt
uname = T.drop 6 $ pktParameter pkt ^. _Just
rn = pktArgs fixedPacket ^. ix "realname"
conns :: [(Int, Int, [T.Text])]
conns = map (\pk ->
let x = parse $ "conn" <> pk
in ( read (T.unpack $ pktArgs x ^. ix "online") :: Int
, read (T.unpack $ pktArgs x ^. ix "idle" ) :: Int
, map (T.drop 8) . filter (not . T.null) . T.splitOn "\n\n" $ pktBody x ^. _Just
)) . tail . T.splitOn "conn" $ pktBody fixedPacket ^. _Just
allRooms = nub $ conns >>= (\(_,_,c) -> c)
(onlinespan,idle,_) = minimumBy (comparing (view _1)) conns
signon = curtime - onlinespan
I.sendWhoisReply us uname (entityDecode rn) allRooms idle signon
q -> klogError $ "Unrecognized property " ++ T.unpack q
respond spk "recv" = deformatRoom (pktParameter spk ^. _Just) >>= \roomname ->
case pktCommand pkt of
"join" -> do
let usname = pktParameter pkt ^. _Just
pcs <- gets_ $ view privclasses
countUser <- numUsers roomname usname
let us = mkUser roomname pcs modifiedPkt
addUser roomname us
if countUser == 0
then do
I.sendJoin usname roomname
pclevel <- getPrivclassLevel roomname $ pktArgs modifiedPkt ^. ix "pc"
I.sendSetUserMode usname roomname pclevel
else I.sendNoticeClone (username us) (succ countUser) roomname
"part" -> do
let uname = pktParameter pkt ^. _Just
removeUser roomname uname
countUser <- numUsers roomname uname
if countUser < 1
then I.sendPart uname roomname $ pktArgs pkt ^. at "r"
else I.sendNoticeUnclone uname countUser roomname
"msg" -> do
let uname = arg "from"
msg = pktBody pkt ^. _Just
un <- use_ name
unless (un == uname) $ I.sendChanMsg uname roomname (entityDecode $ tablumpDecode msg)
"action" -> do
let uname = arg "from"
msg = pktBody pkt ^. _Just
un <- use_ name
unless (un == uname) $ I.sendChanAction uname roomname (entityDecode $ tablumpDecode msg)
"privchg" -> do
let user = pktParameter pkt ^. _Just
by = arg "by"
newPc = arg "pc"
oldPc <- getPrivclass roomname user
oldPcLevel <- getPrivclassLevel roomname (fromMaybe "" oldPc)
newPcLevel <- getPrivclassLevel roomname newPc
setUserPrivclass roomname user newPc
I.sendRoomNotice roomname $ T.concat [ user, " has been moved"
, maybe "" (" from " <>) oldPc
, " to ", newPc, " by ", by
]
I.sendChangeUserMode user roomname oldPcLevel newPcLevel
"kicked" -> do
let uname = pktParameter pkt ^. _Just
removeUserAll roomname uname
I.sendKick uname (arg "by") roomname $ pktBody pkt ^. traverse ^? notNull_
"admin" -> case pktParameter pkt ^. _Just of
"create" -> I.sendRoomNotice roomname $
T.concat [ "Privclass ", arg "name", " created by ", arg "by"
, " with: ", arg "privs" ]
"update" -> I.sendRoomNotice roomname $
T.concat [ "Privclass ", arg "name", " updated by ", arg "by"
, " with: ", arg "privs" ]
"rename" -> I.sendRoomNotice roomname $
T.concat [ "Privclass ", arg "prev", " renamed to ", arg "name"
, " by ", arg "by" ]
"move" -> I.sendRoomNotice roomname $
T.concat [ arg "n", " users in privclass ", arg "prev", " moved to "
, arg "name", " by ", arg "by" ]
"remove" -> I.sendRoomNotice roomname $
T.concat [ "Privclass", arg "name", " removed by ", arg "by" ]
"show" -> mapM_ (I.sendRoomNotice roomname)
. T.splitOn "\n" $ pktBody pkt ^. _Just
"privclass" -> I.sendRoomNotice roomname $ "Admin error: " <> arg "e"
q -> klogError $ "Unknown admin packet type " ++ show q
x -> klogError $ "Unknown packet type " ++ show x
where pkt = pktSubpacket' spk ^?! _Just
modifiedPkt = parse (T.replace "\n\npc" "\npc" $ render pkt)
arg s = pktArgs pkt ^. ix s
respond pkt "kicked" = do
roomname <- deformatRoom $ pktParameter pkt ^. _Just
uname <- use_ name
removeRoom roomname
I.sendKick uname (pktArgs pkt ^. ix "by") roomname $ pktBody pkt ^. traverse ^? notNull_
respond pkt "send" = I.sendNotice $ "Send error: " <> pkt ^. pktArgsL . ix "e"
respond _ "ping" = get_ >>= \k -> io . writeServer k $ ("pong\n\0" :: T.Text)
respond _ str = klog Yellow $ "Got the packet called " ++ T.unpack str
mkUser :: Chatroom -> PrivclassStore -> Packet -> User
mkUser room st p = User {
username = p ^?! pktParameterL . _Just
, privclass = g "pc"
, privclassLevel = fromMaybe 0 $ st ^. at room >>= (view (at $ g "pc"))
, symbol = g "symbol"
, realname = entityDecode $ g "realname"
, typename = g "typename"
, gpc = g "gpc"
}
where g s = p ^. pktArgsL . ix s
errHandlers :: [ Handler KevinIO () ]
errHandlers = [ handler _KevinException $ klogError . show
, handler _IOException (\e -> klogError ("server: " ++ show e) >> E.throw e) ]