feat(exam-office): user invitations

messages/uniworx/de.msg

@@ -817,6 +817,8 @@ MailSubjectExamRegistrationInvitation tid@TermId ssh@SchoolId csh@CourseShorthan
 
 MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zu einer Abgabe für #{shn}
 
+MailSubjectExamOfficeUserInvitation displayName@Text: Berücksichtigung von Prüfungsleistungen in Uni2work
+
 MailSubjectPasswordReset: Uni2work-Passwort ändern bzw. setzen
 
 SheetGrading: Bewertung
@@ -1177,6 +1179,10 @@ SubmissionUserInvitationDeclined shn@SheetName: Sie haben die Einladung, Mitabge
 SubmissionUserInviteHeading shn@SheetName: Einladung zu einer Abgabe für #{shn}
 SubmissionUserInviteExplanation: Sie wurden eingeladen, Mitabgebende(r) bei einer Abgabe zu sein.
 
+ExamOfficeUserInviteHeading displayName@Text: Zugriff auf Ihre Prüfungsleistungen durch #{displayName}
+ExamOfficeUserInviteExplanation: Um Ihre Prüfungsleistungen ordnungsgemäß anrechnen zu können (z.B. im finalen Transcript of Records für Erasmus-Studierende) werden sie eingeladen der hierfür zuständigen Stelle Einsicht zu gewähren.
+ExamOfficeUserInvitationAccepted: Einsicht erfolgreich gewährt
+
 InvitationAction: Aktion
 InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden
 InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten
@@ -1683,4 +1689,7 @@ TransactionExamOfficeFieldsUpdated nUpdates@Int: #{nUpdates} #{pluralDE nUpdates
 ExamOfficeFieldNotSubscribed: —
 ExamOfficeFieldSubscribed: Einsicht
 ExamOfficeFieldForced: Forcierte Einsicht
-InvalidExamOfficeFieldMode parseErr@Text: Konnte „#{parseErr}“ nicht interpretieren
+InvalidExamOfficeFieldMode parseErr@Text: Konnte „#{parseErr}“ nicht interpretieren
+
+LdapIdentification: Campus-Kennung
+LdapIdentificationOrEmail: Campus-Kennung/E-Mail Addresse

routes

@@ -75,6 +75,7 @@
   /                        EOExamsR            GET
   /fields                  EOFieldsR           GET POST
   /users                   EOUsersR            GET POST
+  /users/invite            EOUsersInviteR      GET POST
 
 /term                      TermShowR           GET             !free
 /term/current              TermCurrentR        GET             !free

src/Handler/ExamOffice/Users.hs

