-- | Saving and restoring game state, used by both server and clients.
module Game.LambdaHack.Common.Save
  ( ChanSave, saveToChan, wrapInSaves, restoreGame
  , compatibleVersion, delayPrint
  , saveNameCli, saveNameSer, bkpAllSaves
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , loopSave
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.Concurrent
import           Control.Concurrent.Async
import qualified Control.Exception as Ex
import           Data.Binary
import qualified Data.Text as T
import qualified Data.Text.IO as T
import           Data.Version
import           System.FilePath
import           System.IO (hFlush, stdout)
import qualified System.Random.SplitMix32 as SM

import Game.LambdaHack.Common.ClientOptions
import Game.LambdaHack.Common.File
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Core.Random

type ChanSave a = MVar (Maybe a)

saveToChan :: ChanSave a -> a -> IO ()
saveToChan :: ChanSave a -> a -> IO ()
saveToChan toSave :: ChanSave a
toSave s :: a
s = do
  -- Wipe out previous candidates for saving.
  IO (Maybe (Maybe a)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (Maybe a)) -> IO ()) -> IO (Maybe (Maybe a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ ChanSave a -> IO (Maybe (Maybe a))
forall a. MVar a -> IO (Maybe a)
tryTakeMVar ChanSave a
toSave
  ChanSave a -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar ChanSave a
toSave (Maybe a -> IO ()) -> Maybe a -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
s

-- | Repeatedly save serialized snapshots of current state.
--
-- Running with @-N2@ ca reduce @Max pause@ from 0.2s to 0.01s
-- and @bytes copied during GC@ 10-fold, but framerate nor the frequency
-- of not making a backup save are unaffected (at standard backup settings),
-- even with null frontend, because saving takes so few resources.
-- So, generally, backup save settings are relevant only due to latency
-- impact on very slow computers or in JS.
loopSave :: Binary a => COps -> (a -> FilePath) -> ChanSave a -> IO ()
loopSave :: COps -> (a -> FilePath) -> ChanSave a -> IO ()
loopSave cops :: COps
cops stateToFileName :: a -> FilePath
stateToFileName toSave :: ChanSave a
toSave =
  IO ()
loop
 where
  loop :: IO ()
loop = do
    -- Wait until anyting to save.
    Maybe a
ms <- ChanSave a -> IO (Maybe a)
forall a. MVar a -> IO a
takeMVar ChanSave a
toSave
    case Maybe a
ms of
      Just s :: a
s -> do
        FilePath
dataDir <- IO FilePath
appDataDir
        FilePath -> IO ()
tryCreateDir (FilePath
dataDir FilePath -> FilePath -> FilePath
</> "saves")
        let fileName :: FilePath
fileName = a -> FilePath
stateToFileName a
s
        IO ()
yield  -- minimize UI lag due to saving
        FilePath -> Version -> a -> IO ()
forall b. Binary b => FilePath -> Version -> b -> IO ()
encodeEOF (FilePath
dataDir FilePath -> FilePath -> FilePath
</> "saves" FilePath -> FilePath -> FilePath
</> FilePath
fileName)
                  (RuleContent -> Version
rexeVersion (RuleContent -> Version) -> RuleContent -> Version
forall a b. (a -> b) -> a -> b
$ COps -> RuleContent
corule COps
cops)
                  a
s
        -- Wait until the save finished. During that time, the mvar
        -- is continually updated to newest state values.
        IO ()
loop
      Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- exit

wrapInSaves :: Binary a
            => COps -> (a -> FilePath) -> (ChanSave a -> IO ()) -> IO ()
{-# INLINE wrapInSaves #-}
wrapInSaves :: COps -> (a -> FilePath) -> (ChanSave a -> IO ()) -> IO ()
wrapInSaves cops :: COps
cops stateToFileName :: a -> FilePath
stateToFileName exe :: ChanSave a -> IO ()
exe = do
  -- We don't merge this with the other calls to waitForChildren,
  -- because, e.g., for server, we don't want to wait for clients to exit,
  -- if the server crashes (but we wait for the save to finish).
  ChanSave a
toSave <- IO (ChanSave a)
forall a. IO (MVar a)
newEmptyMVar
  Async ()
a <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ COps -> (a -> FilePath) -> ChanSave a -> IO ()
forall a.
Binary a =>
COps -> (a -> FilePath) -> ChanSave a -> IO ()
loopSave COps
cops a -> FilePath
stateToFileName ChanSave a
toSave
  Async () -> IO ()
forall a. Async a -> IO ()
link Async ()
a
  let fin :: IO ()
fin = do
        -- Wait until the last save (if any) starts
        -- and tell the save thread to end.
        ChanSave a -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar ChanSave a
toSave Maybe a
forall a. Maybe a
Nothing
        -- Wait 0.5s to flush debug and then until the save thread ends.
        Int -> IO ()
threadDelay 500000
        Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
a
  ChanSave a -> IO ()
exe ChanSave a
toSave IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`Ex.finally` IO ()
fin
  -- The creation of, e.g., the initial client state, is outside the 'finally'
  -- clause, but this is OK, since no saves are ordered until 'runActionCli'.
  -- We save often, not only in the 'finally' section, in case of
  -- power outages, kill -9, GHC runtime crashes, etc. For internal game
  -- crashes, C-c, etc., the finalizer would be enough.
  -- If we implement incremental saves, saving often will help
  -- to spread the cost, to avoid a long pause at game exit.

-- | Restore a saved game, if it exists. Initialize directory structure
-- and copy over data files, if needed.
restoreGame :: Binary a
            => RuleContent -> ClientOptions -> FilePath -> IO (Maybe a)
restoreGame :: RuleContent -> ClientOptions -> FilePath -> IO (Maybe a)
restoreGame corule :: RuleContent
corule clientOptions :: ClientOptions
clientOptions fileName :: FilePath
fileName = do
  -- Create user data directory and copy files, if not already there.
  FilePath
dataDir <- IO FilePath
appDataDir
  FilePath -> IO ()
tryCreateDir FilePath
dataDir
  let path :: FilePath
path = FilePath
dataDir FilePath -> FilePath -> FilePath
</> "saves" FilePath -> FilePath -> FilePath
</> FilePath
fileName
  Bool
saveExists <- FilePath -> IO Bool
doesFileExist FilePath
path
  -- If the savefile exists but we get IO or decoding errors,
  -- we show them and start a new game. If the savefile was randomly
  -- corrupted or made read-only, that should solve the problem.
  -- OTOH, serious IO problems (e.g. failure to create a user data directory)
  -- terminate the program with an exception.
  Either SomeException (Maybe a)
res <- IO (Maybe a) -> IO (Either SomeException (Maybe a))
forall e a. Exception e => IO a -> IO (Either e a)
Ex.try (IO (Maybe a) -> IO (Either SomeException (Maybe a)))
-> IO (Maybe a) -> IO (Either SomeException (Maybe a))
forall a b. (a -> b) -> a -> b
$
    if Bool
saveExists then do
      let vExe1 :: Version
vExe1 = RuleContent -> Version
rexeVersion RuleContent
corule
      (vExe2 :: Version
vExe2, s :: a
s) <- FilePath -> IO (Version, a)
forall b. Binary b => FilePath -> IO (Version, b)
strictDecodeEOF FilePath
path
      if Version -> Version -> Bool
compatibleVersion Version
vExe1 Version
vExe2
      then Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$! a
s a -> Maybe a -> Maybe a
forall a b. a -> b -> b
`seq` a -> Maybe a
forall a. a -> Maybe a
Just a
s
      else do
        let msg :: Text
msg = "Savefile" Text -> Text -> Text
<+> FilePath -> Text
T.pack FilePath
path
                  Text -> Text -> Text
<+> "from an incompatible version"
                  Text -> Text -> Text
<+> FilePath -> Text
T.pack (Version -> FilePath
showVersion Version
vExe2)
                  Text -> Text -> Text
<+> "detected while trying to restore"
                  Text -> Text -> Text
<+> FilePath -> Text
T.pack (Version -> FilePath
showVersion Version
vExe1)
                  Text -> Text -> Text
<+> "game."
        FilePath -> IO (Maybe a)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO (Maybe a)) -> FilePath -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
msg
    else Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
  let handler :: Ex.SomeException -> IO (Maybe a)
      handler :: SomeException -> IO (Maybe a)
handler e :: SomeException
e = do
        Bool
moveAside <- RuleContent -> ClientOptions -> IO Bool
bkpAllSaves RuleContent
corule ClientOptions
clientOptions
        let msg :: Text
msg = "Restore failed."
                  Text -> Text -> Text
<+> (if Bool
moveAside
                      then "The wrong file has been moved aside."
                      else "")
                  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 -> IO ()
delayPrint Text
msg
        Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
  (SomeException -> IO (Maybe a))
-> (Maybe a -> IO (Maybe a))
-> Either SomeException (Maybe a)
-> IO (Maybe a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO (Maybe a)
forall a. SomeException -> IO (Maybe a)
handler Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException (Maybe a)
res

-- Minor version discrepancy permitted.
compatibleVersion :: Version -> Version -> Bool
compatibleVersion :: Version -> Version -> Bool
compatibleVersion v1 :: Version
v1 v2 :: Version
v2 = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take 3 (Version -> [Int]
versionBranch Version
v1) [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take 3 (Version -> [Int]
versionBranch Version
v2)

delayPrint :: Text -> IO ()
delayPrint :: Text -> IO ()
delayPrint t :: Text
t = do
  SMGen
smgen <- IO SMGen
SM.newSMGen
  let (delay :: Int
delay, _) = Int -> SMGen -> (Int, SMGen)
forall a. Integral a => a -> SMGen -> (a, SMGen)
nextRandom 10000 SMGen
smgen
  Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ 100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
delay  -- try not to interleave saves with other clients
  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
<> "\n"  -- hPutStrLn not atomic enough
  Handle -> IO ()
hFlush Handle
stdout

saveNameCli :: RuleContent -> FactionId -> String
saveNameCli :: RuleContent -> FactionId -> FilePath
saveNameCli corule :: RuleContent
corule side :: FactionId
side =
  let gameShortName :: FilePath
gameShortName =
        case FilePath -> [FilePath]
words (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ RuleContent -> FilePath
rtitle RuleContent
corule of
          w :: FilePath
w : _ -> FilePath
w
          _ -> "Game"
      n :: Int
n = FactionId -> Int
forall a. Enum a => a -> Int
fromEnum FactionId
side  -- we depend on the numbering hack to number saves
  in FilePath
gameShortName
     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
         then ".human_" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n
         else ".computer_" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (-Int
n))
     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ".sav"

saveNameSer :: RuleContent -> String
saveNameSer :: RuleContent -> FilePath
saveNameSer corule :: RuleContent
corule =
  let gameShortName :: FilePath
gameShortName =
        case FilePath -> [FilePath]
words (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ RuleContent -> FilePath
rtitle RuleContent
corule of
          w :: FilePath
w : _ -> FilePath
w
          _ -> "Game"
  in FilePath
gameShortName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ".server.sav"

bkpAllSaves :: RuleContent -> ClientOptions -> IO Bool
bkpAllSaves :: RuleContent -> ClientOptions -> IO Bool
bkpAllSaves corule :: RuleContent
corule clientOptions :: ClientOptions
clientOptions = do
  FilePath
dataDir <- IO FilePath
appDataDir
  let benchmark :: Bool
benchmark = ClientOptions -> Bool
sbenchmark ClientOptions
clientOptions
      defPrefix :: FilePath
defPrefix = ClientOptions -> FilePath
ssavePrefixCli ClientOptions
defClientOptions
      moveAside :: Bool
moveAside = Bool -> Bool
not Bool
benchmark Bool -> Bool -> Bool
&& ClientOptions -> FilePath
ssavePrefixCli ClientOptions
clientOptions FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
defPrefix
      bkpOneSave :: FilePath -> IO ()
bkpOneSave name :: FilePath
name = do
        let pathSave :: FilePath -> FilePath
pathSave bkp :: FilePath
bkp = FilePath
dataDir FilePath -> FilePath -> FilePath
</> "saves" FilePath -> FilePath -> FilePath
</> FilePath
bkp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
defPrefix FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
name
        Bool
b <- FilePath -> IO Bool
doesFileExist (FilePath -> FilePath
pathSave "")
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
renameFile (FilePath -> FilePath
pathSave "") (FilePath -> FilePath
pathSave "bkp.")
      bkpAll :: IO ()
bkpAll = do
        FilePath -> IO ()
bkpOneSave (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ RuleContent -> FilePath
saveNameSer RuleContent
corule
        [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t a -> (a -> m ()) -> m ()
forM_ [-199..199] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \n :: Int
n ->
          FilePath -> IO ()
bkpOneSave (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ RuleContent -> FactionId -> FilePath
saveNameCli RuleContent
corule (Int -> FactionId
forall a. Enum a => Int -> a
toEnum Int
n)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
moveAside IO ()
bkpAll
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
moveAside