{-# LANGUAGE CPP #-}
module Codec.Archive.Tar.Unpack (
unpack,
) where
import Codec.Archive.Tar.Types
import Codec.Archive.Tar.Check
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import System.Posix.FilePath
( (</>) )
import qualified System.Posix.FilePath as FilePath.Native
( takeDirectory )
import Control.Exception ( Exception
, throwIO
, finally
)
import Data.Time.Clock.POSIX
( posixSecondsToUTCTime )
import Control.Exception as Exception
( catch )
import System.IO.Error
( isPermissionError )
import HPath hiding ((</>))
import HPath.IO hiding (Directory, SymbolicLink)
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 = unpackEntries [] (checkSecurity entries)
>>= emulateLinks
where
unpackEntries _ (Fail err) = either throwIO throwIO err
unpackEntries links Done = return links
unpackEntries links (Next entry es) = case entryContent entry of
NormalFile file _ -> extractFile path file mtime
>> unpackEntries links es
Directory -> extractDir path mtime
>> unpackEntries links es
HardLink link -> (unpackEntries $! saveLink path link links) es
SymbolicLink link -> (unpackEntries $! saveLink path link links) es
_ -> unpackEntries links es
where
path = entryPath entry
mtime = entryTime entry
extractFile path content mtime = do
withRawFilePath absDir (\p -> either (createDirRecursive newDirPerms)
(createDirRecursive newDirPerms) p)
withRawFilePath absPath (\p -> case p of
Right x -> writeFileL x (Just newFilePerms) content
Left x -> writeFileL x (Just newFilePerms) content)
setModTime absPath mtime
where
absDir = baseDir </> FilePath.Native.takeDirectory path
absPath = baseDir </> path
extractDir path mtime = do
withRawFilePath absPath $ \p -> either (createDirRecursive newDirPerms)
(createDirRecursive newDirPerms) p
setModTime absPath mtime
where
absPath = baseDir </> path
saveLink path link links = seq (BS.length path)
$ seq (BS.length link')
$ (path, link'):links
where link' = fromLinkTarget link
emulateLinks = mapM_ $ \(relPath, relLinkTarget) -> do
let absPath = baseDir </> relPath
absTarget = FilePath.Native.takeDirectory absPath </> relLinkTarget
let copy x y = copyFile x y Overwrite
withRawFilePath absPath $ \absPath' -> withRawFilePath absTarget $ \absTarget' -> case (absTarget', absPath') of
(Right x, Right y) -> copy x y
(Left x, Right y) -> copy x y
(Right x, Left y) -> copy x y
(Left x, Left y) -> copy x y
setModTime :: RawFilePath -> EpochTime -> IO ()
setModTime path t = withRawFilePath path $ \p -> either go go p
where
go p = setModificationTime p (fromIntegral t)
`Exception.catch` \e ->
if isPermissionError e then return () else throwIO e