1{-# 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 #-} 19module Data.FileEmbed 20 ( -- * Embed at compile time 21 embedFile 22 , embedOneFileOf 23 , embedDir 24 , embedDirListing 25 , getDir 26 -- * Embed as a IsString 27 , embedStringFile 28 , embedOneStringFileOf 29 -- * Inject into an executable 30 -- $inject 31#if MIN_VERSION_template_haskell(2,5,0) 32 , dummySpace 33 , dummySpaceWith 34#endif 35 , inject 36 , injectFile 37 , injectWith 38 , injectFileWith 39 -- * Relative path manipulation 40 , makeRelativeToProject 41 -- * Internal 42 , stringToBs 43 , bsToExp 44 , strToExp 45 ) where 46 47import Language.Haskell.TH.Syntax 48 ( Exp (AppE, ListE, LitE, TupE, SigE, VarE) 49 , Lit (..) 50 , Q 51 , runIO 52 , qLocation, loc_filename 53#if MIN_VERSION_template_haskell(2,7,0) 54 , Quasi(qAddDependentFile) 55#endif 56 ) 57#if MIN_VERSION_template_haskell(2,16,0) 58import Language.Haskell.TH ( mkBytes, bytesPrimL ) 59import qualified Data.ByteString.Internal as B 60#endif 61import System.Directory (doesDirectoryExist, doesFileExist, 62 getDirectoryContents, canonicalizePath) 63import Control.Exception (throw, ErrorCall(..)) 64import Control.Monad (filterM) 65import qualified Data.ByteString as B 66import qualified Data.ByteString.Char8 as B8 67import Control.Arrow ((&&&), second) 68import Control.Applicative ((<$>)) 69import Data.ByteString.Unsafe (unsafePackAddressLen) 70import System.IO.Unsafe (unsafePerformIO) 71import System.FilePath ((</>), takeDirectory, takeExtension) 72import Data.String (fromString) 73import Prelude as P 74import Data.List (sortBy) 75import Data.Ord (comparing) 76 77-- | Embed a single file in your source code. 78-- 79-- > import qualified Data.ByteString 80-- > 81-- > myFile :: Data.ByteString.ByteString 82-- > myFile = $(embedFile "dirName/fileName") 83embedFile :: FilePath -> Q Exp 84embedFile fp = 85#if MIN_VERSION_template_haskell(2,7,0) 86 qAddDependentFile fp >> 87#endif 88 (runIO $ B.readFile fp) >>= bsToExp 89 90-- | Embed a single existing file in your source code 91-- out of list a list of paths supplied. 92-- 93-- > import qualified Data.ByteString 94-- > 95-- > myFile :: Data.ByteString.ByteString 96-- > myFile = $(embedOneFileOf [ "dirName/fileName", "src/dirName/fileName" ]) 97embedOneFileOf :: [FilePath] -> Q Exp 98embedOneFileOf ps = 99 (runIO $ readExistingFile ps) >>= \ ( path, content ) -> do 100#if MIN_VERSION_template_haskell(2,7,0) 101 qAddDependentFile path 102#endif 103 bsToExp content 104 where 105 readExistingFile :: [FilePath] -> IO ( FilePath, B.ByteString ) 106 readExistingFile xs = do 107 ys <- filterM doesFileExist xs 108 case ys of 109 (p:_) -> B.readFile p >>= \ c -> return ( p, c ) 110 _ -> throw $ ErrorCall "Cannot find file to embed as resource" 111 112-- | Embed a directory recursively in your source code. 113-- 114-- > import qualified Data.ByteString 115-- > 116-- > myDir :: [(FilePath, Data.ByteString.ByteString)] 117-- > myDir = $(embedDir "dirName") 118embedDir :: FilePath -> Q Exp 119embedDir fp = do 120 typ <- [t| [(FilePath, B.ByteString)] |] 121 e <- ListE <$> ((runIO $ fileList fp) >>= mapM (pairToExp fp)) 122 return $ SigE e typ 123 124-- | Embed a directory listing recursively in your source code. 125-- 126-- > myFiles :: [FilePath] 127-- > myFiles = $(embedDirListing "dirName") 128-- 129-- @since 0.0.11 130embedDirListing :: FilePath -> Q Exp 131embedDirListing fp = do 132 typ <- [t| [FilePath] |] 133 e <- ListE <$> ((runIO $ fmap fst <$> fileList fp) >>= mapM strToExp) 134 return $ SigE e typ 135 136-- | Get a directory tree in the IO monad. 137-- 138-- This is the workhorse of 'embedDir' 139getDir :: FilePath -> IO [(FilePath, B.ByteString)] 140getDir = fileList 141 142pairToExp :: FilePath -> (FilePath, B.ByteString) -> Q Exp 143pairToExp _root (path, bs) = do 144#if MIN_VERSION_template_haskell(2,7,0) 145 qAddDependentFile $ _root ++ '/' : path 146#endif 147 exp' <- bsToExp bs 148 return $! TupE 149#if MIN_VERSION_template_haskell(2,16,0) 150 $ map Just 151#endif 152 [LitE $ StringL path, exp'] 153 154bsToExp :: B.ByteString -> Q Exp 155#if MIN_VERSION_template_haskell(2, 5, 0) 156bsToExp bs = 157 return $ VarE 'unsafePerformIO 158 `AppE` (VarE 'unsafePackAddressLen 159 `AppE` LitE (IntegerL $ fromIntegral $ B8.length bs) 160#if MIN_VERSION_template_haskell(2, 16, 0) 161 `AppE` LitE (bytesPrimL ( 162 let B.PS ptr off sz = bs 163 in mkBytes ptr (fromIntegral off) (fromIntegral sz)))) 164#elif MIN_VERSION_template_haskell(2, 8, 0) 165 `AppE` LitE (StringPrimL $ B.unpack bs)) 166#else 167 `AppE` LitE (StringPrimL $ B8.unpack bs)) 168#endif 169#else 170bsToExp bs = do 171 helper <- [| stringToBs |] 172 let chars = B8.unpack bs 173 return $! AppE helper $! LitE $! StringL chars 174#endif 175 176stringToBs :: String -> B.ByteString 177stringToBs = B8.pack 178 179-- | Embed a single file in your source code. 180-- 181-- > import Data.String 182-- > 183-- > myFile :: IsString a => a 184-- > myFile = $(embedStringFile "dirName/fileName") 185-- 186-- Since 0.0.9 187embedStringFile :: FilePath -> Q Exp 188embedStringFile fp = 189#if MIN_VERSION_template_haskell(2,7,0) 190 qAddDependentFile fp >> 191#endif 192 (runIO $ P.readFile fp) >>= strToExp 193 194-- | Embed a single existing string file in your source code 195-- out of list a list of paths supplied. 196-- 197-- Since 0.0.9 198embedOneStringFileOf :: [FilePath] -> Q Exp 199embedOneStringFileOf ps = 200 (runIO $ readExistingFile ps) >>= \ ( path, content ) -> do 201#if MIN_VERSION_template_haskell(2,7,0) 202 qAddDependentFile path 203#endif 204 strToExp content 205 where 206 readExistingFile :: [FilePath] -> IO ( FilePath, String ) 207 readExistingFile xs = do 208 ys <- filterM doesFileExist xs 209 case ys of 210 (p:_) -> P.readFile p >>= \ c -> return ( p, c ) 211 _ -> throw $ ErrorCall "Cannot find file to embed as resource" 212 213strToExp :: String -> Q Exp 214#if MIN_VERSION_template_haskell(2, 5, 0) 215strToExp s = 216 return $ VarE 'fromString 217 `AppE` LitE (StringL s) 218#else 219strToExp s = do 220 helper <- [| fromString |] 221 return $! AppE helper $! LitE $! StringL s 222#endif 223 224notHidden :: FilePath -> Bool 225notHidden ('.':_) = False 226notHidden _ = True 227 228fileList :: FilePath -> IO [(FilePath, B.ByteString)] 229fileList top = fileList' top "" 230 231fileList' :: FilePath -> FilePath -> IO [(FilePath, B.ByteString)] 232fileList' realTop top = do 233 allContents <- filter notHidden <$> getDirectoryContents (realTop </> top) 234 let all' = map ((top </>) &&& (\x -> realTop </> top </> x)) allContents 235 files <- filterM (doesFileExist . snd) all' >>= 236 mapM (liftPair2 . second B.readFile) 237 dirs <- filterM (doesDirectoryExist . snd) all' >>= 238 mapM (fileList' realTop . fst) 239 return $ sortBy (comparing fst) $ concat $ files : dirs 240 241liftPair2 :: Monad m => (a, m b) -> m (a, b) 242liftPair2 (a, b) = b >>= \b' -> return (a, b') 243 244magic :: B.ByteString -> B.ByteString 245magic x = B8.concat ["fe", x] 246 247sizeLen :: Int 248sizeLen = 20 249 250getInner :: B.ByteString -> B.ByteString 251getInner b = 252 let (sizeBS, rest) = B.splitAt sizeLen b 253 in case reads $ B8.unpack sizeBS of 254 (i, _):_ -> B.take i rest 255 [] -> error "Data.FileEmbed (getInner): Your dummy space has been corrupted." 256 257padSize :: Int -> String 258padSize i = 259 let s = show i 260 in replicate (sizeLen - length s) '0' ++ s 261 262#if MIN_VERSION_template_haskell(2,5,0) 263-- | Allocate the given number of bytes in the generate executable. That space 264-- can be filled up with the 'inject' and 'injectFile' functions. 265dummySpace :: Int -> Q Exp 266dummySpace = dummySpaceWith "MS" 267 268-- | Like 'dummySpace', but takes a postfix for the magic string. In 269-- order for this to work, the same postfix must be used by 'inject' / 270-- 'injectFile'. This allows an executable to have multiple 271-- 'ByteString's injected into it, without encountering collisions. 272-- 273-- Since 0.0.8 274dummySpaceWith :: B.ByteString -> Int -> Q Exp 275dummySpaceWith postfix space = do 276 let size = padSize space 277 magic' = magic postfix 278 start = B8.unpack magic' ++ size 279 magicLen = B8.length magic' 280 len = magicLen + sizeLen + space 281 chars = LitE $ StringPrimL $ 282#if MIN_VERSION_template_haskell(2,6,0) 283 map (toEnum . fromEnum) $ 284#endif 285 start ++ replicate space '0' 286 [| getInner (B.drop magicLen (unsafePerformIO (unsafePackAddressLen len $(return chars)))) |] 287#endif 288 289-- | Inject some raw data inside a @ByteString@ containing empty, dummy space 290-- (allocated with @dummySpace@). Typically, the original @ByteString@ is an 291-- executable read from the filesystem. 292inject :: B.ByteString -- ^ bs to inject 293 -> B.ByteString -- ^ original BS containing dummy 294 -> Maybe B.ByteString -- ^ new BS, or Nothing if there is insufficient dummy space 295inject = injectWith "MS" 296 297-- | Like 'inject', but takes a postfix for the magic string. 298-- 299-- Since 0.0.8 300injectWith :: B.ByteString -- ^ postfix of magic string 301 -> B.ByteString -- ^ bs to inject 302 -> B.ByteString -- ^ original BS containing dummy 303 -> Maybe B.ByteString -- ^ new BS, or Nothing if there is insufficient dummy space 304injectWith postfix toInj orig = 305 if toInjL > size 306 then Nothing 307 else Just $ B.concat [before, magic', B8.pack $ padSize toInjL, toInj, B8.pack $ replicate (size - toInjL) '0', after] 308 where 309 magic' = magic postfix 310 toInjL = B.length toInj 311 (before, rest) = B.breakSubstring magic' orig 312 (sizeBS, rest') = B.splitAt sizeLen $ B.drop (B8.length magic') rest 313 size = case reads $ B8.unpack sizeBS of 314 (i, _):_ -> i 315 [] -> error $ "Data.FileEmbed (inject): Your dummy space has been corrupted. Size is: " ++ show sizeBS 316 after = B.drop size rest' 317 318-- | Same as 'inject', but instead of performing the injecting in memory, read 319-- the contents from the filesystem and write back to a different file on the 320-- filesystem. 321injectFile :: B.ByteString -- ^ bs to inject 322 -> FilePath -- ^ template file 323 -> FilePath -- ^ output file 324 -> IO () 325injectFile = injectFileWith "MS" 326 327-- | Like 'injectFile', but takes a postfix for the magic string. 328-- 329-- Since 0.0.8 330injectFileWith :: B.ByteString -- ^ postfix of magic string 331 -> B.ByteString -- ^ bs to inject 332 -> FilePath -- ^ template file 333 -> FilePath -- ^ output file 334 -> IO () 335injectFileWith postfix inj srcFP dstFP = do 336 src <- B.readFile srcFP 337 case injectWith postfix inj src of 338 Nothing -> error "Insufficient dummy space" 339 Just dst -> B.writeFile dstFP dst 340 341{- $inject 342 343The inject system allows arbitrary content to be embedded inside a Haskell 344executable, post compilation. Typically, file-embed allows you to read some 345contents from the file system at compile time and embed them inside your 346executable. Consider a case, instead, where you would want to embed these 347contents after compilation. Two real-world examples are: 348 349* 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.) 350 351* 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. 352 353The typical workflow use: 354 355* Use 'dummySpace' or 'dummySpaceWith' to create some empty space in your executable 356 357* Use 'injectFile' or 'injectFileWith' from a separate utility to modify that executable to have the updated content. 358 359The reason for the @With@-variant of the functions is for cases where you wish 360to inject multiple different kinds of content, and therefore need control over 361the magic key. If you know for certain that there will only be one dummy space 362available, you can use the non-@With@ variants. 363 364-} 365 366-- | Take a relative file path and attach it to the root of the current 367-- project. 368-- 369-- The idea here is that, when building with Stack, the build will always be 370-- executed with a current working directory of the root of the project (where 371-- your .cabal file is located). However, if you load up multiple projects with 372-- @stack ghci@, the working directory may be something else entirely. 373-- 374-- This function looks at the source location of the Haskell file calling it, 375-- finds the first parent directory with a .cabal file, and uses that as the 376-- root directory for fixing the relative path. 377-- 378-- @$(makeRelativeToProject "data/foo.txt" >>= embedFile)@ 379-- 380-- @since 0.0.10 381makeRelativeToProject :: FilePath -> Q FilePath 382makeRelativeToProject rel = do 383 loc <- qLocation 384 runIO $ do 385 srcFP <- canonicalizePath $ loc_filename loc 386 mdir <- findProjectDir srcFP 387 case mdir of 388 Nothing -> error $ "Could not find .cabal file for path: " ++ srcFP 389 Just dir -> return $ dir </> rel 390 where 391 findProjectDir x = do 392 let dir = takeDirectory x 393 if dir == x 394 then return Nothing 395 else do 396 contents <- getDirectoryContents dir 397 if any isCabalFile contents 398 then return (Just dir) 399 else findProjectDir dir 400 401 isCabalFile fp = takeExtension fp == ".cabal" 402