/
FileEmbedLzma.hs
224 lines (200 loc) · 8.03 KB
/
FileEmbedLzma.hs
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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
------------------------------------------------------------
-- |
-- Module : FileEmbedLzma
-- Copyright : (c) 2015-2018 Futurice, 2018 Oleg Grenrus
-- License : BSD-3-Clause
-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>
----------------------------------------------------------------------------
module FileEmbedLzma (
-- * Embed files
embedByteString,
embedLazyByteString,
embedText,
embedLazyText,
-- * Embed directories
embedDir,
embedRecursiveDir,
-- * Internal
-- ** Directory listing
listDirectoryFiles,
listRecursiveDirectoryFiles,
listDirectoryFilesF,
-- ** Template Haskell
lazyBytestringE,
) where
import Control.Arrow (first)
import Control.Monad (forM)
import Control.Monad.Trans.State.Strict (runState, state)
import Data.Foldable (for_)
import Data.Functor.Compose (Compose (..))
import Data.Int (Int64)
import Data.List (sort)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qAddDependentFile)
import System.Directory
(doesDirectoryExist, getDirectoryContents)
import System.FilePath (makeRelative, (</>))
import System.IO.Unsafe (unsafePerformIO)
import qualified Codec.Compression.Lzma as LZMA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Unsafe as BS.Unsafe
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LTE
#if MIN_VERSION_template_haskell(2,16,0)
import qualified Data.ByteString.Internal as BS.Internal
import Language.Haskell.TH.Syntax (Bytes (..))
#endif
-- $setup
-- >>> :set -XTemplateHaskell -dppr-cols=9999
-- >>> import qualified Data.ByteString.Lazy as LBS
-- >>> import qualified Data.ByteString as BS
-- >>> import qualified Data.Text.Lazy as LT
-- >>> import qualified Data.Text as T
listRecursiveDirectoryFiles :: FilePath -> IO [(FilePath, LBS.ByteString)]
listRecursiveDirectoryFiles = listDirectoryFilesF listRecursiveDirectoryFiles
listDirectoryFiles :: FilePath -> IO [(FilePath, LBS.ByteString)]
listDirectoryFiles = listDirectoryFilesF (\_ -> return [])
listDirectoryFilesF
:: (FilePath -> IO [(FilePath, LBS.ByteString)]) -- ^ what to do with a sub-directory
-> FilePath -> IO [(FilePath, LBS.ByteString)]
listDirectoryFilesF go topdir = do
names <- getDirectoryContents topdir
let properNames = filter (`notElem` [".", ".."]) names
paths <- forM properNames $ \name -> do
let path = topdir </> name
isDirectory <- doesDirectoryExist path
if isDirectory
then go path
else do
contents <- LBS.readFile path
return [(path, contents)]
return (concat paths)
makeAllRelative :: FilePath -> [(FilePath, a)] -> [(FilePath, a)]
makeAllRelative topdir = map (first (("/" ++) . makeRelative topdir))
-- | Makes lazy 'LBS.ByteString' expression.
-- Embedded value is compressed with LZMA.
lazyBytestringE :: LBS.ByteString -> Q Exp
lazyBytestringE lbs =
[| LZMA.decompress . LBS.fromStrict . unsafePerformIO |] `appE`
([| BS.Unsafe.unsafePackAddressLen |] `appE` l `appE` s)
where
bs = LBS.toStrict $ LZMA.compressWith params lbs
#if MIN_VERSION_template_haskell(2,16,0)
s = litE $ bytesPrimL $ bsToBytes bs
#else
s = litE $ stringPrimL $ BS.unpack bs
#endif
l = litE $ integerL $ fromIntegral $ BS.length bs
params = LZMA.defaultCompressParams
{- doesn't seem to affect much
{ LZMA.compressLevel = LZMA.CompressionLevel9
, LZMA.compressLevelExtreme = True
}
-}
#if MIN_VERSION_template_haskell(2,16,0)
bsToBytes :: BS.ByteString -> Bytes
bsToBytes (BS.Internal.PS fptr off len) = Bytes fptr (fromIntegral off) (fromIntegral len)
#endif
makeEmbeddedEntry :: Name -> (FilePath, (Int64, Int64)) -> Q Exp
makeEmbeddedEntry name (path, (off, len)) = do
let y = [| LBS.toStrict . LBS.take len . LBS.drop off |] `appE` varE name
[| (,) path |] `appE` y
concatEntries :: Traversable t => t LBS.ByteString -> (LBS.ByteString, t (Int64, Int64))
concatEntries xs = (bslEndo LBS.empty, ys)
where
(ys, (_, bslEndo)) = runState (traverse (state . single) xs) (0, id)
single
:: LBS.ByteString -- file bytestring
-> (Int64, LBS.ByteString -> LBS.ByteString) -- current offset, buffer so far
-> ((Int64, Int64), (Int64, LBS.ByteString -> LBS.ByteString))
single bsl (off, endo) = ((off, l), (off + l, endo . LBS.append bsl))
where
l = fromIntegral $ LBS.length bsl
-------------------------------------------------------------------------------
-- Directories
-------------------------------------------------------------------------------
-- | Embed a @[('FilePath', 'Data.ByteString.ByteString')]@ list, traversing given directory.
embedDir :: FilePath -> Q Exp
embedDir topdir = do
pairs' <- runIO $ listDirectoryFiles topdir
for_ pairs' $ qAddDependentFile . fst
let pairs = makeAllRelative topdir pairs'
embedPairs pairs
embedPairs :: [(FilePath, LBS.ByteString)] -> Q Exp
embedPairs pairs = do
-- we do a hop to only embed single big bytestring.
-- it's beneficial as lzma have more stuff to compress
let (bsl, Compose offsets) = concatEntries (Compose pairs)
bslName <- newName "embedBsl"
bslExpr <- lazyBytestringE bsl
let e = letE [ return $ ValD (VarP bslName) (NormalB bslExpr) [] ] $
listE $ map (makeEmbeddedEntry bslName) offsets
sigE e [t| [(FilePath, BS.ByteString)] |]
-- | Embed a @[('FilePath', 'Data.ByteString.ByteString')]@ list, recursively traversing given directory path.
--
-- For example, with @wai-static-app@ this can be used as:
--
-- @
-- staticApp $ embeddedSettings $('embedRecursiveDir' "static")
-- -- is an embedded (no data-files!) equivalent of
-- staticApp $ defaultFileServerSettings "static"
-- @
--
--
-- >>> $(embedRecursiveDir "example")
-- [("/Example.hs","..."),("/example.txt","Hello from the inside.\n")]
--
-- >>> :t $(embedRecursiveDir "example")
-- $(embedRecursiveDir "example") :: [(FilePath, BS.ByteString)]
--
embedRecursiveDir :: FilePath -> Q Exp
embedRecursiveDir topdir = do
pairs' <- runIO $ listRecursiveDirectoryFiles topdir
for_ pairs' $ qAddDependentFile . fst
let pairs = sort (makeAllRelative topdir pairs')
embedPairs pairs
-------------------------------------------------------------------------------
-- Strings
-------------------------------------------------------------------------------
-- | Embed a lazy 'Data.ByteString.Lazy.ByteString' from a file.
--
-- >>> :t $(embedLazyByteString "file-embed-lzma.cabal")
-- $(embedLazyByteString "file-embed-lzma.cabal") :: LBS.ByteString
--
embedLazyByteString :: FilePath -> Q Exp
embedLazyByteString fp = do
qAddDependentFile fp
bsl <- runIO $ LBS.readFile fp
lazyBytestringE bsl
-- | Embed a strict 'Data.ByteString.ByteString' from a file.
--
-- >>> :t $(embedByteString "file-embed-lzma.cabal")
-- $(embedByteString "file-embed-lzma.cabal") :: BS.ByteString
--
embedByteString :: FilePath -> Q Exp
embedByteString fp = [| LBS.toStrict |] `appE` embedLazyByteString fp
-- | Embed a lazy 'Data.Text.Lazy.Text' from a UTF8-encoded file.
--
-- >>> :t $(embedLazyText "file-embed-lzma.cabal")
-- $(embedLazyText "file-embed-lzma.cabal") :: LT.Text
--
embedLazyText :: FilePath -> Q Exp
embedLazyText fp = do
qAddDependentFile fp
bsl <- runIO $ LBS.readFile fp
case LTE.decodeUtf8' bsl of
Left e -> reportError (show e)
Right _ -> return ()
[| LTE.decodeUtf8 |] `appE` lazyBytestringE bsl
-- | Embed a strict 'Data.Text.Text' from a UTF8-encoded file.
--
-- >>> :t $(embedText "file-embed-lzma.cabal")
-- $(embedText "file-embed-lzma.cabal") :: T.Text
--
embedText :: FilePath -> Q Exp
embedText fp = [| LT.toStrict |] `appE` embedLazyText fp