    -- | 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