{-# 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)
data FormatError
= TruncatedArchive
| ShortTrailer
| BadTrailer
| TrailingJunk
| ChecksumIncorrect
| NotTarFormat
| UnrecognisedTarFormat
|
deriving (FormatError -> FormatError -> Bool
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
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 FormatError
TruncatedArchive = String
"truncated tar archive"
displayException FormatError
ShortTrailer = String
"short tar trailer"
displayException FormatError
BadTrailer = String
"bad tar trailer"
displayException FormatError
TrailingJunk = String
"tar file has trailing junk"
displayException FormatError
ChecksumIncorrect = String
"tar checksum error"
displayException FormatError
NotTarFormat = String
"data is not in tar format"
displayException FormatError
UnrecognisedTarFormat = String
"tar entry not in a recognised format"
displayException FormatError
HeaderBadNumericEncoding = String
"tar header is malformed (bad numeric encoding)"
instance NFData FormatError where
rnf :: FormatError -> ()
rnf !FormatError
_ = ()
read :: LBS.ByteString -> Entries FormatError
read :: ByteString -> Entries FormatError
read = forall a e tarPath linkTarget.
(a -> Either e (Maybe (GenEntry tarPath linkTarget, a)))
-> a -> GenEntries tarPath linkTarget 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 ByteString
bs
| ByteString -> Int
BS.length ByteString
header forall a. Ord a => a -> a -> Bool
< Int
512 = forall a b. a -> Either a b
Left FormatError
TruncatedArchive
| (Word8 -> Bool) -> ByteString -> Bool
LBS.all (forall a. Eq a => a -> a -> Bool
== Word8
0) (Int64 -> ByteString -> ByteString
LBS.take Int64
512 ByteString
bs) = case Int64 -> ByteString -> (ByteString, ByteString)
LBS.splitAt Int64
1024 ByteString
bs of
(ByteString
end, ByteString
trailing)
| ByteString -> Int64
LBS.length ByteString
end forall a. Eq a => a -> a -> Bool
/= Int64
1024 -> forall a b. a -> Either a b
Left FormatError
ShortTrailer
| Bool -> Bool
not ((Word8 -> Bool) -> ByteString -> Bool
LBS.all (forall a. Eq a => a -> a -> Bool
== Word8
0) ByteString
end) -> forall a b. a -> Either a b
Left FormatError
BadTrailer
| Bool -> Bool
not ((Word8 -> Bool) -> ByteString -> Bool
LBS.all (forall a. Eq a => a -> a -> Bool
== Word8
0) ByteString
trailing) -> forall a b. a -> Either a b
Left FormatError
TrailingJunk
| Bool
otherwise -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
| Bool
otherwise = do
case (Either FormatError Int
chksum_, Either FormatError Format
format_) of
(Right Int
chksum, Either FormatError Format
_ ) | ByteString -> Int -> Bool
correctChecksum ByteString
header Int
chksum -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Right Int
_, Right Format
_) -> forall a b. a -> Either a b
Left FormatError
ChecksumIncorrect
(Either FormatError Int, Either FormatError Format)
_ -> forall a b. a -> Either a b
Left FormatError
NotTarFormat
Format
format <- Either FormatError Format
format_; Permissions
mode <- Either FormatError Permissions
mode_;
Int
uid <- Either FormatError Int
uid_; Int
gid <- Either FormatError Int
gid_;
Int64
size <- Either FormatError Int64
size_; Int64
mtime <- Either FormatError Int64
mtime_;
Int
devmajor <- Either FormatError Int
devmajor_; Int
devminor <- Either FormatError Int
devminor_;
let content :: ByteString
content = Int64 -> ByteString -> ByteString
LBS.take Int64
size (Int64 -> ByteString -> ByteString
LBS.drop Int64
512 ByteString
bs)
padding :: Int64
padding = (Int64
512 forall a. Num a => a -> a -> a
- Int64
size) forall a. Integral a => a -> a -> a
`mod` Int64
512
bs' :: ByteString
bs' = Int64 -> ByteString -> ByteString
LBS.drop (Int64
512 forall a. Num a => a -> a -> a
+ Int64
size forall a. Num a => a -> a -> a
+ Int64
padding) ByteString
bs
entry :: Entry
entry = Entry {
entryTarPath :: TarPath
entryTarPath = ByteString -> ByteString -> TarPath
TarPath ByteString
name ByteString
prefix,
entryContent :: GenEntryContent LinkTarget
entryContent = case Char
typecode of
Char
'\0' -> forall linkTarget.
ByteString -> Int64 -> GenEntryContent linkTarget
NormalFile ByteString
content Int64
size
Char
'0' -> forall linkTarget.
ByteString -> Int64 -> GenEntryContent linkTarget
NormalFile ByteString
content Int64
size
Char
'1' -> forall linkTarget. linkTarget -> GenEntryContent linkTarget
HardLink (ByteString -> LinkTarget
LinkTarget ByteString
linkname)
Char
'2' -> forall linkTarget. linkTarget -> GenEntryContent linkTarget
SymbolicLink (ByteString -> LinkTarget
LinkTarget ByteString
linkname)
Char
_ | Format
format forall a. Eq a => a -> a -> Bool
== Format
V7Format
-> forall linkTarget.
Char -> ByteString -> Int64 -> GenEntryContent linkTarget
OtherEntryType Char
typecode ByteString
content Int64
size
Char
'3' -> forall linkTarget. Int -> Int -> GenEntryContent linkTarget
CharacterDevice Int
devmajor Int
devminor
Char
'4' -> forall linkTarget. Int -> Int -> GenEntryContent linkTarget
BlockDevice Int
devmajor Int
devminor
Char
'5' -> forall linkTarget. GenEntryContent linkTarget
Directory
Char
'6' -> forall linkTarget. GenEntryContent linkTarget
NamedPipe
Char
'7' -> forall linkTarget.
ByteString -> Int64 -> GenEntryContent linkTarget
NormalFile ByteString
content Int64
size
Char
_ -> forall linkTarget.
Char -> ByteString -> Int64 -> GenEntryContent linkTarget
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
}
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Entry
entry, ByteString
bs'))
where
header :: ByteString
header = ByteString -> ByteString
LBS.toStrict (Int64 -> ByteString -> ByteString
LBS.take Int64
512 ByteString
bs)
name :: ByteString
name = Int -> Int -> ByteString -> ByteString
getString Int
0 Int
100 ByteString
header
mode_ :: Either FormatError Permissions
mode_ = forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Either FormatError a
getOct Int
100 Int
8 ByteString
header
uid_ :: Either FormatError Int
uid_ = forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Either FormatError a
getOct Int
108 Int
8 ByteString
header
gid_ :: Either FormatError Int
gid_ = forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Either FormatError a
getOct Int
116 Int
8 ByteString
header
size_ :: Either FormatError Int64
size_ = forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Either FormatError a
getOct Int
124 Int
12 ByteString
header
mtime_ :: Either FormatError Int64
mtime_ = forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Either FormatError a
getOct Int
136 Int
12 ByteString
header
chksum_ :: Either FormatError Int
chksum_ = forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Either FormatError a
getOct Int
148 Int
8 ByteString
header
typecode :: Char
typecode = Int -> ByteString -> Char
getByte Int
156 ByteString
header
linkname :: ByteString
linkname = Int -> Int -> ByteString -> ByteString
getString Int
157 Int
100 ByteString
header
magic :: ByteString
magic = Int -> Int -> ByteString -> ByteString
getChars Int
257 Int
8 ByteString
header
uname :: ByteString
uname = Int -> Int -> ByteString -> ByteString
getString Int
265 Int
32 ByteString
header
gname :: ByteString
gname = Int -> Int -> ByteString -> ByteString
getString Int
297 Int
32 ByteString
header
devmajor_ :: Either FormatError Int
devmajor_ = forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Either FormatError a
getOct Int
329 Int
8 ByteString
header
devminor_ :: Either FormatError Int
devminor_ = forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Either FormatError a
getOct Int
337 Int
8 ByteString
header
prefix :: ByteString
prefix = Int -> Int -> ByteString -> ByteString
getString Int
345 Int
155 ByteString
header
format_ :: Either FormatError Format
format_
| ByteString
magic forall a. Eq a => a -> a -> Bool
== ByteString
ustarMagic = forall (m :: * -> *) a. Monad m => a -> m a
return Format
UstarFormat
| ByteString
magic forall a. Eq a => a -> a -> Bool
== ByteString
gnuMagic = forall (m :: * -> *) a. Monad m => a -> m a
return Format
GnuFormat
| ByteString
magic forall a. Eq a => a -> a -> Bool
== ByteString
v7Magic = forall (m :: * -> *) a. Monad m => a -> m a
return Format
V7Format
| Bool
otherwise = forall a b. a -> Either a b
Left FormatError
UnrecognisedTarFormat
v7Magic, ustarMagic, gnuMagic :: BS.ByteString
v7Magic :: ByteString
v7Magic = String -> ByteString
BS.Char8.pack String
"\0\0\0\0\0\0\0\0"
ustarMagic :: ByteString
ustarMagic = String -> ByteString
BS.Char8.pack String
"ustar\NUL00"
gnuMagic :: ByteString
gnuMagic = String -> ByteString
BS.Char8.pack String
"ustar \NUL"
correctChecksum :: BS.ByteString -> Int -> Bool
correctChecksum :: ByteString -> Int -> Bool
correctChecksum ByteString
header Int
checksum = Int
checksum forall a. Eq a => a -> a -> Bool
== Int
checksum'
where
sumchars :: ByteString -> Int
sumchars = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\Int
x Word8
y -> Int
x forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
y) Int
0
checksum' :: Int
checksum' = ByteString -> Int
sumchars (Int -> ByteString -> ByteString
BS.take Int
148 ByteString
header)
forall a. Num a => a -> a -> a
+ Int
256
forall a. Num a => a -> a -> a
+ ByteString -> Int
sumchars (Int -> ByteString -> ByteString
BS.drop Int
156 ByteString
header)
{-# SPECIALISE getOct :: Int -> Int -> BS.ByteString -> Either FormatError Int #-}
{-# SPECIALISE getOct :: Int -> Int -> BS.ByteString -> Either FormatError Int64 #-}
getOct :: (Integral a, Bits a) => Int -> Int -> BS.ByteString -> Either FormatError a
getOct :: forall a.
(Integral a, Bits a) =>
Int -> Int -> ByteString -> Either FormatError a
getOct Int
off Int
len = forall {a}.
(Integral a, Bits a) =>
ByteString -> Either FormatError a
parseOct forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ByteString -> ByteString
getBytes Int
off Int
len
where
parseOct :: ByteString -> Either FormatError a
parseOct ByteString
s | HasCallStack => ByteString -> Word8
BS.head ByteString
s forall a. Eq a => a -> a -> Bool
== Word8
128 = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. (Integral a, Bits a) => ByteString -> a
readBytes (HasCallStack => ByteString -> ByteString
BS.tail ByteString
s))
| HasCallStack => ByteString -> Word8
BS.head ByteString
s forall a. Eq a => a -> a -> Bool
== Word8
255 = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Num a => a -> a
negate (forall a. (Integral a, Bits a) => ByteString -> a
readBytes (HasCallStack => ByteString -> ByteString
BS.tail ByteString
s)))
parseOct ByteString
s
| ByteString -> Bool
BS.null ByteString
stripped = forall (m :: * -> *) a. Monad m => a -> m a
return a
0
| Bool
otherwise = case forall n. Integral n => ByteString -> Maybe n
readOct ByteString
stripped of
Just a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
Maybe a
Nothing -> forall a b. a -> Either a b
Left FormatError
HeaderBadNumericEncoding
where
stripped :: ByteString
stripped = (Char -> Bool) -> ByteString -> ByteString
BS.Char8.takeWhile (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\NUL' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
' ')
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BS.Char8.dropWhile (forall a. Eq a => a -> a -> Bool
== Char
' ') ByteString
s
readBytes :: (Integral a, Bits a) => BS.ByteString -> a
readBytes :: forall a. (Integral a, Bits a) => ByteString -> a
readBytes = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\a
acc Word8
x -> a
acc 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 Word8
x) a
0
getBytes :: Int -> Int -> BS.ByteString -> BS.ByteString
getBytes :: Int -> Int -> ByteString -> ByteString
getBytes Int
off Int
len = Int -> ByteString -> ByteString
BS.take Int
len 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 Int
off 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 = Int -> Int -> ByteString -> ByteString
getBytes
getString :: Int -> Int -> BS.ByteString -> BS.ByteString
getString :: Int -> Int -> ByteString -> ByteString
getString Int
off Int
len = ByteString -> ByteString
BS.copy forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
BS.Char8.takeWhile (forall a. Eq a => a -> a -> Bool
/=Char
'\0') forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ByteString -> ByteString
getBytes Int
off Int
len
{-# SPECIALISE readOct :: BS.ByteString -> Maybe Int #-}
{-# SPECIALISE readOct :: BS.ByteString -> Maybe Int64 #-}
readOct :: Integral n => BS.ByteString -> Maybe n
readOct :: forall n. Integral n => ByteString -> Maybe n
readOct = forall n. Integral n => Int -> n -> ByteString -> Maybe n
go Int
0 n
0
where
go :: Integral n => Int -> n -> BS.ByteString -> Maybe n
go :: forall n. Integral n => Int -> n -> ByteString -> Maybe n
go !Int
i !n
n !ByteString
bs = case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs of
Maybe (Word8, ByteString)
Nothing -> if Int
i forall a. Eq a => a -> a -> Bool
== Int
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just n
n
Just (Word8
w, ByteString
tl)
| Word8
w forall a. Ord a => a -> a -> Bool
>= Word8
0x30 Bool -> Bool -> Bool
&& Word8
w forall a. Ord a => a -> a -> Bool
<= Word8
0x39 ->
forall n. Integral n => Int -> n -> ByteString -> Maybe n
go (Int
iforall a. Num a => a -> a -> a
+Int
1) (n
n forall a. Num a => a -> a -> a
* n
8 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w forall a. Num a => a -> a -> a
- n
0x30)) ByteString
tl
| Bool
otherwise -> forall a. Maybe a
Nothing