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


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 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
              , 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 dropTrailingPathSeparator addTrailingPathSeparator isDir . normalise $ makeValid zipEntryName
      , zipEntryTime = utcToLocalTime utc zipEntryTime
      }