From f75cc641e22b6f00bc494f85aa64cd365ac19ad5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Sep 2019 18:33:50 +0200 Subject: [PATCH 001/150] feat(exam-office): subscription management for users & fields --- messages/uniworx/de.msg | 24 +++- models/exam-office | 14 +++ models/schools | 3 +- routes | 7 ++ src/Application.hs | 1 + src/Audit/Types.hs | 17 +++ src/Database/Esqueleto/Utils.hs | 5 +- src/Foundation.hs | 35 ++++++ src/Handler/Course/Application/List.hs | 2 +- src/Handler/ExamOffice.hs | 8 ++ src/Handler/ExamOffice/Exam.hs | 14 +++ src/Handler/ExamOffice/Exams.hs | 10 ++ src/Handler/ExamOffice/Fields.hs | 116 ++++++++++++++++++ src/Handler/ExamOffice/Users.hs | 102 +++++++++++++++ src/Handler/Utils/Form.hs | 38 +++++- src/Model/Types/Security.hs | 1 + src/Utils.hs | 7 ++ src/Utils/Icon.hs | 2 +- src/Utils/Lens.hs | 12 +- templates/default-layout.lucius | 6 +- .../widgets/fields/examOfficeFieldMode.hamlet | 7 ++ .../massinput/examOfficeUsers/add.hamlet | 6 + .../massinput/examOfficeUsers/cell.hamlet | 5 + .../massinput/examOfficeUsers/layout.hamlet | 11 ++ 24 files changed, 441 insertions(+), 12 deletions(-) create mode 100644 models/exam-office create mode 100644 src/Handler/ExamOffice.hs create mode 100644 src/Handler/ExamOffice/Exam.hs create mode 100644 src/Handler/ExamOffice/Exams.hs create mode 100644 src/Handler/ExamOffice/Fields.hs create mode 100644 src/Handler/ExamOffice/Users.hs create mode 100644 templates/widgets/fields/examOfficeFieldMode.hamlet create mode 100644 templates/widgets/massinput/examOfficeUsers/add.hamlet create mode 100644 templates/widgets/massinput/examOfficeUsers/cell.hamlet create mode 100644 templates/widgets/massinput/examOfficeUsers/layout.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 62214863b..ce29ac156 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -364,6 +364,7 @@ UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausg UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist. +UnauthorizedExamOffice: Sie sind nicht Teil eines Prüfungsamts. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. UnauthorizedAllocationLecturer: Sie sind nicht als Veranstalter für eine Veranstaltung dieser Zentralanmeldung eingetragen. @@ -1045,6 +1046,9 @@ MenuExamNew: Neue Prüfung anlegen MenuExamEdit: Bearbeiten MenuExamUsers: Teilnehmer MenuExamAddMembers: Prüfungsteilnehmer hinzufügen +MenuExamOfficeExams: Prüfungen +MenuExamOfficeFields: Fächer +MenuExamOfficeUsers: Benutzer MenuLecturerInvite: Dozenten hinzufügen MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung MenuCourseApplicationsFiles: Dateien aller Bewerbungen @@ -1056,6 +1060,7 @@ AuthPredsActive: Aktive Authorisierungsprädikate AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert AuthTagFree: Seite ist universell zugänglich AuthTagAdmin: Nutzer ist Administrator +AuthTagExamOffice: Nutzer ist Teil eines Prüfungsamts AuthTagToken: Nutzer präsentiert Authorisierungs-Token AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet AuthTagDeprecated: Seite ist nicht überholt @@ -1628,4 +1633,21 @@ MailAllocationUnratedApplications: Für die unten aufgeführten Kurse liegen Bew MailSubjectAllocationOutdatedRatings allocation@AllocationName: Bereits bewertete Bewerbungen für ihre Kurse in der Zentralanmeldung „#{allocation}“ haben sich geändert MailAllocationOutdatedRatings: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der Zentralanmeldung an den jeweiligen Kurs gestellt wurden, die sich verändert haben, seit sie zuletzt bewertet wurden. -MailAllocationOutdatedRatingsWarning: Bewerbungen deren Bewertung veraltet ist (d.h. die Bewerbung wurde nach der Bewertung verändert) zählen als nicht bewertet. \ No newline at end of file +MailAllocationOutdatedRatingsWarning: Bewerbungen deren Bewertung veraltet ist (d.h. die Bewerbung wurde nach der Bewertung verändert) zählen als nicht bewertet. + +ExamOfficeSubscribedUsers: Benutzer +ExamOfficeSubscribedUsersTip: Sie können mehrere Matrikelnummern mit Komma separieren + +ExamOfficeSubscribedUsersExplanation: Für hier angegebene Benutzer können Sie (ungeachtet der Fächer des Studierenden) stets sämtliche Prüfungsergebnisse einsehen. +ExamOfficeSubscribedFieldsExplanation: Sie können für alle Benutzer, die mindestens eines der angegeben Studienfächer studieren, sämtliche Prüfungsergebnisse einsehen. Sie haben zusätzlich die Möglichkeit anzugeben, ob es den Benutzern gestattet sein soll, dieser Einsicht im Einzelfall (pro Kurs) zu widersprechen. + +UserMatriculationNotFound matriculation@Text: Es existiert kein Uni2work-Benutzer mit Matrikelnummer „#{matriculation}“ +UserMatriculationAmbiguous matriculation@Text: Matrikelnummer „#{matriculation}“ ist nicht eindeutig + +TransactionExamOfficeUsersUpdated nDeleted@Int nAdded@Int: #{nAdded} Benutzer hinzugefügt, #{nDeleted} Benutzer gelöscht + +TransactionExamOfficeFieldsUpdated nUpdates@Int: #{nUpdates} #{pluralDE nUpdates "Studienfach" "Studienfächer"} angepasst +ExamOfficeFieldNotSubscribed: — +ExamOfficeFieldSubscribed: Einsicht +ExamOfficeFieldForced: Forcierte Einsicht +InvalidExamOfficeFieldMode parseErr@Text: Konnte „#{parseErr}“ nicht interpretieren \ No newline at end of file diff --git a/models/exam-office b/models/exam-office new file mode 100644 index 000000000..5963cabb4 --- /dev/null +++ b/models/exam-office @@ -0,0 +1,14 @@ +ExamOfficeField + office UserId + field StudyTermsId + forced Bool + UniqueExamOfficeField office field +ExamOfficeUser + office UserId + user UserId + UniqueExamOfficeUser office user +ExamOfficeResultSynced + office UserId + result ExamResult + time UTCTime + UniqueExamOfficeResultSynced office result \ No newline at end of file diff --git a/models/schools b/models/schools index 2da425cf4..c5bd3d6ac 100644 --- a/models/schools +++ b/models/schools @@ -13,4 +13,5 @@ SchoolLdap UniqueOrgUnit orgUnit SchoolTerms school SchoolId - terms StudyTermsId \ No newline at end of file + terms StudyTermsId + UniqueSchoolTerms school terms \ No newline at end of file diff --git a/routes b/routes index 293577bf9..3210505bb 100644 --- a/routes +++ b/routes @@ -71,6 +71,11 @@ /user/profile ProfileDataR GET !free /user/authpreds AuthPredsR GET POST !free +/exam-office ExamOfficeR !exam-office: + / EOExamsR GET + /fields EOFieldsR GET POST + /users EOUsersR GET POST + /term TermShowR GET !free /term/current TermCurrentR GET !free /term/edit TermEditR GET POST @@ -163,6 +168,8 @@ /users/new EAddUserR GET POST /users/invite EInviteR GET POST /register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result + /grades EGradesR GET !exam-office + /grades/read EGradesReadR POST !exam-office /apps CApplicationsR GET POST !/apps/files CAppsFilesR GET /apps/#CryptoFileNameCourseApplication CourseApplicationR: diff --git a/src/Application.hs b/src/Application.hs index fe1bc98ff..06bb5309a 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -109,6 +109,7 @@ import Handler.SystemMessage import Handler.Health import Handler.Exam import Handler.Allocation +import Handler.ExamOffice -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index dec21cdea..4d1e77356 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -98,6 +98,23 @@ data Transaction { transactionFile :: FileId } + | TransactionExamOfficeUserAdd + { transactionOffice :: UserId + , transactionUser :: UserId + } + | TransactionExamOfficeUserDelete + { transactionOffice :: UserId + , transactionUser :: UserId + } + | TransactionExamOfficeFieldEdit + { transactionOffice :: UserId + , transactionField :: StudyTermsId + } + | TransactionExamOfficeFieldDelete + { transactionOffice :: UserId + , transactionField :: StudyTermsId + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index c038f2152..b8ca06295 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -13,7 +13,7 @@ module Database.Esqueleto.Utils , anyFilter, allFilter , orderByList , orderByOrd, orderByEnum - , lower, ciEq + , strip, lower, ciEq , selectExists , SqlHashable , sha256 @@ -194,6 +194,9 @@ orderByEnum = orderByList $ List.sortOn fromEnum universeF lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) lower = E.unsafeSqlFunction "LOWER" + +strip :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) +strip = E.unsafeSqlFunction "TRIM" ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) ciEq a b = lower a E.==. lower b diff --git a/src/Foundation.hs b/src/Foundation.hs index 60143db44..66b840ced 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -652,6 +652,11 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) return Authorized +tagAccessPredicate AuthExamOffice = APDB $ \mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] [] + guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedExamOffice) + return Authorized tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ lift . validateToken mAuthId route isWrite =<< askTokenUnsafe tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of @@ -1762,6 +1767,10 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (SchoolR ssh SchoolEditR) = return (original (unSchoolKey ssh), Just SchoolListR) breadcrumb SchoolNewR = return ("Neu" , Just SchoolListR) + breadcrumb (ExamOfficeR EOExamsR) = return ("Prüfungen", Nothing) + breadcrumb (ExamOfficeR EOFieldsR) = return ("Fächer" , Just $ ExamOfficeR EOExamsR) + breadcrumb (ExamOfficeR EOUsersR) = return ("Benutzer" , Just $ ExamOfficeR EOExamsR) + breadcrumb InfoR = return ("Information" , Nothing) breadcrumb InfoLecturerR = return ("Veranstalter" , Just InfoR) breadcrumb DataProtR = return ("Datenschutz" , Just InfoR) @@ -1971,6 +1980,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , menuItemModal = False , menuItemAccessCallback' = return True } + , return MenuItem + { menuItemType = NavbarAside + , menuItemLabel = MsgMenuExamOfficeExams + , menuItemIcon = Just "poll-h" + , menuItemRoute = SomeRoute $ ExamOfficeR EOExamsR + , menuItemModal = False + , menuItemAccessCallback' = return True + } , return MenuItem { menuItemType = NavbarAside , menuItemLabel = MsgMenuUsers @@ -2074,6 +2091,24 @@ pageActions (AdminR) = , menuItemAccessCallback' = return True } ] +pageActions (ExamOfficeR EOExamsR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuExamOfficeFields + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ ExamOfficeR EOFieldsR + , menuItemModal = True + , menuItemAccessCallback' = return True + } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuExamOfficeUsers + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ ExamOfficeR EOUsersR + , menuItemModal = True + , menuItemAccessCallback' = return True + } + ] pageActions (SchoolListR) = [ MenuItem { menuItemType = PageActionPrime diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 23ddd7d60..f4056e878 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -268,7 +268,7 @@ postCApplicationsR tid ssh csh = do , emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree , emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester , colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText) - , lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusL 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles)) + , lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusG 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles)) , colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto) , colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints) , colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment) diff --git a/src/Handler/ExamOffice.hs b/src/Handler/ExamOffice.hs new file mode 100644 index 000000000..5ad3a8bda --- /dev/null +++ b/src/Handler/ExamOffice.hs @@ -0,0 +1,8 @@ +module Handler.ExamOffice + ( module Handler.ExamOffice + ) where + +import Handler.ExamOffice.Exams as Handler.ExamOffice +import Handler.ExamOffice.Fields as Handler.ExamOffice +import Handler.ExamOffice.Users as Handler.ExamOffice +import Handler.ExamOffice.Exam as Handler.ExamOffice diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs new file mode 100644 index 000000000..9583df560 --- /dev/null +++ b/src/Handler/ExamOffice/Exam.hs @@ -0,0 +1,14 @@ +module Handler.ExamOffice.Exam + ( getEGradesR + , postEGradesReadR + ) where + +import Import + +-- | View a list of all users' grades that the current user has access to +getEGradesR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getEGradesR = fail "not implemented" + +-- | Mark all users' grades that the current user has access to as "read" +postEGradesReadR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +postEGradesReadR = fail "not implemented" diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs new file mode 100644 index 000000000..dfeae9214 --- /dev/null +++ b/src/Handler/ExamOffice/Exams.hs @@ -0,0 +1,10 @@ +module Handler.ExamOffice.Exams + ( getEOExamsR + ) where + +import Import + +-- | List of all exams where the current user may (in her function as +-- exam-office) access users grades +getEOExamsR :: Handler Html +getEOExamsR = fail "not implemented" diff --git a/src/Handler/ExamOffice/Fields.hs b/src/Handler/ExamOffice/Fields.hs new file mode 100644 index 000000000..2df3860c2 --- /dev/null +++ b/src/Handler/ExamOffice/Fields.hs @@ -0,0 +1,116 @@ +module Handler.ExamOffice.Fields + ( getEOFieldsR + , postEOFieldsR + ) where + +import Import +import Utils.Form + +import qualified Database.Esqueleto as E + +import qualified Data.Set as Set +import qualified Data.Map as Map + + +data ExamOfficeFieldMode + = EOFNotSubscribed + | EOFSubscribed + | EOFForced + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) +embedRenderMessage ''UniWorX ''ExamOfficeFieldMode $ concat . set (ix 0) "ExamOfficeField" . splitCamel +instance Universe ExamOfficeFieldMode +instance Finite ExamOfficeFieldMode +nullaryPathPiece ''ExamOfficeFieldMode $ camelToPathPiece' 1 +instance Default ExamOfficeFieldMode where + def = EOFNotSubscribed + +eofModeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m ExamOfficeFieldMode +-- ^ Always required +eofModeField = Field{..} + where + fieldEnctype = UrlEncoded + fieldView = \theId name attrs val _isReq -> $(widgetFile "widgets/fields/examOfficeFieldMode") + fieldParse = \e _ -> return $ parser e + + parser [] = Right Nothing + parser (x:_) + | Just mode <- fromPathPiece x + = Right $ Just mode + parser (x:_) + = Left . SomeMessage $ MsgInvalidExamOfficeFieldMode x + + isChecked :: Eq a => a -> Either Text a -> Bool + isChecked opt = either (const False) (== opt) + + +makeExamOfficeFieldsForm :: UserId -> Maybe (Map StudyTermsId Bool) -> Form (Map StudyTermsId Bool) +makeExamOfficeFieldsForm uid template = renderWForm FormStandard $ do + availableFields <- liftHandlerT . runDB . E.select . E.from $ \(terms `E.InnerJoin` schoolTerms) -> do + E.on $ terms E.^. StudyTermsId E.==. schoolTerms E.^. SchoolTermsTerms + E.where_ . E.exists . E.from $ \userFunction -> + E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid + E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice + E.&&. userFunction E.^. UserFunctionSchool E.==. schoolTerms E.^. SchoolTermsSchool + return terms + let available = imap (\k terms -> (terms, view forced $ template >>= Map.lookup k)) $ toMapOf (folded .> _entityVal) availableFields + + forced :: Iso' (Maybe Bool) ExamOfficeFieldMode + forced = iso fromForced toForced + where + fromForced = maybe EOFNotSubscribed $ bool EOFSubscribed EOFForced + toForced = \case + EOFNotSubscribed -> Nothing + EOFSubscribed -> Just False + EOFForced -> Just True + + fmap (fmap (Map.mapMaybe $ review forced) . sequence) . forM available $ \(StudyTerms{..}, template') + -> let label = fromMaybe (tshow studyTermsKey) $ studyTermsName <|> studyTermsShorthand + in wpopt eofModeField (fsl label) $ Just template' + +-- | Manage the list of `StudyTerms` this user (in her function as exam-office) +-- has an interest in, i.e. that authorize her to view an users grades, iff +-- they study one of the selected fields +getEOFieldsR, postEOFieldsR :: Handler Html +getEOFieldsR = postEOFieldsR +postEOFieldsR = do + uid <- requireAuthId + + oldFields <- liftHandlerT . runDB $ do + fields <- E.select . E.from $ \examOfficeField -> do + E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid + return $ (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced) + return $ toMapOf (folded .> ito (over _1 E.unValue . over _2 E.unValue)) fields + + ((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields + + formResult fieldsRes $ \newFields -> do + liftHandlerT . runDB . forM_ (Map.keysSet newFields `Set.union` Map.keysSet oldFields) $ \fieldId -> if + | Just forced <- Map.lookup fieldId newFields + , fieldId `Map.member` oldFields -> do + updateBy (UniqueExamOfficeField uid fieldId) [ ExamOfficeFieldForced =. forced ] + audit $ TransactionExamOfficeFieldEdit uid fieldId + | Just forced <- Map.lookup fieldId newFields -> do + insert_ $ ExamOfficeField uid fieldId forced + audit $ TransactionExamOfficeFieldEdit uid fieldId + | otherwise -> do + deleteBy $ UniqueExamOfficeField uid fieldId + audit $ TransactionExamOfficeFieldDelete uid fieldId + addMessageI Success $ MsgTransactionExamOfficeFieldsUpdated (Set.size . Set.map (view _1) $ (setSymmDiff `on` assocsSet) newFields oldFields) + redirect $ ExamOfficeR EOExamsR + + let + fieldsView' = wrapForm fieldsView def + { formAction = Just . SomeRoute $ ExamOfficeR EOFieldsR + , formEncoding = fieldsEnc + } + + siteLayoutMsg MsgMenuExamOfficeFields $ do + setTitleI MsgMenuExamOfficeFields + + [whamlet| + $newline never +

