-- | 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.ModeKind
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 :: m StateServer
getServer = (StateServer -> StateServer) -> m StateServer
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> StateServer
forall a. a -> a
id

putServer :: MonadServer m => StateServer -> m ()
putServer :: 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 :: Text -> m ()
debugPossiblyPrint Text
t = do
  Bool
debug <- (StateServer -> Bool) -> m Bool
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
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
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

debugPossiblyPrintAndExit :: MonadServer m => Text -> m ()
debugPossiblyPrintAndExit :: Text -> m ()
debugPossiblyPrintAndExit Text
t = do
  Bool
debug <- (StateServer -> Bool) -> m Bool
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
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
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
    IO ()
forall a. IO a
exitFailure

serverPrint :: MonadServer m => Text -> m ()
serverPrint :: Text -> m ()
serverPrint Text
t = IO () -> m ()
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 :: m ()
saveServer = do
  State
s <- m State
forall (m :: * -> *). MonadStateRead m => m State
getState
  StateServer
ser <- m StateServer
forall (m :: * -> *). MonadServer m => m StateServer
getServer
  ChanSave (State, StateServer)
toSave <- m (ChanSave (State, StateServer))
forall (m :: * -> *).
MonadServer m =>
m (ChanSave (State, StateServer))
chanSaveServer
  IO () -> m ()
forall (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ChanSave (State, StateServer) -> (State, StateServer) -> IO ()
forall a. ChanSave a -> a -> IO ()
Save.saveToChan ChanSave (State, StateServer)
toSave (State
s, StateServer
ser)

-- | Dumps to stdout the RNG states from the start of the game.
dumpRngs :: MonadServer m => RNGs -> m ()
dumpRngs :: RNGs -> m ()
dumpRngs RNGs
rngs = IO () -> m ()
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 :: COps -> m ScoreDict
restoreScore COps{RuleContent
corule :: COps -> RuleContent
corule :: RuleContent
corule} = do
  Bool
benchmark <- (StateServer -> Bool) -> m Bool
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
  Maybe ScoreDict
mscore <- if Bool
benchmark then Maybe ScoreDict -> m (Maybe ScoreDict)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ScoreDict
forall a. Maybe a
Nothing else do
    let scoresFile :: FilePath
scoresFile = RuleContent -> FilePath
rscoresFile RuleContent
corule
    FilePath
dataDir <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO IO FilePath
appDataDir
    let path :: FilePath -> FilePath
path FilePath
bkp = FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
bkp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
scoresFile
    Bool
configExists <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist (FilePath -> FilePath
path FilePath
"")
    Either SomeException (Maybe ScoreDict)
res <- IO (Either SomeException (Maybe ScoreDict))
-> m (Either SomeException (Maybe ScoreDict))
forall (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO (IO (Either SomeException (Maybe ScoreDict))
 -> m (Either SomeException (Maybe ScoreDict)))
-> IO (Either SomeException (Maybe ScoreDict))
-> m (Either SomeException (Maybe ScoreDict))
forall a b. (a -> b) -> a -> b
$ IO (Maybe ScoreDict) -> IO (Either SomeException (Maybe ScoreDict))
forall e a. Exception e => IO a -> IO (Either e a)
Ex.try (IO (Maybe ScoreDict)
 -> IO (Either SomeException (Maybe ScoreDict)))
-> IO (Maybe ScoreDict)
-> IO (Either SomeException (Maybe ScoreDict))
forall a b. (a -> b) -> a -> b
$
      if Bool
configExists then do
        (Version
vlib2, ScoreDict
s) <- FilePath -> IO (Version, ScoreDict)
forall b. Binary b => FilePath -> IO (Version, b)
strictDecodeEOF (FilePath -> FilePath
path FilePath
"")
        if Version -> Version -> Bool
Save.compatibleVersion Version
vlib2 Version
Self.version
        then Maybe ScoreDict -> IO (Maybe ScoreDict)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ScoreDict -> IO (Maybe ScoreDict))
-> Maybe ScoreDict -> IO (Maybe ScoreDict)
forall a b. (a -> b) -> a -> b
$! ScoreDict
s ScoreDict -> Maybe ScoreDict -> Maybe ScoreDict
`seq` ScoreDict -> Maybe ScoreDict
forall a. a -> Maybe a
Just ScoreDict
s
        else do
          let msg :: FilePath
msg =
                FilePath
"High score file from incompatible version of game detected."
          FilePath -> IO (Maybe ScoreDict)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
msg
      else Maybe ScoreDict -> IO (Maybe ScoreDict)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ScoreDict
forall a. Maybe a
Nothing
    FilePath
savePrefix <- (StateServer -> FilePath) -> m FilePath
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> FilePath) -> m FilePath)
-> (StateServer -> FilePath) -> m FilePath
forall a b. (a -> b) -> a -> b
$ ServerOptions -> FilePath
ssavePrefixSer (ServerOptions -> FilePath)
-> (StateServer -> ServerOptions) -> StateServer -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
    let defPrefix :: FilePath
