{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE EmptyCase #-}

module Model.Types.File
  ( FileContentChunkReference(..), FileContentReference(..)
  , File(..), _fileTitle, _fileContent, _fileModified
  , PureFile, toPureFile, fromPureFile, pureFileToFileReference, _pureFileContent
  , transFile
  , minioFileChunkReference, minioFileReference, etagFileReference
  , FileReference(..), _fileReferenceTitle, _fileReferenceContent, _fileReferenceModified
  , HasFileReference(..), IsFileReference(..), FileReferenceResidual(FileReferenceResidual, FileReferenceResidualEither, unFileReferenceResidualEither, FileReferenceResidualEntity, fileReferenceResidualEntityKey, fileReferenceResidualEntityResidual, unPureFileResidual)
  , FileReferenceTitleMap(..)
  , FileReferenceFileReferenceTitleMapElem(..), _fRefTitleMapContent, _fRefTitleMapModified, _fRefTitleMapAdditional
  , _FileReferenceFileReferenceTitleMap 
  , FileReferenceTitleMapConvertible(..)
  , FileFieldUserOption(..), FileField(..)
  , _fieldOptionForce, _fieldOptionDefault
  , _fieldIdent, _fieldUnpackZips, _fieldMultiple, _fieldRestrictExtensions, _fieldAdditionalFiles, _fieldMaxFileSize
  ) where

import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON, Proxy(..))
import Crypto.Hash (Digest, SHA3_512)
import Language.Haskell.TH.Syntax (Lift)
import Data.Binary (Binary)
import Crypto.Hash.Instances ()
import Data.Proxy (Proxy(..))
import Control.Lens
import Utils.HttpConditional
import Data.Binary.Instances.Time ()
import Data.Time.Clock.Instances ()
import Data.Aeson.TH
import Utils
import Data.Kind (Type)
import Data.Universe
import Numeric.Natural
import Network.Mime
import Control.Monad.Morph
import Data.NonNull.Instances ()
   
import Database.Persist.Sql (PersistFieldSql(..))
import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
import Data.ByteArray (ByteArrayAccess)

import qualified Data.ByteString.Base64.URL as Base64
import qualified Data.ByteArray as ByteArray
import qualified Network.Minio as Minio (Object)
import qualified Crypto.Hash as Crypto (digestFromByteString)
import qualified Crypto.Hash.Conduit as Crypto (sinkHash)

import Utils.Lens.TH

import qualified Data.Conduit.Combinators as C

import Text.Show

import qualified Data.Aeson as JSON
import qualified Data.Map as Map

import qualified Data.Text as Text



newtype FileContentChunkReference = FileContentChunkReference (Digest SHA3_512)
  deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
  deriving newtype ( PersistField
                   , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
                   , Hashable, NFData
                   , ByteArrayAccess
                   , Binary
                   )

instance PersistFieldSql FileContentChunkReference where
  sqlType _ = sqlType $ Proxy @(Digest SHA3_512)

makeWrapped ''FileContentChunkReference

minioFileChunkReference :: Prism' Minio.Object FileContentChunkReference
minioFileChunkReference = prism' toObjectName fromObjectName
  where toObjectName = (chunkPrefix <>) . decodeUtf8 . Base64.encodeUnpadded . ByteArray.convert
        fromObjectName = fmap (review _Wrapped) . Crypto.digestFromByteString <=< preview _Right . Base64.decodeUnpadded . encodeUtf8 <=< Text.stripPrefix chunkPrefix

        chunkPrefix = "chunk."

newtype FileContentReference = FileContentReference (Digest SHA3_512)
  deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
  deriving newtype ( PersistField
                   , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
                   , Hashable, NFData
                   , ByteArrayAccess
                   , Binary
                   )

instance PersistFieldSql FileContentReference where
  sqlType _ = sqlType $ Proxy @(Digest SHA3_512)

makeWrapped ''FileContentReference


minioFileReference :: Prism' Minio.Object FileContentReference
minioFileReference = prism' toObjectName fromObjectName
  where toObjectName = decodeUtf8 . Base64.encodeUnpadded . ByteArray.convert
        fromObjectName = fmap (review _Wrapped) . Crypto.digestFromByteString <=< preview _Right . Base64.decodeUnpadded . encodeUtf8