@@ -1,42 +1,112 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Handler.ExamOffice.Users
-  ( getEOUsersR
+  ( getEOUsersR, postEOUsersR
-  , postEOUsersR
+  , getEOUsersInviteR, postEOUsersInviteR
   ) where
 
 import Import
 import Utils.Form
 import Handler.Utils
+import Handler.Utils.Invitations
+
+import Text.Hamlet (ihamlet)
+import Data.Aeson hiding (Result(..))
+import Jobs.Queue
 
 import qualified Database.Esqueleto as E
 
 import qualified Data.Set as Set
-import Data.Map ((!))
+import qualified Data.Map as Map
+import Data.Map ((!), (!?))
   
 
-makeExamOfficeUsersForm :: Maybe (Set UserId) -> Form (Set UserId)
+instance IsInvitableJunction ExamOfficeUser where
+  type InvitationFor ExamOfficeUser = User
+  data InvitableJunction ExamOfficeUser = JunctionExamOfficeUser
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationDBData ExamOfficeUser = InvDBDataExamOfficeUser
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationTokenData ExamOfficeUser = InvTokenDataExamOfficeUser
+    { invTokenExamOfficeUserOffice :: CryptoUUIDUser
+    }
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+  _InvitableJunction = iso
+    (\ExamOfficeUser{..} -> (examOfficeUserUser, examOfficeUserOffice, JunctionExamOfficeUser))
+    (\(examOfficeUserUser, examOfficeUserOffice, JunctionExamOfficeUser) -> ExamOfficeUser{..})
+
+instance ToJSON (InvitableJunction ExamOfficeUser) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+instance FromJSON (InvitableJunction ExamOfficeUser) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+
+instance ToJSON (InvitationDBData ExamOfficeUser) where
+  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationDBData ExamOfficeUser) where
+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+
+instance ToJSON (InvitationTokenData ExamOfficeUser) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
+instance FromJSON (InvitationTokenData ExamOfficeUser) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
+
+examOfficeUserInvitationConfig :: InvitationConfig ExamOfficeUser
+examOfficeUserInvitationConfig = InvitationConfig{..}
+  where
+    invitationRoute _ _ = return $ ExamOfficeR EOUsersInviteR
+    invitationResolveFor InvTokenDataExamOfficeUser{..} = do
+      officeId <- decrypt invTokenExamOfficeUserOffice
+      bool notFound (return officeId) =<< existsKey officeId
+    invitationSubject (Entity _ User{..}) _ = do
+      return . SomeMessage $ MsgMailSubjectExamOfficeUserInvitation userDisplayName
+    invitationHeading (Entity _ User{..}) _ = do
+      return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName
+    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|]
+    invitationTokenConfig _ _ = do
+      itAuthority <- liftHandlerT requireAuthId
+      let itExpiresAt = Nothing
+          itStartsAt = Nothing
+          itAddAuth = Nothing
+      return InvitationTokenConfig{..}
+    invitationRestriction _ _ = return Authorized
+    invitationForm _ _ _ = pure (JunctionExamOfficeUser, ())
+    invitationInsertHook _ _ ExamOfficeUser{..} _ act = do
+      res <- act
+      audit $ TransactionExamOfficeUserAdd examOfficeUserOffice examOfficeUserUser
+      return res
+    invitationSuccessMsg _ _ =
+      return $ SomeMessage MsgExamOfficeUserInvitationAccepted
+    invitationUltDest _ _ = return $ SomeRoute HomeR
+
+  
+makeExamOfficeUsersForm :: Maybe (Set (Either UserEmail UserId)) -> Form (Set (Either UserEmail UserId))
 makeExamOfficeUsersForm template = renderWForm FormStandard $ do
   Just cRoute <- getCurrentRoute
   
   let
-    sortProj = over _1 ((readMay :: Text -> Maybe Integer) =<<) . view _2
-    
     miAdd' :: (Text -> Text)
            -> FieldView UniWorX
-           -> Form ([(UserId, _)] -> FormResult [(UserId, _)])
+           -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
-    miAdd' nudge submitView csrf = do
+    miAdd' nudge btn csrf = do
       MsgRenderer mr <- getMsgRenderer
