{-# 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
#if MIN_VERSION_unix(2,8,0)
import qualified System.Posix.User.ByteString as UBS
#endif

getFileInfo :: FilePath -> IO FileInfo
getFileInfo :: [Char] -> IO FileInfo
getFileInfo [Char]
fpStr = do
    let fp :: ByteString
fp = [Char] -> ByteString
encodeFilePath [Char]
fpStr
    fs <- [Char] -> IO FileStatus
Posix.getSymbolicLinkStatus [Char]
fpStr
    let uid = FileStatus -> UserID
Posix.fileOwner FileStatus
fs
        gid = FileStatus -> GroupID
Posix.fileGroup FileStatus
fs
    -- Allow for username/group retrieval failure, especially useful for non-tty environment.
    -- Workaround for: https://ghc.haskell.org/trac/ghc/ticket/1487
    -- Moreover, names are non-critical as they are not used during unarchival process
#if MIN_VERSION_unix(2,8,0)
    euEntry :: Either IOException UBS.UserEntry <- try $ Posix.getUserEntryForID uid
    egEntry :: Either IOException UBS.GroupEntry <- try $ Posix.getGroupEntryForID gid
    let
      fileUserName = (IOException -> ByteString)
-> (UserEntry -> ByteString)
-> Either IOException UserEntry
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> IOException -> ByteString
forall a b. a -> b -> a
const ByteString
"") UserEntry -> ByteString
UBS.userName Either IOException UserEntry
euEntry
      fileGroupName = (IOException -> ByteString)
-> (GroupEntry -> ByteString)
-> Either IOException GroupEntry
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> IOException -> ByteString
forall a b. a -> b -> a
const ByteString
"") GroupEntry -> ByteString
UBS.groupName Either IOException GroupEntry
egEntry
#else
    euEntry :: Either IOException Posix.UserEntry <- try $ Posix.getUserEntryForID uid
    egEntry :: Either IOException Posix.GroupEntry <- try $ Posix.getGroupEntryForID gid
    let
      fileUserName = either (const "") (S8.pack . Posix.userName) euEntry
      fileGroupName = either (const "") (S8.pack . Posix.groupName) egEntry
#endif
    (fType, fSize) <-
        case () of
            () | FileStatus -> Bool
Posix.isRegularFile FileStatus
fs     -> (FileType, FileOffset) -> IO (FileType, FileOffset)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileType
FTNormal, FileStatus -> FileOffset
Posix.fileSize FileStatus
fs)
               | FileStatus -> Bool
Posix.isSymbolicLink FileStatus
fs    -> do
                     ln <- [Char] -> IO [Char]
Posix.readSymbolicLink [Char]
fpStr
                     return (FTSymbolicLink (encodeFilePath ln), 0)
               | FileStatus -> Bool
Posix.isCharacterDevice FileStatus
fs -> (FileType, FileOffset) -> IO (FileType, FileOffset)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileType
FTCharacterSpecial, FileOffset
0)
               | FileStatus -> Bool
Posix.isBlockDevice FileStatus
fs     -> (FileType, FileOffset) -> IO (FileType, FileOffset)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileType
FTBlockSpecial, FileOffset
0)
               | FileStatus -> Bool
Posix.isDirectory FileStatus
fs       -> (FileType, FileOffset) -> IO (FileType, FileOffset)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileType
FTDirectory, FileOffset
0)
               | FileStatus -> Bool
Posix.isNamedPipe FileStatus
fs       -> (FileType, FileOffset) -> IO (FileType, FileOffset)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileType
FTFifo, FileOffset
0)
               | Bool
otherwise                  -> [Char] -> IO (FileType, FileOffset)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (FileType, FileOffset))
-> [Char] -> IO (FileType, FileOffset)
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported file type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
S8.unpack ByteString
fp
    return $! FileInfo
        { filePath      = fp
        , fileUserId    = uid
        , fileUserName  = fileUserName
        , fileGroupId   = gid
        , fileGroupName = fileGroupName
        , fileMode      = Posix.fileMode fs .&. 0o7777
        , fileSize      = fSize
        , fileType      = fType
        , fileModTime   = Posix.modificationTime fs
        }

-- | See 'Data.Conduit.Tar.restoreFileWithErrors' for documentation
restoreFileInternal ::
       (MonadResource m)
    => Bool
    -> FileInfo
    -> ConduitM S8.ByteString (IO (FileInfo, [SomeException])) m ()
