{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | This module uses template Haskell. Following is a simplified explanation of usage for those unfamiliar with calling Template Haskell functions.
--
-- The function @embedFile@ in this modules embeds a file into the executable
-- that you can use it at runtime. A file is represented as a @ByteString@.
-- However, as you can see below, the type signature indicates a value of type
-- @Q Exp@ will be returned. In order to convert this into a @ByteString@, you
-- must use Template Haskell syntax, e.g.:
--
-- > $(embedFile "myfile.txt")
--
-- This expression will have type @ByteString@. Be certain to enable the
-- TemplateHaskell language extension, usually by adding the following to the
-- top of your module:
--
-- > {-# LANGUAGE TemplateHaskell #-}
module Data.FileEmbed
    ( -- * Embed at compile time
      embedFile
    , embedFileRelative
    , embedFileIfExists
    , embedOneFileOf
    , embedDir
    , embedDirListing
    , getDir
      -- * Embed as a IsString
    , embedStringFile
    , embedOneStringFileOf
      -- * Inject into an executable
      -- $inject
#if MIN_VERSION_template_haskell(2,5,0)
    , dummySpace
    , dummySpaceWith
#endif
    , inject
    , injectFile
    , injectWith
    , injectFileWith
      -- * Relative path manipulation
    , makeRelativeToProject
    , makeRelativeToLocationPredicate
      -- * Internal
    , stringToBs
    , bsToExp
    , strToExp
    ) where

import Language.Haskell.TH.Syntax
    ( Exp (AppE, ListE, LitE, TupE, SigE, VarE)
    , Lit (..)
    , Q
    , runIO
    , qLocation, loc_filename
#if MIN_VERSION_template_haskell(2,7,0)
    , Quasi(qAddDependentFile)
#endif
    )
#if MIN_VERSION_template_haskell(2,16,0)
import Language.Haskell.TH ( mkBytes, bytesPrimL )
import qualified Data.ByteString.Internal as B
#endif
import System.Directory (doesDirectoryExist, doesFileExist,
                         getDirectoryContents, canonicalizePath)
import Control.Exception (throw, tryJust, ErrorCall(..))
import Control.Monad ((<=<), filterM, guard)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Control.Arrow ((&&&), second)
import Control.Applicative ((<$>))
import Data.ByteString.Unsafe (unsafePackAddressLen)
import System.IO.Error (isDoesNotExistError)
import System.IO.Unsafe (unsafePerformIO)
import System.FilePath ((</>), takeDirectory, takeExtension)
import Data.String (fromString)
import Prelude as P
import Data.List (sortBy)
import Data.Ord (comparing)

-- | Embed a single file in your source code.
--
-- > import qualified Data.ByteString
-- >
-- > myFile :: Data.ByteString.ByteString
-- > myFile = $(embedFile "dirName/fileName")
embedFile :: FilePath -> Q Exp
embedFile :: [Char] -> Q Exp
embedFile [Char]
fp =
#if MIN_VERSION_template_haskell(2,7,0)
    [Char] -> Q ()
forall (m :: * -> *). Quasi m => [Char] -> m ()
qAddDependentFile [Char]
fp Q () -> Q ByteString -> Q ByteString
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
#endif
  (IO ByteString -> Q ByteString
forall a. IO a -> Q a
runIO (IO ByteString -> Q ByteString) -> IO ByteString -> Q ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
B.readFile [Char]
fp) Q ByteString -> (ByteString -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Q Exp
bsToExp

-- | Embed a single file in your source code.
--   Unlike 'embedFile', path is given relative to project root.
-- @since 0.0.16.0
embedFileRelative :: FilePath -> Q Exp
embedFileRelative :: [Char] -> Q Exp
embedFileRelative = [Char] -> Q Exp
embedFile ([Char] -> Q Exp) -> ([Char] -> Q [Char]) -> [Char] -> Q Exp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Char] -> Q [Char]
makeRelativeToProject

-- | Maybe embed a single file in your source code depending on whether or not file exists.
--
-- Warning: When a build is compiled with the file missing, a recompile when the file exists might not trigger an embed of the file.
-- You might try to fix this by doing a clean build.
--
-- > import qualified Data.ByteString
-- >
-- > maybeMyFile :: Maybe Data.ByteString.ByteString
-- > maybeMyFile = $(embedFileIfExists "dirName/fileName")
--
-- @since 0.0.14.0
embedFileIfExists :: FilePath -> Q Exp
embedFileIfExists :: [Char] -> Q Exp
embedFileIfExists [Char]
fp = do
  Maybe ByteString
mbs <- IO (Maybe ByteString) -> Q (Maybe ByteString)
forall a. IO a -> Q a
runIO IO (Maybe ByteString)
maybeFile
  case Maybe ByteString
mbs of
    Maybe ByteString
Nothing -> [| Nothing |]
    Just ByteString
bs -> do
#if MIN_VERSION_template_haskell(2,7,0)
      [Char] -> Q ()
forall (m :: * -> *). Quasi m => [Char] -> m ()
qAddDependentFile [Char]
fp
#endif
      [| Just $(ByteString -> Q Exp
bsToExp ByteString
bs) |]
  where
    maybeFile :: IO (Maybe B.ByteString)
    maybeFile :: IO (Maybe ByteString)
maybeFile = 
      (() -> Maybe ByteString)
-> (ByteString -> Maybe ByteString)
-> Either () ByteString
-> Maybe ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ByteString -> () -> Maybe ByteString
forall a b. a -> b -> a
const Maybe ByteString
forall a. Maybe a
Nothing) ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Either () ByteString -> Maybe ByteString)
-> IO (Either () ByteString) -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 
      (IOError -> Maybe ()) -> IO ByteString -> IO (Either () ByteString)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) ([Char] -> IO ByteString
B.readFile [Char]
fp)

