From ea658f65ce25ddc85c225e88825698c6906e6b02 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 12 Apr 2019 14:08:55 +0200 Subject: [PATCH] Lecturer invitations via e-mail --- messages/uniworx/de.msg | 14 +- models/courses | 6 + routes | 1 + src/Database/Persist/Types/Instances.hs | 12 ++ src/Foundation.hs | 6 +- src/Handler/Course.hs | 155 +++++++++++++++++++---- src/Import/NoFoundation.hs | 1 + src/Jobs.hs | 1 + src/Jobs/Handler/LecturerInvitation.hs | 43 +++++++ src/Jobs/Types.hs | 3 + src/Model.hs | 2 + src/Model/Types.hs | 2 + src/Utils/DB.hs | 6 + templates/courseLecInvite.hamlet | 3 + templates/mail/lecturerInvitation.hamlet | 11 ++ 15 files changed, 237 insertions(+), 29 deletions(-) create mode 100644 src/Database/Persist/Types/Instances.hs create mode 100644 src/Jobs/Handler/LecturerInvitation.hs create mode 100644 templates/courseLecInvite.hamlet create mode 100644 templates/mail/lecturerInvitation.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index a2b384c03..06715ee26 100644 --- a/messages/uniworx/de.msg +++ b/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 \ No newline at end of file +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. \ No newline at end of file diff --git a/models/courses b/models/courses index 4fcf67d65..45166d7d5 100644 --- a/models/courses +++ b/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 diff --git a/routes b/routes index 6e4a39302..87401b00d 100644 --- a/routes +++ b/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 diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs new file mode 100644 index 000000000..db5957d54 --- /dev/null +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 1eebfd41c..38c2052c9 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 98016ca8e..848faf0e7 100644 --- a/src/Handler/Course.hs +++ b/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 - mbCourse <- getBy (TermSchoolCourseShort tid ssh csh) - mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType] - return $ (,) <$> mbCourse <*> mbLecs + courseData <- runDB $ do + mbCourse <- getBy (TermSchoolCourseShort tid ssh csh) + mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType] + 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 cid Course{..}) lecs = CourseForm +courseToForm :: Entity Course -> [Lecturer] -> [LecturerInvitation] -> 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 (email, Just lid) -> FormSuccess $ \prev -> if - | lid `elem` Map.elems prev -> FormFailure [ mr . MsgCourseLecturerAlreadyAdded $ CI.mk email ] - | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) lid + FormSuccess (CI.mk -> email, mLid) -> + let new = maybe (Left email) Right mLid + in FormSuccess $ \prev -> if + | 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 _ lid defType nudge = \csrf -> do - (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType + miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType) + miCell _ (Right lid) defType nudge = \csrf -> do + (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} + + #{lEmail} + # +
+
+
+ _{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 = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) Map.elems $ massInput + lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] + 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 + + ^{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") diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index fd37d73bc..cae93d5f8 100644 --- a/src/Import/NoFoundation.hs +++ b/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) diff --git a/src/Jobs.hs b/src/Jobs.hs index 04df2686c..9b06c3a1c 100644 --- a/src/Jobs.hs +++ b/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 diff --git a/src/Jobs/Handler/LecturerInvitation.hs b/src/Jobs/Handler/LecturerInvitation.hs new file mode 100644 index 000000000..098ccbb61 --- /dev/null +++ b/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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index dc29a9e7a..42ce48824 100644 --- a/src/Jobs/Types.hs +++ b/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 } diff --git a/src/Model.hs b/src/Model.hs index 9210edfde..1b16cd35e 100644 --- a/src/Model.hs +++ b/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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 21672d9d2..00bda42a1 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -824,6 +824,8 @@ deriveJSON defaultOptions } ''LecturerType derivePersistFieldJSON ''LecturerType +instance Hashable LecturerType + -- Type synonyms diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index cb8b80d4e..9700dd88f 100644 --- a/src/Utils/DB.hs +++ b/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) diff --git a/templates/courseLecInvite.hamlet b/templates/courseLecInvite.hamlet new file mode 100644 index 000000000..408556fb7 --- /dev/null +++ b/templates/courseLecInvite.hamlet @@ -0,0 +1,3 @@ +

+ _{MsgCourseLecInviteExplanation} +^{btnWidget} diff --git a/templates/mail/lecturerInvitation.hamlet b/templates/mail/lecturerInvitation.hamlet new file mode 100644 index 000000000..9de17cc39 --- /dev/null +++ b/templates/mail/lecturerInvitation.hamlet @@ -0,0 +1,11 @@ +$newline never +\ + + + + +

+ _{MsgCourseLecInviteExplanation} +

+ + _{MsgCourseLecturerInvitationAcceptDecline}