70 lines
2.3 KiB
Haskell
70 lines
2.3 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns Zip.zipEntrySize in produceZip
|
|
|
|
module Handler.Zip
|
|
( Zip.ZipError(..)
|
|
, Zip.ZipInfo(..)
|
|
, produceZip
|
|
, consumeZip
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Codec.Archive.Zip.Conduit.Types as Zip
|
|
import qualified Codec.Archive.Zip.Conduit.UnZip as Zip
|
|
import qualified Codec.Archive.Zip.Conduit.Zip as Zip
|
|
|
|
import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
|
import qualified Data.ByteString.Lazy as Lazy.ByteString
|
|
|
|
import Data.ByteString (ByteString)
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
|
|
import System.FilePath
|
|
import Data.Time
|
|
|
|
|
|
data ZipEntry = ZipEntry
|
|
{ zipEntryName :: FilePath
|
|
, zipEntryTime :: UTCTime
|
|
, zipEntryContents :: Maybe Lazy.ByteString -- ^ 'Nothing' means this is a directory
|
|
}
|
|
|
|
|
|
consumeZip :: (ZipEntry -> YesodDB UniWorX a) -- ^ Insert entries into database
|
|
-> Sink ByteString (YesodDB UniWorX) (Zip.ZipInfo, [a])
|
|
consumeZip = error "consumeZip not implemented yet"
|
|
|
|
|
|
produceZip :: ( MonadBase b m
|
|
, PrimMonad b
|
|
, MonadThrow m
|
|
) => Zip.ZipInfo
|
|
-> Conduit ZipEntry m ByteString
|
|
produceZip info = toZipData =$= void (Zip.zipStream zipOptions)
|
|
where
|
|
zipOptions = Zip.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 => Conduit ZipEntry m (Zip.ZipEntry, Zip.ZipData m)
|
|
toZipData = do
|
|
entry <- await
|
|
case entry of
|
|
Nothing
|
|
-> return ()
|
|
Just (e@ZipEntry{ zipEntryContents = Nothing })
|
|
-> yield ((toZipEntry True e){ Zip.zipEntrySize = Nothing }, mempty)
|
|
Just (e@ZipEntry{ zipEntryContents = Just b})
|
|
-> yield ((toZipEntry False e){ Zip.zipEntrySize = Just . fromIntegral $ Lazy.ByteString.length b }, Zip.ZipDataByteString b)
|
|
toZipEntry :: Bool -- ^ Is directory?
|
|
-> ZipEntry -> Zip.ZipEntry
|
|
toZipEntry isDir ZipEntry{..} = Zip.ZipEntry
|
|
{ zipEntryName = Text.encodeUtf8 . Text.pack . bool dropTrailingPathSeparator addTrailingPathSeparator isDir . normalise $ makeValid zipEntryName
|
|
, zipEntryTime = utcToLocalTime utc zipEntryTime
|
|
}
|