{-# 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)
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
        Maybe (UserID, GroupID) -> FilePath -> Entries FormatError -> IO ()
unpackTar Maybe (UserID, GroupID)
muid FilePath
dir forall a b. (a -> b) -> a -> b
$ ByteString -> Entries FormatError
Tar.read forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
decompress ByteString
lbs
        FilePath -> IO a
withDir FilePath
dir

unpackTar :: Maybe (UserID, GroupID)
          -> FilePath
          -> Tar.Entries Tar.FormatError
          -> IO ()
unpackTar :: Maybe (UserID, GroupID) -> FilePath -> Entries FormatError -> IO ()
unpackTar Maybe (UserID, GroupID)
muid FilePath
dir =
    forall {a} {b}.
(Exception a, Exception b) =>
Entries (Either a b) -> IO ()
loop forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Entries e -> Entries (Either e FileNameError)
Tar.checkSecurity
  where
    loop :: Entries (Either a b) -> IO ()
loop Entries (Either a b)
Tar.Done = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    loop (Tar.Fail Either a b
e) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall e a. Exception e => e -> IO a
throwIO Either a b
e
    loop (Tar.Next Entry
e Entries (Either a b)
es) = Entry -> IO ()
go Entry
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Entries (Either a b) -> IO ()
loop Entries (Either a b)
es

    go :: Entry -> IO ()
go Entry
e = do
        let fp :: FilePath
fp = FilePath
dir FilePath -> FilePath -> FilePath
</> Entry -> FilePath
Tar.entryPath Entry
e
        case Entry -> EntryContent
Tar.entryContent Entry
e of
            Tar.NormalFile ByteString
lbs FileSize
_ -> do
                case Maybe (UserID, GroupID)
muid of
                    Maybe (UserID, GroupID)
Nothing -> Bool -> FilePath -> IO ()
D.createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
F.takeDirectory FilePath
fp
                    Just (UserID
uid, GroupID
gid) -> UserID -> GroupID -> FilePath -> IO ()
createTreeUID UserID
uid GroupID
gid forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
F.takeDirectory FilePath
fp
                let write :: Fd -> ByteString -> IO ()
write Fd
fd ByteString
bs = forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ptr, Int
len) -> do
                        ByteCount
_ <- Fd -> Ptr Word8 -> ByteCount -> IO ByteCount
fdWriteBuf Fd
fd (forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
                        forall (m :: * -> *) a. Monad m => a -> m a
return ()
                forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
                    (do
                        Fd
fd <- FilePath -> FileMode -> IO Fd
createFile FilePath
fp forall a b. (a -> b) -> a -> b
$ Entry -> FileMode
Tar.entryPermissions Entry
e
                        Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
fd FdOption
CloseOnExec Bool
True
                        case Maybe (UserID, GroupID)
muid of
                            Maybe (UserID, GroupID)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                            Just (UserID
uid, GroupID
gid) -> Fd -> UserID -> GroupID -> IO ()
setFdOwnerAndGroup Fd
fd UserID
uid GroupID
gid
                        forall (m :: * -> *) a. Monad m => a -> m a
return Fd
fd)
                    Fd -> IO ()
closeFd
                    (\Fd
fd -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Fd -> ByteString -> IO ()
write Fd
fd) (ByteString -> [ByteString]
L.toChunks ByteString
lbs))
            EntryContent
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Create a directory tree, setting the uid and gid of all newly created
-- folders.
createTreeUID :: UserID -> GroupID -> FilePath -> IO ()
createTreeUID :: UserID -> GroupID -> FilePath -> IO ()
createTreeUID UserID
uid GroupID
gid =
    FilePath -> IO ()
go
  where
    go :: FilePath -> IO ()
go FilePath
fp = do
        Bool
exists <- FilePath -> IO Bool
D.doesDirectoryExist FilePath
fp
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ do
            FilePath -> IO ()
go forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
F.takeDirectory FilePath
fp
            Bool -> FilePath -> IO ()
D.createDirectoryIfMissing Bool
False FilePath
fp
            FilePath -> UserID -> GroupID -> IO ()
setOwnerAndGroup FilePath
fp UserID
uid GroupID
gid