fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

Merge branch 'master' into stundenplan

Browse Source
This commit is contained in:
Sarah Vaupel 2020-11-03 23:11:25 +01:00
commit 51984cde87
49 changed files with 1031 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
CHANGELOG.md
View File

@ -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)

4
frontend/src/app.sass
View File

@ -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

18
messages/uniworx/de-de-formal.msg
View File

@ -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

18
messages/uniworx/en-eu.msg
View File

@ -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

2
models/allocations.model
View File

@ -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

1
models/courses.model
View File

@ -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

4
models/exams.model
View File

@ -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

1
models/external-exams.model
View File

@ -13,6 +13,7 @@ ExternalExamResult
time UTCTime
lastChanged UTCTime
UniqueExternalExamResult exam user
deriving Eq Ord Show
ExternalExamStaff
user UserId
exam ExternalExamId

1
models/submissions.model
View File

@ -31,3 +31,4 @@ SubmissionGroupUser -- Registered submission groups, just for check
submissionGroup SubmissionGroupId
user UserId
UniqueSubmissionGroupUser submissionGroup user
deriving Eq Ord Show

1
models/tutorials.model
View File

@ -21,3 +21,4 @@ TutorialParticipant
tutorial TutorialId
user UserId
UniqueTutorialParticipant tutorial user
deriving Eq Ord Show

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "20.13.0",
"version": "20.14.0",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

2
package.json
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "20.13.0",
"version": "20.14.0",
"description": "",
"keywords": [],
"author": "",

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 20.13.0
version: 20.14.0
dependencies:
- base

5
src/Audit/Types.hs
View File

@ -170,6 +170,11 @@ data Transaction
, transactionUser :: UserId
}
| TransactionUserAssimilated
{ transactionUser :: UserId
, transactionAssimilatedUser :: UserId
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions

32
src/Database/Esqueleto/Utils.hs
View File

@ -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 ()))))

146
src/Foundation/Authorization.hs
View File

@ -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

1
src/Foundation/Instances.hs
View File

@ -37,7 +37,6 @@ import Foundation.DB
import Network.Wai.Parse (lbsBackEnd)
import Control.Monad.Writer.Class (MonadWriter(..))
import UnliftIO.Pool (withResource)

20
src/Foundation/Routes.hs
View File

@ -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

1
src/Foundation/Yesod/Auth.hs
View File

@ -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)

3
src/Foundation/Yesod/Middleware.hs
View File

@ -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))

1
src/Handler/Course/Application/List.hs
View File

@ -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

6
src/Handler/Course/Edit.hs
View File

@ -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

14
src/Handler/Course/Register.hs
View File

@ -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]

6
src/Handler/Course/Show.hs
View File

@ -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'

21
src/Handler/Exam/Users.hs
View File

@ -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

2
src/Handler/Profile.hs
View File

@ -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

56
src/Handler/Users.hs
View File

@ -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|
<div .shown>
#{tshow err}
|]
Right warnings -> do
unless (null warnings) $
addMessageModal Warning (i18n MsgAssimilateUserHaveWarnings) $ Right
[whamlet|
$newline never
<ul>
$forall warning <- warnings
<li .shown>
#{tshow warning}
|]
addMessageI Success MsgAssimilateUserSuccess
redirect $ AdminUserR uuid
((rightsResult, rightsFormWidget), rightsFormEnctype) <- runFormPost . identifyForm FIDUserRights $ userRightsForm
((authResult, authFormWidget), authFormEnctype) <- runFormPost . identifyForm FIDUserAuthentication $ userAuthenticationForm
((systemFunctionsResult, systemFunctionsWidget), systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm'
((assimilateFormResult, assimilateFormWidget), assimilateFormEnctype) <- runFormPost $ identifyForm FIDUserAssimilate assimilateForm'
let rightsForm = wrapForm rightsFormWidget def
{ formAction = Just . SomeRoute $ AdminUserR uuid
, formEncoding = rightsFormEnctype
@ -409,9 +444,14 @@ postAdminUserR uuid = do
{ formAction = Just . SomeRoute $ AdminUserR uuid
, formEncoding = systemFunctionsEnctype
}
assimilateForm = wrapForm' BtnUserAssimilate assimilateFormWidget def
{ formAction = Just . SomeRoute $ AdminUserR uuid
, formEncoding = assimilateFormEnctype
}
formResult rightsResult userRightsAction
formResult authResult userAuthenticationAction
formResult systemFunctionsResult userSystemFunctionsAction
formResult assimilateFormResult assimilateAction
let heading =
[whamlet|_{MsgAdminUserHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|]
-- Delete Button needed in data-delete
@ -423,7 +463,7 @@ postAdminUserR uuid = do
}
userDataWidget <- runDB $ makeProfileData $ Entity uid user
siteLayout heading $ do
let deleteWidget = $(i18nWidgetFile "data-delete")
let _deleteWidget = $(i18nWidgetFile "data-delete")
$(widgetFile "adminUser")

1
src/Handler/Utils/ExternalExam/Users.hs
View File

@ -446,6 +446,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
when (csvEUserExamResult /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultResult) $
yield $ ExternalExamUserCsvSetResultData (E.unValue dbCsvOldKey) csvEUserExamResult
, dbtCsvValidateActions = return ()
, dbtCsvClassifyAction = \case
ExternalExamUserCsvRegisterData{} -> ExternalExamUserCsvRegister
ExternalExamUserCsvSetTimeData{} -> ExternalExamUserCsvSetTime

9
src/Handler/Utils/Form.hs
View File

@ -48,7 +48,6 @@ import qualified Data.Vector as Vector
import qualified Data.HashMap.Lazy as HashMap
import Control.Monad.Writer.Class
import Control.Monad.Error.Class (MonadError(..))
import Data.Aeson (eitherDecodeStrict')
@ -582,8 +581,8 @@ studyFeaturesFieldFor mRestr isOptional oldFeatures mbuid = selectField $ do
}
uploadModeForm :: Maybe UploadMode -> AForm Handler UploadMode
uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUploadMode <$> prev)
uploadModeForm :: FieldSettings UniWorX -> Maybe UploadMode -> AForm Handler UploadMode
uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
where
actions :: Map UploadModeDescr (AForm Handler UploadMode)
actions = Map.fromList
@ -679,10 +678,10 @@ submissionModeForm prev = explainedMultiActionA actions opts (fslI MsgSheetSubmi
, pure $ SubmissionMode True Nothing
)
, ( SubmissionModeUser
, SubmissionMode False . Just <$> uploadModeForm (prev ^? _Just . _submissionModeUser . _Just)
, SubmissionMode False . Just <$> uploadModeForm (fslI MsgSheetUploadMode) (prev ^? _Just . _submissionModeUser . _Just)
)
, ( SubmissionModeBoth
, SubmissionMode True . Just <$> uploadModeForm (prev ^? _Just . _submissionModeUser . _Just)
, SubmissionMode True . Just <$> uploadModeForm (fslI MsgSheetUploadMode) (prev ^? _Just . _submissionModeUser . _Just)
)
]

2
src/Handler/Utils/Form/MassInput.hs
View File

