Generic invitations for everything

messages/uniworx/de.msg

@@ -552,6 +552,8 @@ InvitationAcceptDecline: Einladung annehmen/ablehnen
 
 MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für #{shn}
 
+MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn}
+
 SheetGrading: Bewertung
 SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
 SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
@@ -817,6 +819,11 @@ CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor f
 SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn}
 SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein.
 
+TutorInvitationAccepted tutn@TutorialName: Sie wurden als Tutor für #{tutn} eingetragen
+TutorInvitationDeclined tutn@TutorialName: Sie haben die Einladung, Tutor für #{tutn} zu werden, abgelehnt
+TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn}
+TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein.
+
 InvitationAction: Aktion
 InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden
 InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten

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

routes

@@ -108,7 +108,7 @@
       !/#SubmissionFileType/*FilePath SubDownloadR           GET      !owner !corrector
     /correctors                 SCorrR        GET POST
     /pseudonym                  SPseudonymR   GET POST        !course-registeredANDcorrector-submissions
-    /corrector-invite/#UserEmail SCorrInviteR     GET POST
+    /corrector-invite           SCorrInviteR  GET POST
     !/#SheetFileType/*FilePath  SFileR        GET             !timeANDcourse-registered !timeANDmaterials !corrector
   /tuts                         CTutorialListR GET            !tutor
   /tuts/new                     CTutorialNewR  GET POST
@@ -118,6 +118,7 @@
     /participants             TUsersR         GET POST        !tutor
     /register                 TRegisterR          POST        !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered
     /communication            TCommR          GET POST        !tutor
+    /tutor-invite             TInviteR        GET POST
 
 
 /subs  CorrectionsR GET POST !corrector !lecturer

src/Handler/Course.hs

@@ -535,7 +535,7 @@ pgCEditR tid ssh csh = do
   courseData <- runDB $ do
       mbCourse     <- getBy (TermSchoolCourseShort tid ssh csh)
       mbLecs       <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
-      mbLecInvites <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerInvitationCourse ==. entityKey course] [Asc LecturerInvitationType]
+      mbLecInvites <- for mbCourse $ sourceInvitationsList . entityKey
       return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
   -- IMPORTANT: both GET and POST Handler must use the same template,
   --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
@@ -684,8 +684,8 @@ lecturerInvitationConfig = InvitationConfig{..}
     invitationResolveFor = do
       Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
       getKeyBy404 $ TermSchoolCourseShort tid csh ssh
-    invitationSubject Course{..} _ = SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
+    invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
-    invitationHeading Course{..} _ = SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
+    invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
     invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
     invitationTokenConfig _ _ = do
       itAuthority <- liftHandlerT requireAuthId
@@ -720,7 +720,7 @@ data CourseForm = CourseForm
         , cfLecturers  :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
         }
 
-courseToForm :: Entity Course -> [Lecturer] -> [LecturerInvitation] -> CourseForm
+courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> CourseForm
 courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
     { cfCourseId   = Just cid
     , cfName       = courseName
@@ -736,7 +736,7 @@ courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
     , cfRegTo      = courseRegisterTo
     , cfDeRegUntil = courseDeregisterUntil
     , cfLecturers  = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
-                  ++ [Left (lecturerInvitationEmail, lecturerInvitationType) | LecturerInvitation{..} <- lecInvites ]
+                  ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ]
     }
 
 makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm

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
@@ -56,6 +59,9 @@ import Utils.Lens
 import Control.Monad.Random.Class (MonadRandom(..))
 import Utils.Sql
 
+import Data.Aeson hiding (Result(..))
+import Text.Hamlet (ihamlet)
+
 
 {-
   * Implement Handlers
@@ -637,7 +643,7 @@ defaultLoads shid = do
     toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load)
 
 
-correctorForm :: SheetId -> AForm Handler (Set (Either SheetCorrectorInvitation SheetCorrector))
+correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector))
 correctorForm shid = wFormToAForm $ do
   Just currentRoute <- liftHandlerT getCurrentRoute
   userId <- liftHandlerT requireAuthId
@@ -647,7 +653,7 @@ correctorForm shid = wFormToAForm $ do
     currentLoads :: DB Loads
     currentLoads = Map.union
       <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] [])
