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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
{-# LANGUAGE JavaScriptFFI #-}
-- | Saving/loading to JS storeage, mimicking operations on files.
module Game.LambdaHack.Common.JSFile
(
#ifdef USE_JSFILE
-- to molify doctest, but don't break stylish-haskell parsing
encodeEOF, strictDecodeEOF
, tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile
#endif
) where
#ifdef USE_JSFILE
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Data.Binary
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Version
import qualified Data.JSString as JSString
import Data.JSString.Text (textToJSString)
import GHCJS.DOM (currentWindow)
import GHCJS.DOM.Storage (getItem, removeItem, setItem)
import GHCJS.DOM.Types (JSString, runDOM)
import GHCJS.DOM.Window (getLocalStorage)
foreign import javascript safe "$r = LZString.compressToUTF16($1);"
compressToUTF16 :: JSString -> IO JSString
foreign import javascript safe "$r = LZString.decompressFromUTF16($1);"
decompressFromUTF16 :: JSString -> IO JSString
-- | Serialize and save data with an EOF marker, compressing.
-- We treat the bytestring as Latin1 characters and so ensure
-- we never run into illegal characters in the aribtrary binary data,
-- unlike when treating it as UTF16 characters. This is also reasonably fast.
-- 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 = flip runDOM undefined $ do
Just win <- currentWindow
storage <- getLocalStorage win
let t = decodeLatin1 $ LBS.toStrict $ encode (v, (encode b, "OK" :: String))
item <- compressToUTF16 $ textToJSString t
setItem storage path item
-- | Read 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.
-- OTOH, binary encoding corruption is not discovered until a version
-- check elsewhere ensures that binary formats are compatible.
strictDecodeEOF :: Binary b => FilePath -> IO (Version, b)
strictDecodeEOF path = flip runDOM undefined $ do
Just win <- currentWindow
storage <- getLocalStorage win
Just item <- getItem storage path
t <- decompressFromUTF16 item
-- TODO: is @LBS.toLazy . encodeUtf8 . textFromJSString@ faster and correct?
let c1 = LBS.pack $ JSString.unpack t
(v1, (c2, s)) = decode c1
return $! if s == ("OK" :: String)
then (v1, decode c2)
else error $ "Fatal error: corrupted file " ++ path
-- | Try to create a directory; not needed with local storage in JS.
tryCreateDir :: FilePath -> IO ()
tryCreateDir _dir = return ()
doesFileExist :: FilePath -> IO Bool
doesFileExist path = flip runDOM undefined $ do
Just win <- currentWindow
storage <- getLocalStorage win
mitem <- getItem storage path
let fileExists = isJust (mitem :: Maybe String)
return $! fileExists
tryWriteFile :: FilePath -> String -> IO ()
tryWriteFile path content = flip runDOM undefined $ do
Just win <- currentWindow
storage <- getLocalStorage win
mitem <- getItem storage path
let fileExists = isJust (mitem :: Maybe String)
unless fileExists $
setItem storage path $ T.unpack content
readFile :: FilePath -> IO String
readFile path = flip runDOM undefined $ do
Just win <- currentWindow
storage <- getLocalStorage win
mitem <- getItem storage path
case mitem of
Nothing -> fail $ "Fatal error: no file " ++ path
Just item -> return item
renameFile :: FilePath -> FilePath -> IO ()
renameFile path path2 = flip runDOM undefined $ do
Just win <- currentWindow
storage <- getLocalStorage win
mitem <- getItem storage path
case mitem :: Maybe String of
Nothing -> fail $ "Fatal error: no file " ++ path
Just item -> do
setItem storage path2 item -- overwrites
removeItem storage path
#endif
|
