{-# 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 Text.Hamlet (ihamlet)
  
import Data.Aeson hiding (Result(..))
  

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

  _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
      Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute
      fetchExamId tid csh ssh examn
    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 <- liftHandlerT 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 liftHandlerT . wFormToAForm $ do
      isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse
      now <- liftIO getCurrentTime

      case (isRegistered, invDBExamRegistrationCourseRegister) of
        (False, False) -> permissionDeniedI MsgUnauthorizedParticipant
        (False, True ) -> do
          fieldRes <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing
          return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
        (True , _    ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) 
    invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
      whenIsJust mField $ \cpField -> do
        insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False
        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