diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index b56ec2fc8..3f89309c9 100644
--- a/messages/uniworx/de.msg
+++ b/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
\ No newline at end of file
+InvalidExamOfficeFieldMode parseErr@Text: Konnte „#{parseErr}“ nicht interpretieren
+
+LdapIdentification: Campus-Kennung
+LdapIdentificationOrEmail: Campus-Kennung/E-Mail Addresse
\ No newline at end of file
diff --git a/routes b/routes
index ee3c56938..2ef578bc8 100644
--- a/routes
+++ b/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
diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs
index 0b004fb5f..1ff543437 100644
--- a/src/Handler/ExamOffice/Users.hs
+++ b/src/Handler/ExamOffice/Users.hs
@@ -1,42 +1,112 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
module Handler.ExamOffice.Users
- ( getEOUsersR
- , postEOUsersR
+ ( getEOUsersR, 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, _)])
- miAdd' nudge submitView csrf = do
+ -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
+ 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
- $ oldUsers ++ [ (uid, (userMatrikelnummer, userSurname, userDisplayName)) | Entity uid User{..} <- newUsers ]
+ -> pure . nub $ oldUsers ++ Set.toList newUsers
return (res', $(widgetFile "widgets/massinput/examOfficeUsers/add"))
- miCell' :: (UserId, (Maybe UserMatriculation, UserSurname, UserDisplayName)) -> Widget
- miCell' (_, (userMatr, userSName, userDName)) = $(widgetFile "widgets/massinput/examOfficeUsers/cell")
+ miCell' :: Either UserEmail UserId -> Widget
+ 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
- users <- E.select . E.from $ \user -> do
- E.where_ $ user E.^. UserId `E.in_` E.valList (Set.toList uids)
- return (user E.^. UserId, user E.^. UserMatrikelnummer, user E.^. UserSurname, user E.^. UserDisplayName)
- return $ users <&> \(E.Value uid, E.Value matr, E.Value sName, E.Value dName) -> (uid, (matr, sName, dName))
+ template' <- for template $ \uids -> liftHandlerT . runDB $ do
+ let (invitations, knownUsers) = partitionEithers $ Set.toList uids
+ knownUsers' <- fmap (map E.unValue) . E.select . E.from $ \user -> do
+ E.where_ $ user E.^. UserId `E.in_` E.valList knownUsers
+ 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
- | change `Set.member` oldUsers -> do
- deleteBy $ UniqueExamOfficeUser uid change
- audit $ TransactionExamOfficeUserDelete uid change
- | otherwise -> do
- insert_ $ ExamOfficeUser uid change
- audit $ TransactionExamOfficeUserAdd uid change
+ liftHandlerT . runDBJobs . forM_ changes $ \change -> if
+ | change `Set.member` oldUsers -> case change of
+ Right change' -> do
+ deleteBy $ UniqueExamOfficeUser uid change'
+ audit $ TransactionExamOfficeUserDelete uid change'
+ Left 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
diff --git a/templates/widgets/massinput/examOfficeUsers/add.hamlet b/templates/widgets/massinput/examOfficeUsers/add.hamlet
index cf4cc6e72..7986b68e3 100644
--- a/templates/widgets/massinput/examOfficeUsers/add.hamlet
+++ b/templates/widgets/massinput/examOfficeUsers/add.hamlet
@@ -1,6 +1,6 @@
$newline never
-|
+ |
#{csrf}
^{fvInput addView}
|
- ^{fvInput submitView}
+ ^{fvInput btn}
diff --git a/templates/widgets/massinput/examOfficeUsers/cell.hamlet b/templates/widgets/massinput/examOfficeUsers/cell.hamlet
deleted file mode 100644
index 28a22faf9..000000000
--- a/templates/widgets/massinput/examOfficeUsers/cell.hamlet
+++ /dev/null
@@ -1,5 +0,0 @@
-$newline never
- |
- ^{nameWidget userDName userSName}
- $maybe matrikel <- userMatr
- \ (#{matrikel})
diff --git a/templates/widgets/massinput/examOfficeUsers/cellInvitation.hamlet b/templates/widgets/massinput/examOfficeUsers/cellInvitation.hamlet
new file mode 100644
index 000000000..f498aff5e
--- /dev/null
+++ b/templates/widgets/massinput/examOfficeUsers/cellInvitation.hamlet
@@ -0,0 +1,9 @@
+ $newline never
+ |
+
+ #{email}
+ |
+
+
+
+ _{MsgEmailInvitationWarning}
diff --git a/templates/widgets/massinput/examOfficeUsers/cellKnown.hamlet b/templates/widgets/massinput/examOfficeUsers/cellKnown.hamlet
new file mode 100644
index 000000000..5ea4cca6f
--- /dev/null
+++ b/templates/widgets/massinput/examOfficeUsers/cellKnown.hamlet
@@ -0,0 +1,3 @@
+$newline never
+
+ ^{nameEmailWidget userEmail userDisplayName userSurname}
diff --git a/templates/widgets/massinput/examOfficeUsers/layout.hamlet b/templates/widgets/massinput/examOfficeUsers/layout.hamlet
index 65352dd95..f1842a72f 100644
--- a/templates/widgets/massinput/examOfficeUsers/layout.hamlet
+++ b/templates/widgets/massinput/examOfficeUsers/layout.hamlet
@@ -5,7 +5,9 @@ $newline never
|
^{cellWdgts ! coord}
|
- ^{fvInput (delButtons ! coord)}
- |
-
- ^{addWdgts ! (0, 0)}
+ $maybe delButton <- delButtons !? coord
+ ^{fvInput delButton}
+ $maybe addWdgt <- addWdgts !? (0, 0)
+
+
+ ^{addWdgt}
|