etagFileReference :: Prism' ETag FileContentReference
etagFileReference = prism' toETag fromETag
  where toETag = StrongETag . decodeUtf8 . Base64.encodeUnpadded . ByteArray.convert
        fromETag = \case
          StrongETag t -> fmap (review _Wrapped) . Crypto.digestFromByteString <=< preview _Right . Base64.decodeUnpadded $ encodeUtf8 t
          _other -> Nothing
  

data File m = File
  { fileTitle    :: FilePath
  , fileContent  :: Maybe (ConduitT () ByteString m ())
  , fileModified :: UTCTime
  } deriving (Generic, Typeable)

makeLenses_ ''File

type PureFile = File Identity

_pureFileContent :: forall bs.
                    ( IsSequence bs
                    , Element bs ~ Word8
                    )
                 => Lens' PureFile (Maybe bs)
_pureFileContent = lens getPureFileContent setPureFileContent
  where
    getPureFileContent = fmap (repack . runIdentity . runConduit . (.| C.fold)) . fileContent
    setPureFileContent f bs = f { fileContent = yield . repack <$> bs }

toPureFile :: Monad m => File m -> m PureFile
toPureFile File{..} = do
  c <- for fileContent $ runConduit . (.| C.fold)
  return File
    { fileContent = fmap yield c
    , ..
    }

fromPureFile :: Monad m => PureFile -> File m
fromPureFile = transFile generalize

pureFileToFileReference :: PureFile -> FileReference
pureFileToFileReference File{..} = FileReference
  { fileReferenceTitle    = fileTitle
  , fileReferenceContent  = review _Wrapped . runIdentity . runConduit . (.| Crypto.sinkHash) <$> fileContent
  , fileReferenceModified = fileModified
  }

instance Eq PureFile where
  a == b = all (\f -> f a b)
    [ (==) `on` fileTitle
    , (==) `on` fileModified
    , (==) `on` (view _pureFileContent :: PureFile -> Maybe ByteString)
    ]
instance Ord PureFile where
  compare = mconcat
    [ comparing fileTitle
    , comparing (view _pureFileContent :: PureFile -> Maybe ByteString)
    , comparing fileModified
    ]
instance Show PureFile where
  showsPrec _ f@File{..}
    = showString "File{"
    . showString "fileTitle = "
    . shows fileTitle
    . showString ", "
    . showString "fileContent = "
    . (case f ^. _pureFileContent of
          Nothing -> showString "Nothing"
          Just c  -> showString "Just $ yield " . showsPrec 11 (c :: ByteString)
      )
    . showString ", "
    . showString "fileModified = "
    . shows fileModified
    . showString "}"

transFile :: Monad m => (forall a. m a -> n a) -> (File m -> File n)
transFile l File{..} = File{ fileContent = transPipe l <$> fileContent, .. }

data FileReference = FileReference
  { fileReferenceTitle    :: FilePath
  , fileReferenceContent  :: Maybe FileContentReference
  , fileReferenceModified :: UTCTime
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
    deriving anyclass (Hashable, Binary, NFData)

makeLenses_ ''FileReference
deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 2
  } ''FileReference


class HasFileReference record where
  data FileReferenceResidual record :: Type

  _FileReference :: Iso' record (FileReference, FileReferenceResidual record)

instance HasFileReference Void where
  data FileReferenceResidual Void

  _FileReference = iso (\case {}) $ views _2 (\case {})


instance HasFileReference FileReference where
  data FileReferenceResidual FileReference = FileReferenceResidual
    deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
    deriving anyclass (Universe, Finite, NFData)
  -- newtype FileReferenceTitleMap FileReference add = FileReferenceFileReferenceTitleMap { unFileReferenceFileReferenceTitleMap :: Map FilePath (FileReferenceTitleMapElem FileReference add) }
  --   deriving (Eq, Ord, Read, Show, Generic, Typeable)
  --   deriving newtype (Semigroup, Monoid)
  -- data FileReferenceTitleMapElem FileReference add = FileReferenceFileReferenceTitleMapElem
  --   { fRefTitleMapContent    :: FileContentReference
  --   , fRefTitleMapModified   :: UTCTime
  --   , fRefTitleMapAdditional :: add
  --   } deriving (Eq, Ord, Read, Show, Generic, Typeable)

  _FileReference = iso (, FileReferenceResidual) $ view _1
  -- _FileReferenceTitleMapElem = iso (\FileReferenceFileReferenceTitleMapElem{..} -> (fRefTitleMapContent, fRefTitleMapModified, FileReferenceResidual, fRefTitleMapAdditional)) (\(fRefTitleMapContent, fRefTitleMapModified, FileReferenceResidual, fRefTitleMapAdditional) -> FileReferenceFileReferenceTitleMapElem{..})

