125 lines
6.3 KiB
Haskell
125 lines
6.3 KiB
Haskell
{-# 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(..))
|
|
|
|
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, 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
|
|
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 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
|
|
void $ upsert
|
|
(CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing CourseParticipantActive)
|
|
[ CourseParticipantRegistration =. examRegistrationTime
|
|
, CourseParticipantField =. cpField
|
|
, CourseParticipantAllocated =. Nothing
|
|
, 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
|