defPrefix = ServerOptions -> FilePath
ssavePrefixSer ServerOptions
defServerOptions
        moveAside :: Bool
moveAside = FilePath
savePrefix FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
defPrefix
        handler :: Ex.SomeException -> m (Maybe a)
        handler :: 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 (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
renameFile (FilePath -> FilePath
path FilePath
"") (FilePath -> FilePath
path FilePath
"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 (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    (SomeException -> m (Maybe ScoreDict))
-> (Maybe ScoreDict -> m (Maybe ScoreDict))
-> Either SomeException (Maybe ScoreDict)
-> m (Maybe ScoreDict)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> m (Maybe ScoreDict)
forall a. SomeException -> m (Maybe a)
handler Maybe ScoreDict -> m (Maybe ScoreDict)
forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException (Maybe ScoreDict)
res
  m ScoreDict
-> (ScoreDict -> m ScoreDict) -> Maybe ScoreDict -> m ScoreDict
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ScoreDict -> m ScoreDict
forall (m :: * -> *) a. Monad m => a -> m a
return ScoreDict
HighScore.empty) ScoreDict -> m ScoreDict
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ScoreDict
mscore

-- | Generate a new score, register it and save.
registerScore :: MonadServer m => Status -> FactionId -> m ()
registerScore :: Status -> FactionId -> m ()
registerScore Status
status FactionId
fid = do
  cops :: COps
cops@COps{RuleContent
corule :: RuleContent
corule :: COps -> RuleContent
corule} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Int
total <- (State -> Int) -> m Int
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Int) -> m Int) -> (State -> Int) -> m Int
forall a b. (a -> b) -> a -> b
$ (ItemBag, Int) -> Int
forall a b. (a, b) -> b
snd ((ItemBag, Int) -> Int)
-> (State -> (ItemBag, Int)) -> State -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FactionId -> State -> (ItemBag, Int)
calculateTotal FactionId
fid
  let scoresFile :: FilePath
scoresFile = RuleContent -> FilePath
rscoresFile RuleContent
corule
  FilePath
dataDir <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO IO FilePath
appDataDir
  -- Re-read the table in case it's changed by a concurrent game.
  ScoreDict
scoreDict <- COps -> m ScoreDict
forall (m :: * -> *). MonadServer m => COps -> m ScoreDict
restoreScore COps
cops
  ContentId ModeKind
gameModeId <- (State -> ContentId ModeKind) -> m (ContentId ModeKind)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ContentId ModeKind
sgameModeId
  Time
time <- (State -> Time) -> m Time
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> Time
stime
  Int
dungeonTotal <- (State -> Int) -> m Int
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> Int
sgold
  POSIXTime
date <- IO POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
  TimeZone
