module Game.LambdaHack.Common.Save
( ChanSave, saveToChan, wrapInSaves, restoreGame
, compatibleVersion, delayPrint
, saveNameCli, saveNameSer, bkpAllSaves
#ifdef EXPOSE_INTERNAL
, 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 :: forall a. ChanSave a -> a -> IO ()
saveToChan ChanSave a
toSave a
s = do
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
loopSave :: Binary a => COps -> (a -> FilePath) -> ChanSave a -> IO ()
loopSave :: forall a. Binary a => COps -> (a -> String) -> ChanSave a -> IO ()
loopSave COps
cops a -> String
stateToFileName ChanSave a
toSave =
IO ()
loop
where
loop :: IO ()
loop = do
Maybe a
ms <- ChanSave a -> IO (Maybe a)
forall a. MVar a -> IO a
takeMVar ChanSave a
toSave
case Maybe a
ms of
Just a
s -> do
String
dataDir <- IO String
appDataDir
String -> IO ()
tryCreateDir (String
dataDir String -> String -> String
</> String
"saves")
let fileName :: String
fileName = a -> String
stateToFileName a
s
IO ()
yield
String -> Version -> a -> IO ()
forall b. Binary b => String -> Version -> b -> IO ()
encodeEOF (String
dataDir String -> String -> String
</> String
"saves" String -> String -> String
</> String
fileName)
(RuleContent -> Version
rexeVersion (RuleContent -> Version) -> RuleContent -> Version
forall a b. (a -> b) -> a -> b
$ COps -> RuleContent
corule COps
cops)
a
s
IO ()
loop
Maybe a
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
wrapInSaves :: Binary a
=> COps -> (a -> FilePath) -> (ChanSave a -> IO ()) -> IO ()
{-# INLINE wrapInSaves #-}
wrapInSaves :: forall a.
Binary a =>
COps -> (a -> String) -> (ChanSave a -> IO ()) -> IO ()
wrapInSaves COps
cops a -> String
stateToFileName ChanSave a -> IO ()
exe = do
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 -> String) -> ChanSave a -> IO ()
forall a. Binary a => COps -> (a -> String) -> ChanSave a -> IO ()
loopSave COps
cops a -> String
stateToFileName ChanSave a
toSave
Async () -> IO ()
forall a. Async a -> IO ()
link Async ()
a
let fin :: IO ()
fin = do
ChanSave a -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar ChanSave a
toSave Maybe a
forall a. Maybe a
Nothing
Int -> IO ()
threadDelay Int
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
restoreGame :: Binary a
=> RuleContent -> ClientOptions -> FilePath -> IO (Maybe a)
restoreGame :: forall a.
Binary a =>
RuleContent -> ClientOptions -> String -> IO (Maybe a)
restoreGame RuleContent
corule ClientOptions
clientOptions String
fileName = do
String
dataDir <- IO String
appDataDir
String -> IO ()
tryCreateDir String
dataDir
let path :: String
path = String
dataDir String -> String -> String
</> String
"saves" String -> String -> String
</> String
fileName
Bool
saveExists <- String -> IO Bool
doesFileExist String
path
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
(Version
vExe2, a
s) <- String -> IO (Version, a)
forall b. Binary b => String -> IO (Version, b)
strictDecodeEOF String
path
if Version -> Version -> Bool
compatibleVersion Version
vExe1 Version
vExe2
then Maybe a -> IO (Maybe a)
forall a. a -> IO 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 = Text
"Savefile" Text -> Text -> Text
<+> String -> Text
T.pack String
path
Text -> Text -> Text
<+> Text
"from an incompatible version"
Text -> Text -> Text
<+> String -> Text
T.pack (Version -> String
showVersion Version
vExe2)
Text -> Text -> Text
<+> Text
"detected while trying to restore"
Text -> Text -> Text
<+> String -> Text
T.pack (Version -> String
showVersion Version
vExe1)
Text -> Text -> Text
<+> Text
"game."
String -> IO (Maybe a)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Maybe a)) -> String -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
msg
else Maybe a -> IO (Maybe a)
forall a. a -> IO 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 :: forall a. SomeException -> IO (Maybe a)
handler SomeException
e = do
Bool
moveAside <- RuleContent -> ClientOptions -> IO Bool
bkpAllSaves RuleContent
corule ClientOptions
clientOptions
let msg :: Text
msg = Text
"Restore failed."
Text -> Text -> Text
<+> (if Bool
moveAside
then Text
"The wrong file has been 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 -> IO ()
delayPrint Text
msg
Maybe a -> IO (Maybe a)
forall a. a -> IO 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException (Maybe a)
res
compatibleVersion :: Version -> Version -> Bool
compatibleVersion :: Version -> Version -> Bool
compatibleVersion Version
v1 Version
v2 = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
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 Int
3 (Version -> [Int]
versionBranch Version
v2)
delayPrint :: Text -> IO ()
delayPrint :: Text -> IO ()
delayPrint Text
t = do
SMGen
smgen <- IO SMGen
SM.newSMGen
let (Int
delay, SMGen
_) = Int -> SMGen -> (Int, SMGen)
forall a. Integral a => a -> SMGen -> (a, SMGen)
nextRandom Int
10000 SMGen
smgen
Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
delay
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"
Handle -> IO ()
hFlush Handle
stdout
saveNameCli :: RuleContent -> FactionId -> String
saveNameCli :: RuleContent -> FactionId -> String
saveNameCli RuleContent
corule FactionId
side =
let gameShortName :: String
gameShortName =
case String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ RuleContent -> String
rtitle RuleContent
corule of
String
w : [String]
_ -> String
w
[String]
_ -> String
"Game"
in String
gameShortName
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".team_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (FactionId -> Int
forall a. Enum a => a -> Int
fromEnum FactionId
side)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".sav"
saveNameSer :: RuleContent -> String
saveNameSer :: RuleContent -> String
saveNameSer RuleContent
corule =
let gameShortName :: String
gameShortName =
case String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ RuleContent -> String
rtitle RuleContent
corule of
String
w : [String]
_ -> String
w
[String]
_ -> String
"Game"
in String
gameShortName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".server.sav"
bkpAllSaves :: RuleContent -> ClientOptions -> IO Bool
bkpAllSaves :: RuleContent -> ClientOptions -> IO Bool
bkpAllSaves RuleContent
corule ClientOptions
clientOptions = do
String
dataDir <- IO String
appDataDir
let benchmark :: Bool
benchmark = ClientOptions -> Bool
sbenchmark ClientOptions
clientOptions
defPrefix :: String
defPrefix = ClientOptions -> String
ssavePrefixCli ClientOptions
defClientOptions
moveAside :: Bool
moveAside = Bool -> Bool
not Bool
benchmark Bool -> Bool -> Bool
&& ClientOptions -> String
ssavePrefixCli ClientOptions
clientOptions String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
defPrefix
bkpOneSave :: String -> IO ()
bkpOneSave String
name = do
let pathSave :: String -> String
pathSave String
bkp = String
dataDir String -> String -> String
</> String
"saves" String -> String -> String
</> String
bkp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
defPrefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name
Bool
b <- String -> IO Bool
doesFileExist (String -> String
pathSave String
"")
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renameFile (String -> String
pathSave String
"") (String -> String
pathSave String
"bkp.")
bkpAll :: IO ()
bkpAll = do
String -> IO ()
bkpOneSave (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ RuleContent -> String
saveNameSer RuleContent
corule
[Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t a -> (a -> m ()) -> m ()
forM_ [-Int
199..Int
199] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
n ->
String -> IO ()
bkpOneSave (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ RuleContent -> FactionId -> String
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
moveAside