Send.hs

{-# LANGUAGE OverloadedStrings #-}

module Kevin.Damn.Protocol.Send (
    sendPacket,
    formatRoom,
    deformatRoom,

    sendHandshake,
    sendLogin,
    sendJoin,
    sendPart,
    sendMsg,
    sendAction,
    sendNpMsg,
    sendPromote,
    sendDemote,
    sendBan,
    sendUnban,
    sendKick,
    sendGet,
    sendWhois,
    sendSet,
    sendAdmin,
    sendKill
) where

import Data.Char (toLower)
import Data.List (sort)
import Data.Monoid
import qualified Data.Text as T
import Kevin.Base
import Kevin.Version

maybeBody :: Maybe T.Text -> T.Text
maybeBody = maybe "" ("\n\n" <>)

sendPacket :: T.Text -> KevinIO ()
sendPacket p = get_ >>= \k -> io . writeServer k . T.snoc p $ '\0'

formatRoom :: T.Text -> KevinIO T.Text
formatRoom b = case T.splitAt 1 b of ("#",s) -> return $ "chat:" <> s
                                     ("&",s) -> do uname <- use_ name
                                                   return . ("pchat:" <>) . T.intercalate ":" . sort . map (T.map toLower) $ [uname, s]
                                     r -> return $ "chat" <> uncurry (<>) r

deformatRoom :: T.Text -> KevinIO T.Text
deformatRoom room = if "chat:" `T.isPrefixOf` room
                       then return $ '#' `T.cons` T.drop 5 room
                       else do uname <- use_ name
                               return $ T.cons '&' (head (filter (/= uname) . T.splitOn ":" . T.drop 6 $ room))

type Str      = T.Text -- just make it shorter
type Room     = Str
type Username = Str
type Pc       = Str

-- * Communication to the server
sendHandshake                  ::                                  KevinIO ()
sendLogin                      :: Username -> Str               -> KevinIO ()
sendJoin, sendPart             :: Room                          -> KevinIO ()
sendMsg, sendAction, sendNpMsg :: Room -> Str                   -> KevinIO ()
sendPromote, sendDemote        :: Room -> Username -> Maybe Pc  -> KevinIO ()
sendBan, sendUnban             :: Room -> Username              -> KevinIO ()
sendKick                       :: Room -> Username -> Maybe Str -> KevinIO ()
sendGet                        :: Room -> Str                   -> KevinIO ()
sendWhois                      :: Username                      -> KevinIO ()
sendSet                        :: Room -> Str -> Str            -> KevinIO ()
sendAdmin                      :: Room -> Str                   -> KevinIO ()
sendKill                       :: Username -> Str               -> KevinIO ()

sendHandshake = sendPacket $ printf "dAmnClient 0.3\nagent=kevin%s\n" [versionStr]

sendLogin u token = sendPacket $ printf "login %s\npk=%s\n" [u, token]

sendJoin room = do roomname <- formatRoom room
                   sendPacket $ printf "join %s\n" [roomname]

sendPart room = do roomname <- formatRoom room
                   sendPacket $ printf "part %s\n" [roomname]

sendMsg = sendNpMsg

sendAction room msg = do roomname <- formatRoom room
                         sendPacket $ printf "send %s\n\naction main\n\n%s" [roomname, msg]

sendNpMsg room msg = do roomname <- formatRoom room
                        sendPacket $ printf "send %s\n\nnpmsg main\n\n%s" [roomname, msg]

sendPromote room us pc = do roomname <- formatRoom room
                            sendPacket $ printf "send %s\n\npromote %s%s" [roomname, us, maybeBody pc]

sendDemote room us pc = do roomname <- formatRoom room
                           sendPacket $ printf "send %s\n\ndemote %s%s" [roomname, us, maybeBody pc]

sendBan room us = do roomname <- formatRoom room
                     sendPacket $ printf "send %s\n\nban %s\n\n" [roomname, us]

sendUnban room us = do roomname <- formatRoom room
                       sendPacket $ printf "send %s\n\nunban %s\n\n" [roomname, us]

sendKick room us reason = do roomname <- formatRoom room
                             sendPacket $ printf "kick %s\nu=%s%s\n" [roomname, us, maybeBody reason]

sendGet room prop = do guard $ prop `elem` ["title", "topic", "privclasses", "members"]
                       roomname <- formatRoom room
                       sendPacket $ printf "get %s\np=%s\n" [roomname, prop]

sendWhois us = sendPacket $ printf "get login:%s\np=info\n" [us]

sendSet room prop val = do guard (prop == "topic" || prop == "title")
                           roomname <- formatRoom room
                           sendPacket $ printf "set %s\np=%s\n\n%s\n" [roomname, prop, val]

sendAdmin room cmd = do roomname <- formatRoom room
                        sendPacket $ printf "send %s\n\nadmin\n\n%s" [roomname, cmd]

sendKill = undefined