instance HasFileReference PureFile where
  newtype FileReferenceResidual PureFile = PureFileResidual { unPureFileResidual :: Maybe ByteString }
    deriving (Eq, Ord, Read, Show, Generic, Typeable)
    deriving anyclass (NFData)

  _FileReference = iso toFileReference fromFileReference
    where
      toFileReference File{..} = (FileReference{..}, PureFileResidual{..})
        where
          fileReferenceTitle = fileTitle
          (fileReferenceContent, unPureFileResidual) = ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) $
            over _1 (review _Wrapped) . runIdentity . runConduit . (.| getZipConduit ((,) <$> ZipConduit Crypto.sinkHash <*> ZipConduit C.fold)) <$> fileContent
          fileReferenceModified = fileModified
      fromFileReference (FileReference{..}, PureFileResidual{..}) = File
        { fileTitle = fileReferenceTitle
        , fileContent = yield <$> unPureFileResidual
        , fileModified = fileReferenceModified
        }

instance (HasFileReference a, HasFileReference b) => HasFileReference (Either a b) where
  newtype FileReferenceResidual (Either a b) = FileReferenceResidualEither { unFileReferenceResidualEither :: Either (FileReferenceResidual a) (FileReferenceResidual b) }
    deriving (Generic, Typeable)

  _FileReference = iso doSplit doJoin
    where doSplit (Right r) = over _2 (FileReferenceResidualEither . Right) $ r ^. _FileReference
          doSplit (Left  r) = over _2 (FileReferenceResidualEither . Left ) $ r ^. _FileReference
          doJoin (fRef, FileReferenceResidualEither (Right res)) = Right $ _FileReference # (fRef, res)
          doJoin (fRef, FileReferenceResidualEither (Left  res)) = Left  $ _FileReference # (fRef, res)

instance HasFileReference record => HasFileReference (Entity record) where
  data FileReferenceResidual (Entity record) = FileReferenceResidualEntity
    { fileReferenceResidualEntityKey :: Key record
    , fileReferenceResidualEntityResidual :: FileReferenceResidual record
    }
    deriving (Generic, Typeable)

  _FileReference = iso doSplit doJoin
    where doSplit Entity{..} = (fRef, FileReferenceResidualEntity entityKey res)
            where (fRef, res) = entityVal ^. _FileReference
          doJoin (fRef, FileReferenceResidualEntity entityKey res) = Entity{ entityVal = _FileReference # (fRef, res), .. }

class (PersistEntity record, HasFileReference record) => IsFileReference record where
  fileReferenceTitleField    :: EntityField record FilePath
  fileReferenceContentField  :: EntityField record (Maybe FileContentReference)
  fileReferenceModifiedField :: EntityField record UTCTime

 
data family FileReferenceTitleMap :: Type -> Type -> Type
newtype instance FileReferenceTitleMap FileReference add = FileReferenceFileReferenceTitleMap
    { unFileReferenceFileReferenceTitleMap :: Map FilePath (FileReferenceFileReferenceTitleMapElem add)
    }
    deriving (Eq, Ord, Read, Show, Generic, Typeable)
    deriving newtype (Semigroup, Monoid)
    deriving anyclass (NFData)
data FileReferenceFileReferenceTitleMapElem add = FileReferenceFileReferenceTitleMapElem
  { fRefTitleMapContent    :: Maybe FileContentReference
  , fRefTitleMapModified   :: UTCTime
  , fRefTitleMapAdditional :: add
  }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving anyclass (NFData)

makePrisms ''FileReferenceFileReferenceTitleMapElem

_FileReferenceFileReferenceTitleMap :: forall add.
                                       Iso' (FileReferenceTitleMap FileReference add) (Map FilePath (Maybe FileContentReference, UTCTime, add))
_FileReferenceFileReferenceTitleMap = coerced . iso (fmap $ view _FileReferenceFileReferenceTitleMapElem) (fmap $ review _FileReferenceFileReferenceTitleMapElem)

class FileReferenceTitleMapConvertible add f1 f2 where
  _FileReferenceTitleMap :: Traversal (FileReferenceTitleMap f1 add) (FileReferenceTitleMap f2 add) (f1, add) (f2, add)

instance FileReferenceTitleMapConvertible add FileReference FileReference where
  _FileReferenceTitleMap = iso unFileReferenceFileReferenceTitleMap FileReferenceFileReferenceTitleMap . iso (map (\(fileReferenceTitle, FileReferenceFileReferenceTitleMapElem fileReferenceContent fileReferenceModified additional) -> (FileReference{..}, additional)) . Map.toList) (Map.fromList . map (\(FileReference{..}, additional) -> (fileReferenceTitle, FileReferenceFileReferenceTitleMapElem fileReferenceContent fileReferenceModified additional))) . traverse

  
data FileFieldUserOption a = FileFieldUserOption
  { fieldOptionForce :: Bool
  , fieldOptionDefault :: a
  }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving anyclass (NFData)

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 2
  } ''FileFieldUserOption

