@@ -1,81 +1,41 @@
1{-# LANGUAGE TemplateHaskell #-}
1{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−-- | This module uses template Haskell. Following is a simplified explanation of usage for those unfamiliar with calling Template Haskell functions.
6−-- The function @embedFile@ in this modules embeds a file into the executable
7−-- that you can use it at runtime. A file is represented as a @ByteString@.
8−-- However, as you can see below, the type signature indicates a value of type
9−-- @Q Exp@ will be returned. In order to convert this into a @ByteString@, you
10−-- must use Template Haskell syntax, e.g.:
12−-- > $(embedFile "myfile.txt")
14−-- This expression will have type @ByteString@. Be certain to enable the
15−-- TemplateHaskell language extension, usually by adding the following to the
16−-- top of your module:
18−-- > {-# LANGUAGE TemplateHaskell #-}
19module Data.FileEmbed
3module Data.FileEmbed
20 ( -- * Embed at compile time
4 ( -- * Embed at compile time
24 , embedDir
6 , embedDir
27− -- * Embed as a IsString
29− , embedOneStringFileOf
30 -- * Inject into an executable
8 -- * Inject into an executable
32#if MIN_VERSION_template_haskell(2,5,0)
9#if MIN_VERSION_template_haskell(2,5,0)
33 , dummySpace
10 , dummySpace
37 , injectFile
13 , injectFile
40− -- * Relative path manipulation
41− , makeRelativeToProject
42− , makeRelativeToLocationPredicate
49import Language.Haskell.TH.Syntax
16import Language.Haskell.TH.Syntax
50− ( Exp (AppE, ListE, LitE, TupE, SigE, VarE)
17+ ( Exp (AppE, ListE, LitE, TupE)
51− , Lit (..)
18+#if MIN_VERSION_template_haskell(2,5,0)
19+ , Lit (StringL, StringPrimL, IntegerL)
21+ , Lit (StringL, IntegerL)
54− , qLocation, loc_filename
55#if MIN_VERSION_template_haskell(2,7,0)
25#if MIN_VERSION_template_haskell(2,7,0)
56 , Quasi(qAddDependentFile)
26 , Quasi(qAddDependentFile)
59−#if MIN_VERSION_template_haskell(2,16,0)
60−import Language.Haskell.TH ( mkBytes, bytesPrimL )
61−import qualified Data.ByteString.Internal as B
63import System.Directory (doesDirectoryExist, doesFileExist,
29import System.Directory (doesDirectoryExist, doesFileExist,
64− getDirectoryContents, canonicalizePath)
30+ getDirectoryContents)
65−import Control.Exception (throw, tryJust, ErrorCall(..))
66−import Control.Monad (filterM, guard)
31+import Control.Monad (filterM)
67import qualified Data.ByteString as B
32import qualified Data.ByteString as B
68import qualified Data.ByteString.Char8 as B8
33import qualified Data.ByteString.Char8 as B8
69−import Control.Arrow ((&&&), second)
34+import Control.Arrow ((&&&), second, first)
70import Control.Applicative ((<$>))
35import Control.Applicative ((<$>))
36+import Data.Monoid (mappend)
71import Data.ByteString.Unsafe (unsafePackAddressLen)
37import Data.ByteString.Unsafe (unsafePackAddressLen)
72−import System.IO.Error (isDoesNotExistError)
73import System.IO.Unsafe (unsafePerformIO)
38import System.IO.Unsafe (unsafePerformIO)
74−import System.FilePath ((</>), takeDirectory, takeExtension)
75−import Data.String (fromString)
77−import Data.List (sortBy)
78−import Data.Ord (comparing)
80-- | Embed a single file in your source code.
40-- | Embed a single file in your source code.
@@ -90,78 +50,14 @@ embedFile fp =
91 (runIO $ B.readFile fp) >>= bsToExp
51 (runIO $ B.readFile fp) >>= bsToExp
93−-- | Maybe embed a single file in your source code depending on whether or not file exists.
95−-- Warning: When a build is compiled with the file missing, a recompile when the file exists might not trigger an embed of the file.
96−-- You might try to fix this by doing a clean build.
98−-- > import qualified Data.ByteString
100−-- > maybeMyFile :: Maybe Data.ByteString.ByteString
101−-- > maybeMyFile = $(embedFileIfExists "dirName/fileName")
104−embedFileIfExists :: FilePath -> Q Exp
105−embedFileIfExists fp = do
106− mbs <- runIO maybeFile
108− Nothing -> [| Nothing |]
110−#if MIN_VERSION_template_haskell(2,7,0)
111− qAddDependentFile fp
113− [| Just $(bsToExp bs) |]
115− maybeFile :: IO (Maybe B.ByteString)
117− either (const Nothing) Just <$>
118− tryJust (guard . isDoesNotExistError) (B.readFile fp)
120−-- | Embed a single existing file in your source code
121−-- out of list a list of paths supplied.
123−-- > import qualified Data.ByteString
125−-- > myFile :: Data.ByteString.ByteString
126−-- > myFile = $(embedOneFileOf [ "dirName/fileName", "src/dirName/fileName" ])
127−embedOneFileOf :: [FilePath] -> Q Exp
129− (runIO $ readExistingFile ps) >>= \ ( path, content ) -> do
130−#if MIN_VERSION_template_haskell(2,7,0)
131− qAddDependentFile path
135− readExistingFile :: [FilePath] -> IO ( FilePath, B.ByteString )
136− readExistingFile xs = do
137− ys <- filterM doesFileExist xs
139− (p:_) -> B.readFile p >>= \ c -> return ( p, c )
140− _ -> throw $ ErrorCall "Cannot find file to embed as resource"
142−-- | Embed a directory recursively in your source code.
53+-- | Embed a directory recusrively in your source code.
144-- > import qualified Data.ByteString
55-- > import qualified Data.ByteString
146-- > myDir :: [(FilePath, Data.ByteString.ByteString)]
57-- > myDir :: [(FilePath, Data.ByteString.ByteString)]
147-- > myDir = $(embedDir "dirName")
58-- > myDir = $(embedDir "dirName")
148embedDir :: FilePath -> Q Exp
59embedDir :: FilePath -> Q Exp
150− typ <- [t| [(FilePath, B.ByteString)] |]
151− e <- ListE <$> ((runIO $ fileList fp) >>= mapM (pairToExp fp))
60+embedDir fp = ListE <$> ((runIO $ fileList fp) >>= mapM (pairToExp fp))
154−-- | Embed a directory listing recursively in your source code.
156−-- > myFiles :: [FilePath]
157−-- > myFiles = $(embedDirListing "dirName")
160−embedDirListing :: FilePath -> Q Exp
161−embedDirListing fp = do
162− typ <- [t| [FilePath] |]
163− e <- ListE <$> ((runIO $ fmap fst <$> fileList fp) >>= mapM strToExp)
166-- | Get a directory tree in the IO monad.
62-- | Get a directory tree in the IO monad.
@@ -170,116 +66,53 @@ getDir :: FilePath -> IO [(FilePath, B.ByteString)]
170getDir = fileList
66getDir = fileList
172pairToExp :: FilePath -> (FilePath, B.ByteString) -> Q Exp
68pairToExp :: FilePath -> (FilePath, B.ByteString) -> Q Exp
173−pairToExp _root (path, bs) = do
69+pairToExp root (path, bs) = do
174#if MIN_VERSION_template_haskell(2,7,0)
70#if MIN_VERSION_template_haskell(2,7,0)
175− qAddDependentFile $ _root ++ '/' : path
71+ qAddDependentFile $ root ++ '/' : path
177 exp' <- bsToExp bs
73 exp' <- bsToExp bs
179−#if MIN_VERSION_template_haskell(2,16,0)
182− [LitE $ StringL path, exp']
74+ return $! TupE [LitE $ StringL path, exp']
184bsToExp :: B.ByteString -> Q Exp
76bsToExp :: B.ByteString -> Q Exp
185−#if MIN_VERSION_template_haskell(2, 5, 0)
187− return $ VarE 'unsafePerformIO
188− `AppE` (VarE 'unsafePackAddressLen
189− `AppE` LitE (IntegerL $ fromIntegral $ B8.length bs)
190−#if MIN_VERSION_template_haskell(2, 16, 0)
191− `AppE` LitE (bytesPrimL (
192− let B.PS ptr off sz = bs
193− in mkBytes ptr (fromIntegral off) (fromIntegral sz))))
194−#elif MIN_VERSION_template_haskell(2, 8, 0)
195− `AppE` LitE (StringPrimL $ B.unpack bs))
197− `AppE` LitE (StringPrimL $ B8.unpack bs))
200bsToExp bs = do
77bsToExp bs = do
201 helper <- [| stringToBs |]
78 helper <- [| stringToBs |]
202 let chars = B8.unpack bs
79 let chars = B8.unpack bs
203 return $! AppE helper $! LitE $! StringL chars
80 return $! AppE helper $! LitE $! StringL chars
206stringToBs :: String -> B.ByteString
82stringToBs :: String -> B.ByteString
207stringToBs = B8.pack
83stringToBs = B8.pack
209−-- | Embed a single file in your source code.
211−-- > import Data.String
213−-- > myFile :: IsString a => a
214−-- > myFile = $(embedStringFile "dirName/fileName")
217−embedStringFile :: FilePath -> Q Exp
219−#if MIN_VERSION_template_haskell(2,7,0)
220− qAddDependentFile fp >>
222− (runIO $ P.readFile fp) >>= strToExp
224−-- | Embed a single existing string file in your source code
225−-- out of list a list of paths supplied.
228−embedOneStringFileOf :: [FilePath] -> Q Exp
229−embedOneStringFileOf ps =
230− (runIO $ readExistingFile ps) >>= \ ( path, content ) -> do
231−#if MIN_VERSION_template_haskell(2,7,0)
232− qAddDependentFile path
236− readExistingFile :: [FilePath] -> IO ( FilePath, String )
237− readExistingFile xs = do
238− ys <- filterM doesFileExist xs
240− (p:_) -> P.readFile p >>= \ c -> return ( p, c )
241− _ -> throw $ ErrorCall "Cannot find file to embed as resource"
243−strToExp :: String -> Q Exp
244−#if MIN_VERSION_template_haskell(2, 5, 0)
246− return $ VarE 'fromString
247− `AppE` LitE (StringL s)
250− helper <- [| fromString |]
251− return $! AppE helper $! LitE $! StringL s
254notHidden :: FilePath -> Bool
85notHidden :: FilePath -> Bool
255notHidden ('.':_) = False
86notHidden ('.':_) = False
256notHidden _ = True
87notHidden _ = True
258fileList :: FilePath -> IO [(FilePath, B.ByteString)]
89fileList :: FilePath -> IO [(FilePath, B.ByteString)]
259−fileList top = fileList' top ""
90+fileList top = map (first tail) <$> fileList' top ""
261fileList' :: FilePath -> FilePath -> IO [(FilePath, B.ByteString)]
92fileList' :: FilePath -> FilePath -> IO [(FilePath, B.ByteString)]
262fileList' realTop top = do
93fileList' realTop top = do
94+ let prefix1 = top ++ "/"
95+ prefix2 = realTop ++ prefix1
263− allContents <- filter notHidden <$> getDirectoryContents (realTop </> top)
96+ allContents <- filter notHidden <$> getDirectoryContents prefix2
264− let all' = map ((top </>) &&& (\x -> realTop </> top </> x)) allContents
97+ let all' = map (mappend prefix1 &&& mappend prefix2) allContents
265 files <- filterM (doesFileExist . snd) all' >>=
98 files <- filterM (doesFileExist . snd) all' >>=
266 mapM (liftPair2 . second B.readFile)
99 mapM (liftPair2 . second B.readFile)
267 dirs <- filterM (doesDirectoryExist . snd) all' >>=
100 dirs <- filterM (doesDirectoryExist . snd) all' >>=
268 mapM (fileList' realTop . fst)
101 mapM (fileList' realTop . fst)
269− return $ sortBy (comparing fst) $ concat $ files : dirs
102+ return $ concat $ files : dirs
271liftPair2 :: Monad m => (a, m b) -> m (a, b)
104liftPair2 :: Monad m => (a, m b) -> m (a, b)
272liftPair2 (a, b) = b >>= \b' -> return (a, b')
105liftPair2 (a, b) = b >>= \b' -> return (a, b')
274−magic :: B.ByteString -> B.ByteString
107+magic :: String
275−magic x = B8.concat ["fe", x]
108+magic = concat ["fe", "MS"]
277sizeLen :: Int
110sizeLen :: Int
278sizeLen = 20
111sizeLen = 20
280getInner :: B.ByteString -> B.ByteString
113getInner :: B.ByteString -> B.ByteString
281getInner b =
114getInner b =
282− let (sizeBS, rest) = B.splitAt sizeLen b
115+ let (sizeBS, rest) = B.splitAt sizeLen $ B.drop (length magic) b
283 in case reads $ B8.unpack sizeBS of
116 in case reads $ B8.unpack sizeBS of
284 (i, _):_ -> B.take i rest
117 (i, _):_ -> B.take i rest
285 [] -> error "Data.FileEmbed (getInner): Your dummy space has been corrupted."
118 [] -> error "Data.FileEmbed (getInner): Your dummy space has been corrupted."
@@ -290,152 +123,44 @@ padSize i =
290 in replicate (sizeLen - length s) '0' ++ s
123 in replicate (sizeLen - length s) '0' ++ s
292#if MIN_VERSION_template_haskell(2,5,0)
125#if MIN_VERSION_template_haskell(2,5,0)
293−-- | Allocate the given number of bytes in the generate executable. That space
294−-- can be filled up with the 'inject' and 'injectFile' functions.
295dummySpace :: Int -> Q Exp
126dummySpace :: Int -> Q Exp
296−dummySpace = dummySpaceWith "MS"
127+dummySpace space = do
298−-- | Like 'dummySpace', but takes a postfix for the magic string. In
299−-- order for this to work, the same postfix must be used by 'inject' /
300−-- 'injectFile'. This allows an executable to have multiple
301−-- 'ByteString's injected into it, without encountering collisions.
304−dummySpaceWith :: B.ByteString -> Int -> Q Exp
305−dummySpaceWith postfix space = do
306 let size = padSize space
128 let size = padSize space
307− magic' = magic postfix
308− start = B8.unpack magic' ++ size
129+ let start = magic ++ size
309− magicLen = B8.length magic'
310− len = magicLen + sizeLen + space
311− chars = LitE $ StringPrimL $
130+ let chars = LitE $ StringPrimL $
312#if MIN_VERSION_template_haskell(2,6,0)
131#if MIN_VERSION_template_haskell(2,6,0)
313 map (toEnum . fromEnum) $
132 map (toEnum . fromEnum) $
315 start ++ replicate space '0'
134 start ++ replicate space '0'
135+ let len = LitE $ IntegerL $ fromIntegral $ length start + space
136+ upi <- [|unsafePerformIO|]
316− [| getInner (B.drop magicLen (unsafePerformIO (unsafePackAddressLen len $(return chars)))) |]
137+ pack <- [|unsafePackAddressLen|]
138+ getInner' <- [|getInner|]
139+ return $ getInner' `AppE` (upi `AppE` (pack `AppE` len `AppE` chars))
319−-- | Inject some raw data inside a @ByteString@ containing empty, dummy space
320−-- (allocated with @dummySpace@). Typically, the original @ByteString@ is an
321−-- executable read from the filesystem.
322inject :: B.ByteString -- ^ bs to inject
142inject :: B.ByteString -- ^ bs to inject
323 -> B.ByteString -- ^ original BS containing dummy
143 -> B.ByteString -- ^ original BS containing dummy
324 -> Maybe B.ByteString -- ^ new BS, or Nothing if there is insufficient dummy space
144 -> Maybe B.ByteString -- ^ new BS, or Nothing if there is insufficient dummy space
325−inject = injectWith "MS"
327−-- | Like 'inject', but takes a postfix for the magic string.
330−injectWith :: B.ByteString -- ^ postfix of magic string
331− -> B.ByteString -- ^ bs to inject
332− -> B.ByteString -- ^ original BS containing dummy
333− -> Maybe B.ByteString -- ^ new BS, or Nothing if there is insufficient dummy space
334−injectWith postfix toInj orig =
145+inject toInj orig =
335 if toInjL > size
146 if toInjL > size
336 then Nothing
147 then Nothing
337− else Just $ B.concat [before, magic', B8.pack $ padSize toInjL, toInj, B8.pack $ replicate (size - toInjL) '0', after]
148+ else Just $ B.concat [before, B8.pack magic, B8.pack $ padSize toInjL, toInj, B8.pack $ replicate (size - toInjL) '0', after]
339− magic' = magic postfix
340 toInjL = B.length toInj
150 toInjL = B.length toInj
341− (before, rest) = B.breakSubstring magic' orig
151+ (before, rest) = B.breakSubstring (B8.pack magic) orig
342− (sizeBS, rest') = B.splitAt sizeLen $ B.drop (B8.length magic') rest
152+ (sizeBS, rest') = B.splitAt sizeLen $ B.drop (length magic) rest
343 size = case reads $ B8.unpack sizeBS of
153 size = case reads $ B8.unpack sizeBS of
344 (i, _):_ -> i
154 (i, _):_ -> i
345 [] -> error $ "Data.FileEmbed (inject): Your dummy space has been corrupted. Size is: " ++ show sizeBS
155 [] -> error $ "Data.FileEmbed (inject): Your dummy space has been corrupted. Size is: " ++ show sizeBS
346− after = B.drop size rest'
156+ (_dummy, after) = B.splitAt size rest'
348−-- | Same as 'inject', but instead of performing the injecting in memory, read
349−-- the contents from the filesystem and write back to a different file on the
351−injectFile :: B.ByteString -- ^ bs to inject
158+injectFile :: B.ByteString
352 -> FilePath -- ^ template file
159 -> FilePath -- ^ template file
353 -> FilePath -- ^ output file
160 -> FilePath -- ^ output file
355−injectFile = injectFileWith "MS"
357−-- | Like 'injectFile', but takes a postfix for the magic string.
360−injectFileWith :: B.ByteString -- ^ postfix of magic string
361− -> B.ByteString -- ^ bs to inject
362− -> FilePath -- ^ template file
363− -> FilePath -- ^ output file
365−injectFileWith postfix inj srcFP dstFP = do
162+injectFile inj srcFP dstFP = do
366 src <- B.readFile srcFP
163 src <- B.readFile srcFP
367− case injectWith postfix inj src of
164+ case inject inj src of
368 Nothing -> error "Insufficient dummy space"
165 Nothing -> error "Insufficient dummy space"
369 Just dst -> B.writeFile dstFP dst
166 Just dst -> B.writeFile dstFP dst
373−The inject system allows arbitrary content to be embedded inside a Haskell
374−executable, post compilation. Typically, file-embed allows you to read some
375−contents from the file system at compile time and embed them inside your
376−executable. Consider a case, instead, where you would want to embed these
377−contents after compilation. Two real-world examples are:
379−* You would like to embed a hash of the executable itself, for sanity checking in a network protocol. (Obviously the hash will change after you embed the hash.)
381−* You want to create a self-contained web server that has a set of content, but will need to update the content on machines that do not have access to GHC.
383−The typical workflow use:
385−* Use 'dummySpace' or 'dummySpaceWith' to create some empty space in your executable
387−* Use 'injectFile' or 'injectFileWith' from a separate utility to modify that executable to have the updated content.
389−The reason for the @With@-variant of the functions is for cases where you wish
390−to inject multiple different kinds of content, and therefore need control over
391−the magic key. If you know for certain that there will only be one dummy space
392−available, you can use the non-@With@ variants.
396−-- | Take a relative file path and attach it to the root of the current
399−-- The idea here is that, when building with Stack, the build will always be
400−-- executed with a current working directory of the root of the project (where
401−-- your .cabal file is located). However, if you load up multiple projects with
402−-- @stack ghci@, the working directory may be something else entirely.
404−-- This function looks at the source location of the Haskell file calling it,
405−-- finds the first parent directory with a .cabal file, and uses that as the
406−-- root directory for fixing the relative path.
408−-- @$(makeRelativeToProject "data/foo.txt" >>= embedFile)@
411−makeRelativeToProject :: FilePath -> Q FilePath
412−makeRelativeToProject = makeRelativeToLocationPredicate $ (==) ".cabal" . takeExtension
414−-- | Take a predicate to infer the project root and a relative file path, the given file path is then attached to the inferred project root
416−-- This function looks at the source location of the Haskell file calling it,
417−-- finds the first parent directory with a file matching the given predicate, and uses that as the
418−-- root directory for fixing the relative path.
420−-- @$(makeRelativeToLocationPredicate ((==) ".cabal" . takeExtension) "data/foo.txt" >>= embedFile)@
423−makeRelativeToLocationPredicate :: (FilePath -> Bool) -> FilePath -> Q FilePath
424−makeRelativeToLocationPredicate isTargetFile rel = do
427− srcFP <- canonicalizePath $ loc_filename loc
428− mdir <- findProjectDir srcFP
430− Nothing -> error $ "Could not find .cabal file for path: " ++ srcFP
431− Just dir -> return $ dir </> rel
433− findProjectDir x = do
434− let dir = takeDirectory x
438− contents <- getDirectoryContents dir
439− if any isTargetFile contents
440− then return (Just dir)
441− else findProjectDir dir