@ -31,8 +31,6 @@ import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Foldable as Fold
import Control.Monad.Reader.Class (MonadReader(local))
import Text.Hamlet (hamletFile)
import Algebra.Lattice.Ordered (Ordered(..))

2
src/Handler/Utils/Table/Cells.hs
View File

@ -2,8 +2,6 @@ module Handler.Utils.Table.Cells where
import Import hiding (link)
import Control.Monad.Writer.Class (MonadWriter(..))
import Text.Blaze (ToMarkup(..))
import Handler.Utils.Table.Pagination

40
src/Handler/Utils/Table/Pagination.hs
View File

@ -69,7 +69,7 @@ import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
import qualified Network.Wai as Wai
import Control.Monad.RWS (RWST(..), execRWS)
import Control.Monad.RWS (RWST(..), execRWS, execRWST)
import Control.Monad.State (evalStateT, execStateT)
import Control.Monad.Trans.Maybe
import Control.Monad.State.Class (modify)
@ -420,6 +420,9 @@ data DBCsvException k'
{ dbCsvExceptionRow :: NamedRecord
, dbCsvException :: Text
}
| DBCsvUnavailableActionRequested
{ dbCsvActions :: Set Value
}
deriving (Show, Typeable)
makeLenses_ ''DBCsvException
@ -598,6 +601,7 @@ data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException
) => DBTCsvDecode
{ dbtCsvRowKey :: csv -> MaybeT DB k'
, dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction DB ()
, dbtCsvValidateActions :: RWST (Set csvAction) [Message] [csvAction] DB ()
, dbtCsvClassifyAction :: csvAction -> csvActionClass
, dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
, dbtCsvExecuteActions :: ConduitT csvAction Void (YesodJobDB UniWorX) route
@ -1177,6 +1181,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
<input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} :defaultChecked (dbtCsvClassifyAction act):checked>
|]
fieldView sJsonField (actionIdent act) (toPathPiece PostDBCsvImportAction) vAttrs (Right act) False
availableActs :: Widget
availableActs = fieldView (secretJsonField :: Field Handler (Set csvAction)) "" (toPathPiece PostDBCsvImportAvailableActions) [] (Right . Set.unions $ Map.elems actionMap) False
(csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandler . generateFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm (FIDDBTableCsvImportConfirm dbtIdent) $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
let csvImportConfirmForm = wrapForm csvImportConfirmForm' FormSettings
{ formMethod = POST
@ -1231,6 +1237,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
<section>
^{csvReImport}
|]
other -> throwM other
, Catch.Handler $ \(csvParseError :: CsvParseError)
-> liftHandler $ sendResponseStatus badRequest400 =<< do
mr <- getMessageRender
@ -1389,18 +1396,29 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
]
((csvImportConfirmRes, _confirmView), _enctype) <- case dbtCsvDecode of
Just (DBTCsvDecode{dbtCsvExecuteActions} :: DBTCsvDecode r' k' csv) -> do
Just (DBTCsvDecode{dbtCsvExecuteActions, dbtCsvValidateActions} :: DBTCsvDecode r' k' csv) -> do
lift . runFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm (FIDDBTableCsvImportConfirm dbtIdent) $ \_csrf -> do
availableActs <- fromMaybe Set.empty <$> globalPostParamField PostDBCsvImportAvailableActions secretJsonField
acts <- globalPostParamFields PostDBCsvImportAction secretJsonField
return . (, mempty) $ if
| null acts -> FormSuccess $ do
addMessageI Info MsgCsvImportAborted
redirect $ tblLink id
| otherwise -> FormSuccess $ do
finalDest <- runDBJobs' . runConduit $ C.sourceList acts .| dbtCsvExecuteActions
addMessageI Success . MsgCsvImportSuccessful $ length acts
E.transactionSave
redirect finalDest
return . (, mempty) . FormSuccess $ if
| unavailableActs <- filter (`Set.notMember` availableActs) acts
, not $ null unavailableActs -> do
throwM . DBCsvUnavailableActionRequested @k' . Set.fromList $ map toJSON unavailableActs
| otherwise -> do
(acts', validationMsgs) <- execRWST dbtCsvValidateActions availableActs acts
if | not $ null validationMsgs -> do
mapM_ addMessage' validationMsgs
E.transactionUndo
redirect $ tblLink id
| null acts' -> do
addMessageI Info MsgCsvImportAborted
redirect $ tblLink id
| otherwise -> do
finalDest <- runDBJobs' . runConduit $ C.sourceList acts' .| dbtCsvExecuteActions
addMessageI Success . MsgCsvImportSuccessful $ length acts'
E.transactionSave
redirect finalDest
_other -> return ((FormMissing, mempty), mempty)
formResult csvImportConfirmRes $ \case
(_, BtnCsvImportAbort) -> do

609
src/Handler/Utils/Users.hs
View File

@ -6,6 +6,8 @@ module Handler.Utils.Users
, matchesName
, GuessUserInfo(..)
, guessUser
, UserAssimilateException(..), UserAssimilateExceptionReason(..)
, assimilateUser
) where
import Import
@ -19,17 +21,23 @@ import Data.Maybe (fromJust)
import qualified Data.List.NonEmpty as NonEmpty (fromList)
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E
import qualified Data.Conduit.Combinators as C
import qualified Data.MultiSet as MultiSet
import qualified Data.Map as Map
import qualified Data.Text as Text
import Jobs.Types(Job, JobChildren)
computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
computeUserAuthenticationDigest = hashlazy . JSON.encode
@ -172,3 +180,604 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
-> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes
| otherwise
-> return Nothing
data UserAssimilateException = UserAssimilateException
{ userAssimilateOldUser, userAssimilateNewUser :: UserId
, userAssimilateException :: UserAssimilateExceptionReason
} deriving (Eq, Ord, Show, Generic, Typeable)
deriving anyclass (Exception)
data UserAssimilateExceptionReason
= UserAssimilateExternalExamResultDifferentResult (Entity ExternalExamResult) (Entity ExternalExamResult)
| UserAssimilateCourseParticipantDifferentAllocation (Entity CourseParticipant) (Entity CourseParticipant)
| UserAssimilateSubmissionGroupUserMultiple (Entity SubmissionGroupUser) (Entity SubmissionGroupUser)
| UserAssimilateAllocationUserDifferentPriority (Entity AllocationUser) (Entity AllocationUser)
| UserAssimilateAllocationDeregisterDuplicateCourse (Entity AllocationDeregister) (Entity AllocationDeregister)
| UserAssimilateExamRegistrationDifferentOccurrence (Entity ExamRegistration) (Entity ExamRegistration)
| UserAssimilateExamPartResultDifferentResult (Entity ExamPartResult) (Entity ExamPartResult)
| UserAssimilateExamBonusDifferentBonus (Entity ExamBonus) (Entity ExamBonus)
| UserAssimilateExamResultDifferentResult (Entity ExamResult) (Entity ExamResult)
| UserAssimilatePersonalisedSheetFileDifferentContent (Entity PersonalisedSheetFile) (Entity PersonalisedSheetFile)
| UserAssimilateTutorialParticipantCollidingRegGroups (Entity TutorialParticipant) (Entity TutorialParticipant)
deriving (Eq, Ord, Show, Generic, Typeable)
assimilateUser :: UserId -- ^ @newUserId@
-> UserId -- ^ @oldUserId@
-> DB (Set UserAssimilateException) -- ^ Warnings
-- ^ Move all relevant properties (submissions, corrections, grades, ...) from @oldUserId@ to @newUserId@
--
-- Fatal errors are thrown, non-fatal warnings are returned
assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
E.insertSelectWithConflict
UniqueCourseFavourite
(E.from $ \courseFavourite -> do
E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId
return $ CourseFavourite
E.<# E.val newUserId
E.<&> (courseFavourite E.^. CourseFavouriteCourse)
E.<&> (courseFavourite E.^. CourseFavouriteReason)
E.<&> (courseFavourite E.^. CourseFavouriteLastVisit)
)
(\current excluded -> [ CourseFavouriteLastVisit E.=. E.max (current E.^. CourseFavouriteLastVisit) (excluded E.^. CourseFavouriteLastVisit) ])
deleteWhere [ CourseFavouriteUser ==. oldUserId ]
E.insertSelectWithConflict
UniqueCourseNoFavourite
(E.from $ \courseNoFavourite -> do
E.where_ $ courseNoFavourite E.^. CourseNoFavouriteUser E.==. E.val oldUserId
return $ CourseNoFavourite
E.<# E.val newUserId
E.<&> (courseNoFavourite E.^. CourseNoFavouriteCourse)
)
(\_current _excluded -> [])
deleteWhere [ CourseNoFavouriteUser ==. oldUserId ]
let getCourseApplications = selectSource [ CourseApplicationUser ==. oldUserId ] []
upsertCourseApplication (Entity oldAppId oldApp) = do
newApp <- selectList [CourseApplicationUser ==. newUserId, CourseApplicationCourse ==. courseApplicationCourse oldApp, CourseApplicationAllocation ==. courseApplicationAllocation oldApp] [LimitTo 1]
case newApp of
(_ : _) -> return ()
[] -> do
newAppId <- insert oldApp
{ courseApplicationUser = newUserId
}
updateWhere [ CourseApplicationFileApplication ==. oldAppId ] [ CourseApplicationFileApplication =. newAppId ]
delete oldAppId
in runConduit $ getCourseApplications .| C.mapM_ upsertCourseApplication
E.insertSelectWithConflict
UniqueExamOfficeField
(E.from $ \examOfficeField -> do
E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val oldUserId
return $ ExamOfficeField
E.<# E.val newUserId
E.<&> (examOfficeField E.^. ExamOfficeFieldField)
E.<&> (examOfficeField E.^. ExamOfficeFieldForced)
)
(\current excluded -> [ ExamOfficeFieldForced E.=. (current E.^. ExamOfficeFieldForced E.||. excluded E.^. ExamOfficeFieldForced) ])
deleteWhere [ ExamOfficeFieldOffice ==. oldUserId ]
E.insertSelectWithConflict
UniqueExamOfficeUser
(E.from $ \examOfficeUser -> do
E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val oldUserId
return $ ExamOfficeUser
E.<# E.val newUserId
E.<&> (examOfficeUser E.^. ExamOfficeUserUser)
)
(\_current _excluded -> [])
deleteWhere [ ExamOfficeUserOffice ==. oldUserId ]
E.insertSelectWithConflict
UniqueExamOfficeUser
(E.from $ \examOfficeUser -> do
E.where_ $ examOfficeUser E.^. ExamOfficeUserUser E.==. E.val oldUserId
return $ ExamOfficeUser
E.<# (examOfficeUser E.^. ExamOfficeUserOffice)
E.<&> E.val newUserId
)
(\_current _excluded -> [])
deleteWhere [ ExamOfficeUserUser ==. oldUserId ]
E.insertSelect . E.from $ \examOfficeResultSynced -> do
E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. E.val oldUserId
return $ ExamOfficeResultSynced
E.<# (examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool)
E.<&> E.val newUserId
E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedResult)
E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedTime)
deleteWhere [ ExamOfficeResultSyncedOffice ==. oldUserId ]
E.insertSelect . E.from $ \examOfficeExternalResultSynced -> do
E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. E.val oldUserId
return $ ExamOfficeExternalResultSynced
E.<# (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool)
E.<&> E.val newUserId
E.<&> (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedResult)
E.<&> (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedTime)
deleteWhere [ ExamOfficeExternalResultSyncedOffice ==. oldUserId ]
let getExternalExamResults = selectSource [ ExternalExamResultUser ==. oldUserId ] []
upsertExternalExamResult oldEEREnt@(Entity oldEERId oldEER) = do
newEER' <- getBy $ UniqueExternalExamResult (externalExamResultExam oldEER) newUserId
newEERId <- case newEER' of
Just newEEREnt@(Entity _ newEER)
| ((/=) `on` externalExamResultResult) newEER oldEER
|| ((/=) `on` externalExamResultTime) newEER oldEER
-> tellError $ UserAssimilateExternalExamResultDifferentResult oldEEREnt newEEREnt
Just (Entity newEERId newEER) -> newEERId <$ update newEERId
[ ExternalExamResultLastChanged =. (max `on` externalExamResultLastChanged) oldEER newEER
]
Nothing -> insert oldEER
{ externalExamResultUser = newUserId
}
updateWhere [ ExamOfficeExternalResultSyncedResult ==. oldEERId ] [ ExamOfficeExternalResultSyncedResult =. newEERId ]
delete oldEERId
in runConduit $ getExternalExamResults .| C.mapM_ upsertExternalExamResult
E.insertSelectWithConflict
UniqueExternalExamStaff
(E.from $ \externalExamStaff -> do
E.where_ $ externalExamStaff E.^. ExternalExamStaffUser E.==. E.val oldUserId
return $ ExternalExamStaff
E.<# E.val newUserId
E.<&> (externalExamStaff E.^. ExternalExamStaffExam)
)
(\_current _excluded -> [])
deleteWhere [ ExternalExamStaffUser ==. oldUserId ]
updateWhere [ SubmissionRatingBy ==. Just oldUserId ] [ SubmissionRatingBy =. Just newUserId ]
updateWhere [ SubmissionEditUser ==. Just oldUserId ] [ SubmissionEditUser =. Just newUserId ]
E.insertSelectWithConflict
UniqueSubmissionUser
(E.from $ \submissionUser -> do
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val oldUserId
return $ SubmissionUser
E.<# E.val newUserId
E.<&> (submissionUser E.^. SubmissionUserSubmission)
)
(\_current _excluded -> [])
deleteWhere [ SubmissionUserUser ==. oldUserId ]
do
collisions <- E.select . E.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do
E.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
E.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
E.&&. submissionGroupUserA E.^. SubmissionGroupUserUser E.==. E.val oldUserId
E.&&. submissionGroupUserB E.^. SubmissionGroupUserUser E.==. E.val newUserId
E.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup
E.where_ $ submissionGroupA E.^. SubmissionGroupCourse E.==. submissionGroupB E.^. SubmissionGroupCourse
return (submissionGroupUserA, submissionGroupUserB)
forM_ collisions $ \(submissionGroupUserA, submissionGroupUserB) ->
tellWarning $ UserAssimilateSubmissionGroupUserMultiple submissionGroupUserA submissionGroupUserB
E.insertSelectWithConflict
UniqueSubmissionGroupUser
(E.from $ \submissionGroupUser -> do
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val oldUserId
return $ SubmissionGroupUser
E.<# (submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup)
E.<&> E.val newUserId
)
(\_current _excluded -> [])
deleteWhere [ SubmissionGroupUserUser ==. oldUserId ]
updateWhere [ TransactionLogInitiator ==. Just oldUserId ] [ TransactionLogInitiator =. Just newUserId ]
-- We're not updating info; doing that would probably be too slow
-- Just check for `TransactionUserAssimilated` entries and correct manually
updateWhere [ CourseEditUser ==. oldUserId ] [ CourseEditUser =. newUserId ]
E.insertSelectWithConflict
UniqueLecturer
(E.from $ \lecturer -> do
E.where_ $ lecturer E.^. LecturerUser E.==. E.val oldUserId
return $ Lecturer
E.<# E.val newUserId
E.<&> (lecturer E.^. LecturerCourse)
E.<&> (lecturer E.^. LecturerType)
)
(\_current excluded -> [ LecturerType E.=. excluded E.^. LecturerType ])
deleteWhere [ LecturerUser ==. oldUserId ]
do
collision <- E.selectMaybe . E.from $ \(courseParticipantA `E.InnerJoin` courseParticipantB) -> do
E.on $ courseParticipantA E.^. CourseParticipantCourse E.==. courseParticipantB E.^. CourseParticipantCourse
E.&&. courseParticipantA E.^. CourseParticipantUser E.==. E.val oldUserId
E.&&. courseParticipantB E.^. CourseParticipantUser E.==. E.val newUserId
E.where_ . E.isJust $ courseParticipantA E.^. CourseParticipantAllocated
E.where_ . E.isJust $ courseParticipantB E.^. CourseParticipantAllocated
return (courseParticipantA, courseParticipantB)
whenIsJust collision $ \(oldParticipant, newParticipant)
-> tellError $ UserAssimilateCourseParticipantDifferentAllocation oldParticipant newParticipant
E.insertSelectWithConflict
UniqueParticipant
(E.from $ \courseParticipant -> do
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val oldUserId
return $ CourseParticipant
E.<# (courseParticipant E.^. CourseParticipantCourse)
E.<&> E.val newUserId
E.<&> (courseParticipant E.^. CourseParticipantRegistration)
E.<&> (courseParticipant E.^. CourseParticipantAllocated)
E.<&> (courseParticipant E.^. CourseParticipantState)
)
(\current excluded ->
[ CourseParticipantState E.=. E.exprLift min (current E.^. CourseParticipantState) (excluded E.^. CourseParticipantState)
, CourseParticipantRegistration E.=. E.max (current E.^. CourseParticipantRegistration) (excluded E.^. CourseParticipantRegistration)
, CourseParticipantAllocated E.=. E.alt (current E.^. CourseParticipantAllocated) (excluded E.^. CourseParticipantAllocated)
]
)
deleteWhere [ CourseParticipantUser ==. oldUserId ]
let getCourseUserNotes = selectSource [ CourseUserNoteUser ==. oldUserId ] []
upsertCourseUserNote (Entity oldCUNId oldCUN) = do
collision <- getBy $ UniqueCourseUserNote newUserId (courseUserNoteCourse oldCUN)
newCUNId <- case collision of
Nothing -> oldCUNId <$ update oldCUNId [ CourseUserNoteUser =. newUserId ]
Just (Entity newCUNId newCUN) -> newCUNId <$ update newCUNId [ CourseUserNoteNote =. ((<>) `on` courseUserNoteNote) oldCUN newCUN ]
when (newCUNId /= oldCUNId) $
updateWhere [CourseUserNoteEditNote ==. oldCUNId] [CourseUserNoteEditNote =. newCUNId]
delete oldCUNId
in runConduit $ getCourseUserNotes .| C.mapM_ upsertCourseUserNote
updateWhere [ CourseUserNoteEditUser ==. oldUserId ] [ CourseUserNoteEditUser =. newUserId ]
E.insertSelectWithConflict
UniqueCourseUserExamOfficeOptOut
(E.from $ \examOfficeOptOut -> do
E.where_ $ examOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. E.val oldUserId
return $ CourseUserExamOfficeOptOut
E.<# (examOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse)
E.<&> E.val newUserId
E.<&> (examOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool)
)
(\_current _excluded -> [])
deleteWhere [ CourseUserExamOfficeOptOutUser ==. oldUserId ]
E.insertSelectWithConflict
UniqueUserFunction
(E.from $ \userFunction -> do
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val oldUserId
return $ UserFunction
E.<# E.val newUserId
E.<&> (userFunction E.^. UserFunctionSchool)
E.<&> (userFunction E.^. UserFunctionFunction)
)
(\_current _excluded -> [])
deleteWhere [ UserFunctionUser ==. oldUserId ]
E.insertSelectWithConflict
UniqueUserSystemFunction
(E.from $ \userSystemFunction -> do
E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. E.val oldUserId
return $ UserSystemFunction
E.<# E.val newUserId
E.<&> (userSystemFunction E.^. UserSystemFunctionFunction)
E.<&> (userSystemFunction E.^. UserSystemFunctionManual)
E.<&> (userSystemFunction E.^. UserSystemFunctionIsOptOut)
)
(\current excluded -> [ UserSystemFunctionManual E.=. (current E.^. UserSystemFunctionManual E.||. excluded E.^. UserSystemFunctionManual), UserSystemFunctionIsOptOut E.=. (current E.^. UserSystemFunctionIsOptOut E.&&. excluded E.^. UserSystemFunctionIsOptOut) ])
deleteWhere [ UserSystemFunctionUser ==. oldUserId ]
E.insertSelectWithConflict
UniqueUserExamOffice
(E.from $ \userExamOffice -> do
E.where_ $ userExamOffice E.^. UserExamOfficeUser E.==. E.val oldUserId
return $ UserExamOffice
E.<# E.val newUserId
E.<&> (userExamOffice E.^. UserExamOfficeField)
)
(\_current _excluded -> [])
deleteWhere [ UserExamOfficeUser ==. oldUserId ]
E.insertSelectWithConflict
UniqueUserSchool
(E.from $ \userSchool -> do
E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val oldUserId
return $ UserSchool
E.<# E.val newUserId
E.<&> (userSchool E.^. UserSchoolSchool)
E.<&> (userSchool E.^. UserSchoolIsOptOut)
)
(\current excluded -> [ UserSchoolIsOptOut E.=. (current E.^. UserSchoolIsOptOut E.&&. excluded E.^. UserSchoolIsOptOut) ])
deleteWhere [ UserSchoolUser ==. oldUserId ]
updateWhere [ UserGroupMemberUser ==. oldUserId, UserGroupMemberPrimary ==. Active ] [ UserGroupMemberUser =. newUserId ]
E.insertSelectWithConflict
UniqueUserGroupMember
(E.from $ \userGroupMember -> do
E.where_ $ userGroupMember E.^. UserGroupMemberUser E.==. E.val oldUserId
return $ UserGroupMember
E.<# (userGroupMember E.^. UserGroupMemberGroup)
E.<&> E.val newUserId
E.<&> (userGroupMember E.^. UserGroupMemberPrimary)
)
(\_current _excluded -> [])
deleteWhere [ UserGroupMemberUser ==. oldUserId ]
do
collisions <- E.select . E.from $ \(allocationUserA `E.InnerJoin` allocationUserB) -> do
E.on $ allocationUserA E.^. AllocationUserAllocation E.==. allocationUserB E.^. AllocationUserAllocation
E.&&. allocationUserA E.^. AllocationUserUser E.==. E.val oldUserId
E.&&. allocationUserB E.^. AllocationUserUser E.==. E.val newUserId
E.where_ $ allocationUserA E.^. AllocationUserPriority E.!=. allocationUserB E.^. AllocationUserPriority
return (allocationUserA, allocationUserB)
forM_ collisions $ \(oldAllocUser, newAllocUser)
-> tellWarning $ UserAssimilateAllocationUserDifferentPriority oldAllocUser newAllocUser
E.insertSelectWithConflict
UniqueAllocationUser
(E.from $ \allocationUser -> do
E.where_ $ allocationUser E.^. AllocationUserUser E.==. E.val oldUserId
return $ AllocationUser
E.<# (allocationUser E.^. AllocationUserAllocation)
E.<&> E.val newUserId
E.<&> (allocationUser E.^. AllocationUserTotalCourses)
E.<&> (allocationUser E.^. AllocationUserPriority)
)
(\current excluded -> [ AllocationUserTotalCourses E.=. E.max (current E.^. AllocationUserTotalCourses) (excluded E.^. AllocationUserTotalCourses) ])
deleteWhere [ AllocationUserUser ==. oldUserId ]
do
collisions <- E.select . E.from $ \(allocationDeregisterA `E.InnerJoin` allocationDeregisterB) -> do
E.on $ allocationDeregisterA E.^. AllocationDeregisterCourse E.==. allocationDeregisterB E.^. AllocationDeregisterCourse
E.&&. allocationDeregisterA E.^. AllocationDeregisterUser E.==. E.val oldUserId
E.&&. allocationDeregisterB E.^. AllocationDeregisterUser E.==. E.val newUserId
return (allocationDeregisterA, allocationDeregisterB)
forM_ collisions $ \(oldAllocationDeregister, newAllocationDeregister) ->
tellWarning $ UserAssimilateAllocationDeregisterDuplicateCourse oldAllocationDeregister newAllocationDeregister
updateWhere [ AllocationDeregisterUser ==. oldUserId ] [ AllocationDeregisterUser =. newUserId ]
E.insertSelectWithConflict
UniqueAllocationNotificationSetting
(E.from $ \allocNotifySetting -> do
E.where_ $ allocNotifySetting E.^. AllocationNotificationSettingUser E.==. E.val oldUserId
return $ AllocationNotificationSetting
E.<# E.val newUserId
E.<&> (allocNotifySetting E.^. AllocationNotificationSettingAllocation)
E.<&> (allocNotifySetting E.^. AllocationNotificationSettingIsOptOut)
)
(\current excluded -> [ AllocationNotificationSettingIsOptOut E.=. (current E.^. AllocationNotificationSettingIsOptOut E.||. excluded E.^. AllocationNotificationSettingIsOptOut) ])
deleteWhere [ AllocationNotificationSettingUser ==. oldUserId ]
do
collisions <- E.select . E.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do
E.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam
E.&&. examRegistrationA E.^. ExamRegistrationUser E.==. E.val oldUserId
E.&&. examRegistrationB E.^. ExamRegistrationUser E.==. E.val newUserId
E.where_ $ examRegistrationA E.^. ExamRegistrationOccurrence E.!=. examRegistrationB E.^. ExamRegistrationOccurrence
E.&&. E.isJust (examRegistrationA E.^. ExamRegistrationOccurrence)
E.&&. E.isJust (examRegistrationB E.^. ExamRegistrationOccurrence)
return (examRegistrationA, examRegistrationB)
forM_ collisions $ \(oldExamRegistration, newExamRegistration)
-> tellWarning $ UserAssimilateExamRegistrationDifferentOccurrence oldExamRegistration newExamRegistration
E.insertSelectWithConflict
UniqueExamRegistration
(E.from $ \examRegistration -> do
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val oldUserId
return $ ExamRegistration
E.<# (examRegistration E.^. ExamRegistrationExam)
E.<&> E.val newUserId
E.<&> (examRegistration E.^. ExamRegistrationOccurrence)
E.<&> (examRegistration E.^. ExamRegistrationTime)
)
(\current excluded -> [ ExamRegistrationOccurrence E.=. E.alt (current E.^. ExamRegistrationOccurrence) (excluded E.^. ExamRegistrationOccurrence), ExamRegistrationTime E.=. E.min (current E.^. ExamRegistrationTime) (excluded E.^. ExamRegistrationTime) ])
deleteWhere [ ExamRegistrationUser ==. oldUserId ]
do
collision <- E.selectMaybe . E.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do
E.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart
E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId
E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId
E.where_ $ examPartResultA E.^. ExamPartResultResult E.!=. examPartResultB E.^. ExamPartResultResult
return (examPartResultA, examPartResultB)
whenIsJust collision $ \(oldExamPartResult, newExamPartResult)
-> tellError $ UserAssimilateExamPartResultDifferentResult oldExamPartResult newExamPartResult
E.insertSelectWithConflict
UniqueExamPartResult
(E.from $ \examPartResult -> do
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val oldUserId
return $ ExamPartResult
E.<# (examPartResult E.^. ExamPartResultExamPart)
E.<&> E.val newUserId
E.<&> (examPartResult E.^. ExamPartResultResult)
E.<&> (examPartResult E.^. ExamPartResultLastChanged)
)
(\current excluded -> [ ExamPartResultLastChanged E.=. E.max (current E.^. ExamPartResultLastChanged) (excluded E.^. ExamPartResultLastChanged) ])
deleteWhere [ ExamPartResultUser ==. oldUserId ]
do
collision <- E.selectMaybe . E.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
E.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam
E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId
E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId
E.where_ $ examBonusA E.^. ExamBonusBonus E.!=. examBonusB E.^. ExamBonusBonus
return (examBonusA, examBonusB)
whenIsJust collision $ \(oldExamBonus, newExamBonus)
-> tellError $ UserAssimilateExamBonusDifferentBonus oldExamBonus newExamBonus
E.insertSelectWithConflict
UniqueExamBonus
(E.from $ \examBonus -> do
E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val oldUserId
return $ ExamBonus
E.<# (examBonus E.^. ExamBonusExam)
E.<&> E.val newUserId
E.<&> (examBonus E.^. ExamBonusBonus)
E.<&> (examBonus E.^. ExamBonusLastChanged)
)
(\current excluded -> [ ExamBonusLastChanged E.=. E.max (current E.^. ExamBonusLastChanged) (excluded E.^. ExamBonusLastChanged) ])
deleteWhere [ ExamBonusUser ==. oldUserId ]
let getExamResults = selectSource [ ExamResultUser ==. oldUserId ] []
upsertExamResult oldEREnt@(Entity oldERId oldER) = do
newER' <- getBy $ UniqueExamResult (examResultExam oldER) newUserId
newERId <- case newER' of
Just newEREnt@(Entity _ newER)
| ((/=) `on` examResultResult) newER oldER
-> tellError $ UserAssimilateExamResultDifferentResult oldEREnt newEREnt
Just (Entity newERId newER) -> newERId <$ update newERId
[ ExamResultLastChanged =. (max `on` examResultLastChanged) oldER newER
]
Nothing -> insert oldER
{ examResultUser = newUserId
}
updateWhere [ ExamOfficeResultSyncedResult ==. oldERId ] [ ExamOfficeResultSyncedResult =. newERId ]
delete oldERId
in runConduit $ getExamResults .| C.mapM_ upsertExamResult
let getExamCorrectors = selectSource [ ExamCorrectorUser ==. oldUserId ] []
upsertExamCorrector (Entity oldECId examCorrector) = do
Entity newECId _ <- upsert examCorrector{ examCorrectorUser = newUserId } []
E.insertSelectWithConflict
UniqueExamPartCorrector
(E.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do
E.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector
E.where_ $ examCorrector' E.^. ExamCorrectorUser E.==. E.val oldUserId
E.&&. examCorrector' E.^. ExamCorrectorExam E.==. E.val (examCorrectorExam examCorrector)
return $ ExamPartCorrector
E.<# (examPartCorrector E.^. ExamPartCorrectorPart)
E.<&> E.val newECId
)
(\_current _excluded -> [])
deleteWhere [ ExamPartCorrectorCorrector ==. oldECId ]
delete oldECId
in runConduit $ getExamCorrectors .| C.mapM_ upsertExamCorrector
let getQueuedJobs = selectSource [] []
updateQueuedJob (Entity jId QueuedJob{..}) = maybeT (return ()) $ do
(content' :: Job) <- hoistMaybe $ JSON.parseMaybe parseJSON queuedJobContent
let uContent' = set (typesUsing @JobChildren . filtered (== oldUserId)) newUserId content'
guard $ uContent' /= content'
lift $ update jId [ QueuedJobContent =. toJSON uContent' ]
in runConduit $ getQueuedJobs .| C.mapM_ updateQueuedJob
updateWhere [ SentNotificationUser ==. oldUserId ] [ SentNotificationUser =. newUserId ]
updateWhere [ SheetEditUser ==. oldUserId] [ SheetEditUser =. newUserId ]
let getSheetPseudonyms = selectSource [ SheetPseudonymUser ==. oldUserId ] []
upsertSheetPseudonym (Entity oldSPId oldSP) = do
collision <- existsBy $ UniqueSheetPseudonymUser (sheetPseudonymSheet oldSP) newUserId
if
| collision -> delete oldSPId
| otherwise -> update oldSPId [ SheetPseudonymUser =. newUserId ]
in runConduit $ getSheetPseudonyms .| C.mapM_ upsertSheetPseudonym
let getSheetCorrectors = selectSource [ SheetCorrectorUser ==. oldUserId ] []
upsertSheetCorrector (Entity oldSCId oldSheetCorrector) = do
collision <- getBy $ UniqueSheetCorrector newUserId (sheetCorrectorSheet oldSheetCorrector)
case collision of
Nothing -> update oldSCId [ SheetCorrectorUser =. newUserId ]
Just (Entity newSCId newSheetCorrector) -> do
update newSCId
[ SheetCorrectorLoad =. (sheetCorrectorLoad oldSheetCorrector <> sheetCorrectorLoad newSheetCorrector)
, SheetCorrectorState =. (min `on` sheetCorrectorState) oldSheetCorrector newSheetCorrector
]
delete oldSCId
in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector
do
collision <- E.selectMaybe . E.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do
E.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet
E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType
E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle
E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
E.&&. personalisedSheetFileB E.^. PersonalisedSheetFileUser E.==. E.val newUserId
E.where_ . E.not_ $ personalisedSheetFileA E.^. PersonalisedSheetFileContent `E.maybeEq` personalisedSheetFileB E.^. PersonalisedSheetFileContent
return (personalisedSheetFileA, personalisedSheetFileB)
whenIsJust collision $ \(oldPersonalisedSheetFile, newPersonalisedSheetFile)
-> tellError $ UserAssimilatePersonalisedSheetFileDifferentContent oldPersonalisedSheetFile newPersonalisedSheetFile
E.insertSelectWithConflict
UniquePersonalisedSheetFile
(E.from $ \personalisedSheetFile -> do
E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
return $ PersonalisedSheetFile
E.<# (personalisedSheetFile E.^. PersonalisedSheetFileSheet)
E.<&> E.val newUserId
E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileType)
E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileTitle)
E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileContent)
E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileModified)
)
(\current excluded -> [ PersonalisedSheetFileModified E.=. E.max (current E.^. PersonalisedSheetFileModified) (excluded E.^. PersonalisedSheetFileModified) ])
deleteWhere [ PersonalisedSheetFileUser ==. oldUserId ]
E.insertSelectWithConflict
UniqueTutor
(E.from $ \tutor -> do
E.where_ $ tutor E.^. TutorUser E.==. E.val oldUserId
return $ Tutor
E.<# (tutor E.^. TutorTutorial)
E.<&> E.val newUserId
)
(\_current _excluded -> [])
do
collision <- E.selectMaybe . E.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do
E.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId
E.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse
E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId
E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId
E.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId
E.where_ $ tutorialA E.^. TutorialId E.!=. tutorialB E.^. TutorialId
E.&&. tutorialA E.^. TutorialRegGroup E.==. tutorialB E.^. TutorialRegGroup
return (tutorialParticipantA, tutorialParticipantB)
whenIsJust collision $ \(tutorialUserA, tutorialUserB)
-> tellError $ UserAssimilateTutorialParticipantCollidingRegGroups tutorialUserA tutorialUserB
E.insertSelectWithConflict
UniqueTutorialParticipant
(E.from $ \tutorialParticipant -> do
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId
return $ TutorialParticipant
E.<# (tutorialParticipant E.^. TutorialParticipantTutorial)
E.<&> E.val newUserId
)
(\_current _excluded -> [])
deleteWhere [ TutorialParticipantUser ==. oldUserId ]
E.insertSelectWithConflict
UniqueSystemMessageHidden
(E.from $ \systemMessageHidden -> do
E.where_ $ systemMessageHidden E.^. SystemMessageHiddenUser E.==. E.val oldUserId
return $ SystemMessageHidden
E.<# (systemMessageHidden E.^. SystemMessageHiddenMessage)
E.<&> E.val newUserId
E.<&> (systemMessageHidden E.^. SystemMessageHiddenTime)
)
(\current excluded -> [ SystemMessageHiddenTime E.=. E.max (current E.^. SystemMessageHiddenTime) (excluded E.^. SystemMessageHiddenTime) ])
deleteWhere [ SystemMessageHiddenUser ==. oldUserId ]
let getStudyFeatures = selectSource [ StudyFeaturesUser ==. oldUserId ] []
upsertStudyFeatures (Entity oldSFId oldStudyFeatures) = do
collision <- getBy $ UniqueStudyFeatures newUserId (studyFeaturesDegree oldStudyFeatures) (studyFeaturesField oldStudyFeatures) (studyFeaturesType oldStudyFeatures) (studyFeaturesSemester oldStudyFeatures)
case collision of
Nothing -> update oldSFId [ StudyFeaturesUser =. newUserId ]
Just (Entity newSFId newStudyFeatures) -> do
update newSFId
[ StudyFeaturesSuperField =. ((<|>) `on` studyFeaturesSuperField) newStudyFeatures oldStudyFeatures
, StudyFeaturesFirstObserved =. (min `on` studyFeaturesFirstObserved) oldStudyFeatures newStudyFeatures
, StudyFeaturesLastObserved =. (max `on` studyFeaturesLastObserved) oldStudyFeatures newStudyFeatures
, StudyFeaturesValid =. ((||) `on` studyFeaturesValid) oldStudyFeatures newStudyFeatures
, StudyFeaturesRelevanceCached =. ((||) `on` studyFeaturesRelevanceCached) oldStudyFeatures newStudyFeatures
]
E.insertSelectWithConflict
UniqueRelevantStudyFeatures
(E.from $ \relevantStudyFeatures -> do
E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. E.val oldSFId
return $ RelevantStudyFeatures
E.<# (relevantStudyFeatures E.^. RelevantStudyFeaturesTerm)
E.<&> E.val newSFId
)
(\_current _excluded -> [])
deleteWhere [ RelevantStudyFeaturesStudyFeatures ==. oldSFId ]
delete oldSFId
in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures
delete oldUserId
audit $ TransactionUserAssimilated newUserId oldUserId
where
tellWarning :: UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) ()
tellWarning = lift . tellPoint . UserAssimilateException oldUserId newUserId
tellError :: forall a. UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) a
tellError = throwM . UserAssimilateException oldUserId newUserId