+ _{MsgExamOfficeSubscribedFieldsExplanation} + ^{fieldsView'} + |] + diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs new file mode 100644 index 000000000..0b004fb5f --- /dev/null +++ b/src/Handler/ExamOffice/Users.hs @@ -0,0 +1,102 @@ +module Handler.ExamOffice.Users + ( getEOUsersR + , postEOUsersR + ) where + +import Import +import Utils.Form +import Handler.Utils + +import qualified Database.Esqueleto as E + +import qualified Data.Set as Set +import Data.Map ((!)) + + +makeExamOfficeUsersForm :: Maybe (Set UserId) -> Form (Set 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 + MsgRenderer mr <- getMsgRenderer + (addRes, addView) <- mpreq userMatriculationField ("" & addName (nudge "matr") & addPlaceholder (mr MsgUserMatriculation)) Nothing + let + res' :: FormResult ([(UserId, _)] -> FormResult [(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 ] + return (res', $(widgetFile "widgets/massinput/examOfficeUsers/add")) + miCell' :: (UserId, (Maybe UserMatriculation, UserSurname, UserDisplayName)) -> Widget + miCell' (_, (userMatr, userSName, userDName)) = $(widgetFile "widgets/massinput/examOfficeUsers/cell") + miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction' frag = Just . SomeRoute $ cRoute :#: frag + miLayout' :: MassInputLayout ListLength _ () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examOfficeUsers/layout") + miIdent' :: Text + miIdent' = "exam-office-users" + fSettings :: FieldSettings UniWorX + fSettings = fslI MsgExamOfficeSubscribedUsers + & setTooltip MsgExamOfficeSubscribedUsersTip + 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)) + + fmap (Set.fromList . keys) <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired template' + + +-- | Manage the list of users this user (in her function as exam-office) +-- has an interest in, i.e. that authorize her to view their grades +getEOUsersR, postEOUsersR :: Handler Html +getEOUsersR = postEOUsersR +postEOUsersR = do + uid <- requireAuthId + + oldUsers <- liftHandlerT . runDB $ do + users <- E.select . E.from $ \(user `E.InnerJoin` examOfficeUser) -> 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 + + ((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 + addMessageI Success $ MsgTransactionExamOfficeUsersUpdated (Set.size $ changes `Set.intersection` oldUsers) (Set.size $ changes `Set.difference` oldUsers) + redirect $ ExamOfficeR EOExamsR + + let + usersView' = wrapForm usersView def + { formAction = Just . SomeRoute $ ExamOfficeR EOUsersR + , formEncoding = usersEnc + } + + siteLayoutMsg MsgMenuExamOfficeUsers $ do + setTitleI MsgMenuExamOfficeUsers + + [whamlet| + $newline never +

+ _{MsgExamOfficeSubscribedUsersExplanation} + ^{usersView'} + |] diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 7dc44c04a..a9b3331b8 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -932,10 +932,10 @@ boolField :: ( MonadHandler m ) => Field m Bool boolField = Field - { fieldParse = \e _ -> return $ boolParser e - , fieldView = \theId name attrs val isReq -> $(widgetFile "widgets/fields/bool") - , fieldEnctype = UrlEncoded - } + { fieldParse = \e _ -> return $ boolParser e + , fieldView = \theId name attrs val isReq -> $(widgetFile "widgets/fields/bool") + , fieldEnctype = UrlEncoded + } where boolParser [] = Right Nothing boolParser (x:_) = case x of @@ -1061,6 +1061,36 @@ formResultModal res finalDest handler = maybeT_ $ do forM_ messages $ \Message{..} -> addMessage messageStatus messageContent redirect finalDest +userMatriculationField :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => Field m [Entity User] +userMatriculationField = Field{..} + where + fieldEnctype = UrlEncoded + fieldView theId name attrs val isReq = do + let val' = val <&> Text.intercalate ", " . mapMaybe (userMatrikelnummer . entityVal) + [whamlet| + $newline never + + |] + fieldParse (all Text.null -> True) _ = return $ Right Nothing + fieldParse ts _ = runExceptT . fmap Just $ do + let ts' = concatMap (Text.splitOn ",") ts + forM ts' $ \matr -> do + dbRes <- liftHandlerT . runDB . E.select . E.from $ \user -> do + E.where_ $ E.strip (user E.^. UserMatrikelnummer) `E.ciEq` E.just (E.val $ Text.strip matr) + return user + case dbRes of + [user] + -> return user + [] + -> throwE . SomeMessage $ MsgUserMatriculationNotFound matr + _other + -> throwE . SomeMessage $ MsgUserMatriculationAmbiguous matr + + multiUserField :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index cf9681e0e..223695da4 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -43,6 +43,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthLecturer | AuthCorrector | AuthTutor + | AuthExamOffice | AuthAllocationRegistered | AuthCourseRegistered | AuthTutorialRegistered diff --git a/src/Utils.hs b/src/Utils.hs index fa6611f35..9f10f6da8 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -46,6 +46,7 @@ import qualified Data.Conduit.List as C import Control.Lens import Control.Lens as Utils (none) +import Data.Set.Lens import Control.Arrow as Utils ((>>>)) import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT) @@ -425,6 +426,12 @@ invertMap = groupMap . map swap . Map.toList countMapElems :: (Ord v) => Map k v -> Map v Int countMapElems = Map.fromListWith (+) . map (\(_k,v)->(v,1)) . Map.toList +mapSymmDiff :: (Ord k, Ord v) => Map k v -> Map k v -> Map k (Set v) +mapSymmDiff a b = Map.fromListWith Set.union . map (over _2 Set.singleton) . Set.toList $ (setSymmDiff `on` assocsSet) a b + +assocsSet :: Ord (k, v) => Map k v -> Set (k, v) +assocsSet = setOf folded . imap (,) + --------------- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 23aa34f6e..cb81aa99c 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -75,7 +75,7 @@ iconText = \case IconCourse -> "graduation-cap" IconEnrolTrue -> "user-plus" IconEnrolFalse -> "user-slash" - IconExam -> "file-invoice" + IconExam -> "poll-h" IconExamRegisterTrue -> "calendar-check" IconExamRegisterFalse -> "calendar-times" IconCommentTrue -> "comment-alt" diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index b8d237864..ad4dc26b9 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -16,6 +16,7 @@ import Control.Lens as Utils.Lens import Control.Lens.Extras as Utils.Lens (is) import Utils.Lens.TH as Utils.Lens import Data.Set.Lens as Utils.Lens +import Data.Map.Lens as Utils.Lens import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) @@ -76,7 +77,16 @@ makeClassyFor_ ''StudyDegree makeClassyFor_ ''StudyTerms -makeLenses_ ''Entity +_entityKey :: Getter (Entity record) (Key record) +-- ^ Not a `Lens'` for safety +_entityKey = to entityKey + +_entityVal :: IndexedLens (Key record) (Entity record) (Entity record) record record +_entityVal = ilens ((,) <$> entityKey <*> entityVal) (\e v -> e { entityVal = v }) + +_Entity :: PersistEntity record' => Iso (Entity record) (Entity record') (Key record, record) (Key record', record') +_Entity = iso ((,) <$> entityKey <*> entityVal) (uncurry Entity) + instance HasStudyFeatures a => HasStudyFeatures (Entity a) where hasStudyFeatures = _entityVal . hasStudyFeatures diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 44baa25d9..9cb58b2b0 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -174,18 +174,20 @@ h4 { > .container { margin: 20px 0; } +} +.main__content, .modal__content { a { text-decoration: underline; } - p { + p, form { margin: 0.5rem 0; &:last-child { margin: 0.5rem 0 0; - &:first-of-type { + &:first-child { margin: 0; } } diff --git a/templates/widgets/fields/examOfficeFieldMode.hamlet b/templates/widgets/fields/examOfficeFieldMode.hamlet new file mode 100644 index 000000000..09f3bd994 --- /dev/null +++ b/templates/widgets/fields/examOfficeFieldMode.hamlet @@ -0,0 +1,7 @@ +$newline never +

+ $forall opt <- universeF +
+ $with inputId <- mconcat [theId, "-", toPathPiece opt] + +