@@ -1,23 +1,81 @@
11{-# LANGUAGE TemplateHaskell #-}
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.
5+--
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.:
11+--
12+-- > $(embedFile "myfile.txt")
13+--
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:
17+--
18+-- > {-# LANGUAGE TemplateHaskell #-}
219module Data.FileEmbed
3− ( embedFile
20+ ( -- * Embed at compile time
21+ embedFile
22+ , embedFileIfExists
23+ , embedOneFileOf
424 , embedDir
25+ , embedDirListing
526 , getDir
27+ -- * Embed as a IsString
28+ , embedStringFile
29+ , embedOneStringFileOf
30+ -- * Inject into an executable
31+ -- $inject
32+#if MIN_VERSION_template_haskell(2,5,0)
33+ , dummySpace
34+ , dummySpaceWith
35+#endif
36+ , inject
37+ , injectFile
38+ , injectWith
39+ , injectFileWith
40+ -- * Relative path manipulation
41+ , makeRelativeToProject
42+ , makeRelativeToLocationPredicate
43+ -- * Internal
44+ , stringToBs
45+ , bsToExp
46+ , strToExp
647 ) where
748
8−import Language.Haskell.TH (runQ,
9− Exp (AppE, ListE, LitE, TupE),
10− Lit (StringL),
11− Q,
12− runIO)
49+import Language.Haskell.TH.Syntax
50+ ( Exp (AppE, ListE, LitE, TupE, SigE, VarE)
51+ , Lit (..)
52+ , Q
53+ , runIO
54+ , qLocation, loc_filename
55+#if MIN_VERSION_template_haskell(2,7,0)
56+ , Quasi(qAddDependentFile)
57+#endif
58+ )
59+#if MIN_VERSION_template_haskell(2,16,0)
60+import Language.Haskell.TH ( mkBytes, bytesPrimL )
61+import qualified Data.ByteString.Internal as B
62+#endif
1363import System.Directory (doesDirectoryExist, doesFileExist,
14− getDirectoryContents)
15−import Control.Monad (filterM)
64+ getDirectoryContents, canonicalizePath)
65+import Control.Exception (throw, tryJust, ErrorCall(..))
66+import Control.Monad (filterM, guard)
1667import qualified Data.ByteString as B
1768import qualified Data.ByteString.Char8 as B8
18−import Control.Arrow ((&&&), second, first)
69+import Control.Arrow ((&&&), second)
1970import Control.Applicative ((<$>))
20−import Data.Monoid (mappend)
71+import Data.ByteString.Unsafe (unsafePackAddressLen)
72+import System.IO.Error (isDoesNotExistError)
73+import System.IO.Unsafe (unsafePerformIO)
74+import System.FilePath ((</>), takeDirectory, takeExtension)
75+import Data.String (fromString)
76+import Prelude as P
77+import Data.List (sortBy)
78+import Data.Ord (comparing)
2179
2280-- | Embed a single file in your source code.
2381--
@@ -26,16 +84,84 @@ import Data.Monoid (mappend)
2684-- > myFile :: Data.ByteString.ByteString
2785-- > myFile = $(embedFile "dirName/fileName")
2886embedFile :: FilePath -> Q Exp
29−embedFile fp = (runIO $ B.readFile fp) >>= bsToExp
87+embedFile fp =
88+#if MIN_VERSION_template_haskell(2,7,0)
89+ qAddDependentFile fp >>
90+#endif
91+ (runIO $ B.readFile fp) >>= bsToExp
92+
93+-- | Maybe embed a single file in your source code depending on whether or not file exists.
94+--
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.
97+--
98+-- > import qualified Data.ByteString
99+-- >
100+-- > maybeMyFile :: Maybe Data.ByteString.ByteString
101+-- > maybeMyFile = $(embedFileIfExists "dirName/fileName")
102+--
103+-- @since 0.0.14.0
104+embedFileIfExists :: FilePath -> Q Exp
105+embedFileIfExists fp = do
106+ mbs <- runIO maybeFile
107+ case mbs of
108+ Nothing -> [| Nothing |]
109+ Just bs -> do
110+#if MIN_VERSION_template_haskell(2,7,0)
111+ qAddDependentFile fp
112+#endif
113+ [| Just $(bsToExp bs) |]
114+ where
115+ maybeFile :: IO (Maybe B.ByteString)
116+ maybeFile =
117+ either (const Nothing) Just <$>
118+ tryJust (guard . isDoesNotExistError) (B.readFile fp)
119+
120+-- | Embed a single existing file in your source code
121+-- out of list a list of paths supplied.
122+--
123+-- > import qualified Data.ByteString
124+-- >
125+-- > myFile :: Data.ByteString.ByteString
126+-- > myFile = $(embedOneFileOf [ "dirName/fileName", "src/dirName/fileName" ])
127+embedOneFileOf :: [FilePath] -> Q Exp
128+embedOneFileOf ps =
129+ (runIO $ readExistingFile ps) >>= \ ( path, content ) -> do
130+#if MIN_VERSION_template_haskell(2,7,0)
131+ qAddDependentFile path
132+#endif
133+ bsToExp content
134+ where
135+ readExistingFile :: [FilePath] -> IO ( FilePath, B.ByteString )
136+ readExistingFile xs = do
137+ ys <- filterM doesFileExist xs
138+ case ys of
139+ (p:_) -> B.readFile p >>= \ c -> return ( p, c )
140+ _ -> throw $ ErrorCall "Cannot find file to embed as resource"
30141
31−-- | Embed a directory recusrively in your source code.
142+-- | Embed a directory recursively in your source code.
32143--
33144-- > import qualified Data.ByteString
34145-- >
35146-- > myDir :: [(FilePath, Data.ByteString.ByteString)]
36147-- > myDir = $(embedDir "dirName")
37148embedDir :: FilePath -> Q Exp
38−embedDir fp = ListE <$> ((runIO $ fileList fp) >>= mapM pairToExp)
149+embedDir fp = do
150+ typ <- [t| [(FilePath, B.ByteString)] |]
151+ e <- ListE <$> ((runIO $ fileList fp) >>= mapM (pairToExp fp))
152+ return $ SigE e typ
153+
154+-- | Embed a directory listing recursively in your source code.
155+--
156+-- > myFiles :: [FilePath]
157+-- > myFiles = $(embedDirListing "dirName")
158+--
159+-- @since 0.0.11
160+embedDirListing :: FilePath -> Q Exp
161+embedDirListing fp = do
162+ typ <- [t| [FilePath] |]
163+ e <- ListE <$> ((runIO $ fmap fst <$> fileList fp) >>= mapM strToExp)
164+ return $ SigE e typ
39165
40166-- | Get a directory tree in the IO monad.
41167--
@@ -43,38 +169,273 @@ embedDir fp = ListE <$> ((runIO $ fileList fp) >>= mapM pairToExp)
43169getDir :: FilePath -> IO [(FilePath, B.ByteString)]
44170getDir = fileList
45171
46−pairToExp :: (FilePath, B.ByteString) -> Q Exp
47−pairToExp (path, bs) = do
172+pairToExp :: FilePath -> (FilePath, B.ByteString) -> Q Exp
173+pairToExp _root (path, bs) = do
174+#if MIN_VERSION_template_haskell(2,7,0)
175+ qAddDependentFile $ _root ++ '/' : path
176+#endif
48177 exp' <- bsToExp bs
49− return $! TupE [LitE $ StringL path, exp']
178+ return $! TupE
179+#if MIN_VERSION_template_haskell(2,16,0)
180+ $ map Just
181+#endif
182+ [LitE $ StringL path, exp']
50183
51184bsToExp :: B.ByteString -> Q Exp
185+#if MIN_VERSION_template_haskell(2, 5, 0)
186+bsToExp bs =
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))
196+#else
197+ `AppE` LitE (StringPrimL $ B8.unpack bs))
198+#endif
199+#else
52200bsToExp bs = do
53− helper <- runQ [| stringToBs |]
201+ helper <- [| stringToBs |]
54202 let chars = B8.unpack bs
55203 return $! AppE helper $! LitE $! StringL chars
204+#endif
56205
57206stringToBs :: String -> B.ByteString
58207stringToBs = B8.pack
59208
209+-- | Embed a single file in your source code.
210+--
211+-- > import Data.String
212+-- >
213+-- > myFile :: IsString a => a
214+-- > myFile = $(embedStringFile "dirName/fileName")
215+--
216+-- Since 0.0.9
217+embedStringFile :: FilePath -> Q Exp
218+embedStringFile fp =
219+#if MIN_VERSION_template_haskell(2,7,0)
220+ qAddDependentFile fp >>
221+#endif
222+ (runIO $ P.readFile fp) >>= strToExp
223+
224+-- | Embed a single existing string file in your source code
225+-- out of list a list of paths supplied.
226+--
227+-- Since 0.0.9
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
233+#endif
234+ strToExp content
235+ where
236+ readExistingFile :: [FilePath] -> IO ( FilePath, String )
237+ readExistingFile xs = do
238+ ys <- filterM doesFileExist xs
239+ case ys of
240+ (p:_) -> P.readFile p >>= \ c -> return ( p, c )
241+ _ -> throw $ ErrorCall "Cannot find file to embed as resource"
242+
243+strToExp :: String -> Q Exp
244+#if MIN_VERSION_template_haskell(2, 5, 0)
245+strToExp s =
246+ return $ VarE 'fromString
247+ `AppE` LitE (StringL s)
248+#else
249+strToExp s = do
250+ helper <- [| fromString |]
251+ return $! AppE helper $! LitE $! StringL s
252+#endif
253+
60254notHidden :: FilePath -> Bool
61255notHidden ('.':_) = False
62256notHidden _ = True
63257
64258fileList :: FilePath -> IO [(FilePath, B.ByteString)]
65−fileList top = map (first tail) <$> fileList' top ""
259+fileList top = fileList' top ""
66260
67261fileList' :: FilePath -> FilePath -> IO [(FilePath, B.ByteString)]
68262fileList' realTop top = do
69− let prefix1 = top ++ "/"
70− prefix2 = realTop ++ prefix1
71− allContents <- filter notHidden <$> getDirectoryContents prefix2
72− let all' = map (mappend prefix1 &&& mappend prefix2) allContents
263+ allContents <- filter notHidden <$> getDirectoryContents (realTop </> top)
264+ let all' = map ((top </>) &&& (\x -> realTop </> top </> x)) allContents
73265 files <- filterM (doesFileExist . snd) all' >>=
74266 mapM (liftPair2 . second B.readFile)
75267 dirs <- filterM (doesDirectoryExist . snd) all' >>=
76268 mapM (fileList' realTop . fst)
77− return $ concat $ files : dirs
269+ return $ sortBy (comparing fst) $ concat $ files : dirs
78270
79271liftPair2 :: Monad m => (a, m b) -> m (a, b)
80272liftPair2 (a, b) = b >>= \b' -> return (a, b')
273+
274+magic :: B.ByteString -> B.ByteString
275+magic x = B8.concat ["fe", x]
276+
277+sizeLen :: Int
278+sizeLen = 20
279+
280+getInner :: B.ByteString -> B.ByteString
281+getInner b =
282+ let (sizeBS, rest) = B.splitAt sizeLen b
283+ in case reads $ B8.unpack sizeBS of
284+ (i, _):_ -> B.take i rest
285+ [] -> error "Data.FileEmbed (getInner): Your dummy space has been corrupted."
286+
287+padSize :: Int -> String
288+padSize i =
289+ let s = show i
290+ in replicate (sizeLen - length s) '0' ++ s
291+
292+#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.
295+dummySpace :: Int -> Q Exp
296+dummySpace = dummySpaceWith "MS"
297+
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.
302+--
303+-- Since 0.0.8
304+dummySpaceWith :: B.ByteString -> Int -> Q Exp
305+dummySpaceWith postfix space = do
306+ let size = padSize space
307+ magic' = magic postfix
308+ start = B8.unpack magic' ++ size
309+ magicLen = B8.length magic'
310+ len = magicLen + sizeLen + space
311+ chars = LitE $ StringPrimL $
312+#if MIN_VERSION_template_haskell(2,6,0)
313+ map (toEnum . fromEnum) $
314+#endif
315+ start ++ replicate space '0'
316+ [| getInner (B.drop magicLen (unsafePerformIO (unsafePackAddressLen len $(return chars)))) |]
317+#endif
318+
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.
322+inject :: B.ByteString -- ^ bs to inject
323+ -> B.ByteString -- ^ original BS containing dummy
324+ -> Maybe B.ByteString -- ^ new BS, or Nothing if there is insufficient dummy space
325+inject = injectWith "MS"
326+
327+-- | Like 'inject', but takes a postfix for the magic string.
328+--
329+-- Since 0.0.8
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 =
335+ if toInjL > size
336+ then Nothing
337+ else Just $ B.concat [before, magic', B8.pack $ padSize toInjL, toInj, B8.pack $ replicate (size - toInjL) '0', after]
338+ where
339+ magic' = magic postfix
340+ toInjL = B.length toInj
341+ (before, rest) = B.breakSubstring magic' orig
342+ (sizeBS, rest') = B.splitAt sizeLen $ B.drop (B8.length magic') rest
343+ size = case reads $ B8.unpack sizeBS of
344+ (i, _):_ -> i
345+ [] -> error $ "Data.FileEmbed (inject): Your dummy space has been corrupted. Size is: " ++ show sizeBS
346+ after = B.drop size rest'
347+
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
350+-- filesystem.
351+injectFile :: B.ByteString -- ^ bs to inject
352+ -> FilePath -- ^ template file
353+ -> FilePath -- ^ output file
354+ -> IO ()
355+injectFile = injectFileWith "MS"
356+
357+-- | Like 'injectFile', but takes a postfix for the magic string.
358+--
359+-- Since 0.0.8
360+injectFileWith :: B.ByteString -- ^ postfix of magic string
361+ -> B.ByteString -- ^ bs to inject
362+ -> FilePath -- ^ template file
363+ -> FilePath -- ^ output file
364+ -> IO ()
365+injectFileWith postfix inj srcFP dstFP = do
366+ src <- B.readFile srcFP
367+ case injectWith postfix inj src of
368+ Nothing -> error "Insufficient dummy space"
369+ Just dst -> B.writeFile dstFP dst
370+
371+{- $inject
372+
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:
378+
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.)
380+
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.
382+
383+The typical workflow use:
384+
385+* Use 'dummySpace' or 'dummySpaceWith' to create some empty space in your executable
386+
387+* Use 'injectFile' or 'injectFileWith' from a separate utility to modify that executable to have the updated content.
388+
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.
393+
394+-}
395+
396+-- | Take a relative file path and attach it to the root of the current
397+-- project.
398+--
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.
403+--
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.
407+--
408+-- @$(makeRelativeToProject "data/foo.txt" >>= embedFile)@
409+--
410+-- @since 0.0.10
411+makeRelativeToProject :: FilePath -> Q FilePath
412+makeRelativeToProject = makeRelativeToLocationPredicate $ (==) ".cabal" . takeExtension
413+
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
415+--
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.
419+--
420+-- @$(makeRelativeToLocationPredicate ((==) ".cabal" . takeExtension) "data/foo.txt" >>= embedFile)@
421+--
422+-- @since 0.0.15.0
423+makeRelativeToLocationPredicate :: (FilePath -> Bool) -> FilePath -> Q FilePath
424+makeRelativeToLocationPredicate isTargetFile rel = do
425+ loc <- qLocation
426+ runIO $ do
427+ srcFP <- canonicalizePath $ loc_filename loc
428+ mdir <- findProjectDir srcFP
429+ case mdir of
430+ Nothing -> error $ "Could not find .cabal file for path: " ++ srcFP
431+ Just dir -> return $ dir </> rel
432+ where
433+ findProjectDir x = do
434+ let dir = takeDirectory x
435+ if dir == x
436+ then return Nothing
437+ else do
438+ contents <- getDirectoryContents dir
439+ if any isTargetFile contents
440+ then return (Just dir)
441+ else findProjectDir dir