-      <*> fmap (foldMap $ \(Entity _ SheetCorrectorInvitation{..}) -> Map.singleton (Left sheetCorrectorInvitationEmail) (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) (selectList [ SheetCorrectorInvitationSheet ==. shid ] [])
+      <*> fmap (foldMap $ \(email, InvDBDataSheetCorrector load state) -> Map.singleton (Left email) (state, load)) (sourceInvitationsList shid)
   (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads
 
   isWrite <- liftHandlerT $ isWriteRequest currentRoute
@@ -743,22 +749,20 @@ correctorForm shid = wFormToAForm $ do
              -> Widget
     miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout")
 
-    postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either SheetCorrectorInvitation SheetCorrector)
+    postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either (Invitation' SheetCorrector) SheetCorrector)
     postProcess = Set.fromList . map postProcess' . Map.elems
       where
         sheetCorrectorSheet = shid
-        sheetCorrectorInvitationSheet = shid
 
-        postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either SheetCorrectorInvitation SheetCorrector
+        postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector
         postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
-        postProcess' (Left sheetCorrectorInvitationEmail, (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) = Left SheetCorrectorInvitation{..}
+        postProcess' (Left email, (state, load)) = Left (email, shid, (InvDBDataSheetCorrector load state, InvTokenDataSheetCorrector))
 
   fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) True (Just . Map.fromList . zip [0..] $ Map.toList loads)
 
 getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
 postSCorrR = getSCorrR
 getSCorrR tid ssh csh shn = do
-  uid <- requireAuthId
   Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
 
   ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $
@@ -769,17 +773,15 @@ getSCorrR tid ssh csh shn = do
     FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
     FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do
       update shid [ SheetAutoDistribute =. autoDistribute ]
+      
+      let (invites, adds) = partitionEithers $ Set.toList sheetCorrectors
+
       deleteWhere [ SheetCorrectorSheet ==. shid ]
-      deleteWhere [ SheetCorrectorInvitationSheet ==. shid, SheetCorrectorInvitationEmail /<-. toListOf (folded . _Left . _sheetCorrectorInvitationEmail) sheetCorrectors ]
+      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 ()
 
@@ -791,48 +793,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' (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

@@ -6,9 +6,11 @@ module Handler.Utils.Invitations
     --
     -- $procedure
     IsInvitableJunction(..)
+  , Invitation'
   , _invitationDBData, _invitationTokenData
   , InvitationReference(..), invRef
   , InvitationConfig(..), InvitationTokenConfig(..)
+  , sourceInvitations, sourceInvitationsList
   , sinkInvitations, sinkInvitationsF
   , invitationR', InvitationR(..)
   ) where
@@ -78,6 +80,9 @@ _invitationTokenData :: IsInvitableJunction junction => Lens' (InvitationData ju
 _invitationTokenData = _InvitationData . _2
 
 
+type Invitation' junction = (UserEmail, Key (InvitationFor junction), InvitationData junction)
+
+
 data InvitationReference junction = IsInvitableJunction junction => InvRef (Key (InvitationFor junction))
 
 deriving instance Eq (InvitationReference junction)
@@ -114,9 +119,9 @@ data InvitationConfig junction = InvitationConfig
     -- ^ Monadically resolve `InvitationFor` during `inviteR`
     --
     -- Usually from `requireBearerToken` or `getCurrentRoute`
-  , invitationSubject     :: InvitationFor junction -> InvitationData junction -> SomeMessage UniWorX
+  , invitationSubject     :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX)
     -- ^ Subject of the e-mail which sends the token to the user
