{-# 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
e 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 <- forall a. a -> IO (IORef a)
I.newIORef forall a. Bounded a => a
minBound
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef IORef Word
tfCounter forall a b. (a -> b) -> a -> b
$ \Word
i -> (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 forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
pack (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 -> 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
    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
    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 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 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
decompress ByteString
lbs
        forall e. Exception e => FilePath -> Entries e -> IO ()
Tar.unpack FilePath
dir Entries FormatError
entries
        Maybe ()
_ <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (UserID, GroupID)
muid forall a b. (a -> b) -> a -> b
$ \(UserID, GroupID)
perms ->
          forall tarPath linkTarget a e.
(GenEntry tarPath linkTarget -> a -> a)
-> a -> (e -> a) -> GenEntries tarPath linkTarget e -> a
Tar.foldEntries ((UserID, GroupID) -> Entry -> IO () -> IO ()
setEntryPermission (UserID, GroupID)
perms) (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) 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) -> Entry -> IO () -> IO ()
setEntryPermission (UserID
uid, GroupID
gid) Entry
entry IO ()
io =
  IO ()
io forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> UserID -> GroupID -> IO ()
setOwnerAndGroup (forall linkTarget. GenEntry TarPath linkTarget -> FilePath
Tar.entryPath Entry
entry) UserID
uid GroupID
gid