module Data.FileEmbed
(
embedFile
, embedDir
, getDir
#if MIN_VERSION_template_haskell(2,5,0)
, dummySpace
#endif
, inject
, injectFile
) where
import Language.Haskell.TH.Syntax
( Exp (AppE, ListE, LitE, TupE)
#if MIN_VERSION_template_haskell(2,5,0)
, Lit (StringL, StringPrimL, IntegerL)
#else
, Lit (StringL, IntegerL)
#endif
, Q
, runIO
#if MIN_VERSION_template_haskell(2,7,0)
, Quasi(qAddDependentFile)
#endif
)
import System.Directory (doesDirectoryExist, doesFileExist,
getDirectoryContents)
import Control.Monad (filterM)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Control.Arrow ((&&&), second, first)
import Control.Applicative ((<$>))
import Data.Monoid (mappend)
import Data.ByteString.Unsafe (unsafePackAddressLen)
import System.IO.Unsafe (unsafePerformIO)
embedFile :: FilePath -> Q Exp
embedFile fp =
#if MIN_VERSION_template_haskell(2,7,0)
qAddDependentFile fp >>
#endif
(runIO $ B.readFile fp) >>= bsToExp
embedDir :: FilePath -> Q Exp
embedDir fp = ListE <$> ((runIO $ fileList fp) >>= mapM (pairToExp fp))
getDir :: FilePath -> IO [(FilePath, B.ByteString)]
getDir = fileList
pairToExp :: FilePath -> (FilePath, B.ByteString) -> Q Exp
pairToExp _root (path, bs) = do
#if MIN_VERSION_template_haskell(2,7,0)
qAddDependentFile $ _root ++ '/' : path
#endif
exp' <- bsToExp bs
return $! TupE [LitE $ StringL path, exp']
bsToExp :: B.ByteString -> Q Exp
bsToExp bs = do
helper <- [| stringToBs |]
let chars = B8.unpack bs
return $! AppE helper $! LitE $! StringL chars
stringToBs :: String -> B.ByteString
stringToBs = B8.pack
notHidden :: FilePath -> Bool
notHidden ('.':_) = False
notHidden _ = True
fileList :: FilePath -> IO [(FilePath, B.ByteString)]
fileList top = map (first tail) <$> fileList' top ""
fileList' :: FilePath -> FilePath -> IO [(FilePath, B.ByteString)]
fileList' realTop top = do
let prefix1 = top ++ "/"
prefix2 = realTop ++ prefix1
allContents <- filter notHidden <$> getDirectoryContents prefix2
let all' = map (mappend prefix1 &&& mappend prefix2) allContents
files <- filterM (doesFileExist . snd) all' >>=
mapM (liftPair2 . second B.readFile)
dirs <- filterM (doesDirectoryExist . snd) all' >>=
mapM (fileList' realTop . fst)
return $ concat $ files : dirs
liftPair2 :: Monad m => (a, m b) -> m (a, b)
liftPair2 (a, b) = b >>= \b' -> return (a, b')
magic :: [Char]
magic = concat ["fe", "MS"]
sizeLen :: Int
sizeLen = 20
getInner :: B.ByteString -> B.ByteString
getInner b =
let (sizeBS, rest) = B.splitAt sizeLen $ B.drop (length magic) b
in case reads $ B8.unpack sizeBS of
(i, _):_ -> B.take i rest
[] -> error "Data.FileEmbed (getInner): Your dummy space has been corrupted."
padSize :: Int -> String
padSize i =
let s = show i
in replicate (sizeLen length s) '0' ++ s
#if MIN_VERSION_template_haskell(2,5,0)
dummySpace :: Int -> Q Exp
dummySpace space = do
let size = padSize space
let start = magic ++ size
let chars = LitE $ StringPrimL $ start ++ replicate space '0'
let len = LitE $ IntegerL $ fromIntegral $ length start + space
upi <- [|unsafePerformIO|]
pack <- [|unsafePackAddressLen|]
getInner' <- [|getInner|]
return $ getInner' `AppE` (upi `AppE` (pack `AppE` len `AppE` chars))
#endif
inject :: B.ByteString
-> B.ByteString
-> Maybe B.ByteString
inject toInj orig =
if toInjL > size
then Nothing
else Just $ B.concat [before, B8.pack magic, B8.pack $ padSize toInjL, toInj, B8.pack $ replicate (size toInjL) '0', after]
where
toInjL = B.length toInj
(before, rest) = B.breakSubstring (B8.pack magic) orig
(sizeBS, rest') = B.splitAt sizeLen $ B.drop (length magic) rest
size = case reads $ B8.unpack sizeBS of
(i, _):_ -> i
[] -> error $ "Data.FileEmbed (inject): Your dummy space has been corrupted. Size is: " ++ show sizeBS
after = B.drop size rest'
injectFile :: B.ByteString
-> FilePath
-> FilePath
-> IO ()
injectFile inj srcFP dstFP = do
src <- B.readFile srcFP
case inject inj src of
Nothing -> error "Insufficient dummy space"
Just dst -> B.writeFile dstFP dst