1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
-- | 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 path a = do
let tmpPath = path <.> "tmp"
Ex.bracketOnError
(openBinaryFile tmpPath WriteMode)
(\h -> hClose h >> removeFile tmpPath)
(\h -> do
LBS.hPut h . encode $ a
hClose h
renameFile tmpPath 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 path v b =
encodeData path (v, (Z.compress $ encode b, "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 path =
withBinaryFile path ReadMode $ \h -> do
c1 <- LBS.hGetContents h
let (v1, (c2, s)) = decode c1
return $! if s == ("OK" :: String)
then (v1, decode $ Z.decompress c2)
else error $ "Fatal error: corrupted file " ++ 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 dir = do
dirExists <- doesDirectoryExist dir
unless dirExists $
Ex.handle (\(_ :: Ex.IOException) -> return ())
(createDirectory 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 path content = do
fileExists <- doesFileExist path
unless fileExists $ 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 = localeEncoding
Ex.handle (\(ex :: Ex.IOException) -> print $ show ex) $
withFile path WriteMode $ \h -> do
when (show enc `elem` ["ASCII", "ISO-8859-1", "ISO-8859-2"]) $
hSetEncoding h utf8
T.hPutStr h content
|
