{-# LANGUAGE LambdaCase #-}

module Codec.Archive.Tar.LongNames
  ( encodeLongNames
  , decodeLongNames
  , DecodeLongNamesError(..)
  ) where

import Codec.Archive.Tar.Types
import Control.Exception
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as BL

-- | Errors raised by 'decodeLongNames'.
--
-- @since 0.6.0.0
data DecodeLongNamesError
  = TwoTypeKEntries
  -- ^ Two adjacent 'OtherEntryType' @\'K\'@ nodes.
  | TwoTypeLEntries
  -- ^ Two adjacent 'OtherEntryType' @\'L\'@ nodes.
  | NoLinkEntryAfterTypeKEntry
  -- ^ 'OtherEntryType' @\'K\'@ node is not followed by a 'SymbolicLink' / 'HardLink'.
  deriving (DecodeLongNamesError -> DecodeLongNamesError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecodeLongNamesError -> DecodeLongNamesError -> Bool
$c/= :: DecodeLongNamesError -> DecodeLongNamesError -> Bool
== :: DecodeLongNamesError -> DecodeLongNamesError -> Bool
$c== :: DecodeLongNamesError -> DecodeLongNamesError -> Bool
Eq, Eq DecodeLongNamesError
DecodeLongNamesError -> DecodeLongNamesError -> Bool
DecodeLongNamesError -> DecodeLongNamesError -> Ordering
DecodeLongNamesError
-> DecodeLongNamesError -> DecodeLongNamesError
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 :: DecodeLongNamesError
-> DecodeLongNamesError -> DecodeLongNamesError
$cmin :: DecodeLongNamesError
-> DecodeLongNamesError -> DecodeLongNamesError
max :: DecodeLongNamesError
-> DecodeLongNamesError -> DecodeLongNamesError
$cmax :: DecodeLongNamesError
-> DecodeLongNamesError -> DecodeLongNamesError
>= :: DecodeLongNamesError -> DecodeLongNamesError -> Bool
$c>= :: DecodeLongNamesError -> DecodeLongNamesError -> Bool
> :: DecodeLongNamesError -> DecodeLongNamesError -> Bool
$c> :: DecodeLongNamesError -> DecodeLongNamesError -> Bool
<= :: DecodeLongNamesError -> DecodeLongNamesError -> Bool
$c<= :: DecodeLongNamesError -> DecodeLongNamesError -> Bool
< :: DecodeLongNamesError -> DecodeLongNamesError -> Bool
$c< :: DecodeLongNamesError -> DecodeLongNamesError -> Bool
compare :: DecodeLongNamesError -> DecodeLongNamesError -> Ordering
$ccompare :: DecodeLongNamesError -> DecodeLongNamesError -> Ordering
Ord, Int -> DecodeLongNamesError -> ShowS
[DecodeLongNamesError] -> ShowS
DecodeLongNamesError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DecodeLongNamesError] -> ShowS
$cshowList :: [DecodeLongNamesError] -> ShowS
show :: DecodeLongNamesError -> String
$cshow :: DecodeLongNamesError -> String
showsPrec :: Int -> DecodeLongNamesError -> ShowS
$cshowsPrec :: Int -> DecodeLongNamesError -> ShowS
Show)

instance Exception DecodeLongNamesError

-- | Translate high-level entries with POSIX 'FilePath's for files and symlinks
-- into entries suitable for serialization by emitting additional
-- 'OtherEntryType' @\'K\'@ and 'OtherEntryType' @\'L\'@ nodes.
--
-- Input 'FilePath's must be POSIX file names, not native ones.
--
-- @since 0.6.0.0
encodeLongNames
  :: GenEntry FilePath FilePath
  -> [Entry]
