Merge branch 'feat/generic-invitations' into 'master'

Feat/generic invitations

See merge request !188

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

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

models/invitations

@@ -0,0 +1,5 @@
+Invitation
+  email     UserEmail
+  for       Value
+  data      Value
+  UniqueInvitation email for

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

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)

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

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
+              let (invites, adds) = partitionEithers $ cfLecturers res
-                  Right (lid, lty) -> insert_  $ Lecturer lid cid lty
+              insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
-                  Left (lEmail, mLTy) -> do
+              sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
-                    insert_ $ LecturerInvitation lEmail cid mLTy
+              insert_ $ CourseEdit aid now cid
-                    queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy
-                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)]
+                    deleteWhere [InvitationFor ==. invRef @Lecturer cid, InvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
-                    forM_ (cfLecturers res) $ \case
+                    let (invites, adds) = partitionEithers $ cfLecturers res
-                      Right (lid, lty) -> insert_  $ Lecturer lid cid lty
+                    insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
-                      Left (lEmail, mLTy) -> do
+                    sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
-                        insertRes <- insertUnique (LecturerInvitation lEmail cid mLTy)
+
-                        case insertRes of
-                          Just _  ->
-                            queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy
-                          Nothing ->
-                            updateBy (UniqueLecturerInvitation lEmail cid) [ LecturerInvitationType =. mLTy ]
                     insert_ $ CourseEdit aid now cid
                     addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True
@@ -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
@@ -1298,54 +1356,6 @@ postCCommR tid ssh csh = do
     }
 
  
-data ButtonLecInvite = BtnLecInvAccept | BtnLecInvDecline
+getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-instance Universe ButtonLecInvite
-instance Finite ButtonLecInvite
-
-nullaryPathPiece ''ButtonLecInvite $ camelToPathPiece' 3
-embedRenderMessage ''UniWorX ''ButtonLecInvite id
-
-instance Button UniWorX ButtonLecInvite where
-  btnClasses BtnLecInvAccept = [BCIsButton, BCPrimary]
-  btnClasses BtnLecInvDecline = [BCIsButton, BCDanger]
-
-getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> UserEmail -> Handler Html
 getCLecInviteR = postCLecInviteR
-postCLecInviteR tid ssh csh email = do
+postCLecInviteR = invitationR lecturerInvitationConfig
-  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")

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 ]
+      insertMany_ adds
-      forM_ sheetCorrectors $ \case
+
-        Right shCor -> insert_ shCor
+      deleteWhere [InvitationFor ==. invRef @SheetCorrector shid, InvitationEmail /<-. toListOf (folded . _1) invites]
-        Left shCorInv -> do
+      sinkInvitationsF correctorInvitationConfig invites
-          insertRes <- insertBy shCorInv
+
-          case insertRes of
-            Right _ ->
-              void . queueDBJob $ JobCorrectorInvitation uid shCorInv
-            Left (Entity old _) ->
-               replace old shCorInv
       addMessageI Success MsgCorrectorsUpdated
     FormMissing -> return ()
 
@@ -781,48 +783,65 @@ getSCorrR tid ssh csh shn = do
       }
 
 
-data ButtonCorrInvite = BtnCorrInvAccept | BtnCorrInvDecline
+instance IsInvitableJunction SheetCorrector where
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  type InvitationFor SheetCorrector = Sheet
-instance Universe ButtonCorrInvite
+  data InvitableJunction SheetCorrector = JunctionSheetCorrector
-instance Finite ButtonCorrInvite
+    { 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
+  _InvitableJunction = iso
-embedRenderMessage ''UniWorX ''ButtonCorrInvite id
+    (\SheetCorrector{..} -> (sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState))
+    (\(sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState) -> SheetCorrector{..})
 
-instance Button UniWorX ButtonCorrInvite where
+instance ToJSON (InvitableJunction SheetCorrector) where
-  btnClasses BtnCorrInvAccept = [BCIsButton, BCPrimary]
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
-  btnClasses BtnCorrInvDecline = [BCIsButton, BCDanger]
+  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
+postSCorrInviteR = invitationR correctorInvitationConfig
-  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")

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' :: Either UserEmail UserId -> Widget
-        miCell' userId = do
+        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
+      whenIsJust insertRes $ \tutid -> do
-        Just tutid -> void . insert $ Tutor tutid tutor
+        let (invites, adds) = partitionEithers $ Set.toList tfTutors
-        _other     -> return ()
+        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 ]
+      when (is _Nothing insertRes) $ do
-      forM_ tfTutors $ void . insert . Tutor tutid
+        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

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.

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

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

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.Invitation
-import Jobs.Handler.CorrectorInvitation
 
 import Jobs.HealthReport
 

src/Jobs/Handler/CorrectorInvitation.hs

@@ -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

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))

src/Jobs/Handler/LecturerInvitation.hs

@@ -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

src/Jobs/Types.hs

@@ -31,12 +31,12 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
                                       , jSubject :: Maybe Text
                                       , jMailContent :: Html
                                       }
-         | JobLecturerInvitation { jInviter :: UserId
+         | JobInvitation { jInviter :: UserId
-                                 , jLecturerInvitation :: LecturerInvitation
+                         , jInvitee :: UserEmail
-                                 }
+                         , jInvitationUrl :: Text
-         | JobCorrectorInvitation { jInviter :: UserId
+                         , jInvitationSubject :: Text
-                                  , jCorrectorInvitation :: SheetCorrectorInvitation
+                         , jInvitationExplanation :: Html
-                                  }
+                         }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationSheetActive { nSheet :: SheetId }

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
 

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

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 --
 ------------

src/Utils/Lens.hs

@@ -98,8 +98,6 @@ makePrisms ''HandlerContents
 
 makePrisms ''ErrorResponse
 
-makeLenses_ ''SheetCorrectorInvitation
-
 makeLenses_ ''SubmissionMode
 
 makePrisms ''E.Value

templates/courseLecInvite.hamlet

@@ -1,3 +0,0 @@
-<p>
-  _{MsgCourseLecInviteExplanation}
-^{btnWidget}

templates/mail/invitation.hamlet

@@ -0,0 +1,11 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+  <body>
+    <p>
+      #{jInvitationExplanation}
+    <p>
+      <a href=#{jInvitationUrl}>
+        _{MsgInvitationAcceptDecline}

templates/sheetCorrInvite.hamlet

@@ -1,3 +0,0 @@
-<p>
-  _{MsgSheetCorrInviteExplanation}
-^{btnWidget}

templates/tutorial/tutorMassInput/add.hamlet

@@ -1,5 +1,5 @@
 $newline never
-<td>
+<td colspan=2>
   #{csrf}
   ^{fvInput addView}
 <td>

templates/tutorial/tutorMassInput/cellInvitation.hamlet

@@ -0,0 +1,9 @@
+$newline never
+<td>
+  <span style="font-family: monospace">
+    #{email}
+<td>
+  <div .tooltip>
+    <div .tooltip__handle>
+    <div .tooltip__content>
+      _{MsgEmailInvitationWarning}

templates/tutorial/tutorMassInput/cellKnown.hamlet

@@ -1,3 +1,3 @@
 $newline never
-<td>
+<td colspan=2>
   ^{nameEmailWidget userEmail userDisplayName userSurname}

templates/widgets/invitation-site.hamlet

@@ -0,0 +1,4 @@
+<section>
+  #{explanation}
+<section>
+  ^{formWidget}