gameServer/HWProtoCore.hs
changeset 15905 bf92592915c6
parent 14402 32e8c81ca35c
child 15909 7409084d891f
--- a/gameServer/HWProtoCore.hs	Thu Sep 29 16:30:02 2022 +0200
+++ b/gameServer/HWProtoCore.hs	Wed Oct 05 22:39:07 2022 +0300
@@ -22,6 +22,7 @@
 import Control.Monad.Reader
 import Data.Maybe
 import qualified Data.ByteString.Char8 as B
+import Text.Regex.TDFA
 --------------------------------------
 import CoreTypes
 import HWProtoNEState
@@ -118,6 +119,8 @@
             return [AnswerClients chans ["CHAT", nickGlobal, p]]
         h "WATCH" f = return [QueryReplay f]
         h "INFO" n | not $ B.null n = handleCmd ["INFO", n]
+        h "ALLOW_MSG" state = handleCmd ["ALLOW_MSG", state]
+        h "MSG" n = handleCmd ["MSG", n]
         h "HELP" _ = handleCmd ["HELP"]
         h "REGISTERED_ONLY" _ = serverAdminOnly $ do
             rnc <- liftM snd ask
@@ -137,6 +140,56 @@
 
         extractParameters p = let (a, b) = B.break (== ' ') p in (upperCase a, B.dropWhile (== ' ') b)
 
+handleCmd_loggedin ["MSG", nickMsg] = do
+    thisCl <- thisClient
+    thisNick <- clientNick
+    clChans <- thisClientChans
+    let addEcho nick msg a = AnswerClients clChans ["CHAT", thisNick, B.concat ["/msg [", nick, "] ", msg]] : a
+    let sendingMsgAllowed clientInfo = case allowMsgState clientInfo of
+          AllowAll -> True
+          AllowRegistered -> isRegistered thisCl
+          AllowNone -> False
+    let sendNickMsg nick msg = do
+          (_, rnc) <- ask
+          maybeClientId <- clientByNick nick
+          case maybeClientId of
+              Just cl -> let ci = client rnc cl in
+                  if sendingMsgAllowed ci  then
+                      return [AnswerClients [sendChan ci]
+                              ["CHAT", thisNick, B.concat ["[direct] ", msg]]]
+                  else
+                      return [Warning $ loc "Player is not allowing direct messages."]
+              Nothing -> return [Warning $ loc "Player is not online."]
+
+    case nickMsg =~ ("^[[:space:]]*\\[([^]\\[]*)\\][[:space:]]*(.*)$" :: B.ByteString) of
+        [[_, "", msg]] -> return [Warning $ loc "Invalid /msg command."]
+        [[_, nick, msg]] -> addEcho (B.strip nick) msg <$> sendNickMsg (B.strip nick) msg
+        [] -> case nickMsg =~ ("^[[:space:]]*([^[:space:]]+)[[:space:]]*(.*)$" :: B.ByteString) of
+            [[_, nick, msg]] -> addEcho nick msg <$> sendNickMsg nick msg
+            [] -> return [Warning $ loc "Invalid /msg command."]
+
+
+handleCmd_loggedin ["ALLOW_MSG", state] = do
+    cl <- thisClient
+    let statusMsg state = B.pack $ "Direct messages allowed: " ++ stateToStr state
+    let changeIgnoreState newState = [
+            ModifyClient (\c -> c{allowMsgState = newState}),
+            AnswerClients [sendChan cl] ["CHAT", nickServer, loc $ statusMsg newState]]
+    let maybeNewState = stateFromStr state
+    return $ maybe
+        [Warning unknownCmdWarningText] changeIgnoreState maybeNewState
+    where
+        stateFromStr str = case B.strip str of
+            "all" -> Just AllowAll
+            "registered" -> Just AllowRegistered
+            "none" -> Just AllowNone
+            _ -> Nothing
+        stateToStr state = case state of
+            AllowAll -> "all"
+            AllowRegistered -> "registered"
+            AllowNone -> "none"
+
+
 handleCmd_loggedin ["INFO", asknick] = do
     (_, rnc) <- ask
     maybeClientId <- clientByNick asknick