{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Codec.Archive.Tar.Unpack (
unpack,
) where
import Codec.Archive.Tar.Types
import Codec.Archive.Tar.Check
import Data.List (partition)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import System.Posix.FilePath
( (</>), normalise )
import qualified System.Posix.FilePath as FilePath.Native
( takeDirectory )
import Control.Exception.Safe ( Exception
, throwIO
, finally
)
import Data.Time.Clock.POSIX
( posixSecondsToUTCTime )
import Control.Exception.Safe as Exception
( catch, handle, throw )
import Control.Monad (when)
import System.IO.Error
( isPermissionError )
import System.Posix.RawFilePath.Directory hiding (Directory, SymbolicLink)
import System.Posix.RawFilePath.Directory.Errors
import qualified System.Posix.IO.ByteString as SPI
import qualified System.Posix as Posix
import System.Posix.FD
import System.IO (hClose)
unpack :: Exception e => RawFilePath -> Entries e -> IO ()
unpack baseDir entries = do
uEntries <- unpackEntries [] (checkSecurity entries)
let (hardlinks, symlinks) = partition (\(_, _, x) -> x) uEntries
emulateLinks hardlinks
emulateLinks symlinks
where
unpackEntries _ (Fail err) = either throwIO throwIO err
unpackEntries links Done = return links
unpackEntries links (Next entry es) = case entryContent entry of
NormalFile file _ -> do
extractFile (entryPermissions entry) (entryPath entry) file (entryTime entry)
unpackEntries links es
Directory -> extractDir (entryPath entry) (entryTime entry)
>> unpackEntries links es
HardLink link -> (unpackEntries $! saveLink True (entryPath entry) link links) es
SymbolicLink link -> (unpackEntries $! saveLink False (entryPath entry) link links) es
OtherEntryType 'L' fn _ ->
case es of
(Next entry' es') -> case entryContent entry' of
NormalFile file _ -> do
extractFile (entryPermissions entry') (L.toStrict fn) file (entryTime entry')
unpackEntries links es'
Directory -> extractDir (L.toStrict fn) (entryTime entry')
>> unpackEntries links es'
HardLink link -> (unpackEntries $! saveLink True (L.toStrict fn) link links) es'
SymbolicLink link -> (unpackEntries $! saveLink False (L.toStrict fn) link links) es'
OtherEntryType 'L' _ _ -> throwIO $ userError "Two subsequent OtherEntryType 'L'"
_ -> unpackEntries links es'
(Fail err) -> either throwIO throwIO err
Done -> throwIO $ userError "././@LongLink without a subsequent entry"
_ -> unpackEntries links es
extractFile fPerms path content mtime = do
createDirRecursive dirPerms (normalise absDir)
writeFileL absPath (Just fPerms) content
setModTime absPath mtime
where
absDir = baseDir </> FilePath.Native.takeDirectory path
absPath = baseDir </> path
extractDir path mtime = do
createDirRecursive dirPerms (normalise absPath)
setModTime absPath mtime
where
absPath = baseDir </> path
saveLink isHardLink path link links = seq (BS.length path)
$ seq (BS.length link')
$ (path, link', isHardLink):links
where link' = fromLinkTarget link
emulateLinks = mapM_ $ \(relPath, relLinkTarget, isHardLink) ->
let absPath = baseDir </> relPath
absTarget = if isHardLink then baseDir </> relLinkTarget else FilePath.Native.takeDirectory absPath </> relLinkTarget
in handle (\(ex :: HPathIOException) ->
when (not . isSameFile $ ex) $ throw ex)
$ copyFile absTarget absPath Overwrite
setModTime :: RawFilePath -> EpochTime -> IO ()
setModTime p t = setModificationTime p (fromIntegral t)
`Exception.catch` \e ->
if isPermissionError e then return () else throwIO e