Lecturer invitations via e-mail

messages/uniworx/de.msg

@@ -11,6 +11,8 @@ BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
 BtnCandidatesDeleteConflicts: Konflikte löschen
 BtnCandidatesDeleteAll: Alle Beobachtungen löschen
 BtnResetTokens: Authorisierungs-Tokens invalidieren
+BtnLecInvAccept: Annehmen
+BtnLecInvDecline: Ablehnen
 
 Aborted: Abgebrochen
 Remarks: Hinweise
@@ -523,6 +525,9 @@ MailEditNotifications: Benachrichtigungen ein-/ausschalten
 MailSubjectSupport: Supportanfrage
 MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject}
 
+MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter
+CourseLecturerInvitationAcceptDecline: Einladung annehmen/ablehnen
+
 SheetGrading: Bewertung
 SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
 SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
@@ -745,4 +750,11 @@ DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus de
 MassInputAddDimension: Hinzufügen
 MassInputDeleteCell: Entfernen
 
-NavigationFavourites: Favoriten
+NavigationFavourites: Favoriten
+
+EmailInvitationWarning: Dem System ist kein Nutzer mit dieser Addresse bekannt. Es wird eine Einladung per E-Mail versandt.
+
+LecturerInvitationAccepted lType@Text csh@CourseShorthand: Sie wurden als #{lType} für #{csh} eingetragen
+LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursverwalter für #{csh} zu werden, abgelehnt
+CourseLecInviteHeading courseName@Text: Einladung zum Kursverwalter für #{courseName}
+CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu sein.

models/courses

@@ -35,6 +35,12 @@ Lecturer                       -- course ownership
     course       CourseId
     type         LecturerType  default='"lecturer"'
     UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table
+LecturerInvitation json        -- preliminary course ownership for when a token to become `Lecturer` is sent to an email
+    email        (CI Text)
+    course       CourseId
+    type         LecturerType Maybe
+    UniqueLecturerInvitation email course
+    deriving Eq Ord Read Show Generic Typeable
 CourseParticipant                      -- course enrolement
     course       CourseId
     user         UserId

routes

@@ -76,6 +76,7 @@
   /                           CShowR          GET             !free
   /register                   CRegisterR          POST        !timeANDcapacity
   /edit                       CEditR          GET POST
+  /lecturer-invite/#UserEmail CLecInviteR     GET POST
   /delete                     CDeleteR        GET POST        !lecturerANDempty
   /users                      CUsersR         GET POST
   /users/#CryptoUUIDUser      CUserR          GET POST        !lecturerANDparticipant

src/Database/Persist/Types/Instances.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Database.Persist.Types.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Database.Persist.Types
+
+instance (Hashable record, Hashable (Key record)) => Hashable (Entity record) where
+  s `hashWithSalt` Entity{..} = s `hashWithSalt` entityKey `hashWithSalt` entityVal

src/Foundation.hs

@@ -487,11 +487,13 @@ tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return r
   User{userTokensIssuedAfter} <- lift $ get404 tokenAuthority
   guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
 
-  authorityVal <- evalAccessFor (Just tokenAuthority) route isWrite
+  authorityVal <- do
+    dnf <- either throwM return $ routeAuthTags route
+    fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite
   guardExceptT (is _Authorized authorityVal) authorityVal
 
   whenIsJust tokenAddAuth $ \addDNF -> do
-    additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) addDNF mAuthId route isWrite
+    additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite
     guardExceptT (is _Authorized additionalVal) additionalVal
 
   return Authorized

src/Handler/Course.hs

@@ -33,6 +33,8 @@ import qualified Database.Esqueleto as E
 
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 
+import Jobs.Queue
+
 -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
 type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
 
@@ -416,7 +418,7 @@ getCourseNewR = do
           return course
       template <- case listToMaybe oldCourses of
         (Just oldTemplate) ->
