module Codec.Archive.Pack ( entriesToFile
, entriesToFileZip
, entriesToFile7Zip
, entriesToBS
, entriesToBSzip
, entriesToBS7zip
, packEntries
, noFail
, packToFile
, packToFileZip
, packToFile7Zip
) where
import Codec.Archive.Foreign
import Codec.Archive.Monad
import Codec.Archive.Pack.Common
import Codec.Archive.Types
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO (..))
import Data.ByteString (packCStringLen)
import qualified Data.ByteString as BS
import Data.Coerce (coerce)
import Data.Foldable (sequenceA_, traverse_)
import Data.Semigroup (Sum (..))
import Foreign.C.String
import Foreign.C.Types (CLLong (..), CLong (..))
import Foreign.Ptr (Ptr)
import System.IO.Unsafe (unsafeDupablePerformIO)
maybeDo :: Applicative f => Maybe (f ()) -> f ()
maybeDo = sequenceA_
contentAdd :: EntryContent -> Ptr Archive -> Ptr ArchiveEntry -> ArchiveM ()
contentAdd (NormalFile contents) a entry = do
liftIO $ archiveEntrySetFiletype entry (Just FtRegular)
liftIO $ archiveEntrySetSize entry (fromIntegral (BS.length contents))
handle $ archiveWriteHeader a entry
useAsCStringLenArchiveM contents $ \(buff, sz) ->
liftIO $ void $ archiveWriteData a buff (fromIntegral sz)
contentAdd Directory a entry = do
liftIO $ archiveEntrySetFiletype entry (Just FtDirectory)
handle $ archiveWriteHeader a entry
contentAdd (Symlink fp) a entry = do
liftIO $ archiveEntrySetFiletype entry (Just FtLink)
liftIO $ withCString fp $ \fpc ->
archiveEntrySetSymlink entry fpc
handle $ archiveWriteHeader a entry
contentAdd (Hardlink fp) a entry = do
liftIO $ archiveEntrySetFiletype entry Nothing
liftIO $ withCString fp $ \fpc ->
archiveEntrySetHardlink entry fpc
handle $ archiveWriteHeader a entry
withMaybeCString :: Maybe String -> (Maybe CString -> IO a) -> IO a
withMaybeCString (Just x) f = withCString x (f . Just)
withMaybeCString Nothing f = f Nothing
setOwnership :: Ownership -> Ptr ArchiveEntry -> IO ()
setOwnership (Ownership uname gname uid gid) entry =
withMaybeCString uname $ \unameC ->
withMaybeCString gname $ \gnameC ->
traverse_ maybeDo
[ archiveEntrySetUname entry <$> unameC
, archiveEntrySetGname entry <$> gnameC
, Just (archiveEntrySetUid entry (coerce uid))
, Just (archiveEntrySetGid entry (coerce gid))
]
setTime :: ModTime -> Ptr ArchiveEntry -> IO ()
setTime (time', nsec) entry = archiveEntrySetMtime entry time' nsec
packEntries :: (Foldable t) => Ptr Archive -> t Entry -> ArchiveM ()
packEntries a = traverse_ (archiveEntryAdd a)
entriesSz :: (Foldable t, Integral a) => t Entry -> a
entriesSz = getSum . foldMap (Sum . entrySz)
where entrySz e = 512 + 512 * (contentSz (content e) `div` 512 + 1)
contentSz (NormalFile str) = fromIntegral $ BS.length str
contentSz Directory = 0
contentSz (Symlink fp) = fromIntegral $ length fp
contentSz (Hardlink fp) = fromIntegral $ length fp
entriesToBS :: Foldable t => t Entry -> BS.ByteString
entriesToBS = unsafeDupablePerformIO . noFail . entriesToBSGeneral archiveWriteSetFormatPaxRestricted
{-# NOINLINE entriesToBS #-}
entriesToBS7zip :: Foldable t => t Entry -> BS.ByteString
entriesToBS7zip = unsafeDupablePerformIO . noFail . entriesToBSGeneral archiveWriteSetFormat7zip
{-# NOINLINE entriesToBS7zip #-}
entriesToBSzip :: Foldable t => t Entry -> BS.ByteString
entriesToBSzip = unsafeDupablePerformIO . noFail . entriesToBSGeneral archiveWriteSetFormatZip
{-# NOINLINE entriesToBSzip #-}
noFail :: ArchiveM a -> IO a
noFail act = do
res <- runArchiveM act
case res of
Right x -> pure x
Left _ -> error "Should not fail."
entriesToBSGeneral :: (Foldable t) => (Ptr Archive -> IO ArchiveResult) -> t Entry -> ArchiveM BS.ByteString
entriesToBSGeneral modifier hsEntries' = do
a <- liftIO archiveWriteNew
ignore $ modifier a
allocaBytesArchiveM bufSize $ \buffer -> do
(err, usedSz) <- liftIO $ archiveWriteOpenMemory a buffer bufSize
handle (pure err)
packEntries a hsEntries'
handle $ archiveWriteClose a
res <- liftIO $ curry packCStringLen buffer (fromIntegral usedSz)
ignore $ archiveFree a
pure res
where bufSize :: Integral a => a
bufSize = entriesSz hsEntries'
filePacker :: (Traversable t) => (FilePath -> t Entry -> ArchiveM ()) -> FilePath -> t FilePath -> ArchiveM ()
filePacker f tar fps = f tar =<< liftIO (traverse mkEntry fps)
packToFile :: Traversable t
=> FilePath
-> t FilePath
-> ArchiveM ()
packToFile = filePacker entriesToFile
packToFileZip :: Traversable t
=> FilePath
-> t FilePath
-> ArchiveM ()
packToFileZip = filePacker entriesToFileZip
packToFile7Zip :: Traversable t
=> FilePath
-> t FilePath
-> ArchiveM ()
packToFile7Zip = filePacker entriesToFile7Zip
entriesToFile :: Foldable t => FilePath -> t Entry -> ArchiveM ()
entriesToFile = entriesToFileGeneral archiveWriteSetFormatPaxRestricted
entriesToFileZip :: Foldable t => FilePath -> t Entry -> ArchiveM ()
entriesToFileZip = entriesToFileGeneral archiveWriteSetFormatZip
entriesToFile7Zip :: Foldable t => FilePath -> t Entry -> ArchiveM ()
entriesToFile7Zip = entriesToFileGeneral archiveWriteSetFormat7zip
entriesToFileGeneral :: Foldable t => (Ptr Archive -> IO ArchiveResult) -> FilePath -> t Entry -> ArchiveM ()
entriesToFileGeneral modifier fp hsEntries' = do
a <- liftIO archiveWriteNew
ignore $ modifier a
withCStringArchiveM fp $ \fpc ->
handle $ archiveWriteOpenFilename a fpc
packEntries a hsEntries'
ignore $ archiveFree a
withArchiveEntry :: MonadIO m => (Ptr ArchiveEntry -> m a) -> m a
withArchiveEntry fact = do
entry <- liftIO archiveEntryNew
res <- fact entry
liftIO $ archiveEntryFree entry
pure res
archiveEntryAdd :: Ptr Archive -> Entry -> ArchiveM ()
archiveEntryAdd a (Entry fp contents perms owner mtime) =
withArchiveEntry $ \entry -> do
liftIO $ withCString fp $ \fpc ->
archiveEntrySetPathname entry fpc
liftIO $ archiveEntrySetPerm entry perms
liftIO $ setOwnership owner entry
liftIO $ maybeDo (setTime <$> mtime <*> pure entry)
contentAdd contents a entry