feat(gs/xanthous): Allow disabling saving r/3017

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

4 files changed, 68 insertions, 34 deletions

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? "