{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-|
Module: Model.Types.Mail
Description: Types related to Notifications
-}

module Model.Types.Mail
  ( module Model.Types.Mail
  ) where

import Import.NoModel

import qualified Data.Aeson.Types as Aeson

import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap

import Crypto.Hash (digestFromByteString, SHAKE128)
import Database.Persist.Sql (PersistFieldSql(..))

import Data.ByteArray (ByteArrayAccess)
import qualified Data.ByteArray as BA

import Web.HttpApiData (ToHttpApiData, FromHttpApiData)

import Data.ByteString.Base32

import qualified Data.CaseInsensitive as CI


-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
--
-- Could maybe be replaced with `Structure Notification` in the long term
data NotificationTrigger
  = NTSubmissionRatedGraded
  | NTSubmissionRated
  | NTSubmissionEdited
  | NTSubmissionUserCreated
  | NTSubmissionUserDeleted
  | NTSheetActive
  | NTSheetHint
  | NTSheetSolution
  | NTSheetSoonInactive
  | NTSheetInactive
  | NTCorrectionsAssigned
  | NTCorrectionsNotDistributed
  | NTUserRightsUpdate
  | NTUserAuthModeUpdate
  | NTExamRegistrationActive
  | NTExamRegistrationSoonInactive
  | NTExamDeregistrationSoonInactive
  | NTExamResult
  | NTAllocationStaffRegister
  | NTAllocationAllocation
  | NTAllocationRegister
  | NTAllocationNewCourse
  | NTAllocationOutdatedRatings
  | NTAllocationUnratedApplications
  | NTAllocationResults
  | NTExamOfficeExamResults
  | NTExamOfficeExamResultsChanged
  | NTCourseRegistered
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Universe, Finite, Hashable, NFData)

nullaryPathPiece ''NotificationTrigger $ camelToPathPiece' 1
pathPieceJSON ''NotificationTrigger
pathPieceJSONKey ''NotificationTrigger


newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
  deriving (Generic, Typeable)
  deriving newtype (Eq, Ord, Read, Show)
  deriving anyclass (NFData)

instance Default NotificationSettings where
  def = NotificationSettings $ not . flip HashSet.member defaultOff
    where
      defaultOff :: HashSet NotificationTrigger
      defaultOff = HashSet.fromList
        [ NTSheetSoonInactive
        , NTExamRegistrationSoonInactive
        , NTAllocationNewCourse
        ]

instance ToJSON NotificationSettings where
  toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF

instance FromJSON NotificationSettings where
  parseJSON = Aeson.withObject "NotificationSettings" $ \o -> do
    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool)
    return . NotificationSettings $ \n -> fromMaybe (notificationAllowed def n) $ HashMap.lookup n o'

derivePersistFieldJSON ''NotificationSettings


newtype BounceSecret = BounceSecret (Digest (SHAKE128 64))
  deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
  deriving newtype ( PersistField
                   , Hashable, NFData
                   , ByteArrayAccess
                   )

instance PersistFieldSql BounceSecret where
  sqlType _ = sqlType $ Proxy @(Digest (SHAKE128 64))

instance PathPiece BounceSecret where
  toPathPiece = CI.foldCase . encodeBase32Unpadded . BA.convert
  fromPathPiece = fmap BounceSecret . digestFromByteString <=< either (const Nothing) Just . decodeBase32Unpadded . encodeUtf8

newtype MailContent = MailContent [Alternatives]
  deriving (Eq, Show, Generic, Typeable)
  deriving newtype (ToJSON, FromJSON)
  deriving anyclass (Binary, NFData)

derivePersistFieldJSON ''MailContent

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

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

derivePersistFieldJSON ''MailHeaders