encodeLongNames :: GenEntry String String -> [Entry]
encodeLongNames GenEntry String String
e = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe Entry
mEntry forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) forall {whatever}. Maybe (GenEntry TarPath whatever)
mEntry' [Entry
e'']
  where
    (Maybe Entry
mEntry, GenEntry String LinkTarget
e') = forall tarPath.
GenEntry tarPath String
-> (Maybe Entry, GenEntry tarPath LinkTarget)
encodeLinkTarget GenEntry String String
e
    (Maybe (GenEntry TarPath whatever)
mEntry', Entry
e'') = forall linkTarget whatever.
GenEntry String linkTarget
-> (Maybe (GenEntry TarPath whatever), GenEntry TarPath linkTarget)
encodeTarPath GenEntry String LinkTarget
e'

encodeTarPath
  :: GenEntry FilePath linkTarget
  -> (Maybe (GenEntry TarPath whatever), GenEntry TarPath linkTarget)
  -- ^ (LongLink entry, actual entry)
encodeTarPath :: forall linkTarget whatever.
GenEntry String linkTarget
-> (Maybe (GenEntry TarPath whatever), GenEntry TarPath linkTarget)
encodeTarPath GenEntry String linkTarget
e = case String -> ToTarPathResult
toTarPath' (forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry String linkTarget
e) of
  ToTarPathResult
FileNameEmpty -> (forall a. Maybe a
Nothing, GenEntry String linkTarget
e { entryTarPath :: TarPath
entryTarPath = ByteString -> ByteString -> TarPath
TarPath forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty })
  FileNameOK TarPath
tarPath -> (forall a. Maybe a
Nothing, GenEntry String linkTarget
e { entryTarPath :: TarPath
entryTarPath = TarPath
tarPath })
  FileNameTooLong TarPath
tarPath -> (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall linkTarget. String -> GenEntry TarPath linkTarget
longLinkEntry forall a b. (a -> b) -> a -> b
$ forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath GenEntry String linkTarget
e, GenEntry String linkTarget
e { entryTarPath :: TarPath
entryTarPath = TarPath
tarPath })

encodeLinkTarget
  :: GenEntry tarPath FilePath
  -> (Maybe (GenEntry TarPath LinkTarget), GenEntry tarPath LinkTarget)
  -- ^ (LongLink symlink entry, actual entry)
encodeLinkTarget :: forall tarPath.
GenEntry tarPath String
-> (Maybe Entry, GenEntry tarPath LinkTarget)
encodeLinkTarget GenEntry tarPath String
e = case forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent GenEntry tarPath String
e of
  NormalFile ByteString
x FileSize
y -> (forall a. Maybe a
Nothing, GenEntry tarPath String
e { entryContent :: GenEntryContent LinkTarget
entryContent = forall linkTarget.
ByteString -> FileSize -> GenEntryContent linkTarget
NormalFile ByteString
x FileSize
y })
  GenEntryContent String
Directory -> (forall a. Maybe a
Nothing, GenEntry tarPath String
e { entryContent :: GenEntryContent LinkTarget
entryContent = forall linkTarget. GenEntryContent linkTarget
Directory })
  SymbolicLink String
