{-# LANGUAGE CPP, BangPatterns, PatternGuards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
module Codec.Archive.Tar.Index (
TarIndex,
lookup,
TarIndexEntry(..),
toList,
TarEntryOffset,
hReadEntry,
hReadEntryHeader,
build,
IndexBuilder,
empty,
addNextEntry,
skipNextEntry,
finalise,
unfinalise,
serialise,
deserialise,
hReadEntryHeaderOrEof,
hSeekEntryOffset,
hSeekEntryContentOffset,
hSeekEndEntryOffset,
nextEntryOffset,
indexEndEntryOffset,
indexNextEntryOffset,
emptyIndex,
finaliseIndex,
#ifdef TESTS
prop_lookup,
prop_toList,
prop_valid,
prop_serialise_deserialise,
prop_serialiseSize,
prop_index_matches_tar,
prop_finalise_unfinalise,
#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, StringTableBuilder)
import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie
import Codec.Archive.Tar.Index.IntTrie (IntTrie, IntTrieBuilder)
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 (assert, throwIO)
import Control.DeepSeq
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.Char8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Unsafe as BS
#if MIN_VERSION_bytestring(0,10,2) || defined(MIN_VERSION_bytestring_builder)
import Data.ByteString.Builder as BS
import Data.ByteString.Builder.Extra as BS (toLazyByteStringWith,
untrimmedStrategy)
#else
import Data.ByteString.Lazy.Builder as BS
import Data.ByteString.Lazy.Builder.Extras as BS (toLazyByteStringWith,
untrimmedStrategy)
#endif
#ifdef TESTS
import qualified Prelude
import Test.QuickCheck
import Test.QuickCheck.Property (ioProperty)
import Control.Applicative ((<$>), (<*>))
import Control.Monad (unless)
import Data.List (nub, sort, sortBy, stripPrefix, isPrefixOf)
import Data.Maybe
import Data.Function (on)
import Control.Exception (SomeException, try)
import Codec.Archive.Tar.Write as Tar
import qualified Data.ByteString.Handle as HBS
#endif
data TarIndex = TarIndex
{-# UNPACK #-} !(StringTable PathComponentId)
{-# UNPACK #-} !(IntTrie PathComponentId TarEntryOffset)
{-# UNPACK #-} !TarEntryOffset
deriving (TarIndex -> TarIndex -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TarIndex -> TarIndex -> Bool
$c/= :: TarIndex -> TarIndex -> Bool
== :: TarIndex -> TarIndex -> Bool
$c== :: TarIndex -> TarIndex -> Bool
Eq, Int -> TarIndex -> ShowS
[TarIndex] -> ShowS
TarIndex -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TarIndex] -> ShowS
$cshowList :: [TarIndex] -> ShowS
show :: TarIndex -> String
$cshow :: TarIndex -> String
showsPrec :: Int -> TarIndex -> ShowS
$cshowsPrec :: Int -> TarIndex -> ShowS
Show, Typeable)
instance NFData TarIndex where
rnf :: TarIndex -> ()
rnf (TarIndex StringTable PathComponentId
_ IntTrie PathComponentId Word32
_ Word32
_) = ()
data TarIndexEntry = TarFileEntry {-# UNPACK #-} !TarEntryOffset
| TarDir [(FilePath, TarIndexEntry)]
deriving (Int -> TarIndexEntry -> ShowS
[TarIndexEntry] -> ShowS
TarIndexEntry -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TarIndexEntry] -> ShowS
$cshowList :: [TarIndexEntry] -> ShowS
show :: TarIndexEntry -> String
$cshow :: TarIndexEntry -> String
showsPrec :: Int -> TarIndexEntry -> ShowS
$cshowsPrec :: Int -> TarIndexEntry -> ShowS
Show, Typeable)
newtype PathComponentId = PathComponentId Int
deriving (PathComponentId -> PathComponentId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PathComponentId -> PathComponentId -> Bool
$c/= :: PathComponentId -> PathComponentId -> Bool
== :: PathComponentId -> PathComponentId -> Bool
$c== :: PathComponentId -> PathComponentId -> Bool
Eq, Eq PathComponentId
PathComponentId -> PathComponentId -> Bool
PathComponentId -> PathComponentId -> Ordering
PathComponentId -> PathComponentId -> PathComponentId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PathComponentId -> PathComponentId -> PathComponentId
$cmin :: PathComponentId -> PathComponentId -> PathComponentId
max :: PathComponentId -> PathComponentId -> PathComponentId
$cmax :: PathComponentId -> PathComponentId -> PathComponentId
>= :: PathComponentId -> PathComponentId -> Bool
$c>= :: PathComponentId -> PathComponentId -> Bool
> :: PathComponentId -> PathComponentId -> Bool
$c> :: PathComponentId -> PathComponentId -> Bool
<= :: PathComponentId -> PathComponentId -> Bool
$c<= :: PathComponentId -> PathComponentId -> Bool
< :: PathComponentId -> PathComponentId -> Bool
$c< :: PathComponentId -> PathComponentId -> Bool
compare :: PathComponentId -> PathComponentId -> Ordering
$ccompare :: PathComponentId -> PathComponentId -> Ordering
Ord, Int -> PathComponentId
PathComponentId -> Int
PathComponentId -> [PathComponentId]
PathComponentId -> PathComponentId
PathComponentId -> PathComponentId -> [PathComponentId]
PathComponentId
-> PathComponentId -> PathComponentId -> [PathComponentId]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: PathComponentId
-> PathComponentId -> PathComponentId -> [PathComponentId]
$cenumFromThenTo :: PathComponentId
-> PathComponentId -> PathComponentId -> [PathComponentId]
enumFromTo :: PathComponentId -> PathComponentId -> [PathComponentId]
$cenumFromTo :: PathComponentId -> PathComponentId -> [PathComponentId]
enumFromThen :: PathComponentId -> PathComponentId -> [PathComponentId]
$cenumFromThen :: PathComponentId -> PathComponentId -> [PathComponentId]
enumFrom :: PathComponentId -> [PathComponentId]
$cenumFrom :: PathComponentId -> [PathComponentId]
fromEnum :: PathComponentId -> Int
$cfromEnum :: PathComponentId -> Int
toEnum :: Int -> PathComponentId
$ctoEnum :: Int -> PathComponentId
pred :: PathComponentId -> PathComponentId
$cpred :: PathComponentId -> PathComponentId
succ :: PathComponentId -> PathComponentId
$csucc :: PathComponentId -> PathComponentId
Enum, Int -> PathComponentId -> ShowS
[PathComponentId] -> ShowS
PathComponentId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathComponentId] -> ShowS
$cshowList :: [PathComponentId] -> ShowS
show :: PathComponentId -> String
$cshow :: PathComponentId -> String
showsPrec :: Int -> PathComponentId -> ShowS
$cshowsPrec :: Int -> PathComponentId -> ShowS
Show, Typeable)
type TarEntryOffset = Word32
lookup :: TarIndex -> FilePath -> Maybe TarIndexEntry
lookup :: TarIndex -> String -> Maybe TarIndexEntry
lookup (TarIndex StringTable PathComponentId
pathTable IntTrie PathComponentId Word32
pathTrie Word32
_) String
path = do
[PathComponentId]
fpath <- StringTable PathComponentId -> String -> Maybe [PathComponentId]
toComponentIds StringTable PathComponentId
pathTable String
path
TrieLookup PathComponentId Word32
tentry <- forall k v.
(Enum k, Enum v) =>
IntTrie k v -> [k] -> Maybe (TrieLookup k v)
IntTrie.lookup IntTrie PathComponentId Word32
pathTrie [PathComponentId]
fpath
forall (m :: * -> *) a. Monad m => a -> m a
return (TrieLookup PathComponentId Word32 -> TarIndexEntry
mkIndexEntry TrieLookup PathComponentId Word32
tentry)
where
mkIndexEntry :: TrieLookup PathComponentId Word32 -> TarIndexEntry
mkIndexEntry (IntTrie.Entry Word32
offset) = Word32 -> TarIndexEntry
TarFileEntry Word32
offset
mkIndexEntry (IntTrie.Completions Completions PathComponentId Word32
entries) =
[(String, TarIndexEntry)] -> TarIndexEntry
TarDir [ (StringTable PathComponentId -> PathComponentId -> String
fromComponentId StringTable PathComponentId
pathTable PathComponentId
key, TrieLookup PathComponentId Word32 -> TarIndexEntry
mkIndexEntry TrieLookup PathComponentId Word32
entry)
| (PathComponentId
key, TrieLookup PathComponentId Word32
entry) <- Completions PathComponentId Word32
entries ]
toComponentIds :: StringTable PathComponentId -> FilePath -> Maybe [PathComponentId]
toComponentIds :: StringTable PathComponentId -> String -> Maybe [PathComponentId]
toComponentIds StringTable PathComponentId
table =
[PathComponentId] -> [ByteString] -> Maybe [PathComponentId]
lookupComponents []
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char -> ByteString
BS.Char8.singleton Char
'.')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
splitDirectories
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.Char8.pack
where
lookupComponents :: [PathComponentId] -> [ByteString] -> Maybe [PathComponentId]
lookupComponents [PathComponentId]
cs' [] = forall a. a -> Maybe a
Just (forall a. [a] -> [a]
reverse [PathComponentId]
cs')
lookupComponents [PathComponentId]
cs' (ByteString
c:[ByteString]
cs) = case forall id. Enum id => StringTable id -> ByteString -> Maybe id
StringTable.lookup StringTable PathComponentId
table ByteString
c of
Maybe PathComponentId
Nothing -> forall a. Maybe a
Nothing
Just PathComponentId
cid -> [PathComponentId] -> [ByteString] -> Maybe [PathComponentId]
lookupComponents (PathComponentId
cidforall a. a -> [a] -> [a]
:[PathComponentId]
cs') [ByteString]
cs
fromComponentId :: StringTable PathComponentId -> PathComponentId -> FilePath
fromComponentId :: StringTable PathComponentId -> PathComponentId -> String
fromComponentId StringTable PathComponentId
table = ByteString -> String
BS.Char8.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall id. Enum id => StringTable id -> id -> ByteString
StringTable.index StringTable PathComponentId
table
toList :: TarIndex -> [(FilePath, TarEntryOffset)]
toList :: TarIndex -> [(String, Word32)]
toList (TarIndex StringTable PathComponentId
pathTable IntTrie PathComponentId Word32
pathTrie Word32
_) =
[ (String
path, Word32
off)
| ([PathComponentId]
cids, Word32
off) <- forall k v. (Enum k, Enum v) => IntTrie k v -> [([k], v)]
IntTrie.toList IntTrie PathComponentId Word32
pathTrie
, let path :: String
path = [String] -> String
FilePath.joinPath (forall a b. (a -> b) -> [a] -> [b]
map (StringTable PathComponentId -> PathComponentId -> String
fromComponentId StringTable PathComponentId
pathTable) [PathComponentId]
cids) ]
build :: Entries e -> Either e TarIndex
build :: forall e. Entries e -> Either e TarIndex
build = forall {a}. IndexBuilder -> Entries a -> Either a TarIndex
go IndexBuilder
empty
where
go :: IndexBuilder -> Entries a -> Either a TarIndex
go !IndexBuilder
builder (Next Entry
e Entries a
es) = IndexBuilder -> Entries a -> Either a TarIndex
go (Entry -> IndexBuilder -> IndexBuilder
addNextEntry Entry
e IndexBuilder
builder) Entries a
es
go !IndexBuilder
builder Entries a
Done = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! IndexBuilder -> TarIndex
finalise IndexBuilder
builder
go !IndexBuilder
_ (Fail a
err) = forall a b. a -> Either a b
Left a
err
data IndexBuilder
= IndexBuilder !(StringTableBuilder PathComponentId)
!(IntTrieBuilder PathComponentId TarEntryOffset)
{-# UNPACK #-} !TarEntryOffset
deriving (IndexBuilder -> IndexBuilder -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IndexBuilder -> IndexBuilder -> Bool
$c/= :: IndexBuilder -> IndexBuilder -> Bool
== :: IndexBuilder -> IndexBuilder -> Bool
$c== :: IndexBuilder -> IndexBuilder -> Bool
Eq, Int -> IndexBuilder -> ShowS
[IndexBuilder] -> ShowS
IndexBuilder -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IndexBuilder] -> ShowS
$cshowList :: [IndexBuilder] -> ShowS
show :: IndexBuilder -> String
$cshow :: IndexBuilder -> String
showsPrec :: Int -> IndexBuilder -> ShowS
$cshowsPrec :: Int -> IndexBuilder -> ShowS
Show)
instance NFData IndexBuilder where
rnf :: IndexBuilder -> ()
rnf (IndexBuilder StringTableBuilder PathComponentId
_ IntTrieBuilder PathComponentId Word32
_ Word32
_) = ()
empty :: IndexBuilder
empty :: IndexBuilder
empty = StringTableBuilder PathComponentId
-> IntTrieBuilder PathComponentId Word32 -> Word32 -> IndexBuilder
IndexBuilder forall id. StringTableBuilder id
StringTable.empty forall k v. IntTrieBuilder k v
IntTrie.empty Word32
0
emptyIndex :: IndexBuilder
emptyIndex :: IndexBuilder
emptyIndex = IndexBuilder
empty
{-# DEPRECATED emptyIndex "Use TarIndex.empty" #-}
addNextEntry :: Entry -> IndexBuilder -> IndexBuilder
addNextEntry :: Entry -> IndexBuilder -> IndexBuilder
addNextEntry Entry
entry (IndexBuilder StringTableBuilder PathComponentId
stbl IntTrieBuilder PathComponentId Word32
itrie Word32
nextOffset) =
StringTableBuilder PathComponentId
-> IntTrieBuilder PathComponentId Word32 -> Word32 -> IndexBuilder
IndexBuilder StringTableBuilder PathComponentId
stbl' IntTrieBuilder PathComponentId Word32
itrie'
(Entry -> Word32 -> Word32
nextEntryOffset Entry
entry Word32
nextOffset)
where
!entrypath :: [ByteString]
entrypath = TarPath -> [ByteString]
splitTarPath (Entry -> TarPath
entryTarPath Entry
entry)
(StringTableBuilder PathComponentId
stbl', [PathComponentId]
cids) = forall id.
Enum id =>
[ByteString]
-> StringTableBuilder id -> (StringTableBuilder id, [id])
StringTable.inserts [ByteString]
entrypath StringTableBuilder PathComponentId
stbl
itrie' :: IntTrieBuilder PathComponentId Word32
itrie' = forall k v.
(Enum k, Enum v) =>
[k] -> v -> IntTrieBuilder k v -> IntTrieBuilder k v
IntTrie.insert [PathComponentId]
cids Word32
nextOffset IntTrieBuilder PathComponentId Word32
itrie
skipNextEntry :: Entry -> IndexBuilder -> IndexBuilder
skipNextEntry :: Entry -> IndexBuilder -> IndexBuilder
skipNextEntry Entry
entry (IndexBuilder StringTableBuilder PathComponentId
stbl IntTrieBuilder PathComponentId Word32
itrie Word32
nextOffset) =
StringTableBuilder PathComponentId
-> IntTrieBuilder PathComponentId Word32 -> Word32 -> IndexBuilder
IndexBuilder StringTableBuilder PathComponentId
stbl IntTrieBuilder PathComponentId Word32
itrie (Entry -> Word32 -> Word32
nextEntryOffset Entry
entry Word32
nextOffset)
finalise :: IndexBuilder -> TarIndex
finalise :: IndexBuilder -> TarIndex
finalise (IndexBuilder StringTableBuilder PathComponentId
stbl IntTrieBuilder PathComponentId Word32
itrie Word32
finalOffset) =
StringTable PathComponentId
-> IntTrie PathComponentId Word32 -> Word32 -> TarIndex
TarIndex StringTable PathComponentId
pathTable IntTrie PathComponentId Word32
pathTrie Word32
finalOffset
where
pathTable :: StringTable PathComponentId
pathTable = forall id. Enum id => StringTableBuilder id -> StringTable id
StringTable.finalise StringTableBuilder PathComponentId
stbl
pathTrie :: IntTrie PathComponentId Word32
pathTrie = forall k v. IntTrieBuilder k v -> IntTrie k v
IntTrie.finalise IntTrieBuilder PathComponentId Word32
itrie
finaliseIndex :: IndexBuilder -> TarIndex
finaliseIndex :: IndexBuilder -> TarIndex
finaliseIndex = IndexBuilder -> TarIndex
finalise
{-# DEPRECATED finaliseIndex "Use TarIndex.finalise" #-}
indexNextEntryOffset :: IndexBuilder -> TarEntryOffset
indexNextEntryOffset :: IndexBuilder -> Word32
indexNextEntryOffset (IndexBuilder StringTableBuilder PathComponentId
_ IntTrieBuilder PathComponentId Word32
_ Word32
off) = Word32
off
indexEndEntryOffset :: TarIndex -> TarEntryOffset
indexEndEntryOffset :: TarIndex -> Word32
indexEndEntryOffset (TarIndex StringTable PathComponentId
_ IntTrie PathComponentId Word32
_ Word32
off) = Word32
off
nextEntryOffset :: Entry -> TarEntryOffset -> TarEntryOffset
nextEntryOffset :: Entry -> Word32 -> Word32
nextEntryOffset Entry
entry Word32
offset =
Word32
offset
forall a. Num a => a -> a -> a
+ Word32
1
forall a. Num a => a -> a -> a
+ case Entry -> EntryContent
entryContent Entry
entry of
NormalFile ByteString
_ FileSize
size -> FileSize -> Word32
blocks FileSize
size
OtherEntryType Char
_ ByteString
_ FileSize
size -> FileSize -> Word32
blocks FileSize
size
EntryContent
_ -> Word32
0
where
blocks :: Int64 -> TarEntryOffset
blocks :: FileSize -> Word32
blocks FileSize
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileSize
1 forall a. Num a => a -> a -> a
+ (FileSize
size forall a. Num a => a -> a -> a
- FileSize
1) forall a. Integral a => a -> a -> a
`div` FileSize
512)
type FilePathBS = BS.ByteString
splitTarPath :: TarPath -> [FilePathBS]
splitTarPath :: TarPath -> [ByteString]
splitTarPath (TarPath ByteString
name ByteString
prefix) =
ByteString -> [ByteString]
splitDirectories ByteString
prefix forall a. [a] -> [a] -> [a]
++ ByteString -> [ByteString]
splitDirectories ByteString
name
splitDirectories :: FilePathBS -> [FilePathBS]
splitDirectories :: ByteString -> [ByteString]
splitDirectories ByteString
bs =
case Char -> ByteString -> [ByteString]
BS.Char8.split Char
'/' ByteString
bs of
ByteString
c:[ByteString]
cs | ByteString -> Bool
BS.null ByteString
c -> Char -> ByteString
BS.Char8.singleton Char
'/' forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
BS.null) [ByteString]
cs
[ByteString]
cs -> forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
BS.null) [ByteString]
cs
unfinalise :: TarIndex -> IndexBuilder
unfinalise :: TarIndex -> IndexBuilder
unfinalise (TarIndex StringTable PathComponentId
pathTable IntTrie PathComponentId Word32
pathTrie Word32
finalOffset) =
StringTableBuilder PathComponentId
-> IntTrieBuilder PathComponentId Word32 -> Word32 -> IndexBuilder
IndexBuilder (forall id. Enum id => StringTable id -> StringTableBuilder id
StringTable.unfinalise StringTable PathComponentId
pathTable)
(forall k v. (Enum k, Enum v) => IntTrie k v -> IntTrieBuilder k v
IntTrie.unfinalise IntTrie PathComponentId Word32
pathTrie)
Word32
finalOffset
hReadEntry :: Handle -> TarEntryOffset -> IO Entry
hReadEntry :: Handle -> Word32 -> IO Entry
hReadEntry Handle
hnd Word32
off = do
Entry
entry <- Handle -> Word32 -> IO Entry
hReadEntryHeader Handle
hnd Word32
off
case Entry -> EntryContent
entryContent Entry
entry of
NormalFile ByteString
_ FileSize
size -> do ByteString
body <- Handle -> Int -> IO ByteString
LBS.hGet Handle
hnd (forall a b. (Integral a, Num b) => a -> b
fromIntegral FileSize
size)
forall (m :: * -> *) a. Monad m => a -> m a
return Entry
entry {
entryContent :: EntryContent
entryContent = ByteString -> FileSize -> EntryContent
NormalFile ByteString
body FileSize
size
}
OtherEntryType Char
c ByteString
_ FileSize
size -> do ByteString
body <- Handle -> Int -> IO ByteString
LBS.hGet Handle
hnd (forall a b. (Integral a, Num b) => a -> b
fromIntegral FileSize
size)
forall (m :: * -> *) a. Monad m => a -> m a
return Entry
entry {
entryContent :: EntryContent
entryContent = Char -> ByteString -> FileSize -> EntryContent
OtherEntryType Char
c ByteString
body FileSize
size
}
EntryContent
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Entry
entry
hReadEntryHeader :: Handle -> TarEntryOffset -> IO Entry
Handle
hnd Word32
blockOff = do
Handle -> Word32 -> IO ()
hSeekEntryOffset Handle
hnd Word32
blockOff
ByteString
header <- Handle -> Int -> IO ByteString
LBS.hGet Handle
hnd Int
512
case ByteString -> Entries FormatError
Tar.read ByteString
header of
Tar.Next Entry
entry Entries FormatError
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Entry
entry
Tar.Fail FormatError
e -> forall e a. Exception e => e -> IO a
throwIO FormatError
e
Entries FormatError
Tar.Done -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"hReadEntryHeader: impossible"
hSeekEntryOffset :: Handle -> TarEntryOffset -> IO ()
hSeekEntryOffset :: Handle -> Word32 -> IO ()
hSeekEntryOffset Handle
hnd Word32
blockOff =
Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
hnd SeekMode
AbsoluteSeek (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
blockOff forall a. Num a => a -> a -> a
* Integer
512)
hSeekEntryContentOffset :: Handle -> TarEntryOffset -> IO ()
hSeekEntryContentOffset :: Handle -> Word32 -> IO ()
hSeekEntryContentOffset Handle
hnd Word32
blockOff =
Handle -> Word32 -> IO ()
hSeekEntryOffset Handle
hnd (Word32
blockOff forall a. Num a => a -> a -> a
+ Word32
1)
hReadEntryHeaderOrEof :: Handle -> TarEntryOffset
-> IO (Maybe (Entry, TarEntryOffset))
Handle
hnd Word32
blockOff = do
Handle -> Word32 -> IO ()
hSeekEntryOffset Handle
hnd Word32
blockOff
ByteString
header <- Handle -> Int -> IO ByteString
LBS.hGet Handle
hnd Int
1024
case ByteString -> Entries FormatError
Tar.read ByteString
header of
Tar.Next Entry
entry Entries FormatError
_ -> let !blockOff' :: Word32
blockOff' = Entry -> Word32 -> Word32
nextEntryOffset Entry
entry Word32
blockOff
in forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Entry
entry, Word32
blockOff'))
Entries FormatError
Tar.Done -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Tar.Fail FormatError
e -> forall e a. Exception e => e -> IO a
throwIO FormatError
e
hSeekEndEntryOffset :: Handle -> Maybe TarIndex -> IO TarEntryOffset
hSeekEndEntryOffset :: Handle -> Maybe TarIndex -> IO Word32
hSeekEndEntryOffset Handle
hnd (Just TarIndex
index) = do
let offset :: Word32
offset = TarIndex -> Word32
indexEndEntryOffset TarIndex
index
Handle -> Word32 -> IO ()
hSeekEntryOffset Handle
hnd Word32
offset
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
offset
hSeekEndEntryOffset Handle
hnd Maybe TarIndex
Nothing = do
Integer
size <- Handle -> IO Integer
hFileSize Handle
hnd
if Integer
size forall a. Eq a => a -> a -> Bool
== Integer
0
then forall (m :: * -> *) a. Monad m => a -> m a
return Word32
0
else Word32 -> IO Word32
seekToEnd Word32
0
where
seekToEnd :: Word32 -> IO Word32
seekToEnd Word32
offset = do
Maybe (Entry, Word32)
mbe <- Handle -> Word32 -> IO (Maybe (Entry, Word32))
hReadEntryHeaderOrEof Handle
hnd Word32
offset
case Maybe (Entry, Word32)
mbe of
Maybe (Entry, Word32)
Nothing -> do Handle -> Word32 -> IO ()
hSeekEntryOffset Handle
hnd Word32
offset
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
offset
Just (Entry
_, Word32
offset') -> Word32 -> IO Word32
seekToEnd Word32
offset'
serialise :: TarIndex -> BS.ByteString
serialise :: TarIndex -> ByteString
serialise = ByteString -> ByteString
toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. TarIndex -> ByteString
serialiseLBS
serialiseLBS :: TarIndex -> LBS.ByteString
serialiseLBS :: TarIndex -> ByteString
serialiseLBS TarIndex
index =
AllocationStrategy -> ByteString -> Builder -> ByteString
BS.toLazyByteStringWith
(Int -> Int -> AllocationStrategy
BS.untrimmedStrategy (TarIndex -> Int
serialiseSize TarIndex
index) Int
512) ByteString
LBS.empty
(TarIndex -> Builder
serialiseBuilder TarIndex
index)
serialiseSize :: TarIndex -> Int
serialiseSize :: TarIndex -> Int
serialiseSize (TarIndex StringTable PathComponentId
stringTable IntTrie PathComponentId Word32
intTrie Word32
_) =
forall id. StringTable id -> Int
StringTable.serialiseSize StringTable PathComponentId
stringTable
forall a. Num a => a -> a -> a
+ forall k v. IntTrie k v -> Int
IntTrie.serialiseSize IntTrie PathComponentId Word32
intTrie
forall a. Num a => a -> a -> a
+ Int
8
serialiseBuilder :: TarIndex -> BS.Builder
serialiseBuilder :: TarIndex -> Builder
serialiseBuilder (TarIndex StringTable PathComponentId
stringTable IntTrie PathComponentId Word32
intTrie Word32
finalOffset) =
Word32 -> Builder
BS.word32BE Word32
2
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
BS.word32BE Word32
finalOffset
forall a. Semigroup a => a -> a -> a
<> forall id. StringTable id -> Builder
StringTable.serialise StringTable PathComponentId
stringTable
forall a. Semigroup a => a -> a -> a
<> forall k v. IntTrie k v -> Builder
IntTrie.serialise IntTrie PathComponentId Word32
intTrie
deserialise :: BS.ByteString -> Maybe (TarIndex, BS.ByteString)
deserialise :: ByteString -> Maybe (TarIndex, ByteString)
deserialise ByteString
bs
| ByteString -> Int
BS.length ByteString
bs forall a. Ord a => a -> a -> Bool
< Int
8
= forall a. Maybe a
Nothing
| let ver :: Word32
ver = ByteString -> Int -> Word32
readWord32BE ByteString
bs Int
0
, Word32
ver forall a. Eq a => a -> a -> Bool
== Word32
1
= do let !finalOffset :: Word32
finalOffset = ByteString -> Int -> Word32
readWord32BE ByteString
bs Int
4
(StringTable PathComponentId
stringTable, ByteString
bs') <- forall id. ByteString -> Maybe (StringTable id, ByteString)
StringTable.deserialiseV1 (Int -> ByteString -> ByteString
BS.drop Int
8 ByteString
bs)
(IntTrie PathComponentId Word32
intTrie, ByteString
bs'') <- forall k v. ByteString -> Maybe (IntTrie k v, ByteString)
IntTrie.deserialise ByteString
bs'
forall (m :: * -> *) a. Monad m => a -> m a
return (StringTable PathComponentId
-> IntTrie PathComponentId Word32 -> Word32 -> TarIndex
TarIndex StringTable PathComponentId
stringTable IntTrie PathComponentId Word32
intTrie Word32
finalOffset, ByteString
bs'')
| let ver :: Word32
ver = ByteString -> Int -> Word32
readWord32BE ByteString
bs Int
0
, Word32
ver forall a. Eq a => a -> a -> Bool
== Word32
2
= do let !finalOffset :: Word32
finalOffset = ByteString -> Int -> Word32
readWord32BE ByteString
bs Int
4
(StringTable PathComponentId
stringTable, ByteString
bs') <- forall id. ByteString -> Maybe (StringTable id, ByteString)
StringTable.deserialiseV2 (Int -> ByteString -> ByteString
BS.drop Int
8 ByteString
bs)
(IntTrie PathComponentId Word32
intTrie, ByteString
bs'') <- forall k v. ByteString -> Maybe (IntTrie k v, ByteString)
IntTrie.deserialise ByteString
bs'
forall (m :: * -> *) a. Monad m => a -> m a
return (StringTable PathComponentId
-> IntTrie PathComponentId Word32 -> Word32 -> TarIndex
TarIndex StringTable PathComponentId
stringTable IntTrie PathComponentId Word32
intTrie Word32
finalOffset, ByteString
bs'')
| Bool
otherwise = forall a. Maybe a
Nothing
readWord32BE :: BS.ByteString -> Int -> Word32
readWord32BE :: ByteString -> Int -> Word32
readWord32BE ByteString
bs Int
i =
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
i forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
iforall a. Num a => a -> a -> a
+Int
3 forall a. Ord a => a -> a -> Bool
<= ByteString -> Int
BS.length ByteString
bs forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word8
BS.unsafeIndex ByteString
bs (Int
i forall a. Num a => a -> a -> a
+ Int
0)) forall a. Bits a => a -> Int -> a
`shiftL` Int
24
forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word8
BS.unsafeIndex ByteString
bs (Int
i forall a. Num a => a -> a -> a
+ Int
1)) forall a. Bits a => a -> Int -> a
`shiftL` Int
16
forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word8
BS.unsafeIndex ByteString
bs (Int
i forall a. Num a => a -> a -> a
+ Int
2)) forall a. Bits a => a -> Int -> a
`shiftL` Int
8
forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word8
BS.unsafeIndex ByteString
bs (Int
i forall a. Num a => a -> a -> a
+ Int
3))
#ifdef TESTS
prop_lookup :: ValidPaths -> NonEmptyFilePath -> Bool
prop_lookup (ValidPaths paths) (NonEmptyFilePath p) =
case (lookup index p, Prelude.lookup p paths) of
(Nothing, Nothing) -> True
(Just (TarFileEntry offset), Just (_,offset')) -> offset == offset'
(Just (TarDir entries), Nothing) -> sort (nub (map fst entries))
== sort (nub completions)
_ -> False
where
index = construct paths
completions = [ head (FilePath.splitDirectories completion)
| (path,_) <- paths
, completion <- maybeToList $ stripPrefix (p ++ "/") path ]
prop_toList :: ValidPaths -> Bool
prop_toList (ValidPaths paths) =
sort (toList index)
== sort [ (path, off) | (path, (_sz, off)) <- paths ]
where
index = construct paths
prop_valid :: ValidPaths -> Bool
prop_valid (ValidPaths 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
index@(TarIndex pathTable _ _) = construct paths
pathbits = concatMap (map BS.Char8.pack . FilePath.splitDirectories . fst)
paths
intpaths = [ (cids, offset)
| (path, (_size, offset)) <- paths
, let Just cids = toComponentIds pathTable path ]
prop' = flip all paths $ \(file, (_size, offset)) ->
case lookup index file of
Just (TarFileEntry offset') -> offset' == offset
_ -> False
prop_serialise_deserialise :: ValidPaths -> Bool
prop_serialise_deserialise (ValidPaths paths) =
Just (index, BS.empty) == (deserialise . serialise) index
where
index = construct paths
prop_serialiseSize :: ValidPaths -> Bool
prop_serialiseSize (ValidPaths paths) =
case (LBS.toChunks . serialiseLBS) index of
[c1] -> BS.length c1 == serialiseSize index
_ -> False
where
index = construct paths
newtype NonEmptyFilePath = NonEmptyFilePath FilePath deriving Show
instance Arbitrary NonEmptyFilePath where
arbitrary = NonEmptyFilePath . FilePath.joinPath
<$> listOf1 (elements ["a", "b", "c", "d"])
newtype ValidPaths = ValidPaths [(FilePath, (Int64, TarEntryOffset))] deriving Show
instance Arbitrary ValidPaths where
arbitrary = do
paths <- makeNoPrefix <$> listOf arbitraryPath
sizes <- vectorOf (length paths) (getNonNegative <$> arbitrary)
let offsets = scanl (\o sz -> o + 1 + blocks sz) 0 sizes
return (ValidPaths (zip paths (zip sizes offsets)))
where
arbitraryPath = FilePath.joinPath
<$> listOf1 (elements ["a", "b", "c", "d"])
makeNoPrefix [] = []
makeNoPrefix (k:ks)
| all (not . isPrefixOfOther k) ks
= k : makeNoPrefix ks
| otherwise = makeNoPrefix ks
isPrefixOfOther a b = a `isPrefixOf` b || b `isPrefixOf` a
blocks :: Int64 -> TarEntryOffset
blocks size = fromIntegral (1 + ((size - 1) `div` 512))
construct :: [(FilePath, (Int64, TarEntryOffset))] -> TarIndex
construct =
either (\_ -> undefined) id
. build
. foldr (\(path, (size, _off)) es -> Next (testEntry path size) es) Done
example0 :: Entries ()
example0 =
testEntry "foo-1.0/foo-1.0.cabal" 1500
`Next` testEntry "foo-1.0/LICENSE" 2000
`Next` testEntry "foo-1.0/Data/Foo.hs" 1000
`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
data SimpleTarArchive = SimpleTarArchive {
simpleTarEntries :: Tar.Entries ()
, simpleTarRaw :: [(FilePath, LBS.ByteString)]
, simpleTarBS :: LBS.ByteString
}
instance Show SimpleTarArchive where
show = show . simpleTarRaw
prop_index_matches_tar :: SimpleTarArchive -> Property
prop_index_matches_tar sta =
ioProperty (try go >>= either (\e -> throwIO (e :: SomeException))
(\_ -> return True))
where
go :: IO ()
go = do
h <- HBS.readHandle True (simpleTarBS sta)
goEntries h 0 (simpleTarEntries sta)
goEntries :: Handle -> TarEntryOffset -> Tar.Entries () -> IO ()
goEntries _ _ Tar.Done =
return ()
goEntries _ _ (Tar.Fail _) =
throwIO (userError "Fail entry in SimpleTarArchive")
goEntries h offset (Tar.Next e es) = do
goEntry h offset e
goEntries h (nextEntryOffset e offset) es
goEntry :: Handle -> TarEntryOffset -> Tar.Entry -> IO ()
goEntry h offset e = do
e' <- hReadEntry h offset
case (Tar.entryContent e, Tar.entryContent e') of
(Tar.NormalFile bs sz, Tar.NormalFile bs' sz') ->
unless (sz == sz' && bs == bs') $
throwIO $ userError "Entry mismatch"
_otherwise ->
throwIO $ userError "unexpected entry types"
instance Arbitrary SimpleTarArchive where
arbitrary = do
numEntries <- sized $ \n -> choose (0, n)
rawEntries <- mkRaw numEntries
let entries = mkList rawEntries
return SimpleTarArchive {
simpleTarEntries = mkEntries entries
, simpleTarRaw = rawEntries
, simpleTarBS = Tar.write entries
}
where
mkRaw :: Int -> Gen [(FilePath, LBS.ByteString)]
mkRaw 0 = return []
mkRaw n = do
sz <- sized $ \n -> elements (take n fileSizes)
bs <- LBS.pack `fmap` vectorOf sz arbitrary
es <- mkRaw (n - 1)
return $ ("file" ++ show n, bs) : es
mkList :: [(FilePath, LBS.ByteString)] -> [Tar.Entry]
mkList [] = []
mkList ((fp, bs):es) = entry : mkList es
where
Right path = toTarPath False fp
entry = simpleEntry path content
content = NormalFile bs (LBS.length bs)
mkEntries :: [Tar.Entry] -> Tar.Entries ()
mkEntries [] = Tar.Done
mkEntries (e:es) = Tar.Next e (mkEntries es)
fileSizes :: [Int]
fileSizes = [
0 , 1 , 2
, 510 , 511 , 512 , 513 , 514
, 1022 , 1023 , 1024 , 1025 , 1026
]
newtype SimpleIndexBuilder = SimpleIndexBuilder IndexBuilder
deriving Show
instance Arbitrary SimpleIndexBuilder where
arbitrary = SimpleIndexBuilder . build' . simpleTarEntries <$> arbitrary
where
build' :: Show e => Entries e -> IndexBuilder
build' = go empty
where
go !builder (Next e es) = go (addNextEntry e builder) es
go !builder Done = builder
go !_ (Fail err) = error (show err)
prop_finalise_unfinalise :: SimpleIndexBuilder -> Bool
prop_finalise_unfinalise (SimpleIndexBuilder index) =
unfinalise (finalise index) == index
#endif
toStrict :: LBS.ByteString -> BS.ByteString
#if MIN_VERSION_bytestring(0,10,0)
toStrict :: ByteString -> ByteString
toStrict = ByteString -> ByteString
LBS.toStrict
#else
toStrict = BS.concat . LBS.toChunks
#endif
#if !(MIN_VERSION_base(4,5,0))
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
#endif