produceZip

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.

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
+      }

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: {}