-            let newTemplate = courseToForm oldTemplate [] in
+            let newTemplate = courseToForm oldTemplate [] [] in
             return $ Just $ newTemplate
                 { cfCourseId   = Nothing
                 , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
@@ -445,13 +447,14 @@ postCEditR = pgCEditR
 
 pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 pgCEditR tid ssh csh = do
-  courseLecs <- runDB $ do
+  courseData <- runDB $ do
-      mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
+      mbCourse     <- getBy (TermSchoolCourseShort tid ssh csh)
-      mbLecs   <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
+      mbLecs       <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
-      return $ (,) <$> mbCourse <*> mbLecs
+      mbLecInvites <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerInvitationCourse ==. entityKey course] [Asc LecturerInvitationType]
+      return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
   -- IMPORTANT: both GET and POST Handler must use the same template,
   --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
-  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ uncurry courseToForm <$> courseLecs
+  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData
 
 
 getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@@ -479,7 +482,7 @@ courseEditHandler miButtonAction mbCourseForm = do
         , cfTerm     = tid
         } -> do -- create new course
           now <- liftIO getCurrentTime
-          insertOkay <- runDB $ do
+          insertOkay <- runDBJobs $ do
             insertOkay <- insertUnique Course
               { courseName            = cfName     res
               , courseDescription     = cfDesc     res
@@ -495,7 +498,11 @@ courseEditHandler miButtonAction mbCourseForm = do
               , courseDeregisterUntil = cfDeRegUntil res
               }
             whenIsJust insertOkay $ \cid -> do
-                forM_ (cfLecturers res) (\(lid,lty) -> insert_  $ Lecturer lid cid lty)
+                forM_ (cfLecturers res) $ \case
+                  Right (lid, lty) -> insert_  $ Lecturer lid cid lty
+                  Left (lEmail, mLTy) -> do
+                    insert_ $ LecturerInvitation lEmail cid mLTy
+                    queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy
                 insert_ $ CourseEdit aid now cid
             return insertOkay
           case insertOkay of
