{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Conduit.Tar.Unix
( getFileInfo
, restoreFileInternal
) where
import Conduit hiding (throwM)
import Control.Exception.Safe
import Control.Monad (void, when, unless)
import Data.Bits
import qualified Data.ByteString.Char8 as S8
import Data.Either
import Data.Conduit.Tar.Types
import Foreign.C.Types (CTime (..))
import qualified System.Directory as Dir
import qualified System.Posix.Files as Posix
import qualified System.Posix.User as Posix
import qualified System.FilePath.Posix as Posix
getFileInfo :: FilePath -> IO FileInfo
getFileInfo fpStr = do
let fp = encodeFilePath fpStr
fs <- Posix.getSymbolicLinkStatus fpStr
let uid = Posix.fileOwner fs
gid = Posix.fileGroup fs
euEntry :: Either IOException Posix.UserEntry <- try $ Posix.getUserEntryForID uid
egEntry :: Either IOException Posix.GroupEntry <- try $ Posix.getGroupEntryForID gid
(fType, fSize) <-
case () of
() | Posix.isRegularFile fs -> return (FTNormal, Posix.fileSize fs)
| Posix.isSymbolicLink fs -> do
ln <- Posix.readSymbolicLink fpStr
return (FTSymbolicLink (encodeFilePath ln), 0)
| Posix.isCharacterDevice fs -> return (FTCharacterSpecial, 0)
| Posix.isBlockDevice fs -> return (FTBlockSpecial, 0)
| Posix.isDirectory fs -> return (FTDirectory, 0)
| Posix.isNamedPipe fs -> return (FTFifo, 0)
| otherwise -> error $ "Unsupported file type: " ++ S8.unpack fp
return $! FileInfo
{ filePath = fp
, fileUserId = uid
, fileUserName = either (const "") (S8.pack . Posix.userName) euEntry
, fileGroupId = gid
, fileGroupName = either (const "") (S8.pack . Posix.groupName) egEntry
, fileMode = Posix.fileMode fs .&. 0o7777
, fileSize = fSize
, fileType = fType
, fileModTime = Posix.modificationTime fs
}
restoreFileInternal ::
(MonadResource m)
=> Bool
-> FileInfo
-> ConduitM S8.ByteString (IO (FileInfo, [SomeException])) m ()
restoreFileInternal lenient fi@FileInfo {..} = do
let fpStr = decodeFilePath filePath
tryAnyCond action = if lenient then tryAny action else fmap Right action
restorePermissions = do
eExc1 <- tryAnyCond $ Posix.setOwnerAndGroup fpStr fileUserId fileGroupId
eExc2 <- tryAnyCond $ Posix.setFileMode fpStr fileMode
return $! fst $ partitionEithers [eExc1, eExc2]
case fileType of
FTDirectory -> do
excs <- liftIO $ do
Dir.createDirectoryIfMissing True fpStr
restorePermissions
yield $ do
eExc <- tryAnyCond (Dir.doesDirectoryExist fpStr >>=
(`when` Posix.setFileTimes fpStr fileModTime fileModTime))
return (fi, either ((excs ++) . pure) (const excs) eExc)
FTSymbolicLink link -> do
excs <- liftIO $ do
void $ tryAny $ Posix.removeLink fpStr
when lenient $ Dir.createDirectoryIfMissing True $ Posix.takeDirectory fpStr
Posix.createSymbolicLink (decodeFilePath link) fpStr
eExc1 <- tryAnyCond $ Posix.setSymbolicLinkOwnerAndGroup fpStr fileUserId fileGroupId
#if MIN_VERSION_unix(2,7,0)
let CTime epochInt32 = fileModTime
unixModTime = fromInteger (fromIntegral epochInt32)
eExc2 <- tryAny $ Posix.setSymbolicLinkTimesHiRes fpStr unixModTime unixModTime
#endif
return $ fst $ partitionEithers [eExc1, eExc2]
unless (null excs) $ yield (return (fi, excs))
FTHardLink link -> do
excs <- liftIO $ do
let linkedFp = decodeFilePath link
when lenient $ do
linkedFileExists <- Posix.fileExist linkedFp
unless linkedFileExists $ do
Dir.createDirectoryIfMissing True $ Posix.takeDirectory linkedFp
writeFile linkedFp ""
Dir.createDirectoryIfMissing True $ Posix.takeDirectory fpStr
void $ tryAny $ Posix.removeLink fpStr
Posix.createLink linkedFp fpStr
liftIO $ do
excs <- restorePermissions
eExc <- tryAnyCond $ Posix.setFileTimes fpStr fileModTime fileModTime
return (either ((excs ++) . pure) (const excs) eExc)
unless (null excs) $ yield (return (fi, excs))
FTNormal -> do
when lenient $ liftIO $ Dir.createDirectoryIfMissing True $ Posix.takeDirectory fpStr
sinkFile fpStr
excs <- liftIO $ do
excs <- restorePermissions
eExc <- tryAnyCond $ Posix.setFileTimes fpStr fileModTime fileModTime
return (either ((excs ++) . pure) (const excs) eExc)
unless (null excs) $ yield $ return (fi, excs)
ty -> do
let exc = UnsupportedType ty
unless lenient $ liftIO $ throwM exc
yield $ return (fi, [toException exc])