-  , invitationHeading     :: InvitationFor junction -> InvitationData junction -> SomeMessage UniWorX
+  , invitationHeading     :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX)
     -- ^ Heading of the page which allows the invitee to accept/decline the invitation (`invitationR`
   , invitationExplanation :: InvitationFor junction -> InvitationData junction -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
     -- ^ Explanation of what kind of invitation this is (used both in the e-mail and in `invitationR`)
@@ -161,7 +166,7 @@ instance IsInvitableJunction junction => FromJSON (InvitationTokenRestriction ju
 sinkInvitations :: forall junction.
                    IsInvitableJunction junction
                 => InvitationConfig junction
-                -> Sink (UserEmail, Key (InvitationFor junction), InvitationData junction) (YesodJobDB UniWorX) ()
+                -> Sink (Invitation' junction) (YesodJobDB UniWorX) ()
 -- | Register invitations in the database
 --
 -- When an invitation for a certain junction (i.e. an `UserEmail`, `Key
@@ -171,9 +176,9 @@ sinkInvitations :: forall junction.
 -- For new junctions an invitation is sent by e-mail.
 sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lift . sinkInvitations'
   where
-    determineExists :: Conduit (UserEmail, Key (InvitationFor junction), InvitationData junction)
+    determineExists :: Conduit (Invitation' junction)
                                (YesodJobDB UniWorX)
-                               (Either (InvitationId, InvitationData junction) (UserEmail, Key (InvitationFor junction), InvitationData junction))
+                               (Either (InvitationId, InvitationData junction) (Invitation' junction))
     determineExists
       | is _Just (ephemeralInvitation @junction)
       = C.map Right
@@ -181,7 +186,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
       = C.mapM $ \inp@(email, fid, dat) ->
           maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (invRef @junction fid))
 
-    sinkInvitations' :: [Either (InvitationId, InvitationData junction) (UserEmail, Key (InvitationFor junction), InvitationData junction)]
+    sinkInvitations' :: [Either (InvitationId, InvitationData junction) (Invitation' junction)]
                      -> YesodJobDB UniWorX ()
     sinkInvitations' (partitionEithers -> (existing, new)) = do
       when (is _Nothing (ephemeralInvitation @junction)) $ do
@@ -201,15 +206,15 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
         let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
         jwt <- encodeToken token
         jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
-        let jInvitationSubject     = mr $ invitationSubject fRec dat
+        jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fRec dat
-            jInvitationExplanation = invitationExplanation fRec dat (toHtml . mr) ur
+        let jInvitationExplanation = invitationExplanation fRec dat (toHtml . mr) ur
 
         queueDBJob JobInvitation{..}
 
 sinkInvitationsF :: forall junction mono.
                     ( IsInvitableJunction junction
                     , MonoFoldable mono
-                    , Element mono ~ (UserEmail, Key (InvitationFor junction), InvitationData junction)
+                    , Element mono ~ Invitation' junction
                     )
                  => InvitationConfig junction
                  -> mono
@@ -218,6 +223,25 @@ sinkInvitationsF :: forall junction mono.
 sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg
 
 
+
+sourceInvitations :: forall junction.
+                     IsInvitableJunction junction
+                  => Key (InvitationFor junction)
+                  -> Source (YesodDB UniWorX) (UserEmail, InvitationDBData junction)
+sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
+  where
+    decode (Entity _ (Invitation email _ invitationData))
+      = case fromJSON invitationData of
+          JSON.Success dbData -> return (email, dbData)
+          JSON.Error   str    -> fail $ "Could not decode invitationData: " <> str
+
+sourceInvitationsList :: forall junction.
+                         IsInvitableJunction junction
+                      => Key (InvitationFor junction)
+                      -> YesodDB UniWorX [(UserEmail, InvitationDBData junction)]
+sourceInvitationsList forKey = runConduit $ sourceInvitations forKey .| C.foldMap pure
+
+
 data ButtonInvite = BtnInviteAccept | BtnInviteDecline
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 instance Universe ButtonInvite
@@ -268,9 +292,8 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
 
     MsgRenderer mr <- getMsgRenderer
     ur <- getUrlRenderParams
-    let
+    heading <- invitationHeading fRec iData
-      heading = invitationHeading fRec iData
+    let explanation = invitationExplanation fRec iData (toHtml . mr) ur
-      explanation = invitationExplanation fRec iData (toHtml . mr) ur
 
     fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case
       Nothing -> do
@@ -282,6 +305,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
         case mResult of
           Nothing -> invalidArgsI [MsgInvitationCollision]
           Just res -> do
+            deleteBy . UniqueInvitation itEmail $ invRef @junction fid
             addMessageI Success =<< invitationSuccessMsg fRec res
             Just <$> invitationUltDest fRec res
 

src/Jobs.hs

@@ -59,7 +59,6 @@ import Jobs.Handler.HelpRequest
 import Jobs.Handler.SetLogSettings
 import Jobs.Handler.DistributeCorrections
 import Jobs.Handler.SendCourseCommunication
-import Jobs.Handler.CorrectorInvitation
 import Jobs.Handler.Invitation
 
   

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/Types.hs

@@ -31,9 +31,6 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
                                       , jSubject :: Maybe Text
                                       , jMailContent :: Html
                                       }
-         | JobCorrectorInvitation { jInviter :: UserId
-                                  , jCorrectorInvitation :: SheetCorrectorInvitation
-                                  }
          | JobInvitation { jInviter :: UserId
                          , jInvitee :: UserEmail
                          , jInvitationUrl :: Text

src/Model.hs

@@ -41,8 +41,5 @@ deriving instance Eq (Unique Tutorial)
 -- Automatically generated (i.e. numeric) ids are already taken care of
 deriving instance Binary (Key Term)
 
-instance Hashable LecturerInvitation
-instance Hashable SheetCorrectorInvitation
-
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime

src/Utils/Lens.hs

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

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}