diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 49822549e..19941107c 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -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
\ No newline at end of file
+HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
diff --git a/models/courses b/models/courses
index 45166d7d5..4fcf67d65 100644
--- a/models/courses
+++ b/models/courses
@@ -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
diff --git a/models/invitations b/models/invitations
new file mode 100644
index 000000000..c1d15148c
--- /dev/null
+++ b/models/invitations
@@ -0,0 +1,5 @@
+Invitation
+ email UserEmail
+ for Value
+ data Value
+ UniqueInvitation email for
\ No newline at end of file
diff --git a/models/sheets b/models/sheets
index 293d75b2f..f8d21a6c2 100644
--- a/models/sheets
+++ b/models/sheets
@@ -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
diff --git a/package.yaml b/package.yaml
index 3994357bf..4edc4d864 100644
--- a/package.yaml
+++ b/package.yaml
@@ -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)
diff --git a/routes b/routes
index c98fd9131..747207cc0 100644
--- a/routes
+++ b/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
diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs
index 55ad19245..003fdfcdc 100644
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@@ -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
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index b0e11604f..b4d549d49 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -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
diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs
index 7a07c6a55..255f26aea 100644
--- a/src/Handler/Tutorial.hs
+++ b/src/Handler/Tutorial.hs
@@ -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
diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs
new file mode 100644
index 000000000..a256a7a99
--- /dev/null
+++ b/src/Handler/Utils/Invitations.hs
@@ -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.
diff --git a/src/Handler/Utils/Tokens.hs b/src/Handler/Utils/Tokens.hs
index e95b16a69..8ca5ad400 100644
--- a/src/Handler/Utils/Tokens.hs
+++ b/src/Handler/Utils/Tokens.hs
@@ -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
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index e057be569..266ad727b 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -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
diff --git a/src/Jobs.hs b/src/Jobs.hs
index 9c7fd3674..641d3e100 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -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
diff --git a/src/Jobs/Handler/CorrectorInvitation.hs b/src/Jobs/Handler/CorrectorInvitation.hs
deleted file mode 100644
index 76e0d26c2..000000000
--- a/src/Jobs/Handler/CorrectorInvitation.hs
+++ /dev/null
@@ -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
diff --git a/src/Jobs/Handler/Invitation.hs b/src/Jobs/Handler/Invitation.hs
new file mode 100644
index 000000000..f86256f33
--- /dev/null
+++ b/src/Jobs/Handler/Invitation.hs
@@ -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))
diff --git a/src/Jobs/Handler/LecturerInvitation.hs b/src/Jobs/Handler/LecturerInvitation.hs
deleted file mode 100644
index e3fd03a6d..000000000
--- a/src/Jobs/Handler/LecturerInvitation.hs
+++ /dev/null
@@ -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
diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs
index 80d308626..f333f0c7d 100644
--- a/src/Jobs/Types.hs
+++ b/src/Jobs/Types.hs
@@ -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 }
diff --git a/src/Jose/Jwt/Instances.hs b/src/Jose/Jwt/Instances.hs
index 4bf4e3827..0c0c093ef 100644
--- a/src/Jose/Jwt/Instances.hs
+++ b/src/Jose/Jwt/Instances.hs
@@ -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
diff --git a/src/Model.hs b/src/Model.hs
index 1ee1c9530..1e1ecf062 100644
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -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
diff --git a/src/Utils.hs b/src/Utils.hs
index 9e79c33e7..39dbf3126 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -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 --
------------
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 52780e335..7a7c6a4db 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -98,8 +98,6 @@ makePrisms ''HandlerContents
makePrisms ''ErrorResponse
-makeLenses_ ''SheetCorrectorInvitation
-
makeLenses_ ''SubmissionMode
makePrisms ''E.Value
diff --git a/templates/courseLecInvite.hamlet b/templates/courseLecInvite.hamlet
deleted file mode 100644
index 408556fb7..000000000
--- a/templates/courseLecInvite.hamlet
+++ /dev/null
@@ -1,3 +0,0 @@
-
- _{MsgCourseLecInviteExplanation}
-^{btnWidget}
diff --git a/templates/mail/invitation.hamlet b/templates/mail/invitation.hamlet
new file mode 100644
index 000000000..ef3b004e5
--- /dev/null
+++ b/templates/mail/invitation.hamlet
@@ -0,0 +1,11 @@
+$newline never
+\
+
+
+
+
+
+ #{jInvitationExplanation}
+
+
+ _{MsgInvitationAcceptDecline}
diff --git a/templates/sheetCorrInvite.hamlet b/templates/sheetCorrInvite.hamlet
deleted file mode 100644
index 8e51c7358..000000000
--- a/templates/sheetCorrInvite.hamlet
+++ /dev/null
@@ -1,3 +0,0 @@
-
- _{MsgSheetCorrInviteExplanation}
-^{btnWidget}
diff --git a/templates/tutorial/tutorMassInput/add.hamlet b/templates/tutorial/tutorMassInput/add.hamlet
index cf4cc6e72..bdf6da247 100644
--- a/templates/tutorial/tutorMassInput/add.hamlet
+++ b/templates/tutorial/tutorMassInput/add.hamlet
@@ -1,5 +1,5 @@
$newline never
-
+ |
#{csrf}
^{fvInput addView}
|
diff --git a/templates/tutorial/tutorMassInput/cellInvitation.hamlet b/templates/tutorial/tutorMassInput/cellInvitation.hamlet
new file mode 100644
index 000000000..27c423ad1
--- /dev/null
+++ b/templates/tutorial/tutorMassInput/cellInvitation.hamlet
@@ -0,0 +1,9 @@
+$newline never
+ |
+
+ #{email}
+ |
+
+
+
+ _{MsgEmailInvitationWarning}
diff --git a/templates/tutorial/tutorMassInput/cellKnown.hamlet b/templates/tutorial/tutorMassInput/cellKnown.hamlet
index c6c6cc2ad..5ea4cca6f 100644
--- a/templates/tutorial/tutorMassInput/cellKnown.hamlet
+++ b/templates/tutorial/tutorMassInput/cellKnown.hamlet
@@ -1,3 +1,3 @@
$newline never
-
+ |
^{nameEmailWidget userEmail userDisplayName userSurname}
diff --git a/templates/widgets/invitation-site.hamlet b/templates/widgets/invitation-site.hamlet
new file mode 100644
index 000000000..064e92184
--- /dev/null
+++ b/templates/widgets/invitation-site.hamlet
@@ -0,0 +1,4 @@
+ | |