{-# LANGUAGE CPP, DeriveDataTypeable, BangPatterns #-}
module Codec.Archive.Tar.Read (read, FormatError(..)) where
import Codec.Archive.Tar.Types
import Data.Char (ord)
import Data.Int (Int64)
import Data.Bits (Bits(shiftL))
import Control.Exception (Exception(..))
import Data.Typeable (Typeable)
import Control.Applicative
import Control.Monad
import Control.DeepSeq
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.Char8
import qualified Data.ByteString.Unsafe as BS
import qualified Data.ByteString.Lazy as LBS
import Prelude hiding (read)
#if !MIN_VERSION_bytestring(0,10,0)
import Data.Monoid (Monoid(..))
import qualified Data.ByteString.Lazy.Internal as LBS
#endif
data FormatError
= TruncatedArchive
| ShortTrailer
| BadTrailer
| TrailingJunk
| ChecksumIncorrect
| NotTarFormat
| UnrecognisedTarFormat
|
#if MIN_VERSION_base(4,8,0)
deriving (FormatError -> FormatError -> Bool
(FormatError -> FormatError -> Bool)
-> (FormatError -> FormatError -> Bool) -> Eq FormatError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FormatError -> FormatError -> Bool
$c/= :: FormatError -> FormatError -> Bool
== :: FormatError -> FormatError -> Bool
$c== :: FormatError -> FormatError -> Bool
Eq, Int -> FormatError -> ShowS
[FormatError] -> ShowS
FormatError -> String
(Int -> FormatError -> ShowS)
-> (FormatError -> String)
-> ([FormatError] -> ShowS)
-> Show FormatError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FormatError] -> ShowS
$cshowList :: [FormatError] -> ShowS
show :: FormatError -> String
$cshow :: FormatError -> String
showsPrec :: Int -> FormatError -> ShowS
$cshowsPrec :: Int -> FormatError -> ShowS
Show, Typeable)
instance Exception FormatError where
displayException :: FormatError -> String
displayException TruncatedArchive = "truncated tar archive"
displayException ShortTrailer = "short tar trailer"
displayException BadTrailer = "bad tar trailer"
displayException TrailingJunk = "tar file has trailing junk"
displayException ChecksumIncorrect = "tar checksum error"
displayException NotTarFormat = "data is not in tar format"
displayException UnrecognisedTarFormat = "tar entry not in a recognised format"
displayException HeaderBadNumericEncoding = "tar header is malformed (bad numeric encoding)"
#else
deriving (Eq, Typeable)
instance Show FormatError where
show TruncatedArchive = "truncated tar archive"
show ShortTrailer = "short tar trailer"
show BadTrailer = "bad tar trailer"
show TrailingJunk = "tar file has trailing junk"
show ChecksumIncorrect = "tar checksum error"
show NotTarFormat = "data is not in tar format"
show UnrecognisedTarFormat = "tar entry not in a recognised format"
show HeaderBadNumericEncoding = "tar header is malformed (bad numeric encoding)"
instance Exception FormatError
#endif
instance NFData FormatError where
rnf :: FormatError -> ()
rnf !FormatError
_ = ()
read :: LBS.ByteString -> Entries FormatError
read :: ByteString -> Entries FormatError
read = (ByteString -> Either FormatError (Maybe (Entry, ByteString)))
-> ByteString -> Entries FormatError
forall a e. (a -> Either e (Maybe (Entry, a))) -> a -> Entries e
unfoldEntries ByteString -> Either FormatError (Maybe (Entry, ByteString))
getEntry
getEntry :: LBS.ByteString -> Either FormatError (Maybe (Entry, LBS.ByteString))
getEntry :: ByteString -> Either FormatError (Maybe (Entry, ByteString))
getEntry bs :: ByteString
bs
| ByteString -> Int
BS.length ByteString
header Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 512 = FormatError -> Either FormatError (Maybe (Entry, ByteString))
forall a b. a -> Either a b
Left FormatError
TruncatedArchive
| ByteString -> Word8
LBS.head ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = case Int64 -> ByteString -> (ByteString, ByteString)
LBS.splitAt 1024 ByteString
bs of
(end :: ByteString
end, trailing :: ByteString
trailing)
| ByteString -> Int64
LBS.length ByteString
end Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= 1024 -> FormatError -> Either FormatError (Maybe (Entry, ByteString))
forall a b. a -> Either a b
Left FormatError
ShortTrailer
| Bool -> Bool
not ((Word8 -> Bool) -> ByteString -> Bool
LBS.all (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0) ByteString
end) -> FormatError -> Either FormatError (Maybe (Entry, ByteString))
forall a b. a -> Either a b
Left FormatError
BadTrailer
| Bool -> Bool
not ((Word8 -> Bool) -> ByteString -> Bool
LBS.all (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0) ByteString
trailing) -> FormatError -> Either FormatError (Maybe (Entry, ByteString))
forall a b. a -> Either a b
Left FormatError
TrailingJunk
| Bool
otherwise -> Maybe (Entry, ByteString)
-> Either FormatError (Maybe (Entry, ByteString))
forall a b. b -> Either a b
Right Maybe (Entry, ByteString)
forall a. Maybe a
Nothing
| Bool
otherwise = Partial FormatError (Maybe (Entry, ByteString))
-> Either FormatError (Maybe (Entry, ByteString))
forall e a. Partial e a -> Either e a
partial (Partial FormatError (Maybe (Entry, ByteString))
-> Either FormatError (Maybe (Entry, ByteString)))
-> Partial FormatError (Maybe (Entry, ByteString))
-> Either FormatError (Maybe (Entry, ByteString))
forall a b. (a -> b) -> a -> b
$ do
case (Partial FormatError Int
chksum_, Partial FormatError Format
format_) of
(Ok chksum :: Int
chksum, _ ) | ByteString -> Int -> Bool
correctChecksum ByteString
header Int
chksum -> () -> Partial FormatError ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Ok _, Ok _) -> FormatError -> Partial FormatError ()
forall e a. e -> Partial e a
Error FormatError
ChecksumIncorrect
_ -> FormatError -> Partial FormatError ()
forall e a. e -> Partial e a
Error FormatError
NotTarFormat
Format
format <- Partial FormatError Format
format_; Permissions
mode <- Partial FormatError Permissions
mode_;
Int
uid <- Partial FormatError Int
uid_; Int
gid <- Partial FormatError Int
gid_;
Int64
size <- Partial FormatError Int64
size_; Int64
mtime <- Partial FormatError Int64
mtime_;
Int
devmajor <- Partial FormatError Int
devmajor_; Int
devminor <- Partial FormatError Int
devminor_;
let content :: ByteString
content = Int64 -> ByteString -> ByteString
LBS.take Int64
size (Int64 -> ByteString -> ByteString
LBS.drop 512 ByteString
bs)
padding :: Int64
padding = (512 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
size) Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`mod` 512
bs' :: ByteString
bs' = Int64 -> ByteString -> ByteString
LBS.drop (512 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
size Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
padding) ByteString
bs
entry :: Entry
entry = $WEntry :: TarPath
-> EntryContent
-> Permissions
-> Ownership
-> Int64
-> Format
-> Entry
Entry {
entryTarPath :: TarPath
entryTarPath = ByteString -> ByteString -> TarPath
TarPath ByteString
name ByteString
prefix,
entryContent :: EntryContent
entryContent = case Char
typecode of
'\0' -> ByteString -> Int64 -> EntryContent
NormalFile ByteString
content Int64
size
'0' -> ByteString -> Int64 -> EntryContent
NormalFile ByteString
content Int64
size
'1' -> LinkTarget -> EntryContent
HardLink (ByteString -> LinkTarget
LinkTarget ByteString
linkname)
'2' -> LinkTarget -> EntryContent
SymbolicLink (ByteString -> LinkTarget
LinkTarget ByteString
linkname)
_ | Format
format Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
V7Format
-> Char -> ByteString -> Int64 -> EntryContent
OtherEntryType Char
typecode ByteString
content Int64
size
'3' -> Int -> Int -> EntryContent
CharacterDevice Int
devmajor Int
devminor
'4' -> Int -> Int -> EntryContent
BlockDevice Int
devmajor Int
devminor
'5' -> EntryContent
Directory
'6' -> EntryContent
NamedPipe
'7' -> ByteString -> Int64 -> EntryContent
NormalFile ByteString
content Int64
size
_ -> Char -> ByteString -> Int64 -> EntryContent
OtherEntryType Char
typecode ByteString
content Int64
size,
entryPermissions :: Permissions
entryPermissions = Permissions
mode,
entryOwnership :: Ownership
entryOwnership = String -> String -> Int -> Int -> Ownership
Ownership (ByteString -> String
BS.Char8.unpack ByteString
uname)
(ByteString -> String
BS.Char8.unpack ByteString
gname) Int
uid Int
gid,
entryTime :: Int64
entryTime = Int64
mtime,
entryFormat :: Format
entryFormat = Format
format
}
Maybe (Entry, ByteString)
-> Partial FormatError (Maybe (Entry, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Entry, ByteString) -> Maybe (Entry, ByteString)
forall a. a -> Maybe a
Just (Entry
entry, ByteString
bs'))
where
#if MIN_VERSION_bytestring(0,10,0)
header :: ByteString
header = ByteString -> ByteString
LBS.toStrict (Int64 -> ByteString -> ByteString
LBS.take 512 ByteString
bs)
#else
header = toStrict (LBS.take 512 bs)
toStrict = LBS.foldrChunks mappend mempty
#endif
name :: ByteString
name = Int -> Int -> ByteString -> ByteString
getString 0 100 ByteString
header
mode_ :: Partial FormatError Permissions
mode_ = Int -> Int -> ByteString -> Partial FormatError Permissions
forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Partial FormatError a
getOct 100 8 ByteString
header
uid_ :: Partial FormatError Int
uid_ = Int -> Int -> ByteString -> Partial FormatError Int
forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Partial FormatError a
getOct 108 8 ByteString
header
gid_ :: Partial FormatError Int
gid_ = Int -> Int -> ByteString -> Partial FormatError Int
forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Partial FormatError a
getOct 116 8 ByteString
header
size_ :: Partial FormatError Int64
size_ = Int -> Int -> ByteString -> Partial FormatError Int64
forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Partial FormatError a
getOct 124 12 ByteString
header
mtime_ :: Partial FormatError Int64
mtime_ = Int -> Int -> ByteString -> Partial FormatError Int64
forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Partial FormatError a
getOct 136 12 ByteString
header
chksum_ :: Partial FormatError Int
chksum_ = Int -> Int -> ByteString -> Partial FormatError Int
forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Partial FormatError a
getOct 148 8 ByteString
header
typecode :: Char
typecode = Int -> ByteString -> Char
getByte 156 ByteString
header
linkname :: ByteString
linkname = Int -> Int -> ByteString -> ByteString
getString 157 100 ByteString
header
magic :: ByteString
magic = Int -> Int -> ByteString -> ByteString
getChars 257 8 ByteString
header
uname :: ByteString
uname = Int -> Int -> ByteString -> ByteString
getString 265 32 ByteString
header
gname :: ByteString
gname = Int -> Int -> ByteString -> ByteString
getString 297 32 ByteString
header
devmajor_ :: Partial FormatError Int
devmajor_ = Int -> Int -> ByteString -> Partial FormatError Int
forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Partial FormatError a
getOct 329 8 ByteString
header
devminor_ :: Partial FormatError Int
devminor_ = Int -> Int -> ByteString -> Partial FormatError Int
forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Partial FormatError a
getOct 337 8 ByteString
header
prefix :: ByteString
prefix = Int -> Int -> ByteString -> ByteString
getString 345 155 ByteString
header
format_ :: Partial FormatError Format
format_
| ByteString
magic ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
ustarMagic = Format -> Partial FormatError Format
forall (m :: * -> *) a. Monad m => a -> m a
return Format
UstarFormat
| ByteString
magic ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
gnuMagic = Format -> Partial FormatError Format
forall (m :: * -> *) a. Monad m => a -> m a
return Format
GnuFormat
| ByteString
magic ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
v7Magic = Format -> Partial FormatError Format
forall (m :: * -> *) a. Monad m => a -> m a
return Format
V7Format
| Bool
otherwise = FormatError -> Partial FormatError Format
forall e a. e -> Partial e a
Error FormatError
UnrecognisedTarFormat
v7Magic, ustarMagic, gnuMagic :: BS.ByteString
v7Magic :: ByteString
v7Magic = String -> ByteString
BS.Char8.pack "\0\0\0\0\0\0\0\0"
ustarMagic :: ByteString
ustarMagic = String -> ByteString
BS.Char8.pack "ustar\NUL00"
gnuMagic :: ByteString
gnuMagic = String -> ByteString
BS.Char8.pack "ustar \NUL"
correctChecksum :: BS.ByteString -> Int -> Bool
correctChecksum :: ByteString -> Int -> Bool
correctChecksum header :: ByteString
header checksum :: Int
checksum = Int
checksum Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
checksum'
where
sumchars :: ByteString -> Int
sumchars = (Int -> Word8 -> Int) -> Int -> ByteString -> Int
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\x :: Int
x y :: Word8
y -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
y) 0
checksum' :: Int
checksum' = ByteString -> Int
sumchars (Int -> ByteString -> ByteString
BS.take 148 ByteString
header)
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 256
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
sumchars (Int -> ByteString -> ByteString
BS.drop 156 ByteString
header)
{-# SPECIALISE getOct :: Int -> Int -> BS.ByteString -> Partial FormatError Int #-}
{-# SPECIALISE getOct :: Int -> Int -> BS.ByteString -> Partial FormatError Int64 #-}
getOct :: (Integral a, Bits a) => Int -> Int -> BS.ByteString -> Partial FormatError a
getOct :: Int -> Int -> ByteString -> Partial FormatError a
getOct off :: Int
off len :: Int
len = ByteString -> Partial FormatError a
forall a.
(Integral a, Bits a) =>
ByteString -> Partial FormatError a
parseOct
(ByteString -> Partial FormatError a)
-> (ByteString -> ByteString)
-> ByteString
-> Partial FormatError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
BS.Char8.takeWhile (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\NUL' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ' ')
(ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
BS.Char8.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ')
(ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ByteString -> ByteString
getBytes Int
off Int
len
where
parseOct :: ByteString -> Partial FormatError a
parseOct s :: ByteString
s | ByteString -> Bool
BS.null ByteString
s = a -> Partial FormatError a
forall (m :: * -> *) a. Monad m => a -> m a
return 0
parseOct s :: ByteString
s | ByteString -> Word8
BS.head ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 128 = a -> Partial FormatError a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> a
forall a. (Integral a, Bits a) => ByteString -> a
readBytes (ByteString -> ByteString
BS.tail ByteString
s))
| ByteString -> Word8
BS.head ByteString
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 255 = a -> Partial FormatError a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a
forall a. Num a => a -> a
negate (ByteString -> a
forall a. (Integral a, Bits a) => ByteString -> a
readBytes (ByteString -> ByteString
BS.tail ByteString
s)))
parseOct s :: ByteString
s = case ByteString -> Maybe a
forall n. Integral n => ByteString -> Maybe n
readOct ByteString
s of
Just x :: a
x -> a -> Partial FormatError a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
Nothing -> FormatError -> Partial FormatError a
forall e a. e -> Partial e a
Error FormatError
HeaderBadNumericEncoding
readBytes :: (Integral a, Bits a) => BS.ByteString -> a
readBytes :: ByteString -> a
readBytes = (a -> Word8 -> a) -> a -> ByteString -> a
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\acc :: a
acc x :: Word8
x -> a
acc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` 8 a -> a -> a
forall a. Num a => a -> a -> a
+ Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x) 0
getBytes :: Int -> Int -> BS.ByteString -> BS.ByteString
getBytes :: Int -> Int -> ByteString -> ByteString
getBytes off :: Int
off len :: Int
len = Int -> ByteString -> ByteString
BS.take Int
len (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.drop Int
off
getByte :: Int -> BS.ByteString -> Char
getByte :: Int -> ByteString -> Char
getByte off :: Int
off bs :: ByteString
bs = ByteString -> Int -> Char
BS.Char8.index ByteString
bs Int
off
getChars :: Int -> Int -> BS.ByteString -> BS.ByteString
getChars :: Int -> Int -> ByteString -> ByteString
getChars off :: Int
off len :: Int
len = Int -> Int -> ByteString -> ByteString
getBytes Int
off Int
len
getString :: Int -> Int -> BS.ByteString -> BS.ByteString
getString :: Int -> Int -> ByteString -> ByteString
getString off :: Int
off len :: Int
len = ByteString -> ByteString
BS.copy (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
BS.Char8.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='\0') (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ByteString -> ByteString
getBytes Int
off Int
len
data Partial e a = Error e | Ok a
partial :: Partial e a -> Either e a
partial :: Partial e a -> Either e a
partial (Error msg :: e
msg) = e -> Either e a
forall a b. a -> Either a b
Left e
msg
partial (Ok x :: a
x) = a -> Either e a
forall a b. b -> Either a b
Right a
x
instance Functor (Partial e) where
fmap :: (a -> b) -> Partial e a -> Partial e b
fmap = (a -> b) -> Partial e a -> Partial e b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative (Partial e) where
pure :: a -> Partial e a
pure = a -> Partial e a
forall e a. a -> Partial e a
Ok
<*> :: Partial e (a -> b) -> Partial e a -> Partial e b
(<*>) = Partial e (a -> b) -> Partial e a -> Partial e b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad (Partial e) where
return :: a -> Partial e a
return = a -> Partial e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Error m :: e
m >>= :: Partial e a -> (a -> Partial e b) -> Partial e b
>>= _ = e -> Partial e b
forall e a. e -> Partial e a
Error e
m
Ok x :: a
x >>= k :: a -> Partial e b
k = a -> Partial e b
k a
x
#if !MIN_VERSION_base(4,13,0)
fail = error "fail @(Partial e)"
#endif
{-# SPECIALISE readOct :: BS.ByteString -> Maybe Int #-}
{-# SPECIALISE readOct :: BS.ByteString -> Maybe Int64 #-}
readOct :: Integral n => BS.ByteString -> Maybe n
readOct :: ByteString -> Maybe n
readOct bs0 :: ByteString
bs0 = case Int -> n -> ByteString -> n
forall n. Integral n => Int -> n -> ByteString -> n
go 0 0 ByteString
bs0 of
-1 -> Maybe n
forall a. Maybe a
Nothing
n :: n
n -> n -> Maybe n
forall a. a -> Maybe a
Just n
n
where
go :: Integral n => Int -> n -> BS.ByteString -> n
go :: Int -> n -> ByteString -> n
go !Int
i !n
n !ByteString
bs
| ByteString -> Bool
BS.null ByteString
bs = if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then -1 else n
n
| Bool
otherwise =
case ByteString -> Word8
BS.unsafeHead ByteString
bs of
w :: Word8
w | Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= 0x30
Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x39 -> Int -> n -> ByteString -> n
forall n. Integral n => Int -> n -> ByteString -> n
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
(n
n n -> n -> n
forall a. Num a => a -> a -> a
* 8 n -> n -> n
forall a. Num a => a -> a -> a
+ (Word8 -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w n -> n -> n
forall a. Num a => a -> a -> a
- 0x30))
(ByteString -> ByteString
BS.unsafeTail ByteString
bs)
| Bool
otherwise -> -1