diff --git a/CHANGELOG.md b/CHANGELOG.md index 5ce661834..b0334821b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,20 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [20.14.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.13.0...v20.14.0) (2020-11-02) + + +### Features + +* **users:** assimilation ([ef51c6e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ef51c6e7c34effa691125e4313876d95feda96af)) + + +### Bug Fixes + +* **exam-users:** prevent exam results without registration via csv ([1c6ac4c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1c6ac4cb4a52ac7e69e615e0e3ff96432b173962)) +* work around conduit-bug releasing fh to early ([3ff2cf1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3ff2cf1fec1bf582fe1d5e1f6ee08dcc85d6bc00)) +* **exams:** error messages for foreign key constraint violations ([ca29a66](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ca29a66330a977a1f28bbdbe9a733aef10371427)) + ## [20.13.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.12.1...v20.13.0) (2020-10-20) diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 842b5fef1..2b492df10 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -732,6 +732,10 @@ section .uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label font-family: var(--font-monospace) +.shown + font-family: var(--font-monospace) + white-space: pre-wrap + .token font-family: var(--font-monospace) white-space: pre-wrap diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 53d55bc25..aea19e0bd 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -258,7 +258,9 @@ CourseApplicationInstructionsTip: Wird den Studierenden angezeigt, wenn diese si CourseApplicationTemplate: Bewerbungsvorlagen CourseApplicationTemplateTip: Werden den Studierenden zum download angeboten, wenn diese sich für Ihre Veranstaltung bewerben bzw. bei dieser anmelden CourseApplicationsText: Text-Bewerbungen -CourseApplicationsTextTip: Sollen die Studierenden Bewerbungen (ggf. zusätzlich zu abgegebenen Dateien) als unformatierten Text einreichen? +CourseApplicationsTextTip: Sollen die Studierenden bei Ihrer Bewerbung bzw. Anmeldung (ggf. zusätzlich zu abgegebenen Dateien) auch unformatierten Text einreichen können? +CourseApplicationsFiles: Bewerbungsdateien +CourseApplicationsFilesTip: Sollen die Studierenden bei Ihrer Bewerbung bzw. Anmeldung (ggf. zusätzlich zu unformatiertem Text) auch Dateien abgeben können? CourseApplicationRatingsVisible: Feedback für Bewerbungen CourseApplicationRatingsVisibleTip: Sollen Bewertung und Kommentar der Bewerbungen den Studierenden nach Ende der Bewertungs-Phase angezeigt werden? CourseApplicationRequired: Bewerbungsverfahren @@ -271,6 +273,8 @@ CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand CourseApplication: Bewerbung CourseApplicationIsParticipant: Kursteilnehmer +CourseApplicationInstructionsRecommended: Studierende können bei ihrer Anmeldung/Bewerbung nach aktuellen Einstellungen Texte bzw. Dateien abgeben. Es wurden jedoch keine Anweisungen zur Bewerbung oder Vorlage-Dateien hinterlegt. Sie sollten entweder keine Texte bzw. Dateien verlangen oder über Anweisungen bzw. Vorlagen klarstellen, was Sie von den Studierenden erwarten. + CourseApplicationExists: Sie haben sich bereits für diesen Kurs beworben CourseApplicationInvalidAction: Angegebene Aktion kann nicht durchgeführt werden CourseApplicationCreated csh@CourseShorthand: Erfolgreich zu #{csh} beworben @@ -300,6 +304,8 @@ CourseRegistrationFilesNeedReupload: Dateien zur Anmeldung müssen neu hochgelad CourseApplicationDeleteToEdit: Um Ihre Bewerbung zu editieren müssen Sie sie zunächst zurückziehen und sich erneut bewerben. CourseRegistrationDeleteToEdit: Um Ihre Anmeldungsdaten zu editieren müssen Sie sich zunächst ab- und dann erneut anmelden. +CourseDeregistrationNoReRegistration: Wenn Sie sich jetzt vom Kurs abmelden, können Sie sich nicht wieder selbstständig anmelden. + CourseLoginToApply: Um sich zum Kurz zu bewerben müssen Sie sich zunächst in Uni2work anmelden CourseLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden @@ -821,6 +827,12 @@ AccessRightsNotChanged: Berechtigungen wurden nicht verändert UserSystemFunctions: Systemweite Rollen UserSystemFunctionsSaved: Systemweite Rollen gespeichert UserSystemFunctionsNotChanged: Es wurden keine systemweiten Rollen angepasst +UserAssimilateUser: Benutzer +BtnUserAssimilate: Assimilieren +AssimilateUserNotFound: E-Mail Adresse konnte keinem Benutzer zugeordnet werden +AssimilateUserHaveError: Beim Assimilieren ist ein Fehler aufgetreten +AssimilateUserHaveWarnings: Beim Assimilieren wurden Warnungen ausgegeben +AssimilateUserSuccess: Benutzer erfolgreich assimiliert LecturersForN n@Int: #{pluralDE n "Dozent" "Dozenten"} @@ -2024,6 +2036,7 @@ ExamUsersResultsReset count@Int64: Prüfungsergebnis für #{show count} Teilnehm ExamUsersPartResultsSet count@Int64: Teilprüfungsergebnis für #{show count} Teilnehmer angepasst ExamUsersBonusSet count@Int64: Bonuspunkte für #{show count} Teilnehmer angepasst ExamUsersResultSet count@Int64: Prüfungsergebnis für #{show count} Teilnehmer angepasst +ExamUsersExamDataRequiresRegistration: Wenn Prüfungsbezogene Daten (Teil-/Ergebnis, Termin/Raum, Bonus) gesetzt bzw. angepasst werden sollen, muss der jeweilige Teilnehmer zur Prüfung angemeldet sein bzw. werden. CourseUserTutorialsDeregistered count@Int64: Teilnehmer von #{show count} #{pluralDE count "Tutorium" "Tutorien"} abgemeldet CourseUserNoTutorialsDeregistered: Teilnehmer ist zu keinem der gewählten Tutorien angemeldet CourseUserExamsDeregistered count@Int64: Teilnehmer von #{show count} #{pluralDE count "Prüfung" "Prüfungen"} abgemeldet @@ -2349,6 +2362,8 @@ UserDisplayEmail: Angezeigte E-Mail-Adresse UserDisplayEmailTip: Diese Adresse wird in öffentlich zugänglichen Teilen des Systems im Zusammenhang mit Ihrem Namen angezeigt. Benachrichtigungen und andere Kommunikation von Uni2work und Nutzern mit erweiterten Rechten erhalten sie stets, unabhängig von dieser Einstellung, an die in Ihren Persönlichen Daten hinterlegte primäre Adresse. UserDisplayEmailChangeSent displayEmail@UserEmail: Anweisungen zum Ändern der angezeigten E-Mail-Adresse wurden an „#{displayEmail}” versandt +UserCreated: Account erstellt + SchoolShort: Kürzel SchoolName: Name SchoolLdapOrganisations: Assoziierte LDAP-Fragmente @@ -2456,6 +2471,7 @@ AdminUserIdent: Identifikation AdminUserAuth: Authentifizierung AdminUserMatriculation: Matrikelnummer AdminUserSex: Geschlecht +AdminUserAssimilate: Benutzer assimilieren AuthKindLDAP: Campus-Kennung AuthKindPWHash: Uni2work-Kennung UserAdded: Benutzer erfolgreich angelegt diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 0aac8123f..60619430a 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -259,7 +259,9 @@ CourseApplicationInstructionsTip: Will be shown to students if they decide to ap CourseApplicationTemplate: Application template CourseApplicationTemplateTip: Students can download this template if they decide to apply for this course CourseApplicationsText: Text application -CourseApplicationsTextTip: Should students submit a plaintext application (in addition to submitted files if applicable)? +CourseApplicationsTextTip: Should students submit plaintext with their application/registration (in addition to submitted files if applicable)? +CourseApplicationsFiles: Application files +CourseApplicationsFilesTip: Should students submit files with their application/registration (in addition to plaintext if applicable)? CourseApplicationRatingsVisible: Feedback to applications CourseApplicationRatingsVisibleTip: Should students be allowed to view rating and comments on their application after the rating period? CourseApplicationRequired: Applications required @@ -272,6 +274,8 @@ CourseApplicationTemplateArchiveName tid ssh csh: #{foldCase (termToText (unTerm CourseApplication: Application CourseApplicationIsParticipant: Course participant +CourseApplicationInstructionsRecommended: Students can, as per the current course settings, submit files and/or texts with their applications/registrations. There are, however, no instructions for application or template files. You should either not require files/texts or clarify through instructions or templates what is expected of the students. + CourseApplicationExists: You already applied for this course CourseApplicationInvalidAction: Invalid action CourseApplicationCreated csh: Successfully applied for #{csh} @@ -301,6 +305,8 @@ CourseRegistrationFilesNeedReupload: Registration files need to be reuploaded ev CourseApplicationDeleteToEdit: You need to withdraw your application and reapply to edit your application. CourseRegistrationDeleteToEdit: You need to deregister and reregister to edit your registration. +CourseDeregistrationNoReRegistration: If you deregister from the course now, you will not be able to re-register yourself. + CourseLoginToApply: You need to login to Uni2work before you can apply for this course. CourseLoginToRegister: Your need to login to Uni2work before you can register for this course. @@ -818,6 +824,12 @@ AccessRightsNotChanged: Permissions left unchanged UserSystemFunctions: System wide roles UserSystemFunctionsSaved: Successfully saved system wide roles UserSystemFunctionsNotChanged: No system wide roles were changed +UserAssimilateUser: User +BtnUserAssimilate: Assimilate +AssimilateUserNotFound: Email could not be resolved to an user +AssimilateUserHaveError: An error occurred during assimilation +AssimilateUserHaveWarnings: Warnings were ermitted during assimilation +AssimilateUserSuccess: Successfully assimilated user LecturersForN n: #{pluralEN n "Lecturer" "Lecturers"} @@ -2023,6 +2035,7 @@ ExamUsersResultsReset count: Successfully reset result for #{show count} #{plura ExamUsersPartResultsSet count: Successfully modified exam part result for #{show count} #{pluralEN count "participant" "participants"} ExamUsersBonusSet count: Successfully modified exam bonus for #{show count} #{pluralEN count "participant" "participants"} ExamUsersResultSet count: Sucessfully modified exam result for #{show count} #{pluralEN count "participant" "participants"} +ExamUsersExamDataRequiresRegistration: If exam data (part-/result, occurrence/room, bonus) is to be modified/set, the relenvant participant needs to be registered for the exam. CourseUserTutorialsDeregistered count: Sucessfully deregistered participant from #{show count} #{pluralEN count "tutorial" "tutorials"} CourseUserNoTutorialsDeregistered: Participant is not registered for any of the selected tutorials CourseUserExamsDeregistered count: Successfully deregistered participant from #{show count} #{pluralEN count "exam" "exams"} @@ -2349,6 +2362,8 @@ UserDisplayEmail: Display email UserDisplayEmailTip: This email address may be displayed publicly alongside your display name. Notifications and other communication from Uni2work or users with elevated permissions are always sent to your primary email address as specified under "personal information". UserDisplayEmailChangeSent displayEmail: Instructions to change your display email have been sent to “#{displayEmail}”. +UserCreated: Account created + SchoolShort: Shorthand SchoolName: Name SchoolLdapOrganisations: Associated LDAP fragments @@ -2456,6 +2471,7 @@ AdminUserIdent: Identification AdminUserAuth: Authentication AdminUserMatriculation: Matriculation AdminUserSex: Sex +AdminUserAssimilate: Assimilate user AuthKindLDAP: Campus account AuthKindPWHash: Uni2work account UserAdded: Successfully added user diff --git a/models/allocations.model b/models/allocations.model index a8263979b..0bbebbea5 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -45,12 +45,14 @@ AllocationUser totalCourses Natural -- number of total allocated courses for this user must be <= than this number priority AllocationPriority Maybe UniqueAllocationUser allocation user + deriving Eq Ord Show AllocationDeregister -- self-inflicted user-deregistrations from an allocated course user UserId course CourseId Maybe time UTCTime reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button) + deriving Eq Ord Show AllocationNotificationSetting user UserId diff --git a/models/courses.model b/models/courses.model index 137c0cdf1..5ddc24d0f 100644 --- a/models/courses.model +++ b/models/courses.model @@ -60,6 +60,7 @@ CourseParticipant -- course enrolement allocated AllocationId Maybe -- participant was centrally allocated state CourseParticipantState UniqueParticipant user course + deriving Eq Ord Show -- Replace the last two by the following, once an audit log is available -- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student -- course CourseId diff --git a/models/exams.model b/models/exams.model index 68ed2a782..459cac9fb 100644 --- a/models/exams.model +++ b/models/exams.model @@ -43,24 +43,28 @@ ExamRegistration occurrence ExamOccurrenceId Maybe time UTCTime default=now() UniqueExamRegistration exam user + deriving Eq Ord Show ExamPartResult examPart ExamPartId user UserId result ExamResultPoints lastChanged UTCTime default=now() UniqueExamPartResult examPart user + deriving Eq Ord Show ExamBonus exam ExamId user UserId bonus Points lastChanged UTCTime default=now() UniqueExamBonus exam user + deriving Eq Ord Show ExamResult exam ExamId user UserId result ExamResultPassedGrade lastChanged UTCTime default=now() UniqueExamResult exam user + deriving Eq Ord Show ExamCorrector exam ExamId user UserId diff --git a/models/external-exams.model b/models/external-exams.model index 945284399..0efe62669 100644 --- a/models/external-exams.model +++ b/models/external-exams.model @@ -13,6 +13,7 @@ ExternalExamResult time UTCTime lastChanged UTCTime UniqueExternalExamResult exam user + deriving Eq Ord Show ExternalExamStaff user UserId exam ExternalExamId diff --git a/models/submissions.model b/models/submissions.model index f2c87fdc4..abfe0c6bd 100644 --- a/models/submissions.model +++ b/models/submissions.model @@ -31,3 +31,4 @@ SubmissionGroupUser -- Registered submission groups, just for check submissionGroup SubmissionGroupId user UserId UniqueSubmissionGroupUser submissionGroup user + deriving Eq Ord Show \ No newline at end of file diff --git a/models/tutorials.model b/models/tutorials.model index 3eb2b3fc8..113dc179b 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -21,3 +21,4 @@ TutorialParticipant tutorial TutorialId user UserId UniqueTutorialParticipant tutorial user + deriving Eq Ord Show diff --git a/package-lock.json b/package-lock.json index d52c1250a..8daf7f468 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.13.0", + "version": "20.14.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index c9ed90296..cd33e1246 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.13.0", + "version": "20.14.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index fa6071e8e..6dd206294 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.13.0 +version: 20.14.0 dependencies: - base diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 7b5757e94..84fd31336 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -170,6 +170,11 @@ data Transaction , transactionUser :: UserId } + | TransactionUserAssimilated + { transactionUser :: UserId + , transactionAssimilatedUser :: UserId + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 7db0e3c39..66061ec3e 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -4,7 +4,7 @@ module Database.Esqueleto.Utils ( true, false , justVal, justValList - , isJust + , isJust, alt , isInfixOf, hasInfix , strConcat, substring , or, and @@ -30,6 +30,7 @@ module Database.Esqueleto.Utils , selectCountRows , selectMaybe , day, diffDays + , exprLift , module Database.Esqueleto.Utils.TH ) where @@ -83,6 +84,9 @@ justValList = E.valList . map Just isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) isJust = E.not_ . E.isNothing +alt :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ)) +alt a b = E.case_ [(isJust a, a), (isJust b, b)] b + infix 4 `isInfixOf`, `hasInfix` -- | Check if the first string is contained in the text derived from the second argument @@ -388,3 +392,29 @@ infixl 6 `diffDays` diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) -- ^ PostgreSQL is weird. diffDays a b = E.veryUnsafeCoerceSqlExprValue $ a E.-. b + + +class ExprLift e a | e -> a where + exprLift :: a -> e + +instance PersistField a => ExprLift (E.SqlExpr (E.Value a)) a where + exprLift = E.val + +instance (PersistField a, PersistField b, Finite a) => ExprLift (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b)) (a -> b) where + exprLift f v = E.case_ + [ E.when_ (v E.==. E.val v') E.then_ (E.val $ f v') + | v' <- universeF + ] + (E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ())))) + +instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2) => ExprLift (E.SqlExpr (E.Value a1) -> E.SqlExpr (E.Value a2) -> E.SqlExpr (E.Value b)) (a1 -> a2 -> b) where + exprLift f v1 v2 = E.case_ + [ E.when_ ( v1 E.==. E.val v1' + E.&&. v2 E.==. E.val v2' + ) + E.then_ (E.val $ f v1' v2') + | v1' <- universeF + , v2' <- universeF + ] + (E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ())))) + diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 3f479f5df..ad088cbe3 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -40,7 +40,6 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Memo.Class (MonadMemo(..), for4) import Data.Aeson.Lens hiding (_Value, key) @@ -74,25 +73,27 @@ newtype InvalidAuthTag = InvalidAuthTag Text instance Exception InvalidAuthTag +type AuthTagsEval m = AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult + data AccessPredicate = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) | APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult) - | APDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult) + | APDB ((forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult) class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where - evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult + evalAccessPred :: AccessPredicate -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where - evalAccessPred aPred aid r w = liftHandler $ case aPred of + evalAccessPred aPred cont aid r w = liftHandler $ case aPred of (APPure p) -> runReader (p aid r w) <$> getMsgRenderer (APHandler p) -> p aid r w - (APDB p) -> runDBRead $ p aid r w + (APDB p) -> runDBRead $ p cont aid r w instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX) => MonadAP (ReaderT backend m) where - evalAccessPred aPred aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of + evalAccessPred aPred cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer (APHandler p) -> lift $ p aid r w - (APDB p) -> p aid r w + (APDB p) -> p cont aid r w orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult @@ -170,7 +171,9 @@ isDryRun = $cachedHere . liftHandler $ orM noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar dnf <- either throwM return $ routeAuthTags currentRoute - guardAuthResult <=< fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) mAuthId currentRoute isWrite + let eval :: forall m'. MonadAP m' => AuthTagsEval m' + eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite' + in guardAuthResult <=< fmap fst . runWriterT $ eval dnf mAuthId currentRoute isWrite return False @@ -222,6 +225,8 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val noTokenAuth :: AuthDNF -> AuthDNF noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar + eval :: forall m'. MonadAP m' => AuthTagsEval m' + eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite'' guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority forM_ bearerAuthority' $ \uid -> do @@ -230,12 +235,12 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val authorityVal <- do dnf <- either throwM return $ routeAuthTags route - fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just uid) route isWrite + fmap fst . runWriterT $ eval (noTokenAuth dnf) (Just uid) route isWrite guardExceptT (is _Authorized authorityVal) authorityVal whenIsJust bearerAddAuth $ \addDNF -> do $logDebugS "validateToken" $ tshow addDNF - additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite + additionalVal <- fmap fst . runWriterT $ eval (noTokenAuth addDNF) mAuthId route isWrite guardExceptT (is _Authorized additionalVal) additionalVal return Authorized @@ -287,7 +292,7 @@ maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do tagAccessPredicate :: BearerAuthSite UniWorX => AuthTag -> AccessPredicate tagAccessPredicate AuthFree = trueAP -tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthAdmin = APDB $ \_ mAuthId route _ -> case route of -- Courses: access only to school admins CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId @@ -324,12 +329,12 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) return Authorized -tagAccessPredicate AuthSystemExamOffice = APDB $ \mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do +tagAccessPredicate AuthSystemExamOffice = APDB $ \_ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False] guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice return Authorized -tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthExamOffice = APDB $ \_ mAuthId route _ -> case route of CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do @@ -367,7 +372,7 @@ tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice) return Authorized -tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthEvaluation = APDB $ \_ mAuthId route _ -> case route of ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation @@ -383,7 +388,7 @@ tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation] guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation return Authorized -tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthAllocationAdmin = APDB $ \_ mAuthId route _ -> case route of AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation @@ -399,9 +404,9 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route o isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation] guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin return Authorized -tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ +tagAccessPredicate AuthToken = APDB $ \_ mAuthId route isWrite -> exceptT return return $ lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe -tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthNoEscalation = APDB $ \_ mAuthId route _ -> case route of AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do myUid <- maybeExceptT AuthenticationRequired $ return mAuthId uid <- decrypt cID @@ -422,7 +427,7 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do #else return $ Unauthorized "Route under development" #endif -tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthLecturer = APDB $ \_ mAuthId route _ -> case route of CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do @@ -461,7 +466,7 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of authId <- maybeExceptT AuthenticationRequired $ return mAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] [] return Authorized -tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do +tagAccessPredicate AuthCorrector = APDB $ \_ mAuthId route _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId @@ -489,7 +494,7 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret _ -> do guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) return Authorized -tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthExamCorrector = APDB $ \_ mAuthId route _ -> case route of CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do @@ -514,7 +519,7 @@ tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector return Authorized r -> $unsupportedAuthPredicate AuthExamCorrector r -tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do +tagAccessPredicate AuthTutor = APDB $ \_ mAuthId route _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId @@ -537,14 +542,14 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return _ -> do guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) return Authorized -tagAccessPredicate AuthTutorControl = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthTutorControl = APDB $ \_ _ route _ -> case route of CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn guard tutorialTutorControlled return Authorized r -> $unsupportedAuthPredicate AuthTutorControl r -tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthSubmissionGroup = APDB $ \_ mAuthId route _ -> case route of CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn @@ -569,7 +574,7 @@ tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route o return Authorized r -> $unsupportedAuthPredicate AuthSubmissionGroup r -tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthTime = APDB $ \(runTACont -> cont) mAuthId route isWrite -> case route of CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn @@ -669,9 +674,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh CRegisterR -> do now <- liftIO getCurrentTime mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh - registered <- case (mbc,mAuthId) of - (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive] - _ -> return False + registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite case mbc of (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) | not registered @@ -751,7 +754,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of return Authorized r -> $unsupportedAuthPredicate AuthTime r -tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of +tagAccessPredicate AuthStaffTime = APDB $ \_ _ route isWrite -> case route of CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course @@ -776,16 +779,14 @@ tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of return Authorized r -> $unsupportedAuthPredicate AuthStaffTime r -tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthAllocationTime = APDB $ \(runTACont -> cont) mAuthId route isWrite -> case route of CourseR tid ssh csh CRegisterR -> do now <- liftIO getCurrentTime mba <- mbAllocation tid ssh csh case mba of Nothing -> return Authorized - Just (cid, Allocation{..}) -> do - registered <- case mAuthId of - Just uid -> $cachedHereBinary (uid, cid) $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] - _ -> return False + Just (_, Allocation{..}) -> do + registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite if | not registered , NTop allocationRegisterByCourse >= NTop (Just now) @@ -822,7 +823,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid (cid,) <$> MaybeT (get allocationCourseAllocation) -tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of +tagAccessPredicate AuthCourseTime = APDB $ \_ _mAuthId route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do now <- liftIO getCurrentTime courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do @@ -833,7 +834,7 @@ tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime) return Authorized r -> $unsupportedAuthPredicate AuthCourseTime r -tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthCourseRegistered = APDB $ \_ mAuthId route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do @@ -846,7 +847,7 @@ tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthCourseRegistered r -tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthTutorialRegistered = APDB $ \_ mAuthId route _ -> case route of CTutorialR tid ssh csh tutn _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do @@ -871,7 +872,7 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthTutorialRegistered r -tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ _ route _ -> case route of CExamR tid ssh csh examn _ -> exceptT return return $ do isOccurrenceRegistration <- $cachedHereBinary (tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam) -> do E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse @@ -883,7 +884,7 @@ tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case ro guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration) return Authorized r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r -tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \_ mAuthId route _ -> case route of CExamR tid ssh csh examn (ERegisterOccR occn) -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn, occn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do @@ -924,7 +925,7 @@ tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> cas guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r -tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthExamRegistered = APDB $ \_ mAuthId route _ -> case route of CExamR tid ssh csh examn _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do @@ -965,7 +966,7 @@ tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredAnyExam return Authorized r -> $unsupportedAuthPredicate AuthExamRegistered r -tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthExamResult = APDB $ \_ mAuthId route _ -> case route of CExamR tid ssh csh examn _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do @@ -1018,14 +1019,14 @@ tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult) return Authorized r -> $unsupportedAuthPredicate AuthExamRegistered r -tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthAllocationRegistered = APDB $ \_ mAuthId route _ -> case route of AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do uid <- hoistMaybe mAuthId aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid return Authorized r -> $unsupportedAuthPredicate AuthAllocationRegistered r -tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthParticipant = APDB $ \_ mAuthId route _ -> case route of CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedParticipantSelf) $ do nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId @@ -1133,7 +1134,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthApplicant = APDB $ \_ mAuthId route _ -> case route of CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID isApplicant <- isCourseApplicant tid ssh csh uid @@ -1154,7 +1155,7 @@ tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthCapacity = APDB $ \_ _ route _ -> case route of CExamR tid ssh csh examn (ERegisterOccR occn) -> maybeT (unauthorizedI MsgExamOccurrenceNoCapacity) $ do cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh eid <- $cachedHereBinary (cid, examn) . MaybeT . getKeyBy $ UniqueExam cid examn @@ -1174,7 +1175,7 @@ tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> $unsupportedAuthPredicate AuthCapacity r -tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthRegisterGroup = APDB $ \_ mAuthId route _ -> case route of CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn @@ -1190,7 +1191,7 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of guard $ not hasOther return Authorized r -> $unsupportedAuthPredicate AuthRegisterGroup r -tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthEmpty = APDB $ \_ mAuthId route _ -> case route of EExamListR -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do @@ -1211,20 +1212,20 @@ tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> case route of E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return Authorized r -> $unsupportedAuthPredicate AuthEmpty r -tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthMaterials = APDB $ \_ _ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh guard courseMaterialFree return Authorized r -> $unsupportedAuthPredicate AuthMaterials r -tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthOwner = APDB $ \_ mAuthId route _ -> case route of CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID authId <- maybeExceptT AuthenticationRequired $ return mAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid return Authorized r -> $unsupportedAuthPredicate AuthOwner r -tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \_ mAuthId route _ -> case route of CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh @@ -1239,28 +1240,28 @@ tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count return Authorized r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r -tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthRated = APDB $ \_ _ route _ -> case route of CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sub <- MaybeT $ get sid guard $ submissionRatingDone sub return Authorized r -> $unsupportedAuthPredicate AuthRated r -tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthUserSubmissions = APDB $ \_ _ route _ -> case route of CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn guard $ is _Just submissionModeUser return Authorized r -> $unsupportedAuthPredicate AuthUserSubmissions r -tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of +tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ _ route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn guard submissionModeCorrector return Authorized r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r -tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do +tagAccessPredicate AuthSelf = APDB $ \_ mAuthId route _ -> exceptT return return $ do referencedUser' <- case route of AdminUserR cID -> return $ Left cID AdminUserDeleteR cID -> return $ Left cID @@ -1281,7 +1282,7 @@ tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ | uid == referencedUser -> return Authorized Nothing -> return AuthenticationRequired _other -> unauthorizedI MsgUnauthorizedSelf -tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do +tagAccessPredicate AuthIsLDAP = APDB $ \_ _ route _ -> exceptT return return $ do referencedUser <- case route of AdminUserR cID -> return cID AdminUserDeleteR cID -> return cID @@ -1295,7 +1296,7 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do User{..} <- MaybeT $ get referencedUser' guard $ userAuthentication == AuthLDAP return Authorized -tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do +tagAccessPredicate AuthIsPWHash = APDB $ \_ _ route _ -> exceptT return return $ do referencedUser <- case route of AdminUserR cID -> return cID AdminUserDeleteR cID -> return cID @@ -1309,7 +1310,7 @@ tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ d User{..} <- MaybeT $ get referencedUser' guard $ is _AuthPWHash userAuthentication return Authorized -tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthAuthentication = APDB $ \_ mAuthId route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId @@ -1330,6 +1331,11 @@ tagAccessPredicate AuthWrite = APPure $ \_ _ isWrite -> do MsgRenderer mr <- ask return $ bool (Unauthorized $ mr MsgUnauthorized) Authorized isWrite +runTACont :: forall m. MonadAP m + => (forall m'. MonadAP m' => AuthTagsEval m') + -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m Bool +runTACont cont dnf mAuthId route isWrite = is _Authorized . fst <$> runWriterT (cont dnf mAuthId route isWrite) + authTagSpecificity :: AuthTag -> AuthTag -> Ordering -- ^ Heuristic for which `AuthTag`s to evaluate first @@ -1371,9 +1377,9 @@ routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partiti | otherwise = Left $ InvalidAuthTag t -evalAuthTags :: forall m. MonadAP m => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult +evalAuthTags :: forall ctx m. (Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m -- ^ `tell`s disabled predicates, identified as pivots -evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite +evalAuthTags ctx AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite = do mr <- getMsgRenderer let @@ -1383,11 +1389,11 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf authTagIsInactive = not . authTagIsActive evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult - evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite + evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (ctx, AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for5 memo (const evalAccessPred') ctx authTag mAuthId route isWrite where evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite') - evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite' + evalAccessPred (tagAccessPredicate authTag') cont mAuthId' route' isWrite' evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult evalAuthLiteral PLVariable{..} = evalAuthTag plVar @@ -1419,7 +1425,9 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessFor mAuthId route isWrite = do dnf <- either throwM return $ routeAuthTags route - fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite + let eval :: forall m'. MonadAP m' => AuthTagsEval m' + eval dnf' mAuthId' route' isWrite' = evalAuthTags 'evalAccessFor (AuthTagActive $ const True) eval dnf' mAuthId' route' isWrite' + in fmap fst . runWriterT $ eval dnf mAuthId route isWrite evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessForDB = evalAccessFor @@ -1427,14 +1435,16 @@ evalAccessForDB = evalAccessFor evalAccessWith :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult evalAccessWith assumptions route isWrite = do mAuthId <- liftHandler maybeAuthId - tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags + (tagActive :: AuthTagActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags dnf <- either throwM return $ routeAuthTags route - let dnf' = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) $ Just dnf - case dnf' of - Nothing -> return Authorized - Just dnf'' -> do - (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite - result <$ tellSessionJson SessionInactiveAuthTags deactivated + let adjDNF = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) . Just + evalAdj :: forall m'. MonadAP m' => AuthTagsEval m' + evalAdj (adjDNF -> dnf') mAuthId' route' isWrite' = case dnf' of + Nothing -> return Authorized + Just dnf'' -> evalAuthTags ('evalAccessWith, assumptions) tagActive evalAdj dnf'' mAuthId' route' isWrite' + in do + (result, deactivated) <- runWriterT $ evalAdj dnf mAuthId route isWrite + result <$ tellSessionJson SessionInactiveAuthTags deactivated evalAccessWithDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessWithDB = evalAccessWith diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 4827b3583..ec8242bab 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -37,7 +37,6 @@ import Foundation.DB import Network.Wai.Parse (lbsBackEnd) -import Control.Monad.Writer.Class (MonadWriter(..)) import UnliftIO.Pool (withResource) diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index 52ca3f87c..d2dc89459 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -40,6 +40,26 @@ deriving instance Generic CourseNewsR deriving instance Generic CourseEventR deriving instance Generic (Route UniWorX) +instance Ord (Route Auth) where + compare = compare `on` renderRoute +instance Ord (Route EmbeddedStatic) where + compare = compare `on` renderRoute + +deriving instance Ord CourseR +deriving instance Ord SheetR +deriving instance Ord SubmissionR +deriving instance Ord MaterialR +deriving instance Ord TutorialR +deriving instance Ord ExamR +deriving instance Ord EExamR +deriving instance Ord CourseApplicationR +deriving instance Ord AllocationR +deriving instance Ord SchoolR +deriving instance Ord ExamOfficeR +deriving instance Ord CourseNewsR +deriving instance Ord CourseEventR +deriving instance Ord (Route UniWorX) + data RouteChildren type instance Children RouteChildren a = ChildrenRouteChildren a type family ChildrenRouteChildren a where diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index e1b515e98..3d6f747c5 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -40,7 +40,6 @@ import qualified Data.Binary as Binary import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -import Control.Monad.Writer.Class (MonadWriter(..)) import Crypto.Hash.Conduit (sinkHash) diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 3c9fb713c..4c6206205 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -15,9 +15,6 @@ import qualified Network.Wai as W import qualified Data.Aeson as JSON import qualified Data.CaseInsensitive as CI -import Control.Monad.Reader.Class (MonadReader(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) - import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild)) diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 57ed2f2db..8e9f53d79 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -402,6 +402,7 @@ postCApplicationsR tid ssh csh = do CourseApplicationsTableCsvSetRatingData{} -> CourseApplicationsTableCsvSetRating CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment , dbtCsvCoarsenActionClass = const DBCsvActionExisting + , dbtCsvValidateActions = return () , dbtCsvExecuteActions = do C.mapM_ $ \case CourseApplicationsTableCsvSetVetoData{..} -> do diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 9071a9ef0..d1a340740 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -305,7 +305,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB <*> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template) <*> aopt (multiFileField' . fromMaybe (return ()) $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template) <*> apopt checkBoxField (fslI MsgCourseApplicationsText & setTooltip MsgCourseApplicationsTextTip) (cfAppText <$> template) - <*> uploadModeForm (cfAppFiles <$> template) + <*> uploadModeForm (fslI MsgCourseApplicationsFiles & setTooltip MsgCourseApplicationsFilesTip) (fmap cfAppFiles template <|> pure NoUpload) <*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template) <*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template) @@ -376,6 +376,10 @@ validateCourse = do $ length (CI.original cfShort) <= 10 warnValidation MsgCourseNotAlwaysVisibleDuringRegistration $ NTop cfVisFrom <= NTop cfRegFrom && NTop cfRegTo <= NTop cfVisTo + + warnValidation MsgCourseApplicationInstructionsRecommended + $ (is _Just cfAppInstructions || is _Just cfAppInstructionFiles) + || not (cfAppText || isn't _NoUpload cfAppFiles) getCourseNewR :: Handler Html -- call via toTextUrl diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 92297d3d9..331f94461 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -1,7 +1,7 @@ module Handler.Course.Register ( ButtonCourseRegister(..) , CourseRegisterForm(..) - , courseRegisterForm + , courseRegisterForm, courseMayReRegister , getCRegisterR, postCRegisterR , deregisterParticipant ) where @@ -147,18 +147,29 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do E.||. isCourseExamCorrector muid ata (course E.^. CourseId) ) + mayReRegister <- liftHandler . runDB . courseMayReRegister $ Entity cid Course{..} + when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $ wformMessage =<< messageIconI Warning IconExamRegisterFalse MsgCourseDeregistrationAllocationLog when (is _Just (registration >>= courseParticipantAllocated . entityVal) && courseDeregisterNoShow) $ wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoShow when (isRegistered && not mayViewCourseAfterDeregistration) $ wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationFromInvisibleCourse + unless mayReRegister $ + wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoReRegistration return $ CourseRegisterForm <$ secretRes <*> appTextRes <*> appFilesRes +courseMayReRegister :: Entity Course -> DB Bool +courseMayReRegister (Entity cid Course{..}) = do + registrations <- count [ CourseParticipantState ==. CourseParticipantActive, CourseParticipantCourse ==. cid ] + let capacity = maybe True (>= registrations) courseCapacity + + wouldHaveWriteAccessTo [(AuthCapacity, capacity), (AuthCourseRegistered, False)] $ CourseR courseTerm courseSchool courseShorthand CRegisterR + -- | Workaround for klicking register button without being logged in. -- After log in, the user sees a "get request not supported" error. @@ -273,7 +284,6 @@ deleteApplicationFiles appId = deleteWhere [ CourseApplicationFileApplication == deregisterParticipant :: UserId -> CourseId -> DB () deregisterParticipant uid cid = do - deleteApplications uid cid part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid forM_ part $ \(Entity partId CourseParticipant{}) -> do update partId [CourseParticipantState =. CourseParticipantInactive False] diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 619c79818..f34d5048f 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -28,7 +28,7 @@ getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId now <- liftIO getCurrentTime - (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen) <- runDB . maybeT notFound $ do + (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -106,7 +106,9 @@ getCShowR tid ssh csh = do return $ submissionGroup E.^. SubmissionGroupName let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup' - return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen) + mayReRegister <- lift . courseMayReRegister $ Entity cid course + + return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister) let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) mDereg' diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 30b351113..6e76ed20b 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -43,6 +43,8 @@ import Control.Lens.Indexed ((<.), (.>)) import Jobs.Queue +import qualified Control.Monad.State.Class as State + type ExamUserTableExpr = ( E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User) @@ -613,8 +615,7 @@ postEUsersR tid ssh csh examn = do -> error "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys" DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do (isPart, uid) <- lift $ guessUser' dbCsvNew - unless isPart $ - yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupOccurrence dbCsvNew + yieldM $ bool ExamUserCsvCourseRegisterData ExamUserCsvRegisterData isPart uid <$> lookupOccurrence dbCsvNew iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes -> when (epNumber `elem` examPartNumbers) $ @@ -706,6 +707,22 @@ postEUsersR tid ssh csh examn = do ExamUserCsvRegister -> DBCsvActionNew ExamUserCsvDeregister -> DBCsvActionMissing _other -> DBCsvActionExisting + , dbtCsvValidateActions = do + selectedActions <- State.get + availableActions <- ask + let missingExamDataUsers = flip filter examDataUsers $ \uid -> any (isRegisterAction uid) availableActions && none (isRegisterAction uid) selectedActions + where + examDataUsers = flip mapMaybe selectedActions $ \case + ExamUserCsvSetResultData{..} -> Just examUserCsvActUser + ExamUserCsvSetBonusData{..} -> Just examUserCsvActUser + ExamUserCsvSetPartResultData{..} -> Just examUserCsvActUser + _other -> Nothing + isRegisterAction uid = \case + ExamUserCsvCourseRegisterData{..} -> uid == examUserCsvActUser + ExamUserCsvRegisterData{..} -> uid == examUserCsvActUser + _other -> False + unless (null missingExamDataUsers) $ + tellMPoint $ messageI Error MsgExamUsersExamDataRequiresRegistration , dbtCsvExecuteActions = do C.mapM_ $ \case ExamUserCsvCourseRegisterData{..} -> do diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e2ff11b91..2c58b0b5a 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -552,8 +552,6 @@ makeProfileData (Entity uid User{..}) = do examTable = i18n MsgPersonalInfoExamAchievementsWip ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip tutorialTable = i18n MsgPersonalInfoTutorialsWip - lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication - lastLdapSync <- traverse (formatTime SelFormatDateTime) userLastLdapSynchronisation cID <- encrypt uid mCRoute <- getCurrentRoute diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 96a285ce0..0bdc3c963 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -53,18 +53,16 @@ hijackUserForm csrf = do data UserAction = UserLdapSync | UserHijack deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) -instance Universe UserAction -instance Finite UserAction nullaryPathPiece ''UserAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''UserAction id data AllUsersAction = AllUsersLdapSync deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) -instance Universe AllUsersAction -instance Finite AllUsersAction nullaryPathPiece ''AllUsersAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''AllUsersAction id @@ -277,6 +275,19 @@ instance Button UniWorX ButtonAuthMode where btnClasses _ = [BCIsButton] +data UserAssimilateButton = BtnUserAssimilate + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) + +instance Button UniWorX UserAssimilateButton where + btnClasses _ = [BCIsButton, BCPrimary] + +nullaryPathPiece ''UserAssimilateButton $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''UserAssimilateButton id + + + + getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html getAdminUserR = postAdminUserR postAdminUserR uuid = do @@ -393,9 +404,33 @@ postAdminUserR uuid = do | otherwise -> addMessageI Info MsgUserSystemFunctionsNotChanged redirect $ AdminUserR uuid - ((rightsResult, rightsFormWidget),rightsFormEnctype) <- runFormPost userRightsForm - ((authResult, authFormWidget),authFormEnctype) <- runFormPost userAuthenticationForm - ((systemFunctionsResult, systemFunctionsWidget),systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm' + let assimilateForm' = renderAForm FormStandard $ + areq (checkMap (first $ const MsgAssimilateUserNotFound) Right $ userField False Nothing) (fslI MsgUserAssimilateUser) Nothing + assimilateAction oldUserId = do + res <- try . runDB . setSerializable $ assimilateUser uid oldUserId + case res of + Left (err :: UserAssimilateException) -> + addMessageModal Error (i18n MsgAssimilateUserHaveError) $ Right + [whamlet| +
+ #{tshow err} + |] + Right warnings -> do + unless (null warnings) $ + addMessageModal Warning (i18n MsgAssimilateUserHaveWarnings) $ Right + [whamlet| + $newline never +