consumeZip

src/Handler/Zip.hs

@@ -1,6 +1,8 @@
 {-# 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(..)
@@ -11,6 +13,8 @@ module Handler.Zip
 
 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
@@ -26,17 +30,49 @@ 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 :: (ZipEntry -> YesodDB UniWorX a) -- ^ Insert entries into database
           -> Sink ByteString (YesodDB UniWorX) (Zip.ZipInfo, [a])
-consumeZip = error "consumeZip not implemented yet"
+consumeZip insertEntry = Zip.unZipStream `fuseBoth` consumeZip'
+  where
+    -- consumeZip' :: Sink (Either Zip.ZipEntry ByteString) (YesodDB UniWorX) [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 $ insertEntry 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
@@ -44,23 +80,20 @@ produceZip :: ( MonadBase b m
               , MonadThrow m
               ) => Zip.ZipInfo
               -> Conduit ZipEntry m ByteString
-produceZip info = toZipData =$= void (Zip.zipStream zipOptions)
+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 => Conduit ZipEntry m (Zip.ZipEntry, Zip.ZipData m)
+
-    toZipData = do
+    toZipData :: Monad m => ZipEntry -> (Zip.ZipEntry, Zip.ZipData m)
-      entry <- await
+    toZipData (e@ZipEntry{ zipEntryContents = Nothing })
-      case entry of
+      = ((toZipEntry True e){ Zip.zipEntrySize = Nothing }, mempty)
-        Nothing
+    toZipData (e@ZipEntry{ zipEntryContents = Just b})
-          -> return ()
+      = ((toZipEntry False e){ Zip.zipEntrySize = Just . fromIntegral $ Lazy.ByteString.length b }, Zip.ZipDataByteString b)
-        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