-- | Embed a single existing file in your source code
-- out of list a list of paths supplied.
--
-- > import qualified Data.ByteString
-- >
-- > myFile :: Data.ByteString.ByteString
-- > myFile = $(embedOneFileOf [ "dirName/fileName", "src/dirName/fileName" ])
embedOneFileOf :: [FilePath] -> Q Exp
embedOneFileOf :: [[Char]] -> Q Exp
embedOneFileOf [[Char]]
ps =
  (IO ([Char], ByteString) -> Q ([Char], ByteString)
forall a. IO a -> Q a
runIO (IO ([Char], ByteString) -> Q ([Char], ByteString))
-> IO ([Char], ByteString) -> Q ([Char], ByteString)
forall a b. (a -> b) -> a -> b
$ [[Char]] -> IO ([Char], ByteString)
readExistingFile [[Char]]
ps) Q ([Char], ByteString) -> (([Char], ByteString) -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ ( [Char]
path, ByteString
content ) -> do
#if MIN_VERSION_template_haskell(2,7,0)
    [Char] -> Q ()
forall (m :: * -> *). Quasi m => [Char] -> m ()
qAddDependentFile [Char]
path
#endif
    ByteString -> Q Exp
bsToExp ByteString
content
  where
    readExistingFile :: [FilePath] -> IO ( FilePath, B.ByteString )
    readExistingFile :: [[Char]] -> IO ([Char], ByteString)
readExistingFile [[Char]]
xs = do
      [[Char]]
ys <- ([Char] -> IO Bool) -> [[Char]] -> IO [[Char]]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [Char] -> IO Bool
doesFileExist [[Char]]
xs
      case [[Char]]
ys of
        ([Char]
p:[[Char]]
_) -> [Char] -> IO ByteString
B.readFile [Char]
p IO ByteString
-> (ByteString -> IO ([Char], ByteString))
-> IO ([Char], ByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ ByteString
c -> ([Char], ByteString) -> IO ([Char], ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Char]
p, ByteString
c )
        [[Char]]
_ -> ErrorCall -> IO ([Char], ByteString)
forall a e. Exception e => e -> a
throw (ErrorCall -> IO ([Char], ByteString))
-> ErrorCall -> IO ([Char], ByteString)
forall a b. (a -> b) -> a -> b
$ [Char] -> ErrorCall
ErrorCall [Char]
"Cannot find file to embed as resource"

-- | Embed a directory recursively in your source code.
--
-- > import qualified Data.ByteString
-- >
-- > myDir :: [(FilePath, Data.ByteString.ByteString)]
-- > myDir = $(embedDir "dirName")
embedDir :: FilePath -> Q Exp
embedDir :: [Char] -> Q Exp
embedDir [Char]
fp = do
    Type
typ <- [t| [(FilePath, B.ByteString)] |]
    Exp
e <- [Exp] -> Exp
ListE ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((IO [([Char], ByteString)] -> Q [([Char], ByteString)]
forall a. IO a -> Q a
runIO (IO [([Char], ByteString)] -> Q [([Char], ByteString)])
-> IO [([Char], ByteString)] -> Q [([Char], ByteString)]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [([Char], ByteString)]
fileList [Char]
fp) Q [([Char], ByteString)]
-> ([([Char], ByteString)] -> Q [Exp]) -> Q [Exp]
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (([Char], ByteString) -> Q Exp)
-> [([Char], ByteString)] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Char] -> ([Char], ByteString) -> Q Exp
pairToExp [Char]
fp))
    Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Type -> Exp
