feat(exams): implement exam registration invitations

messages/uniworx/de.msg

@@ -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

src/Audit.hs

@@ -43,16 +43,18 @@ data AuditException
 instance Exception AuditException
 
 
-audit :: ( AuthId site ~ Key User
+audit :: ( AuthId (HandlerSite m) ~ Key User
-         , AuthEntity site ~ User
+         , AuthEntity (HandlerSite m) ~ User
-         , IsSqlBackend (YesodPersistBackend site)
+         , IsSqlBackend (YesodPersistBackend (HandlerSite m))
-         , SqlBackendCanWrite (YesodPersistBackend site)
+         , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
-         , HasInstanceID site InstanceId
+         , HasInstanceID (HandlerSite m) InstanceId
-         , YesodAuthPersist site
+         , 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
+audit' :: ( AuthId (HandlerSite m) ~ Key User
-          , AuthEntity site ~ User
+          , AuthEntity (HandlerSite m) ~ User
-          , IsSqlBackend (YesodPersistBackend site)
+          , IsSqlBackend (YesodPersistBackend (HandlerSite m))
-          , SqlBackendCanWrite (YesodPersistBackend site)
+          , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
-          , HasInstanceID site InstanceId
+          , HasInstanceID (HandlerSite m) InstanceId
-          , YesodAuthPersist site
+          , 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 []

src/Foundation.hs

@@ -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

src/Handler/Course.hs

@@ -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
+    invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
-    invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
+    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
+    invitationSubject     (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
-    invitationHeading     Course{..} _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
+    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
+      return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures
-    invitationSuccessMsg Course{..} _ =
+    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

src/Handler/Exam.hs

@@ -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
+    invitationForm _ _ _ = pure (JunctionExamCorrector, ())
-    invitationSuccessMsg Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName
+    invitationInsertHook _ _ _ _ = id
-    invitationUltDest Exam{..} _ = do
+    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

src/Handler/Sheet.hs

@@ -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
+    invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ())
-    invitationSuccessMsg Sheet{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
+    invitationInsertHook _ _ _ _ = id
-    invitationUltDest Sheet{..} _ = do
+    invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
+    invitationUltDest (Entity _ Sheet{..}) _ = do
       Course{..} <- get404 sheetCourse
       return . SomeRoute $ CSheetR courseTerm courseSchool courseShorthand sheetName SShowR
 

src/Handler/Submission.hs

@@ -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
+    invitationForm _ _ _ = pure (JunctionSubmissionUser, ())
-    invitationSuccessMsg Submission{..} _ = do
+    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
 
 

src/Handler/Tutorial.hs

@@ -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
+    invitationForm _ _ _ = pure (JunctionTutor, ())
-    invitationSuccessMsg Tutorial{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
+    invitationInsertHook _ _ _ _ = id
-    invitationUltDest Tutorial{..} _ = do
+    invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
+    invitationUltDest (Entity _ Tutorial{..}) _ = do
       Course{..} <- get404 tutorialCourse
       return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR
 

src/Handler/Utils/Invitations.hs

@@ -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
+data InvitationConfig junction = forall formCtx. InvitationConfig
-  { invitationRoute       :: Entity (InvitationFor junction) -> InvitationData junction -> YesodDB UniWorX (Route UniWorX)
+  { 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) ->
+      = awaitForever $ \inp@(email, fid, view _InvitationData -> (dat, _)) -> do
-          maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (invRef @junction fid))
+          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
+        route <- mapReaderT liftHandlerT $ invitationRoute fEnt dat
-        InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec 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
+        jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat
-        let jInvitationExplanation = invitationExplanation fRec dat (toHtml . mr) ur
+        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
+    heading <- invitationHeading fEnt iData
-    let explanation = invitationExplanation fRec iData (toHtml . mr) ur
+    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
+      Just (jData, formCtx) -> do
-        mResult <- insertUniqueEntity $ review _InvitableJunction (invitee, fid, jData)
+        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
+            addMessageI Success =<< invitationSuccessMsg fEnt res
-            Just <$> invitationUltDest fRec res
+            Just <$> invitationUltDest fEnt res
 
   whenIsJust tRoute redirect
 

src/Import/NoModel.hs

@@ -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)
 

templates/messages/examRegistrationInvitationNotRegisteredWithoutCourse.hamlet

@@ -0,0 +1,5 @@
+<h2>
+  _{MsgExamRegistrationNotRegisteredWithoutCourse (length registeredNoField)}
+<ul>
+  $forall email <- noCourseRegistration
+    <li style="font-family: monospace">#{email}

templates/messages/examRegistrationInvitationRegisteredWithoutField.hamlet

@@ -0,0 +1,5 @@
+<h2>
+  _{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}
+<ul>
+  $forall email <- registeredNoField
+    <li style="font-family: monospace">#{email}