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