diff --git a/package.yaml b/package.yaml index e2b9b88f3..46ec0daa1 100644 --- a/package.yaml +++ b/package.yaml @@ -50,6 +50,8 @@ dependencies: - base64-bytestring - memory - http-api-data +- zip-stream +- filepath # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/src/Handler/Zip.hs b/src/Handler/Zip.hs new file mode 100644 index 000000000..5462ac82f --- /dev/null +++ b/src/Handler/Zip.hs @@ -0,0 +1,69 @@ +{-# 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 + } diff --git a/stack.yaml b/stack.yaml index 8a276d119..0234457d9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -36,10 +36,11 @@ resolver: lts-9.3 # non-dependency (i.e. a user package), and its test suites and benchmarks # will not be run. This is useful for tweaking upstream packages. packages: -- . + - . # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) -extra-deps: [] +extra-deps: + - zip-stream-0.1.0.1 # Override default flag values for local packages and extra-deps flags: {}