-- | Basic server monads and related operations.
module Game.LambdaHack.Server.MonadServer
  ( -- * The server monad
    MonadServer( getsServer
               , modifyServer
               , chanSaveServer  -- exposed only to be implemented, not used
               , liftIO  -- exposed only to be implemented, not used
               )
  , MonadServerAtomic(..)
    -- * Assorted primitives
  , getServer, putServer, debugPossiblyPrint, debugPossiblyPrintAndExit
  , serverPrint, saveServer, dumpRngs, restoreScore, registerScore
  , rndToAction, getSetGen
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

-- Cabal
import qualified Paths_LambdaHack as Self (version)

import qualified Control.Exception as Ex
import qualified Control.Monad.Trans.State.Strict as St
import qualified Data.EnumMap.Strict as EM
import qualified Data.Text as T
import qualified Data.Text.IO as T
import           Data.Time.Clock.POSIX
import           Data.Time.LocalTime
import           System.Exit (exitFailure)
import           System.FilePath
import           System.IO (hFlush, stdout)
import qualified System.Random.SplitMix32 as SM

import           Game.LambdaHack.Atomic
import           Game.LambdaHack.Common.ActorState
import           Game.LambdaHack.Common.ClientOptions (sbenchmark)
import           Game.LambdaHack.Common.Faction
import           Game.LambdaHack.Common.File
import qualified Game.LambdaHack.Common.HighScore as HighScore
import           Game.LambdaHack.Common.Kind
import           Game.LambdaHack.Common.Misc
import           Game.LambdaHack.Common.MonadStateRead
import           Game.LambdaHack.Common.Perception
import qualified Game.LambdaHack.Common.Save as Save
import           Game.LambdaHack.Common.State
import           Game.LambdaHack.Common.Types
import           Game.LambdaHack.Content.FactionKind
import           Game.LambdaHack.Content.RuleKind
import           Game.LambdaHack.Core.Random
import           Game.LambdaHack.Server.ServerOptions
import           Game.LambdaHack.Server.State

class MonadStateRead m => MonadServer m where
  getsServer     :: (StateServer -> a) -> m a
  modifyServer   :: (StateServer -> StateServer) -> m ()
  chanSaveServer :: m (Save.ChanSave (State, StateServer))
  -- We do not provide a MonadIO instance, so that outside
  -- nobody can subvert the action monads by invoking arbitrary IO.
  liftIO         :: IO a -> m a

-- | The monad for executing atomic game state transformations.
class MonadServer m => MonadServerAtomic m where
  -- | Execute an atomic command that changes the state
  -- on the server and on all clients that can notice it.
  execUpdAtomic :: UpdAtomic -> m ()
  -- | Execute an atomic command that changes the state
  -- on the server only.
  execUpdAtomicSer :: UpdAtomic -> m Bool
  -- | Execute an atomic command that changes the state
  -- on the given single client only.
  execUpdAtomicFid :: FactionId -> UpdAtomic -> m ()
  -- | Execute an atomic command that changes the state
  -- on the given single client only.
  -- Catch 'AtomicFail' and indicate if it was in fact raised.
  execUpdAtomicFidCatch :: FactionId -> UpdAtomic -> m Bool
  -- | Execute an atomic command that only displays special effects.
  execSfxAtomic :: SfxAtomic -> m ()
  execSendPer :: FactionId -> LevelId
              -> Perception -> Perception -> Perception -> m ()

getServer :: MonadServer m => m StateServer
getServer :: forall (m :: * -> *). MonadServer m => m StateServer
getServer = (StateServer -> StateServer) -> m StateServer
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> StateServer
forall a. a -> a
id

putServer :: MonadServer m => StateServer -> m ()
putServer :: forall (m :: * -> *). MonadServer m => StateServer -> m ()
putServer StateServer
s = (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer (StateServer -> StateServer -> StateServer
forall a b. a -> b -> a
const StateServer
s)

debugPossiblyPrint :: MonadServer m => Text -> m ()
debugPossiblyPrint :: forall (m :: * -> *). MonadServer m => Text -> m ()
debugPossiblyPrint Text
t = do
  debug <- (StateServer -> Bool) -> m Bool
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Bool
sdbgMsgSer (ServerOptions -> Bool)
-> (StateServer -> ServerOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
  when debug $ liftIO $ do
    T.hPutStr stdout $! t <> "\n"  -- hPutStrLn not atomic enough
    hFlush stdout

-- No moving savefiles aside, to debug more easily.
debugPossiblyPrintAndExit :: MonadServer m => Text -> m ()
debugPossiblyPrintAndExit :: forall (m :: * -> *). MonadServer m => Text -> m ()
debugPossiblyPrintAndExit Text
t = do
  debug <- (StateServer -> Bool) -> m Bool
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Bool
sdbgMsgSer (ServerOptions -> Bool)
-> (StateServer -> ServerOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
  when debug $ liftIO $ do
    T.hPutStr stdout $! t <> "\n"  -- hPutStrLn not atomic enough
    hFlush stdout
    exitFailure

serverPrint :: MonadServer m => Text -> m ()
serverPrint :: forall (m :: * -> *). MonadServer m => Text -> m ()
serverPrint Text
t = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Handle -> Text -> IO ()
T.hPutStr Handle
stdout (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$! Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"  -- hPutStrLn not atomic enough
  Handle -> IO ()
hFlush Handle
stdout

saveServer :: MonadServer m => m ()
saveServer :: forall (m :: * -> *). MonadServer m => m ()
saveServer = do
  s <- m State
forall (m :: * -> *). MonadStateRead m => m State
getState
  ser <- getServer
  toSave <- chanSaveServer
  liftIO $ Save.saveToChan toSave (s, ser)

-- | Dumps to stdout the RNG states from the start of the game.
dumpRngs :: MonadServer m => RNGs -> m ()
dumpRngs :: forall (m :: * -> *). MonadServer m => RNGs -> m ()
dumpRngs RNGs
rngs = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Handle -> Text -> IO ()
T.hPutStr Handle
stdout (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$! RNGs -> Text
forall a. Show a => a -> Text
tshow RNGs
rngs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"  -- hPutStrLn not atomic enough
  Handle -> IO ()
hFlush Handle
stdout

-- | Read the high scores dictionary. Return the empty table if no file.
restoreScore :: forall m. MonadServer m => COps -> m HighScore.ScoreDict
restoreScore :: forall (m :: * -> *). MonadServer m => COps -> m ScoreDict
restoreScore COps{RuleContent
corule :: RuleContent
corule :: COps -> RuleContent
corule} = do
  benchmark <- (StateServer -> Bool) -> m Bool
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ClientOptions -> Bool
sbenchmark (ClientOptions -> Bool)
-> (StateServer -> ClientOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerOptions -> ClientOptions
sclientOptions (ServerOptions -> ClientOptions)
-> (StateServer -> ServerOptions) -> StateServer -> ClientOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
  mscore <- if benchmark then return Nothing else do
    let scoresFileName = RuleContent -> String
rscoresFileName RuleContent
corule
    dataDir <- liftIO appDataDir
    let path String
bkp = String
dataDir String -> String -> String
</> String
bkp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
scoresFileName
    configExists <- liftIO $ doesFileExist (path "")
    res <- liftIO $ Ex.try $
      if configExists then do
        (vlib2, s) <- strictDecodeEOF (path "")
        if Save.compatibleVersion vlib2 Self.version
        then return $! s `seq` Just s
        else do
          let msg =
                String
"High score file from incompatible version of game detected."
          fail msg
      else return Nothing
    savePrefix <- getsServer $ ssavePrefixSer . soptions
    let defPrefix = ServerOptions -> String
ssavePrefixSer ServerOptions
defServerOptions
        moveAside = String
savePrefix String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
defPrefix
        handler :: Ex.SomeException -> m (Maybe a)
        handler SomeException
e = do
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
moveAside (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renameFile (String -> String
path String
"") (String -> String
path String
"bkp.")
          let msg :: Text
msg = Text
"High score restore failed."
                    Text -> Text -> Text
<+> (if Bool
moveAside
                        then Text
"The wrong file moved aside."
                        else Text
"")
                    Text -> Text -> Text
<+> Text
"The error message is:"
                    Text -> Text -> Text
<+> ([Text] -> Text
T.unwords ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines) (SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
e)
          Text -> m ()
forall (m :: * -> *). MonadServer m => Text -> m ()
serverPrint Text
msg
          Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    either handler return res
  maybe (return HighScore.empty) return mscore

-- | Generate a new score, register it and save.
registerScore :: MonadServer m => Status -> FactionId -> m ()
registerScore :: forall (m :: * -> *). MonadServer m => Status -> FactionId -> m ()
registerScore Status
status FactionId
fid = do
  cops@COps{corule} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  total <- getsState $ snd . calculateTotal fid
  let scoresFileName = RuleContent -> String
rscoresFileName RuleContent
corule
  dataDir <- liftIO appDataDir
  -- Re-read the table in case it's changed by a concurrent game.
  scoreDict <- restoreScore cops
  gameModeId <- getsState sgameModeId
  time <- getsState stime
  dungeonTotal <- getsState sgold
  date <- liftIO getPOSIXTime
  tz <- liftIO $ getTimeZone $ posixSecondsToUTCTime date
  curChalSer <- getsServer $ scurChalSer . soptions
  factionD <- getsState sfactionD
  bench <- getsServer $ sbenchmark . sclientOptions . soptions
  noConfirmsGame <- isNoConfirmsGame
  sbandSpawned <- getsServer sbandSpawned
  let fact = FactionDict
factionD FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid
      path = String
dataDir String -> String -> String
</> String
scoresFileName
      outputScore (Bool
worthMentioning, (ScoreTable
ntable, Int
pos)) =
        -- If testing or fooling around, dump instead of registering.
        -- In particular don't register score for the auto-* scenarios.
        if Bool
bench Bool -> Bool -> Bool
|| Bool
noConfirmsGame Bool -> Bool -> Bool
|| Faction -> Bool
gunderAI Faction
fact then
          Text -> m ()
forall (m :: * -> *). MonadServer m => Text -> m ()
debugPossiblyPrint (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"\n"
          ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ TimeZone -> Int -> ScoreRecord -> [Text]
HighScore.showScore TimeZone
tz Int
pos (Int -> ScoreTable -> ScoreRecord
HighScore.getRecord Int
pos ScoreTable
ntable)
            [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"           Spawned groups:"
                Text -> Text -> Text
<+> [Text] -> Text
T.unwords ([Text] -> [Text]
forall a. HasCallStack => [a] -> [a]
tail (Text -> [Text]
T.words (IntMap Int -> Text
forall a. Show a => a -> Text
tshow IntMap Int
sbandSpawned)))]
        else
          let nScoreDict :: ScoreDict
nScoreDict = ContentId ModeKind -> ScoreTable -> ScoreDict -> ScoreDict
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert ContentId ModeKind
gameModeId ScoreTable
ntable ScoreDict
scoreDict
          in Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
worthMentioning (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
               String -> Version -> ScoreDict -> IO ()
forall b. Binary b => String -> Version -> b -> IO ()
encodeEOF String
path Version
Self.version (ScoreDict
nScoreDict :: HighScore.ScoreDict)
      theirVic (FactionId
fi, Faction
fa) | FactionId -> Faction -> FactionId -> Bool
isFoe FactionId
fid Faction
fact FactionId
fi
                          Bool -> Bool -> Bool
&& Bool -> Bool
not (Faction -> Bool
isHorrorFact Faction
fa) = EnumMap (ContentId ItemKind) Int
-> Maybe (EnumMap (ContentId ItemKind) Int)
forall a. a -> Maybe a
Just (EnumMap (ContentId ItemKind) Int
 -> Maybe (EnumMap (ContentId ItemKind) Int))
-> EnumMap (ContentId ItemKind) Int
-> Maybe (EnumMap (ContentId ItemKind) Int)
forall a b. (a -> b) -> a -> b
$ Faction -> EnumMap (ContentId ItemKind) Int
gvictims Faction
fa
                        | Bool
otherwise = Maybe (EnumMap (ContentId ItemKind) Int)
forall a. Maybe a
Nothing
      theirVictims = (Int -> Int -> Int)
-> [EnumMap (ContentId ItemKind) Int]
-> EnumMap (ContentId ItemKind) Int
forall a k. (a -> a -> a) -> [EnumMap k a] -> EnumMap k a
EM.unionsWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ([EnumMap (ContentId ItemKind) Int]
 -> EnumMap (ContentId ItemKind) Int)
-> [EnumMap (ContentId ItemKind) Int]
-> EnumMap (ContentId ItemKind) Int
forall a b. (a -> b) -> a -> b
$ ((FactionId, Faction) -> Maybe (EnumMap (ContentId ItemKind) Int))
-> [(FactionId, Faction)] -> [EnumMap (ContentId ItemKind) Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (FactionId, Faction) -> Maybe (EnumMap (ContentId ItemKind) Int)
theirVic ([(FactionId, Faction)] -> [EnumMap (ContentId ItemKind) Int])
-> [(FactionId, Faction)] -> [EnumMap (ContentId ItemKind) Int]
forall a b. (a -> b) -> a -> b
$ FactionDict -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs FactionDict
factionD
      ourVic (FactionId
fi, Faction
fa) | FactionId -> Faction -> FactionId -> Bool
isFriend FactionId
fid Faction
fact FactionId
fi = EnumMap (ContentId ItemKind) Int
-> Maybe (EnumMap (ContentId ItemKind) Int)
forall a. a -> Maybe a
Just (EnumMap (ContentId ItemKind) Int
 -> Maybe (EnumMap (ContentId ItemKind) Int))
-> EnumMap (ContentId ItemKind) Int
-> Maybe (EnumMap (ContentId ItemKind) Int)
forall a b. (a -> b) -> a -> b
$ Faction -> EnumMap (ContentId ItemKind) Int
gvictims Faction
fa
                      | Bool
otherwise = Maybe (EnumMap (ContentId ItemKind) Int)
forall a. Maybe a
Nothing
      ourVictims = (Int -> Int -> Int)
-> [EnumMap (ContentId ItemKind) Int]
-> EnumMap (ContentId ItemKind) Int
forall a k. (a -> a -> a) -> [EnumMap k a] -> EnumMap k a
EM.unionsWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ([EnumMap (ContentId ItemKind) Int]
 -> EnumMap (ContentId ItemKind) Int)
-> [EnumMap (ContentId ItemKind) Int]
-> EnumMap (ContentId ItemKind) Int
forall a b. (a -> b) -> a -> b
$ ((FactionId, Faction) -> Maybe (EnumMap (ContentId ItemKind) Int))
-> [(FactionId, Faction)] -> [EnumMap (ContentId ItemKind) Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (FactionId, Faction) -> Maybe (EnumMap (ContentId ItemKind) Int)
ourVic ([(FactionId, Faction)] -> [EnumMap (ContentId ItemKind) Int])
-> [(FactionId, Faction)] -> [EnumMap (ContentId ItemKind) Int]
forall a b. (a -> b) -> a -> b
$ FactionDict -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs FactionDict
factionD
      table = ContentId ModeKind -> ScoreDict -> ScoreTable
HighScore.getTable ContentId ModeKind
gameModeId ScoreDict
scoreDict
      registeredScore =
        ScoreTable
-> Int
-> Int
-> Time
-> Status
-> POSIXTime
-> Challenge
-> Text
-> EnumMap (ContentId ItemKind) Int
-> EnumMap (ContentId ItemKind) Int
-> HiCondPoly
-> (Bool, (ScoreTable, Int))
HighScore.register ScoreTable
table Int
total Int
dungeonTotal Time
time Status
status POSIXTime
date Challenge
curChalSer
                           ([Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. HasCallStack => [a] -> [a]
tail ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Faction -> Text
gname Faction
fact)
                           EnumMap (ContentId ItemKind) Int
ourVictims EnumMap (ContentId ItemKind) Int
theirVictims
                           (FactionKind -> HiCondPoly
fhiCondPoly (FactionKind -> HiCondPoly) -> FactionKind -> HiCondPoly
forall a b. (a -> b) -> a -> b
$ Faction -> FactionKind
gkind Faction
fact)
  outputScore registeredScore

-- | Invoke pseudo-random computation with the generator kept in the state.
rndToAction :: MonadServer m => Rnd a -> m a
rndToAction :: forall (m :: * -> *) a. MonadServer m => Rnd a -> m a
rndToAction Rnd a
r = do
  gen1 <- (StateServer -> SMGen) -> m SMGen
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> SMGen
srandom
  let (a, gen2) = St.runState r gen1
  modifyServer $ \StateServer
ser -> StateServer
ser {srandom = gen2}
  return a

-- | Gets a random generator from the user-submitted options or, if not present,
-- generates one.
getSetGen :: MonadServer m => Maybe SM.SMGen -> m SM.SMGen
getSetGen :: forall (m :: * -> *). MonadServer m => Maybe SMGen -> m SMGen
getSetGen Maybe SMGen
mrng = case Maybe SMGen
mrng of
  Just SMGen
rnd -> SMGen -> m SMGen
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return SMGen
rnd
  Maybe SMGen
Nothing -> IO SMGen -> m SMGen
forall a. IO a -> m a
forall (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO IO SMGen
SM.newSMGen