{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
-- | Handles allocation of temporary directories and unpacking of bundles into
-- them. Sets owner and group of all created files and directories as
-- necessary.
module Keter.TempTarball
    ( TempFolder
    , setup
    , unpackTempTar
    ) where

import qualified Codec.Archive.Tar         as Tar
import qualified Codec.Archive.Tar.Check   as Tar
import qualified Codec.Archive.Tar.Entry   as Tar
import           Codec.Compression.GZip    (decompress)
import           Control.Exception         (bracket, bracketOnError, throwIO)
import           Control.Monad             (unless, when)
import qualified Data.ByteString.Lazy      as L
import           Data.ByteString.Unsafe    (unsafeUseAsCStringLen)
import qualified Data.IORef                as I
import           Data.Monoid               ((<>))
import           Data.Text                 (Text, pack, unpack)
import           Data.Word                 (Word)
import           System.FilePath ((</>))
import qualified System.FilePath           as F
import qualified System.Directory          as D
import           Foreign.Ptr               (castPtr)
import           System.Posix.Files        (setFdOwnerAndGroup,
                                            setOwnerAndGroup)
import           System.Posix.IO           (FdOption (CloseOnExec), closeFd,
                                            createFile, fdWriteBuf, setFdOption)
import           System.Posix.Types        (GroupID, UserID)

data TempFolder = TempFolder
    { TempFolder -> FilePath
tfRoot    :: FilePath
    , TempFolder -> IORef Word
tfCounter :: I.IORef Word
    }

setup :: FilePath -> IO TempFolder
setup :: FilePath -> IO TempFolder
setup FilePath
fp = do
    Bool
e <- FilePath -> IO Bool
D.doesDirectoryExist FilePath
fp
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
e (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
D.removeDirectoryRecursive FilePath
fp
    Bool -> FilePath -> IO ()
D.createDirectoryIfMissing Bool
True FilePath
fp
    IORef Word
c <- Word -> IO (IORef Word)
forall a. a -> IO (IORef a)
I.newIORef Word
forall a. Bounded a => a
minBound
    TempFolder -> IO TempFolder
forall (m :: * -> *) a. Monad m => a -> m a
return (TempFolder -> IO TempFolder) -> TempFolder -> IO TempFolder
forall a b. (a -> b) -> a -> b
$ FilePath -> IORef Word -> TempFolder
TempFolder FilePath
fp IORef Word
c

getFolder :: Maybe (UserID, GroupID)
          -> TempFolder
          -> Text -- ^ prefix for folder name
          -> IO FilePath
getFolder :: Maybe (UserID, GroupID) -> TempFolder -> Text -> IO FilePath
getFolder Maybe (UserID, GroupID)
muid TempFolder {FilePath
IORef Word
tfCounter :: IORef Word
tfRoot :: FilePath
tfCounter :: TempFolder -> IORef Word
tfRoot :: TempFolder -> FilePath
..} Text
appname = do
    !Word
i <- IORef Word -> (Word -> (Word, Word)) -> IO Word
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef Word
tfCounter ((Word -> (Word, Word)) -> IO Word)
-> (Word -> (Word, Word)) -> IO Word
forall a b. (a -> b) -> a -> b
$ \Word
i -> (Word -> Word
forall a. Enum a => a -> a
succ Word
i, Word
i)
    let fp :: FilePath
fp = FilePath
tfRoot FilePath -> FilePath -> FilePath
</> Text -> FilePath
unpack (Text
appname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
pack (Word -> FilePath
forall a. Show a => a -> FilePath
show Word
i))
    Bool -> FilePath -> IO ()
D.createDirectoryIfMissing Bool
True FilePath
fp
    case Maybe (UserID, GroupID)
muid of
        Maybe (UserID, GroupID)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (UserID
uid, GroupID
gid) -> FilePath -> UserID -> GroupID -> IO ()
setOwnerAndGroup FilePath
fp UserID
uid GroupID
gid
    FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
fp

unpackTempTar :: Maybe (UserID, GroupID)
              -> TempFolder
              -> FilePath -- ^ bundle
              -> Text -- ^ prefix for folder name
              -> (FilePath -> IO a)
              -> IO a
unpackTempTar :: Maybe (UserID, GroupID)
-> TempFolder -> FilePath -> Text -> (FilePath -> IO a) -> IO a
unpackTempTar Maybe (UserID, GroupID)
muid TempFolder
tf FilePath
bundle Text
appname FilePath -> IO a
withDir = do
    ByteString
lbs <- FilePath -> IO ByteString
L.readFile FilePath
bundle
    IO FilePath -> (FilePath -> IO ()) -> (FilePath -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (Maybe (UserID, GroupID) -> TempFolder -> Text -> IO FilePath
getFolder Maybe (UserID, GroupID)
muid TempFolder
tf Text
appname) FilePath -> IO ()
D.removeDirectoryRecursive ((FilePath -> IO a) -> IO a) -> (FilePath -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
        Maybe (UserID, GroupID) -> FilePath -> Entries FormatError -> IO ()
unpackTar Maybe (UserID, GroupID)
muid FilePath
dir (Entries FormatError -> IO ()) -> Entries FormatError -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Entries FormatError
Tar.read (ByteString -> Entries FormatError)
-> ByteString -> Entries FormatError
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
decompress ByteString
lbs
        FilePath -> IO a
withDir FilePath
dir

unpackTar :: Maybe (UserID, GroupID)
          -> FilePath
          -> Tar.Entries Tar.FormatError
          -> IO ()
unpackTar :: Maybe (UserID, GroupID) -> FilePath -> Entries FormatError -> IO ()
unpackTar Maybe (UserID, GroupID)
muid FilePath
dir =
    Entries (Either FormatError FileNameError) -> IO ()
forall e e.
(Exception e, Exception e) =>
Entries (Either e e) -> IO ()
loop (Entries (Either FormatError FileNameError) -> IO ())
-> (Entries FormatError
    -> Entries (Either FormatError FileNameError))
-> Entries FormatError
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entries FormatError -> Entries (Either FormatError FileNameError)
forall e. Entries e -> Entries (Either e FileNameError)
Tar.checkSecurity
  where
    loop :: Entries (Either e e) -> IO ()
loop Entries (Either e e)
Tar.Done = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    loop (Tar.Fail Either e e
e) = (e -> IO ()) -> (e -> IO ()) -> Either e e -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> IO ()
forall e a. Exception e => e -> IO a
throwIO e -> IO ()
forall e a. Exception e => e -> IO a
throwIO Either e e
e
    loop (Tar.Next Entry
e Entries (Either e e)
es) = Entry -> IO ()
go Entry
e IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Entries (Either e e) -> IO ()
loop Entries (Either e e)
es

    go :: Entry -> IO ()
go Entry
e = do
        let fp :: FilePath
fp = FilePath
dir FilePath -> FilePath -> FilePath
</> Entry -> FilePath
Tar.entryPath Entry
e
        case Entry -> EntryContent
Tar.entryContent Entry
e of
            Tar.NormalFile ByteString
lbs FileSize
_ -> do
                case Maybe (UserID, GroupID)
muid of
                    Maybe (UserID, GroupID)
Nothing -> Bool -> FilePath -> IO ()
D.createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
F.takeDirectory FilePath
fp
                    Just (UserID
uid, GroupID
gid) -> UserID -> GroupID -> FilePath -> IO ()
createTreeUID UserID
uid GroupID
gid (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
F.takeDirectory FilePath
fp
                let write :: Fd -> ByteString -> IO ()
write Fd
fd ByteString
bs = ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ptr, Int
len) -> do
                        ByteCount
_ <- Fd -> Ptr Word8 -> ByteCount -> IO ByteCount
fdWriteBuf Fd
fd (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr) (Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
                        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                IO Fd -> (Fd -> IO ()) -> (Fd -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
                    (do
                        Fd
fd <- FilePath -> FileMode -> IO Fd
createFile FilePath
fp (FileMode -> IO Fd) -> FileMode -> IO Fd
forall a b. (a -> b) -> a -> b
$ Entry -> FileMode
Tar.entryPermissions Entry
e
                        Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
fd FdOption
CloseOnExec Bool
True
                        case Maybe (UserID, GroupID)
muid of
                            Maybe (UserID, GroupID)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                            Just (UserID
uid, GroupID
gid) -> Fd -> UserID -> GroupID -> IO ()
setFdOwnerAndGroup Fd
fd UserID
uid GroupID
gid
                        Fd -> IO Fd
forall (m :: * -> *) a. Monad m => a -> m a
return Fd
fd)
                    Fd -> IO ()
closeFd
                    (\Fd
fd -> (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Fd -> ByteString -> IO ()
write Fd
fd) (ByteString -> [ByteString]
L.toChunks ByteString
lbs))
            EntryContent
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Create a directory tree, setting the uid and gid of all newly created
-- folders.
createTreeUID :: UserID -> GroupID -> FilePath -> IO ()
createTreeUID :: UserID -> GroupID -> FilePath -> IO ()
createTreeUID UserID
uid GroupID
gid =
    FilePath -> IO ()
go
  where
    go :: FilePath -> IO ()
go FilePath
fp = do
        Bool
exists <- FilePath -> IO Bool
D.doesDirectoryExist FilePath
fp
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            FilePath -> IO ()
go (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
F.takeDirectory FilePath
fp
            Bool -> FilePath -> IO ()
D.createDirectoryIfMissing Bool
False FilePath
fp
            FilePath -> UserID -> GroupID -> IO ()
setOwnerAndGroup FilePath
fp UserID
uid GroupID
gid