124 lines
4.2 KiB
Haskell
124 lines
4.2 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns zipEntrySize in produceZip
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Utils.Zip
|
|
( typeZip, extensionZip
|
|
, ZipError(..)
|
|
, ZipInfo(..)
|
|
, produceZip
|
|
, consumeZip
|
|
, modifyFileTitle
|
|
, sourceFiles, acceptFile
|
|
) where
|
|
|
|
import Import
|
|
|
|
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 System.FilePath
|
|
import Data.Time.LocalTime (localTimeToUTC, utcToLocalTime)
|
|
|
|
import Data.List (dropWhileEnd)
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
typeZip :: ContentType
|
|
typeZip = "application/zip"
|
|
|
|
extensionZip :: Extension
|
|
extensionZip = fromMaybe "zip" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeZip ]
|
|
|
|
|
|
|
|
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 ZipEntry{..}) -> do
|
|
contentChunks <- toConsumer accContents
|
|
let
|
|
fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise $ makeValid zipEntryName
|
|
fileModified = localTimeToUTC utc zipEntryTime
|
|
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 = mapC 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 = bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ fileTitle
|
|
, zipEntryTime = utcToLocalTime utc fileModified
|
|
}
|
|
where
|
|
isDir = isNothing fileContent
|
|
|
|
modifyFileTitle :: Monad m => (FilePath -> FilePath) -> Conduit File m File
|
|
modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle }
|
|
|
|
-- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo
|
|
sourceFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File
|
|
sourceFiles fInfo
|
|
| ((==) `on` simpleContentType) mimeType typeZip = do
|
|
$logInfoS "sourceFiles" "Unpacking ZIP"
|
|
fileSource fInfo =$= void consumeZip
|
|
| otherwise = do
|
|
$logDebugS "sourceFiles" [st|Not unpacking file of type #{decodeUtf8 mimeType}|]
|
|
yieldM $ acceptFile fInfo
|
|
where
|
|
mimeType = mimeLookup $ fileName fInfo
|
|
|
|
acceptFile :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> m File
|
|
acceptFile fInfo = do
|
|
let fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise . unpack $ fileName fInfo
|
|
fileModified <- liftIO getCurrentTime
|
|
fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
|
|
return File{..}
|