{-# 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 Codec.Archive.Tar qualified as Tar
import Codec.Compression.GZip (decompress)
import Control.Exception (bracketOnError, throwIO)
import Control.Monad (forM_, when)
import Data.ByteString.Lazy qualified as L
import Data.IORef qualified as I
import Data.Text (Text, pack, unpack)
import System.Directory qualified as D
import System.FilePath ((</>))
import System.Posix.Files (setOwnerAndGroup)
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 (UserID, GroupID) -> ((UserID, GroupID) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (UserID, GroupID)
muid (((UserID, GroupID) -> IO ()) -> IO ())
-> ((UserID, GroupID) -> IO ()) -> IO ()
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