gameServer/HWProtoCore.hs
changeset 15905 bf92592915c6
parent 14402 32e8c81ca35c
child 15909 7409084d891f
equal deleted inserted replaced
15904:f185e7367dd3 15905:bf92592915c6
    20 module HWProtoCore where
    20 module HWProtoCore where
    21 
    21 
    22 import Control.Monad.Reader
    22 import Control.Monad.Reader
    23 import Data.Maybe
    23 import Data.Maybe
    24 import qualified Data.ByteString.Char8 as B
    24 import qualified Data.ByteString.Char8 as B
       
    25 import Text.Regex.TDFA
    25 --------------------------------------
    26 --------------------------------------
    26 import CoreTypes
    27 import CoreTypes
    27 import HWProtoNEState
    28 import HWProtoNEState
    28 import HWProtoLobbyState
    29 import HWProtoLobbyState
    29 import HWProtoInRoomState
    30 import HWProtoInRoomState
   116             rnc <- liftM snd ask
   117             rnc <- liftM snd ask
   117             let chans = map (sendChan . client rnc) $ allClients rnc
   118             let chans = map (sendChan . client rnc) $ allClients rnc
   118             return [AnswerClients chans ["CHAT", nickGlobal, p]]
   119             return [AnswerClients chans ["CHAT", nickGlobal, p]]
   119         h "WATCH" f = return [QueryReplay f]
   120         h "WATCH" f = return [QueryReplay f]
   120         h "INFO" n | not $ B.null n = handleCmd ["INFO", n]
   121         h "INFO" n | not $ B.null n = handleCmd ["INFO", n]
       
   122         h "ALLOW_MSG" state = handleCmd ["ALLOW_MSG", state]
       
   123         h "MSG" n = handleCmd ["MSG", n]
   121         h "HELP" _ = handleCmd ["HELP"]
   124         h "HELP" _ = handleCmd ["HELP"]
   122         h "REGISTERED_ONLY" _ = serverAdminOnly $ do
   125         h "REGISTERED_ONLY" _ = serverAdminOnly $ do
   123             rnc <- liftM snd ask
   126             rnc <- liftM snd ask
   124             let chans = map (sendChan . client rnc) $ allClients rnc
   127             let chans = map (sendChan . client rnc) $ allClients rnc
   125             return
   128             return
   134                 ]
   137                 ]
   135         h _ _ = return [Warning unknownCmdWarningText]
   138         h _ _ = return [Warning unknownCmdWarningText]
   136 
   139 
   137 
   140 
   138         extractParameters p = let (a, b) = B.break (== ' ') p in (upperCase a, B.dropWhile (== ' ') b)
   141         extractParameters p = let (a, b) = B.break (== ' ') p in (upperCase a, B.dropWhile (== ' ') b)
       
   142 
       
   143 handleCmd_loggedin ["MSG", nickMsg] = do
       
   144     thisCl <- thisClient
       
   145     thisNick <- clientNick
       
   146     clChans <- thisClientChans
       
   147     let addEcho nick msg a = AnswerClients clChans ["CHAT", thisNick, B.concat ["/msg [", nick, "] ", msg]] : a
       
   148     let sendingMsgAllowed clientInfo = case allowMsgState clientInfo of
       
   149           AllowAll -> True
       
   150           AllowRegistered -> isRegistered thisCl
       
   151           AllowNone -> False
       
   152     let sendNickMsg nick msg = do
       
   153           (_, rnc) <- ask
       
   154           maybeClientId <- clientByNick nick
       
   155           case maybeClientId of
       
   156               Just cl -> let ci = client rnc cl in
       
   157                   if sendingMsgAllowed ci  then
       
   158                       return [AnswerClients [sendChan ci]
       
   159                               ["CHAT", thisNick, B.concat ["[direct] ", msg]]]
       
   160                   else
       
   161                       return [Warning $ loc "Player is not allowing direct messages."]
       
   162               Nothing -> return [Warning $ loc "Player is not online."]
       
   163 
       
   164     case nickMsg =~ ("^[[:space:]]*\\[([^]\\[]*)\\][[:space:]]*(.*)$" :: B.ByteString) of
       
   165         [[_, "", msg]] -> return [Warning $ loc "Invalid /msg command."]
       
   166         [[_, nick, msg]] -> addEcho (B.strip nick) msg <$> sendNickMsg (B.strip nick) msg
       
   167         [] -> case nickMsg =~ ("^[[:space:]]*([^[:space:]]+)[[:space:]]*(.*)$" :: B.ByteString) of
       
   168             [[_, nick, msg]] -> addEcho nick msg <$> sendNickMsg nick msg
       
   169             [] -> return [Warning $ loc "Invalid /msg command."]
       
   170 
       
   171 
       
   172 handleCmd_loggedin ["ALLOW_MSG", state] = do
       
   173     cl <- thisClient
       
   174     let statusMsg state = B.pack $ "Direct messages allowed: " ++ stateToStr state
       
   175     let changeIgnoreState newState = [
       
   176             ModifyClient (\c -> c{allowMsgState = newState}),
       
   177             AnswerClients [sendChan cl] ["CHAT", nickServer, loc $ statusMsg newState]]
       
   178     let maybeNewState = stateFromStr state
       
   179     return $ maybe
       
   180         [Warning unknownCmdWarningText] changeIgnoreState maybeNewState
       
   181     where
       
   182         stateFromStr str = case B.strip str of
       
   183             "all" -> Just AllowAll
       
   184             "registered" -> Just AllowRegistered
       
   185             "none" -> Just AllowNone
       
   186             _ -> Nothing
       
   187         stateToStr state = case state of
       
   188             AllowAll -> "all"
       
   189             AllowRegistered -> "registered"
       
   190             AllowNone -> "none"
       
   191 
   139 
   192 
   140 handleCmd_loggedin ["INFO", asknick] = do
   193 handleCmd_loggedin ["INFO", asknick] = do
   141     (_, rnc) <- ask
   194     (_, rnc) <- ask
   142     maybeClientId <- clientByNick asknick
   195     maybeClientId <- clientByNick asknick
   143     isAdminAsking <- liftM isAdministrator thisClient
   196     isAdminAsking <- liftM isAdministrator thisClient