Factor out JS and HS file handling

Game/LambdaHack/Client/FileClient.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE CPP #-}
+-- | Saving/loading with serialization and compression.
+module Game.LambdaHack.Client.FileClient
+  ( encodeEOF, strictDecodeEOF, tryCreateDir, tryCopyDataFiles, appDataDir
+  ) where
+
+#ifdef USE_JSFILE_CLIENT
+import Game.LambdaHack.Common.JSFile
+#else
+import Game.LambdaHack.Common.HSFile
+#endif

Game/LambdaHack/Client/MonadClient.hs

@@ -16,10 +16,10 @@ import Data.Text (Text)
 import System.Directory
 import System.FilePath
 
+import Game.LambdaHack.Client.FileClient
 import Game.LambdaHack.Client.State
 import Game.LambdaHack.Common.ClientOptions
 import Game.LambdaHack.Common.Faction
-import Game.LambdaHack.Common.File
 import qualified Game.LambdaHack.Common.Kind as Kind
 import Game.LambdaHack.Common.Misc
 import Game.LambdaHack.Common.MonadStateRead
@@ -73,7 +73,8 @@ restoreGame = do
     let copies = [( "GameDefinition" </> cfgUIName <.> "default"
                   , cfgUIName <.> "ini" )]
         name = fromMaybe "save" prefix <.> saveName side isAI
-    liftIO $ Save.restoreGame name copies pathsDataFile
+    liftIO $ Save.restoreGame tryCreateDir tryCopyDataFiles strictDecodeEOF
+                              name copies pathsDataFile
 
 -- | Assuming the client runs on the same machine and for the same
 -- user as the server, move the server savegame out of the way.

Game/LambdaHack/Client/UI/Config.hs

@@ -21,9 +21,9 @@ import System.Directory
 import System.FilePath
 import Text.Read
 
+import Game.LambdaHack.Client.FileClient
 import qualified Game.LambdaHack.Client.Key as K
 import Game.LambdaHack.Client.UI.HumanCmd
-import Game.LambdaHack.Common.File
 import qualified Game.LambdaHack.Common.Kind as Kind
 import Game.LambdaHack.Common.Msg
 import Game.LambdaHack.Content.RuleKind

Game/LambdaHack/Common/File.hs → Game/LambdaHack/Common/HSFile.hs

@@ -1,5 +1,5 @@
 -- | Saving/loading with serialization and compression.
-module Game.LambdaHack.Common.File
+module Game.LambdaHack.Common.HSFile
   ( encodeEOF, strictDecodeEOF, tryCreateDir, tryCopyDataFiles, appDataDir
   ) where
 

Game/LambdaHack/Common/JSFile.hs

@@ -0,0 +1,45 @@
+-- | Saving/loading with serialization and compression.
+module Game.LambdaHack.Common.JSFile
+  ( encodeEOF, strictDecodeEOF, tryCreateDir, tryCopyDataFiles, appDataDir
+  ) where
+
+import Data.Binary
+import qualified Data.Char as Char
+import System.Directory
+import System.Environment
+
+-- TODO: implement using on of the data stores available in browsers
+-- and one of the compression libs/packages/js sources
+
+-- | Serialize, compress and save data with an EOF marker.
+-- The @OK@ is used as an EOF marker to ensure any apparent problems with
+-- corrupted files are reported to the user ASAP.
+encodeEOF :: Binary a => FilePath -> a -> IO ()
+encodeEOF _f _a = return ()
+
+-- | Read, decompress and deserialize data with an EOF marker.
+-- The @OK@ EOF marker ensures any easily detectable file corruption
+-- is discovered and reported before the function returns.
+strictDecodeEOF :: Binary a => FilePath -> IO a
+strictDecodeEOF _f = error "file handling not yet implemented on browser"
+
+-- | Try to create a directory, if it doesn't exist. We catch exceptions
+-- in case many clients try to do the same thing at the same time.
+tryCreateDir :: FilePath -> IO ()
+tryCreateDir _dir = return ()
+
+-- | Try to copy over data files, if not already there. We catch exceptions
+-- in case many clients try to do the same thing at the same time.
+tryCopyDataFiles :: FilePath
+                 -> (FilePath -> IO FilePath)
+                 -> [(FilePath, FilePath)]
+                 -> IO ()
+tryCopyDataFiles _dataDir _pathsDataFile _files = return ()
+
+-- | Personal data directory for the game. Depends on the OS and the game,
+-- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@.
+appDataDir :: IO FilePath
+appDataDir = do
+  progName <- getProgName
+  let name = takeWhile Char.isAlphaNum progName
+  getAppUserDataDirectory name