restoreFileInternal :: forall (m :: * -> *).
MonadResource m =>
Bool
-> FileInfo
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
restoreFileInternal Bool
lenient fi :: FileInfo
fi@FileInfo {EpochTime
GroupID
FileMode
FileOffset
UserID
ByteString
FileType
filePath :: FileInfo -> ByteString
fileUserId :: FileInfo -> UserID
fileUserName :: FileInfo -> ByteString
fileGroupId :: FileInfo -> GroupID
fileGroupName :: FileInfo -> ByteString
fileMode :: FileInfo -> FileMode
fileSize :: FileInfo -> FileOffset
fileType :: FileInfo -> FileType
fileModTime :: FileInfo -> EpochTime
filePath :: ByteString
fileUserId :: UserID
fileUserName :: ByteString
fileGroupId :: GroupID
fileGroupName :: ByteString
fileMode :: FileMode
fileSize :: FileOffset
fileType :: FileType
fileModTime :: EpochTime
..} = do
    let fpStr :: [Char]
fpStr = ByteString -> [Char]
decodeFilePath ByteString
filePath
        tryAnyCond :: m a -> m (Either SomeException a)
tryAnyCond m a
action = if Bool
lenient then m a -> m (Either SomeException a)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryAny m a
action else (a -> Either SomeException a) -> m a -> m (Either SomeException a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either SomeException a
forall a b. b -> Either a b
Right m a
action
        restorePermissions :: IO [SomeException]
restorePermissions = do
            eExc1 <- IO () -> IO (Either SomeException ())
forall {m :: * -> *} {a}.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAnyCond (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ [Char] -> UserID -> GroupID -> IO ()
Posix.setOwnerAndGroup [Char]
fpStr UserID
fileUserId GroupID
fileGroupId
            eExc2 <- tryAnyCond $ Posix.setFileMode fpStr fileMode
            return $! fst $ partitionEithers [eExc1, eExc2]
        -- | Catch all exceptions, but only if lenient is set to True
    case FileType
fileType of
        FileType
FTDirectory -> do
            excs <- IO [SomeException]
-> ConduitT
     ByteString (IO (FileInfo, [SomeException])) m [SomeException]
forall a.
IO a -> ConduitT ByteString (IO (FileInfo, [SomeException])) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [SomeException]
 -> ConduitT
      ByteString (IO (FileInfo, [SomeException])) m [SomeException])
-> IO [SomeException]
-> ConduitT
     ByteString (IO (FileInfo, [SomeException])) m [SomeException]
forall a b. (a -> b) -> a -> b
$ do
                Bool -> [Char] -> IO ()
Dir.createDirectoryIfMissing Bool
True [Char]
fpStr
                IO [SomeException]
restorePermissions
            yield $ do
                eExc <- tryAnyCond (Dir.doesDirectoryExist fpStr >>=
                                    (`when` Posix.setFileTimes fpStr fileModTime fileModTime))
                return (fi, either ((excs ++) . pure) (const excs) eExc)
        FTSymbolicLink ByteString
link -> do
            excs <- IO [SomeException]
-> ConduitT
     ByteString (IO (FileInfo, [SomeException])) m [SomeException]
forall a.
IO a -> ConduitT ByteString (IO (FileInfo, [SomeException])) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [SomeException]
 -> ConduitT
      ByteString (IO (FileInfo, [SomeException])) m [SomeException])
-> IO [SomeException]
-> ConduitT
     ByteString (IO (FileInfo, [SomeException])) m [SomeException]
