{-# 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
    FileStatus
fs <- [Char] -> IO FileStatus
Posix.getSymbolicLinkStatus [Char]
fpStr
    let uid :: UserID
uid = FileStatus -> UserID
Posix.fileOwner FileStatus
fs
        gid :: GroupID
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 = either (const "") UBS.userName euEntry
      fileGroupName = either (const "") UBS.groupName egEntry
#else
    Either IOException UserEntry
euEntry :: Either IOException Posix.UserEntry <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ UserID -> IO UserEntry
Posix.getUserEntryForID UserID
uid
    Either IOException GroupEntry
egEntry :: Either IOException Posix.GroupEntry <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ GroupID -> IO GroupEntry
Posix.getGroupEntryForID GroupID
gid
    let
      fileUserName :: ByteString
fileUserName = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const ByteString
"") ([Char] -> ByteString
S8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserEntry -> [Char]
Posix.userName) Either IOException UserEntry
euEntry
      fileGroupName :: ByteString
fileGroupName = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const ByteString
"") ([Char] -> ByteString
S8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupEntry -> [Char]
Posix.groupName) Either IOException GroupEntry
egEntry
#endif
    (FileType
fType, FileOffset
fSize) <-
        case () of
            () | FileStatus -> Bool
Posix.isRegularFile FileStatus
fs     -> forall (m :: * -> *) a. Monad m => a -> m a
return (FileType
FTNormal, FileStatus -> FileOffset
Posix.fileSize FileStatus
fs)
               | FileStatus -> Bool
Posix.isSymbolicLink FileStatus
fs    -> do
                     [Char]
ln <- [Char] -> IO [Char]
Posix.readSymbolicLink [Char]
fpStr
                     forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> FileType
FTSymbolicLink ([Char] -> ByteString
encodeFilePath [Char]
ln), FileOffset
0)
               | FileStatus -> Bool
Posix.isCharacterDevice FileStatus
fs -> forall (m :: * -> *) a. Monad m => a -> m a
return (FileType
FTCharacterSpecial, FileOffset
0)
               | FileStatus -> Bool
Posix.isBlockDevice FileStatus
fs     -> forall (m :: * -> *) a. Monad m => a -> m a
return (FileType
FTBlockSpecial, FileOffset
0)
               | FileStatus -> Bool
Posix.isDirectory FileStatus
fs       -> forall (m :: * -> *) a. Monad m => a -> m a
return (FileType
FTDirectory, FileOffset
0)
               | FileStatus -> Bool
Posix.isNamedPipe FileStatus
fs       -> forall (m :: * -> *) a. Monad m => a -> m a
return (FileType
FTFifo, FileOffset
0)
               | Bool
otherwise                  -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported file type: " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
S8.unpack ByteString
fp
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! FileInfo
        { filePath :: ByteString
filePath      = ByteString
fp
        , fileUserId :: UserID
fileUserId    = UserID
uid
        , fileUserName :: ByteString
fileUserName  = ByteString
fileUserName
        , fileGroupId :: GroupID
fileGroupId   = GroupID
gid
        , fileGroupName :: ByteString
fileGroupName = ByteString
fileGroupName
        , fileMode :: FileMode
fileMode      = FileStatus -> FileMode
Posix.fileMode FileStatus
fs forall a. Bits a => a -> a -> a
.&. FileMode
0o7777
        , fileSize :: FileOffset
fileSize      = FileOffset
fSize
        , fileType :: FileType
fileType      = FileType
fType
        , fileModTime :: EpochTime
fileModTime   = FileStatus -> EpochTime
Posix.modificationTime FileStatus
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 {UserID
FileOffset
FileMode
GroupID
EpochTime
ByteString
FileType
fileModTime :: EpochTime
fileType :: FileType
fileSize :: FileOffset
fileMode :: FileMode
fileGroupName :: ByteString
fileGroupId :: GroupID
fileUserName :: ByteString
fileUserId :: UserID
filePath :: ByteString
fileModTime :: FileInfo -> EpochTime
fileType :: FileInfo -> FileType
fileSize :: FileInfo -> FileOffset
fileMode :: FileInfo -> FileMode
fileGroupName :: FileInfo -> ByteString
fileGroupId :: FileInfo -> GroupID
fileUserName :: FileInfo -> ByteString
fileUserId :: FileInfo -> UserID
filePath :: FileInfo -> ByteString
..} = 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 forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAny m a
action else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right m a
action
        restorePermissions :: IO [SomeException]
restorePermissions = do
            Either SomeException ()
eExc1 <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAnyCond forall a b. (a -> b) -> a -> b
$ [Char] -> UserID -> GroupID -> IO ()
Posix.setOwnerAndGroup [Char]
fpStr UserID
fileUserId GroupID
fileGroupId
            Either SomeException ()
eExc2 <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAnyCond forall a b. (a -> b) -> a -> b
$ [Char] -> FileMode -> IO ()
Posix.setFileMode [Char]
fpStr FileMode
fileMode
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either SomeException ()
eExc1, Either SomeException ()
eExc2]
        -- | Catch all exceptions, but only if lenient is set to True
    case FileType
