content: -- | 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 = getsServer id
  
  putServer :: MonadServer m => StateServer -> m ()
  putServer s = modifyServer (const s)
  
  debugPossiblyPrint :: MonadServer m => Text -> m ()
  debugPossiblyPrint t = do
    debug <- getsServer $ sdbgMsgSer . 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 t = do
    debug <- getsServer $ sdbgMsgSer . soptions
    when debug $ liftIO $ do
      T.hPutStr stdout $! t <> "\n"  -- hPutStrLn not atomic enough
      hFlush stdout
      exitFailure
  
  serverPrint :: MonadServer m => Text -> m ()
  serverPrint t = liftIO $ do
    T.hPutStr stdout $! t <> "\n"  -- hPutStrLn not atomic enough
    hFlush stdout
  
  saveServer :: MonadServer m => m ()
  saveServer = do
    s <- 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 rngs = liftIO $ do
    T.hPutStr stdout $! tshow rngs <> "\n"  -- hPutStrLn not atomic enough
    hFlush stdout
  
  -- | Read the high scores dictionary. Return the empty table if no file.
  restoreScore :: forall m. MonadServer m => COps -> m HighScore.ScoreDict
  restoreScore COps{corule} = do
    benchmark <- getsServer $ sbenchmark . sclientOptions . soptions
    mscore <- if benchmark then return Nothing else do
      let scoresFileName = rscoresFileName corule
      dataDir <- liftIO appDataDir
      let path bkp = dataDir </> bkp <> 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 =
                  "High score file from incompatible version of game detected."
            fail msg
        else return Nothing
      savePrefix <- getsServer $ ssavePrefixSer . soptions
      let defPrefix = ssavePrefixSer defServerOptions
          moveAside = savePrefix == defPrefix
          handler :: Ex.SomeException -> m (Maybe a)
          handler e = do
            when moveAside $
              liftIO $ renameFile (path "") (path "bkp.")
            let msg = "High score restore failed."
                      <+> (if moveAside
                          then "The wrong file moved aside."
                          else "")
                      <+> "The error message is:"
                      <+> (T.unwords . T.lines) (tshow e)
            serverPrint msg
            return 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 status fid = do
    cops@COps{corule} <- getsState scops
    total <- getsState $ snd . calculateTotal fid
    let scoresFileName = rscoresFileName 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 = factionD EM.! fid
        path = dataDir </> scoresFileName
        outputScore (worthMentioning, (ntable, pos)) =
          -- If testing or fooling around, dump instead of registering.
          -- In particular don't register score for the auto-* scenarios.
          if bench || noConfirmsGame || gunderAI fact then
            debugPossiblyPrint $ T.intercalate "\n"
            $ HighScore.showScore tz pos (HighScore.getRecord pos ntable)
              ++ ["           Spawned groups:"
                  <+> T.unwords (tail (T.words (tshow sbandSpawned)))]
          else
            let nScoreDict = EM.insert gameModeId ntable scoreDict
            in when worthMentioning $ liftIO $
                 encodeEOF path Self.version (nScoreDict :: HighScore.ScoreDict)
        theirVic (fi, fa) | isFoe fid fact fi
                            && not (isHorrorFact fa) = Just $ gvictims fa
                          | otherwise = Nothing
        theirVictims = EM.unionsWith (+) $ mapMaybe theirVic $ EM.assocs factionD
        ourVic (fi, fa) | isFriend fid fact fi = Just $ gvictims fa
                        | otherwise = Nothing
        ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD
        table = HighScore.getTable gameModeId scoreDict
        registeredScore =
          HighScore.register table total dungeonTotal time status date curChalSer
                             (T.unwords $ tail $ T.words $ gname fact)
                             ourVictims theirVictims
                             (fhiCondPoly $ gkind fact)
    outputScore registeredScore
  
  -- | Invoke pseudo-random computation with the generator kept in the state.
  rndToAction :: MonadServer m => Rnd a -> m a
  rndToAction r = do
    gen1 <- getsServer srandom
    let (a, gen2) = St.runState r gen1
    modifyServer $ \ser -> 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 mrng = case mrng of
    Just rnd -> return rnd
    Nothing -> liftIO SM.newSMGen
  