Game/LambdaHack/Common/Save.hs

@@ -8,17 +8,22 @@ import Control.Concurrent.Async
 import qualified Control.Exception as Ex hiding (handle)
 import Control.Monad
 import Data.Binary
+import qualified Data.Char as Char
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import System.Directory
+import System.Environment
 import System.FilePath
 import System.IO
 import qualified System.Random as R
 
-import Game.LambdaHack.Common.File
 import Game.LambdaHack.Common.Msg
 
+-- TODO: refactor all this somehow, preferably restricting the use
+-- of IO and/or making these operations a part of the Client
+-- and Server monads
+
 type ChanSave a = MVar (Maybe a)
 
 saveToChan :: ChanSave a -> a -> IO ()
@@ -36,8 +41,9 @@ saveToChan toSave s = do
 -- All this is not needed if we bkp save each turn, but that's costly.
 
 -- | Repeatedly save a simple serialized version of the current state.
-loopSave :: Binary a => (a -> FilePath) -> ChanSave a -> IO ()
-loopSave saveFile toSave =
+loopSave :: Binary a => (FilePath -> IO ()) -> (FilePath -> a -> IO ())
+         -> (a -> FilePath) -> ChanSave a -> IO ()
+loopSave tryCreateDir encodeEOF saveFile toSave =
   loop
  where
   loop = do
@@ -53,13 +59,14 @@ loopSave saveFile toSave =
         loop
       Nothing -> return ()  -- exit
 
-wrapInSaves :: Binary a => (a -> FilePath) -> (ChanSave a -> IO ()) -> IO ()
-wrapInSaves saveFile exe = do
+wrapInSaves :: Binary a => (FilePath -> IO ()) -> (FilePath -> a -> IO ())
+            -> (a -> FilePath) -> (ChanSave a -> IO ()) -> IO ()
+wrapInSaves tryCreateDir encodeEOF saveFile exe = do
   -- We don't merge this with the other calls to waitForChildren,
   -- because, e.g., for server, we don't want to wait for clients to exit,
   -- if the server crashes (but we wait for the save to finish).
   toSave <- newEmptyMVar
-  a <- async $ loopSave saveFile toSave
+  a <- async $ loopSave tryCreateDir encodeEOF saveFile toSave
   link a
   let fin = do
         -- Wait until the last save (if any) starts
@@ -80,9 +87,15 @@ wrapInSaves saveFile exe = do
 -- | Restore a saved game, if it exists. Initialize directory structure
 -- and copy over data files, if needed.
 restoreGame :: Binary a
-            => String -> [(FilePath, FilePath)] -> (FilePath -> IO FilePath)
+            => (FilePath -> IO ())
+            -> (FilePath
+                -> (FilePath -> IO FilePath)
+                -> [(FilePath, FilePath)]
+                -> IO ())
+            -> (FilePath -> IO a)
+            -> String -> [(FilePath, FilePath)] -> (FilePath -> IO FilePath)
             -> IO (Maybe a)
-restoreGame name copies pathsDataFile = do
+restoreGame tryCreateDir tryCopyDataFiles strictDecodeEOF name copies pathsDataFile = do
   -- Create user data directory and copy files, if not already there.
   dataDir <- appDataDir
   tryCreateDir dataDir
@@ -113,3 +126,12 @@ delayPrint t = do
   threadDelay delay  -- try not to interleave saves with other clients
   T.hPutStrLn stderr t
   hFlush stderr
+
+-- TODO: deduplicate
+-- | Personal data directory for the game. Depends on the OS and the game,
+-- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@.
+appDataDir :: IO FilePath
+appDataDir = do
+  progName <- getProgName
+  let name = takeWhile Char.isAlphaNum progName
+  getAppUserDataDirectory name

Game/LambdaHack/SampleImplementation/SampleMonadClient.hs

@@ -24,6 +24,7 @@ import System.FilePath
 import Game.LambdaHack.Atomic.HandleAtomicWrite
 import Game.LambdaHack.Atomic.MonadAtomic
 import Game.LambdaHack.Atomic.MonadStateWrite