lnk -> let (Maybe Entry
mEntry, LinkTarget
lnk') = String -> (Maybe Entry, LinkTarget)
encodeLinkPath String
lnk in
    (Maybe Entry
mEntry, GenEntry tarPath String
e { entryContent :: GenEntryContent LinkTarget
entryContent = forall linkTarget. linkTarget -> GenEntryContent linkTarget
SymbolicLink LinkTarget
lnk' })
  HardLink String
lnk -> let (Maybe Entry
mEntry, LinkTarget
lnk') = String -> (Maybe Entry, LinkTarget)
encodeLinkPath String
lnk in
    (Maybe Entry
mEntry, GenEntry tarPath String
e { entryContent :: GenEntryContent LinkTarget
entryContent = forall linkTarget. linkTarget -> GenEntryContent linkTarget
HardLink LinkTarget
lnk' })
  CharacterDevice Int
x Int
y -> (forall a. Maybe a
Nothing, GenEntry tarPath String
e { entryContent :: GenEntryContent LinkTarget
entryContent = forall linkTarget. Int -> Int -> GenEntryContent linkTarget
CharacterDevice Int
x Int
y })
  BlockDevice Int
x Int
y -> (forall a. Maybe a
Nothing, GenEntry tarPath String
e { entryContent :: GenEntryContent LinkTarget
entryContent = forall linkTarget. Int -> Int -> GenEntryContent linkTarget
BlockDevice Int
x Int
y })
  GenEntryContent String
NamedPipe -> (forall a. Maybe a
Nothing, GenEntry tarPath String
e { entryContent :: GenEntryContent LinkTarget
entryContent = forall linkTarget. GenEntryContent linkTarget
NamedPipe })
  OtherEntryType Char
x ByteString
y FileSize
z -> (forall a. Maybe a
Nothing, GenEntry tarPath String
e { entryContent :: GenEntryContent LinkTarget
entryContent = forall linkTarget.
Char -> ByteString -> FileSize -> GenEntryContent linkTarget
OtherEntryType Char
x ByteString
y FileSize
z })

encodeLinkPath
  :: FilePath
  -> (Maybe (GenEntry TarPath LinkTarget), LinkTarget)
encodeLinkPath :: String -> (Maybe Entry, LinkTarget)
encodeLinkPath String
lnk = case String -> ToTarPathResult
toTarPath' String
lnk of
  ToTarPathResult
FileNameEmpty -> (forall a. Maybe a
Nothing, ByteString -> LinkTarget
LinkTarget forall a. Monoid a => a
mempty)
  FileNameOK (TarPath ByteString
name ByteString
prefix)
    | ByteString -> Bool
B.null ByteString
prefix -> (forall a. Maybe a
Nothing, ByteString -> LinkTarget
LinkTarget ByteString
name)
    | Bool
otherwise -> (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall linkTarget. String -> GenEntry TarPath linkTarget
longSymLinkEntry String
lnk, ByteString -> LinkTarget
LinkTarget ByteString
name)
  FileNameTooLong (TarPath ByteString
name ByteString
_) ->
    (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall linkTarget. String -> GenEntry TarPath linkTarget
longSymLinkEntry String
lnk, ByteString -> LinkTarget
LinkTarget ByteString
name)

-- | Translate low-level entries (usually freshly deserialized) into
-- high-level entries with POSIX 'FilePath's for files and symlinks
-- by parsing and eliminating
-- 'OtherEntryType' @\'K\'@ and 'OtherEntryType' @\'L\'@ nodes.
--
-- Resolved 'FilePath's are still POSIX file names, not native ones.
--
-- @since 0.6.0.0
decodeLongNames
  :: Entries e
  -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
decodeLongNames :: forall e.
Entries e
-> GenEntries String String (Either e DecodeLongNamesError)
decodeLongNames = forall e.
Maybe String
-> Maybe String
-> Entries e
-> GenEntries String String (Either e DecodeLongNamesError)
go forall a. Maybe a
Nothing forall a. Maybe a
Nothing
  where
    go :: Maybe FilePath -> Maybe FilePath -> Entries e -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
    go :: forall e.
Maybe String
-> Maybe String
-> Entries e
-> GenEntries String String (Either e DecodeLongNamesError)
go Maybe String
_ Maybe String
_ (Fail e
err) = forall tarPath linkTarget e. e -> GenEntries tarPath linkTarget e
Fail (forall a b. a -> Either a b
Left e
err)
    go Maybe String
_ Maybe String
_ GenEntries TarPath LinkTarget e
Done = forall tarPath linkTarget e. GenEntries tarPath linkTarget e
Done

    go Maybe String
Nothing Maybe String
Nothing (Next Entry
e GenEntries TarPath LinkTarget e
rest) = case forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent Entry
e of
      OtherEntryType Char
'K' ByteString
fn FileSize
_ ->
        forall e.
Maybe String
-> Maybe String
-> Entries e
-> GenEntries String String (Either e DecodeLongNamesError)
go (forall a. a -> Maybe a
Just (ByteString -> String
otherEntryPayloadToFilePath ByteString
fn)) forall a. Maybe a
Nothing GenEntries TarPath LinkTarget e
rest
      OtherEntryType Char
'L' ByteString
fn FileSize
_ ->
        forall e.
Maybe String
-> Maybe String
-> Entries e
-> GenEntries String String (Either e DecodeLongNamesError)
go forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (ByteString -> String
otherEntryPayloadToFilePath ByteString
fn)) GenEntries TarPath LinkTarget e
rest
      GenEntryContent LinkTarget
_ ->
        forall tarPath linkTarget e.
GenEntry tarPath linkTarget
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget e
Next (Entry -> GenEntry String String
castEntry Entry
e) (forall e.
Maybe String
-> Maybe String
-> Entries e
-> GenEntries String String (Either e DecodeLongNamesError)
go forall a. Maybe a
Nothing forall a. Maybe a
Nothing GenEntries TarPath LinkTarget e
rest)

    go Maybe String
Nothing (Just String
path) (Next Entry
e GenEntries TarPath LinkTarget e
rest) = case forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent Entry
e of
      OtherEntryType Char
'K' ByteString
fn FileSize
_ ->
        forall e.
Maybe String
-> Maybe String
-> Entries e
-> GenEntries String String (Either e DecodeLongNamesError)
go (forall a. a -> Maybe a
Just (ByteString -> String
otherEntryPayloadToFilePath ByteString
fn)) (forall a. a -> Maybe a
Just String
path) GenEntries TarPath LinkTarget e
rest
      OtherEntryType Char
'L' ByteString
_ FileSize
_ ->
        forall tarPath linkTarget e. e -> GenEntries tarPath linkTarget e
Fail forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right DecodeLongNamesError
TwoTypeLEntries
      GenEntryContent LinkTarget
_ -> forall tarPath linkTarget e.
GenEntry tarPath linkTarget
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget e
Next ((Entry -> GenEntry String String
castEntry Entry
e) { entryTarPath :: String
entryTarPath = String
path }) (forall e.
Maybe String
-> Maybe String
-> Entries e
-> GenEntries String String (Either e DecodeLongNamesError)
go forall a. Maybe a
Nothing forall a. Maybe a
Nothing GenEntries TarPath LinkTarget e
rest)

    go (Just String
link) Maybe String
Nothing (Next Entry
e GenEntries TarPath LinkTarget e
rest) = case forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent Entry
e of
      OtherEntryType Char
'K' ByteString
_ FileSize
_ ->
        forall tarPath linkTarget e. e -> GenEntries tarPath linkTarget e
Fail forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right DecodeLongNamesError
TwoTypeKEntries
      OtherEntryType Char
'L' ByteString
fn FileSize
_ ->
        forall e.
Maybe String
-> Maybe String
-> Entries e
-> GenEntries String String (Either e DecodeLongNamesError)
go (forall a. a -> Maybe a
Just String
link) (forall a. a -> Maybe a
Just (ByteString -> String
otherEntryPayloadToFilePath ByteString
fn)) GenEntries TarPath LinkTarget e
rest
      SymbolicLink{} ->
        forall tarPath linkTarget e.
GenEntry tarPath linkTarget
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget e
Next ((Entry -> GenEntry String String
castEntry Entry
e) { entryContent :: GenEntryContent String
entryContent = forall linkTarget. linkTarget -> GenEntryContent linkTarget
SymbolicLink String
link }) (forall e.
Maybe String
-> Maybe String
-> Entries e
-> GenEntries String String (Either e DecodeLongNamesError)
go forall a. Maybe a
Nothing forall a. Maybe a
Nothing GenEntries TarPath LinkTarget e
rest)
      HardLink{} ->
        forall tarPath linkTarget e.
GenEntry tarPath linkTarget
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget e
Next ((Entry -> GenEntry String String
castEntry Entry
e) { entryContent :: GenEntryContent String
entryContent = forall linkTarget. linkTarget -> GenEntryContent linkTarget
HardLink String
link }) (forall e.
Maybe String
-> Maybe String
-> Entries e
-> GenEntries String String (Either e DecodeLongNamesError)
go forall a. Maybe a
Nothing forall a. Maybe a
Nothing GenEntries TarPath LinkTarget e
rest)
      GenEntryContent LinkTarget
_ ->
        forall tarPath linkTarget e. e -> GenEntries tarPath linkTarget e
Fail forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right DecodeLongNamesError
NoLinkEntryAfterTypeKEntry

    go (Just String
link) (Just String
path) (Next Entry
e GenEntries TarPath LinkTarget e
rest) = case forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent Entry
e of
      OtherEntryType Char
'K' ByteString
_ FileSize
_ ->
        forall tarPath linkTarget e. e -> GenEntries tarPath linkTarget e
Fail forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right DecodeLongNamesError
TwoTypeKEntries
      OtherEntryType Char
'L' ByteString
_ FileSize
_ ->
        forall tarPath linkTarget e. e -> GenEntries tarPath linkTarget e
Fail forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right DecodeLongNamesError
TwoTypeLEntries
      SymbolicLink{} ->
        forall tarPath linkTarget e.
GenEntry tarPath linkTarget
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget e
Next ((Entry -> GenEntry String String
castEntry Entry
e) { entryTarPath :: String
entryTarPath = String
path, entryContent :: GenEntryContent String
entryContent = forall linkTarget. linkTarget -> GenEntryContent linkTarget
SymbolicLink String
link }) (forall e.
Maybe String
-> Maybe String
-> Entries e
-> GenEntries String String (Either e DecodeLongNamesError)
go forall a. Maybe a
Nothing forall a. Maybe a
Nothing GenEntries TarPath LinkTarget e
rest)
      HardLink{} ->
        forall tarPath linkTarget e.
GenEntry tarPath linkTarget
-> GenEntries tarPath linkTarget e
-> GenEntries tarPath linkTarget e
Next ((Entry -> GenEntry String String
castEntry Entry
e) { entryTarPath :: String
entryTarPath = String
path, entryContent :: GenEntryContent String
entryContent = forall linkTarget. linkTarget -> GenEntryContent linkTarget
HardLink String
link }) (forall e.
Maybe String
-> Maybe String
-> Entries e
-> GenEntries String String (Either e DecodeLongNamesError)
go forall a. Maybe a
Nothing forall a. Maybe a
Nothing GenEntries TarPath LinkTarget e
rest)
      GenEntryContent LinkTarget
_ ->
        forall tarPath linkTarget e. e -> GenEntries tarPath linkTarget e
Fail forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right DecodeLongNamesError
NoLinkEntryAfterTypeKEntry

otherEntryPayloadToFilePath :: BL.ByteString -> FilePath
otherEntryPayloadToFilePath :: ByteString -> String
otherEntryPayloadToFilePath = ByteString -> String
B.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
B.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\0') forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict

castEntry :: Entry -> GenEntry FilePath FilePath
castEntry :: Entry -> GenEntry String String
castEntry Entry
e = Entry
e
  { entryTarPath :: String
entryTarPath = TarPath -> String
fromTarPathToPosixPath (forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath Entry
e)
  , entryContent :: GenEntryContent String
entryContent = GenEntryContent LinkTarget -> GenEntryContent String
castEntryContent (forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent Entry
e)
  }

castEntryContent :: EntryContent -> GenEntryContent FilePath
castEntryContent :: GenEntryContent LinkTarget -> GenEntryContent String
castEntryContent = \case
  NormalFile ByteString
x FileSize
y -> forall linkTarget.
ByteString -> FileSize -> GenEntryContent linkTarget
NormalFile ByteString
x FileSize
y
  GenEntryContent LinkTarget
Directory -> forall linkTarget. GenEntryContent linkTarget
Directory
  SymbolicLink LinkTarget
linkTarget -> forall linkTarget. linkTarget -> GenEntryContent linkTarget
SymbolicLink forall a b. (a -> b) -> a -> b
$ LinkTarget -> String
fromLinkTargetToPosixPath LinkTarget
linkTarget
  HardLink LinkTarget
linkTarget -> forall linkTarget. linkTarget -> GenEntryContent linkTarget
HardLink forall a b. (a -> b) -> a -> b
$ LinkTarget -> String
fromLinkTargetToPosixPath LinkTarget
linkTarget
  CharacterDevice Int
x Int
y -> forall linkTarget. Int -> Int -> GenEntryContent linkTarget
CharacterDevice Int
x Int
y
  BlockDevice Int
x Int
y -> forall linkTarget. Int -> Int -> GenEntryContent linkTarget
BlockDevice Int
x Int
y
  GenEntryContent LinkTarget
NamedPipe -> forall linkTarget. GenEntryContent linkTarget
NamedPipe
  OtherEntryType Char
x ByteString
y FileSize
z -> forall linkTarget.
Char -> ByteString -> FileSize -> GenEntryContent linkTarget
OtherEntryType Char
x ByteString
y FileSize
z