diff --git a/Codec/Archive/Tar.hs b/Codec/Archive/Tar.hs --- a/Codec/Archive/Tar.hs +++ b/Codec/Archive/Tar.hs @@ -47,6 +47,7 @@ -- * High level \"all in one\" operations create, extract, + append, -- * Notes -- ** Compressed tar archives @@ -146,11 +147,13 @@ import Codec.Archive.Tar.Pack import Codec.Archive.Tar.Unpack +import Codec.Archive.Tar.Index (hSeekEndEntryOffset) import Codec.Archive.Tar.Check import Control.Exception (Exception, throw, catch) import qualified Data.ByteString.Lazy as BS +import System.IO (withFile, IOMode(..)) import Prelude hiding (read) -- | Create a new @\".tar\"@ file from a directory of files. @@ -222,3 +225,19 @@ -> FilePath -- ^ Tarball -> IO () extract dir tar = unpack dir . read =<< BS.readFile tar + +-- | Append new entries to a @\".tar\"@ file from a directory of files. +-- +-- This is much like 'create', except that all the entries are added to the +-- end of an existing tar file. Or if the file does not already exists then +-- it behaves the same as 'create'. +-- +append :: FilePath -- ^ Path of the \".tar\" file to write. + -> FilePath -- ^ Base directory + -> [FilePath] -- ^ Files and directories to archive, relative to base dir + -> IO () +append tar base paths = + withFile tar ReadWriteMode $ \hnd -> do + _ <- hSeekEndEntryOffset hnd Nothing + BS.hPut hnd . write =<< pack base paths + diff --git a/Codec/Archive/Tar/Check.hs b/Codec/Archive/Tar/Check.hs --- a/Codec/Archive/Tar/Check.hs +++ b/Codec/Archive/Tar/Check.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar diff --git a/Codec/Archive/Tar/Index.hs b/Codec/Archive/Tar/Index.hs new file mode 100644 --- /dev/null +++ b/Codec/Archive/Tar/Index.hs @@ -0,0 +1,603 @@ +{-# LANGUAGE CPP, BangPatterns, PatternGuards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Archive.Tar.Index +-- Copyright : (c) 2010-2015 Duncan Coutts +-- License : BSD3 +-- +-- Maintainer : duncan@community.haskell.org +-- Portability : portable +-- +-- Random access to the content of a @.tar@ archive. +-- +-- This module uses common names and so is designed to be imported qualified: +-- +-- > import qualified Codec.Archive.Tar.Index as Tar +-- +----------------------------------------------------------------------------- +module Codec.Archive.Tar.Index ( + + -- | The @tar@ format does not contain an index of files within the + -- archive. Normally, @tar@ file have to be processed linearly. It is + -- sometimes useful however to be able to get random access to files + -- within the archive. + -- + -- This module provides an index of a @tar@ file. A linear pass of the + -- @tar@ file is needed to 'build' the 'TarIndex', but thereafter you can + -- 'lookup' paths in the @tar@ file, and then use 'hReadEntry' to + -- seek to the right part of the file and read the entry. + + -- * Index type + TarIndex, + + -- * Index lookup + lookup, + TarIndexEntry(..), + + -- ** I\/O operations + TarEntryOffset, + hReadEntry, + hReadEntryHeader, + + -- * Index construction + build, + -- ** Incremental construction + -- $incremental-construction + IndexBuilder, + emptyIndex, + addNextEntry, + skipNextEntry, + finaliseIndex, + + -- * Serialising indexes + serialise, + deserialise, + + -- * Lower level operations with offsets and I\/O on tar files + hReadEntryHeaderOrEof, + hSeekEntryOffset, + hSeekEntryContentOffset, + hSeekEndEntryOffset, + nextEntryOffset, + indexEndEntryOffset, + indexNextEntryOffset, + +#ifdef TESTS + prop_lookup, + prop_valid, +#endif + ) where + +import Data.Typeable (Typeable) + +import Codec.Archive.Tar.Types as Tar +import Codec.Archive.Tar.Read as Tar +import qualified Codec.Archive.Tar.Index.StringTable as StringTable +import Codec.Archive.Tar.Index.StringTable (StringTable(..)) +import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie +import Codec.Archive.Tar.Index.IntTrie (IntTrie(..)) + +import qualified System.FilePath.Posix as FilePath +import Data.Monoid (Monoid(..)) +#if (MIN_VERSION_base(4,5,0)) +import Data.Monoid ((<>)) +#endif +import Data.Word +import Data.Int +import Data.Bits +import qualified Data.Array.Unboxed as A +import Prelude hiding (lookup) +import System.IO +import Control.Exception (throwIO) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +#if MIN_VERSION_bytestring(0,10,2) +import Data.ByteString.Builder as BS +#else +import Data.ByteString.Lazy.Builder as BS +#endif + +#ifdef TESTS +import qualified Prelude +import Test.QuickCheck +import Control.Applicative ((<$>), (<*>)) +#endif + + +-- | An index of the entries in a tar file. +-- +-- This index type is designed to be quite compact and suitable to store either +-- on disk or in memory. +-- +data TarIndex = TarIndex + + -- As an example of how the mapping works, consider these example files: + -- "foo/bar.hs" at offset 0 + -- "foo/baz.hs" at offset 1024 + -- + -- We split the paths into components and enumerate them. + -- { "foo" -> TokenId 0, "bar.hs" -> TokenId 1, "baz.hs" -> TokenId 2 } + -- + -- We convert paths into sequences of 'TokenId's, i.e. + -- "foo/bar.hs" becomes [PathComponentId 0, PathComponentId 1] + -- "foo/baz.hs" becomes [PathComponentId 0, PathComponentId 2] + -- + -- We use a trie mapping sequences of 'PathComponentId's to the entry offset: + -- { [PathComponentId 0, PathComponentId 1] -> offset 0 + -- , [PathComponentId 0, PathComponentId 2] -> offset 1024 } + + -- The mapping of filepath components as strings to ids. + {-# UNPACK #-} !(StringTable PathComponentId) + + -- Mapping of sequences of filepath component ids to tar entry offsets. + {-# UNPACK #-} !(IntTrie PathComponentId TarEntryOffset) + + -- The offset immediatly after the last entry, where we would append any + -- additional entries. + {-# UNPACK #-} !TarEntryOffset + + deriving (Eq, Show, Typeable) + +-- | The result of 'lookup' in a 'TarIndex'. It can either be a file directly, +-- or a directory entry containing further entries (and all subdirectories +-- recursively). Note that the subtrees are constructed lazily, so it's +-- cheaper if you don't look at them. +-- +data TarIndexEntry = TarFileEntry {-# UNPACK #-} !TarEntryOffset + | TarDir [(FilePath, TarIndexEntry)] + deriving (Show, Typeable) + + +newtype PathComponentId = PathComponentId Int + deriving (Eq, Ord, Enum, Show, Typeable) + +-- | An offset within a tar file. Use 'hReadEntry', 'hReadEntryHeader' or +-- 'hSeekEntryOffset'. +-- +-- This is actually a tar \"record\" number, not a byte offset. +-- +type TarEntryOffset = Word32 + + +-- | Look up a given filepath in the 'TarIndex'. It may return a 'TarFileEntry' +-- containing the 'TarEntryOffset' of the file within the tar file, or if +-- the filepath identifies a directory then it returns a 'TarDir' containing +-- the list of files within that directory. +-- +-- Given the 'TarEntryOffset' you can then use one of the I\/O operations: +-- +-- * 'hReadEntry' to read the whole entry; +-- +-- * 'hReadEntryHeader' to read just the file metadata (e.g. its length); +-- +lookup :: TarIndex -> FilePath -> Maybe TarIndexEntry +lookup (TarIndex pathTable pathTrie _) path = do + fpath <- toComponentIds pathTable path + tentry <- IntTrie.lookup pathTrie fpath + return (mkIndexEntry tentry) + where + mkIndexEntry (IntTrie.Entry offset) = TarFileEntry offset + mkIndexEntry (IntTrie.Completions entries) = + TarDir [ (fromComponentId pathTable key, mkIndexEntry entry) + | (key, entry) <- entries ] + + +toComponentIds :: StringTable PathComponentId -> FilePath -> Maybe [PathComponentId] +toComponentIds table = + lookupComponents [] + . filter (/= ".") + . FilePath.splitDirectories + where + lookupComponents cs' [] = Just (reverse cs') + lookupComponents cs' (c:cs) = case StringTable.lookup table c of + Nothing -> Nothing + Just cid -> lookupComponents (cid:cs') cs + +fromComponentId :: StringTable PathComponentId -> PathComponentId -> FilePath +fromComponentId table = StringTable.index table + + +-- | Build a 'TarIndex' from a sequence of tar 'Entries'. The 'Entries' are +-- assumed to start at offset @0@ within a file. +-- +build :: Entries e -> Either e TarIndex +build = go emptyIndex + where + go !builder (Next e es) = go (addNextEntry e builder) es + go !builder Done = Right $! finaliseIndex builder + go !_ (Fail err) = Left err + + +-- $incremental-construction +-- If you need more control than 'build' then you can construct the index +-- in an acumulator style using the 'IndexBuilder' and operations. +-- +-- Start with the 'emptyIndex' and use 'addNextEntry' (or 'skipNextEntry') for +-- each 'Entry' in the tar file in order. Every entry must added or skipped in +-- order, otherwise the resulting 'TarIndex' will report the wrong +-- 'TarEntryOffset's. At the end use 'finaliseIndex' to get the 'TarIndex'. +-- +-- For example, 'build' is simply: +-- +-- > build = go emptyIndex +-- > where +-- > go !builder (Next e es) = go (addNextEntry e builder) es +-- > go !builder Done = Right $! finaliseIndex builder +-- > go !_ (Fail err) = Left err + + +-- | The intermediate type used for incremental construction of a 'TarIndex'. +-- +data IndexBuilder = IndexBuilder [(FilePath, TarEntryOffset)] + {-# UNPACK #-} !TarEntryOffset + +-- | The initial empty 'IndexBuilder'. +-- +emptyIndex :: IndexBuilder +emptyIndex = IndexBuilder [] 0 + +-- | Add the next 'Entry' into the 'IndexBuilder'. +-- +addNextEntry :: Entry -> IndexBuilder -> IndexBuilder +addNextEntry entry (IndexBuilder acc nextOffset) = + IndexBuilder ((entrypath, nextOffset):acc) + (nextEntryOffset entry nextOffset) + where + !entrypath = entryPath entry + +-- | Use this function if you want to skip some entries and not add them to the +-- final 'TarIndex'. +-- +skipNextEntry :: Entry -> IndexBuilder -> IndexBuilder +skipNextEntry entry (IndexBuilder acc nextOffset) = + IndexBuilder acc (nextEntryOffset entry nextOffset) + +-- | Finish accumulating 'Entry' information and build the compact 'TarIndex' +-- lookup structure. +-- +finaliseIndex :: IndexBuilder -> TarIndex +finaliseIndex (IndexBuilder pathsOffsets finalOffset) = + TarIndex pathTable pathTrie finalOffset + where + pathComponents = concatMap (FilePath.splitDirectories . fst) pathsOffsets + pathTable = StringTable.construct pathComponents + pathTrie = IntTrie.construct + [ (cids, offset) + | (path, offset) <- pathsOffsets + , let Just cids = toComponentIds pathTable path ] + +-- | This is the offset immediately following the entry most recently added +-- to the 'IndexBuilder'. You might use this if you need to know the offsets +-- but don't want to use the 'TarIndex' lookup structure. +-- Use with 'hSeekEntryOffset'. See also 'nextEntryOffset'. +-- +indexNextEntryOffset :: IndexBuilder -> TarEntryOffset +indexNextEntryOffset (IndexBuilder _ off) = off + +-- | This is the offset immediately following the last entry in the tar file. +-- This can be useful to append further entries into the tar file. +-- Use with 'hSeekEntryOffset', or just use 'hSeekEndEntryOffset' directly. +-- +indexEndEntryOffset :: TarIndex -> TarEntryOffset +indexEndEntryOffset (TarIndex _ _ off) = off + +-- | Calculate the 'TarEntryOffset' of the next entry, given the size and +-- offset of the current entry. +-- +-- This is much like using 'skipNextEntry' and 'indexNextEntryOffset', but without +-- using an 'IndexBuilder'. +-- +nextEntryOffset :: Entry -> TarEntryOffset -> TarEntryOffset +nextEntryOffset entry offset = + offset + + 1 + + case entryContent entry of + NormalFile _ size -> blocks size + OtherEntryType _ _ size -> blocks size + _ -> 0 + where + blocks size = 1 + ((fromIntegral size - 1) `div` 512) + + +------------------------- +-- I/O operations +-- + +-- | Reads an entire 'Entry' at the given 'TarEntryOffset' in the tar file. +-- The 'Handle' must be open for reading and be seekable. +-- +-- This reads the whole entry into memory strictly, not incrementally. For more +-- control, use 'hReadEntryHeader' and then read the entry content manually. +-- +hReadEntry :: Handle -> TarEntryOffset -> IO Entry +hReadEntry hnd off = do + entry <- hReadEntryHeader hnd off + case entryContent entry of + NormalFile _ size -> do body <- LBS.hGet hnd (fromIntegral size) + return entry { + entryContent = NormalFile body size + } + OtherEntryType c _ size -> do body <- LBS.hGet hnd (fromIntegral size) + return entry { + entryContent = OtherEntryType c body size + } + _ -> return entry + +-- | Read the header for a 'Entry' at the given 'TarEntryOffset' in the tar +-- file. The 'entryContent' will contain the correct metadata but an empty file +-- content. The 'Handle' must be open for reading and be seekable. +-- +-- The 'Handle' position is advanced to the beginning of the entry content (if +-- any). You must check the 'entryContent' to see if the entry is of type +-- 'NormalFile'. If it is, the 'NormalFile' gives the content length and you +-- are free to read this much data from the 'Handle'. +-- +-- > entry <- Tar.hReadEntryHeader hnd +-- > case Tar.entryContent entry of +-- > Tar.NormalFile _ size -> do content <- BS.hGet hnd size +-- > ... +-- +-- Of course you don't have to read it all in one go (as 'hReadEntry' does), +-- you can use any appropriate method to read it incrementally. +-- +-- In addition to I\/O errors, this can throw a 'FormatError' if the offset is +-- wrong, or if the file is not valid tar format. +-- +-- There is also the lower level operation 'hSeekEntryOffset'. +-- +hReadEntryHeader :: Handle -> TarEntryOffset -> IO Entry +hReadEntryHeader hnd blockOff = do + hSeekEntryOffset hnd blockOff + header <- LBS.hGet hnd 512 + case Tar.read header of + Tar.Next entry _ -> return entry + Tar.Fail e -> throwIO e + Tar.Done -> fail "hReadEntryHeader: impossible" + +-- | Set the 'Handle' position to the position corresponding to the given +-- 'TarEntryOffset'. +-- +-- This position is where the entry metadata can be read. If you already know +-- the entry has a body (and perhaps know it's length), you may wish to seek to +-- the body content directly using 'hSeekEntryContentOffset'. +-- +hSeekEntryOffset :: Handle -> TarEntryOffset -> IO () +hSeekEntryOffset hnd blockOff = + hSeek hnd AbsoluteSeek (fromIntegral blockOff * 512) + +-- | Set the 'Handle' position to the entry content position corresponding to +-- the given 'TarEntryOffset'. +-- +-- This position is where the entry content can be read using ordinary I\/O +-- operations (though you have to know in advance how big the entry content +-- is). This is /only valid/ if you /already know/ the entry has a body (i.e. +-- is a normal file). +-- +hSeekEntryContentOffset :: Handle -> TarEntryOffset -> IO () +hSeekEntryContentOffset hnd blockOff = + hSeekEntryOffset hnd (blockOff + 1) + +-- | This is a low level variant on 'hReadEntryHeader', that can be used to +-- iterate through a tar file, entry by entry. +-- +-- It has a few differences compared to 'hReadEntryHeader': +-- +-- * It returns an indication when the end of the tar file is reached. +-- +-- * It /does not/ move the 'Handle' position to the beginning of the entry +-- content. +-- +-- * It returns the 'TarEntryOffset' of the next entry. +-- +-- After this action, the 'Handle' position is not in any useful place. If +-- you want to skip to the next entry, take the 'TarEntryOffset' returned and +-- use 'hReadEntryHeaderOrEof' again. Or if having inspected the 'Entry' +-- header you want to read the entry content (if it has one) then use +-- 'hSeekEntryContentOffset' on the original input 'TarEntryOffset'. +-- +hReadEntryHeaderOrEof :: Handle -> TarEntryOffset + -> IO (Maybe (Entry, TarEntryOffset)) +hReadEntryHeaderOrEof hnd blockOff = do + hSeekEntryOffset hnd blockOff + header <- LBS.hGet hnd 1024 + case Tar.read header of + Tar.Next entry _ -> let !blockOff' = nextEntryOffset entry blockOff + in return (Just (entry, blockOff')) + Tar.Done -> return Nothing + Tar.Fail e -> throwIO e + +-- | Seek to the end of a tar file, to the position where new entries can +-- be appended, and return that 'TarEntryOffset'. +-- +-- If you have a valid 'TarIndex' for this tar file then you should supply it +-- because it allows seeking directly to the correct location. +-- +-- If you do not have an index, then this becomes an expensive linear +-- operation because we have to read each tar entry header from the beginning +-- to find the location immediately after the last entry (this is because tar +-- files have a variable length trailer and we cannot reliably find that by +-- starting at the end). In this mode, it will fail with an exception if the +-- file is not in fact in the tar format. +-- +hSeekEndEntryOffset :: Handle -> Maybe TarIndex -> IO TarEntryOffset +hSeekEndEntryOffset hnd (Just index) = do + let offset = indexEndEntryOffset index + hSeekEntryOffset hnd offset + return offset + +hSeekEndEntryOffset hnd Nothing = do + size <- hFileSize hnd + if size == 0 + then return 0 + else seekToEnd 0 + where + seekToEnd offset = do + mbe <- hReadEntryHeaderOrEof hnd offset + case mbe of + Nothing -> do hSeekEntryOffset hnd offset + return offset + Just (_, offset') -> seekToEnd offset' + +------------------------- +-- (de)serialisation +-- + +-- | The 'TarIndex' is compact in memory, and it has a similarly compact +-- external representation. +-- +serialise :: TarIndex -> BS.Builder +serialise (TarIndex stringTable intTrie finalOffset) = + BS.word32BE 1 -- format version + <> BS.word32BE finalOffset + <> serialiseStringTable stringTable + <> serialiseIntTrie intTrie + +-- | Read the external representation back into a 'TarIndex'. +-- +deserialise :: BS.ByteString -> Maybe (TarIndex, BS.ByteString) +deserialise bs + | BS.length bs >= 8 + , let ver = readWord32BE bs 0 + , ver == 1 + = do let !finalOffset = readWord32BE bs 4 + (stringTable, bs') <- deserialiseStringTable (BS.drop 8 bs) + (intTrie, bs'') <- deserialiseIntTrie bs' + return (TarIndex stringTable intTrie finalOffset, bs'') + + | otherwise = Nothing + +serialiseIntTrie :: IntTrie k v -> BS.Builder +serialiseIntTrie (IntTrie arr) = + let (_, !ixEnd) = A.bounds arr in + BS.word32BE (ixEnd+1) + <> foldr (\n r -> BS.word32BE n <> r) mempty (A.elems arr) + +deserialiseIntTrie :: BS.ByteString -> Maybe (IntTrie k v, BS.ByteString) +deserialiseIntTrie bs + | BS.length bs >= 4 + , let lenArr = readWord32BE bs 0 + lenTotal = 4 + 4 * fromIntegral lenArr + , BS.length bs >= 4 + 4 * fromIntegral lenArr + , let !arr = A.array (0, lenArr-1) + [ (i, readWord32BE bs off) + | (i, off) <- zip [0..lenArr-1] [4,8 .. lenTotal - 4] ] + !bs' = BS.drop lenTotal bs + = Just (IntTrie arr, bs') + + | otherwise + = Nothing + +serialiseStringTable :: StringTable id -> BS.Builder +serialiseStringTable (StringTable strs arr) = + let (_, !ixEnd) = A.bounds arr in + + BS.word32BE (fromIntegral (BS.length strs)) + <> BS.word32BE (fromIntegral ixEnd + 1) + <> BS.byteString strs + <> foldr (\n r -> BS.word32BE n <> r) mempty (A.elems arr) + +deserialiseStringTable :: BS.ByteString -> Maybe (StringTable id, BS.ByteString) +deserialiseStringTable bs + | BS.length bs >= 8 + , let lenStrs = fromIntegral (readWord32BE bs 0) + lenArr = fromIntegral (readWord32BE bs 4) + lenTotal= 8 + lenStrs + 4 * lenArr + , BS.length bs >= lenTotal + , let strs = BS.take lenStrs (BS.drop 8 bs) + arr = A.array (0, lenArr-1) + [ (i, readWord32BE bs off) + | (i, off) <- zip [0..lenArr-1] + [offArrS,offArrS+4 .. offArrE] + ] + offArrS = 8 + lenStrs + offArrE = offArrS + 4 * lenArr - 1 + !stringTable = StringTable strs arr + !bs' = BS.drop lenTotal bs + = Just (stringTable, bs') + + | otherwise + = Nothing + +readWord32BE :: BS.ByteString -> Int -> Word32 +readWord32BE bs i = + fromIntegral (BS.index bs (i + 0)) `shiftL` 24 + + fromIntegral (BS.index bs (i + 1)) `shiftL` 16 + + fromIntegral (BS.index bs (i + 2)) `shiftL` 8 + + fromIntegral (BS.index bs (i + 3)) + + +------------------------- +-- Test properties +-- + +#ifdef TESTS + +-- properties of a finite mapping... + +prop_lookup :: [(NonEmptyFilePath, TarEntryOffset)] -> NonEmptyFilePath -> Bool +prop_lookup paths (NonEmptyFilePath p) = + case (lookup index p, Prelude.lookup p paths') of + (Nothing, Nothing) -> True + (Just (TarFileEntry offset), Just offset') -> offset == offset' + _ -> False + where + paths' = [ (p, off) | (NonEmptyFilePath p, off) <- paths ] + + index@(TarIndex pathTable _ _) = + finaliseIndex (IndexBuilder paths' 0) + +prop_valid :: [(NonEmptyFilePath, TarEntryOffset)] -> Bool +prop_valid paths + | not $ StringTable.prop_valid pathbits = error "TarIndex: bad string table" + | not $ IntTrie.prop_lookup intpaths = error "TarIndex: bad int trie" + | not $ IntTrie.prop_completions intpaths = error "TarIndex: bad int trie" + | not $ prop' = error "TarIndex: bad prop" + | otherwise = True + + where + paths' = [ (p, off) | (NonEmptyFilePath p, off) <- paths ] + + index@(TarIndex pathTable _ _) = + finaliseIndex (IndexBuilder paths' 0) + + pathbits = concatMap (FilePath.splitDirectories . fst) paths' + intpaths = [ (cids, offset) + | (path, offset) <- paths' + , let Just cids = toComponentIds pathTable path ] + prop' = flip all paths' $ \(file, offset) -> + case lookup index file of + Just (TarFileEntry offset') -> offset' == offset + _ -> False + +newtype NonEmptyFilePath = NonEmptyFilePath FilePath deriving Show + +instance Arbitrary NonEmptyFilePath where + arbitrary = NonEmptyFilePath . FilePath.joinPath + <$> listOf1 (elements ["a", "b", "c", "d"]) + +example0 :: Entries () +example0 = + testEntry "foo-1.0/foo-1.0.cabal" 1500 -- at block 0 + `Next` testEntry "foo-1.0/LICENSE" 2000 -- at block 4 + `Next` testEntry "foo-1.0/Data/Foo.hs" 1000 -- at block 9 + `Next` Done + +example1 :: Entries () +example1 = + Next (testEntry "./" 1500) Done <> example0 + +testEntry :: FilePath -> Int64 -> Entry +testEntry name size = simpleEntry path (NormalFile mempty size) + where + Right path = toTarPath False name + +#endif + +#if !(MIN_VERSION_base(4,5,0)) +(<>) :: Monoid m => m -> m -> m +(<>) = mappend +#endif + diff --git a/Codec/Archive/Tar/Index/IntTrie.hs b/Codec/Archive/Tar/Index/IntTrie.hs new file mode 100644 --- /dev/null +++ b/Codec/Archive/Tar/Index/IntTrie.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} + +module Codec.Archive.Tar.Index.IntTrie ( + + IntTrie(..), + construct, + + lookup, + TrieLookup(..), + +#ifdef TESTS + test1, test2, test3, + ValidPaths(..), + prop_lookup, + prop_completions, + prop_lookup_mono, + prop_completions_mono, +#endif + ) where + +import Prelude hiding (lookup) + +import Data.Typeable (Typeable) + +import qualified Data.Array.Unboxed as A +import Data.Array.IArray ((!)) +import qualified Data.Bits as Bits +import Data.Word (Word32) + +import Data.List hiding (lookup) +import Data.Function (on) + +#ifdef TESTS +import Test.QuickCheck +import Control.Applicative ((<$>), (<*>)) +#endif + + +-- | A compact mapping from sequences of small nats to nats. +-- +newtype IntTrie k v = IntTrie (A.UArray Word32 Word32) + deriving (Eq, Show, Typeable) + + +-- Compact, read-only implementation of a trie. It's intended for use with file +-- paths, but we do that via string ids. + +#ifdef TESTS +-- Example mapping: +-- +example0 :: [(FilePath, Int)] +example0 = + [("foo-1.0/foo-1.0.cabal", 512) -- tar block 1 + ,("foo-1.0/LICENSE", 2048) -- tar block 4 + ,("foo-1.0/Data/Foo.hs", 4096)] -- tar block 8 + +-- After converting path components to integers this becomes: +-- +example1 :: Paths Word32 Word32 +example1 = + [([1,2], 512) + ,([1,3], 2048) + ,([1,4,5], 4096)] + +-- As a trie this looks like: + +-- [ (1, *) ] +-- | +-- [ (2, 512), (3, 1024), (4, *) ] +-- | +-- [ (5, 4096) ] + +-- We use an intermediate trie representation + +example2 :: Trie Word32 Word32 +example2 = Trie [ Node 1 t1 ] + where + t1 = Trie [ Leaf 2 512, Leaf 3 2048, Node 4 t2 ] + t2 = Trie [ Leaf 5 4096 ] + + +example2' :: Trie Word32 Word32 +example2' = Trie [ Node 0 t1 ] + where + t1 = Trie [ Node 3 t2 ] + t2 = Trie [ Node 1 t3, Node 2 t4 ] + t3 = Trie [ Leaf 4 10608 ] + t4 = Trie [ Leaf 4 10612 ] +{- +0: [1,N0,3] + + 3: [1,N3,6] + + 6: [2,N1,N2,11,12] + + 11: [1,4,10608] + 14: [1,4,10612] +-} + +example2'' :: Trie Word32 Word32 +example2'' = Trie [ Node 1 t1, Node 2 t2 ] + where + t1 = Trie [ Leaf 4 10608 ] + t2 = Trie [ Leaf 4 10612 ] + +example2''' :: Trie Word32 Word32 +example2''' = Trie [ Node 0 t3 ] + where + t3 = Trie [ Node 4 t8, Node 6 t11 ] + t8 = Trie [ Node 1 t14 ] + t11 = Trie [ Leaf 5 10605 ] + t14 = Trie [ Node 2 t19, Node 3 t22 ] + t19 = Trie [ Leaf 7 10608 ] + t22 = Trie [ Leaf 7 10612 ] +{- + 0: [1,N0,3] + 3: [2,N4,N6,8,11] + 8: [1,N1,11] +11: [1,5,10605] +14: [2,N2,N3,16,19] +19: [1,7,10608] +22: [1,7,10612] +-} + +-- We convert from the 'Paths' to the 'Trie' using 'mkTrie': +-- +test1 = example2 == mkTrie example1 +#endif + +-- Each node has a size and a sequence of keys followed by an equal length +-- sequnce of corresponding entries. Since we're going to flatten this into +-- a single array then we will need to replace the trie structure with pointers +-- represented as array offsets. + +-- Each node is a pair of arrays, one of keys and one of Either value pointer. +-- We need to distinguish values from internal pointers. We use a tag bit: +-- +tagLeaf, tagNode, untag :: Word32 -> Word32 +tagLeaf = id +tagNode = flip Bits.setBit 31 +untag = flip Bits.clearBit 31 + +isNode :: Word32 -> Bool +isNode = flip Bits.testBit 31 + +-- So the overall array form of the above trie is: +-- +-- offset: 0 1 2 3 4 5 6 7 8 9 10 11 12 +-- array: [ 1 | N1 | 3 ][ 3 | 2, 3, N4 | 512, 2048, 10 ][ 1 | 5 | 4096 ] +-- \__/ \___/ + +#ifdef TESTS +example3 :: [Word32] +example3 = + [1, tagNode 1, + 3, + 3, tagLeaf 2, tagLeaf 3, tagNode 4, + 512, 2048, 10, + 1, tagLeaf 5, + 4096 + ] + +-- We get the array form by using flattenTrie: + +test2 = example3 == flattenTrie example2 + +example4 :: IntTrie Int Int +example4 = IntTrie (mkArray example3) + +test3 = case lookup example4 [1] of + Just (Completions [(2,_),(3,_),(4,_)]) -> True + _ -> False + +test1, test2, test3 :: Bool +#endif + +------------------------------------- +-- Decoding the trie array form +-- + +completionsFrom :: (Enum k, Enum v) => IntTrie k v -> Word32 -> Completions k v +completionsFrom trie@(IntTrie arr) nodeOff = + [ (word32ToEnum (untag key), next) + | keyOff <- [keysStart..keysEnd] + , let key = arr ! keyOff + entry = arr ! (keyOff + nodeSize) + next | isNode key = Completions (completionsFrom trie entry) + | otherwise = Entry (word32ToEnum entry) + ] + where + nodeSize = arr ! nodeOff + keysStart = nodeOff + 1 + keysEnd = nodeOff + nodeSize + +------------------------------------- +-- Toplevel trie array construction +-- + +-- So constructing the 'IntTrie' as a whole is just a matter of stringing +-- together all the bits + +-- | Build an 'IntTrie' from a bunch of (key, value) pairs, where the keys +-- are sequences. +-- +construct :: (Ord k, Enum k, Enum v) => [([k], v)] -> IntTrie k v +construct = IntTrie . mkArray . flattenTrie . mkTrie + +mkArray :: [Word32] -> A.UArray Word32 Word32 +mkArray xs = A.listArray (0, fromIntegral (length xs) - 1) xs + + +--------------------------------- +-- Looking up in the trie array +-- + +data TrieLookup k v = Entry !v | Completions (Completions k v) deriving Show +type Completions k v = [(k, TrieLookup k v)] + +lookup :: forall k v. (Enum k, Enum v) => IntTrie k v -> [k] -> Maybe (TrieLookup k v) +lookup trie@(IntTrie arr) = go 0 + where + go :: Word32 -> [k] -> Maybe (TrieLookup k v) + go nodeOff [] = Just (completions nodeOff) + go nodeOff (k:ks) = case search nodeOff (tagLeaf k') of + Just entryOff + | null ks -> Just (entry entryOff) + | otherwise -> Nothing + Nothing -> case search nodeOff (tagNode k') of + Nothing -> Nothing + Just entryOff -> go (arr ! entryOff) ks + where + k' = enumToWord32 k + + entry entryOff = Entry (word32ToEnum (arr ! entryOff)) + completions nodeOff = Completions (completionsFrom trie nodeOff) + + search :: Word32 -> Word32 -> Maybe Word32 + search nodeOff key = fmap (+nodeSize) (bsearch keysStart keysEnd key) + where + nodeSize = arr ! nodeOff + keysStart = nodeOff + 1 + keysEnd = nodeOff + nodeSize + + bsearch :: Word32 -> Word32 -> Word32 -> Maybe Word32 + bsearch a b key + | a > b = Nothing + | otherwise = case compare key (arr ! mid) of + LT -> bsearch a (mid-1) key + EQ -> Just mid + GT -> bsearch (mid+1) b key + where mid = (a + b) `div` 2 + + +enumToWord32 :: Enum n => n -> Word32 +enumToWord32 = fromIntegral . fromEnum + +word32ToEnum :: Enum n => Word32 -> n +word32ToEnum = toEnum . fromIntegral + + +------------------------- +-- Intermediate Trie type +-- + +-- The trie node functor +data TrieNodeF k v x = Leaf k v | Node k x deriving (Eq, Show) + +instance Functor (TrieNodeF k v) where + fmap _ (Leaf k v) = Leaf k v + fmap f (Node k x) = Node k (f x) + +-- The trie functor +type TrieF k v x = [TrieNodeF k v x] + +-- Trie is the fixpoint of the 'TrieF' functor +newtype Trie k v = Trie (TrieF k v (Trie k v)) deriving (Eq, Show) + + +unfoldTrieNode :: (s -> TrieNodeF k v [s]) -> s -> TrieNodeF k v (Trie k v) +unfoldTrieNode f = fmap (unfoldTrie f) . f + +unfoldTrie :: (s -> TrieNodeF k v [s]) -> [s] -> Trie k v +unfoldTrie f = Trie . map (unfoldTrieNode f) + +{- +trieSize :: Trie k v -> Int +trieSize (Trie ts) = 1 + sum (map trieNodeSize ts) + +trieNodeSize :: TrieNodeF k v (Trie k v) -> Int +trieNodeSize (Leaf _ _) = 2 +trieNodeSize (Node _ t) = 2 + trieSize t +-} + +--------------------------------- +-- Building and flattening Tries +-- + +-- | A list of key value pairs. The keys must be distinct and non-empty. +type Paths k v = [([k], v)] + + +mkTrie :: Ord k => Paths k v -> Trie k v +mkTrie = unfoldTrie (fmap split) . split + . sortBy (compare `on` fst) + . filter (not . null . fst) + where + split :: Eq k => Paths k v -> TrieF k v (Paths k v) + split = map mkGroup . groupBy ((==) `on` (head . fst)) + where + mkGroup = \ksvs@((k0:_,v0):_) -> + case [ (ks, v) | (_:ks, v) <- ksvs, not (null ks) ] of + [] -> Leaf k0 v0 + ksvs' -> Node k0 ksvs' + +type Offset = Int + +-- This is a breadth-first traversal. We keep a list of the tries that we are +-- to write out next. Each of these have an offset allocated to them at the +-- time we put them into the list. We keep a running offset so we know where +-- to allocate next. +-- +flattenTrie :: (Enum k, Enum v) => Trie k v -> [Word32] +flattenTrie trie = go (queue [trie]) (size trie) + where + size (Trie tns) = 1 + 2 * length tns + + go :: (Enum k, Enum v) => Q (Trie k v) -> Offset -> [Word32] + go todo !offset = + case dequeue todo of + Nothing -> [] + Just (Trie tnodes, tries) -> + flat ++ go (tries `enqueue` tries') offset' + where + !count = length tnodes + flat = fromIntegral count : keys ++ values + (keys, values) = unzip (sortBy (compare `on` fst) keysValues) + (!keysValues, !tries', !offset') = doNodes offset [] [] tnodes + + doNodes off kvs ts' [] = (kvs, reverse ts', off) + doNodes off kvs ts' (tn:tns) = case tn of + Leaf k v -> doNodes off (leafKV k v :kvs) ts' tns + Node k t -> doNodes (off + size t) (nodeKV k off:kvs) (t:ts') tns + + leafKV k v = (tagLeaf (enum2Word32 k), enum2Word32 v) + nodeKV k o = (tagNode (enum2Word32 k), int2Word32 o) + +data Q a = Q [a] [[a]] + +queue :: [a] -> Q a +queue xs = Q xs [] + +enqueue :: Q a -> [a] -> Q a +enqueue (Q front back) [] = Q front back +enqueue (Q front back) xs = Q front (xs : back) + +dequeue :: Q a -> Maybe (a, Q a) +dequeue (Q (x:xs) back) = Just (x, Q xs back) +dequeue (Q [] back) = case concat (reverse back) of + x:xs -> Just (x, Q xs []) + [] -> Nothing + +int2Word32 :: Int -> Word32 +int2Word32 = fromIntegral + +enum2Word32 :: Enum n => n -> Word32 +enum2Word32 = int2Word32 . fromEnum + + +------------------------- +-- Correctness property +-- + +#ifdef TESTS + +prop_lookup :: (Ord k, Enum k, Eq v, Enum v, Show k, Show v) + => [([k], v)] -> Bool +prop_lookup paths = + flip all paths $ \(key, value) -> + case lookup trie key of + Just (Entry value') | value' == value -> True + Just (Entry value') -> error $ "IntTrie: " ++ show (key, value, value') + Nothing -> error $ "IntTrie: didn't find " ++ show key + Just (Completions xs) -> error $ "IntTrie: " ++ show xs + + where + trie = construct paths + +prop_completions :: forall k v. (Ord k, Enum k, Eq v, Enum v) => [([k], v)] -> Bool +prop_completions paths = + mkTrie paths == convertCompletions (completionsFrom (construct paths) 0) + where + convertCompletions :: Ord k => Completions k v -> Trie k v + convertCompletions kls = + Trie [ case l of + Entry v -> Leaf k v + Completions kls' -> Node k (convertCompletions kls') + | (k, l) <- sortBy (compare `on` fst) kls ] + + +prop_lookup_mono :: ValidPaths -> Bool +prop_lookup_mono (ValidPaths paths) = prop_lookup paths + +prop_completions_mono :: ValidPaths -> Bool +prop_completions_mono (ValidPaths paths) = prop_completions paths + + +newtype ValidPaths = ValidPaths (Paths Char Char) deriving Show + +instance Arbitrary ValidPaths where + arbitrary = + ValidPaths . makeNoPrefix <$> listOf ((,) <$> listOf1 arbitrary <*> arbitrary) + where + makeNoPrefix [] = [] + makeNoPrefix ((k,v):kvs) + | all (\(k', _) -> not (isPrefixOfOther k k')) kvs + = (k,v) : makeNoPrefix kvs + | otherwise = makeNoPrefix kvs + + shrink (ValidPaths kvs) = + map ValidPaths . filter noPrefix . filter nonEmpty . shrink $ kvs + where + noPrefix [] = True + noPrefix ((k,_):kvs) = all (\(k', _) -> not (isPrefixOfOther k k')) kvs + && noPrefix kvs + nonEmpty = all (not . null . fst) + +isPrefixOfOther a b = a `isPrefixOf` b || b `isPrefixOf` a + +#endif diff --git a/Codec/Archive/Tar/Index/StringTable.hs b/Codec/Archive/Tar/Index/StringTable.hs new file mode 100644 --- /dev/null +++ b/Codec/Archive/Tar/Index/StringTable.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE CPP, BangPatterns, DeriveDataTypeable #-} + +module Codec.Archive.Tar.Index.StringTable ( + + StringTable(..), + lookup, + index, + construct, + +#ifdef TESTS + prop_valid, +#endif + ) where + +import Data.Typeable (Typeable) + +import Prelude hiding (lookup) +import qualified Data.List as List +import qualified Data.Array.Unboxed as A +import Data.Array.Unboxed ((!)) +import qualified Data.ByteString.Char8 as BS +import Data.Word (Word32) + + + +-- | An effecient mapping from strings to a dense set of integers. +-- +data StringTable id = StringTable + {-# UNPACK #-} !BS.ByteString -- all the strings concatenated + {-# UNPACK #-} !(A.UArray Int Word32) -- offset table + deriving (Eq, Show, Typeable) + +-- | Look up a string in the token table. If the string is present, return +-- its corresponding index. +-- +lookup :: Enum id => StringTable id -> String -> Maybe id +lookup (StringTable bs tbl) str = + binarySearch 0 (topBound-1) (BS.pack str) + where + (0, topBound) = A.bounds tbl + + binarySearch !a !b !key + | a > b = Nothing + | otherwise = case compare key (index' bs tbl mid) of + LT -> binarySearch a (mid-1) key + EQ -> Just (toEnum mid) + GT -> binarySearch (mid+1) b key + where mid = (a + b) `div` 2 + +index' :: BS.ByteString -> A.UArray Int Word32 -> Int -> BS.ByteString +index' bs tbl i = BS.take len . BS.drop start $ bs + where + start, end, len :: Int + start = fromIntegral (tbl ! i) + end = fromIntegral (tbl ! (i+1)) + len = end - start + + +-- | Given the index of a string in the table, return the string. +-- +index :: Enum id => StringTable id -> id -> String +index (StringTable bs tbl) = BS.unpack . index' bs tbl . fromEnum + + +-- | Given a list of strings, construct a 'StringTable' mapping those strings +-- to a dense set of integers. +-- +construct :: Enum id => [String] -> StringTable id +construct strs = StringTable bs tbl + where + bs = BS.pack (concat strs') + tbl = A.array (0, length strs') (zip [0..] offsets) + offsets = scanl (\off str -> off + fromIntegral (length str)) 0 strs' + strs' = map head . List.group . List.sort $ strs + + +#ifdef TESTS + +prop_valid :: [String] -> Bool +prop_valid strs = + all lookupIndex (enumStrings tbl) + && all indexLookup (enumIds tbl) + + where + tbl :: StringTable Int + tbl = construct strs + + lookupIndex str = index tbl ident == str + where Just ident = lookup tbl str + + indexLookup ident = lookup tbl str == Just ident + where str = index tbl ident + +enumStrings :: Enum id => StringTable id -> [String] +enumStrings (StringTable bs tbl) = map (BS.unpack . index' bs tbl) [0..h-1] + where (0,h) = A.bounds tbl + +enumIds :: Enum id => StringTable id -> [id] +enumIds (StringTable _ tbl) = map toEnum [0..h-1] + where (0,h) = A.bounds tbl + +#endif diff --git a/Codec/Archive/Tar/Read.hs b/Codec/Archive/Tar/Read.hs --- a/Codec/Archive/Tar/Read.hs +++ b/Codec/Archive/Tar/Read.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar.Read diff --git a/Codec/Archive/Tar/Types.hs b/Codec/Archive/Tar/Types.hs --- a/Codec/Archive/Tar/Types.hs +++ b/Codec/Archive/Tar/Types.hs @@ -418,6 +418,8 @@ | Done | Fail e +infixr 5 `Next` + -- | This is like the standard 'unfoldr' function on lists, but for 'Entries'. -- It includes failure as an extra possibility that the stepper function may -- return. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,5 @@ Copyright (c) 2007 Björn Bringert, - 2008-2012 Duncan Coutts, + 2008-2015 Duncan Coutts, 2011 Max Bolingbroke All rights reserved. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,22 @@ +0.4.2.0 Duncan Coutts July 2015 + + * New Index module for random access to tar file contents + * New lower level tar file I/O actions + * New tarball file 'append' action + +0.4.1.0 Duncan Coutts January 2015 + + * Build with GHC 7.10 + * Switch from old-time to time package + * Added more instance for Entries type + +0.4.0.1 Duncan Coutts October 2012 + + * fixes to work with directory 1.2 + * More Eq/Ord instances + +0.4.0.0 Duncan Coutts February 2012 + + * More explicit error types and error handling + * Support star base-256 number format + * Improved API documentation diff --git a/tar.cabal b/tar.cabal --- a/tar.cabal +++ b/tar.cabal @@ -1,5 +1,5 @@ name: tar -version: 0.4.1.0 +version: 0.4.2.0 license: BSD3 license-file: LICENSE author: Bjorn Bringert @@ -18,6 +18,7 @@ preserved. build-type: Simple cabal-version: >=1.8 +extra-source-files: changelog.md source-repository head type: darcs @@ -26,8 +27,11 @@ flag old-time library - build-depends: base == 4.*, filepath, - bytestring, directory + build-depends: base == 4.*, + bytestring >= 0.10, + filepath, + directory, + array if flag(old-time) build-depends: directory < 1.2, old-time else @@ -37,6 +41,7 @@ Codec.Archive.Tar Codec.Archive.Tar.Entry Codec.Archive.Tar.Check + Codec.Archive.Tar.Index other-modules: Codec.Archive.Tar.Types @@ -44,8 +49,37 @@ Codec.Archive.Tar.Write Codec.Archive.Tar.Pack Codec.Archive.Tar.Unpack + Codec.Archive.Tar.Index.StringTable + Codec.Archive.Tar.Index.IntTrie - extensions: - DeriveDataTypeable + other-extensions: + CPP, BangPatterns, + DeriveDataTypeable, ScopedTypeVariables ghc-options: -Wall -fno-warn-unused-imports + +test-suite properties + type: exitcode-stdio-1.0 + build-depends: base, + bytestring, + filepath, directory, + old-time, time, + array, + QuickCheck == 2.*, + tasty == 0.10.*, + tasty-quickcheck == 0.8.* + + hs-source-dirs: . test + + main-is: test/Properties.hs + cpp-options: -DTESTS + + other-modules: + Codec.Archive.Tar.Index + Codec.Archive.Tar.Index.StringTable + Codec.Archive.Tar.Index.IntTrie + + other-extensions: + CPP, BangPatterns, + DeriveDataTypeable, ScopedTypeVariables + diff --git a/test/Properties.hs b/test/Properties.hs new file mode 100644 --- /dev/null +++ b/test/Properties.hs @@ -0,0 +1,31 @@ +module Main where + +import qualified Codec.Archive.Tar.Index as Index +import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie +import qualified Codec.Archive.Tar.Index.StringTable as StringTable + +import qualified Data.ByteString.Lazy.Char8 as BS +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + +main :: IO () +main = + defaultMain $ + testGroup "tar tests" [ + testGroup "string table" [ + testProperty "construction and lookup" StringTable.prop_valid + ] + , testGroup "int trie" [ + testProperty "unit 1" IntTrie.test1, + testProperty "unit 2" IntTrie.test2, + testProperty "unit 3" IntTrie.test3, + testProperty "lookups" IntTrie.prop_lookup_mono, + testProperty "completions" IntTrie.prop_completions_mono + ] + , testGroup "index" [ + testProperty "lookup" Index.prop_lookup + , testProperty "valid" Index.prop_valid + ] + ] +