+import Game.LambdaHack.Client.FileClient
 import Game.LambdaHack.Client.MonadClient
 import Game.LambdaHack.Client.ProtocolClient
 import Game.LambdaHack.Client.State
@@ -103,4 +104,4 @@ executorCli m cliSession cliState cliClient cliDict =
         <.> saveName (sside cli2) (sisAI cli2)
       exe cliToSave =
         evalStateT (runCliImplementation m) CliState{..}
-  in Save.wrapInSaves saveFile exe
+  in Save.wrapInSaves tryCreateDir encodeEOF saveFile exe

Game/LambdaHack/SampleImplementation/SampleMonadServer.hs

@@ -31,6 +31,7 @@ import qualified Game.LambdaHack.Common.Save as Save
 import Game.LambdaHack.Common.State
 import Game.LambdaHack.Common.Thread
 import Game.LambdaHack.Server.CommonServer
+import Game.LambdaHack.Server.FileServer
 import Game.LambdaHack.Server.MonadServer
 import Game.LambdaHack.Server.ProtocolServer
 import Game.LambdaHack.Server.State
@@ -108,7 +109,7 @@ executorSer m = do
                    , serDict = EM.empty
                    , serToSave
                    }
-      exeWithSaves = Save.wrapInSaves saveFile exe
+      exeWithSaves = Save.wrapInSaves tryCreateDir encodeEOF saveFile exe
   -- Wait for clients to exit even in case of server crash
   -- (or server and client crash), which gives them time to save
   -- and report their own inconsistencies, if any.

Game/LambdaHack/Server/FileServer.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE CPP #-}
+-- | Saving/loading with serialization and compression.
+module Game.LambdaHack.Server.FileServer
+  ( encodeEOF, strictDecodeEOF, tryCreateDir, tryCopyDataFiles, appDataDir
+  ) where
+
+#ifdef USE_JSFILE_SERVER
+import Game.LambdaHack.Common.JSFile
+#else
+import Game.LambdaHack.Common.HSFile
+#endif

Game/LambdaHack/Server/MonadServer.hs

@@ -38,7 +38,6 @@ import Game.LambdaHack.Common.Actor
 import Game.LambdaHack.Common.ActorState
 import Game.LambdaHack.Common.ClientOptions
 import Game.LambdaHack.Common.Faction
-import Game.LambdaHack.Common.File
 import qualified Game.LambdaHack.Common.HighScore as HighScore
 import qualified Game.LambdaHack.Common.Kind as Kind
 import Game.LambdaHack.Common.Misc
@@ -52,6 +51,7 @@ import qualified Game.LambdaHack.Common.Tile as Tile
 import Game.LambdaHack.Common.Time
 import Game.LambdaHack.Content.ModeKind
 import Game.LambdaHack.Content.RuleKind
+import Game.LambdaHack.Server.FileServer
 import Game.LambdaHack.Server.State
 
 class MonadStateRead m => MonadServer m where
@@ -241,7 +241,7 @@ tryRestore Kind.COps{corule} sdebugSer = do
     let copies = [( "GameDefinition" </> scoresFile
                   , scoresFile )]
         name = fromMaybe "save" prefix <.> saveName
-    liftIO $ Save.restoreGame name copies pathsDataFile
+    liftIO $ Save.restoreGame tryCreateDir tryCopyDataFiles strictDecodeEOF name copies pathsDataFile
 
 -- | Compute and insert auxiliary optimized components into game content,
 -- to be used in time-critical sections of the code.

LambdaHack.cabal

@@ -121,6 +121,7 @@ library
                       Game.LambdaHack.Client.Bfs,
                       Game.LambdaHack.Client.BfsClient,
                       Game.LambdaHack.Client.CommonClient,
+                      Game.LambdaHack.Client.FileClient,
                       Game.LambdaHack.Client.HandleAtomicClient,
                       Game.LambdaHack.Client.HandleResponseClient,
                       Game.LambdaHack.Client.ItemSlot,
@@ -158,7 +159,6 @@ library
                       Game.LambdaHack.Common.Dice,
                       Game.LambdaHack.Common.EffectDescription,
                       Game.LambdaHack.Common.Faction,
-                      Game.LambdaHack.Common.File,
                       Game.LambdaHack.Common.Flavour,
                       Game.LambdaHack.Common.Frequency,
                       Game.LambdaHack.Common.HighScore,
