feat(users): lecturer invitations

messages/uniworx/de.msg

@@ -899,6 +899,7 @@ MenuExamNew: Neue Klausur anlegen
 MenuExamEdit: Bearbeiten
 MenuExamUsers: Teilnehmer
 MenuExamAddMembers: Klausurteilnehmer hinzufügen
+MenuLecturerInvite: Dozenten hinzufügen
 
 AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
 AuthPredsActive: Aktive Authorisierungsprädikate
@@ -1323,4 +1324,16 @@ NewPasswordRepeat: Wiederholung
 CurrentPasswordInvalid: Aktuelles Passwort ist inkorrekt
 PasswordRepeatInvalid: Wiederholung stimmt nicht mit neuem Passwort überein
 UserPasswordHeadingFor: Passwort ändern für
-PasswordChangedSuccess: Passwort erfolgreich geändert
+PasswordChangedSuccess: Passwort erfolgreich geändert
+
+LecturerInviteSchool: Institut
+LecturerInviteField: Einzuladende EMail Addressen
+LecturerInviteHeading: Dozenten hinzufügen
+
+LecturersInvited n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} per EMail eingeladen
+LecturersAdded n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} eingetragen
+
+MailSubjectSchoolLecturerInvitation school@SchoolName: Einladung zum Dozent für „#{school}“
+MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „#{school}“
+SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen.
+SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen

routes

@@ -49,6 +49,8 @@
 /users/#CryptoUUIDUser/hijack AdminHijackUserR     POST       !adminANDno-escalation
 /users/#CryptoUUIDUser/notifications UserNotificationR GET POST   !self
 /users/#CryptoUUIDUser/password      UserPasswordR     GET POST   !selfANDis-pw-hash
+!/users/lecturer-invite/new    AdminNewLecturerInviteR  GET POST
+!/users/lecturer-invite        AdminLecturerInviteR     GET POST
 /admin                        AdminR           GET
 /admin/features               AdminFeaturesR   GET POST
 /admin/test                   AdminTestR       GET POST

src/Foundation.hs

@@ -1832,6 +1832,16 @@ pageActions (AdminR) =
       , menuItemAccessCallback' = return True
       }
   ]