@@ -513,7 +520,7 @@ courseEditHandler miButtonAction mbCourseForm = do
         } -> do -- edit existing course
           now <- liftIO getCurrentTime
           -- addMessage "debug" [shamlet| #{show res}|]
-          success <- runDB $ do
+          success <- runDBJobs $ do
             old <- get cid
             case old of
               Nothing -> addMessageI Error MsgInvalidInput $> False
@@ -536,7 +543,15 @@ courseEditHandler miButtonAction mbCourseForm = do
                   (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
                   Nothing  -> do
                     deleteWhere [LecturerCourse ==. cid]
-                    forM_ (cfLecturers res) (\(lid,lty) -> insert_  $ Lecturer lid cid lty)
+                    forM_ (cfLecturers res) $ \case
+                      Right (lid, lty) -> insert_  $ Lecturer lid cid lty
+                      Left (lEmail, mLTy) -> do
+                        insertRes <- insertUnique (LecturerInvitation lEmail cid mLTy)
+                        case insertRes of
+                          Just _  ->
+                            queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy
+                          Nothing -> 
+                            updateBy (UniqueLecturerInvitation lEmail cid) [ LecturerInvitationType =. mLTy ]
                     insert_ $ CourseEdit aid now cid
                     addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True
@@ -564,11 +579,11 @@ data CourseForm = CourseForm
         , cfRegFrom    :: Maybe UTCTime
         , cfRegTo      :: Maybe UTCTime
         , cfDeRegUntil :: Maybe UTCTime
-        , cfLecturers  :: [(UserId, LecturerType)]
+        , cfLecturers  :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
         }
 
-courseToForm :: Entity Course -> [Lecturer] -> CourseForm
+courseToForm :: Entity Course -> [Lecturer] -> [LecturerInvitation] -> CourseForm
-courseToForm (Entity cid Course{..}) lecs = CourseForm
+courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
     { cfCourseId   = Just cid
     , cfName       = courseName
     , cfDesc       = courseDescription
@@ -582,7 +597,8 @@ courseToForm (Entity cid Course{..}) lecs = CourseForm
     , cfRegFrom    = courseRegisterFrom
     , cfRegTo      = courseRegisterTo
     , cfDeRegUntil = courseDeregisterUntil
-    , cfLecturers  = [(lecturerUser, lecturerType) | Lecturer{..} <- lecs]
+    , cfLecturers  = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
+                  ++ [Left (lecturerInvitationEmail, lecturerInvitationType) | LecturerInvitation{..} <- lecInvites ]
     }
 
 makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
@@ -609,29 +625,46 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
                 | otherwise ->  termsSetField [cfTerm cform]
           _allOtherCases -> return termsAllowedField
 
-    let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition UserId -> FormResult (Map ListPosition UserId)))
+    let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
         miAdd _ _ nudge btn = Just $ \csrf -> do
           (addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
           addRes'  <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
           let addRes'' = case (,) <$> addRes <*> addRes' of
-                FormSuccess (email, Nothing) -> FormFailure [ mr . MsgEMailUnknown $ CI.mk email ]
+                FormSuccess (CI.mk -> email, mLid) ->
-                FormSuccess (email, Just lid) -> FormSuccess $ \prev -> if
+                  let new = maybe (Left email) Right mLid
-                  | lid `elem` Map.elems prev -> FormFailure [ mr . MsgCourseLecturerAlreadyAdded $ CI.mk email ]
+                  in  FormSuccess $ \prev -> if
-                  | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) lid
+                        | new `elem` Map.elems prev -> FormFailure [ mr $ MsgCourseLecturerAlreadyAdded email ] -- Since there is only ever one email address associated with any user, the case where a @Left email@ corresponds to a @Right lid@ can never occur (at least logically; might still be the same person, of course)
+                        | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new
                 FormFailure errs -> FormFailure errs
                 FormMissing -> FormMissing
               addView'  = toWidget csrf >> fvInput addView >> fvInput btn
           return (addRes'', addView')
 
-        miCell :: ListPosition -> UserId -> Maybe LecturerType -> (Text -> Text) -> Form LecturerType
+        miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
-        miCell _ lid defType nudge = \csrf -> do
+        miCell _ (Right lid) defType nudge = \csrf -> do
-          (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
+          (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
           User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
           let lrwView' = [whamlet|$newline never
                   #{csrf}
                   ^{nameEmailWidget userEmail userDisplayName userSurname} #
                   ^{fvInput lrwView}
                 |]
+          return (Just <$> lrwRes,lrwView')
+        miCell _ (Left lEmail) defType nudge = \csrf -> do
+          (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
+          let lrwView' = [whamlet|
+                           $newline never
+                           #{csrf}
+                           <span style="font-family:monospace">
+                             #{lEmail}
+                            #
+                           <div .tooltip>
+                             <div .tooltip__handle>
+                             <div .tooltip__content>
+                               _{MsgEmailInvitationWarning}
+                            #
+                           ^{fvInput lrwView}
+                         |]
           return (lrwRes,lrwView')
 
         miDelete :: ListLength   -- ^ Current shape
@@ -643,13 +676,22 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
         miAllowAdd _ _ _ = True
 
 
-        lecturerForm :: AForm Handler [(UserId,LecturerType)]
+        lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
-        lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) Map.elems $ massInput
+        lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
                 MassInput{..}
                 (fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical)
                 True
-                (Just . Map.fromList . zip [0..] $ maybe [(uid, CourseLecturer)] cfLecturers template)
+                (Just . Map.fromList . zip [0..] $ maybe [(Right uid, Just CourseLecturer)] (map unliftEither . cfLecturers) template)
                 mempty
+          where
+            liftEither :: (Either UserEmail UserId, Maybe LecturerType) -> Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)
+            liftEither (Right lid  , Just lType) = Right (lid   , lType )
+            liftEither (Left lEmail, mLType    ) = Left  (lEmail, mLType)
+            liftEither _                         = error "liftEither: lecturerForm produced output it should not have been able to"
+
+            unliftEither :: Either (UserEmail, Maybe LecturerType) (UserId, LecturerType) -> (Either UserEmail UserId, Maybe LecturerType)
+            unliftEither (Right (lid   , lType )) = (Right lid  , Just lType)
+            unliftEither (Left  (lEmail, mLType)) = (Left lEmail, mLType    )
 
     (newRegFrom,newRegTo,newDeRegUntil) <- case template of
         (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
@@ -717,7 +759,7 @@ validateCourse CourseForm{..} = do
           ( NTop cfRegFrom <= NTop cfDeRegUntil
           , MsgCourseDeregistrationEndMustBeAfterStart
           )
-        , ( maybe (any ((== uid) . fst) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
+        , ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
           , MsgCourseUserMustBeLecturer
           )
         ] ]
@@ -1039,3 +1081,64 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 -- If they are shared, adjust MsgCourseUserNoteTooltip
 getCNotesR  = error "CNotesR: Not implemented"
 postCNotesR = error "CNotesR: Not implemented"
+
+
+data ButtonLecInvite = BtnLecInvAccept | BtnLecInvDecline
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe ButtonLecInvite
+instance Finite ButtonLecInvite
+
+nullaryPathPiece ''ButtonLecInvite $ camelToPathPiece' 3
+embedRenderMessage ''UniWorX ''ButtonLecInvite id
+
+instance Button UniWorX ButtonLecInvite where
+  btnClasses BtnLecInvAccept = [BCIsButton, BCPrimary]
+  btnClasses BtnLecInvDecline = [BCIsButton, BCDanger]
+
+getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> UserEmail -> Handler Html
+getCLecInviteR = postCLecInviteR
+postCLecInviteR tid ssh csh email = do
+  uid <- requireAuthId
+  (Entity cid Course{..}, Entity liId LecturerInvitation{..}) <- runDB $ do
+    cRes@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
+    iRes <- getBy404 $ UniqueLecturerInvitation email cid
+    return (cRes, iRes)
+
+  ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost $ \csrf -> do
+    (ltRes, ltView) <- case lecturerInvitationType of
+      Nothing -> mreq (selectField optionsFinite) "" Nothing
+      Just lType -> mforced (selectField optionsFinite) "" lType
+    (btnRes, btnWdgt) <- buttonForm mempty
+    return ((,) <$> ltRes <*> btnRes, toWidget csrf <> fvInput ltView <> btnWdgt)
+  mJwt <- askJwt
+
+  let btnWidget = wrapForm btnInnerWidget' def
+        { formEncoding = btnEncoding
+        , formAction = Just . SomeRoute . CourseR tid ssh csh $ CLecInviteR email
+        , formSubmit = FormNoSubmit
+        }
+      btnInnerWidget'
+        = [whamlet|
+            $newline never
+            $maybe jwt <- mJwt
+              <input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}>
+            ^{btnInnerWidget}
+          |]
+
+  formResult btnResult $ \case
+    (lType, BtnLecInvAccept) -> do
+      runDB $ do
+        delete liId
+        insert_ $ Lecturer uid cid lType
+      MsgRenderer mr <- getMsgRenderer
+      addMessageI Success $ MsgLecturerInvitationAccepted (mr lType) csh
+      redirect $ CourseR tid ssh csh CShowR
+    (_, BtnLecInvDecline) -> do
+      runDB $
+        delete liId
+      addMessageI Info $ MsgLecturerInvitationDeclined csh
+      redirect HomeR
+
+  siteLayoutMsg (MsgCourseLecInviteHeading $ CI.original courseName) $ do
+    setTitleI . MsgCourseLecInviteHeading $ CI.original courseName
+    $(widgetFile "courseLecInvite")

src/Import/NoFoundation.hs

@@ -64,6 +64,7 @@ import Ldap.Client.Pool as Import
 import Database.Esqueleto.Instances as Import ()
 import Database.Persist.Sql.Instances as Import ()
 import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
+import Database.Persist.Types.Instances as Import ()
 
 import Numeric.Natural.Instances as Import ()
 import System.Random as Import (Random)

src/Jobs.hs

@@ -59,6 +59,7 @@ import Jobs.Handler.QueueNotification
 import Jobs.Handler.HelpRequest
 import Jobs.Handler.SetLogSettings
 import Jobs.Handler.DistributeCorrections
+import Jobs.Handler.LecturerInvitation
 
   
 data JobQueueException = JInvalid QueuedJobId QueuedJob

src/Jobs/Handler/LecturerInvitation.hs

@@ -0,0 +1,43 @@
+module Jobs.Handler.LecturerInvitation
+  ( dispatchJobLecturerInvitation
+  ) where
+
+import Import
+
+import Text.Hamlet
+
+import qualified Data.HashSet as HashSet
+
+import qualified Data.CaseInsensitive as CI
+
+import Utils.Lens
+
+import Control.Monad.Trans.Maybe
+
+
+dispatchJobLecturerInvitation :: UserId -> LecturerInvitation -> Handler ()
+dispatchJobLecturerInvitation jInviter jLecturerInvitation@LecturerInvitation{..} = do
+  ctx <- runDB . runMaybeT $ do
+    course <- MaybeT $ get lecturerInvitationCourse
+    void . MaybeT $ getByValue jLecturerInvitation
+    user <- MaybeT $ get jInviter
+    return (course, user)
+
+  case ctx of
+    Just (Course{..}, User{..}) -> do
+      let baseRoute = CourseR courseTerm courseSchool courseShorthand $ CLecInviteR lecturerInvitationEmail
+      jwt <- encodeToken =<< bearerToken jInviter (Just $ HashSet.singleton baseRoute) Nothing Nothing Nothing
+      let
+        invitationUrl :: SomeRoute UniWorX
+        invitationUrl = SomeRoute (baseRoute, [(toPathPiece GetBearer, toPathPiece jwt)])
+      invitationUrl' <- toTextUrl invitationUrl
+
+      mailT def $ do
+        _mailTo .= [Address Nothing (CI.original $ lecturerInvitationEmail)]
+        replaceMailHeader "Reply-To" . Just . renderAddress $ Address (Just userDisplayName) (CI.original userEmail)
+        replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+        setSubjectI $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
+      
+        addPart ($(ihamletFile "templates/mail/lecturerInvitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+    Nothing -> runDB .
+      deleteBy $ UniqueLecturerInvitation lecturerInvitationEmail lecturerInvitationCourse

src/Jobs/Types.hs

@@ -23,6 +23,9 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
                           }
          | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
          | JobDistributeCorrections { jSheet :: SheetId }
+         | JobLecturerInvitation { jInviter :: UserId
+                                 , jLecturerInvitation :: LecturerInvitation
+                                 }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationSheetActive { nSheet :: SheetId }

src/Model.hs

@@ -40,5 +40,7 @@ deriving instance Eq (Unique Sheet)
 -- Automatically generated (i.e. numeric) ids are already taken care of
 deriving instance Binary (Key Term)
 
+instance Hashable LecturerInvitation
+
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime

src/Model/Types.hs

@@ -824,6 +824,8 @@ deriveJSON  defaultOptions
   } ''LecturerType
 derivePersistFieldJSON ''LecturerType
 
+instance Hashable LecturerType
+
 
 -- Type synonyms
 

src/Utils/DB.hs

@@ -35,6 +35,12 @@ existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity r
   => Key record -> ReaderT backend m Bool
 existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
 
+updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
+  => Unique record -> [Update record] -> ReaderT backend m ()
+updateBy uniq updates = do
+  key <- getKeyBy uniq
+  for_ key $ flip update updates
+
 myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq  record which is not needed anyway)
     :: (MonadIO m
        ,Eq (Unique record)

templates/courseLecInvite.hamlet

@@ -0,0 +1,3 @@
+<p>
+  _{MsgCourseLecInviteExplanation}
+^{btnWidget}

templates/mail/lecturerInvitation.hamlet

@@ -0,0 +1,11 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+  <body>
+    <p>
+      _{MsgCourseLecInviteExplanation}
+    <p>
+      <a href=#{invitationUrl'}>
+        _{MsgCourseLecturerInvitationAcceptDecline}