{-# 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
( (</>), 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 )
import System.IO.Error
( isPermissionError )
import System.Posix.RawFilePath.Directory 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
createDirRecursive newDirPerms (normalise absDir)
writeFileL absPath (Just newFilePerms) content
setModTime absPath mtime
where
absDir = baseDir </> FilePath.Native.takeDirectory path
absPath = baseDir </> path
extractDir path mtime = do
createDirRecursive newDirPerms (normalise absPath)
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
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