{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Codec.Archive.Tar.Types
-- Copyright   :  (c) 2007 Bjorn Bringert,
--                    2008 Andrea Vezzosi,
--                    2008-2009 Duncan Coutts
--                    2011 Max Bolingbroke
-- License     :  BSD3
--
-- Maintainer  :  duncan@community.haskell.org
-- Portability :  portable
--
-- Types to represent the content of @.tar@ archives.
--
-----------------------------------------------------------------------------
module Codec.Archive.Tar.Types (

  Entry(..),
  entryPath,
  EntryContent(..),
  FileSize,
  Permissions,
  Ownership(..),
  EpochTime,
  TypeCode,
  DevMajor,
  DevMinor,
  Format(..),

  simpleEntry,
  fileEntry,
  directoryEntry,

  ordinaryFilePermissions,
  executableFilePermissions,
  directoryPermissions,

  TarPath(..),
  toTarPath,
  fromTarPath,
  fromTarPathToPosixPath,
  fromTarPathToWindowsPath,

  LinkTarget(..),
  toLinkTarget,
  fromLinkTarget,
  fromLinkTargetToPosixPath,
  fromLinkTargetToWindowsPath,

  Entries(..),
  mapEntries,
  mapEntriesNoFail,
  foldEntries,
  foldlEntries,
  unfoldEntries,

#ifdef TESTS
  limitToV7FormatCompat
#endif
  ) where

import Data.Int      (Int64)
import Data.Monoid   (Monoid(..))
import Data.Semigroup as Sem
import qualified Data.ByteString       as BS
import qualified Data.ByteString.Char8 as BS.Char8
import qualified Data.ByteString.Lazy  as LBS
import Control.DeepSeq

import qualified System.FilePath as FilePath.Native
         ( joinPath, splitDirectories, addTrailingPathSeparator )
import qualified System.FilePath.Posix as FilePath.Posix
         ( joinPath, splitPath, splitDirectories, hasTrailingPathSeparator
         , addTrailingPathSeparator )
import qualified System.FilePath.Windows as FilePath.Windows
         ( joinPath, addTrailingPathSeparator )
import System.Posix.Types
         ( FileMode )

#ifdef TESTS
import Test.QuickCheck
import Control.Applicative ((<$>), (<*>), pure)
import Data.Word (Word16)
#endif


type FileSize  = Int64
-- | The number of seconds since the UNIX epoch
type EpochTime = Int64
type DevMajor  = Int
type DevMinor  = Int
type TypeCode  = Char
type Permissions = FileMode

-- | Tar archive entry.
--
data Entry = Entry {

    -- | The path of the file or directory within the archive. This is in a
    -- tar-specific form. Use 'entryPath' to get a native 'FilePath'.
    Entry -> TarPath
entryTarPath :: {-# UNPACK #-} !TarPath,

    -- | The real content of the entry. For 'NormalFile' this includes the
    -- file data. An entry usually contains a 'NormalFile' or a 'Directory'.
    Entry -> EntryContent
entryContent :: !EntryContent,

    -- | File permissions (Unix style file mode).
    Entry -> Permissions
entryPermissions :: {-# UNPACK #-} !Permissions,

    -- | The user and group to which this file belongs.
    Entry -> Ownership
entryOwnership :: {-# UNPACK #-} !Ownership,

    -- | The time the file was last modified.
    Entry -> EpochTime
entryTime :: {-# UNPACK #-} !EpochTime,

    -- | The tar format the archive is using.
    Entry -> Format
entryFormat :: !Format
  }
  deriving (Entry -> Entry -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Entry -> Entry -> Bool
$c/= :: Entry -> Entry -> Bool
== :: Entry -> Entry -> Bool
$c== :: Entry -> Entry -> Bool
Eq, Int -> Entry -> ShowS
[Entry] -> ShowS
Entry -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Entry] -> ShowS
$cshowList :: [Entry] -> ShowS
show :: Entry -> String
$cshow :: Entry -> String
showsPrec :: Int -> Entry -> ShowS
$cshowsPrec :: Int -> Entry -> ShowS
Show)

-- | Native 'FilePath' of the file or directory within the archive.
--
entryPath :: Entry -> FilePath
entryPath :: Entry -> String
entryPath = TarPath -> String
fromTarPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> TarPath
entryTarPath

-- | The content of a tar archive entry, which depends on the type of entry.
--
-- Portable archives should contain only 'NormalFile' and 'Directory'.
--
data EntryContent = NormalFile      LBS.ByteString {-# UNPACK #-} !FileSize
                  | Directory
                  | SymbolicLink    !LinkTarget
                  | HardLink        !LinkTarget
                  | CharacterDevice {-# UNPACK #-} !DevMajor
                                    {-# UNPACK #-} !DevMinor
                  | BlockDevice     {-# UNPACK #-} !DevMajor
                                    {-# UNPACK #-} !DevMinor
                  | NamedPipe
                  | OtherEntryType  {-# UNPACK #-} !TypeCode LBS.ByteString
                                    {-# UNPACK #-} !FileSize
    deriving (EntryContent -> EntryContent -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EntryContent -> EntryContent -> Bool
$c/= :: EntryContent -> EntryContent -> Bool
== :: EntryContent -> EntryContent -> Bool
$c== :: EntryContent -> EntryContent -> Bool
Eq, Eq EntryContent
EntryContent -> EntryContent -> Bool
EntryContent -> EntryContent -> Ordering
EntryContent -> EntryContent -> EntryContent
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 :: EntryContent -> EntryContent -> EntryContent
$cmin :: EntryContent -> EntryContent -> EntryContent
max :: EntryContent -> EntryContent -> EntryContent
$cmax :: EntryContent -> EntryContent -> EntryContent
>= :: EntryContent -> EntryContent -> Bool
$c>= :: EntryContent -> EntryContent -> Bool
> :: EntryContent -> EntryContent -> Bool
$c> :: EntryContent -> EntryContent -> Bool
<= :: EntryContent -> EntryContent -> Bool
$c<= :: EntryContent -> EntryContent -> Bool
< :: EntryContent -> EntryContent -> Bool
$c< :: EntryContent -> EntryContent -> Bool
compare :: EntryContent -> EntryContent -> Ordering
$ccompare :: EntryContent -> EntryContent -> Ordering
Ord, Int -> EntryContent -> ShowS
[EntryContent] -> ShowS
EntryContent -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EntryContent] -> ShowS
$cshowList :: [EntryContent] -> ShowS
show :: EntryContent -> String
$cshow :: EntryContent -> String
showsPrec :: Int -> EntryContent -> ShowS
$cshowsPrec :: Int -> EntryContent -> ShowS
Show)

data Ownership = Ownership {
    -- | The owner user name. Should be set to @\"\"@ if unknown.
    Ownership -> String
ownerName :: String,

    -- | The owner group name. Should be set to @\"\"@ if unknown.
    Ownership -> String
groupName :: String,

    -- | Numeric owner user id. Should be set to @0@ if unknown.
    Ownership -> Int
ownerId :: {-# UNPACK #-} !Int,

    -- | Numeric owner group id. Should be set to @0@ if unknown.
    Ownership -> Int
groupId :: {-# UNPACK #-} !Int
  }
    deriving (Ownership -> Ownership -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ownership -> Ownership -> Bool
$c/= :: Ownership -> Ownership -> Bool
== :: Ownership -> Ownership -> Bool
$c== :: Ownership -> Ownership -> Bool
Eq, Eq Ownership
Ownership -> Ownership -> Bool
Ownership -> Ownership -> Ordering
Ownership -> Ownership -> Ownership
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 :: Ownership -> Ownership -> Ownership
$cmin :: Ownership -> Ownership -> Ownership
max :: Ownership -> Ownership -> Ownership
$cmax :: Ownership -> Ownership -> Ownership
>= :: Ownership -> Ownership -> Bool
$c>= :: Ownership -> Ownership -> Bool
> :: Ownership -> Ownership -> Bool
$c> :: Ownership -> Ownership -> Bool
<= :: Ownership -> Ownership -> Bool
$c<= :: Ownership -> Ownership -> Bool
< :: Ownership -> Ownership -> Bool
$c< :: Ownership -> Ownership -> Bool
compare :: Ownership -> Ownership -> Ordering
$ccompare :: Ownership -> Ownership -> Ordering
Ord, Int -> Ownership -> ShowS
[Ownership] -> ShowS
Ownership -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ownership] -> ShowS
$cshowList :: [Ownership] -> ShowS
show :: Ownership -> String
$cshow :: Ownership -> String
showsPrec :: Int -> Ownership -> ShowS
$cshowsPrec :: Int -> Ownership -> ShowS
Show)

-- | There have been a number of extensions to the tar file format over the
-- years. They all share the basic entry fields and put more meta-data in
-- different extended headers.
--
data Format =

     -- | This is the classic Unix V7 tar format. It does not support owner and
     -- group names, just numeric Ids. It also does not support device numbers.
     V7Format

     -- | The \"USTAR\" format is an extension of the classic V7 format. It was
     -- later standardised by POSIX. It has some restrictions but is the most
     -- portable format.
     --
   | UstarFormat

     -- | The GNU tar implementation also extends the classic V7 format, though
     -- in a slightly different way from the USTAR format. In general for new
     -- archives the standard USTAR/POSIX should be used.
     --
   | GnuFormat
  deriving (Format -> Format -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Format -> Format -> Bool
$c/= :: Format -> Format -> Bool
== :: Format -> Format -> Bool
$c== :: Format -> Format -> Bool
Eq, Eq Format
Format -> Format -> Bool
Format -> Format -> Ordering
Format -> Format -> Format
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 :: Format -> Format -> Format
$cmin :: Format -> Format -> Format
max :: Format -> Format -> Format
$cmax :: Format -> Format -> Format
>= :: Format -> Format -> Bool
$c>= :: Format -> Format -> Bool
> :: Format -> Format -> Bool
$c> :: Format -> Format -> Bool
<= :: Format -> Format -> Bool
$c<= :: Format -> Format -> Bool
< :: Format -> Format -> Bool
$c< :: Format -> Format -> Bool
compare :: Format -> Format -> Ordering
$ccompare :: Format -> Format -> Ordering
Ord, Int -> Format -> ShowS
[Format] -> ShowS
Format -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Format] -> ShowS
$cshowList :: [Format] -> ShowS
show :: Format -> String
$cshow :: Format -> String
showsPrec :: Int -> Format -> ShowS
$cshowsPrec :: Int -> Format -> ShowS
Show)

instance NFData Entry where
  rnf :: Entry -> ()
rnf (Entry TarPath
_ EntryContent
c Permissions
_ Ownership
_ EpochTime
_ Format
_) = forall a. NFData a => a -> ()
rnf EntryContent
c

instance NFData EntryContent where
  rnf :: EntryContent -> ()
rnf EntryContent
x = case EntryContent
x of
      NormalFile       ByteString
c EpochTime
_  -> ByteString -> ()
rnflbs ByteString
c
      OtherEntryType TypeCode
_ ByteString
c EpochTime
_  -> ByteString -> ()
rnflbs ByteString
c
      EntryContent
_                     -> seq :: forall a b. a -> b -> b
seq EntryContent
x ()
    where
#if MIN_VERSION_bytestring(0,10,0)
      rnflbs :: ByteString -> ()
rnflbs = forall a. NFData a => a -> ()
rnf
#else
      rnflbs = foldr (\ !_bs r -> r) () . LBS.toChunks
#endif

instance NFData Ownership where
  rnf :: Ownership -> ()
rnf (Ownership String
o String
g Int
_ Int
_) = forall a. NFData a => a -> ()
rnf String
o seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf String
g

-- | @rw-r--r--@ for normal files
ordinaryFilePermissions :: Permissions
ordinaryFilePermissions :: Permissions
ordinaryFilePermissions   = Permissions
0o0644

-- | @rwxr-xr-x@ for executable files
executableFilePermissions :: Permissions
executableFilePermissions :: Permissions
executableFilePermissions = Permissions
0o0755

-- | @rwxr-xr-x@ for directories
directoryPermissions :: Permissions
directoryPermissions :: Permissions
directoryPermissions  = Permissions
0o0755

-- | An 'Entry' with all default values except for the file name and type. It
-- uses the portable USTAR/POSIX format (see 'UstarHeader').
--
-- You can use this as a basis and override specific fields, eg:
--
-- > (emptyEntry name HardLink) { linkTarget = target }
--
simpleEntry :: TarPath -> EntryContent -> Entry
simpleEntry :: TarPath -> EntryContent -> Entry
simpleEntry TarPath
tarpath EntryContent
content = Entry {
    entryTarPath :: TarPath
entryTarPath     = TarPath
tarpath,
    entryContent :: EntryContent
entryContent     = EntryContent
content,
    entryPermissions :: Permissions
entryPermissions = case EntryContent
content of
                         EntryContent
Directory -> Permissions
directoryPermissions
                         EntryContent
_         -> Permissions
ordinaryFilePermissions,
    entryOwnership :: Ownership
entryOwnership   = String -> String -> Int -> Int -> Ownership
Ownership String
"" String
"" Int
0 Int
0,
    entryTime :: EpochTime
entryTime        = EpochTime
0,
    entryFormat :: Format
entryFormat      = Format
UstarFormat
  }

-- | A tar 'Entry' for a file.
--
-- Entry  fields such as file permissions and ownership have default values.
--
-- You can use this as a basis and override specific fields. For example if you
-- need an executable file you could use:
--
-- > (fileEntry name content) { fileMode = executableFileMode }
--
fileEntry :: TarPath -> LBS.ByteString -> Entry
fileEntry :: TarPath -> ByteString -> Entry
fileEntry TarPath
name ByteString
fileContent =
  TarPath -> EntryContent -> Entry
simpleEntry TarPath
name (ByteString -> EpochTime -> EntryContent
NormalFile ByteString
fileContent (ByteString -> EpochTime
LBS.length ByteString
fileContent))

-- | A tar 'Entry' for a directory.
--
-- Entry fields such as file permissions and ownership have default values.
--
directoryEntry :: TarPath -> Entry
directoryEntry :: TarPath -> Entry
directoryEntry TarPath
name = TarPath -> EntryContent -> Entry
simpleEntry TarPath
name EntryContent
Directory

--
-- * Tar paths
--

-- | The classic tar format allowed just 100 characters for the file name. The
-- USTAR format extended this with an extra 155 characters, however it uses a
-- complex method of splitting the name between the two sections.
--
-- Instead of just putting any overflow into the extended area, it uses the
-- extended area as a prefix. The aggravating insane bit however is that the
-- prefix (if any) must only contain a directory prefix. That is the split
-- between the two areas must be on a directory separator boundary. So there is
-- no simple calculation to work out if a file name is too long. Instead we
-- have to try to find a valid split that makes the name fit in the two areas.
--
-- The rationale presumably was to make it a bit more compatible with old tar
-- programs that only understand the classic format. A classic tar would be
-- able to extract the file name and possibly some dir prefix, but not the
-- full dir prefix. So the files would end up in the wrong place, but that's
-- probably better than ending up with the wrong names too.
--
-- So it's understandable but rather annoying.
--
-- * Tar paths use Posix format (ie @\'/\'@ directory separators), irrespective
--   of the local path conventions.
--
-- * The directory separator between the prefix and name is /not/ stored.
--
data TarPath = TarPath {-# UNPACK #-} !BS.ByteString -- path name, 100 characters max.
                       {-# UNPACK #-} !BS.ByteString -- path prefix, 155 characters max.
  deriving (TarPath -> TarPath -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TarPath -> TarPath -> Bool
$c/= :: TarPath -> TarPath -> Bool
== :: TarPath -> TarPath -> Bool
$c== :: TarPath -> TarPath -> Bool
Eq, Eq TarPath
TarPath -> TarPath -> Bool
TarPath -> TarPath -> Ordering
TarPath -> TarPath -> TarPath
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 :: TarPath -> TarPath -> TarPath
$cmin :: TarPath -> TarPath -> TarPath
max :: TarPath -> TarPath -> TarPath
$cmax :: TarPath -> TarPath -> TarPath
>= :: TarPath -> TarPath -> Bool
$c>= :: TarPath -> TarPath -> Bool
> :: TarPath -> TarPath -> Bool
$c> :: TarPath -> TarPath -> Bool
<= :: TarPath -> TarPath -> Bool
$c<= :: TarPath -> TarPath -> Bool
< :: TarPath -> TarPath -> Bool
$c< :: TarPath -> TarPath -> Bool
compare :: TarPath -> TarPath -> Ordering
$ccompare :: TarPath -> TarPath -> Ordering
Ord)

instance NFData TarPath where
  rnf :: TarPath -> ()
rnf (TarPath ByteString
_ ByteString
_) = () -- fully strict by construction

instance Show TarPath where
  show :: TarPath -> String
show = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. TarPath -> String
fromTarPath

-- | Convert a 'TarPath' to a native 'FilePath'.
--
-- The native 'FilePath' will use the native directory separator but it is not
-- otherwise checked for validity or sanity. In particular:
--
-- * The tar path may be invalid as a native path, eg the file name @\"nul\"@
--   is not valid on Windows.
--
-- * The tar path may be an absolute path or may contain @\"..\"@ components.
--   For security reasons this should not usually be allowed, but it is your
--   responsibility to check for these conditions (eg using 'checkSecurity').
--
fromTarPath :: TarPath -> FilePath
fromTarPath :: TarPath -> String
fromTarPath (TarPath ByteString
namebs ByteString
prefixbs) = ShowS
adjustDirectory forall a b. (a -> b) -> a -> b
$
  [String] -> String
FilePath.Native.joinPath forall a b. (a -> b) -> a -> b
$ String -> [String]
FilePath.Posix.splitDirectories String
prefix
                          forall a. [a] -> [a] -> [a]
++ String -> [String]
FilePath.Posix.splitDirectories String
name
  where
    name :: String
name   = ByteString -> String
BS.Char8.unpack ByteString
namebs
    prefix :: String
prefix = ByteString -> String
BS.Char8.unpack ByteString
prefixbs
    adjustDirectory :: ShowS
adjustDirectory | String -> Bool
FilePath.Posix.hasTrailingPathSeparator String
name
                    = ShowS
FilePath.Native.addTrailingPathSeparator
                    | Bool
otherwise = forall a. a -> a
id

-- | Convert a 'TarPath' to a Unix\/Posix 'FilePath'.
--
-- The difference compared to 'fromTarPath' is that it always returns a Unix
-- style path irrespective of the current operating system.
--
-- This is useful to check how a 'TarPath' would be interpreted on a specific
-- operating system, eg to perform portability checks.
--
fromTarPathToPosixPath :: TarPath -> FilePath
fromTarPathToPosixPath :: TarPath -> String
fromTarPathToPosixPath (TarPath ByteString
namebs ByteString
prefixbs) = ShowS
adjustDirectory forall a b. (a -> b) -> a -> b
$
  [String] -> String
FilePath.Posix.joinPath forall a b. (a -> b) -> a -> b
$ String -> [String]
FilePath.Posix.splitDirectories String
prefix
                         forall a. [a] -> [a] -> [a]
++ String -> [String]
FilePath.Posix.splitDirectories String
name
  where
    name :: String
name   = ByteString -> String
BS.Char8.unpack ByteString
namebs
    prefix :: String
prefix = ByteString -> String
BS.Char8.unpack ByteString
prefixbs
    adjustDirectory :: ShowS
adjustDirectory | String -> Bool
FilePath.Posix.hasTrailingPathSeparator String
name
                    = ShowS
FilePath.Posix.addTrailingPathSeparator
                    | Bool
otherwise = forall a. a -> a
id

-- | Convert a 'TarPath' to a Windows 'FilePath'.
--
-- The only difference compared to 'fromTarPath' is that it always returns a
-- Windows style path irrespective of the current operating system.
--
-- This is useful to check how a 'TarPath' would be interpreted on a specific
-- operating system, eg to perform portability checks.
--
fromTarPathToWindowsPath :: TarPath -> FilePath
fromTarPathToWindowsPath :: TarPath -> String
fromTarPathToWindowsPath (TarPath ByteString
namebs ByteString
prefixbs) = ShowS
adjustDirectory forall a b. (a -> b) -> a -> b
$
  [String] -> String
FilePath.Windows.joinPath forall a b. (a -> b) -> a -> b
$ String -> [String]
FilePath.Posix.splitDirectories String
prefix
                           forall a. [a] -> [a] -> [a]
++ String -> [String]
FilePath.Posix.splitDirectories String
name
  where
    name :: String
name   = ByteString -> String
BS.Char8.unpack ByteString
namebs
    prefix :: String
prefix = ByteString -> String
BS.Char8.unpack ByteString
prefixbs
    adjustDirectory :: ShowS
adjustDirectory | String -> Bool
FilePath.Posix.hasTrailingPathSeparator String
name
                    = ShowS
FilePath.Windows.addTrailingPathSeparator
                    | Bool
otherwise = forall a. a -> a
id

-- | Convert a native 'FilePath' to a 'TarPath'.
--
-- The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a
-- description of the problem with splitting long 'FilePath's.
--
toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for
                  -- directories a 'TarPath' must always use a trailing @\/@.
          -> FilePath -> Either String TarPath
toTarPath :: Bool -> String -> Either String TarPath
toTarPath Bool
isDir = String -> Either String TarPath
splitLongPath
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
addTrailingSep
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
FilePath.Posix.joinPath
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
FilePath.Native.splitDirectories
  where
    addTrailingSep :: ShowS
addTrailingSep | Bool
isDir     = ShowS
FilePath.Posix.addTrailingPathSeparator
                   | Bool
otherwise = forall a. a -> a
id

-- | Take a sanitised path, split on directory separators and try to pack it
-- into the 155 + 100 tar file name format.
--
-- The strategy is this: take the name-directory components in reverse order
-- and try to fit as many components into the 100 long name area as possible.
-- If all the remaining components fit in the 155 name area then we win.
--
splitLongPath :: FilePath -> Either String TarPath
splitLongPath :: String -> Either String TarPath
splitLongPath String
path =
  case Int -> [String] -> Either String (String, [String])
packName Int
nameMax (forall a. [a] -> [a]
reverse (String -> [String]
FilePath.Posix.splitPath String
path)) of
    Left String
err                 -> forall a b. a -> Either a b
Left String
err
    Right (String
name, [])         -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! ByteString -> ByteString -> TarPath
TarPath (String -> ByteString
BS.Char8.pack String
name)
                                                  ByteString
BS.empty
    Right (String
name, String
first:[String]
rest) -> case Int -> [String] -> Either String (String, [String])
packName Int
prefixMax [String]
remainder of
      Left String
err               -> forall a b. a -> Either a b
Left String
err
      Right (String
_     , (String
_:[String]
_))  -> forall a b. a -> Either a b
Left String
"File name too long (cannot split)"
      Right (String
prefix, [])     -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! ByteString -> ByteString -> TarPath
TarPath (String -> ByteString
BS.Char8.pack String
name)
                                                 (String -> ByteString
BS.Char8.pack String
prefix)
      where
        -- drop the '/' between the name and prefix:
        remainder :: [String]
remainder = forall a. [a] -> [a]
init String
first forall a. a -> [a] -> [a]
: [String]
rest

  where
    nameMax, prefixMax :: Int
    nameMax :: Int
nameMax   = Int
100
    prefixMax :: Int
prefixMax = Int
155

    packName :: Int -> [String] -> Either String (String, [String])
packName Int
_      []     = forall a b. a -> Either a b
Left String
"File name empty"
    packName Int
maxLen (String
c:[String]
cs)
      | Int
n forall a. Ord a => a -> a -> Bool
> Int
maxLen         = forall a b. a -> Either a b
Left String
"File name too long"
      | Bool
otherwise          = forall a b. b -> Either a b
Right (Int -> Int -> [String] -> [String] -> (String, [String])
packName' Int
maxLen Int
n [String
c] [String]
cs)
      where n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c

    packName' :: Int -> Int -> [String] -> [String] -> (String, [String])
packName' Int
maxLen Int
n [String]
ok (String
c:[String]
cs)
      | Int
n' forall a. Ord a => a -> a -> Bool
<= Int
maxLen             = Int -> Int -> [String] -> [String] -> (String, [String])
packName' Int
maxLen Int
n' (String
cforall a. a -> [a] -> [a]
:[String]
ok) [String]
cs
                                     where n' :: Int
n' = Int
n forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c
    packName' Int
_      Int
_ [String]
ok    [String]
cs  = ([String] -> String
FilePath.Posix.joinPath [String]
ok, [String]
cs)

-- | The tar format allows just 100 ASCII characters for the 'SymbolicLink' and
-- 'HardLink' entry types.
--
newtype LinkTarget = LinkTarget BS.ByteString
  deriving (LinkTarget -> LinkTarget -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LinkTarget -> LinkTarget -> Bool
$c/= :: LinkTarget -> LinkTarget -> Bool
== :: LinkTarget -> LinkTarget -> Bool
$c== :: LinkTarget -> LinkTarget -> Bool
Eq, Eq LinkTarget
LinkTarget -> LinkTarget -> Bool
LinkTarget -> LinkTarget -> Ordering
LinkTarget -> LinkTarget -> LinkTarget
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 :: LinkTarget -> LinkTarget -> LinkTarget
$cmin :: LinkTarget -> LinkTarget -> LinkTarget
max :: LinkTarget -> LinkTarget -> LinkTarget
$cmax :: LinkTarget -> LinkTarget -> LinkTarget
>= :: LinkTarget -> LinkTarget -> Bool
$c>= :: LinkTarget -> LinkTarget -> Bool
> :: LinkTarget -> LinkTarget -> Bool
$c> :: LinkTarget -> LinkTarget -> Bool
<= :: LinkTarget -> LinkTarget -> Bool
$c<= :: LinkTarget -> LinkTarget -> Bool
< :: LinkTarget -> LinkTarget -> Bool
$c< :: LinkTarget -> LinkTarget -> Bool
compare :: LinkTarget -> LinkTarget -> Ordering
$ccompare :: LinkTarget -> LinkTarget -> Ordering
Ord, Int -> LinkTarget -> ShowS
[LinkTarget] -> ShowS
LinkTarget -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LinkTarget] -> ShowS
$cshowList :: [LinkTarget] -> ShowS
show :: LinkTarget -> String
$cshow :: LinkTarget -> String
showsPrec :: Int -> LinkTarget -> ShowS
$cshowsPrec :: Int -> LinkTarget -> ShowS
Show)

instance NFData LinkTarget where
#if MIN_VERSION_bytestring(0,10,0)
    rnf :: LinkTarget -> ()
rnf (LinkTarget ByteString
bs) = forall a. NFData a => a -> ()
rnf ByteString
bs
#else
    rnf (LinkTarget !_bs) = ()
#endif

-- | Convert a native 'FilePath' to a tar 'LinkTarget'. This may fail if the
-- string is longer than 100 characters or if it contains non-portable
-- characters.
--
toLinkTarget   :: FilePath -> Maybe LinkTarget
toLinkTarget :: String -> Maybe LinkTarget
toLinkTarget String
path | forall (t :: * -> *) a. Foldable t => t a -> Int
length String
path forall a. Ord a => a -> a -> Bool
<= Int
100 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! ByteString -> LinkTarget
LinkTarget (String -> ByteString
BS.Char8.pack String
path)
                  | Bool
otherwise          = forall a. Maybe a
Nothing

-- | Convert a tar 'LinkTarget' to a native 'FilePath'.
--
fromLinkTarget :: LinkTarget -> FilePath
fromLinkTarget :: LinkTarget -> String
fromLinkTarget (LinkTarget ByteString
pathbs) = ShowS
adjustDirectory forall a b. (a -> b) -> a -> b
$
  [String] -> String
FilePath.Native.joinPath forall a b. (a -> b) -> a -> b
$ String -> [String]
FilePath.Posix.splitDirectories String
path
  where
    path :: String
path = ByteString -> String
BS.Char8.unpack ByteString
pathbs
    adjustDirectory :: ShowS
adjustDirectory | String -> Bool
FilePath.Posix.hasTrailingPathSeparator String
path
                    = ShowS
FilePath.Native.addTrailingPathSeparator
                    | Bool
otherwise = forall a. a -> a
id

-- | Convert a tar 'LinkTarget' to a Unix/Posix 'FilePath'.
--
fromLinkTargetToPosixPath :: LinkTarget -> FilePath
fromLinkTargetToPosixPath :: LinkTarget -> String
fromLinkTargetToPosixPath (LinkTarget ByteString
pathbs) = ShowS
adjustDirectory forall a b. (a -> b) -> a -> b
$
  [String] -> String
FilePath.Posix.joinPath forall a b. (a -> b) -> a -> b
$ String -> [String]
FilePath.Posix.splitDirectories String
path
  where
    path :: String
path = ByteString -> String
BS.Char8.unpack ByteString
pathbs
    adjustDirectory :: ShowS
adjustDirectory | String -> Bool
FilePath.Posix.hasTrailingPathSeparator String
path
                    = ShowS
FilePath.Native.addTrailingPathSeparator
                    | Bool
otherwise = forall a. a -> a
id

-- | Convert a tar 'LinkTarget' to a Windows 'FilePath'.
--
fromLinkTargetToWindowsPath :: LinkTarget -> FilePath
fromLinkTargetToWindowsPath :: LinkTarget -> String
fromLinkTargetToWindowsPath (LinkTarget ByteString
pathbs) = ShowS
adjustDirectory forall a b. (a -> b) -> a -> b
$
  [String] -> String
FilePath.Windows.joinPath forall a b. (a -> b) -> a -> b
$ String -> [String]
FilePath.Posix.splitDirectories String
path
  where
    path :: String
path = ByteString -> String
BS.Char8.unpack ByteString
pathbs
    adjustDirectory :: ShowS
adjustDirectory | String -> Bool
FilePath.Posix.hasTrailingPathSeparator String
path
                    = ShowS
FilePath.Windows.addTrailingPathSeparator
                    | Bool
otherwise = forall a. a -> a
id

--
-- * Entries type
--

-- | A tar archive is a sequence of entries.
--
-- The point of this type as opposed to just using a list is that it makes the
-- failure case explicit. We need this because the sequence of entries we get
-- from reading a tarball can include errors.
--
-- It is a concrete data type so you can manipulate it directly but it is often
-- clearer to use the provided functions for mapping, folding and unfolding.
--
-- Converting from a list can be done with just @foldr Next Done@. Converting
-- back into a list can be done with 'foldEntries' however in that case you
-- must be prepared to handle the 'Fail' case inherent in the 'Entries' type.
--
-- The 'Monoid' instance lets you concatenate archives or append entries to an
-- archive.
--
data Entries e = Next Entry (Entries e)
               | Done
               | Fail e
  deriving (Entries e -> Entries e -> Bool
forall e. Eq e => Entries e -> Entries e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Entries e -> Entries e -> Bool
$c/= :: forall e. Eq e => Entries e -> Entries e -> Bool
== :: Entries e -> Entries e -> Bool
$c== :: forall e. Eq e => Entries e -> Entries e -> Bool
Eq, Int -> Entries e -> ShowS
forall e. Show e => Int -> Entries e -> ShowS
forall e. Show e => [Entries e] -> ShowS
forall e. Show e => Entries e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Entries e] -> ShowS
$cshowList :: forall e. Show e => [Entries e] -> ShowS
show :: Entries e -> String
$cshow :: forall e. Show e => Entries e -> String
showsPrec :: Int -> Entries e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> Entries e -> ShowS
Show)

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.
--
-- It can be used to generate 'Entries' from some other type. For example it is
-- used internally to lazily unfold entries from a 'LBS.ByteString'.
--
unfoldEntries :: (a -> Either e (Maybe (Entry, a))) -> a -> Entries e
unfoldEntries :: forall a e. (a -> Either e (Maybe (Entry, a))) -> a -> Entries e
unfoldEntries a -> Either e (Maybe (Entry, a))
f = a -> Entries e
unfold
  where
    unfold :: a -> Entries e
unfold a
x = case a -> Either e (Maybe (Entry, a))
f a
x of
      Left e
err             -> forall e. e -> Entries e
Fail e
err
      Right Maybe (Entry, a)
Nothing        -> forall e. Entries e
Done
      Right (Just (Entry
e, a
x')) -> forall e. Entry -> Entries e -> Entries e
Next Entry
e (a -> Entries e
unfold a
x')

-- | This is like the standard 'foldr' function on lists, but for 'Entries'.
-- Compared to 'foldr' it takes an extra function to account for the
-- possibility of failure.
--
-- This is used to consume a sequence of entries. For example it could be used
-- to scan a tarball for problems or to collect an index of the contents.
--
foldEntries :: (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a
foldEntries :: forall a e. (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a
foldEntries Entry -> a -> a
next a
done e -> a
fail' = Entries e -> a
fold
  where
    fold :: Entries e -> a
fold (Next Entry
e Entries e
es) = Entry -> a -> a
next Entry
e (Entries e -> a
fold Entries e
es)
    fold Entries e
Done        = a
done
    fold (Fail e
err)  = e -> a
fail' e
err

-- | A 'foldl'-like function on Entries. It either returns the final
-- accumulator result, or the failure along with the intermediate accumulator
-- value.
--
foldlEntries :: (a -> Entry -> a) -> a -> Entries e -> Either (e, a) a
foldlEntries :: forall a e. (a -> Entry -> a) -> a -> Entries e -> Either (e, a) a
foldlEntries a -> Entry -> a
f a
z = forall {a}. a -> Entries a -> Either (a, a) a
go a
z
  where
    go :: a -> Entries a -> Either (a, a) a
go !a
acc (Next Entry
e Entries a
es) = a -> Entries a -> Either (a, a) a
go (a -> Entry -> a
f a
acc Entry
e) Entries a
es
    go !a
acc  Entries a
Done       = forall a b. b -> Either a b
Right a
acc
    go !a
acc (Fail a
err)  = forall a b. a -> Either a b
Left (a
err, a
acc)

-- | This is like the standard 'map' function on lists, but for 'Entries'. It
-- includes failure as a extra possible outcome of the mapping function.
--
-- If your mapping function cannot fail it may be more convenient to use
-- 'mapEntriesNoFail'
mapEntries :: (Entry -> Either e' Entry) -> Entries e -> Entries (Either e e')
mapEntries :: forall e' e.
(Entry -> Either e' Entry) -> Entries e -> Entries (Either e e')
mapEntries Entry -> Either e' Entry
f =
  forall a e. (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a
foldEntries (\Entry
entry Entries (Either e e')
rest -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e. e -> Entries e
Fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right) (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e. Entry -> Entries e -> Entries e
Next Entries (Either e e')
rest) (Entry -> Either e' Entry
f Entry
entry)) forall e. Entries e
Done (forall e. e -> Entries e
Fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)

-- | Like 'mapEntries' but the mapping function itself cannot fail.
--
mapEntriesNoFail :: (Entry -> Entry) -> Entries e -> Entries e
mapEntriesNoFail :: forall e. (Entry -> Entry) -> Entries e -> Entries e
mapEntriesNoFail Entry -> Entry
f =
  forall a e. (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a
foldEntries (\Entry
entry -> forall e. Entry -> Entries e -> Entries e
Next (Entry -> Entry
f Entry
entry)) forall e. Entries e
Done forall e. e -> Entries e
Fail

-- | @since 0.5.1.0
instance Sem.Semigroup (Entries e) where
  Entries e
a <> :: Entries e -> Entries e -> Entries e
<> Entries e
b = forall a e. (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a
foldEntries forall e. Entry -> Entries e -> Entries e
Next Entries e
b forall e. e -> Entries e
Fail Entries e
a

instance Monoid (Entries e) where
  mempty :: Entries e
mempty  = forall e. Entries e
Done
  mappend :: Entries e -> Entries e -> Entries e
mappend = forall a. Semigroup a => a -> a -> a
(Sem.<>)

instance Functor Entries where
  fmap :: forall a b. (a -> b) -> Entries a -> Entries b
fmap a -> b
f = forall a e. (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a
foldEntries forall e. Entry -> Entries e -> Entries e
Next forall e. Entries e
Done (forall e. e -> Entries e
Fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance NFData e => NFData (Entries e) where
  rnf :: Entries e -> ()
rnf (Next Entry
e Entries e
es) = forall a. NFData a => a -> ()
rnf Entry
e seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Entries e
es
  rnf  Entries e
Done       = ()
  rnf (Fail e
e)    = forall a. NFData a => a -> ()
rnf e
e


-------------------------
-- QuickCheck instances
--

#ifdef TESTS

instance Arbitrary Entry where
  arbitrary = Entry <$> arbitrary <*> arbitrary <*> arbitraryPermissions
                    <*> arbitrary <*> arbitraryEpochTime <*> arbitrary
    where
      arbitraryPermissions :: Gen Permissions
      arbitraryPermissions = fromIntegral <$> (arbitrary :: Gen Word16)

      arbitraryEpochTime :: Gen EpochTime
      arbitraryEpochTime = arbitraryOctal 11

  shrink (Entry path content perms author time format) =
      [ Entry path' content' perms author' time' format
      | (path', content', author', time') <-
         shrink (path, content, author, time) ]
   ++ [ Entry path content perms' author time format
      | perms' <- shrinkIntegral perms ]

instance Arbitrary TarPath where
  arbitrary = either error id
            . toTarPath False
            . FilePath.Posix.joinPath
          <$> listOf1ToN (255 `div` 5)
                         (elements (map (replicate 4) "abcd"))

  shrink = map (either error id . toTarPath False)
         . map FilePath.Posix.joinPath
         . filter (not . null)
         . shrinkList shrinkNothing
         . FilePath.Posix.splitPath
         . fromTarPathToPosixPath

instance Arbitrary LinkTarget where
  arbitrary = maybe (error "link target too large") id
            . toLinkTarget
            . FilePath.Native.joinPath
          <$> listOf1ToN (100 `div` 5)
                         (elements (map (replicate 4) "abcd"))

  shrink = map (maybe (error "link target too large") id . toLinkTarget)
         . map FilePath.Posix.joinPath
         . filter (not . null)
         . shrinkList shrinkNothing
         . FilePath.Posix.splitPath
         . fromLinkTargetToPosixPath


listOf1ToN :: Int -> Gen a -> Gen [a]
listOf1ToN n g = sized $ \sz -> do
    n <- choose (1, min n (max 1 sz))
    vectorOf n g

listOf0ToN :: Int -> Gen a -> Gen [a]
listOf0ToN n g = sized $ \sz -> do
    n <- choose (0, min n sz)
    vectorOf n g

instance Arbitrary EntryContent where
  arbitrary =
    frequency
      [ (16, do bs <- arbitrary;
                return (NormalFile bs (LBS.length bs)))
      , (2, pure Directory)
      , (1, SymbolicLink    <$> arbitrary)
      , (1, HardLink        <$> arbitrary)
      , (1, CharacterDevice <$> arbitraryOctal 7 <*> arbitraryOctal 7)
      , (1, BlockDevice     <$> arbitraryOctal 7 <*> arbitraryOctal 7)
      , (1, pure NamedPipe)
      , (1, do c  <- elements (['A'..'Z']++['a'..'z'])
               bs <- arbitrary;
               return (OtherEntryType c bs (LBS.length bs)))
      ]

  shrink (NormalFile bs _)   = [ NormalFile bs' (LBS.length bs') 
                               | bs' <- shrink bs ]
  shrink  Directory          = []
  shrink (SymbolicLink link) = [ SymbolicLink link' | link' <- shrink link ]
  shrink (HardLink     link) = [ HardLink     link' | link' <- shrink link ]
  shrink (CharacterDevice ma mi) = [ CharacterDevice ma' mi'
                                   | (ma', mi') <- shrink (ma, mi) ]
  shrink (BlockDevice     ma mi) = [ BlockDevice ma' mi'
                                   | (ma', mi') <- shrink (ma, mi) ]
  shrink  NamedPipe              = []
  shrink (OtherEntryType c bs _) = [ OtherEntryType c bs' (LBS.length bs') 
                                   | bs' <- shrink bs ]

instance Arbitrary LBS.ByteString where
  arbitrary = fmap LBS.pack arbitrary
  shrink    = map LBS.pack . shrink . LBS.unpack

instance Arbitrary BS.ByteString where
  arbitrary = fmap BS.pack arbitrary
  shrink    = map BS.pack . shrink . BS.unpack

instance Arbitrary Ownership where
  arbitrary = Ownership <$> name <*> name
                        <*> idno <*> idno
    where
      -- restrict user/group to posix ^[a-z][-a-z0-9]{0,30}$
      name = do
        first <- choose ('a', 'z')
        rest <- listOf0ToN 30 (oneof [choose ('a', 'z'), choose ('0', '9'), pure '-'])
        return $ first : rest
      idno = arbitraryOctal 7

  shrink (Ownership oname gname oid gid) =
    [ Ownership oname' gname' oid' gid'
    | (oname', gname', oid', gid') <- shrink (oname, gname, oid, gid) ]

instance Arbitrary Format where
  arbitrary = elements [V7Format, UstarFormat, GnuFormat]


--arbitraryOctal :: (Integral n, Random n) => Int -> Gen n
arbitraryOctal n =
    oneof [ pure 0
          , choose (0, upperBound)
          , pure upperBound
          ]
  where
    upperBound = 8^n-1

-- For QC tests it's useful to have a way to limit the info to that which can
-- be expressed in the old V7 format
limitToV7FormatCompat :: Entry -> Entry
limitToV7FormatCompat entry@Entry { entryFormat = V7Format } =
    entry {
      entryContent = case entryContent entry of
        CharacterDevice _ _ -> OtherEntryType  '3' LBS.empty 0
        BlockDevice     _ _ -> OtherEntryType  '4' LBS.empty 0
        Directory           -> OtherEntryType  '5' LBS.empty 0
        NamedPipe           -> OtherEntryType  '6' LBS.empty 0
        other               -> other,

      entryOwnership = (entryOwnership entry) {
        groupName = "",
        ownerName = ""
      },

      entryTarPath = let TarPath name _prefix = entryTarPath entry
                      in TarPath name BS.empty
    }
limitToV7FormatCompat entry = entry

#endif