tz <- IO TimeZone -> m TimeZone
forall (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO (IO TimeZone -> m TimeZone) -> IO TimeZone -> m TimeZone
forall a b. (a -> b) -> a -> b
$ UTCTime -> IO TimeZone
getTimeZone (UTCTime -> IO TimeZone) -> UTCTime -> IO TimeZone
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
date
  Challenge
curChalSer <- (StateServer -> Challenge) -> m Challenge
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Challenge) -> m Challenge)
-> (StateServer -> Challenge) -> m Challenge
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Challenge
scurChalSer (ServerOptions -> Challenge)
-> (StateServer -> ServerOptions) -> StateServer -> Challenge
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
  FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
  Bool
bench <- (StateServer -> Bool) -> m Bool
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
  Bool
noConfirmsGame <- m Bool
forall (m :: * -> *). MonadStateRead m => m Bool
isNoConfirmsGame
  IntMap Int
sbandSpawned <- (StateServer -> IntMap Int) -> m (IntMap Int)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> IntMap Int
sbandSpawned
  let fact :: Faction
fact = FactionDict
factionD FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid
      path :: FilePath
path = FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
scoresFile
      outputScore :: (Bool, (ScoreTable, Int)) -> m ()
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
isAIFact 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. [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 (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
               FilePath -> Version -> ScoreDict -> IO ()
forall b. Binary b => FilePath -> Version -> b -> IO ()
encodeEOF FilePath
path Version
Self.version (ScoreDict
nScoreDict :: HighScore.ScoreDict)
      chal :: Challenge
chal | Player -> Bool
fhasUI (Player -> Bool) -> Player -> Bool
forall a b. (a -> b) -> a -> b
$ Faction -> Player
gplayer Faction
fact = Challenge
curChalSer
           | Bool
otherwise = Challenge
curChalSer
                           {cdiff :: Int
cdiff = Int -> Int
difficultyInverse (Challenge -> Int
cdiff Challenge
curChalSer)}
      theirVic :: (FactionId, Faction) -> Maybe (EnumMap (ContentId ItemKind) Int)
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 :: EnumMap (ContentId ItemKind) Int
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, Faction) -> Maybe (EnumMap (ContentId ItemKind) Int)
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 :: EnumMap (ContentId ItemKind) Int
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 :: ScoreTable
table = ContentId ModeKind -> ScoreDict -> ScoreTable
HighScore.getTable ContentId ModeKind
gameModeId ScoreDict
scoreDict
      registeredScore :: (Bool, (ScoreTable, Int))
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
chal
                           ([Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [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
                           (Player -> HiCondPoly
fhiCondPoly (Player -> HiCondPoly) -> Player -> HiCondPoly
forall a b. (a -> b) -> a -> b
$ Faction -> Player
gplayer Faction
fact)
  (Bool, (ScoreTable, Int)) -> m ()
outputScore (Bool, (ScoreTable, Int))
registeredScore

-- | Invoke pseudo-random computation with the generator kept in the state.
rndToAction :: MonadServer m => Rnd a -> m a
rndToAction :: Rnd a -> m a
rndToAction Rnd a
r = do
  SMGen
gen1 <- (StateServer -> SMGen) -> m SMGen
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> SMGen
srandom
  let (a
a, SMGen
gen2) = Rnd a -> SMGen -> (a, SMGen)
forall s a. State s a -> s -> (a, s)
St.runState Rnd a
r SMGen
gen1
  (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser -> StateServer
ser {srandom :: SMGen
srandom = SMGen
gen2}
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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 :: Maybe SMGen -> m SMGen
getSetGen Maybe SMGen
mrng = case Maybe SMGen
mrng of
  Just SMGen
rnd -> SMGen -> m SMGen
forall (m :: * -> *) a. Monad m => a -> m a
return SMGen
rnd
  Maybe SMGen
Nothing -> IO SMGen -> m SMGen
forall (m :: * -> *) a. MonadServer m => IO a -> m a
liftIO IO SMGen
SM.newSMGen