diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for file-embed-lzma + +## 0 + +- First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Oleg Grenrus + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Example.hs b/example/Example.hs new file mode 100644 --- /dev/null +++ b/example/Example.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main (main) where + +import Data.Foldable (for_) +import FileEmbedLzma (embedByteString, embedRecursiveDir) + +import qualified Data.ByteString as BS + +main :: IO () +main = do + BS.putStr $(embedByteString "example/example.txt") + for_ $(embedRecursiveDir "src") $ \(n, bs) -> + print (n, BS.length bs) diff --git a/example/example.txt b/example/example.txt new file mode 100644 --- /dev/null +++ b/example/example.txt @@ -0,0 +1,1 @@ +Hello from the inside. diff --git a/file-embed-lzma.cabal b/file-embed-lzma.cabal new file mode 100644 --- /dev/null +++ b/file-embed-lzma.cabal @@ -0,0 +1,71 @@ +cabal-version: 2.0 +name: file-embed-lzma +version: 0 + +synopsis: Use Template Haskell to embed (LZMA compressed) data. +description: + The @file-embed@ package let's embed file and dir contents. + . + This package is similar, but also compresses the embedded contents with LZMA. + That makes resulting object files smaller, at the cost of start up decompression. + . + There's also an 'embedRecursiveDir' function. + +homepage: https://github.com/phadej/file-embed-lzma +bug-reports: https://github.com/phadej/file-embed-lzma/issues +license: BSD3 +license-file: LICENSE +author: Oleg Grenrus +maintainer: Oleg.Grenrus +copyright: (c) 2015-2018 Futurice, 2018 Oleg Grenrus +category: Data +build-type: Simple + +extra-source-files: ChangeLog.md example/example.txt + +tested-with: + GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.2, + GHC==8.2.2, + GHC==8.4.1 + +source-repository head + type: git + location: https://github.com/phadej/file-embed-lzma.git + +library + exposed-modules: + FileEmbedLzma + + -- GHC boot libraries + build-depends: + base >=4.7 && <4.12 + , base-compat >=0.9.3 && <0.10 + , template-haskell >=2.9 && <2.14 + , bytestring >=0.10.4.0 && <0.11 + , transformers >=0.3.0.0 && <0.6 + , directory >=1.2.1.0 && <1.4 + , filepath >=1.3.0.2 && <1.5 + , text >=1.2.3.0 && <1.3 + + -- non bundled dependencies + build-depends: + lzma ^>=0.0.0.3 + , th-lift-instances ^>=0.1.11 + + other-extensions: + OverloadedStrings + QuasiQuotes + TemplateHaskell + hs-source-dirs: src + default-language: Haskell2010 + +test-suite example + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Example.hs + hs-source-dirs: example + ghc-options: -Wall + build-depends: + base, file-embed-lzma, bytestring diff --git a/src/FileEmbedLzma.hs b/src/FileEmbedLzma.hs new file mode 100644 --- /dev/null +++ b/src/FileEmbedLzma.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +------------------------------------------------------------ +-- | +-- 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 Prelude () +import Prelude.Compat + +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 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 BSL +import qualified Data.ByteString.Unsafe as BS.Unsafe +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE + +import Instances.TH.Lift () + +listRecursiveDirectoryFiles :: FilePath -> IO [(FilePath, BSL.ByteString)] +listRecursiveDirectoryFiles = listDirectoryFilesF listRecursiveDirectoryFiles + +listDirectoryFiles :: FilePath -> IO [(FilePath, BSL.ByteString)] +listDirectoryFiles = listDirectoryFilesF (\_ -> return []) + +listDirectoryFilesF + :: (FilePath -> IO [(FilePath, BSL.ByteString)]) -- ^ what to do with a sub-directory + -> FilePath -> IO [(FilePath, BSL.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 <- BSL.readFile path + return [(path, contents)] + return (concat paths) + +makeAllRelative :: FilePath -> [(FilePath, a)] -> [(FilePath, a)] +makeAllRelative topdir = map (first (("/" ++) . makeRelative topdir)) + +-- | Makes lazy 'BSL.ByteString' expression. +-- Embedded value is compressed with LZMA. +lazyBytestringE :: BSL.ByteString -> Q Exp +lazyBytestringE lbs = + [| LZMA.decompress + $ BSL.fromStrict + $ unsafePerformIO + $ BS.Unsafe.unsafePackAddressLen $l $s + :: BSL.ByteString + |] + where + bs = BSL.toStrict $ LZMA.compressWith params lbs + s = litE $ stringPrimL $ BS.unpack bs + l = litE $ integerL $ fromIntegral $ BS.length bs + + params = LZMA.defaultCompressParams + {- doesn't seem to affect much + { LZMA.compressLevel = LZMA.CompressionLevel9 + , LZMA.compressLevelExtreme = True + } + -} + +makeEmbeddedEntry :: Name -> (FilePath, (Int64, Int64)) -> Q Exp +makeEmbeddedEntry name (path, (off, len)) = + [| (path, BSL.toStrict $ BSL.take len $ BSL.drop off $(varE name)) |] + +concatEntries :: Traversable t => t BSL.ByteString -> (BSL.ByteString, t (Int64, Int64)) +concatEntries xs = (bslEndo BSL.empty, ys) + where + (ys, (_, bslEndo)) = runState (traverse (state . single) xs) (0, id) + + single + :: BSL.ByteString -- file bytestring + -> (Int64, BSL.ByteString -> BSL.ByteString) -- current offset, buffer so far + -> ((Int64, Int64), (Int64, BSL.ByteString -> BSL.ByteString)) + single bsl (off, endo) = ((off, l), (off + l, endo . BSL.append bsl)) + where + l = fromIntegral $ BSL.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, BSL.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 :: FilePath -> Q Exp +embedRecursiveDir topdir = do + pairs' <- runIO $ listRecursiveDirectoryFiles topdir + for_ pairs' $ qAddDependentFile . fst + let pairs = makeAllRelative topdir pairs' + embedPairs pairs + +------------------------------------------------------------------------------- +-- Strings +------------------------------------------------------------------------------- + +-- | Embed a lazy 'Data.ByteString.Lazy.ByteString' from a file. +embedLazyByteString :: FilePath -> Q Exp +embedLazyByteString fp = do + qAddDependentFile fp + bsl <- runIO $ BSL.readFile fp + lazyBytestringE bsl + +-- | Embed a strict 'Data.ByteString.ByteString' from a file. +embedByteString :: FilePath -> Q Exp +embedByteString fp = [| BSL.toStrict $(embedLazyByteString fp) :: BS.ByteString |] + +-- | Embed a lazy 'Data.Text.Lazy.Text' from a UTF8-encoded file. +embedLazyText :: FilePath -> Q Exp +embedLazyText fp = do + qAddDependentFile fp + bsl <- runIO $ BSL.readFile fp + case TLE.decodeUtf8' bsl of + Left e -> reportError (show e) + Right _ -> return () + [| TLE.decodeUtf8 $ $(lazyBytestringE bsl) :: TL.Text |] + +-- | Embed a strict 'Data.Text.Text' from a UTF8-encoded file. +embedText :: FilePath -> Q Exp +embedText fp = [| TL.toStrict $(embedLazyText fp) :: T.Text |]