9
src/Import/NoModel.hs
View File

@ -88,17 +88,20 @@ import Control.Monad.Random.Class as Import (MonadRandom(..))
import Control.Monad.Morph as Import
import Control.Monad.Trans.Resource as Import (ReleaseKey)
import Control.Monad.Trans.Reader as Import
( reader, runReader, mapReader, withReader
( runReader, mapReader, withReader
, mapReaderT, withReaderT
)
import Control.Monad.Reader.Class as Import (MonadReader(..))
import Control.Monad.Trans.State as Import
( state, State, runState, mapState, withState
( State, runState, mapState, withState
, StateT(..), mapStateT, withStateT
)
import Control.Monad.State.Class as Import (MonadState(state))
import Control.Monad.Trans.Writer.Lazy as Import
( writer, Writer, runWriter, mapWriter, execWriter
( Writer, runWriter, mapWriter, execWriter
, WriterT(..), mapWriterT, execWriterT
)
import Control.Monad.Writer.Class as Import (MonadWriter(..))
import Control.Monad.Trans.Except as Import
( except, Except, runExcept, mapExcept
, ExceptT(..), runExceptT, mapExceptT, throwE

1
src/Jobs.hs
View File

@ -32,7 +32,6 @@ import Data.Map.Strict ((!))
import Control.Monad.Trans.RWS.Lazy (RWST, mapRWST, evalRWST)
import Control.Monad.Trans.State.Strict (StateT, evalStateT)
import qualified Control.Monad.State.Class as State
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Trans.Cont (ContT(..), callCC)
import Control.Monad.Random.Lazy (evalRandTIO, mapRandT)
import Control.Monad.Logger

2
src/Jobs/Crontab.hs
View File

@ -17,8 +17,6 @@ import Data.Time.Clock.POSIX
import Handler.Utils.DateTime
import Control.Monad.Writer.Class (MonadWriter(..))
import qualified Data.Conduit.List as C
import qualified Database.Esqueleto as E

2
src/Jobs/Queue.hs
View File

@ -13,8 +13,6 @@ import Import hiding ((<>))
import Jobs.Types
import Control.Monad.Writer.Class (MonadWriter(..))
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NonEmpty

23
src/Jobs/Types.hs
View File

@ -1,8 +1,9 @@
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
module Jobs.Types
( Job(..), Notification(..)
, JobChildren
, classifyJob
, JobCtl(..)
, classifyJobCtl
@ -42,6 +43,8 @@ import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone)
import System.Clock (getTime, Clock(Monotonic), TimeSpec)
import GHC.Conc (unsafeIOToSTM)
import Data.Generics.Product.Types (Children, ChGeneric)
data Job
= JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
@ -144,6 +147,24 @@ deriveJSON defaultOptions
, sumEncoding = TaggedObject "notification" "data"
} ''Notification
data JobChildren
type instance Children JobChildren a = ChildrenJobChildren a
type family ChildrenJobChildren a where
ChildrenJobChildren ByteString = '[]
ChildrenJobChildren Html = '[]
ChildrenJobChildren Day = '[]
ChildrenJobChildren DiffTime = '[]
ChildrenJobChildren (SelDateTimeFormat -> DateTimeFormat) = '[]
ChildrenJobChildren Natural = '[]
ChildrenJobChildren UUID = '[]
ChildrenJobChildren (Key a) = '[]
ChildrenJobChildren (CI a) = '[]
ChildrenJobChildren (Set a) = '[]
ChildrenJobChildren a = Children ChGeneric a
classifyJob :: Job -> String
classifyJob job = unpack tag
where

9
src/Language/Haskell/TH/Instances.hs
View File

@ -7,6 +7,7 @@ module Language.Haskell.TH.Instances
import ClassyPrelude
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Lift (deriveLift)
import Data.Binary (Binary)
@ -15,6 +16,14 @@ instance Binary Loc
deriveLift ''Loc
instance Binary OccName
instance Binary ModName
instance Binary NameSpace
instance Binary PkgName
instance Binary NameFlavour
instance Binary Name
instance Semigroup (Q [Dec]) where
(<>) = liftA2 (<>)

10
src/Model/Types/Security.hs
View File

@ -211,6 +211,16 @@ dnfAssumeValue var val
predDNFFalse :: PredDNF a
predDNFFalse = PredDNF Set.empty
predDNFSingleton :: Ord a => PredLiteral a -> PredDNF a
predDNFSingleton = PredDNF . Set.singleton . impureNonNull . Set.singleton
predDNFAnd, predDNFOr :: Ord a => PredDNF a -> PredDNF a -> PredDNF a
predDNFAnd (PredDNF a) (PredDNF b) = PredDNF . Set.fromList $ do
aConj <- Set.toList a
bConj <- Set.toList b
return . impureNonNull $ toNullable aConj `Set.union` toNullable bConj
predDNFOr (PredDNF a) (PredDNF b) = PredDNF $ a <> b
data UserGroupName
= UserGroupMetrics

6
src/Model/Types/Sheet.hs
View File

@ -302,16 +302,12 @@ instance Monoid Load where
data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
deriving anyclass (Universe, Finite, Hashable)
deriveJSON defaultOptions
{ constructorTagModifier = fromJust . stripPrefix "Corrector"
} ''CorrectorState
instance Universe CorrectorState
instance Finite CorrectorState
instance Hashable CorrectorState
nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
derivePersistField "CorrectorState"

16
src/Utils.hs
View File

@ -810,7 +810,7 @@ and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool
and2M ma mb = ifM ma mb (return False)
or2M ma = ifM ma (return True)
andM, orM :: (MonoFoldable mono, Element mono ~ (m Bool), Monad m) => mono -> m Bool
andM, orM :: (MonoFoldable mono, Element mono ~ m Bool, Monad m) => mono -> m Bool
andM = ofoldl' and2M (return True)
orM = ofoldl' or2M (return False)
@ -875,9 +875,19 @@ diffTimeout timeoutLength timeoutRes act = fromMaybe timeoutRes <$> timeout time
= let (MkFixed micro :: Micro) = realToFrac timeoutLength
in fromInteger micro
------------
-- Writer --
------------
tellM :: (MonadTrans t, MonadWriter x (t m), Monad m) => m x -> t m ()
tellM = tell <=< lift
tellPoint :: (MonadWriter mono m, MonoPointed mono) => Element mono -> m ()
tellPoint = tell . opoint
tellMPoint :: (MonadTrans t, MonadWriter mono (t m), Monad m, MonoPointed mono) => m (Element mono) -> t m ()
tellMPoint = tellM . fmap opoint
-------------
-- Conduit --
-------------
@ -1152,6 +1162,10 @@ setLastModified lastModified = do
safeMethods = [ methodGet, methodHead, methodOptions ]
-- | Adapter for memoization of five-argument function
for5 :: (((k1, k2, k3, k4, k5) -> mv) -> (k1, k2, k3, k4, k5) -> mv) -> (k1 -> k2 -> k3 -> k4 -> k5 -> mv) -> k1 -> k2 -> k3 -> k4 -> k5 -> mv
for5 m f a b c d e = m (\(a',b',c',d',e') -> f a' b' c' d' e') (a,b,c,d,e)
--------------
-- Lattices --
--------------

1
src/Utils/Allocation.hs
View File

@ -16,7 +16,6 @@ import qualified Data.Array.MArray as MArr
import System.Random (RandomGen)
import Control.Monad.Trans.Random.Strict (evalRandT, RandT)
import Control.Monad.Trans.State.Strict (StateT, modify', get, gets, evalStateT)
import Control.Monad.Writer (tell)
import Control.Monad.ST

2
src/Utils/Form.hs
View File

@ -223,7 +223,7 @@ data FormIdentifier
| FIDUserDelete
| FIDCommunication
| FIDAssignSubmissions
| FIDUserAuthMode
| FIDUserAuthMode | FIDUserAssimilate | FIDUserRights | FIDUserAuthentication
| FIDAllUsersAction
| FIDLanguage
| FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID

2
src/Utils/Parameters.hs
View File

@ -58,7 +58,7 @@ data GlobalPostParam = PostFormIdentifier
| PostDeleteTarget
| PostMassInputShape
| PostBearer
| PostDBCsvImportAction
| PostDBCsvImportAction | PostDBCsvImportAvailableActions
| PostDBCsvReImport
| PostLoginDummy
| PostExamAutoOccurrencePrevious

12
templates/adminUser.hamlet
View File

@ -11,7 +11,11 @@ $newline never
_{MsgAdminUserAuthHeading}
^{authForm}
<section>
<p>
_{MsgUserAccountDeleteWarning}
<p>
^{modal "Benutzer löschen" (Right deleteWidget)}
<h3>
_{MsgAdminUserAssimilate}
^{assimilateForm}
$# <section>
$# <p>
$# _{MsgUserAccountDeleteWarning}
$# <p>
$# ^{modal "Benutzer löschen" (Right deleteWidget)}

8
templates/course.hamlet
View File

@ -225,13 +225,9 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
$if registrationOpen
$# regForm is defined through templates/widgets/registerForm
^{regForm}
$if isJust mApplication && courseApplicationsRequired course
<p>
$if (isJust mApplication && courseApplicationsRequired course) && mayReRegister
<p .explanation>
_{MsgCourseApplicationDeleteToEdit}
$else
$if isJust registration
<p>
_{MsgCourseRegistrationDeleteToEdit}
<dt .deflist__dt>
_{MsgCourseMaterial}

1
templates/csv-import-confirmation.hamlet
View File

@ -1,5 +1,6 @@
$newline never
#{csrf}
^{availableActs}
<div .actions>
$forall actionClass <- sortOn dbtCsvCoarsenActionClass (Map.keys actionMap)
<div .action>

28
templates/profileData.hamlet
View File

@ -5,6 +5,10 @@ $newline never
_{MsgIdent}
<dd .deflist__dd .email>
#{userIdent}
<dt .deflist__dt>
_{MsgAuthMode}
<dd .deflist__dd>
_{userAuthentication}
<dt .deflist__dt>
_{MsgName}
<dd .deflist__dd>
@ -18,19 +22,28 @@ $newline never
_{MsgEMail}
<dd .deflist__dd>
#{mailtoHtml userEmail}
$if userEmail /= userDisplayEmail
<dt .deflist__dt>
_{MsgUserDisplayEmail}
<dd .deflist__dd .email>
#{userDisplayEmail}
$if showAdminInfo
<dt .deflist__dt>
_{MsgUserCreated}
<dd .deflist__dd>
^{formatTimeW SelFormatDateTime userCreated}
<dt .deflist__dt>
_{MsgLastLogin}
<dd .deflist__dd>
$maybe llogin <- lastLogin
#{llogin}
$maybe llogin <- userLastAuthentication
^{formatTimeW SelFormatDateTime llogin}
$nothing
_{MsgNever}
<dt .deflist__dt>
_{MsgProfileLastLdapSynchronisation}
<dd .deflist__dd>
$maybe lsync <- lastLdapSync
#{lsync}
$maybe lsync <- userLastLdapSynchronisation
^{formatTimeW SelFormatDateTime lsync}
$nothing
_{MsgNever}
$maybe pKey <- userLdapPrimaryKey
@ -38,6 +51,13 @@ $newline never
_{MsgProfileLdapPrimaryKey}
<dd .deflist__dd .ldap-primary-key>
#{pKey}
<dt .deflist__dt>
_{MsgTokensLastReset}
<dd .deflist__dd>
$maybe lastInvalidated <- userTokensIssuedAfter
^{formatTimeW SelFormatDateTime lastInvalidated}
$nothing
_{MsgNever}
$forall (function, schools) <- Map.toList functions
<dt .deflist__dt>_{function}
<dd .deflist__dd>