Lecturer invitations via e-mail
This commit is contained in:
Gregor Kleen
parent
ec3f816241
commit
ea658f65ce
@ -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.
|
||||
@ -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
|
||||
|
||||
1
routes
1
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
|
||||
|
||||
12
src/Database/Persist/Types/Instances.hs
Normal file
12
src/Database/Persist/Types/Instances.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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}
|
||||
<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 = 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
|
||||
<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")
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
43
src/Jobs/Handler/LecturerInvitation.hs
Normal file
43
src/Jobs/Handler/LecturerInvitation.hs
Normal file
@ -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
|
||||
@ -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 }
|
||||
|
||||
@ -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
|
||||
|
||||
@ -824,6 +824,8 @@ deriveJSON defaultOptions
|
||||
} ''LecturerType
|
||||
derivePersistFieldJSON ''LecturerType
|
||||
|
||||
instance Hashable LecturerType
|
||||
|
||||
|
||||
-- Type synonyms
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
3
templates/courseLecInvite.hamlet
Normal file
3
templates/courseLecInvite.hamlet
Normal file
@ -0,0 +1,3 @@
|
||||
<p>
|
||||
_{MsgCourseLecInviteExplanation}
|
||||
^{btnWidget}
|
||||
11
templates/mail/lecturerInvitation.hamlet
Normal file
11
templates/mail/lecturerInvitation.hamlet
Normal file
@ -0,0 +1,11 @@
|
||||
$newline never
|
||||
\<!doctype html>
|
||||
<html>
|
||||
<head>
|
||||
<meta charset="UTF-8">
|
||||
<body>
|
||||
<p>
|
||||
_{MsgCourseLecInviteExplanation}
|
||||
<p>
|
||||
<a href=#{invitationUrl'}>
|
||||
_{MsgCourseLecturerInvitationAcceptDecline}
|
||||
Loading…
Reference in New Issue
Block a user