diff --git a/Data/Embed.hs b/Data/Embed.hs new file mode 100644 --- /dev/null +++ b/Data/Embed.hs @@ -0,0 +1,41 @@ +-- | This module provides access to files bundled with the current executable. +-- To bundle files within an executable, use the accompanying @embedtool@ +-- command line tool, or the functions provided in "Data.Embed.File". +-- +-- To embed a directory of data files with an executable, try: +-- +-- > embedtool -p1 -w my_executable my_data_dir +module Data.Embed where +import qualified Data.ByteString as BS +import System.IO.Unsafe +import System.Environment.Executable +import Data.Embed.File + +{-# NOINLINE myBundle #-} +-- | Handle to this application's embedded file bundle. +-- Throws an error upon evaluation if the application has none. +myBundle :: Bundle +myBundle = + case unsafePerformIO (getExecutablePath >>= openBundle) of + Right b -> b + Left e -> error $ "couldn't open executable's bundle: " ++ e + +-- | Returns the specified embedded file, or Nothing if it does not exist or +-- this executable has no embedded file bundle. +embeddedFile :: FilePath -> Maybe BS.ByteString +embeddedFile fp = + case theFile of + Right bytes -> Just bytes + _ -> Nothing + where + theFile = unsafePerformIO $ do + eb <- getExecutablePath >>= openBundle + case eb of + Right b -> readBundleFile b fp + Left e -> return (Left e) + +-- | Like 'embeddedFile', but throws an error if the given file does not exist +-- in the executable's embedded file bundle. +embeddedFile' :: FilePath -> BS.ByteString +embeddedFile' fp = + maybe (error $ "no such embedded file: `" ++ fp ++ "'") id $ embeddedFile fp diff --git a/Data/Embed/File.hs b/Data/Embed/File.hs new file mode 100644 --- /dev/null +++ b/Data/Embed/File.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE RecordWildCards #-} +-- | Reading/writing bundles of embedded files and other data from/to +-- executables. +-- +-- A bundle has three parts: the static header, which identifies +-- a string of bytes as a bundle using a particular version of the format +-- and gives the size of the dynamic header; the dynamic header which +-- describes all files and directories contained in the bundle; and the data +-- part, where the data for all files is located. +-- All words are stored in little endian format. +-- +-- The static header comprises the last 'bundleHeaderStaticSize' bytes of the +-- file, with the dynamic header coming immediately before, and the data +-- section coming immediately before the dynamic header. +-- +-- The dynamic header is stored as a tuple of the number of files in the +-- bundle (Word32), and the . +-- Each file is stored as a triple of the file's UTF-8 encoded path, +-- its offset from the start of the data section, and its size. +-- The path is prepended with a Word32 giving its length in bytes; the +-- offset is given as a Word32 and the size is given as a Word32. +-- +-- The layout of the bundle format is given in the following table: +-- +-- > [file data] +-- > +-- > [files] * hdrNumFiles +-- > pathLen : Word32 +-- > path : pathLen * Word8 +-- > offset : Word64 +-- > size : Word32 +-- > +-- > [static header] +-- > hdrDataOffset : Word64 +-- > hdrNumFiles : Word32 +-- > hdrDynSize : Word32 +-- > hdrVersion : Word8 +-- > "BNDLLDNB" : Word64 +-- +-- The included @embedtool@ program offers a command line interface +-- for manipulating and inspecting bundles. +module Data.Embed.File ( + Bundle, + + -- * Reading bundles + hasBundle, openBundle, withBundle, closeBundle, readBundleFile, readBundle, + listBundleFiles, + + -- * Creating bundles + File (..), appendBundle, eraseBundle, replaceBundle + ) where +import Control.Concurrent +import Control.Exception +import Control.Monad +import qualified Data.ByteString as BS +import Data.Hashable +import qualified Data.IntMap as M +import Data.Serialize +import Data.String +import System.Directory +import System.IO +import Data.Embed.Header + +-- | A file to be included in a bundle. May be either the path to a file on +-- disk or an actual (path, data) pair. +-- +-- If a file path refers to a directory, all non-dotfile files and +-- subdirectories of that directory will be included in the bundle. +-- File paths also have a strip number: the number of leading directories +-- to strip from file names when adding them to a bundle. +-- For instance, adding @File 1 "foo/bar"@ to a bundle will add the file +-- @foo/bar@, under the name @bar@ within the bundle. +-- +-- If a file name would "disappear" entirely due to stripping, for instance +-- when stripping two directories from @foo/bar@, @bar@ will "disappear" +-- entirely and so will be silently ignored. +data File = FilePath Int FilePath | FileData FilePath BS.ByteString + +instance IsString File where + fromString = FilePath 0 + +-- | A handle to a file bundle. Bundle handles are obtained using 'openBundle' +-- or 'withBundle' and start out as open. That is, files may be read from +-- them. An open bundle contains an open file handle to the bundle's backing +-- file, ensuring that the file data will not disappear from under it. +-- When a bundle becomes unreachable, its corresponding file handle is +-- closed by the bundle's associated finalizer. +-- +-- However, as finalizers are not guaranteed to run promptly - or even +-- at all - bundles may also be closed before becoming unreachable using +-- 'closeBundle'. If you expect to perform other operations on a bundle's +-- backing file, you should always close the bundle manually first. +data Bundle = Bundle { + -- | The header of the bundle. + bundleHeader :: !BundleHeader, + + -- | An open handle to the bundle's file, for reading file data. + bundleHandle :: !Handle, + + -- | The offset from the end of the file to the start of the data section. + bundleDataOffset :: !Integer, + + -- | Lock to ensure thread safety of read/close operations. Iff 'True', then + -- the bundle is still alive, i.e. the handle is still open. + bundleLock :: !(MVar Bool) + } + +-- | Read a bundle static header from the end of a file. +readStaticHeader :: Handle -> IO (Either String StaticHeader) +readStaticHeader hdl = do + hSeek hdl SeekFromEnd (negate bundleHeaderStaticSize) + ehdr <- decode <$> BS.hGet hdl (fromInteger bundleHeaderStaticSize) + case ehdr of + Left e -> + pure (Left $ "unable to parse static header: " ++ e) + Right hdr + | hdrMagicNumber hdr /= bundleMagicNumber -> + pure (Left "not a bundle") + | hdrVersion hdr > bundleCurrentVersion -> + pure (Left "unsupported bundle version") + | otherwise -> + pure (Right hdr) + +-- | Open a file bundle. The bundle will keep an open handle to its backing +-- file. The handle will be closed when the bundle is garbage collected. +-- Use 'closeBundle' to close the handle before the +openBundle :: FilePath -> IO (Either String Bundle) +openBundle fp = flip catch (\(SomeException e) -> pure (Left $ show e)) $ do + -- Read static header + hdl <- openBinaryFile fp ReadMode + ehdr <- readStaticHeader hdl + case ehdr of + Left err -> pure (Left err) + Right statichdr -> do + -- Read dynamic header + let dynsize = fromIntegral (hdrDynSize statichdr) + dynoffset = bundleHeaderStaticSize + dynsize + hSeek hdl SeekFromEnd (negate dynoffset) + bytes <- BS.hGet hdl (fromInteger dynsize) + + -- Parse dynamic header and create bundle + case runGet (getHdrFiles (hdrNumFiles statichdr)) bytes of + Left e -> fail $ "unable to parse file list: " ++ e + Right filehdr -> do + let hdr = BundleHeader { + hdrFiles = filehdr, + hdrStatic = statichdr + } + lock <- newMVar True + let b = Bundle hdr hdl (fromIntegral (hdrDataOffset statichdr)) lock + _ <- mkWeakMVar lock (closeBundle b) + pure $! Right $! b + +-- | Close a bundle before it becomes unreachable. After a bundle is closed, +-- any read operations performed on it will fail as though the requested +-- file could not be found. +-- Subsequent close operations on it will have no effect. +closeBundle :: Bundle -> IO () +closeBundle b = do + alive <- takeMVar (bundleLock b) + when alive $ hClose (bundleHandle b) + putMVar (bundleLock b) False + +-- | Perform a computation over a bundle, returning an error if either the +-- computation failed or the bundle could not be loaded. +-- The bundle is always closed before this function returns, regardless of +-- whether an error occurred. +withBundle :: FilePath -> (Bundle -> IO a) -> IO (Either String a) +withBundle fp f = do + eb <- openBundle fp + case eb of + Right b -> fmap Right (f b) `catch` handler <* closeBundle b + Left e -> return (Left e) + where + handler (SomeException e) = pure (Left $ show e) + +-- | Write a bundle to a file. If the given file already has a bundle, the new +-- bundle will be written *after* the old one. The old bundle will thus still +-- be present in the file, but only the new one will be recognized by +-- 'openBundle' and friends. +appendBundle :: FilePath -> [File] -> IO () +appendBundle fp fs = withBinaryFile fp AppendMode $ \hdl -> do + (datasize, metadata) <- foldM (packFile hdl) (0, M.empty) fs + let mdbytes = putHdrFiles metadata + mdlen = BS.length mdbytes + dataoff = datasize + fromIntegral mdlen + + fromIntegral bundleHeaderStaticSize + hdr = mkStaticHdr (M.size metadata) mdlen dataoff + BS.hPut hdl mdbytes + BS.hPut hdl (encode hdr) + where + isDotFile ('.':_) = True + isDotFile _ = False + + p f = p ++ "/" ++ f + + stripLeading 0 f = f + stripLeading n f = stripLeading (n-1) (drop 1 (dropWhile (/= '/') f)) + + packFile hdl acc (FilePath n p) = do + let stripped = stripLeading n p + if null stripped + then return acc + else do + isDir <- doesDirectoryExist p + if isDir + then do + files <- filter (not . isDotFile) <$> getDirectoryContents p + foldM (packFile hdl) acc (map (FilePath n . (p )) files) + else BS.readFile p >>= packFile hdl acc . FileData stripped + packFile hdl (off, m) (FileData p d) = do + BS.hPut hdl d + let len = fromIntegral (BS.length d) + off' = off + fromIntegral len + off' `seq` return (off', (M.alter (ins p off len) (hash p) m)) + + ins p off len Nothing = Just [(p, (off, len))] + ins p off len (Just xs) = Just ((p, (off, len)) : xs) + +-- | Read a file from a previously opened bundle. Will fail of the given path +-- is not found within the bundle, or if the bundle is no longer alive, i.e. +-- it has been closed using 'closeBundle'. +readBundleFile :: Bundle -> FilePath -> IO (Either String BS.ByteString) +readBundleFile (Bundle {..}) fp = + flip catch (\(SomeException e) -> pure (Left $ show e)) $ do + withMVar bundleLock $ \v -> do + when (v == False) $ fail "bundle already closed" + case M.lookup (hash fp) (hdrFiles bundleHeader) >>= lookup fp of + Nothing -> fail "no such file" + Just (off, sz) -> do + hSeek bundleHandle SeekFromEnd (fromIntegral off - bundleDataOffset) + Right <$> BS.hGet bundleHandle (fromIntegral sz) + +-- | List all files in the given bundle. Will succeed even on closed bundles. +listBundleFiles :: Bundle -> [FilePath] +listBundleFiles = map fst . concat . M.elems . hdrFiles . bundleHeader + +-- | Like 'readBundleFile', but attempts to decode the file's contents into an +-- appropriate Haskell value. +readBundle :: Serialize a => Bundle -> FilePath -> IO (Either String a) +readBundle b fp = do + ebytes <- readBundleFile b fp + pure (ebytes >>= decode) + +-- | Does the given file contain a bundle or not? +hasBundle :: FilePath -> IO Bool +hasBundle fp = do + ehdr <- withBinaryFile fp ReadMode readStaticHeader + case ehdr of + Right _ -> pure True + _ -> pure False + +-- | Remove a bundle from an existing file. Does nothing if the given file +-- does not have a bundle. The given file is *not* removed, even if it only +-- contains the bundle. +eraseBundle :: FilePath -> IO () +eraseBundle fp = do + withBinaryFile fp ReadWriteMode $ \hdl -> do + ehdr <- readStaticHeader hdl + case ehdr of + Right hdr -> do + sz <- hFileSize hdl + hSetFileSize hdl (sz - fromIntegral (hdrDataOffset hdr)) + _ -> return () + +-- | Replace the bundle currently attached to the given file. Equivalent to +-- 'appendBundle' if the given file does not already have a bundle attached. +replaceBundle :: FilePath -> [File] -> IO () +replaceBundle fp fs = eraseBundle fp >> appendBundle fp fs diff --git a/Data/Embed/Header.hs b/Data/Embed/Header.hs new file mode 100644 --- /dev/null +++ b/Data/Embed/Header.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE BangPatterns #-} +-- | The bundle data type, representing a binary bundle attached to an +-- executable. +module Data.Embed.Header where +import Control.Monad +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 +import Data.Hashable +import qualified Data.IntMap.Strict as M +import Data.Serialize +import Data.Word + +type FileMap = M.IntMap [(FilePath, (Word64, Word32))] + +-- | "Magic number" identifying a structure as a bundle header: "BNDLLDNB" +bundleMagicNumber :: Word64 +bundleMagicNumber = 0x424e444c4c444e42 -- "BNDLLDNB" + +-- | Current version of the bundle format. +bundleCurrentVersion :: Word8 +bundleCurrentVersion = 0 + +-- | Maximum file size of a file in the bundle. +bundleMaxFileSize :: Integer +bundleMaxFileSize = fromIntegral (maxBound :: Word32) + +-- | Size of the bundle's static header: two Word64 + two Word32 + one Word8. +bundleHeaderStaticSize :: Integer +bundleHeaderStaticSize = 25 + +-- | The static header of a file bundle. +data StaticHeader = StaticHeader { + -- | The offset from the end of the file to the beginning of the file data + -- section. + hdrDataOffset :: !Word64, + + -- | Total number of files in the bundle. + hdrNumFiles :: !Word32, + + -- | Size of the dynamic part of the header, where file names, offsets and + -- sizes are stored. + hdrDynSize :: !Word32, + + -- | Version of the bundle structure. Must always be less than or equal to + -- 'bundleCurrentVersion' + hdrVersion :: !Word8, + + -- | Magic number. Must always be 'bundleMagicNumber'. + hdrMagicNumber :: !Word64 + } + +-- | A file bundle header. Contains basic metadata about the bundle itself, and +-- the metadata for all files contained therein. +data BundleHeader = BundleHeader { + -- | A hash map from file paths to the respective offsets and sizes. + hdrFiles :: !FileMap, + + -- | Static part of the header. + hdrStatic :: !StaticHeader + } + +-- | Build a static header with the specified number of files, size of the +-- dynamic header, and offset to the start of the data section. +mkStaticHdr :: Int -> Int -> Word64 -> StaticHeader +mkStaticHdr nfiles dynsize dataoff = StaticHeader { + hdrVersion = bundleCurrentVersion, + hdrMagicNumber = bundleMagicNumber, + hdrNumFiles = fromIntegral nfiles, + hdrDynSize = fromIntegral dynsize, + hdrDataOffset = dataoff + } + +instance Serialize StaticHeader where + put hdr = do + putWord64le (hdrDataOffset hdr) + putWord32le (hdrNumFiles hdr) + putWord32le (hdrDynSize hdr) + putWord8 (hdrVersion hdr) + putWord64le (hdrMagicNumber hdr) + get = + StaticHeader <$> getWord64le + <*> getWord32le + <*> getWord32le + <*> getWord8 + <*> getWord64le + +getHdrFile :: Get (FilePath, (Word64, Word32)) +getHdrFile = do + pathlen <- getWord32le + path <- getBytes (fromIntegral pathlen) + off <- getWord64le + sz <- getWord32le + return (toString path, (off, sz)) + +getHdrFiles :: Word32 -> Get FileMap +getHdrFiles = getFiles M.empty + where + getFiles !m 0 = pure m + getFiles !m n = do + f <- getHdrFile + getFiles (M.alter (ins f) (hash $ fst f) m) (n-1) + ins f (Just fs) = Just (f:fs) + ins f _ = Just [f] + +putHdrFiles :: FileMap -> BS.ByteString +putHdrFiles m = runPut $ forM_ (concat $ M.elems m) $ \(p, (off, sz)) -> do + let p' = fromString p + putWord32le (fromIntegral $ BS.length p') + putByteString p' + putWord64le off + putWord32le sz diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Anton Ekblad + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 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/data-embed.cabal b/data-embed.cabal new file mode 100644 --- /dev/null +++ b/data-embed.cabal @@ -0,0 +1,56 @@ +name: data-embed +version: 0.1.0.0 +synopsis: Embed files and other binary blobs inside executables without Template Haskell. +description: This package provides a Template Haskell-free alternative to . It provides a versioned, well defined binary format for embedded blobs, as well as library support and command line utilities for manipulating them. +homepage: https://github.com/valderman/data-embed +license: MIT +license-file: LICENSE +author: Anton Ekblad +maintainer: anton@ekblad.cc +category: Data +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/valderman/data-embed.git + +executable embedtool + main-is: + embedtool.hs + build-depends: + base >=4.8 && <5, + cereal >=0.4 && <0.5, + bytestring >=0.10 && <0.11, + hashable >=1.2 && <1.3, + containers >=0.5 && <0.6, + utf8-string >=1.0 && <1.1, + directory >=1.2 && <1.3, + executable-path >=0.0.3 && <0.1 + default-language: + Haskell2010 + ghc-options: + -Wall + +library + exposed-modules: + Data.Embed, + Data.Embed.File + other-modules: + Data.Embed.Header + other-extensions: + RecordWildCards, + BangPatterns + build-depends: + base >=4.8 && <5, + cereal >=0.4 && <0.5, + bytestring >=0.10 && <0.11, + hashable >=1.2 && <1.3, + containers >=0.5 && <0.6, + utf8-string >=1.0 && <1.1, + directory >=1.2 && <1.3, + executable-path >=0.0.3 && <0.1 + default-language: + Haskell2010 + ghc-options: + -Wall diff --git a/embedtool.hs b/embedtool.hs new file mode 100644 --- /dev/null +++ b/embedtool.hs @@ -0,0 +1,134 @@ +-- | Main module for @embedtool@, a command line interface to @data-embed@. +module Main where +import Control.Monad +import Data.Embed.File +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO + +data Overwrite = Append | Replace | DontOverwrite + deriving Show + +data Option + = Write -- Write a bundle to an executable + | Erase -- Erase an existing bundle + | Check -- Check if a file contains a bundle or not + | List -- List all files in a bundle + | PrintHelp -- Print help message and exit + | PrintUsage -- Print usage message and exit + | SetOverwrite Overwrite -- Set overwrite mode + | SetStrip Int -- Set the number of leading directories to strip + -- from file names added to bundle + deriving Show + +optspec :: [OptDescr Option] +optspec = + [ Option "w" ["write"] (NoArg Write) $ + "Write a bundle to a file. Do nothing if the file already has a bundle." + , Option "r" ["replace"] (NoArg (SetOverwrite Replace)) $ + "When writing a bundle to a file, overwrite any previously existing " ++ + "bundle." + , Option "a" ["append"] (NoArg (SetOverwrite Append)) $ + "When writing a bundle to a file, leave the old one in place but " ++ + "append the new one at the end of the file." + , Option "p" ["strip"] (ReqArg (SetStrip . read) "NUM") $ + "Strip up to NUM leading directories from file names added to bundle.\n" ++ + "`embedtool -p1 -w outfile dir/infile' will add `dir/infile' to the " ++ + "bundle with the name `infile'." + , Option "ed" ["erase"] (NoArg Erase) $ + "Erase previously created bundles from any of the given files." + , Option "l" ["list"] (NoArg List) $ + "List all files in the given bundle." + , Option "c" ["check"] (NoArg Check) $ + "Check whether the given file contains a bundle or not." + , Option "?h" ["help"] (NoArg PrintHelp) $ + "Print this message and exit." + ] + +helpHeader :: String +helpHeader = concat + [ "embedtool creates, modifies and inspects file bundles for use with the " + , "`data-bundle' library. It accepts the following options:" + ] + +main :: IO () +main = do + args <- getArgs + case getOpt Permute optspec args of + (opts, nonopts, []) -> runAct (getAction opts) (writeOpts opts) nonopts + (_, _, errs) -> mapM_ (hPutStr stderr) errs >> exitFailure + +-- | Extract write options from the given list of options. +writeOpts :: [Option] -> (Overwrite, Int) +writeOpts = foldl writeOpt (DontOverwrite, 0) + where + writeOpt (_, s) (SetOverwrite ovr) = (ovr, s) + writeOpt (ovr, _) (SetStrip s) = (ovr, s) + writeOpt acc _ = acc + +-- | Get the action to perform from the given list of options. +getAction :: [Option] -> Option +getAction = foldl getAct PrintUsage + where + getAct acc (SetOverwrite _) = acc + getAct acc (SetStrip _) = acc + getAct _ act = act + +runAct :: Option -> (Overwrite, Int) -> [String] -> IO () +runAct Write (ovr, s) fs = do + case fs of + (outf : infs) | not (null infs) -> do + alreadyHasBundle <- hasBundle outf + when alreadyHasBundle $ do + case ovr of + DontOverwrite -> do + hPutStrLn stderr $ "file `" ++ outf ++ "' already has a " ++ + "bundle; aborting" + exitFailure + Replace -> + eraseBundle outf + _ -> + return () + appendBundle outf (map (FilePath s) infs) + _ -> do + hPutStrLn stderr $ "need an output file and at least one input file " ++ + "to create a bundle" + hPutStrLn stderr $ "try `embedtool -w outfile infile1 [infile2 ...]'" + exitFailure +runAct Erase _ outfs = do + when (null outfs) $ do + hPutStrLn stderr $ "need at least one file to erase bundle from" + hPutStrLn stderr $ "try `embedtool -e file1 [file2 ...]'" + exitFailure + mapM_ eraseBundle outfs +runAct Check _ infs = do + case infs of + [inf] -> do + ok <- hasBundle inf + putStrLn $ if ok then "yes" else "no" + _ -> do + hPutStrLn stderr $ "need exactly one file to check for bundles" + hPutStrLn stderr $ "try `embedtool -c file'" + exitFailure +runAct List _ infs = do + case infs of + [inf] -> do + res <- withBundle inf (mapM_ putStrLn . listBundleFiles) + case res of + Right _ -> return () + Left e -> do + hPutStrLn stderr $ "failed to read bundle: " ++ e + exitFailure + _ -> do + hPutStrLn stderr $ "need exactly one file to list files from" + hPutStrLn stderr $ "try `embedtool -l file'" + exitFailure +runAct PrintHelp _ _ = do + putStr $ usageInfo helpHeader optspec +runAct PrintUsage _ _ = do + putStrLn "usage: embedtool OPTIONS FILE [FILES]" + putStrLn "try `embedtool --help' for more information" + exitFailure +runAct opt _ _ = do + error $ "BUG: option `" ++ show opt ++ "' is not an action!"