Generic invitations for everything
This commit is contained in:
Gregor Kleen
parent
c933fc7664
commit
22c01d988c
@ -552,6 +552,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
|
||||
@ -817,6 +819,11 @@ 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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
3
routes
3
routes
@ -108,7 +108,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
|
||||
/tuts CTutorialListR GET !tutor
|
||||
/tuts/new CTutorialNewR GET POST
|
||||
@ -118,6 +118,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
|
||||
|
||||
@ -535,7 +535,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.
|
||||
@ -684,8 +684,8 @@ lecturerInvitationConfig = InvitationConfig{..}
|
||||
invitationResolveFor = do
|
||||
Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
|
||||
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
||||
invitationSubject Course{..} _ = SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
|
||||
invitationHeading Course{..} _ = SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
|
||||
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
|
||||
@ -720,7 +720,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
|
||||
@ -736,7 +736,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
|
||||
|
||||
@ -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
|
||||
@ -56,6 +59,9 @@ import Utils.Lens
|
||||
import Control.Monad.Random.Class (MonadRandom(..))
|
||||
import Utils.Sql
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
|
||||
{-
|
||||
* Implement Handlers
|
||||
@ -637,7 +643,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
|
||||
@ -647,7 +653,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
|
||||
@ -743,22 +749,20 @@ correctorForm shid = wFormToAForm $ do
|
||||
-> Widget
|
||||
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout")
|
||||
|
||||
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 $
|
||||
@ -769,17 +773,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 ()
|
||||
|
||||
@ -791,48 +793,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' (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
|
||||
|
||||
@ -6,9 +6,11 @@ module Handler.Utils.Invitations
|
||||
--
|
||||
-- $procedure
|
||||
IsInvitableJunction(..)
|
||||
, Invitation'
|
||||
, _invitationDBData, _invitationTokenData
|
||||
, InvitationReference(..), invRef
|
||||
, InvitationConfig(..), InvitationTokenConfig(..)
|
||||
, sourceInvitations, sourceInvitationsList
|
||||
, sinkInvitations, sinkInvitationsF
|
||||
, invitationR', InvitationR(..)
|
||||
) where
|
||||
@ -78,6 +80,9 @@ _invitationTokenData :: IsInvitableJunction junction => Lens' (InvitationData ju
|
||||
_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)
|
||||
@ -114,9 +119,9 @@ data InvitationConfig junction = InvitationConfig
|
||||
-- ^ Monadically resolve `InvitationFor` during `inviteR`
|
||||
--
|
||||
-- Usually from `requireBearerToken` or `getCurrentRoute`
|
||||
, invitationSubject :: InvitationFor junction -> InvitationData junction -> SomeMessage UniWorX
|
||||
, 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 -> SomeMessage UniWorX
|
||||
, 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`)
|
||||
@ -161,7 +166,7 @@ instance IsInvitableJunction junction => FromJSON (InvitationTokenRestriction ju
|
||||
sinkInvitations :: forall junction.
|
||||
IsInvitableJunction junction
|
||||
=> InvitationConfig junction
|
||||
-> Sink (UserEmail, Key (InvitationFor junction), InvitationData junction) (YesodJobDB UniWorX) ()
|
||||
-> Sink (Invitation' junction) (YesodJobDB UniWorX) ()
|
||||
-- | Register invitations in the database
|
||||
--
|
||||
-- When an invitation for a certain junction (i.e. an `UserEmail`, `Key
|
||||
@ -171,9 +176,9 @@ sinkInvitations :: forall junction.
|
||||
-- For new junctions an invitation is sent by e-mail.
|
||||
sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lift . sinkInvitations'
|
||||
where
|
||||
determineExists :: Conduit (UserEmail, Key (InvitationFor junction), InvitationData junction)
|
||||
determineExists :: Conduit (Invitation' junction)
|
||||
(YesodJobDB UniWorX)
|
||||
(Either (InvitationId, InvitationData junction) (UserEmail, Key (InvitationFor junction), InvitationData junction))
|
||||
(Either (InvitationId, InvitationData junction) (Invitation' junction))
|
||||
determineExists
|
||||
| is _Just (ephemeralInvitation @junction)
|
||||
= C.map Right
|
||||
@ -181,7 +186,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
|
||||
= C.mapM $ \inp@(email, fid, dat) ->
|
||||
maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (invRef @junction fid))
|
||||
|
||||
sinkInvitations' :: [Either (InvitationId, InvitationData junction) (UserEmail, Key (InvitationFor junction), InvitationData junction)]
|
||||
sinkInvitations' :: [Either (InvitationId, InvitationData junction) (Invitation' junction)]
|
||||
-> YesodJobDB UniWorX ()
|
||||
sinkInvitations' (partitionEithers -> (existing, new)) = do
|
||||
when (is _Nothing (ephemeralInvitation @junction)) $ do
|
||||
@ -201,15 +206,15 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
|
||||
let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
|
||||
jwt <- encodeToken token
|
||||
jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
|
||||
let jInvitationSubject = mr $ invitationSubject fRec dat
|
||||
jInvitationExplanation = invitationExplanation fRec dat (toHtml . mr) ur
|
||||
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 ~ (UserEmail, Key (InvitationFor junction), InvitationData junction)
|
||||
, Element mono ~ Invitation' junction
|
||||
)
|
||||
=> InvitationConfig junction
|
||||
-> mono
|
||||
@ -218,6 +223,25 @@ sinkInvitationsF :: forall junction mono.
|
||||
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
|
||||
@ -268,9 +292,8 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
ur <- getUrlRenderParams
|
||||
let
|
||||
heading = invitationHeading fRec iData
|
||||
explanation = invitationExplanation fRec iData (toHtml . mr) ur
|
||||
heading <- invitationHeading fRec iData
|
||||
let explanation = invitationExplanation fRec iData (toHtml . mr) ur
|
||||
|
||||
fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case
|
||||
Nothing -> do
|
||||
@ -282,6 +305,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
|
||||
case mResult of
|
||||
Nothing -> invalidArgsI [MsgInvitationCollision]
|
||||
Just res -> do
|
||||
deleteBy . UniqueInvitation itEmail $ invRef @junction fid
|
||||
addMessageI Success =<< invitationSuccessMsg fRec res
|
||||
Just <$> invitationUltDest fRec res
|
||||
|
||||
|
||||
@ -59,7 +59,6 @@ import Jobs.Handler.HelpRequest
|
||||
import Jobs.Handler.SetLogSettings
|
||||
import Jobs.Handler.DistributeCorrections
|
||||
import Jobs.Handler.SendCourseCommunication
|
||||
import Jobs.Handler.CorrectorInvitation
|
||||
import Jobs.Handler.Invitation
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
@ -31,9 +31,6 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
|
||||
, jSubject :: Maybe Text
|
||||
, jMailContent :: Html
|
||||
}
|
||||
| JobCorrectorInvitation { jInviter :: UserId
|
||||
, jCorrectorInvitation :: SheetCorrectorInvitation
|
||||
}
|
||||
| JobInvitation { jInviter :: UserId
|
||||
, jInvitee :: UserEmail
|
||||
, jInvitationUrl :: Text
|
||||
|
||||
@ -41,8 +41,5 @@ deriving instance Eq (Unique 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
|
||||
|
||||
@ -98,8 +98,6 @@ makePrisms ''HandlerContents
|
||||
|
||||
makePrisms ''ErrorResponse
|
||||
|
||||
makeLenses_ ''SheetCorrectorInvitation
|
||||
|
||||
makeLenses_ ''SubmissionMode
|
||||
|
||||
makePrisms ''E.Value
|
||||
|
||||
@ -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}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user