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

3 files changed, 49 insertions, 27 deletions

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