SigE Exp
e Type
typ

-- | Embed a directory listing recursively in your source code.
--
-- > myFiles :: [FilePath]
-- > myFiles = $(embedDirListing "dirName")
--
-- @since 0.0.11
embedDirListing :: FilePath -> Q Exp
embedDirListing :: [Char] -> Q Exp
embedDirListing [Char]
fp = do
    Type
typ <- [t| [FilePath] |]
    Exp
e <- [Exp] -> Exp
ListE ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((IO [[Char]] -> Q [[Char]]
forall a. IO a -> Q a
runIO (IO [[Char]] -> Q [[Char]]) -> IO [[Char]] -> Q [[Char]]
forall a b. (a -> b) -> a -> b
$ (([Char], ByteString) -> [Char])
-> [([Char], ByteString)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char], ByteString) -> [Char]
forall a b. (a, b) -> a
fst ([([Char], ByteString)] -> [[Char]])
-> IO [([Char], ByteString)] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [([Char], ByteString)]
fileList [Char]
fp) Q [[Char]] -> ([[Char]] -> Q [Exp]) -> Q [Exp]
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Char] -> Q Exp) -> [[Char]] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Char] -> Q Exp
strToExp)
    Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Type -> Exp
SigE Exp
e Type
typ

-- | Get a directory tree in the IO monad.
--
-- This is the workhorse of 'embedDir'
getDir :: FilePath -> IO [(FilePath, B.ByteString)]
getDir :: [Char] -> IO [([Char], ByteString)]
getDir = [Char] -> IO [([Char], ByteString)]
fileList

pairToExp :: FilePath -> (FilePath, B.ByteString) -> Q Exp
pairToExp :: [Char] -> ([Char], ByteString) -> Q Exp
pairToExp [Char]
_root ([Char]
path, ByteString
bs) = do
#if MIN_VERSION_template_haskell(2,7,0)
    [Char] -> Q ()
