feat(gs/xanthous): Allow disabling saving

Add a command-line parameter to disable the Save command, so people
don't save and fill up my disk when I'm running this on the internet.

Change-Id: I2408e60de2d99764ac53c21c3ea784282576d400
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3808
Reviewed-by: grfn <grfn@gws.fyi>
Tested-by: BuildkiteCI
This commit is contained in:
Griffin Smith 2021-11-07 15:44:57 -05:00 committed by grfn
parent e3724448a2
commit 9577d97a8f
4 changed files with 68 additions and 34 deletions

View file

@ -1,3 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
module Main ( main ) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (finally)
@ -12,6 +14,7 @@ import System.Exit (die)
--------------------------------------------------------------------------------
import qualified Xanthous.Game as Game
import Xanthous.Game.Env (GameEnv(..))
import qualified Xanthous.Game.Env as Game
import Xanthous.App
import Xanthous.Generators.Level
( GeneratorInput
@ -26,9 +29,17 @@ import Xanthous.Data (Dimensions, Dimensions'(Dimensions))
import Data.Array.IArray ( amap )
--------------------------------------------------------------------------------
parseGameConfig :: Opt.Parser Game.Config
parseGameConfig = Game.Config
<$> Opt.switch
( Opt.long "disable-saving"
<> Opt.help "Disallow saving games"
)
data RunParams = RunParams
{ seed :: Maybe Int
, characterName :: Maybe Text
, gameConfig :: Game.Config
}
deriving stock (Show, Eq)
@ -46,6 +57,7 @@ parseRunParams = RunParams
<> "will be prompted for at runtime"
)
))
<*> parseGameConfig
data Command
= Run RunParams
@ -104,7 +116,7 @@ newGame rparams = do
let initialState = Game.initialStateFromSeed gameSeed &~ do
for_ (characterName rparams) $ \cn ->
Game.character . Character.characterName ?= cn
runGame NewGame initialState `finally` do
runGame NewGame (gameConfig rparams) initialState `finally` do
thanks
when (isNothing $ seed rparams)
. putStrLn
@ -115,19 +127,19 @@ loadGame :: FilePath -> IO ()
loadGame saveFile = do
gameState <- maybe (die "Invalid save file!") pure . Game.loadGame . fromStrict
=<< readFile @IO saveFile
gameState `deepseq` runGame (LoadGame saveFile) gameState
gameState `deepseq` runGame (LoadGame saveFile) Game.defaultConfig gameState
runGame :: RunType -> Game.GameState -> IO ()
runGame rt gameState = do
eventChan <- Brick.BChan.newBChan 10
let gameEnv = GameEnv eventChan
runGame :: RunType -> Game.Config -> Game.GameState -> IO ()
runGame rt _config gameState = do
_eventChan <- Brick.BChan.newBChan 10
let gameEnv = GameEnv {..}
app <- makeApp gameEnv rt
let buildVty = Vty.mkVty Vty.defaultConfig
initialVty <- buildVty
_game' <- customMain
initialVty
buildVty
(Just eventChan)
(Just _eventChan)
app
gameState
pure ()

View file

@ -332,31 +332,34 @@ handleCommand Fire = do
let enemies = los >>= \(_, es) -> toList $ headMay es
in enemies ^? folded . below _SomeEntity
handleCommand Save = do
-- TODO default save locations / config file?
use savefile >>= \case
Just filepath ->
stringPromptWithDefault_
["save", "location"]
Cancellable
(pack filepath)
promptCallback
Nothing -> prompt_ @'StringPrompt ["save", "location"] Cancellable promptCallback
continue
where
promptCallback :: PromptResult 'StringPrompt -> AppM ()
promptCallback (StringResult filename) = do
sf <- use savefile
exists <- liftIO . doesFileExist $ unpack filename
if exists && sf /= Just (unpack filename)
then confirm ["save", "overwrite"] (object ["filename" A..= filename])
$ doSave filename
else doSave filename
doSave filename = do
src <- gets saveGame
lift . liftIO $ do
writeFile (unpack filename) $ toStrict src
exitSuccess
handleCommand Save =
view (config . disableSaving) >>= \case
True -> say_ ["save", "disabled"] >> continue
False -> do
-- TODO default save locations / config file?
use savefile >>= \case
Just filepath ->
stringPromptWithDefault_
["save", "location"]
Cancellable
(pack filepath)
promptCallback
Nothing -> prompt_ @'StringPrompt ["save", "location"] Cancellable promptCallback
continue
where
promptCallback :: PromptResult 'StringPrompt -> AppM ()
promptCallback (StringResult filename) = do
sf <- use savefile
exists <- liftIO . doesFileExist $ unpack filename
if exists && sf /= Just (unpack filename)
then confirm ["save", "overwrite"] (object ["filename" A..= filename])
$ doSave filename
else doSave filename
doSave filename = do
src <- gets saveGame
lift . liftIO $ do
writeFile (unpack filename) $ toStrict src
exitSuccess
handleCommand GoUp = do
hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity UpStaircase)

View file

@ -1,8 +1,12 @@
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Game.Env
( GameEnv(..)
( Config(..)
, defaultConfig
, disableSaving
, GameEnv(..)
, eventChan
, config
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
@ -11,9 +15,23 @@ import Brick.BChan (BChan)
import Xanthous.Data.App (AppEvent)
--------------------------------------------------------------------------------
data Config = Config
{ _disableSaving :: Bool
}
deriving stock (Generic, Show, Eq)
makeLenses ''Config
{-# ANN Config ("HLint: ignore Use newtype instead of data" :: String) #-}
defaultConfig :: Config
defaultConfig = Config
{ _disableSaving = False
}
--------------------------------------------------------------------------------
data GameEnv = GameEnv
{ _eventChan :: BChan AppEvent
, _config :: Config
}
deriving stock (Generic)
makeLenses ''GameEnv
{-# ANN GameEnv ("HLint: ignore Use newtype instead of data" :: String) #-}

View file

@ -9,6 +9,7 @@ generic:
continue: Press enter to continue...
save:
disabled: "Sorry, saving is currently disabled"
location: "Enter filename to save to: "
overwrite: "A file named {{filename}} already exists. Would you like to overwrite it? "