106 lines
3.6 KiB
Haskell
106 lines
3.6 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
|
|
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns Zip.zipEntrySize in produceZip
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Zip
|
|
( Zip.ZipError(..)
|
|
, Zip.ZipInfo(..)
|
|
, produceZip
|
|
, consumeZip
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Conduit.List as Conduit (map)
|
|
|
|
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
|
|
|
|
import GHC.Generics (Generic)
|
|
import Data.Typeable (Typeable)
|
|
|
|
|
|
data ZipEntry = ZipEntry
|
|
{ zipEntryName :: FilePath
|
|
, zipEntryTime :: UTCTime
|
|
, zipEntryContents :: Maybe Lazy.ByteString -- ^ 'Nothing' means this is a directory
|
|
} deriving (Read, Show, Generic, Typeable)
|
|
|
|
|
|
instance Default Zip.ZipInfo where
|
|
def = Zip.ZipInfo
|
|
{ zipComment = mempty
|
|
}
|
|
|
|
|
|
consumeZip :: ( MonadBase b m
|
|
, PrimMonad b
|
|
, MonadThrow m
|
|
) => (ZipEntry -> m a) -- ^ Handle entries (insert into database)
|
|
-> Sink ByteString m (Zip.ZipInfo, [a])
|
|
consumeZip handleEntry = Zip.unZipStream `fuseBoth` consumeZip'
|
|
where
|
|
-- consumeZip' :: Sink (Either Zip.ZipEntry ByteString) m [a]
|
|
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' <- either throw return . Text.decodeUtf8' $ Zip.zipEntryName e
|
|
contentChunks <- accContents
|
|
let
|
|
zipEntryName = normalise . makeValid $ Text.unpack zipEntryName'
|
|
zipEntryTime = localTimeToUTC utc $ Zip.zipEntryTime e
|
|
zipEntryContents
|
|
| hasTrailingPathSeparator zipEntryName = Nothing
|
|
| otherwise = Just $ Lazy.ByteString.fromChunks contentChunks
|
|
(:) <$> (lift $ handleEntry ZipEntry{..}) <*> consumeZip'
|
|
accContents :: Monad m => Sink (Either a b) m [b]
|
|
accContents = do
|
|
input <- await
|
|
case input of
|
|
Just (Right x) -> (x :) <$> accContents
|
|
_ -> return []
|
|
|
|
|
|
produceZip :: ( MonadBase b m
|
|
, PrimMonad b
|
|
, MonadThrow m
|
|
) => Zip.ZipInfo
|
|
-> Conduit ZipEntry m ByteString
|
|
produceZip info = Conduit.map 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 => ZipEntry -> (Zip.ZipEntry, Zip.ZipData m)
|
|
toZipData (e@ZipEntry{ zipEntryContents = Nothing })
|
|
= ((toZipEntry True e){ Zip.zipEntrySize = Nothing }, mempty)
|
|
toZipData (e@ZipEntry{ zipEntryContents = Just b})
|
|
= ((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
|
|
}
|