-      (addRes, addView) <- mpreq userMatriculationField ("" & addName (nudge "matr") & addPlaceholder (mr MsgUserMatriculation)) Nothing
+      (addRes, addView) <- mpreq (multiUserField False Nothing) ("" & addName (nudge "users") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
       let
-        res' :: FormResult ([(UserId, _)] -> FormResult [(UserId, _)])
+        res' :: FormResult ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
         res' = addRes <&> \newUsers oldUsers -> if
           | null newUsers
             -> pure oldUsers
           | otherwise
-            -> pure . nubOn (view _1) . sortOn sortProj
+            -> pure . nub $ oldUsers ++ Set.toList newUsers
-               $ oldUsers ++ [ (uid, (userMatrikelnummer, userSurname, userDisplayName)) | Entity uid User{..} <- newUsers ]
       return (res', $(widgetFile "widgets/massinput/examOfficeUsers/add"))
-    miCell' :: (UserId, (Maybe UserMatriculation, UserSurname, UserDisplayName)) -> Widget
+    miCell' :: Either UserEmail UserId -> Widget
-    miCell' (_, (userMatr, userSName, userDName)) = $(widgetFile "widgets/massinput/examOfficeUsers/cell")
+    miCell' (Left email) = $(widgetFile "widgets/massinput/examOfficeUsers/cellInvitation")
+    miCell' (Right uid) = do
+      User{..} <- liftHandlerT . runDB $ getJust uid
+      $(widgetFile "widgets/massinput/examOfficeUsers/cellKnown")
     miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
     miButtonAction' frag = Just . SomeRoute $ cRoute :#: frag
     miLayout' :: MassInputLayout ListLength _ ()
@@ -49,13 +119,15 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do
     fRequired :: Bool
     fRequired = False
 
-  template' <- for template $ \uids -> fmap (sortOn sortProj) . liftHandlerT . runDB $ do
+  template' <- for template $ \uids -> liftHandlerT . runDB $ do
-    users <- E.select . E.from $ \user -> do
+    let (invitations, knownUsers) = partitionEithers $ Set.toList uids
-      E.where_ $ user E.^. UserId `E.in_` E.valList (Set.toList uids)
+    knownUsers' <- fmap (map E.unValue) . E.select . E.from $ \user -> do
-      return (user E.^. UserId, user E.^. UserMatrikelnummer, user E.^. UserSurname, user E.^. UserDisplayName)
+      E.where_ $ user E.^. UserId `E.in_` E.valList knownUsers
-    return $ users <&> \(E.Value uid, E.Value matr, E.Value sName, E.Value dName) -> (uid, (matr, sName, dName))
+      E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
+      return $ user E.^. UserId
+    return $ map Left invitations ++ map Right knownUsers'
 
-  fmap (Set.fromList . keys) <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired template'
+  fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired template'
     
 
 -- | Manage the list of users this user (in her function as exam-office)
@@ -70,18 +142,26 @@ postEOUsersR = do
       E.on $ user E.^. UserId E.==. examOfficeUser E.^. ExamOfficeUserUser
        E.&&. examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val uid
       return $ user E.^. UserId
-    return $ setOf (folded . _Value) users
+    invites <- Map.keysSet <$> sourceInvitationsF @ExamOfficeUser uid
+    return $ setOf (folded . _Value . re _Right) users <> Set.mapMonotonic Left invites
 
   ((usersRes, usersView), usersEnc) <- runFormPost . makeExamOfficeUsersForm $ Just oldUsers
 
   formResult usersRes $ \(setSymmDiff oldUsers -> changes) -> do
-    liftHandlerT . runDB . forM_ changes $ \change -> if
+    liftHandlerT . runDBJobs . forM_ changes $ \change -> if
-      | change `Set.member` oldUsers -> do
+      | change `Set.member` oldUsers -> case change of
-          deleteBy $ UniqueExamOfficeUser uid change
+          Right change' -> do
-          audit $ TransactionExamOfficeUserDelete uid change
+            deleteBy $ UniqueExamOfficeUser uid change'
-      | otherwise -> do
+            audit $ TransactionExamOfficeUserDelete uid change'
-          insert_ $ ExamOfficeUser uid change
+          Left change' ->
-          audit $ TransactionExamOfficeUserAdd uid change
+            deleteInvitation @ExamOfficeUser uid change'
+      | otherwise -> case change of
+          Right change' -> do
+            insert_ $ ExamOfficeUser uid change'
+            audit $ TransactionExamOfficeUserAdd uid change'
+          Left change' -> do
+            cID <- encrypt uid
+            sinkInvitation examOfficeUserInvitationConfig (change', uid, (InvDBDataExamOfficeUser, InvTokenDataExamOfficeUser cID))
     addMessageI Success $ MsgTransactionExamOfficeUsersUpdated (Set.size $ changes `Set.intersection` oldUsers) (Set.size $ changes `Set.difference` oldUsers)
     redirect $ ExamOfficeR EOExamsR
 
@@ -100,3 +180,7 @@ postEOUsersR = do
         _{MsgExamOfficeSubscribedUsersExplanation}
       ^{usersView'}
     |]
+
+getEOUsersInviteR, postEOUsersInviteR :: Handler Html
+getEOUsersInviteR = postEOUsersInviteR
+postEOUsersInviteR = invitationR examOfficeUserInvitationConfig

templates/widgets/massinput/examOfficeUsers/add.hamlet

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

templates/widgets/massinput/examOfficeUsers/cell.hamlet

@@ -1,5 +0,0 @@
-$newline never
-<td>
-  ^{nameWidget userDName userSName}
-  $maybe matrikel <- userMatr
-    \ (#{matrikel})

templates/widgets/massinput/examOfficeUsers/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/widgets/massinput/examOfficeUsers/cellKnown.hamlet

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

templates/widgets/massinput/examOfficeUsers/layout.hamlet

@@ -5,7 +5,9 @@ $newline never
       <tr .massinput__cell>
         ^{cellWdgts ! coord}
         <td>
-          ^{fvInput (delButtons ! coord)}
+          $maybe delButton <- delButtons !? coord
-  <tfoot>
+            ^{fvInput delButton}
-    <tr .massinput__cell.massinput__cell--add>
+  $maybe addWdgt <- addWdgts !? (0, 0)
-      ^{addWdgts ! (0, 0)}
+    <tfoot>
+      <tr .massinput__cell.massinput__cell--add>
+        ^{addWdgt}