{-# 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(..)
  , ZipEntry(..)
  , 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)

import Data.List (dropWhileEnd)


data ZipEntry = ZipEntry
  { zipEntryName :: FilePath
  , zipEntryTime :: UTCTime
  , zipEntryContents :: Maybe Lazy.ByteString -- ^ 'Nothing' means this is a directory
  } deriving (Read, Show, Generic, Typeable, Eq, Ord)


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' <- fmap Text.unpack . either throw return . Text.decodeUtf8' $ Zip.zipEntryName e
          contentChunks <- accContents
          let
            zipEntryName = normalise $ makeValid 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
        Just (Left x)  -> []    <$ leftover (Left x)
        _ -> 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 (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ zipEntryName
      , zipEntryTime = utcToLocalTime utc zipEntryTime
      }