feat(exams): implement exam registration invitations
This commit is contained in:
Gregor Kleen
parent
a278cc5048
commit
dd90fd04a3
@ -668,6 +668,8 @@ MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@Tuto
|
||||
|
||||
MailSubjectExamCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: [#{tid}-#{ssh}-#{csh}] Einladung zum Korrektor für #{examn}
|
||||
|
||||
MailSubjectExamRegistrationInvitation tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: [#{tid}-#{ssh}-#{csh}] Einladung zum Teilnehmer für #{examn}
|
||||
|
||||
MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zu einer Abgabe für #{shn}
|
||||
|
||||
SheetGrading: Bewertung
|
||||
@ -879,6 +881,7 @@ MenuExamList: Klausuren
|
||||
MenuExamNew: Neue Klausur anlegen
|
||||
MenuExamEdit: Bearbeiten
|
||||
MenuExamUsers: Teilnehmer
|
||||
MenuExamAddMembers: Klausurteilnehmer hinzufügen
|
||||
|
||||
AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
|
||||
AuthPredsActive: Aktive Authorisierungsprädikate
|
||||
@ -953,7 +956,7 @@ CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu
|
||||
|
||||
CourseParticipantInviteHeading courseName@Text: Einladung zum Kursteilnahmer für #{courseName}
|
||||
CourseParticipantInviteExplanation: Sie wurden eingeladen, an einem Kurs teilzunehmen.
|
||||
CourseParticipantEnlistDirectly: Bekannte Teilnehmer sofort als Teilnehmer eintragen
|
||||
CourseParticipantEnlistDirectly: Bekannte Nutzer sofort als Teilnehmer eintragen
|
||||
CourseParticipantInviteField: Einzuladende EMail Adressen
|
||||
|
||||
CourseParticipantInvitationAccepted courseName@Text: Sie wurden als Teilnehmer für #{courseName} eingetragen
|
||||
@ -970,10 +973,15 @@ TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn}
|
||||
TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein.
|
||||
|
||||
ExamCorrectorInvitationAccepted examn@ExamName: Sie wurden als Korrektor für #{examn} eingetragen
|
||||
ExamCorrectorInvitationDeclined examn@ExamName: Sie haben die Einladung, Korrektor für #{examn} zu werden, abgelehnt
|
||||
ExamCorrectorInvitationDeclined examn@ExamName: Sie haben die Einladung, Korrektor für #{examn} zu werden, abgelehnt
|
||||
ExamCorrectorInviteHeading examn@ExamName: Einladung zum Korrektor für #{examn}
|
||||
ExamCorrectorInviteExplanation: Sie wurden eingeladen, Klausur-Korrektor zu sein.
|
||||
|
||||
ExamRegistrationInvitationAccepted examn@ExamName: Sie wurden als Teilnehmer für #{examn} eingetragen
|
||||
ExamRegistrationInvitationDeclined examn@ExamName: Sie haben die Einladung, Teilnehmer für #{examn} zu werden, abgelehnt
|
||||
ExamRegistrationInviteHeading examn@ExamName: Einladung zum Teilnehmer für #{examn}
|
||||
ExamRegistrationInviteExplanation: Sie wurden eingeladen, Klausurteilnehmer zu sein.
|
||||
|
||||
SubmissionUserInvitationAccepted shn@SheetName: Sie wurden als Mitabgebende(r) für eine Abgabe zu #{shn} eingetragen
|
||||
SubmissionUserInvitationDeclined shn@SheetName: Sie haben die Einladung, Mitabgebende(r) für #{shn} zu werden, abgelehnt
|
||||
SubmissionUserInviteHeading shn@SheetName: Einladung zu einer Abgabe für #{shn}
|
||||
@ -1070,6 +1078,18 @@ CourseParticipantsRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wu
|
||||
CourseParticipantsRegistered n@Int: #{n} Teilnehmer erfolgreich angemeldet
|
||||
CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen
|
||||
|
||||
ExamRegistrationAndCourseParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zum Kurs, als auch zur Klausur angemeldet
|
||||
ExamRegistrationNotRegisteredWithoutCourse n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} nicht zur Klausur angemeldet, da #{pluralDE n "er" "sie"} nicht zum Kurs angemeldet #{pluralDE n "ist" "sind"}
|
||||
ExamRegistrationRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zur Klausur, als auch #{pluralDE n "ohne assoziiertes Hauptfach" "ohne assoziierte Hauptfächer"} zum Kurs angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}
|
||||
ExamRegistrationParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} zur Klausur angemeldet
|
||||
ExamRegistrationInviteDeadline: Einladung nur gültig bis
|
||||
ExamRegistrationEnlistDirectly: Bekannte Nutzer sofort als Teilnehmer eintragen
|
||||
ExamRegistrationRegisterCourse: Nutzer auch zum Kurs anmelden
|
||||
ExamRegistrationRegisterCourseTip: Nutzer, die keine Kursteilnehmer sind, werden sonst nicht zur Klausur angemeldet.
|
||||
ExamRegistrationInviteField: Einzuladende EMail Addressen
|
||||
ExamParticipantsRegisterHeading: Klausurteilnehmer hinzufügen
|
||||
ExamParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
|
||||
|
||||
ExamName: Name
|
||||
ExamTime: Termin
|
||||
ExamsHeading: Klausuren
|
||||
|
||||
32
src/Audit.hs
32
src/Audit.hs
@ -43,16 +43,18 @@ data AuditException
|
||||
instance Exception AuditException
|
||||
|
||||
|
||||
audit :: ( AuthId site ~ Key User
|
||||
, AuthEntity site ~ User
|
||||
, IsSqlBackend (YesodPersistBackend site)
|
||||
, SqlBackendCanWrite (YesodPersistBackend site)
|
||||
, HasInstanceID site InstanceId
|
||||
, YesodAuthPersist site
|
||||
audit :: ( AuthId (HandlerSite m) ~ Key User
|
||||
, AuthEntity (HandlerSite m) ~ User
|
||||
, IsSqlBackend (YesodPersistBackend (HandlerSite m))
|
||||
, SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
|
||||
, HasInstanceID (HandlerSite m) InstanceId
|
||||
, YesodAuthPersist (HandlerSite m)
|
||||
, MonadHandler m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Transaction -- ^ Transaction to record
|
||||
-> [UserId] -- ^ Affected users
|
||||
-> YesodDB site ()
|
||||
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
||||
-- ^ Log a transaction using information available from `HandlerT`:
|
||||
--
|
||||
-- - `transactionLogTime` is now
|
||||
@ -71,14 +73,16 @@ audit (toJSON -> transactionLogInfo) affected = do
|
||||
affectedUsers <- forM affected $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid'
|
||||
insertMany_ $ map (TransactionLogAffected tlId) affectedUsers
|
||||
|
||||
audit' :: ( AuthId site ~ Key User
|
||||
, AuthEntity site ~ User
|
||||
, IsSqlBackend (YesodPersistBackend site)
|
||||
, SqlBackendCanWrite (YesodPersistBackend site)
|
||||
, HasInstanceID site InstanceId
|
||||
, YesodAuthPersist site
|
||||
audit' :: ( AuthId (HandlerSite m) ~ Key User
|
||||
, AuthEntity (HandlerSite m) ~ User
|
||||
, IsSqlBackend (YesodPersistBackend (HandlerSite m))
|
||||
, SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
|
||||
, HasInstanceID (HandlerSite m) InstanceId
|
||||
, YesodAuthPersist (HandlerSite m)
|
||||
, MonadHandler m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Transaction -- ^ Transaction to record
|
||||
-> YesodDB site ()
|
||||
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
||||
-- ^ Special case of `audit` for when there are no affected users
|
||||
audit' = flip audit []
|
||||
|
||||
@ -1527,6 +1527,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR)
|
||||
breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR)
|
||||
breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR)
|
||||
breadcrumb (CExamR tid ssh csh examn EAddUserR) = return ("Klausurteilnehmer hinzufügen", Just $ CExamR tid ssh csh examn EUsersR)
|
||||
|
||||
breadcrumb (CTutorialR tid ssh csh tutn TUsersR) = return (original tutn, Just $ CourseR tid ssh csh CTutorialListR)
|
||||
breadcrumb (CTutorialR tid ssh csh tutn TEditR) = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR)
|
||||
@ -2219,6 +2220,16 @@ pageActions (CExamR tid ssh csh examn EShowR) =
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CExamR tid ssh csh examn EUsersR) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuExamAddMembers
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EAddUserR
|
||||
, menuItemModal = True
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CSheetR tid ssh csh shn SShowR) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
|
||||
@ -794,8 +794,8 @@ lecturerInvitationConfig = InvitationConfig{..}
|
||||
invitationResolveFor = do
|
||||
Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
|
||||
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
||||
invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
|
||||
invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
|
||||
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
|
||||
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
@ -805,12 +805,13 @@ lecturerInvitationConfig = InvitationConfig{..}
|
||||
Nothing -> areq (selectField optionsFinite) lFs Nothing
|
||||
Just lType -> aforced (selectField optionsFinite) lFs lType
|
||||
where
|
||||
toJunction jLecturerType = JunctionLecturer{..}
|
||||
toJunction jLecturerType = (JunctionLecturer{..}, ())
|
||||
lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical
|
||||
invitationSuccessMsg Course{..} (Entity _ Lecturer{..}) = do
|
||||
invitationInsertHook _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ Course{..}) (Entity _ Lecturer{..}) = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand
|
||||
invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
|
||||
|
||||
data CourseForm = CourseForm
|
||||
@ -1537,8 +1538,6 @@ instance IsInvitableJunction CourseParticipant where
|
||||
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField))
|
||||
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..})
|
||||
|
||||
ephemeralInvitation = Just (iso (const InvDBDataParticipant) (const ()))
|
||||
|
||||
instance ToJSON (InvitableJunction CourseParticipant) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
@ -1564,23 +1563,22 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
invitationResolveFor = do
|
||||
Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute
|
||||
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
||||
invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
|
||||
invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
|
||||
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
|
||||
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
|
||||
-- Keine besonderen Einschränkungen beim Einlösen der Token
|
||||
-- ACHTUNG: Mit einem Token könnten sich deshalb mehrere Benutzer anmelden!
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm Course{..} _ uid = hoistAForm lift . wFormToAForm $ do
|
||||
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
|
||||
now <- liftIO getCurrentTime
|
||||
studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid)
|
||||
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing
|
||||
return $ JunctionParticipant <$> pure now <*> studyFeatures
|
||||
invitationSuccessMsg Course{..} _ =
|
||||
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures
|
||||
invitationInsertHook _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ Course{..}) _ =
|
||||
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
|
||||
invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
|
||||
data AddRecipientsResult = AddRecipientsResult
|
||||
{ aurAlreadyRegistered
|
||||
|
||||
@ -2,7 +2,7 @@
|
||||
|
||||
module Handler.Exam where
|
||||
|
||||
import Import
|
||||
import Import hiding (Option(..))
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Exam
|
||||
@ -32,8 +32,12 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
import Control.Monad.Trans.Writer (WriterT, execWriterT)
|
||||
import Control.Monad.Error.Class (MonadError(..))
|
||||
import Control.Arrow (Kleisli(..))
|
||||
|
||||
import Data.Semigroup (Option(..))
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
@ -42,6 +46,8 @@ import Numeric.Lens (integral)
|
||||
|
||||
import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
||||
|
||||
import Generics.Deriving.Monoid
|
||||
|
||||
|
||||
|
||||
-- Dedicated ExamRegistrationButton
|
||||
@ -148,20 +154,21 @@ examCorrectorInvitationConfig = InvitationConfig{..}
|
||||
invitationResolveFor = do
|
||||
Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute
|
||||
fetchExamId tid csh ssh examn
|
||||
invitationSubject Exam{..} _ = do
|
||||
invitationSubject (Entity _ Exam{..}) _ = do
|
||||
Course{..} <- get404 examCourse
|
||||
return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
|
||||
invitationHeading Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
|
||||
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ _ = pure JunctionExamCorrector
|
||||
invitationSuccessMsg Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName
|
||||
invitationUltDest Exam{..} _ = do
|
||||
invitationForm _ _ _ = pure (JunctionExamCorrector, ())
|
||||
invitationInsertHook _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName
|
||||
invitationUltDest (Entity _ Exam{..}) _ = do
|
||||
Course{..} <- get404 examCourse
|
||||
return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CExamListR
|
||||
return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR
|
||||
|
||||
getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getECInviteR = postECInviteR
|
||||
@ -1280,13 +1287,222 @@ postEUsersR tid ssh csh examn = do
|
||||
$(widgetFile "exam-users")
|
||||
|
||||
|
||||
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 _ _ = [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 (studyFeaturesPrimaryFieldFor False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing
|
||||
return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
|
||||
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
|
||||
invitationInsertHook (Entity _ Exam{..}) _ ExamRegistration{..} mField act = do
|
||||
whenIsJust mField $
|
||||
insert_ . CourseParticipant examCourse examRegistrationUser examRegistrationTime
|
||||
|
||||
Course{..} <- get404 examCourse
|
||||
User{..} <- get404 examRegistrationUser
|
||||
let doAudit = audit' $ TransactionExamRegister (unTermKey courseTerm) (unSchoolKey courseSchool) courseShorthand examName userIdent
|
||||
act <* doAudit
|
||||
invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName
|
||||
invitationUltDest (Entity _ Exam{..}) _ = do
|
||||
Course{..} <- get404 examCourse
|
||||
return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR
|
||||
|
||||
data AddRecipientsResult = AddRecipientsResult
|
||||
{ aurAlreadyRegistered
|
||||
, aurNoUniquePrimaryField
|
||||
, aurNoCourseRegistration
|
||||
, aurSuccess :: [UserEmail]
|
||||
} deriving (Read, Show, Generic, Typeable)
|
||||
|
||||
instance Monoid AddRecipientsResult where
|
||||
mempty = memptydefault
|
||||
mappend = mappenddefault
|
||||
|
||||
|
||||
getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getEAddUserR = postEAddUserR
|
||||
postEAddUserR = error "postEAddUserR"
|
||||
postEAddUserR tid ssh csh examn = do
|
||||
eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn
|
||||
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
||||
now <- liftIO getCurrentTime
|
||||
occurrences <- liftHandlerT . runDB $ selectList [ExamOccurrenceExam ==. eid] []
|
||||
|
||||
let
|
||||
localNow = utcToLocalTime now
|
||||
tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of
|
||||
LTUUnique utc' _ -> utc'
|
||||
_other -> UTCTime (addDays 2 $ utctDay now) 0
|
||||
earliestDate = getOption . fmap getMin $ mconcat
|
||||
[ Option $ Min <$> examStart
|
||||
, foldMap (Option . Just . Min . examOccurrenceStart . entityVal) occurrences
|
||||
]
|
||||
modifiedEarliestDate = earliestDate <&> \earliestDate'@(utcToLocalTime -> localEarliestDate')
|
||||
-> case localTimeToUTC (LocalTime (addDays (-1) $ localDay localEarliestDate') midnight) of
|
||||
LTUUnique utc' _ -> utc'
|
||||
_other -> UTCTime (addDays (-1) $ utctDay earliestDate') 0
|
||||
defDeadline
|
||||
| Just registerTo <- examRegisterTo
|
||||
, registerTo > now
|
||||
= registerTo
|
||||
| Just earliestDate' <- modifiedEarliestDate
|
||||
= max tomorrowEndOfDay earliestDate'
|
||||
| otherwise
|
||||
= tomorrowEndOfDay
|
||||
|
||||
deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
|
||||
enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly) (Just False)
|
||||
registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False)
|
||||
occurrence <- wopt (examOccurrenceField eid) (fslI MsgExamOccurrence) Nothing
|
||||
users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
|
||||
(fslI MsgExamRegistrationInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
|
||||
return $ (,,,) <$> deadline <*> registerCourse <*> occurrence <*> users
|
||||
|
||||
formResultModal usersToEnlist (CExamR tid ssh csh examn EUsersR) $ processUsers eEnt
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh MsgExamParticipantsRegisterHeading
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
wrapForm formWgt def
|
||||
{ formEncoding
|
||||
, formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAddUserR
|
||||
}
|
||||
where
|
||||
processUsers :: Entity Exam -> (UTCTime, Bool, Maybe ExamOccurrenceId, Set (Either UserEmail UserId)) -> WriterT [Message] Handler ()
|
||||
processUsers (Entity eid Exam{..}) (deadline, registerCourse, occId, users) = do
|
||||
let (emails,uids) = partitionEithers $ Set.toList users
|
||||
AddRecipientsResult alreadyRegistered registeredNoField noCourseRegistration registeredOneField <- lift . runDBJobs $ do
|
||||
-- send Invitation eMails to unkown users
|
||||
sinkInvitationsF examRegistrationInvitationConfig [(mail,eid,(InvDBDataExamRegistration occId deadline registerCourse, InvTokenDataExamRegistration)) | mail <- emails]
|
||||
-- register known users
|
||||
execWriterT $ mapM (registerUser examCourse eid registerCourse occId) uids
|
||||
|
||||
when (not $ null emails) $
|
||||
tell . pure <=< messageI Success . MsgExamParticipantsInvited $ length emails
|
||||
|
||||
when (not $ null alreadyRegistered) $
|
||||
tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length registeredOneField
|
||||
|
||||
when (not $ null registeredNoField) $ do
|
||||
let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}|]
|
||||
modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField")
|
||||
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
when (not $ null noCourseRegistration) $ do
|
||||
let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length noCourseRegistration)}|]
|
||||
modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse")
|
||||
tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
when (not $ null registeredOneField) $
|
||||
tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length registeredOneField
|
||||
|
||||
registerUser :: CourseId -> ExamId -> Bool -> Maybe ExamOccurrenceId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
|
||||
registerUser cid eid registerCourse occId uid = exceptT tell tell $ do
|
||||
User{..} <- lift . lift $ getJust uid
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
let
|
||||
examRegister :: YesodJobDB UniWorX ()
|
||||
examRegister = do
|
||||
insert_ $ ExamRegistration eid uid occId now
|
||||
audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
|
||||
|
||||
whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $
|
||||
throwError $ mempty { aurAlreadyRegistered = pure userEmail }
|
||||
|
||||
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ do
|
||||
lift $ lift examRegister
|
||||
throwError $ mempty { aurSuccess = pure userEmail }
|
||||
|
||||
unless registerCourse $
|
||||
throwError $ mempty { aurNoCourseRegistration = pure userEmail }
|
||||
|
||||
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
|
||||
|
||||
let courseParticipantField
|
||||
| [f] <- features = Just f
|
||||
| otherwise = Nothing
|
||||
|
||||
lift . lift . insert_ $ CourseParticipant
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, courseParticipantRegistration = now
|
||||
, ..
|
||||
}
|
||||
lift $ lift examRegister
|
||||
|
||||
return $ case courseParticipantField of
|
||||
Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
|
||||
Just _ -> mempty { aurSuccess = pure userEmail }
|
||||
|
||||
|
||||
getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
getEInviteR = postEInviteR
|
||||
postEInviteR = error "postEInviteR"
|
||||
postEInviteR _ _ _ _ = invitationR' examRegistrationInvitationConfig
|
||||
|
||||
postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
||||
postERegisterR tid ssh csh examn = do
|
||||
|
||||
@ -902,18 +902,19 @@ correctorInvitationConfig = InvitationConfig{..}
|
||||
invitationResolveFor = do
|
||||
Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute
|
||||
fetchSheetId tid csh ssh shn
|
||||
invitationSubject Sheet{..} _ = do
|
||||
invitationSubject (Entity _ Sheet{..}) _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
|
||||
invitationHeading Sheet{..} _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
|
||||
invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ JunctionSheetCorrector load state
|
||||
invitationSuccessMsg Sheet{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
|
||||
invitationUltDest Sheet{..} _ = do
|
||||
invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ())
|
||||
invitationInsertHook _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
|
||||
invitationUltDest (Entity _ Sheet{..}) _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
return . SomeRoute $ CSheetR courseTerm courseSchool courseShorthand sheetName SShowR
|
||||
|
||||
|
||||
@ -93,15 +93,15 @@ submissionUserInvitationConfig = InvitationConfig{..}
|
||||
Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute
|
||||
subId <- decrypt cID
|
||||
bool notFound (return subId) =<< existsKey subId
|
||||
invitationSubject Submission{..} _ = do
|
||||
invitationSubject (Entity _ Submission{..}) _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
Course{..} <- getJust sheetCourse
|
||||
return . SomeMessage $ MsgMailSubjectSubmissionUserInvitation courseTerm courseSchool courseShorthand sheetName
|
||||
invitationHeading Submission{..} _ = do
|
||||
invitationHeading (Entity _ Submission{..}) _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|]
|
||||
invitationTokenConfig Submission{..} _ = do
|
||||
invitationTokenConfig (Entity _ Submission{..}) _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
Course{..} <- getJust sheetCourse
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
@ -110,14 +110,15 @@ submissionUserInvitationConfig = InvitationConfig{..}
|
||||
itStartsAt = Nothing
|
||||
return InvitationTokenConfig{..}
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ _ = pure JunctionSubmissionUser
|
||||
invitationSuccessMsg Submission{..} _ = do
|
||||
invitationForm _ _ _ = pure (JunctionSubmissionUser, ())
|
||||
invitationInsertHook _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ Submission{..}) _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName
|
||||
invitationUltDest Submission{..} (Entity _ SubmissionUser{..}) = do
|
||||
invitationUltDest (Entity subId Submission{..}) _ = do
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
Course{..} <- getJust sheetCourse
|
||||
cID <- encrypt submissionUserSubmission
|
||||
cID <- encrypt subId
|
||||
return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR
|
||||
|
||||
|
||||
|
||||
@ -252,18 +252,19 @@ tutorInvitationConfig = InvitationConfig{..}
|
||||
invitationResolveFor = do
|
||||
Just (CTutorialR tid csh ssh tutn TInviteR) <- getCurrentRoute
|
||||
fetchTutorialId tid csh ssh tutn
|
||||
invitationSubject Tutorial{..} _ = do
|
||||
invitationSubject (Entity _ Tutorial{..}) _ = do
|
||||
Course{..} <- get404 tutorialCourse
|
||||
return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName
|
||||
invitationHeading Tutorial{..} _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
|
||||
invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ _ = pure JunctionTutor
|
||||
invitationSuccessMsg Tutorial{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
|
||||
invitationUltDest Tutorial{..} _ = do
|
||||
invitationForm _ _ _ = pure (JunctionTutor, ())
|
||||
invitationInsertHook _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
|
||||
invitationUltDest (Entity _ Tutorial{..}) _ = do
|
||||
Course{..} <- get404 tutorialCourse
|
||||
return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR
|
||||
|
||||
|
||||
@ -40,6 +40,7 @@ import Data.Typeable
|
||||
class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
|
||||
, ToJSON (InvitationDBData junction), ToJSON (InvitationTokenData junction)
|
||||
, FromJSON (InvitationDBData junction), FromJSON (InvitationTokenData junction)
|
||||
, Eq (InvitationDBData junction)
|
||||
, PersistRecordBackend (InvitationFor junction) (YesodPersistBackend UniWorX)
|
||||
, Typeable junction
|
||||
) => IsInvitableJunction junction where
|
||||
@ -111,30 +112,32 @@ invRef = toJSON . InvRef @junction
|
||||
-- | Configuration needed for creating and accepting/declining `Invitation`s
|
||||
--
|
||||
-- It is advisable to define this once per `junction` in a global constant
|
||||
data InvitationConfig junction = InvitationConfig
|
||||
{ invitationRoute :: Entity (InvitationFor junction) -> InvitationData junction -> YesodDB UniWorX (Route UniWorX)
|
||||
data InvitationConfig junction = forall formCtx. InvitationConfig
|
||||
{ invitationRoute :: Entity (InvitationFor junction) -> InvitationData junction -> DB (Route UniWorX)
|
||||
-- ^ Which route calls `invitationR` for this kind of invitation?
|
||||
, invitationResolveFor :: YesodDB UniWorX (Key (InvitationFor junction))
|
||||
, invitationResolveFor :: DB (Key (InvitationFor junction))
|
||||
-- ^ Monadically resolve `InvitationFor` during `inviteR`
|
||||
--
|
||||
-- Usually from `requireBearerToken` or `getCurrentRoute`
|
||||
, invitationSubject :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX)
|
||||
, invitationSubject :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
|
||||
-- ^ Subject of the e-mail which sends the token to the user
|
||||
, invitationHeading :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX)
|
||||
, invitationHeading :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
|
||||
-- ^ Heading of the page which allows the invitee to accept/decline the invitation (`invitationR`
|
||||
, invitationExplanation :: InvitationFor junction -> InvitationData junction -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
|
||||
, invitationExplanation :: Entity (InvitationFor junction) -> InvitationData junction -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
|
||||
-- ^ Explanation of what kind of invitation this is (used both in the e-mail and in `invitationR`)
|
||||
, invitationTokenConfig :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX InvitationTokenConfig
|
||||
, invitationTokenConfig :: Entity (InvitationFor junction) -> InvitationData junction -> DB InvitationTokenConfig
|
||||
-- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently)
|
||||
, invitationRestriction :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX AuthResult
|
||||
, invitationRestriction :: Entity (InvitationFor junction) -> InvitationData junction -> DB AuthResult
|
||||
-- ^ Additional restrictions to check before allowing an user to redeem an invitation token
|
||||
, invitationForm :: InvitationFor junction -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction)
|
||||
, invitationForm :: Entity (InvitationFor junction) -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction, formCtx)
|
||||
-- ^ Assimilate the additional data entered by the redeeming user
|
||||
, invitationSuccessMsg :: InvitationFor junction -> Entity junction -> YesodDB UniWorX (SomeMessage UniWorX)
|
||||
, invitationInsertHook :: forall a. Entity (InvitationFor junction) -> InvitationData junction -> junction -> formCtx -> (DB a -> DB a)
|
||||
-- ^ Perform additional actions before or after insertion of the junction into the database
|
||||
, invitationSuccessMsg :: Entity (InvitationFor junction) -> Entity junction -> DB (SomeMessage UniWorX)
|
||||
-- ^ What to tell the redeeming user after accepting the invitation
|
||||
, invitationUltDest :: InvitationFor junction -> Entity junction -> YesodDB UniWorX (SomeRoute UniWorX)
|
||||
, invitationUltDest :: Entity (InvitationFor junction) -> Entity junction -> DB (SomeRoute UniWorX)
|
||||
-- ^ Where to redirect the redeeming user after accepting the invitation
|
||||
} deriving (Generic, Typeable)
|
||||
}
|
||||
|
||||
-- | Additional configuration needed for an invocation of `bearerToken`
|
||||
data InvitationTokenConfig = InvitationTokenConfig
|
||||
@ -177,36 +180,50 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
|
||||
where
|
||||
determineExists :: Conduit (Invitation' junction)
|
||||
(YesodJobDB UniWorX)
|
||||
(Either (InvitationId, InvitationData junction) (Invitation' junction))
|
||||
(Invitation' junction)
|
||||
determineExists
|
||||
| is _Just (ephemeralInvitation @junction)
|
||||
= C.map Right
|
||||
= C.map id
|
||||
| otherwise
|
||||
= C.mapM $ \inp@(email, fid, dat) ->
|
||||
maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (invRef @junction fid))
|
||||
= awaitForever $ \inp@(email, fid, view _InvitationData -> (dat, _)) -> do
|
||||
dbEntry <- lift . getBy $ UniqueInvitation email (invRef @junction fid)
|
||||
case dbEntry of
|
||||
Just (Entity _ Invitation{invitationData})
|
||||
| Just dbData <- decode invitationData
|
||||
, dbData == dat
|
||||
-> return ()
|
||||
Just (Entity invId _)
|
||||
-> lift (delete invId) >> yield inp
|
||||
Nothing
|
||||
-> yield inp
|
||||
where
|
||||
decode invData
|
||||
= case fromJSON invData of
|
||||
JSON.Success dbData -> return dbData
|
||||
JSON.Error str -> fail $ "Could not decode invitationData: " <> str
|
||||
|
||||
sinkInvitations' :: [Either (InvitationId, InvitationData junction) (Invitation' junction)]
|
||||
sinkInvitations' :: [Invitation' junction]
|
||||
-> YesodJobDB UniWorX ()
|
||||
sinkInvitations' (partitionEithers -> (existing, new)) = do
|
||||
sinkInvitations' new = do
|
||||
when (is _Nothing (ephemeralInvitation @junction)) $ do
|
||||
insertMany_ $ map (\(email, fid, dat) -> Invitation email (invRef @junction fid) (toJSON $ dat ^. _invitationDBData)) new
|
||||
forM_ existing $ \(iid, dat) -> update iid [ InvitationData =. toJSON (dat ^. _invitationDBData) ]
|
||||
-- forM_ existing $ \(iid, oldDat) -> update iid [ InvitationData =. toJSON (dat ^. _invitationDBData) ]
|
||||
forM_ new $ \(jInvitee, fid, dat) -> do
|
||||
app <- getYesod
|
||||
let mr = renderMessage app $ NonEmpty.toList appLanguages
|
||||
ur <- getUrlRenderParams
|
||||
|
||||
fRec <- get404 fid
|
||||
fEnt <- Entity fid <$> get404 fid
|
||||
|
||||
jInviter <- liftHandlerT requireAuthId
|
||||
route <- mapReaderT liftHandlerT $ invitationRoute (Entity fid fRec) dat
|
||||
InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec dat
|
||||
route <- mapReaderT liftHandlerT $ invitationRoute fEnt dat
|
||||
InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fEnt dat
|
||||
protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
|
||||
let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
|
||||
jwt <- encodeToken token
|
||||
jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
|
||||
jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fRec dat
|
||||
let jInvitationExplanation = invitationExplanation fRec dat (toHtml . mr) ur
|
||||
jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat
|
||||
let jInvitationExplanation = invitationExplanation fEnt dat (toHtml . mr) ur
|
||||
|
||||
queueDBJob JobInvitation{..}
|
||||
|
||||
@ -270,7 +287,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
|
||||
Just cRoute <- getCurrentRoute
|
||||
|
||||
(tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do
|
||||
Entity fid fRec <- invitationResolveFor >>= (\k -> Entity k <$> get404 k)
|
||||
fEnt@(Entity fid _) <- invitationResolveFor >>= (\k -> Entity k <$> get404 k)
|
||||
dbData <- case ephemeralInvitation @junction of
|
||||
Nothing -> do
|
||||
Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid)
|
||||
@ -281,9 +298,9 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
|
||||
let
|
||||
iData :: InvitationData junction
|
||||
iData = review _InvitationData (dbData, itData)
|
||||
guardAuthResult =<< invitationRestriction fRec iData
|
||||
guardAuthResult =<< invitationRestriction fEnt iData
|
||||
((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
|
||||
dataRes <- aFormToWForm $ invitationForm fRec iData invitee
|
||||
dataRes <- aFormToWForm $ invitationForm fEnt iData invitee
|
||||
btnRes <- aFormToWForm . disambiguateButtons $ combinedButtonField (BtnInviteAccept : [ BtnInviteDecline | is _Nothing $ ephemeralInvitation @junction ]) (fslI MsgInvitationAction & bool id (setTooltip MsgInvitationActionTip) (is _Nothing $ ephemeralInvitation @junction))
|
||||
case btnRes of
|
||||
FormSuccess BtnInviteDecline -> return $ FormSuccess Nothing
|
||||
@ -291,22 +308,23 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
ur <- getUrlRenderParams
|
||||
heading <- invitationHeading fRec iData
|
||||
let explanation = invitationExplanation fRec iData (toHtml . mr) ur
|
||||
heading <- invitationHeading fEnt iData
|
||||
let explanation = invitationExplanation fEnt iData (toHtml . mr) ur
|
||||
|
||||
fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case
|
||||
Nothing -> do
|
||||
addMessageI Info MsgInvitationDeclined
|
||||
deleteBy . UniqueInvitation itEmail $ invRef @junction fid
|
||||
return . Just $ SomeRoute HomeR
|
||||
Just jData -> do
|
||||
mResult <- insertUniqueEntity $ review _InvitableJunction (invitee, fid, jData)
|
||||
Just (jData, formCtx) -> do
|
||||
let junction = review _InvitableJunction (invitee, fid, jData)
|
||||
mResult <- invitationInsertHook fEnt iData junction formCtx $ insertUniqueEntity junction
|
||||
case mResult of
|
||||
Nothing -> invalidArgsI [MsgInvitationCollision]
|
||||
Just res -> do
|
||||
deleteBy . UniqueInvitation itEmail $ invRef @junction fid
|
||||
addMessageI Success =<< invitationSuccessMsg fRec res
|
||||
Just <$> invitationUltDest fRec res
|
||||
addMessageI Success =<< invitationSuccessMsg fEnt res
|
||||
Just <$> invitationUltDest fEnt res
|
||||
|
||||
whenIsJust tRoute redirect
|
||||
|
||||
|
||||
@ -44,7 +44,7 @@ import Data.Ix as Import (Ix)
|
||||
import Data.Hashable as Import
|
||||
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
|
||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
import Data.Semigroup as Import (Semigroup)
|
||||
import Data.Semigroup as Import (Semigroup, Min(..), Max(..))
|
||||
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..))
|
||||
import Data.Binary as Import (Binary)
|
||||
|
||||
|
||||
@ -0,0 +1,5 @@
|
||||
<h2>
|
||||
_{MsgExamRegistrationNotRegisteredWithoutCourse (length registeredNoField)}
|
||||
<ul>
|
||||
$forall email <- noCourseRegistration
|
||||
<li style="font-family: monospace">#{email}
|
||||
@ -0,0 +1,5 @@
|
||||
<h2>
|
||||
_{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}
|
||||
<ul>
|
||||
$forall email <- registeredNoField
|
||||
<li style="font-family: monospace">#{email}
|
||||
Loading…
Reference in New Issue
Block a user