data FileField fileid = FileField
  { fieldIdent :: Maybe Text
  , fieldUnpackZips :: FileFieldUserOption Bool
  , fieldMultiple :: Bool
  , fieldRestrictExtensions :: Maybe (NonNull (Set Extension))
  , fieldMaxFileSize, fieldMaxCumulativeSize :: Maybe Natural
  , fieldAdditionalFiles :: FileReferenceTitleMap fileid (FileFieldUserOption Bool)
  , fieldAllEmptyOk :: Bool
  }
  deriving (Generic, Typeable)
deriving instance Eq (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Eq (FileField fileid)
deriving instance Ord (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Ord (FileField fileid)
deriving instance Read (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Read (FileField fileid)
deriving instance Show (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Show (FileField fileid)
deriving anyclass instance NFData (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => NFData (FileField fileid)

instance ToJSON (FileField FileReference) where
  toJSON FileField{..} = JSON.object $ catMaybes 
    [ ("ident" JSON..=) <$> fieldIdent
    , pure $ "unpack-zips" JSON..= fieldUnpackZips
    , pure $ "multiple" JSON..= fieldMultiple
    , pure $ "restrict-extensions" JSON..= fieldRestrictExtensions
    , pure $ "max-file-size" JSON..= fieldMaxFileSize
    , pure $ "max-cumulative-size" JSON..= fieldMaxCumulativeSize
    , pure $ "additional-files" JSON..= addFiles'
    , pure $ "all-empty-ok" JSON..= fieldAllEmptyOk
    ]
    where addFiles' = unFileReferenceFileReferenceTitleMap fieldAdditionalFiles <&> \FileReferenceFileReferenceTitleMapElem{..} -> JSON.object
            [ "content" JSON..= fRefTitleMapContent
            , "modified" JSON..= fRefTitleMapModified
            , "include" JSON..= fRefTitleMapAdditional
            ]
instance FromJSON (FileField FileReference) where
  parseJSON = JSON.withObject "FileField" $ \o -> do
    fieldIdent <- o JSON..:? "ident"
    fieldUnpackZips <- o JSON..: "unpack-zips"
    fieldMultiple <- o JSON..: "multiple"
    fieldRestrictExtensions <- o JSON..:? "restrict-extensions"
    fieldMaxFileSize <- o JSON..:? "max-file-size"
    fieldMaxCumulativeSize <- o JSON..:? "max-cumulative-size"
    fieldAllEmptyOk <- o JSON..:? "all-empty-ok" JSON..!= True
    addFiles' <- o JSON..:? "additional-files" JSON..!= mempty
    fieldAdditionalFiles <- fmap FileReferenceFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileReferenceFileReferenceTitleMapElem" $ \o' -> do
      fRefTitleMapContent <- o' JSON..: "content"
      fRefTitleMapModified <- o' JSON..: "modified"
      fRefTitleMapAdditional <- o' JSON..: "include"
      return FileReferenceFileReferenceTitleMapElem{..} 
    return FileField{..}

makeLenses_ ''FileFieldUserOption
makeLenses_ ''FileField
makeLenses_ ''FileReferenceFileReferenceTitleMapElem
