-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.Exam.RegistrationInvite
  ( InvitableJunction(..)
  , InvitationDBData(..)
  , InvitationTokenData(..)
  , examRegistrationInvitationConfig
  , getEInviteR, postEInviteR
  ) where

import Import
import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Invitations

import qualified Data.Set as Set

import Data.Aeson hiding (Result(..))

import Jobs.Queue

import qualified Data.HashSet as HashSet


instance IsInvitableJunction ExamRegistration where
  type InvitationFor ExamRegistration = Exam
  data InvitableJunction ExamRegistration = JunctionExamRegistration
    { jExamRegistrationOccurrence :: Maybe ExamOccurrenceId
    , jExamRegistrationTime :: UTCTime
    } deriving (Eq, Ord, Read, Show, Generic)
  data InvitationDBData ExamRegistration = InvDBDataExamRegistration
    { invDBExamRegistrationOccurrence :: Maybe ExamOccurrenceId
    , invDBExamRegistrationDeadline :: UTCTime
    , invDBExamRegistrationCourseRegister :: Bool
    } deriving (Eq, Ord, Read, Show, Generic)
  data InvitationTokenData ExamRegistration = InvTokenDataExamRegistration
    deriving (Eq, Ord, Read, Show, Generic)

  _InvitableJunction = iso
    (\ExamRegistration{..} -> (examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime))
    (\(examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime) -> ExamRegistration{..})

instance ToJSON (InvitableJunction ExamRegistration) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction ExamRegistration) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }

instance ToJSON (InvitationDBData ExamRegistration) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationDBData ExamRegistration) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }

instance ToJSON (InvitationTokenData ExamRegistration) where
  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationTokenData ExamRegistration) where
  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }

examRegistrationInvitationConfig :: InvitationConfig ExamRegistration
examRegistrationInvitationConfig = InvitationConfig{..}
  where
    invitationRoute (Entity _ Exam{..}) _ = do
      Course{..} <- get404 examCourse
      return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR
    invitationResolveFor _ = do
      cRoute <- getCurrentRoute
      case cRoute of
        Just (CExamR tid csh ssh examn EInviteR) ->
          fetchExamId tid csh ssh examn
        _other ->
          error "examRegistrationInvitationConfig called from unsupported route"
    invitationSubject (Entity _ Exam{..}) _ = do
      Course{..} <- get404 examCourse
      return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName
    invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
    invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
      let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
          itAddAuth
            | not invDBExamRegistrationCourseRegister
            = Just . PredDNF . Set.singleton . impureNonNull . Set.singleton $ PLVariable AuthCourseRegistered
            | otherwise
            = Nothing
          itStartsAt = Nothing
      return InvitationTokenConfig{..}
    invitationRestriction _ _ = return Authorized
    invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandler . wFormToAForm $ do
      isRegistered <- fmap (is _Just) . liftHandler . runDB . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive). getBy $ UniqueParticipant uid examCourse
      now <- liftIO getCurrentTime

      case (isRegistered, invDBExamRegistrationCourseRegister) of
        (False, False) -> permissionDeniedI MsgExamUnauthorizedParticipant
        (False, True ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, True)
        (True , _    ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, False)
    invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} doReg act = do
      when doReg $ do
        void $ upsert
          (CourseParticipant examCourse examRegistrationUser examRegistrationTime CourseParticipantActive)
          [ CourseParticipantRegistration =. examRegistrationTime
          , CourseParticipantState =. CourseParticipantActive
          ]
        queueDBJob . JobQueueNotification $ NotificationCourseRegistered examRegistrationUser examCourse
        audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser

      let doAudit = audit $ TransactionExamRegister eid examRegistrationUser
      act <* doAudit
    invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName
    invitationUltDest (Entity _ Exam{..}) _ = do
      Course{..} <- get404 examCourse
      return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR


getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEInviteR = postEInviteR
postEInviteR _ _ _ _ = invitationR' examRegistrationInvitationConfig