-- | Saving/loading to files, with serialization and compression.
module Game.LambdaHack.Common.HSFile
  ( encodeEOF, strictDecodeEOF
  , tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , encodeData
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Codec.Compression.Zlib as Z
import qualified Control.Exception as Ex
import           Data.Binary
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text.IO as T
import           Data.Version
import           System.Directory
import           System.FilePath
import           System.IO
  ( IOMode (..)
  , hClose
  , hSetEncoding
  , localeEncoding
  , openBinaryFile
  , readFile
  , utf8
  , withBinaryFile
  , withFile
  )

-- | Serialize and save data.
-- Note that LBS.writeFile opens the file in binary mode.
encodeData :: Binary a => FilePath -> a -> IO ()
encodeData :: forall a. Binary a => String -> a -> IO ()
encodeData String
path a
a = do
  let tmpPath :: String
tmpPath = String
path String -> String -> String
<.> String
"tmp"
  IO Handle -> (Handle -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Ex.bracketOnError
    (String -> IOMode -> IO Handle
openBinaryFile String
tmpPath IOMode
WriteMode)
    (\Handle
h -> Handle -> IO ()
hClose Handle
h IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
removeFile String
tmpPath)
    (\Handle
h -> do
       Handle -> ByteString -> IO ()
LBS.hPut Handle
h (ByteString -> IO ()) -> (a -> ByteString) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Binary a => a -> ByteString
encode (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$ a
a
       Handle -> IO ()
hClose Handle
h
       String -> String -> IO ()
renameFile String
tmpPath String
path
    )

-- | 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 b => FilePath -> Version -> b -> IO ()
encodeEOF :: forall b. Binary b => String -> Version -> b -> IO ()
encodeEOF String
path Version
v b
b =
  String -> (Version, (ByteString, String)) -> IO ()
forall a. Binary a => String -> a -> IO ()
encodeData String
path (Version
v, (ByteString -> ByteString
Z.compress (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ b -> ByteString
forall a. Binary a => a -> ByteString
encode b
b, String
"OK" :: String))

-- | Read, decompress and deserialize data with an EOF marker.
-- The @OK@ EOF marker ensures any easily detectable file corruption
-- is discovered and reported before any value is decoded from
-- the second component and before the file handle is closed.
-- OTOH, binary encoding corruption is not discovered until a version
-- check elswere ensures that binary formats are compatible.
strictDecodeEOF :: Binary b => FilePath -> IO (Version, b)
strictDecodeEOF :: forall b. Binary b => String -> IO (Version, b)
strictDecodeEOF String
path =
  String -> IOMode -> (Handle -> IO (Version, b)) -> IO (Version, b)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path IOMode
ReadMode ((Handle -> IO (Version, b)) -> IO (Version, b))
-> (Handle -> IO (Version, b)) -> IO (Version, b)
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    ByteString
c1 <- Handle -> IO ByteString
LBS.hGetContents Handle
h
    let (Version
v1, (ByteString
c2, String
s)) = ByteString -> (Version, (ByteString, String))
forall a. Binary a => ByteString -> a
decode ByteString
c1
    (Version, b) -> IO (Version, b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Version, b) -> IO (Version, b))
-> (Version, b) -> IO (Version, b)
forall a b. (a -> b) -> a -> b
$! if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String
"OK" :: String)
              then (Version
v1, ByteString -> b
forall a. Binary a => ByteString -> a
decode (ByteString -> b) -> ByteString -> b
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Z.decompress ByteString
c2)
              else String -> (Version, b)
forall a. HasCallStack => String -> a
error (String -> (Version, b)) -> String -> (Version, b)
forall a b. (a -> b) -> a -> b
$ String
"Fatal error: corrupted file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path

-- | 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 :: String -> IO ()
tryCreateDir String
dir = do
  Bool
dirExists <- String -> IO Bool
doesDirectoryExist String
dir
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dirExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Ex.handle (\(IOException
_ :: Ex.IOException) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              (String -> IO ()
createDirectory String
dir)

-- | Try to write a file, given content, if the file not already there.
-- We catch exceptions in case many clients and/or the server try to do
-- the same thing at the same time. Using `Text.IO` to avoid UTF conflicts
-- with OS or filesystem.
tryWriteFile :: FilePath -> Text -> IO ()
tryWriteFile :: String -> Text -> IO ()
tryWriteFile String
path Text
content = do
  Bool
fileExists <- String -> IO Bool
doesFileExist String
path
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
fileExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- With some luck, locale was already corrected in Main.hs, but just
    -- in case, we make sure not to save UTF files in too primitve encodings.
    let enc :: TextEncoding
enc = TextEncoding
localeEncoding
    (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Ex.handle (\(IOException
ex :: Ex.IOException) -> String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
ex) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TextEncoding -> String
forall a. Show a => a -> String
show TextEncoding
enc String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"ASCII", String
"ISO-8859-1", String
"ISO-8859-2"]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
        Handle -> Text -> IO ()
T.hPutStr Handle
h Text
content