@@ -202,6 +202,7 @@ library
                       Game.LambdaHack.Server.DungeonGen.Cave,
                       Game.LambdaHack.Server.DungeonGen.Place,
                       Game.LambdaHack.Server.EndServer,
+                      Game.LambdaHack.Server.FileServer,
                       Game.LambdaHack.Server.Fov,
                       Game.LambdaHack.Server.Fov.Common,
                       Game.LambdaHack.Server.Fov.Digital,
@@ -245,8 +246,7 @@ library
                       text       >= 0.11.2.3 && < 2,
                       transformers >= 0.3   && < 1,
                       unordered-containers >= 0.2.3 && < 1,
-                      vector     >= 0.10    && < 1,
-                      zlib       >= 0.5.3.1 && < 1
+                      vector     >= 0.10    && < 1
 
   default-language:   Haskell2010
   default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings
@@ -267,9 +267,9 @@ library
   if flag(browser) {
     other-modules:    Game.LambdaHack.Client.UI.Frontend.Dom
     build-depends:    ghcjs-dom >= 0.2 && < 0.3
-    cpp-options:      -DUSE_BROWSER
+    cpp-options:      -DUSE_BROWSER -DUSE_JSFILE_CLIENT -DUSE_JSFILE_SERVER
 --TODO:    with-compiler: ghcjs (so that --ghcjs on commandline not needed)
---TODO:    js-sources: a drop-in replacement for zlib when there is one
+--         compiler: ghcjs    ???
   } else { if flag(webkit) {
     other-modules:    Game.LambdaHack.Client.UI.Frontend.Dom
     build-depends:    ghcjs-dom >= 0.2 && < 0.3
@@ -289,6 +289,14 @@ library
     pkgconfig-depends: gtk+-2.0
   } } } }
 
+  if flag(browser) {
+    other-modules:    Game.LambdaHack.Common.JSFile
+--TODO:    js-sources: a drop-in replacement for zlib when there is one
+  } else {
+    other-modules:    Game.LambdaHack.Common.HSFile
+    build-depends:    zlib >= 0.5.3.1 && < 1
+  }
+
   if flag(expose_internal)
     cpp-options:      -DEXPOSE_INTERNAL
 
@@ -347,8 +355,7 @@ executable LambdaHack
                       text       >= 0.11.2.3 && < 2,
                       transformers >= 0.3   && < 1,
                       unordered-containers >= 0.2.3 && < 1,
-                      vector     >= 0.10    && < 1,
-                      zlib       >= 0.5.3.1 && < 1
+                      vector     >= 0.10    && < 1
 
   default-language:   Haskell2010
   default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings
@@ -359,6 +366,14 @@ executable LambdaHack
   ghc-options:        -fno-ignore-asserts -funbox-strict-fields
   ghc-options:        -threaded "-with-rtsopts=-C0.005" -rtsopts
 
+  if flag(browser) {
+--TODO:    js-sources: a drop-in replacement for zlib when there is one
+    default-language:   Haskell2010
+-- dummy
+  } else {
+    build-depends:    zlib >= 0.5.3.1 && < 1
+  }
+
   if flag(release)
     ghc-options:      -O2 -fno-ignore-asserts "-with-rtsopts=-N1"
 -- TODO: -N
@@ -397,8 +412,7 @@ test-suite test
                       text       >= 0.11.2.3 && < 2,
                       transformers >= 0.3   && < 1,
                       unordered-containers >= 0.2.3 && < 1,
-                      vector     >= 0.10    && < 1,
-                      zlib       >= 0.5.3.1 && < 1
+                      vector     >= 0.10    && < 1
 
   default-language:   Haskell2010
   default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings
@@ -409,6 +423,14 @@ test-suite test
   ghc-options:        -fno-ignore-asserts -funbox-strict-fields
   ghc-options:        -threaded "-with-rtsopts=-C0.005" -rtsopts
 
+  if flag(browser) {
+--TODO:    js-sources: a drop-in replacement for zlib when there is one
+    default-language:   Haskell2010
+-- dummy
+  } else {
+    build-depends:    zlib >= 0.5.3.1 && < 1
+  }
+
   if flag(release)
     ghc-options:      -O2 -fno-ignore-asserts "-with-rtsopts=-N1"
 -- TODO: -N