{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns zipEntrySize in produceZip
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.Utils.Zip
  ( ZipError(..)
  , ZipInfo(..)
  , produceZip
  , consumeZip
  , modifyFileTitle
  ) 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

import Data.List (dropWhileEnd)


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