{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-} ------------------------------------------------------------ -- | -- Module : FileEmbedLzma -- Copyright : (c) 2015-2018 Futurice, 2018 Oleg Grenrus -- License : BSD-3-Clause -- Maintainer : Oleg Grenrus ---------------------------------------------------------------------------- module FileEmbedLzma ( -- * Embed files embedByteString, embedLazyByteString, embedText, embedLazyText, -- * Embed directories embedDir, embedRecursiveDir, -- * Internal -- ** Directory listing listDirectoryFiles, listRecursiveDirectoryFiles, listDirectoryFilesF, -- ** Template Haskell lazyBytestringE, ) where import Control.Arrow (first) import Control.Monad (forM) import Control.Monad.Trans.State.Strict (runState, state) import Data.Foldable (for_) import Data.Functor.Compose (Compose (..)) import Data.Int (Int64) import Data.List (sort) import Language.Haskell.TH import Language.Haskell.TH.Syntax (qAddDependentFile) import System.Directory (doesDirectoryExist, getDirectoryContents) import System.FilePath (makeRelative, ()) import System.IO.Unsafe (unsafePerformIO) import qualified Codec.Compression.Lzma as LZMA import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Unsafe as BS.Unsafe import qualified Data.Text as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LTE #if MIN_VERSION_template_haskell(2,16,0) import qualified Data.ByteString.Internal as BS.Internal import Language.Haskell.TH.Syntax (Bytes (..)) #endif -- $setup -- >>> :set -XTemplateHaskell -dppr-cols=9999 -- >>> import qualified Data.ByteString.Lazy as LBS -- >>> import qualified Data.ByteString as BS -- >>> import qualified Data.Text.Lazy as LT -- >>> import qualified Data.Text as T listRecursiveDirectoryFiles :: FilePath -> IO [(FilePath, LBS.ByteString)] listRecursiveDirectoryFiles = listDirectoryFilesF listRecursiveDirectoryFiles listDirectoryFiles :: FilePath -> IO [(FilePath, LBS.ByteString)] listDirectoryFiles = listDirectoryFilesF (\_ -> return []) listDirectoryFilesF :: (FilePath -> IO [(FilePath, LBS.ByteString)]) -- ^ what to do with a sub-directory -> FilePath -> IO [(FilePath, LBS.ByteString)] listDirectoryFilesF go topdir = do names <- getDirectoryContents topdir let properNames = filter (`notElem` [".", ".."]) names paths <- forM properNames $ \name -> do let path = topdir name isDirectory <- doesDirectoryExist path if isDirectory then go path else do contents <- LBS.readFile path return [(path, contents)] return (concat paths) makeAllRelative :: FilePath -> [(FilePath, a)] -> [(FilePath, a)] makeAllRelative topdir = map (first (("/" ++) . makeRelative topdir)) -- | Makes lazy 'LBS.ByteString' expression. -- Embedded value is compressed with LZMA. lazyBytestringE :: LBS.ByteString -> Q Exp lazyBytestringE lbs = [| LZMA.decompress . LBS.fromStrict . unsafePerformIO |] `appE` ([| BS.Unsafe.unsafePackAddressLen |] `appE` l `appE` s) where bs = LBS.toStrict $ LZMA.compressWith params lbs #if MIN_VERSION_template_haskell(2,16,0) s = litE $ bytesPrimL $ bsToBytes bs #else s = litE $ stringPrimL $ BS.unpack bs #endif l = litE $ integerL $ fromIntegral $ BS.length bs params = LZMA.defaultCompressParams {- doesn't seem to affect much { LZMA.compressLevel = LZMA.CompressionLevel9 , LZMA.compressLevelExtreme = True } -} #if MIN_VERSION_template_haskell(2,16,0) bsToBytes :: BS.ByteString -> Bytes bsToBytes (BS.Internal.PS fptr off len) = Bytes fptr (fromIntegral off) (fromIntegral len) #endif makeEmbeddedEntry :: Name -> (FilePath, (Int64, Int64)) -> Q Exp makeEmbeddedEntry name (path, (off, len)) = do let y = [| LBS.toStrict . LBS.take len . LBS.drop off |] `appE` varE name [| (,) path |] `appE` y concatEntries :: Traversable t => t LBS.ByteString -> (LBS.ByteString, t (Int64, Int64)) concatEntries xs = (bslEndo LBS.empty, ys) where (ys, (_, bslEndo)) = runState (traverse (state . single) xs) (0, id) single :: LBS.ByteString -- file bytestring -> (Int64, LBS.ByteString -> LBS.ByteString) -- current offset, buffer so far -> ((Int64, Int64), (Int64, LBS.ByteString -> LBS.ByteString)) single bsl (off, endo) = ((off, l), (off + l, endo . LBS.append bsl)) where l = fromIntegral $ LBS.length bsl ------------------------------------------------------------------------------- -- Directories ------------------------------------------------------------------------------- -- | Embed a @[('FilePath', 'Data.ByteString.ByteString')]@ list, traversing given directory. embedDir :: FilePath -> Q Exp embedDir topdir = do pairs' <- runIO $ listDirectoryFiles topdir for_ pairs' $ qAddDependentFile . fst let pairs = makeAllRelative topdir pairs' embedPairs pairs embedPairs :: [(FilePath, LBS.ByteString)] -> Q Exp embedPairs pairs = do -- we do a hop to only embed single big bytestring. -- it's beneficial as lzma have more stuff to compress let (bsl, Compose offsets) = concatEntries (Compose pairs) bslName <- newName "embedBsl" bslExpr <- lazyBytestringE bsl let e = letE [ return $ ValD (VarP bslName) (NormalB bslExpr) [] ] $ listE $ map (makeEmbeddedEntry bslName) offsets sigE e [t| [(FilePath, BS.ByteString)] |] -- | Embed a @[('FilePath', 'Data.ByteString.ByteString')]@ list, recursively traversing given directory path. -- -- For example, with @wai-static-app@ this can be used as: -- -- @ -- staticApp $ embeddedSettings $('embedRecursiveDir' "static") -- -- is an embedded (no data-files!) equivalent of -- staticApp $ defaultFileServerSettings "static" -- @ -- -- -- >>> $(embedRecursiveDir "example") -- [("/Example.hs","..."),("/example.txt","Hello from the inside.\n")] -- -- >>> :t $(embedRecursiveDir "example") -- $(embedRecursiveDir "example") :: [(FilePath, BS.ByteString)] -- embedRecursiveDir :: FilePath -> Q Exp embedRecursiveDir topdir = do pairs' <- runIO $ listRecursiveDirectoryFiles topdir for_ pairs' $ qAddDependentFile . fst let pairs = sort (makeAllRelative topdir pairs') embedPairs pairs ------------------------------------------------------------------------------- -- Strings ------------------------------------------------------------------------------- -- | Embed a lazy 'Data.ByteString.Lazy.ByteString' from a file. -- -- >>> :t $(embedLazyByteString "file-embed-lzma.cabal") -- $(embedLazyByteString "file-embed-lzma.cabal") :: LBS.ByteString -- embedLazyByteString :: FilePath -> Q Exp embedLazyByteString fp = do qAddDependentFile fp bsl <- runIO $ LBS.readFile fp lazyBytestringE bsl -- | Embed a strict 'Data.ByteString.ByteString' from a file. -- -- >>> :t $(embedByteString "file-embed-lzma.cabal") -- $(embedByteString "file-embed-lzma.cabal") :: BS.ByteString -- embedByteString :: FilePath -> Q Exp embedByteString fp = [| LBS.toStrict |] `appE` embedLazyByteString fp -- | Embed a lazy 'Data.Text.Lazy.Text' from a UTF8-encoded file. -- -- >>> :t $(embedLazyText "file-embed-lzma.cabal") -- $(embedLazyText "file-embed-lzma.cabal") :: LT.Text -- embedLazyText :: FilePath -> Q Exp embedLazyText fp = do qAddDependentFile fp bsl <- runIO $ LBS.readFile fp case LTE.decodeUtf8' bsl of Left e -> reportError (show e) Right _ -> return () [| LTE.decodeUtf8 |] `appE` lazyBytestringE bsl -- | Embed a strict 'Data.Text.Text' from a UTF8-encoded file. -- -- >>> :t $(embedText "file-embed-lzma.cabal") -- $(embedText "file-embed-lzma.cabal") :: T.Text -- embedText :: FilePath -> Q Exp embedText fp = [| LT.toStrict |] `appE` embedLazyText fp