forall a b. (a -> b) -> a -> b
$ do
                -- Try to unlink any existing file/symlink
                IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> IO (Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryAny (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
Posix.removeLink [Char]
fpStr
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
lenient (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
Dir.createDirectoryIfMissing Bool
True ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
Posix.takeDirectory [Char]
fpStr
                [Char] -> [Char] -> IO ()
Posix.createSymbolicLink (ByteString -> [Char]
decodeFilePath ByteString
link) [Char]
fpStr
                eExc1 <- IO () -> IO (Either SomeException ())
forall {m :: * -> *} {a}.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAnyCond (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ [Char] -> UserID -> GroupID -> IO ()
Posix.setSymbolicLinkOwnerAndGroup [Char]
fpStr UserID
fileUserId GroupID
fileGroupId
#if MIN_VERSION_unix(2,7,0)
                -- Try best effort in setting symbolic link modification time.
                let CTime epochInt32 = fileModTime
                    unixModTime = Integer -> POSIXTime
forall a. Num a => Integer -> a
fromInteger (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
epochInt32)
                eExc2 <- tryAny $ Posix.setSymbolicLinkTimesHiRes fpStr unixModTime unixModTime
#endif
                return $ fst $ partitionEithers [eExc1, eExc2]
            unless (null excs) $ yield (return (fi, excs))
        FTHardLink ByteString
link -> do
            excs <- IO [SomeException]
-> ConduitT
     ByteString (IO (FileInfo, [SomeException])) m [SomeException]
forall a.
IO a -> ConduitT ByteString (IO (FileInfo, [SomeException])) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [SomeException]
 -> ConduitT
      ByteString (IO (FileInfo, [SomeException])) m [SomeException])
-> IO [SomeException]
-> ConduitT
     ByteString (IO (FileInfo, [SomeException])) m [SomeException]
forall a b. (a -> b) -> a -> b
$ do
                let linkedFp :: [Char]
linkedFp = ByteString -> [Char]
decodeFilePath ByteString
link
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
lenient (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    linkedFileExists <- [Char] -> IO Bool
Posix.fileExist [Char]
linkedFp
                    -- If the linked file does not exist (yet), we cannot create a hard link.
                    -- Try to "pre-create" it.
                    unless linkedFileExists $ do
                        Dir.createDirectoryIfMissing True $ Posix.takeDirectory linkedFp
                        writeFile linkedFp ""
                Bool -> [Char] -> IO ()
Dir.createDirectoryIfMissing Bool
True ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
Posix.takeDirectory [Char]
fpStr
                -- Try to unlink any existing file/hard link
                IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> IO (Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryAny (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
Posix.removeLink [Char]
fpStr
                [Char] -> [Char] -> IO ()
Posix.createLink [Char]
linkedFp [Char]
fpStr
                IO [SomeException] -> IO [SomeException]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [SomeException] -> IO [SomeException])
-> IO [SomeException] -> IO [SomeException]
forall a b. (a -> b) -> a -> b
$ do
                    excs <- IO [SomeException]
restorePermissions
                    eExc <- tryAnyCond $ Posix.setFileTimes fpStr fileModTime fileModTime
                    return (either ((excs ++) . pure) (const excs) eExc)
            unless (null excs) $ yield (return (fi, excs))
        FileType
FTNormal -> do
            Bool
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
lenient (ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
 -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ())
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall a b. (a -> b) -> a -> b
$ IO () -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall a.
IO a -> ConduitT ByteString (IO (FileInfo, [SomeException])) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ())
-> IO ()
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
Dir.createDirectoryIfMissing Bool
True ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
Posix.takeDirectory [Char]
fpStr
            [Char] -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall (m :: * -> *) o.
MonadResource m =>
[Char] -> ConduitT ByteString o m ()
sinkFile [Char]
fpStr
            excs <- IO [SomeException]
-> ConduitT
     ByteString (IO (FileInfo, [SomeException])) m [SomeException]
forall a.
IO a -> ConduitT ByteString (IO (FileInfo, [SomeException])) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [SomeException]
 -> ConduitT
      ByteString (IO (FileInfo, [SomeException])) m [SomeException])
-> IO [SomeException]
-> ConduitT
     ByteString (IO (FileInfo, [SomeException])) m [SomeException]
forall a b. (a -> b) -> a -> b
$ do
                excs <- IO [SomeException]
restorePermissions
                eExc <- tryAnyCond $ Posix.setFileTimes fpStr fileModTime fileModTime
                return (either ((excs ++) . pure) (const excs) eExc)
            unless (null excs) $ yield $ return (fi, excs)
        FileType
ty -> do
            let exc :: TarException
exc = FileType -> TarException
UnsupportedType FileType
ty
            Bool
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
lenient (ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
 -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ())
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall a b. (a -> b) -> a -> b
$ IO () -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall a.
IO a -> ConduitT ByteString (IO (FileInfo, [SomeException])) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ())
-> IO ()
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall a b. (a -> b) -> a -> b
$ TarException -> IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwM TarException
exc
            IO (FileInfo, [SomeException])
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (IO (FileInfo, [SomeException])
 -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ())
-> IO (FileInfo, [SomeException])
-> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()
forall a b. (a -> b) -> a -> b
$ (FileInfo, [SomeException]) -> IO (FileInfo, [SomeException])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileInfo
fi, [TarException -> SomeException
forall e. Exception e => e -> SomeException
toException TarException
exc])