forall (m :: * -> *). Quasi m => [Char] -> m ()
qAddDependentFile ([Char] -> Q ()) -> [Char] -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char]
_root [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
'/' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
path
#endif
    Exp
exp' <- ByteString -> Q Exp
bsToExp ByteString
bs
    Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$! [Maybe Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
      ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just
#endif
      [Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> Lit
StringL [Char]
path, Exp
exp']

bsToExp :: B.ByteString -> Q Exp
#if MIN_VERSION_template_haskell(2, 5, 0)
bsToExp :: ByteString -> Q Exp
bsToExp ByteString
bs =
    Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'unsafePerformIO
      Exp -> Exp -> Exp
`AppE` (Name -> Exp
VarE 'unsafePackAddressLen
      Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (Integer -> Lit
IntegerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B8.length ByteString
bs)
#if MIN_VERSION_template_haskell(2, 16, 0)
      Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (Bytes -> Lit
bytesPrimL (
                let B.PS ForeignPtr Word8
ptr Int
off Int
sz = ByteString
bs
                in  ForeignPtr Word8 -> Word -> Word -> Bytes
mkBytes ForeignPtr Word8
ptr (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz))))
#elif MIN_VERSION_template_haskell(2, 8, 0)
      `AppE` LitE (StringPrimL $ B.unpack bs))
#else
      `AppE` LitE (StringPrimL $ B8.unpack bs))
#endif
#else
bsToExp bs = do
    helper <- [| stringToBs |]
    let chars = B8.unpack bs
    return $! AppE helper $! LitE $! StringL chars
#endif

stringToBs :: String -> B.ByteString
stringToBs :: [Char] -> ByteString
stringToBs = [Char] -> ByteString
B8.pack

-- | Embed a single file in your source code.
--
-- > import Data.String
-- >
-- > myFile :: IsString a => a
-- > myFile = $(embedStringFile "dirName/fileName")
--
-- Since 0.0.9
embedStringFile :: FilePath -> Q Exp
embedStringFile :: [Char] -> Q Exp
embedStringFile [Char]
fp =
#if MIN_VERSION_template_haskell(2,7,0)
    [Char] -> Q ()
forall (m :: * -> *). Quasi m => [Char] -> m ()
qAddDependentFile [Char]
fp Q () -> Q [Char] -> Q [Char]
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
#endif
  (IO [Char] -> Q [Char]
forall a. IO a -> Q a
runIO (IO [Char] -> Q [Char]) -> IO [Char] -> Q [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
P.readFile [Char]
fp) Q [Char] -> ([Char] -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Q Exp
strToExp

-- | Embed a single existing string file in your source code
-- out of list a list of paths supplied.
--
-- Since 0.0.9
embedOneStringFileOf :: [FilePath] -> Q Exp
embedOneStringFileOf :: [[Char]] -> Q Exp
embedOneStringFileOf [[Char]]
ps =
  (IO ([Char], [Char]) -> Q ([Char], [Char])
forall a. IO a -> Q a
runIO (IO ([Char], [Char]) -> Q ([Char], [Char]))
-> IO ([Char], [Char]) -> Q ([Char], [Char])
forall a b. (a -> b) -> a -> b
$ [[Char]] -> IO ([Char], [Char])
readExistingFile [[Char]]
ps) Q ([Char], [Char]) -> (([Char], [Char]) -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ ( [Char]
path, [Char]
content ) -> do
#if MIN_VERSION_template_haskell(2,7,0)
    [Char] -> Q ()
forall (m :: * -> *). Quasi m => [Char] -> m ()
qAddDependentFile [Char]
path
#endif
    [Char] -> Q Exp
strToExp [Char]
content
  where
    readExistingFile :: [FilePath] -> IO ( FilePath, String )
    readExistingFile :: [[Char]] -> IO ([Char], [Char])
readExistingFile [[Char]]
xs = do
      [[Char]]
ys <- ([Char] -> IO Bool) -> [[Char]] -> IO [[Char]]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [Char] -> IO Bool
doesFileExist [[Char]]
xs
      case [[Char]]
ys of
        ([Char]
p:[[Char]]
_) -> [Char] -> IO [Char]
P.readFile [Char]
p IO [Char] -> ([Char] -> IO ([Char], [Char])) -> IO ([Char], [Char])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ [Char]
c -> ([Char], [Char]) -> IO ([Char], [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Char]
p, [Char]
c )
        [[Char]]
_ -> ErrorCall -> IO ([Char], [Char])
forall a e. Exception e => e -> a
throw (ErrorCall -> IO ([Char], [Char]))
-> ErrorCall -> IO ([Char], [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> ErrorCall
ErrorCall [Char]
"Cannot find file to embed as resource"

strToExp :: String -> Q Exp
#if MIN_VERSION_template_haskell(2, 5, 0)
strToExp :: [Char] -> Q Exp
strToExp [Char]
s =
    Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'fromString
      Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE ([Char] -> Lit
StringL [Char]
s)
#else
strToExp s = do
    helper <- [| fromString |]
    return $! AppE helper $! LitE $! StringL s
#endif

notHidden :: FilePath -> Bool
notHidden :: [Char] -> Bool
notHidden (Char
'.':[Char]
_) = Bool
False
notHidden [Char]
_ = Bool
True

fileList :: FilePath -> IO [(FilePath, B.ByteString)]
fileList :: [Char] -> IO [([Char], ByteString)]
fileList [Char]
top = [Char] -> [Char] -> IO [([Char], ByteString)]
fileList' [Char]
top [Char]
""

fileList' :: FilePath -> FilePath -> IO [(FilePath, B.ByteString)]
fileList' :: [Char] -> [Char] -> IO [([Char], ByteString)]
fileList' [Char]
realTop [Char]
top = do
    [[Char]]
allContents <- ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
notHidden ([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [[Char]]
getDirectoryContents ([Char]
realTop [Char] -> [Char] -> [Char]
</> [Char]
top)
    let all' :: [([Char], [Char])]
all' = ([Char] -> ([Char], [Char])) -> [[Char]] -> [([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (([Char]
top [Char] -> [Char] -> [Char]
</>) ([Char] -> [Char])
-> ([Char] -> [Char]) -> [Char] -> ([Char], [Char])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (\[Char]
x -> [Char]
realTop [Char] -> [Char] -> [Char]
</> [Char]
top [Char] -> [Char] -> [Char]
</> [Char]
x)) [[Char]]
allContents
    [([Char], ByteString)]
files <- (([Char], [Char]) -> IO Bool)
-> [([Char], [Char])] -> IO [([Char], [Char])]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ([Char] -> IO Bool
doesFileExist ([Char] -> IO Bool)
-> (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> [Char]
forall a b. (a, b) -> b
snd) [([Char], [Char])]
all' IO [([Char], [Char])]
-> ([([Char], [Char])] -> IO [([Char], ByteString)])
-> IO [([Char], ByteString)]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
             (([Char], [Char]) -> IO ([Char], ByteString))
-> [([Char], [Char])] -> IO [([Char], ByteString)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([Char], IO ByteString) -> IO ([Char], ByteString)
forall (m :: * -> *) a b. Monad m => (a, m b) -> m (a, b)
liftPair2 (([Char], IO ByteString) -> IO ([Char], ByteString))
-> (([Char], [Char]) -> ([Char], IO ByteString))
-> ([Char], [Char])
-> IO ([Char], ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> IO ByteString)
-> ([Char], [Char]) -> ([Char], IO ByteString)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [Char] -> IO ByteString
B.readFile)
    [[([Char], ByteString)]]
dirs <- (([Char], [Char]) -> IO Bool)
-> [([Char], [Char])] -> IO [([Char], [Char])]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ([Char] -> IO Bool
doesDirectoryExist ([Char] -> IO Bool)
-> (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> [Char]
forall a b. (a, b) -> b
snd) [([Char], [Char])]
all' IO [([Char], [Char])]
-> ([([Char], [Char])] -> IO [[([Char], ByteString)]])
-> IO [[([Char], ByteString)]]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            (([Char], [Char]) -> IO [([Char], ByteString)])
-> [([Char], [Char])] -> IO [[([Char], ByteString)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Char] -> [Char] -> IO [([Char], ByteString)]
fileList' [Char]
realTop ([Char] -> IO [([Char], ByteString)])
-> (([Char], [Char]) -> [Char])
-> ([Char], [Char])
-> IO [([Char], ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> [Char]
forall a b. (a, b) -> a
fst)
    [([Char], ByteString)] -> IO [([Char], ByteString)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([([Char], ByteString)] -> IO [([Char], ByteString)])
-> [([Char], ByteString)] -> IO [([Char], ByteString)]
forall a b. (a -> b) -> a -> b
$ (([Char], ByteString) -> ([Char], ByteString) -> Ordering)
-> [([Char], ByteString)] -> [([Char], ByteString)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((([Char], ByteString) -> [Char])
-> ([Char], ByteString) -> ([Char], ByteString) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ([Char], ByteString) -> [Char]
forall a b. (a, b) -> a
fst) ([([Char], ByteString)] -> [([Char], ByteString)])
-> [([Char], ByteString)] -> [([Char], ByteString)]
forall a b. (a -> b) -> a -> b
$ [[([Char], ByteString)]] -> [([Char], ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[([Char], ByteString)]] -> [([Char], ByteString)])
-> [[([Char], ByteString)]] -> [([Char], ByteString)]
forall a b. (a -> b) -> a -> b
$ [([Char], ByteString)]
files [([Char], ByteString)]
-> [[([Char], ByteString)]] -> [[([Char], ByteString)]]
forall a. a -> [a] -> [a]
: [[([Char], ByteString)]]
dirs

liftPair2 :: Monad m => (a, m b) -> m (a, b)
liftPair2 :: forall (m :: * -> *) a b. Monad m => (a, m b) -> m (a, b)
liftPair2 (a
a, m b
b) = m b
b m b -> (b -> m (a, b)) -> m (a, b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
b' -> (a, b) -> m (a, b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b')

magic :: B.ByteString -> B.ByteString
magic :: ByteString -> ByteString
magic ByteString
x = [ByteString] -> ByteString
B8.concat [ByteString
"fe", ByteString
x]

sizeLen :: Int
sizeLen :: Int
sizeLen = Int
20

getInner :: B.ByteString -> B.ByteString
getInner :: ByteString -> ByteString
getInner ByteString
b =
    let (ByteString
sizeBS, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
sizeLen ByteString
b
     in case ReadS Int
forall a. Read a => ReadS a
reads ReadS Int -> ReadS Int
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
B8.unpack ByteString
sizeBS of
            (Int
i, [Char]
_):[(Int, [Char])]
_ -> Int -> ByteString -> ByteString
B.take Int
i ByteString
rest
            [] -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Data.FileEmbed (getInner): Your dummy space has been corrupted."

padSize :: Int -> String
padSize :: Int -> [Char]
padSize Int
i =
    let s :: [Char]
s = Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
     in Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
sizeLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s) Char
'0' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s

#if MIN_VERSION_template_haskell(2,5,0)
-- | Allocate the given number of bytes in the generate executable. That space
-- can be filled up with the 'inject' and 'injectFile' functions.
dummySpace :: Int -> Q Exp
dummySpace :: Int -> Q Exp
dummySpace = ByteString -> Int -> Q Exp
dummySpaceWith ByteString
"MS"

-- | Like 'dummySpace', but takes a postfix for the magic string.  In
-- order for this to work, the same postfix must be used by 'inject' /
-- 'injectFile'.  This allows an executable to have multiple
-- 'ByteString's injected into it, without encountering collisions.
--
-- Since 0.0.8
dummySpaceWith :: B.ByteString -> Int -> Q Exp
dummySpaceWith :: ByteString -> Int -> Q Exp
dummySpaceWith ByteString
postfix Int
space = do
    let size :: [Char]
size = Int -> [Char]
padSize Int
space
        magic' :: ByteString
magic' = ByteString -> ByteString
magic ByteString
postfix
        start :: [Char]
start = ByteString -> [Char]
B8.unpack ByteString
magic' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
size
        magicLen :: Int
magicLen = ByteString -> Int
B8.length ByteString
magic'
        len :: Int
len = Int
magicLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sizeLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
space
        chars :: Exp
chars = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ [Word8] -> Lit
StringPrimL ([Word8] -> Lit) -> [Word8] -> Lit
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_template_haskell(2,6,0)
            (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) ([Char] -> [Word8]) -> [Char] -> [Word8]
forall a b. (a -> b) -> a -> b
$
#endif
            [Char]
start [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
space Char
'0'
    [| getInner (B.drop magicLen (unsafePerformIO (unsafePackAddressLen len $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
chars)))) |]
#endif

-- | Inject some raw data inside a @ByteString@ containing empty, dummy space
-- (allocated with @dummySpace@). Typically, the original @ByteString@ is an
-- executable read from the filesystem.
inject :: B.ByteString -- ^ bs to inject
       -> B.ByteString -- ^ original BS containing dummy
       -> Maybe B.ByteString -- ^ new BS, or Nothing if there is insufficient dummy space
inject :: ByteString -> ByteString -> Maybe ByteString
inject = ByteString -> ByteString -> ByteString -> Maybe ByteString
injectWith ByteString
"MS"

-- | Like 'inject', but takes a postfix for the magic string.
--
-- Since 0.0.8
injectWith :: B.ByteString -- ^ postfix of magic string
           -> B.ByteString -- ^ bs to inject
           -> B.ByteString -- ^ original BS containing dummy
           -> Maybe B.ByteString -- ^ new BS, or Nothing if there is insufficient dummy space
injectWith :: ByteString -> ByteString -> ByteString -> Maybe ByteString
injectWith ByteString
postfix ByteString
toInj ByteString
orig =
    if Int
toInjL Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
size
        then Maybe ByteString
forall a. Maybe a
Nothing
        else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString
before, ByteString
magic', [Char] -> ByteString
B8.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
padSize Int
toInjL, ByteString
toInj, [Char] -> ByteString
B8.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
toInjL) Char
'0', ByteString
after]
  where
    magic' :: ByteString
magic' = ByteString -> ByteString
magic ByteString
postfix
    toInjL :: Int
toInjL = ByteString -> Int
B.length ByteString
toInj
    (ByteString
before, ByteString
rest) = ByteString -> ByteString -> (ByteString, ByteString)
B.breakSubstring ByteString
magic' ByteString
orig
    (ByteString
sizeBS, ByteString
rest') = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
sizeLen (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B8.length ByteString
magic') ByteString
rest
    size :: Int
size = case ReadS Int
forall a. Read a => ReadS a
reads ReadS Int -> ReadS Int
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
B8.unpack ByteString
sizeBS of
            (Int
i, [Char]
_):[(Int, [Char])]
_ -> Int
i
            [] -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char] -> Int) -> [Char] -> Int
forall a b. (a -> b) -> a -> b
$ [Char]
"Data.FileEmbed (inject): Your dummy space has been corrupted. Size is: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
sizeBS
    after :: ByteString
after = Int -> ByteString -> ByteString
B.drop Int
size ByteString
rest'

-- | Same as 'inject', but instead of performing the injecting in memory, read
-- the contents from the filesystem and write back to a different file on the
-- filesystem.
injectFile :: B.ByteString -- ^ bs to inject
           -> FilePath -- ^ template file
           -> FilePath -- ^ output file
           -> IO ()
injectFile :: ByteString -> [Char] -> [Char] -> IO ()
injectFile = ByteString -> ByteString -> [Char] -> [Char] -> IO ()
injectFileWith ByteString
"MS"

-- | Like 'injectFile', but takes a postfix for the magic string.
--
-- Since 0.0.8
injectFileWith :: B.ByteString -- ^ postfix of magic string
               -> B.ByteString -- ^ bs to inject
               -> FilePath -- ^ template file
               -> FilePath -- ^ output file
               -> IO ()
injectFileWith :: ByteString -> ByteString -> [Char] -> [Char] -> IO ()
injectFileWith ByteString
postfix ByteString
inj [Char]
srcFP [Char]
dstFP = do
    ByteString
src <- [Char] -> IO ByteString
B.readFile [Char]
srcFP
    case ByteString -> ByteString -> ByteString -> Maybe ByteString
injectWith ByteString
postfix ByteString
inj ByteString
src of
        Maybe ByteString
Nothing -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Insufficient dummy space"
        Just ByteString
dst -> [Char] -> ByteString -> IO ()
B.writeFile [Char]
dstFP ByteString
dst

{- $inject

The inject system allows arbitrary content to be embedded inside a Haskell
executable, post compilation. Typically, file-embed allows you to read some
contents from the file system at compile time and embed them inside your
executable. Consider a case, instead, where you would want to embed these
contents after compilation. Two real-world examples are:

* 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.)

* 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.

The typical workflow use:

* Use 'dummySpace' or 'dummySpaceWith' to create some empty space in your executable

* Use 'injectFile' or 'injectFileWith' from a separate utility to modify that executable to have the updated content.

The reason for the @With@-variant of the functions is for cases where you wish
to inject multiple different kinds of content, and therefore need control over
the magic key. If you know for certain that there will only be one dummy space
available, you can use the non-@With@ variants.

-}

-- | Take a relative file path and attach it to the root of the current
-- project.
--
-- The idea here is that, when building with Stack, the build will always be
-- executed with a current working directory of the root of the project (where
-- your .cabal file is located). However, if you load up multiple projects with
-- @stack ghci@, the working directory may be something else entirely.
--
-- This function looks at the source location of the Haskell file calling it,
-- finds the first parent directory with a .cabal file, and uses that as the
-- root directory for fixing the relative path.
--
-- @$(makeRelativeToProject "data/foo.txt" >>= embedFile)@
--
-- @since 0.0.10
makeRelativeToProject :: FilePath -> Q FilePath
makeRelativeToProject :: [Char] -> Q [Char]
makeRelativeToProject = ([Char] -> Bool) -> [Char] -> Q [Char]
makeRelativeToLocationPredicate (([Char] -> Bool) -> [Char] -> Q [Char])
-> ([Char] -> Bool) -> [Char] -> Q [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Char]
".cabal" ([Char] -> Bool) -> ([Char] -> [Char]) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
takeExtension

-- | 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
--
-- This function looks at the source location of the Haskell file calling it,
-- finds the first parent directory with a file matching the given predicate, and uses that as the
-- root directory for fixing the relative path.
--
-- @$(makeRelativeToLocationPredicate ((==) ".cabal" . takeExtension) "data/foo.txt" >>= embedFile)@
--
-- @since 0.0.15.0
makeRelativeToLocationPredicate :: (FilePath -> Bool) -> FilePath -> Q FilePath
makeRelativeToLocationPredicate :: ([Char] -> Bool) -> [Char] -> Q [Char]
makeRelativeToLocationPredicate [Char] -> Bool
isTargetFile [Char]
rel = do
    Loc
loc <- Q Loc
forall (m :: * -> *). Quasi m => m Loc
qLocation
    IO [Char] -> Q [Char]
forall a. IO a -> Q a
runIO (IO [Char] -> Q [Char]) -> IO [Char] -> Q [Char]
forall a b. (a -> b) -> a -> b
$ do
        [Char]
srcFP <- [Char] -> IO [Char]
canonicalizePath ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ Loc -> [Char]
loc_filename Loc
loc
        Maybe [Char]
mdir <- [Char] -> IO (Maybe [Char])
findProjectDir [Char]
srcFP
        case Maybe [Char]
mdir of
            Maybe [Char]
Nothing -> [Char] -> IO [Char]
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not find .cabal file for path: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
srcFP
            Just [Char]
dir -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
rel
  where
    findProjectDir :: [Char] -> IO (Maybe [Char])
findProjectDir [Char]
x = do
        let dir :: [Char]
dir = [Char] -> [Char]
takeDirectory [Char]
x
        if [Char]
dir [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
x
            then Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing
            else do
                [[Char]]
contents <- [Char] -> IO [[Char]]
getDirectoryContents [Char]
dir
                if ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [Char] -> Bool
isTargetFile [[Char]]
contents
                    then Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
dir)
                    else [Char] -> IO (Maybe [Char])
findProjectDir [Char]
dir