{-# 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, forM)
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 a. a -> IO a
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
tfRoot :: TempFolder -> FilePath
tfCounter :: TempFolder -> IORef Word
tfRoot :: FilePath
tfCounter :: IORef Word
..} 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 a. a -> IO a
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 a. a -> IO a
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 :: forall a.
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
        Bool -> FilePath -> IO ()
D.createDirectoryIfMissing Bool
True FilePath
dir
        let entries :: Entries FormatError
entries = ByteString -> Entries FormatError
Tar.read (ByteString -> Entries FormatError)
-> ByteString -> Entries FormatError
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
decompress ByteString
lbs
        FilePath -> Entries FormatError -> IO ()
forall e. Exception e => FilePath -> Entries e -> IO ()
Tar.unpack FilePath
dir Entries FormatError
entries
        Maybe ()
_ <- Maybe (UserID, GroupID)
-> ((UserID, GroupID) -> IO ()) -> IO (Maybe ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (UserID, GroupID)
muid (((UserID, GroupID) -> IO ()) -> IO (Maybe ()))
-> ((UserID, GroupID) -> IO ()) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ \(UserID, GroupID)
perms ->
          (GenEntry TarPath LinkTarget -> IO () -> IO ())
-> IO () -> (FormatError -> IO ()) -> Entries FormatError -> IO ()
forall tarPath linkTarget a e.
(GenEntry tarPath linkTarget -> a -> a)
-> a -> (e -> a) -> GenEntries tarPath linkTarget e -> a
Tar.foldEntries ((UserID, GroupID) -> GenEntry TarPath LinkTarget -> IO () -> IO ()
setEntryPermission (UserID, GroupID)
perms) (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) FormatError -> IO ()
forall e a. Exception e => e -> IO a
throwIO Entries FormatError
entries
        FilePath -> IO a
withDir FilePath
dir

setEntryPermission :: (UserID, GroupID) -> Tar.Entry ->  IO () -> IO ()
setEntryPermission :: (UserID, GroupID) -> GenEntry TarPath LinkTarget -> IO () -> IO ()
setEntryPermission (UserID
uid, GroupID
gid) GenEntry TarPath LinkTarget
entry IO ()
io =
  IO ()
io IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> UserID -> GroupID -> IO ()
setOwnerAndGroup (GenEntry TarPath LinkTarget -> FilePath
forall linkTarget. GenEntry TarPath linkTarget -> FilePath
Tar.entryPath GenEntry TarPath LinkTarget
entry) UserID
uid GroupID
gid