Merge branch 'feat/generic-invitations' into 'master'
Feat/generic invitations See merge request !188
This commit is contained in:
Gregor Kleen
commit
2e6c701fe0
@ -580,6 +580,8 @@ InvitationAcceptDecline: Einladung annehmen/ablehnen
|
||||
|
||||
MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für #{shn}
|
||||
|
||||
MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn}
|
||||
|
||||
SheetGrading: Bewertung
|
||||
SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
|
||||
SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
|
||||
@ -852,6 +854,20 @@ CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor f
|
||||
SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn}
|
||||
SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein.
|
||||
|
||||
TutorInvitationAccepted tutn@TutorialName: Sie wurden als Tutor für #{tutn} eingetragen
|
||||
TutorInvitationDeclined tutn@TutorialName: Sie haben die Einladung, Tutor für #{tutn} zu werden, abgelehnt
|
||||
TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn}
|
||||
TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein.
|
||||
|
||||
InvitationAction: Aktion
|
||||
InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden
|
||||
InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten
|
||||
InvitationCollision: Einladung konnte nicht angenommen werden da ein derartiger Eintrag bereits existiert
|
||||
InvitationDeclined: Einladung wurde abgelehnt
|
||||
BtnInviteAccept: Einladung annehmen
|
||||
BtnInviteDecline: Einladung ablehnen
|
||||
|
||||
LecturerType: Rolle
|
||||
ScheduleKindWeekly: Wöchentlich
|
||||
|
||||
ScheduleRegular: Planmäßiger Termin
|
||||
@ -922,4 +938,4 @@ HealthMatchingClusterConfig: Cluster-geteilte Konfiguration ist aktuell
|
||||
HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werden
|
||||
HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden werden können
|
||||
HealthSMTPConnect: SMTP-Server kann erreicht werden
|
||||
HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
|
||||
HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
|
||||
|
||||
@ -35,12 +35,6 @@ 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
|
||||
|
||||
5
models/invitations
Normal file
5
models/invitations
Normal file
@ -0,0 +1,5 @@
|
||||
Invitation
|
||||
email UserEmail
|
||||
for Value
|
||||
data Value
|
||||
UniqueInvitation email for
|
||||
@ -35,13 +35,6 @@ SheetCorrector -- grant corrector role to user for a sheet
|
||||
state CorrectorState default='CorrectorNormal' -- whether a corrector is assigned his load this time (e.g. in case of sickness)
|
||||
UniqueSheetCorrector user sheet
|
||||
deriving Show Eq Ord
|
||||
SheetCorrectorInvitation json
|
||||
email UserEmail
|
||||
sheet SheetId
|
||||
load Load
|
||||
state CorrectorState
|
||||
UniqueSheetCorrectorInvitation email sheet
|
||||
deriving Show Read Eq Ord Generic Typeable
|
||||
SheetFile -- a file that is part of an exercise sheet
|
||||
sheet SheetId
|
||||
file FileId
|
||||
|
||||
@ -177,12 +177,14 @@ default-extensions:
|
||||
- PackageImports
|
||||
- TypeApplications
|
||||
- RecursiveDo
|
||||
- TypeFamilyDependencies
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -fno-warn-type-defaults
|
||||
- -fno-warn-unrecognised-pragmas
|
||||
- -fno-warn-partial-type-signatures
|
||||
- -fno-max-relevant-binds
|
||||
|
||||
when:
|
||||
- condition: flag(pedantic)
|
||||
|
||||
5
routes
5
routes
@ -82,7 +82,7 @@
|
||||
/ CShowR GET !free
|
||||
/register CRegisterR GET POST !timeANDcapacity
|
||||
/edit CEditR GET POST
|
||||
/lecturer-invite/#UserEmail CLecInviteR GET POST
|
||||
/lecturer-invite CLecInviteR GET POST
|
||||
/delete CDeleteR GET POST !lecturerANDempty
|
||||
/users CUsersR GET POST
|
||||
/users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant
|
||||
@ -110,7 +110,7 @@
|
||||
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
|
||||
/correctors SCorrR GET POST
|
||||
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
|
||||
/corrector-invite/#UserEmail SCorrInviteR GET POST
|
||||
/corrector-invite/ SCorrInviteR GET POST
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector
|
||||
/file MaterialListR GET !course-registered !materials !corrector !tutor
|
||||
/file/new MaterialNewR GET POST
|
||||
@ -127,6 +127,7 @@
|
||||
/participants TUsersR GET POST !tutor
|
||||
/register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered
|
||||
/communication TCommR GET POST !tutor
|
||||
/tutor-invite TInviteR GET POST
|
||||
|
||||
|
||||
/subs CorrectionsR GET POST !corrector !lecturer
|
||||
|
||||
@ -16,6 +16,7 @@ import Handler.Utils.Delete
|
||||
import Handler.Utils.Database
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Table.Columns
|
||||
import Handler.Utils.Invitations
|
||||
import Database.Persist.Sql (deleteWhereCount)
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
@ -36,6 +37,11 @@ import Text.Blaze.Html.Renderer.Text (renderHtml)
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
|
||||
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
|
||||
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
|
||||
|
||||
@ -542,7 +548,7 @@ pgCEditR tid ssh csh = do
|
||||
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]
|
||||
mbLecInvites <- for mbCourse $ sourceInvitationsList . entityKey
|
||||
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.
|
||||
@ -590,12 +596,10 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
, courseDeregisterUntil = cfDeRegUntil res
|
||||
}
|
||||
whenIsJust insertOkay $ \cid -> do
|
||||
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
|
||||
let (invites, adds) = partitionEithers $ cfLecturers res
|
||||
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
|
||||
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
|
||||
insert_ $ CourseEdit aid now cid
|
||||
return insertOkay
|
||||
case insertOkay of
|
||||
Just _ -> do
|
||||
@ -635,16 +639,11 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
|
||||
Nothing -> do
|
||||
deleteWhere [LecturerCourse ==. cid]
|
||||
deleteWhere [LecturerInvitationCourse ==. cid, LecturerInvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
|
||||
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 ]
|
||||
deleteWhere [InvitationFor ==. invRef @Lecturer cid, InvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
|
||||
let (invites, adds) = partitionEithers $ cfLecturers res
|
||||
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
|
||||
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
|
||||
|
||||
insert_ $ CourseEdit aid now cid
|
||||
addMessageI Success $ MsgCourseEditOk tid ssh csh
|
||||
return True
|
||||
@ -658,6 +657,65 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
}
|
||||
|
||||
|
||||
instance IsInvitableJunction Lecturer where
|
||||
type InvitationFor Lecturer = Course
|
||||
data InvitableJunction Lecturer = JunctionLecturer
|
||||
{ jLecturerType :: LecturerType
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData Lecturer = InvDBDataLecturer
|
||||
{ invDBLecturerType :: Maybe LecturerType
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationTokenData Lecturer = InvTokenDataLecturer
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
_InvitableJunction = iso
|
||||
(\Lecturer{..} -> (lecturerUser, lecturerCourse, JunctionLecturer lecturerType))
|
||||
(\(lecturerUser, lecturerCourse, JunctionLecturer lecturerType) -> Lecturer{..})
|
||||
|
||||
instance ToJSON (InvitableJunction Lecturer) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
instance FromJSON (InvitableJunction Lecturer) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
|
||||
instance ToJSON (InvitationDBData Lecturer) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationDBData Lecturer) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
|
||||
instance ToJSON (InvitationTokenData Lecturer) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationTokenData Lecturer) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
|
||||
lecturerInvitationConfig :: InvitationConfig Lecturer
|
||||
lecturerInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute Course{..} _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
|
||||
invitationResolveFor = do
|
||||
Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
|
||||
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
||||
invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
|
||||
invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ (InvDBDataLecturer mlType, _) = hoistAForm liftHandlerT $ toJunction <$> case mlType of
|
||||
Nothing -> areq (selectField optionsFinite) lFs Nothing
|
||||
Just lType -> aforced (selectField optionsFinite) lFs lType
|
||||
where
|
||||
toJunction jLecturerType = JunctionLecturer{..}
|
||||
lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical
|
||||
invitationSuccessMsg Course{..} (Entity _ Lecturer{..}) = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand
|
||||
invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
|
||||
|
||||
data CourseForm = CourseForm
|
||||
{ cfCourseId :: Maybe CourseId
|
||||
, cfName :: CourseName
|
||||
@ -675,7 +733,7 @@ data CourseForm = CourseForm
|
||||
, cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
|
||||
}
|
||||
|
||||
courseToForm :: Entity Course -> [Lecturer] -> [LecturerInvitation] -> CourseForm
|
||||
courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> CourseForm
|
||||
courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
|
||||
{ cfCourseId = Just cid
|
||||
, cfName = courseName
|
||||
@ -691,7 +749,7 @@ courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
|
||||
, cfRegTo = courseRegisterTo
|
||||
, cfDeRegUntil = courseDeregisterUntil
|
||||
, cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
|
||||
++ [Left (lecturerInvitationEmail, lecturerInvitationType) | LecturerInvitation{..} <- lecInvites ]
|
||||
++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ]
|
||||
}
|
||||
|
||||
makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
|
||||
@ -1297,55 +1355,7 @@ postCCommR tid ssh csh = do
|
||||
evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
|
||||
}
|
||||
|
||||
|
||||
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 :: TermId -> SchoolId -> CourseShorthand -> 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 . formEmbedJwtPost $ \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)
|
||||
|
||||
let btnWidget = wrapForm btnInnerWidget def
|
||||
{ formEncoding = btnEncoding
|
||||
, formAction = Just . SomeRoute . CourseR tid ssh csh $ CLecInviteR email
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
|
||||
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")
|
||||
postCLecInviteR = invitationR lecturerInvitationConfig
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Sheet where
|
||||
|
||||
import Import
|
||||
@ -13,6 +15,7 @@ import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.SheetType
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
-- import Data.Time
|
||||
-- import qualified Data.Text as T
|
||||
@ -54,6 +57,9 @@ import Utils.Lens
|
||||
import Control.Monad.Random.Class (MonadRandom(..))
|
||||
import Utils.Sql
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
|
||||
{-
|
||||
* Implement Handlers
|
||||
@ -624,7 +630,7 @@ defaultLoads shid = do
|
||||
toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load)
|
||||
|
||||
|
||||
correctorForm :: SheetId -> AForm Handler (Set (Either SheetCorrectorInvitation SheetCorrector))
|
||||
correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector))
|
||||
correctorForm shid = wFormToAForm $ do
|
||||
Just currentRoute <- liftHandlerT getCurrentRoute
|
||||
userId <- liftHandlerT requireAuthId
|
||||
@ -634,7 +640,7 @@ correctorForm shid = wFormToAForm $ do
|
||||
currentLoads :: DB Loads
|
||||
currentLoads = Map.union
|
||||
<$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] [])
|
||||
<*> fmap (foldMap $ \(Entity _ SheetCorrectorInvitation{..}) -> Map.singleton (Left sheetCorrectorInvitationEmail) (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) (selectList [ SheetCorrectorInvitationSheet ==. shid ] [])
|
||||
<*> fmap (foldMap $ \(email, InvDBDataSheetCorrector load state) -> Map.singleton (Left email) (state, load)) (sourceInvitationsList shid)
|
||||
(defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads
|
||||
|
||||
isWrite <- liftHandlerT $ isWriteRequest currentRoute
|
||||
@ -733,22 +739,20 @@ correctorForm shid = wFormToAForm $ do
|
||||
miIdent :: Text
|
||||
miIdent = "correctors"
|
||||
|
||||
postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either SheetCorrectorInvitation SheetCorrector)
|
||||
postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either (Invitation' SheetCorrector) SheetCorrector)
|
||||
postProcess = Set.fromList . map postProcess' . Map.elems
|
||||
where
|
||||
sheetCorrectorSheet = shid
|
||||
sheetCorrectorInvitationSheet = shid
|
||||
|
||||
postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either SheetCorrectorInvitation SheetCorrector
|
||||
postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector
|
||||
postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
|
||||
postProcess' (Left sheetCorrectorInvitationEmail, (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) = Left SheetCorrectorInvitation{..}
|
||||
postProcess' (Left email, (state, load)) = Left (email, shid, (InvDBDataSheetCorrector load state, InvTokenDataSheetCorrector))
|
||||
|
||||
fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) True (Just . Map.fromList . zip [0..] $ Map.toList loads)
|
||||
|
||||
getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
postSCorrR = getSCorrR
|
||||
getSCorrR tid ssh csh shn = do
|
||||
uid <- requireAuthId
|
||||
Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
|
||||
|
||||
((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $
|
||||
@ -759,17 +763,15 @@ getSCorrR tid ssh csh shn = do
|
||||
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
||||
FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do
|
||||
update shid [ SheetAutoDistribute =. autoDistribute ]
|
||||
|
||||
let (invites, adds) = partitionEithers $ Set.toList sheetCorrectors
|
||||
|
||||
deleteWhere [ SheetCorrectorSheet ==. shid ]
|
||||
deleteWhere [ SheetCorrectorInvitationSheet ==. shid, SheetCorrectorInvitationEmail /<-. toListOf (folded . _Left . _sheetCorrectorInvitationEmail) sheetCorrectors ]
|
||||
forM_ sheetCorrectors $ \case
|
||||
Right shCor -> insert_ shCor
|
||||
Left shCorInv -> do
|
||||
insertRes <- insertBy shCorInv
|
||||
case insertRes of
|
||||
Right _ ->
|
||||
void . queueDBJob $ JobCorrectorInvitation uid shCorInv
|
||||
Left (Entity old _) ->
|
||||
replace old shCorInv
|
||||
insertMany_ adds
|
||||
|
||||
deleteWhere [InvitationFor ==. invRef @SheetCorrector shid, InvitationEmail /<-. toListOf (folded . _1) invites]
|
||||
sinkInvitationsF correctorInvitationConfig invites
|
||||
|
||||
addMessageI Success MsgCorrectorsUpdated
|
||||
FormMissing -> return ()
|
||||
|
||||
@ -781,48 +783,65 @@ getSCorrR tid ssh csh shn = do
|
||||
}
|
||||
|
||||
|
||||
data ButtonCorrInvite = BtnCorrInvAccept | BtnCorrInvDecline
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Universe ButtonCorrInvite
|
||||
instance Finite ButtonCorrInvite
|
||||
instance IsInvitableJunction SheetCorrector where
|
||||
type InvitationFor SheetCorrector = Sheet
|
||||
data InvitableJunction SheetCorrector = JunctionSheetCorrector
|
||||
{ jSheetCorrectorLoad :: Load
|
||||
, jSheetCorrectorState :: CorrectorState
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData SheetCorrector = InvDBDataSheetCorrector
|
||||
{ invDBSheetCorrectorLoad :: Load
|
||||
, invDBSheetCorrectorState :: CorrectorState
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationTokenData SheetCorrector = InvTokenDataSheetCorrector
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
nullaryPathPiece ''ButtonCorrInvite $ camelToPathPiece' 3
|
||||
embedRenderMessage ''UniWorX ''ButtonCorrInvite id
|
||||
_InvitableJunction = iso
|
||||
(\SheetCorrector{..} -> (sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState))
|
||||
(\(sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState) -> SheetCorrector{..})
|
||||
|
||||
instance Button UniWorX ButtonCorrInvite where
|
||||
btnClasses BtnCorrInvAccept = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnCorrInvDecline = [BCIsButton, BCDanger]
|
||||
instance ToJSON (InvitableJunction SheetCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
instance FromJSON (InvitableJunction SheetCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
|
||||
getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> UserEmail -> Handler Html
|
||||
instance ToJSON (InvitationDBData SheetCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationDBData SheetCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
|
||||
instance ToJSON (InvitationTokenData SheetCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationTokenData SheetCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
|
||||
correctorInvitationConfig :: InvitationConfig SheetCorrector
|
||||
correctorInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute Sheet{..} _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
|
||||
invitationResolveFor = do
|
||||
Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute
|
||||
fetchSheetId tid csh ssh shn
|
||||
invitationSubject Sheet{..} _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
|
||||
invitationHeading Sheet{..} _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ (InvDBDataSheetCorrector load state, _) = pure $ JunctionSheetCorrector load state
|
||||
invitationSuccessMsg Sheet{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
|
||||
invitationUltDest Sheet{..} _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
return . SomeRoute $ CSheetR courseTerm courseSchool courseShorthand sheetName SShowR
|
||||
|
||||
getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSCorrInviteR = postSCorrInviteR
|
||||
postSCorrInviteR tid ssh csh shn email = do
|
||||
uid <- requireAuthId
|
||||
(Entity _ Course{..}, Entity shid Sheet{..}, Entity ciId SheetCorrectorInvitation{..}) <- runDB $ do
|
||||
(sRes@(Entity shid _), cRes) <- fetchSheetCourse tid ssh csh shn
|
||||
iRes <- getBy404 $ UniqueSheetCorrectorInvitation email shid
|
||||
return (cRes, sRes, iRes)
|
||||
|
||||
((btnResult, btnInnerWidget), btnEncoding) <- runFormPost $ formEmbedJwtPost buttonForm
|
||||
|
||||
let btnWidget = wrapForm btnInnerWidget def
|
||||
{ formEncoding = btnEncoding
|
||||
, formAction = Just . SomeRoute . CSheetR tid ssh csh shn $ SCorrInviteR email
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
|
||||
formResult btnResult $ \case
|
||||
BtnCorrInvAccept -> do
|
||||
runDB $ do
|
||||
delete ciId
|
||||
insert_ $ SheetCorrector uid shid sheetCorrectorInvitationLoad sheetCorrectorInvitationState
|
||||
addMessageI Success $ MsgCorrectorInvitationAccepted shn
|
||||
redirect $ CSheetR tid ssh csh shn SShowR
|
||||
BtnCorrInvDecline -> do
|
||||
runDB $
|
||||
delete ciId
|
||||
addMessageI Info $ MsgCorrectorInvitationDeclined shn
|
||||
redirect HomeR
|
||||
|
||||
siteLayoutMsg (MsgSheetCorrInviteHeading shn) $ do
|
||||
setTitleI $ MsgSheetCorrInviteHeading shn
|
||||
$(widgetFile "sheetCorrInvite")
|
||||
postSCorrInviteR = invitationR correctorInvitationConfig
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Tutorial where
|
||||
|
||||
import Import
|
||||
@ -8,6 +10,8 @@ import Handler.Utils.Delete
|
||||
import Handler.Utils.Communication
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Handler.Utils.Form.Occurences
|
||||
import Handler.Utils.Invitations
|
||||
import Jobs.Queue
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
@ -22,6 +26,9 @@ import qualified Data.Text as Text
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
{-# ANN module ("Hlint: ignore Redundant void" :: String) #-}
|
||||
|
||||
|
||||
@ -193,6 +200,66 @@ postTCommR tid ssh csh tutn = do
|
||||
}
|
||||
|
||||
|
||||
instance IsInvitableJunction Tutor where
|
||||
type InvitationFor Tutor = Tutorial
|
||||
data InvitableJunction Tutor = JunctionTutor
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData Tutor = InvDBDataTutor
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationTokenData Tutor = InvTokenDataTutor
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
_InvitableJunction = iso
|
||||
(\Tutor{..} -> (tutorUser, tutorTutorial, JunctionTutor))
|
||||
(\(tutorUser, tutorTutorial, JunctionTutor) -> Tutor{..})
|
||||
|
||||
instance ToJSON (InvitableJunction Tutor) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
instance FromJSON (InvitableJunction Tutor) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
|
||||
instance ToJSON (InvitationDBData Tutor) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationDBData Tutor) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
|
||||
instance ToJSON (InvitationTokenData Tutor) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationTokenData Tutor) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
|
||||
tutorInvitationConfig :: InvitationConfig Tutor
|
||||
tutorInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute Tutorial{..} _ = do
|
||||
Course{..} <- get404 tutorialCourse
|
||||
return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR
|
||||
invitationResolveFor = do
|
||||
Just (CTutorialR tid csh ssh tutn TInviteR) <- getCurrentRoute
|
||||
fetchTutorialId tid csh ssh tutn
|
||||
invitationSubject Tutorial{..} _ = do
|
||||
Course{..} <- get404 tutorialCourse
|
||||
return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName
|
||||
invitationHeading Tutorial{..} _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ = pure JunctionTutor
|
||||
invitationSuccessMsg Tutorial{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
|
||||
invitationUltDest Tutorial{..} _ = do
|
||||
Course{..} <- get404 tutorialCourse
|
||||
return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR
|
||||
|
||||
getTInviteR, postTInviteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
|
||||
getTInviteR = postTInviteR
|
||||
postTInviteR = invitationR tutorInvitationConfig
|
||||
|
||||
|
||||
data TutorialForm = TutorialForm
|
||||
{ tfName :: TutorialName
|
||||
, tfType :: CI Text
|
||||
@ -203,7 +270,7 @@ data TutorialForm = TutorialForm
|
||||
, tfRegisterFrom :: Maybe UTCTime
|
||||
, tfRegisterTo :: Maybe UTCTime
|
||||
, tfDeregisterUntil :: Maybe UTCTime
|
||||
, tfTutors :: Set UserId -- awaiting feat/generic-invitations
|
||||
, tfTutors :: Set (Either UserEmail UserId)
|
||||
}
|
||||
|
||||
tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm
|
||||
@ -215,29 +282,29 @@ tutorialForm cid template html = do
|
||||
let
|
||||
tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template)
|
||||
where
|
||||
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([UserId] -> FormResult [UserId])
|
||||
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
|
||||
miAdd' nudge submitView csrf = do
|
||||
(addRes, addView) <- mpreq (multiUserField False . Just $ tutUserSuggestions uid) ("" & addName (nudge "email")) Nothing
|
||||
let
|
||||
addRes'
|
||||
| unresolved <- toListOf (_FormSuccess . folded . _Left) addRes
|
||||
, (fUnresolved : _) <- unresolved
|
||||
= FormFailure [mr $ MsgEMailUnknown fUnresolved]
|
||||
| otherwise
|
||||
= addRes <&> \newDat oldDat -> if
|
||||
| (_ : _) <- Set.toList $ setOf (folded . _Right) newDat `Set.intersection` Set.fromList oldDat
|
||||
| existing <- newDat `Set.intersection` Set.fromList oldDat
|
||||
, not $ Set.null existing
|
||||
-> FormFailure [mr MsgTutorialTutorAlreadyAdded]
|
||||
| otherwise
|
||||
-> FormSuccess $ toListOf (folded . _Right) newDat
|
||||
-> FormSuccess $ Set.toList newDat
|
||||
return (addRes', $(widgetFile "tutorial/tutorMassInput/add"))
|
||||
|
||||
|
||||
miCell' :: UserId -> Widget
|
||||
miCell' userId = do
|
||||
miCell' :: Either UserEmail UserId -> Widget
|
||||
miCell' (Left email) =
|
||||
$(widgetFile "tutorial/tutorMassInput/cellInvitation")
|
||||
miCell' (Right userId) = do
|
||||
User{..} <- liftHandlerT . runDB $ get404 userId
|
||||
$(widgetFile "tutorial/tutorMassInput/cellKnown")
|
||||
|
||||
miLayout' :: MassInputLayout ListLength UserId ()
|
||||
miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
|
||||
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "tutorial/tutorMassInput/layout")
|
||||
|
||||
flip (renderAForm FormStandard) html $ TutorialForm
|
||||
@ -282,7 +349,7 @@ postCTutorialNewR tid ssh csh = do
|
||||
((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing
|
||||
|
||||
formResult newTutResult $ \TutorialForm{..} -> do
|
||||
insertRes <- runDB $ do
|
||||
insertRes <- runDBJobs $ do
|
||||
now <- liftIO getCurrentTime
|
||||
insertRes <- insertUnique Tutorial
|
||||
{ tutorialName = tfName
|
||||
@ -297,9 +364,10 @@ postCTutorialNewR tid ssh csh = do
|
||||
, tutorialDeregisterUntil = tfDeregisterUntil
|
||||
, tutorialLastChanged = now
|
||||
}
|
||||
forM_ tfTutors $ \tutor -> case insertRes of
|
||||
Just tutid -> void . insert $ Tutor tutid tutor
|
||||
_other -> return ()
|
||||
whenIsJust insertRes $ \tutid -> do
|
||||
let (invites, adds) = partitionEithers $ Set.toList tfTutors
|
||||
insertMany_ $ map (Tutor tutid) adds
|
||||
sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites
|
||||
return insertRes
|
||||
case insertRes of
|
||||
Nothing -> addMessageI Error $ MsgTutorialNameTaken tfName
|
||||
@ -329,6 +397,8 @@ postTEditR tid ssh csh tutn = do
|
||||
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
||||
return $ tutor E.^. TutorUser
|
||||
|
||||
tutorInvites <- sourceInvitationsList tutid
|
||||
|
||||
let
|
||||
template = TutorialForm
|
||||
{ tfName = tutorialName
|
||||
@ -340,7 +410,8 @@ postTEditR tid ssh csh tutn = do
|
||||
, tfRegisterFrom = tutorialRegisterFrom
|
||||
, tfRegisterTo = tutorialRegisterTo
|
||||
, tfDeregisterUntil = tutorialDeregisterUntil
|
||||
, tfTutors = Set.fromList tutorIds
|
||||
, tfTutors = Set.fromList (map Right tutorIds)
|
||||
<> Set.fromList (map (\(email, InvDBDataTutor) -> Left email) tutorInvites)
|
||||
}
|
||||
|
||||
return (cid, tutid, template)
|
||||
@ -348,7 +419,7 @@ postTEditR tid ssh csh tutn = do
|
||||
((newTutResult, newTutWidget), newTutEnctype) <- runFormPost . tutorialForm cid $ Just template
|
||||
|
||||
formResult newTutResult $ \TutorialForm{..} -> do
|
||||
insertRes <- runDB $ do
|
||||
insertRes <- runDBJobs $ do
|
||||
now <- liftIO getCurrentTime
|
||||
insertRes <- myReplaceUnique tutid Tutorial
|
||||
{ tutorialName = tfName
|
||||
@ -363,8 +434,14 @@ postTEditR tid ssh csh tutn = do
|
||||
, tutorialDeregisterUntil = tfDeregisterUntil
|
||||
, tutorialLastChanged = now
|
||||
}
|
||||
deleteWhere [ TutorTutorial ==. tutid ]
|
||||
forM_ tfTutors $ void . insert . Tutor tutid
|
||||
when (is _Nothing insertRes) $ do
|
||||
let (invites, adds) = partitionEithers $ Set.toList tfTutors
|
||||
|
||||
deleteWhere [ TutorTutorial ==. tutid ]
|
||||
insertMany_ $ map (Tutor tutid) adds
|
||||
|
||||
deleteWhere [ InvitationFor ==. invRef @Tutor tutid, InvitationEmail /<-. invites ]
|
||||
sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites
|
||||
return insertRes
|
||||
case insertRes of
|
||||
Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName
|
||||
|
||||
359
src/Handler/Utils/Invitations.hs
Normal file
359
src/Handler/Utils/Invitations.hs
Normal file
@ -0,0 +1,359 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
|
||||
module Handler.Utils.Invitations
|
||||
( -- * Procedure
|
||||
--
|
||||
-- $procedure
|
||||
IsInvitableJunction(..)
|
||||
, Invitation'
|
||||
, _invitationDBData, _invitationTokenData
|
||||
, InvitationReference(..), invRef
|
||||
, InvitationConfig(..), InvitationTokenConfig(..)
|
||||
, sourceInvitations, sourceInvitationsList
|
||||
, sinkInvitations, sinkInvitationsF
|
||||
, invitationR', InvitationR(..)
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Jobs.Queue
|
||||
|
||||
import Handler.Utils.Tokens
|
||||
|
||||
import Text.Hamlet
|
||||
|
||||
import Control.Monad.Trans.Reader (mapReaderT)
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
import Data.Aeson (fromJSON)
|
||||
import qualified Data.Aeson as JSON
|
||||
import Data.Aeson.TH
|
||||
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Data.Typeable
|
||||
|
||||
|
||||
class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
|
||||
, ToJSON (InvitationDBData junction), ToJSON (InvitationTokenData junction)
|
||||
, FromJSON (InvitationDBData junction), FromJSON (InvitationTokenData junction)
|
||||
, PersistRecordBackend (InvitationFor junction) (YesodPersistBackend UniWorX)
|
||||
, Typeable junction
|
||||
) => IsInvitableJunction junction where
|
||||
-- | One side of the junction is always `User`; `InvitationFor junction` is the other
|
||||
type InvitationFor junction :: *
|
||||
-- | `junction` without `Key User` and `Key (InvitationFor junction)`
|
||||
data InvitableJunction junction :: *
|
||||
|
||||
-- | `InvitationData` is all data associated with an invitation except for the `UserEmail` and `InvitationFor junction`
|
||||
--
|
||||
-- Note that this is only the data associated with the invitation; some user input might still be required to construct `InvitableJunction junction`
|
||||
type InvitationData junction = (dat :: *) | dat -> junction
|
||||
type InvitationData junction = (InvitationDBData junction, InvitationTokenData junction)
|
||||
-- | `InvitationDBData` is the part of `InvitationData` that is stored confidentially in the database
|
||||
data InvitationDBData junction :: *
|
||||
-- | `InvitationTokenData` is the part of `InvitationData` that is stored readably within the token
|
||||
data InvitationTokenData junction :: *
|
||||
|
||||
_InvitableJunction :: Iso' junction (UserId, Key (InvitationFor junction), InvitableJunction junction)
|
||||
|
||||
_InvitationData :: Iso' (InvitationData junction) (InvitationDBData junction, InvitationTokenData junction)
|
||||
default _InvitationData :: InvitationData junction ~ (InvitationDBData junction, InvitationTokenData junction)
|
||||
=> Iso' (InvitationData junction) (InvitationDBData junction, InvitationTokenData junction)
|
||||
_InvitationData = id
|
||||
|
||||
-- | If `ephemeralInvitation` is not `Nothing` pending invitations are not stored in the database
|
||||
--
|
||||
-- In this case no invitation data can be stored in the database (@InvitationDBData junction ~ ()@)
|
||||
ephemeralInvitation :: Maybe (AnIso' () (InvitationDBData junction))
|
||||
ephemeralInvitation = Nothing
|
||||
|
||||
{-# MINIMAL _InvitableJunction #-}
|
||||
|
||||
_invitationDBData :: IsInvitableJunction junction => Lens' (InvitationData junction) (InvitationDBData junction)
|
||||
_invitationDBData = _InvitationData . _1
|
||||
_invitationTokenData :: IsInvitableJunction junction => Lens' (InvitationData junction) (InvitationTokenData junction)
|
||||
_invitationTokenData = _InvitationData . _2
|
||||
|
||||
|
||||
type Invitation' junction = (UserEmail, Key (InvitationFor junction), InvitationData junction)
|
||||
|
||||
|
||||
data InvitationReference junction = IsInvitableJunction junction => InvRef (Key (InvitationFor junction))
|
||||
|
||||
deriving instance Eq (InvitationReference junction)
|
||||
deriving instance Ord (InvitationReference junction)
|
||||
deriving instance IsInvitableJunction junction => Read (InvitationReference junction)
|
||||
deriving instance Show (InvitationReference junction)
|
||||
|
||||
instance ToJSON (InvitationReference junction) where
|
||||
toJSON (InvRef fId) = JSON.object
|
||||
[ "junction" JSON..= show (typeRep (Proxy @junction))
|
||||
, "record" JSON..= fId
|
||||
]
|
||||
instance IsInvitableJunction junction => FromJSON (InvitationReference junction) where
|
||||
parseJSON = JSON.withObject "InvitationReference" $ \o -> do
|
||||
table <- o JSON..: "junction"
|
||||
key <- o JSON..: "record"
|
||||
|
||||
unless (table == show (typeRep (Proxy @junction))) $
|
||||
fail "Unexpected table"
|
||||
|
||||
return $ InvRef key
|
||||
|
||||
invRef :: forall junction. IsInvitableJunction junction => Key (InvitationFor junction) -> JSON.Value
|
||||
invRef = toJSON . InvRef @junction
|
||||
|
||||
|
||||
-- | Configuration needed for creating and accepting/declining `Invitation`s
|
||||
--
|
||||
-- It is advisable to define this once per `junction` in a global constant
|
||||
data InvitationConfig junction = InvitationConfig
|
||||
{ invitationRoute :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (Route UniWorX)
|
||||
-- ^ Which route calls `invitationR` for this kind of invitation?
|
||||
, invitationResolveFor :: YesodDB UniWorX (Key (InvitationFor junction))
|
||||
-- ^ Monadically resolve `InvitationFor` during `inviteR`
|
||||
--
|
||||
-- Usually from `requireBearerToken` or `getCurrentRoute`
|
||||
, invitationSubject :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX)
|
||||
-- ^ Subject of the e-mail which sends the token to the user
|
||||
, invitationHeading :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (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)
|
||||
-- ^ 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
|
||||
-- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently)
|
||||
, invitationRestriction :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX AuthResult
|
||||
-- ^ Additional restrictions to check before allowing an user to redeem an invitation token
|
||||
, invitationForm :: InvitationFor junction -> InvitationData junction -> AForm (YesodDB UniWorX) (InvitableJunction junction)
|
||||
-- ^ Assimilate the additional data entered by the redeeming user
|
||||
, invitationSuccessMsg :: InvitationFor junction -> Entity junction -> YesodDB UniWorX (SomeMessage UniWorX)
|
||||
-- ^ What to tell the redeeming user after accepting the invitation
|
||||
, invitationUltDest :: InvitationFor junction -> Entity junction -> YesodDB UniWorX (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
|
||||
{ itAuthority :: UserId
|
||||
, itAddAuth :: Maybe AuthDNF
|
||||
, itExpiresAt :: Maybe (Maybe UTCTime)
|
||||
, itStartsAt :: Maybe UTCTime
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
data InvitationTokenRestriction junction = IsInvitableJunction junction => InvitationTokenRestriction
|
||||
{ itEmail :: UserEmail
|
||||
, itData :: InvitationTokenData junction
|
||||
}
|
||||
deriving instance Eq (InvitationTokenData junction) => Eq (InvitationTokenRestriction junction)
|
||||
deriving instance Ord (InvitationTokenData junction) => Ord (InvitationTokenRestriction junction)
|
||||
deriving instance (Read (InvitationTokenData junction), IsInvitableJunction junction) => Read (InvitationTokenRestriction junction)
|
||||
deriving instance Show (InvitationTokenData junction) => Show (InvitationTokenRestriction junction)
|
||||
|
||||
$(return [])
|
||||
|
||||
instance ToJSON (InvitationTokenRestriction junction) where
|
||||
toJSON = $(mkToJSON defaultOptions{ fieldLabelModifier = camelToPathPiece' 1 } ''InvitationTokenRestriction)
|
||||
|
||||
instance IsInvitableJunction junction => FromJSON (InvitationTokenRestriction junction) where
|
||||
parseJSON = $(mkParseJSON defaultOptions{ fieldLabelModifier = camelToPathPiece' 1 } ''InvitationTokenRestriction)
|
||||
|
||||
|
||||
sinkInvitations :: forall junction.
|
||||
IsInvitableJunction junction
|
||||
=> InvitationConfig junction
|
||||
-> Sink (Invitation' junction) (YesodJobDB UniWorX) ()
|
||||
-- | Register invitations in the database
|
||||
--
|
||||
-- When an invitation for a certain junction (i.e. an `UserEmail`, `Key
|
||||
-- (InvitationFor junction)`-Pair) already exists it's `InvitationData` is
|
||||
-- updated, instead.
|
||||
--
|
||||
-- For new junctions an invitation is sent by e-mail.
|
||||
sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lift . sinkInvitations'
|
||||
where
|
||||
determineExists :: Conduit (Invitation' junction)
|
||||
(YesodJobDB UniWorX)
|
||||
(Either (InvitationId, InvitationData junction) (Invitation' junction))
|
||||
determineExists
|
||||
| is _Just (ephemeralInvitation @junction)
|
||||
= C.map Right
|
||||
| otherwise
|
||||
= C.mapM $ \inp@(email, fid, dat) ->
|
||||
maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (invRef @junction fid))
|
||||
|
||||
sinkInvitations' :: [Either (InvitationId, InvitationData junction) (Invitation' junction)]
|
||||
-> YesodJobDB UniWorX ()
|
||||
sinkInvitations' (partitionEithers -> (existing, 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_ new $ \(jInvitee, fid, dat) -> do
|
||||
app <- getYesod
|
||||
let mr = renderMessage app $ NonEmpty.toList appLanguages
|
||||
ur <- getUrlRenderParams
|
||||
|
||||
fRec <- get404 fid
|
||||
|
||||
jInviter <- liftHandlerT requireAuthId
|
||||
route <- mapReaderT liftHandlerT $ invitationRoute fRec dat
|
||||
InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec dat
|
||||
protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
|
||||
let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
|
||||
jwt <- encodeToken token
|
||||
jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
|
||||
jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fRec dat
|
||||
let jInvitationExplanation = invitationExplanation fRec dat (toHtml . mr) ur
|
||||
|
||||
queueDBJob JobInvitation{..}
|
||||
|
||||
sinkInvitationsF :: forall junction mono.
|
||||
( IsInvitableJunction junction
|
||||
, MonoFoldable mono
|
||||
, Element mono ~ Invitation' junction
|
||||
)
|
||||
=> InvitationConfig junction
|
||||
-> mono
|
||||
-> YesodJobDB UniWorX ()
|
||||
-- | Non-conduit version of `sinkInvitations`
|
||||
sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg
|
||||
|
||||
|
||||
|
||||
sourceInvitations :: forall junction.
|
||||
IsInvitableJunction junction
|
||||
=> Key (InvitationFor junction)
|
||||
-> Source (YesodDB UniWorX) (UserEmail, InvitationDBData junction)
|
||||
sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
|
||||
where
|
||||
decode (Entity _ (Invitation email _ invitationData))
|
||||
= case fromJSON invitationData of
|
||||
JSON.Success dbData -> return (email, dbData)
|
||||
JSON.Error str -> fail $ "Could not decode invitationData: " <> str
|
||||
|
||||
sourceInvitationsList :: forall junction.
|
||||
IsInvitableJunction junction
|
||||
=> Key (InvitationFor junction)
|
||||
-> YesodDB UniWorX [(UserEmail, InvitationDBData junction)]
|
||||
sourceInvitationsList forKey = runConduit $ sourceInvitations forKey .| C.foldMap pure
|
||||
|
||||
|
||||
data ButtonInvite = BtnInviteAccept | BtnInviteDecline
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Universe ButtonInvite
|
||||
instance Finite ButtonInvite
|
||||
|
||||
nullaryPathPiece ''ButtonInvite $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''ButtonInvite id
|
||||
|
||||
instance Button UniWorX ButtonInvite where
|
||||
btnClasses BtnInviteAccept = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnInviteDecline = [BCIsButton, BCDanger]
|
||||
|
||||
btnValidate _ BtnInviteAccept = True
|
||||
btnValidate _ BtnInviteDecline = False
|
||||
|
||||
invitationR' :: forall junction m.
|
||||
( IsInvitableJunction junction
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> InvitationConfig junction
|
||||
-> m Html
|
||||
-- | Generic handler for incoming invitations
|
||||
invitationR' InvitationConfig{..} = liftHandlerT $ do
|
||||
InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return currentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
|
||||
invitee <- requireAuthId
|
||||
Just cRoute <- getCurrentRoute
|
||||
|
||||
(tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do
|
||||
Entity fid fRec <- invitationResolveFor >>= (\k -> Entity k <$> get404 k)
|
||||
dbData <- case ephemeralInvitation @junction of
|
||||
Nothing -> do
|
||||
Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid)
|
||||
case fromJSON invitationData of
|
||||
JSON.Success dbData -> return dbData
|
||||
JSON.Error str -> fail $ "Could not decode invitationData: " <> str
|
||||
Just (cloneIso -> _DBData) -> return $ view _DBData ()
|
||||
let
|
||||
iData :: InvitationData junction
|
||||
iData = review _InvitationData (dbData, itData)
|
||||
guardAuthResult =<< invitationRestriction fRec iData
|
||||
((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
|
||||
dataRes <- aFormToWForm $ invitationForm fRec iData
|
||||
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
|
||||
_other -> return $ Just <$> dataRes
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
ur <- getUrlRenderParams
|
||||
heading <- invitationHeading fRec iData
|
||||
let explanation = invitationExplanation fRec iData (toHtml . mr) ur
|
||||
|
||||
fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case
|
||||
Nothing -> do
|
||||
addMessageI Info MsgInvitationDeclined
|
||||
deleteBy . UniqueInvitation itEmail $ invRef @junction fid
|
||||
return . Just $ SomeRoute HomeR
|
||||
Just jData -> do
|
||||
mResult <- insertUniqueEntity $ review _InvitableJunction (invitee, fid, jData)
|
||||
case mResult of
|
||||
Nothing -> invalidArgsI [MsgInvitationCollision]
|
||||
Just res -> do
|
||||
deleteBy . UniqueInvitation itEmail $ invRef @junction fid
|
||||
addMessageI Success =<< invitationSuccessMsg fRec res
|
||||
Just <$> invitationUltDest fRec res
|
||||
|
||||
whenIsJust tRoute redirect
|
||||
|
||||
let formWidget = wrapForm dataWidget def
|
||||
{ formMethod = POST
|
||||
, formAction = Just $ SomeRoute cRoute
|
||||
, formEncoding = dataEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
|
||||
siteLayoutMsg heading $(widgetFile "widgets/invitation-site")
|
||||
|
||||
|
||||
class InvitationR a where
|
||||
invitationR :: forall junction.
|
||||
( IsInvitableJunction junction
|
||||
)
|
||||
=> InvitationConfig junction
|
||||
-> a
|
||||
|
||||
instance InvitationR (Handler Html) where
|
||||
invitationR = invitationR'
|
||||
|
||||
instance InvitationR b => InvitationR (a -> b) where
|
||||
invitationR cfg _ = invitationR cfg
|
||||
|
||||
|
||||
-- $procedure
|
||||
--
|
||||
-- `Invitation`s encode a pending entry of some junction table between some
|
||||
-- record and `User` e.g.
|
||||
--
|
||||
-- > data SheetCorrector = SheetCorrector
|
||||
-- > { sheetCorrectorUser :: UserId
|
||||
-- > , sheetCorrectorSheet :: SheetId
|
||||
-- > , sheetCorrectorLoad :: Load
|
||||
-- > }
|
||||
--
|
||||
-- We split the record, encoding a line in the junction table, into a `(UserId,
|
||||
-- InvitationData)`-Pair, storing only part of the `InvitationData` in a
|
||||
-- separate table (what we don't store in that table gets encoded into a
|
||||
-- `BearerToken`).
|
||||
--
|
||||
-- After a User, authorized by said token, supplies their `UserId` the record is
|
||||
-- completed and `insert`ed into the database.
|
||||
--
|
||||
-- We also make provisions for storing one side of the junction's `Key`s
|
||||
-- (`InvitationFor`) separately from the rest of the `InvitationData` to make
|
||||
-- querying for pending invitations easier.
|
||||
@ -1,5 +1,6 @@
|
||||
module Handler.Utils.Tokens
|
||||
( maybeBearerToken, requireBearerToken
|
||||
, currentTokenRestrictions
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -25,3 +26,9 @@ requireBearerToken = liftHandlerT $ do
|
||||
isWrite <- isWriteRequest currentRoute
|
||||
guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
|
||||
return token
|
||||
|
||||
currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, FromJSON a, ToJSON a) => m (Maybe a)
|
||||
currentTokenRestrictions = runMaybeT $ do
|
||||
token <- MaybeT maybeBearerToken
|
||||
route <- MaybeT getCurrentRoute
|
||||
hoistMaybe $ preview (_tokenRestrictionIx route) token
|
||||
|
||||
@ -84,6 +84,7 @@ import Control.Monad.Random.Class as Import (MonadRandom(..))
|
||||
|
||||
import Text.Blaze.Instances as Import ()
|
||||
import Jose.Jwt.Instances as Import ()
|
||||
import Jose.Jwt as Import (Jwt)
|
||||
import Web.PathPieces.Instances as Import ()
|
||||
|
||||
import Data.Time.Calendar as Import
|
||||
|
||||
@ -61,8 +61,7 @@ import Jobs.Handler.HelpRequest
|
||||
import Jobs.Handler.SetLogSettings
|
||||
import Jobs.Handler.DistributeCorrections
|
||||
import Jobs.Handler.SendCourseCommunication
|
||||
import Jobs.Handler.LecturerInvitation
|
||||
import Jobs.Handler.CorrectorInvitation
|
||||
import Jobs.Handler.Invitation
|
||||
|
||||
import Jobs.HealthReport
|
||||
|
||||
|
||||
@ -1,42 +0,0 @@
|
||||
module Jobs.Handler.CorrectorInvitation
|
||||
( dispatchJobCorrectorInvitation
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Text.Hamlet
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
|
||||
dispatchJobCorrectorInvitation :: UserId -> SheetCorrectorInvitation -> Handler ()
|
||||
dispatchJobCorrectorInvitation jInviter jCorrectorInvitation@SheetCorrectorInvitation{..} = do
|
||||
ctx <- runDB . runMaybeT $ do
|
||||
sheet <- MaybeT $ get sheetCorrectorInvitationSheet
|
||||
course <- MaybeT . get $ sheetCourse sheet
|
||||
void . MaybeT $ getByValue jCorrectorInvitation
|
||||
user <- MaybeT $ get jInviter
|
||||
return (sheet, course, user)
|
||||
|
||||
case ctx of
|
||||
Just (Sheet{..}, Course{..}, User{..}) -> do
|
||||
let baseRoute = CSheetR courseTerm courseSchool courseShorthand sheetName $ SCorrInviteR sheetCorrectorInvitationEmail
|
||||
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 sheetCorrectorInvitationEmail]
|
||||
replaceMailHeader "Reply-To" . Just . renderAddress $ Address (Just userDisplayName) (CI.original userEmail)
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
|
||||
|
||||
addPart ($(ihamletFile "templates/mail/correctorInvitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
Nothing -> runDB .
|
||||
deleteBy $ UniqueSheetCorrectorInvitation sheetCorrectorInvitationEmail sheetCorrectorInvitationSheet
|
||||
27
src/Jobs/Handler/Invitation.hs
Normal file
27
src/Jobs/Handler/Invitation.hs
Normal file
@ -0,0 +1,27 @@
|
||||
module Jobs.Handler.Invitation
|
||||
( dispatchJobInvitation
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Utils.Lens
|
||||
import Handler.Utils.Mail
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Text.Hamlet
|
||||
|
||||
|
||||
dispatchJobInvitation :: UserId
|
||||
-> UserEmail
|
||||
-> Text
|
||||
-> Text
|
||||
-> Html
|
||||
-> Handler ()
|
||||
dispatchJobInvitation jInviter jInvitee jInvitationUrl jInvitationSubject jInvitationExplanation = do
|
||||
mInviter <- runDB $ get jInviter
|
||||
|
||||
whenIsJust mInviter $ \jInviter' -> mailT def $ do
|
||||
_mailTo .= [Address Nothing $ CI.original jInvitee]
|
||||
replaceMailHeader "Reply-To" . Just . renderAddress $ userAddress jInviter'
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
replaceMailHeader "Subject" $ Just jInvitationSubject
|
||||
addPart ($(ihamletFile "templates/mail/invitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
@ -1,41 +0,0 @@
|
||||
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
|
||||
|
||||
|
||||
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
|
||||
@ -31,12 +31,12 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
|
||||
, jSubject :: Maybe Text
|
||||
, jMailContent :: Html
|
||||
}
|
||||
| JobLecturerInvitation { jInviter :: UserId
|
||||
, jLecturerInvitation :: LecturerInvitation
|
||||
}
|
||||
| JobCorrectorInvitation { jInviter :: UserId
|
||||
, jCorrectorInvitation :: SheetCorrectorInvitation
|
||||
}
|
||||
| JobInvitation { jInviter :: UserId
|
||||
, jInvitee :: UserEmail
|
||||
, jInvitationUrl :: Text
|
||||
, jInvitationSubject :: Text
|
||||
, jInvitationExplanation :: Html
|
||||
}
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
|
||||
| NotificationSheetActive { nSheet :: SheetId }
|
||||
|
||||
@ -9,10 +9,18 @@ import ClassyPrelude.Yesod
|
||||
import Jose.Jwt
|
||||
|
||||
|
||||
deriving instance Ord Jwt
|
||||
deriving instance Read Jwt
|
||||
deriving instance Generic Jwt
|
||||
deriving instance Typeable Jwt
|
||||
|
||||
instance PathPiece Jwt where
|
||||
toPathPiece (Jwt bytes) = decodeUtf8 bytes
|
||||
fromPathPiece = Just . Jwt . encodeUtf8
|
||||
|
||||
instance Hashable Jwt
|
||||
|
||||
|
||||
deriving instance Generic JwtError
|
||||
deriving instance Typeable JwtError
|
||||
|
||||
|
||||
@ -42,8 +42,5 @@ deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial
|
||||
-- Automatically generated (i.e. numeric) ids are already taken care of
|
||||
deriving instance Binary (Key Term)
|
||||
|
||||
instance Hashable LecturerInvitation
|
||||
instance Hashable SheetCorrectorInvitation
|
||||
|
||||
submissionRatingDone :: Submission -> Bool
|
||||
submissionRatingDone Submission{..} = isJust submissionRatingTime
|
||||
|
||||
@ -494,6 +494,12 @@ formResultToMaybe :: Alternative m => FormResult a -> m a
|
||||
formResultToMaybe (FormSuccess x) = pure x
|
||||
formResultToMaybe _ = empty
|
||||
|
||||
maybeThrow :: (MonadThrow m, Exception e) => e -> Maybe a -> m a
|
||||
maybeThrow exc = maybe (throwM exc) return
|
||||
|
||||
maybeThrowM :: (MonadThrow m, Exception e) => m e -> Maybe a -> m a
|
||||
maybeThrowM excM = maybe (throwM =<< excM) return
|
||||
|
||||
------------
|
||||
-- Either --
|
||||
------------
|
||||
|
||||
@ -98,8 +98,6 @@ makePrisms ''HandlerContents
|
||||
|
||||
makePrisms ''ErrorResponse
|
||||
|
||||
makeLenses_ ''SheetCorrectorInvitation
|
||||
|
||||
makeLenses_ ''SubmissionMode
|
||||
|
||||
makePrisms ''E.Value
|
||||
|
||||
@ -1,3 +0,0 @@
|
||||
<p>
|
||||
_{MsgCourseLecInviteExplanation}
|
||||
^{btnWidget}
|
||||
11
templates/mail/invitation.hamlet
Normal file
11
templates/mail/invitation.hamlet
Normal file
@ -0,0 +1,11 @@
|
||||
$newline never
|
||||
\<!doctype html>
|
||||
<html>
|
||||
<head>
|
||||
<meta charset="UTF-8">
|
||||
<body>
|
||||
<p>
|
||||
#{jInvitationExplanation}
|
||||
<p>
|
||||
<a href=#{jInvitationUrl}>
|
||||
_{MsgInvitationAcceptDecline}
|
||||
@ -1,3 +0,0 @@
|
||||
<p>
|
||||
_{MsgSheetCorrInviteExplanation}
|
||||
^{btnWidget}
|
||||
@ -1,5 +1,5 @@
|
||||
$newline never
|
||||
<td>
|
||||
<td colspan=2>
|
||||
#{csrf}
|
||||
^{fvInput addView}
|
||||
<td>
|
||||
|
||||
9
templates/tutorial/tutorMassInput/cellInvitation.hamlet
Normal file
9
templates/tutorial/tutorMassInput/cellInvitation.hamlet
Normal file
@ -0,0 +1,9 @@
|
||||
$newline never
|
||||
<td>
|
||||
<span style="font-family: monospace">
|
||||
#{email}
|
||||
<td>
|
||||
<div .tooltip>
|
||||
<div .tooltip__handle>
|
||||
<div .tooltip__content>
|
||||
_{MsgEmailInvitationWarning}
|
||||
@ -1,3 +1,3 @@
|
||||
$newline never
|
||||
<td>
|
||||
<td colspan=2>
|
||||
^{nameEmailWidget userEmail userDisplayName userSurname}
|
||||
|
||||
4
templates/widgets/invitation-site.hamlet
Normal file
4
templates/widgets/invitation-site.hamlet
Normal file
@ -0,0 +1,4 @@
|
||||
<section>
|
||||
#{explanation}
|
||||
<section>
|
||||
^{formWidget}
|
||||
Loading…
Reference in New Issue
Block a user