{-# 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
  ) where

import Import

import qualified Data.Conduit.List as Conduit (map)

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 qualified Data.Text as Text
import qualified Data.Text.Encoding as Text

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 e) -> do
          zipEntryName' <- fmap Text.unpack . either throw return . Text.decodeUtf8' $ zipEntryName e
          contentChunks <- toConsumer accContents
          let
            fileTitle = normalise $ makeValid zipEntryName'
            fileModified = localTimeToUTC utc $ zipEntryTime e
            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 = Conduit.map 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 = Text.encodeUtf8 . Text.pack . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ fileTitle
      , zipEntryTime = utcToLocalTime utc fileModified
      }
      where
        isDir = isNothing fileContent