123 lines
6.1 KiB
Haskell
123 lines
6.1 KiB
Haskell
-- 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
|