fileType of
        FileType
FTDirectory -> do
            [SomeException]
excs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                Bool -> [Char] -> IO ()
Dir.createDirectoryIfMissing Bool
True [Char]
fpStr
                IO [SomeException]
restorePermissions
            forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ do
                Either SomeException ()
eExc <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAnyCond ([Char] -> IO Bool
Dir.doesDirectoryExist [Char]
fpStr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                    (forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`when` [Char] -> EpochTime -> EpochTime -> IO ()
Posix.setFileTimes [Char]
fpStr EpochTime
fileModTime EpochTime
fileModTime))
                forall (m :: * -> *) a. Monad m => a -> m a
return (FileInfo
fi, forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (([SomeException]
excs forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) (forall a b. a -> b -> a
const [SomeException]
excs) Either SomeException ()
eExc)
        FTSymbolicLink ByteString
link -> do
            [SomeException]
excs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                -- Try to unlink any existing file/symlink
                forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
Posix.removeLink [Char]
fpStr
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
lenient forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
Dir.createDirectoryIfMissing Bool
True 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
                Either SomeException ()
eExc1 <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAnyCond 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 Int64
epochInt32 = EpochTime
fileModTime
                    unixModTime :: POSIXTime
unixModTime = forall a. Num a => Integer -> a
fromInteger (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
epochInt32)
                Either SomeException ()
eExc2 <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ [Char] -> POSIXTime -> POSIXTime -> IO ()
Posix.setSymbolicLinkTimesHiRes [Char]
fpStr POSIXTime
unixModTime POSIXTime
unixModTime
#endif
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either SomeException ()
eExc1, Either SomeException ()
eExc2]
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SomeException]
excs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (forall (m :: * -> *) a. Monad m => a -> m a
return (FileInfo
fi, [SomeException]
excs))
        FTHardLink ByteString
link -> do
            [SomeException]
excs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                let linkedFp :: [Char]
linkedFp = ByteString -> [Char]
decodeFilePath ByteString
link
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
lenient forall a b. (a -> b) -> a -> b
$ do
                    Bool
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.
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
linkedFileExists forall a b. (a -> b) -> a -> b
$ do
                        Bool -> [Char] -> IO ()
Dir.createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
Posix.takeDirectory [Char]
linkedFp
                        [Char] -> [Char] -> IO ()
writeFile [Char]
linkedFp [Char]
""
                Bool -> [Char] -> IO ()
Dir.createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
Posix.takeDirectory [Char]
fpStr
                -- Try to unlink any existing file/hard link
                forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
Posix.removeLink [Char]
fpStr
                [Char] -> [Char] -> IO ()
Posix.createLink [Char]
linkedFp [Char]
fpStr
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                    [SomeException]
excs <- IO [SomeException]
restorePermissions
                    Either SomeException ()
eExc <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAnyCond forall a b. (a -> b) -> a -> b
$ [Char] -> EpochTime -> EpochTime -> IO ()
Posix.setFileTimes [Char]
fpStr EpochTime
fileModTime EpochTime
fileModTime
                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (([SomeException]
excs forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) (forall a b. a -> b -> a
const [SomeException]
excs) Either SomeException ()
eExc)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SomeException]
excs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (forall (m :: * -> *) a. Monad m => a -> m a
return (FileInfo
fi, [SomeException]
excs))
        FileType
FTNormal -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
lenient forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
Dir.createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
Posix.takeDirectory [Char]
fpStr
            forall (m :: * -> *) o.
MonadResource m =>
[Char] -> ConduitT ByteString o m ()
sinkFile [Char]
fpStr
            [SomeException]
excs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                [SomeException]
excs <- IO [SomeException]
restorePermissions
                Either SomeException ()
eExc <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAnyCond forall a b. (a -> b) -> a -> b
$ [Char] -> EpochTime -> EpochTime -> IO ()
Posix.setFileTimes [Char]
fpStr EpochTime
fileModTime EpochTime
fileModTime
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (([SomeException]
excs forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) (forall a b. a -> b -> a
const [SomeException]
excs) Either SomeException ()
eExc)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SomeException]
excs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (FileInfo
fi, [SomeException]
excs)
        FileType
ty -> do
            let exc :: TarException
exc = FileType -> TarException
UnsupportedType FileType
ty
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
lenient forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM TarException
exc
            forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (FileInfo
fi, [forall e. Exception e => e -> SomeException
toException TarException
exc])