{-# 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
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
-> 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
-> 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
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