From 9577d97a8f351e6dc1057c7ec9f7c825f6e9a020 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sun, 7 Nov 2021 15:44:57 -0500 Subject: 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 Tested-by: BuildkiteCI --- users/grfn/xanthous/app/Main.hs | 26 +++++++++---- users/grfn/xanthous/src/Xanthous/App.hs | 53 ++++++++++++++------------ users/grfn/xanthous/src/Xanthous/Game/Env.hs | 22 ++++++++++- users/grfn/xanthous/src/Xanthous/messages.yaml | 1 + 4 files changed, 68 insertions(+), 34 deletions(-) (limited to 'users') diff --git a/users/grfn/xanthous/app/Main.hs b/users/grfn/xanthous/app/Main.hs index e67ad4ac9992..c771a0d932cb 100644 --- a/users/grfn/xanthous/app/Main.hs +++ b/users/grfn/xanthous/app/Main.hs @@ -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 () diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs index 9318c713478b..78f9e76775d9 100644 --- a/users/grfn/xanthous/src/Xanthous/App.hs +++ b/users/grfn/xanthous/src/Xanthous/App.hs @@ -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) diff --git a/users/grfn/xanthous/src/Xanthous/Game/Env.hs b/users/grfn/xanthous/src/Xanthous/Game/Env.hs index 6e10d0f73581..5d7b275c8a0b 100644 --- a/users/grfn/xanthous/src/Xanthous/Game/Env.hs +++ b/users/grfn/xanthous/src/Xanthous/Game/Env.hs @@ -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) #-} diff --git a/users/grfn/xanthous/src/Xanthous/messages.yaml b/users/grfn/xanthous/src/Xanthous/messages.yaml index a906650aa7f8..d207a73bf663 100644 --- a/users/grfn/xanthous/src/Xanthous/messages.yaml +++ b/users/grfn/xanthous/src/Xanthous/messages.yaml @@ -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? " -- cgit 1.4.1