{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
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
-> 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
-> Text
-> (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