+pageActions (UsersR) =
+  [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuLecturerInvite
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute AdminNewLecturerInviteR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
+  ]
 pageActions (AdminUserR cID) =
   [ MenuItem
       { menuItemType  = PageActionPrime

src/Handler/Course.hs

@@ -791,7 +791,7 @@ lecturerInvitationConfig :: InvitationConfig Lecturer
 lecturerInvitationConfig = InvitationConfig{..}
   where
     invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
-    invitationResolveFor = do
+    invitationResolveFor _ = do
       Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
       getKeyBy404 $ TermSchoolCourseShort tid csh ssh
     invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
@@ -1552,7 +1552,7 @@ instance FromJSON (InvitationDBData CourseParticipant) where
 
 instance ToJSON (InvitationTokenData CourseParticipant) where
   toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
-  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
 instance FromJSON (InvitationTokenData CourseParticipant) where
   parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
 
@@ -1560,7 +1560,7 @@ participantInvitationConfig :: InvitationConfig CourseParticipant
 participantInvitationConfig = InvitationConfig{..}
   where
     invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
-    invitationResolveFor = do
+    invitationResolveFor _ = do
       Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute
       getKeyBy404 $ TermSchoolCourseShort tid csh ssh
     invitationSubject     (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand

src/Handler/Exam/CorrectorInvite.hs

@@ -56,7 +56,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
     invitationRoute (Entity _ Exam{..}) _ = do
       Course{..} <- get404 examCourse
       return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR
-    invitationResolveFor = do
+    invitationResolveFor _ = do
       Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute
       fetchExamId tid csh ssh examn
     invitationSubject (Entity _ Exam{..}) _ = do

src/Handler/Exam/RegistrationInvite.hs

@@ -64,7 +64,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
     invitationRoute (Entity _ Exam{..}) _ = do
       Course{..} <- get404 examCourse
       return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR
-    invitationResolveFor = do
+    invitationResolveFor _ = do
       Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute
       fetchExamId tid csh ssh examn
     invitationSubject (Entity _ Exam{..}) _ = do

src/Handler/Sheet.hs

@@ -899,7 +899,7 @@ correctorInvitationConfig = InvitationConfig{..}
     invitationRoute (Entity _ Sheet{..}) _ = do
       Course{..} <- get404 sheetCourse
       return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
-    invitationResolveFor = do
+    invitationResolveFor _ = do
       Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute
       fetchSheetId tid csh ssh shn
     invitationSubject (Entity _ Sheet{..}) _ = do

src/Handler/Submission.hs

@@ -89,7 +89,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
       Course{..} <- getJust sheetCourse
       cID <- encrypt subId
       return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR
-    invitationResolveFor = do
+    invitationResolveFor _ = do
       Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute
       subId <- decrypt cID
       bool notFound (return subId) =<< existsKey subId

src/Handler/Tutorial.hs

@@ -249,7 +249,7 @@ tutorInvitationConfig = InvitationConfig{..}
     invitationRoute (Entity _ Tutorial{..}) _ = do
       Course{..} <- get404 tutorialCourse
       return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR
-    invitationResolveFor = do
+    invitationResolveFor _ = do
       Just (CTutorialR tid csh ssh tutn TInviteR) <- getCurrentRoute
       fetchTutorialId tid csh ssh tutn
     invitationSubject (Entity _ Tutorial{..}) _ = do

src/Handler/Users.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Handler.Users where
 
 import Import
@@ -7,6 +9,7 @@ import Jobs
 import Handler.Utils
 import Handler.Utils.Tokens
 import Handler.Utils.Users
+import Handler.Utils.Invitations
 
 import qualified Auth.LDAP as Auth
 
@@ -26,6 +29,9 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
 import qualified Data.ByteString.Base64 as Base64
 
+import Text.Hamlet (ihamlet)
+import Data.Aeson hiding (Result(..))
+
 
 hijackUserForm :: CryptoUUIDUser -> Form ()
 hijackUserForm cID csrf = do
@@ -432,3 +438,100 @@ postUserPasswordR cID = do
       , formEncoding = passEnctype
       , formAttrs = [ asyncSubmitAttr | isModal ]
       }
+
+
+instance IsInvitableJunction UserLecturer where
+  type InvitationFor UserLecturer = School
+  data InvitableJunction UserLecturer = JunctionUserLecturer
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationDBData UserLecturer = InvDBDataUserLecturer
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationTokenData UserLecturer = InvTokenDataUserLecturer
+    { invTokenUserLecturerSchool :: SchoolShorthand
+    }
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+  _InvitableJunction = iso
+    (\UserLecturer{..} -> (userLecturerUser, userLecturerSchool, JunctionUserLecturer))
+    (\(userLecturerUser, userLecturerSchool, JunctionUserLecturer) -> UserLecturer{..})
+
+instance ToJSON (InvitableJunction UserLecturer) where
+  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
+instance FromJSON (InvitableJunction UserLecturer) where
+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
+
+instance ToJSON (InvitationDBData UserLecturer) where
+  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationDBData UserLecturer) where
+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+
+instance ToJSON (InvitationTokenData UserLecturer) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationTokenData UserLecturer) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+
+lecturerInvitationConfig :: InvitationConfig UserLecturer
+lecturerInvitationConfig = InvitationConfig{..}
+  where
+    invitationRoute _ _ = return AdminLecturerInviteR
+    invitationResolveFor InvTokenDataUserLecturer{..} = return $ SchoolKey invTokenUserLecturerSchool
+    invitationSubject (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSubjectSchoolLecturerInvitation schoolName
+    invitationHeading (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSchoolLecturerInviteHeading schoolName
+    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSchoolLecturerInviteExplanation}|]
+    invitationTokenConfig _ _ = do
+      itAuthority <- liftHandlerT requireAuthId
+      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
+    invitationRestriction _ _ = return Authorized
+    invitationForm _ _ _ = pure $ (JunctionUserLecturer, ())
+    invitationInsertHook _ _ _ _ = id
+    invitationSuccessMsg (Entity _ School{..}) _ = return . SomeMessage $ MsgSchoolLecturerInvitationAccepted schoolName
+    invitationUltDest (Entity ssh _) _ = do
+      currentTerm <- E.select . E.from $ \term -> do
+        E.where_ $ term E.^. TermActive
+        E.orderBy [E.desc $ term E.^. TermName]
+        E.limit 1
+        return $ term E.^. TermId
+      return . SomeRoute $ case currentTerm of
+        [E.Value tid] -> TermSchoolCourseListR tid ssh
+        _other        -> CourseListR
+      
+      
+getAdminNewLecturerInviteR, postAdminNewLecturerInviteR :: Handler Html
+getAdminNewLecturerInviteR = postAdminNewLecturerInviteR
+postAdminNewLecturerInviteR = do
+  uid <- requireAuthId
+  userSchools <- runDB . E.select . E.from $ \userAdmin -> do
+    E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
+    return $ userAdmin E.^. UserAdminSchool
+  
+  ((invitesResult, invitesWgt), invitesEncoding) <- runFormPost . renderWForm FormStandard $ do
+    school <- wreq (schoolFieldFor $ map E.unValue userSchools) (fslI MsgLecturerInviteSchool) Nothing
+    users <- wreq (multiUserField False Nothing) (fslI MsgLecturerInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
+    return $ (,) <$> school <*> users
+
+  formResultModal invitesResult UsersR $ \(schoolId, users) -> do
+    let (emails, uids) = partitionEithers $ Set.toList users
+    lift . runDBJobs $ do
+      forM_ uids $ \lecId ->
+        void . insertUnique $ UserLecturer lecId schoolId
+
+      sinkInvitationsF lecturerInvitationConfig [ (mail, schoolId, (InvDBDataUserLecturer, InvTokenDataUserLecturer $ unSchoolKey schoolId)) | mail <- emails ]
+
+    unless (null emails) $ 
+      tell . pure <=< messageI Success . MsgLecturersInvited $ length emails
+    unless (null uids) $ 
+      tell . pure <=< messageI Success . MsgLecturersAdded $ length uids
+
+  siteLayoutMsg MsgLecturerInviteHeading $ do
+    setTitleI MsgLecturerInviteHeading
+    wrapForm invitesWgt def
+      { formEncoding = invitesEncoding
+      , formAction = Just $ SomeRoute AdminNewLecturerInviteR
+      }
+
+getAdminLecturerInviteR, postAdminLecturerInviteR :: Handler Html
+getAdminLecturerInviteR = postAdminLecturerInviteR
+postAdminLecturerInviteR = invitationR lecturerInvitationConfig

src/Handler/Utils/Invitations.hs

@@ -115,10 +115,10 @@ invRef = toJSON . InvRef @junction
 data InvitationConfig junction = forall formCtx. InvitationConfig
   { invitationRoute       :: Entity (InvitationFor junction) -> InvitationData junction -> DB (Route UniWorX)
     -- ^ Which route calls `invitationR` for this kind of invitation?
-  , invitationResolveFor  :: DB (Key (InvitationFor junction))
+  , invitationResolveFor  :: InvitationTokenData junction -> DB (Key (InvitationFor junction))
     -- ^ Monadically resolve `InvitationFor` during `inviteR`
     --
-    -- Usually from `requireBearerToken` or `getCurrentRoute`
+    -- Usually from `getCurrentRoute`
   , invitationSubject     :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
     -- ^ Subject of the e-mail which sends the token to the user
   , invitationHeading     :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
@@ -287,7 +287,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
   Just cRoute <- getCurrentRoute
 
   (tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do
-    fEnt@(Entity fid _) <- invitationResolveFor >>= (\k -> Entity k <$> get404 k)
+    fEnt@(Entity fid _) <- invitationResolveFor itData >>= (\k -> Entity k <$> get404 k)
     dbData <- case ephemeralInvitation @junction of
       Nothing -> do
         Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid)