98 lines
3.2 KiB
Haskell
98 lines
3.2 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
|
|
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns zipEntrySize in produceZip
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Utils.Zip
|
|
( ZipError(..)
|
|
, ZipInfo(..)
|
|
, produceZip
|
|
, consumeZip
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Conduit.List as Conduit (map)
|
|
|
|
import Codec.Archive.Zip.Conduit.Types
|
|
import Codec.Archive.Zip.Conduit.UnZip
|
|
import Codec.Archive.Zip.Conduit.Zip
|
|
|
|
-- import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
|
import qualified Data.ByteString.Lazy as Lazy.ByteString
|
|
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString as ByteString
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
|
|
import System.FilePath
|
|
import Data.Time
|
|
|
|
import Data.List (dropWhileEnd)
|
|
|
|
|
|
instance Default ZipInfo where
|
|
def = ZipInfo
|
|
{ zipComment = mempty
|
|
}
|
|
|
|
|
|
consumeZip :: ( MonadBase b m
|
|
, PrimMonad b
|
|
, MonadThrow m
|
|
) => ConduitM ByteString File m ZipInfo
|
|
consumeZip = unZipStream `fuseUpstream` consumeZip'
|
|
where
|
|
consumeZip' :: ( MonadThrow m
|
|
) => Conduit (Either ZipEntry ByteString) m File
|
|
consumeZip' = do
|
|
input <- await
|
|
case input of
|
|
Nothing -> return ()
|
|
Just (Right _) -> throw $ userError "Data chunk in unexpected place when parsing ZIP"
|
|
Just (Left e) -> do
|
|
zipEntryName' <- fmap Text.unpack . either throw return . Text.decodeUtf8' $ zipEntryName e
|
|
contentChunks <- toConsumer accContents
|
|
let
|
|
fileTitle = normalise $ makeValid zipEntryName'
|
|
fileModified = localTimeToUTC utc $ zipEntryTime e
|
|
fileContent
|
|
| hasTrailingPathSeparator zipEntryName' = Nothing
|
|
| otherwise = Just $ mconcat contentChunks
|
|
yield $ File{..}
|
|
consumeZip'
|
|
accContents :: Monad m => Sink (Either a b) m [b]
|
|
accContents = do
|
|
input <- await
|
|
case input of
|
|
Just (Right x) -> (x :) <$> accContents
|
|
Just (Left x) -> [] <$ leftover (Left x)
|
|
_ -> return []
|
|
|
|
produceZip :: ( MonadBase b m
|
|
, PrimMonad b
|
|
, MonadThrow m
|
|
) => ZipInfo
|
|
-> Conduit File m ByteString
|
|
produceZip info = Conduit.map toZipData =$= void (zipStream zipOptions)
|
|
where
|
|
zipOptions = ZipOptions
|
|
{ zipOpt64 = True
|
|
, zipOptCompressLevel = -1 -- This is passed through all the way to the C zlib, where it means "default level"
|
|
, zipOptInfo = info
|
|
}
|
|
|
|
toZipData :: Monad m => File -> (ZipEntry, ZipData m)
|
|
toZipData f@(File{..}) = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent)
|
|
|
|
toZipEntry :: File -> ZipEntry
|
|
toZipEntry File{..} = ZipEntry
|
|
{ zipEntryName = Text.encodeUtf8 . Text.pack . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ fileTitle
|
|
, zipEntryTime = utcToLocalTime utc fileModified
|
|
}
|
|
where
|
|
isDir = isNothing fileContent
|