Merge branch 'fix/sub-study-terms'
This commit is contained in:
Gregor Kleen
commit
77ae311935
@ -17,9 +17,13 @@ BtnHijack: Sitzung übernehmen
|
|||||||
BtnSave: Speichern
|
BtnSave: Speichern
|
||||||
PressSaveToSave: Änderungen werden erst durch Drücken des Knopfes "Speichern" gespeichert.
|
PressSaveToSave: Änderungen werden erst durch Drücken des Knopfes "Speichern" gespeichert.
|
||||||
BtnHandIn: Abgeben
|
BtnHandIn: Abgeben
|
||||||
BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
|
BtnNameCandidatesInfer: Studienfach-Namens-Zuordnung automatisch lernen
|
||||||
BtnCandidatesDeleteConflicts: Konflikte löschen
|
BtnNameCandidatesDeleteConflicts: Namenskonflikte löschen
|
||||||
BtnCandidatesDeleteAll: Alle Beobachtungen löschen
|
BtnNameCandidatesDeleteAll: Alle Namens-Beobachtungen löschen
|
||||||
|
BtnParentCandidatesInfer: Unterstudiengangs-Zuordnung automatisch lernen
|
||||||
|
BtnParentCandidatesDeleteAll: Alle Unterstudiengangs-Beobachtungen löschen
|
||||||
|
BtnStandaloneCandidatesDeleteAll: Alle Einzelstudiengangs-Beobachtungen löschen
|
||||||
|
BtnStandaloneCandidatesDeleteRedundant: Redundante Einzelstudiengangs-Beobachtungen löschen
|
||||||
BtnResetTokens: Authorisierungs-Tokens invalidieren
|
BtnResetTokens: Authorisierungs-Tokens invalidieren
|
||||||
BtnLecInvAccept: Annehmen
|
BtnLecInvAccept: Annehmen
|
||||||
BtnLecInvDecline: Ablehnen
|
BtnLecInvDecline: Ablehnen
|
||||||
@ -761,9 +765,15 @@ AdminFeaturesHeading: Studiengänge
|
|||||||
StudyTerms: Studiengänge
|
StudyTerms: Studiengänge
|
||||||
StudyTerm: Studiengang
|
StudyTerm: Studiengang
|
||||||
NoStudyTermsKnown: Keine Studiengänge bekannt
|
NoStudyTermsKnown: Keine Studiengänge bekannt
|
||||||
StudyFeatureInference: Studiengangschlüssel-Inferenz
|
StudyFeaturesDegrees: Abschlüsse
|
||||||
StudyFeatureInferenceNoConflicts: Keine Konflikte beobachtet
|
StudyFeaturesTerms: Studiengänge
|
||||||
StudyFeatureInferenceConflictsHeading: Studiengangseinträge mit beobachteten Konflikten
|
StudyFeaturesNameCandidates: Namens-Kandidaten
|
||||||
|
StudyFeaturesParentCandidates: Kandidaten für Unterstudiengänge
|
||||||
|
StudyFeaturesStandaloneCandidates: Kandidaten für Einzelstudiengänge
|
||||||
|
StudyFeatureNameInference: Studiengangschlüssel-Inferenz
|
||||||
|
StudyFeatureParentInference: Unterstudiengang-Inferenz
|
||||||
|
StudyFeatureInferenceNoNameConflicts: Keine Konflikte beobachtet
|
||||||
|
StudyFeatureInferenceNameConflictsHeading: Studiengangseinträge mit beobachteten Konflikten
|
||||||
StudyFeatureAge: Fachsemester
|
StudyFeatureAge: Fachsemester
|
||||||
StudyFeatureDegree: Abschluss
|
StudyFeatureDegree: Abschluss
|
||||||
FieldPrimary: Hauptfach
|
FieldPrimary: Hauptfach
|
||||||
@ -784,11 +794,17 @@ StudyTermsShort: Studiengangkürzel
|
|||||||
StudyTermsChangeSuccess: Zuordnung Studiengänge aktualisiert
|
StudyTermsChangeSuccess: Zuordnung Studiengänge aktualisiert
|
||||||
StudyDegreeChangeSuccess: Zuordnung Abschlüsse aktualisiert
|
StudyDegreeChangeSuccess: Zuordnung Abschlüsse aktualisiert
|
||||||
StudyCandidateIncidence: Synchronisation
|
StudyCandidateIncidence: Synchronisation
|
||||||
AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt
|
AmbiguousNameCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt
|
||||||
RedundantCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Kandidat" "bekannte Kandiaten"} entfernt
|
RedundantNameCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Namenskandidat" "bekannte Namenskandiaten"} entfernt
|
||||||
CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
|
RedundantParentCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Elternkandidat" "bekannte Elternkandiaten"} entfernt
|
||||||
NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
|
RedundantStandaloneCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Einzelstudiengangskandidat" "bekannte Einzelstudiengangskandiaten"} entfernt
|
||||||
AllIncidencesDeleted: Alle Beobachtungen wurden gelöscht.
|
NameCandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
|
||||||
|
NoNameCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
|
||||||
|
ParentCandidatesInferred n@Int: #{show n} #{pluralDE n "neuer Unterstudiengang" "neue Unterstudiengänge"} inferiert
|
||||||
|
NoParentCandidatesInferred: Keine neuen Unterstudiengänge inferiert
|
||||||
|
AllNameIncidencesDeleted: Alle Namens-Beobachtungen wurden gelöscht.
|
||||||
|
AllParentIncidencesDeleted: Alle Unterstudiengang-Beobachtungen wurden gelöscht.
|
||||||
|
AllStandaloneIncidencesDeleted: Alle Einzelstudiengang-Beobachtungen wurden gelöscht.
|
||||||
IncidencesDeleted n@Int: #{show n} #{pluralDE n "Beobachtung" "Beobachtungen"} gelöscht
|
IncidencesDeleted n@Int: #{show n} #{pluralDE n "Beobachtung" "Beobachtungen"} gelöscht
|
||||||
StudyTermIsNew: Neu
|
StudyTermIsNew: Neu
|
||||||
StudyFeatureConflict: Es wurden Konflikte in der Studiengang-Zuordnung gefunden
|
StudyFeatureConflict: Es wurden Konflikte in der Studiengang-Zuordnung gefunden
|
||||||
@ -2077,6 +2093,13 @@ ShortSexNotApplicable: k.A.
|
|||||||
ShowSex: Geschlechter anderer Nutzer anzeigen
|
ShowSex: Geschlechter anderer Nutzer anzeigen
|
||||||
ShowSexTip: Sollen in Kursteilnehmer-Tabellen u.Ä. die Geschlechter der Nutzer angezeigt werden?
|
ShowSexTip: Sollen in Kursteilnehmer-Tabellen u.Ä. die Geschlechter der Nutzer angezeigt werden?
|
||||||
|
|
||||||
|
StudySubTermsChildKey: Kind
|
||||||
|
StudySubTermsChildName: Kindname
|
||||||
|
StudySubTermsParentKey: Elter
|
||||||
|
StudySubTermsParentName: Eltername
|
||||||
|
StudyTermsDefaultDegree: Default Abschluss
|
||||||
|
StudyTermsDefaultFieldType: Default Typ
|
||||||
|
|
||||||
MenuLanguage: Sprache
|
MenuLanguage: Sprache
|
||||||
LanguageChanged: Sprache erfolgreich geändert
|
LanguageChanged: Sprache erfolgreich geändert
|
||||||
|
|
||||||
@ -2137,4 +2160,4 @@ Deficit: Defizit
|
|||||||
|
|
||||||
MetricNoSamples: Keine Messwerte
|
MetricNoSamples: Keine Messwerte
|
||||||
MetricName: Name
|
MetricName: Name
|
||||||
MetricValue: Wert
|
MetricValue: Wert
|
||||||
|
|||||||
@ -17,9 +17,13 @@ BtnHijack: Hijack session
|
|||||||
BtnSave: Save
|
BtnSave: Save
|
||||||
PressSaveToSave: Changes will only be saved after clicking "Save".
|
PressSaveToSave: Changes will only be saved after clicking "Save".
|
||||||
BtnHandIn: Hand in submission
|
BtnHandIn: Hand in submission
|
||||||
BtnCandidatesInfer: Infer mapping
|
BtnNameCandidatesInfer: Infer name-mapping
|
||||||
BtnCandidatesDeleteConflicts: Delete conflicts
|
BtnNameCandidatesDeleteConflicts: Delete name-conflicts
|
||||||
BtnCandidatesDeleteAll: Delete all observations
|
BtnNameCandidatesDeleteAll: Delete all name-observations
|
||||||
|
BtnParentCandidatesInfer: Infer parent-relation
|
||||||
|
BtnParentCandidatesDeleteAll: Delete all parent-observations
|
||||||
|
BtnStandaloneCandidatesDeleteAll: Delete all standalone-observations
|
||||||
|
BtnStandaloneCandidatesDeleteRedundant: Delete redundant standalone-observations
|
||||||
BtnResetTokens: Invalidate tokens
|
BtnResetTokens: Invalidate tokens
|
||||||
BtnLecInvAccept: Accept
|
BtnLecInvAccept: Accept
|
||||||
BtnLecInvDecline: Decline
|
BtnLecInvDecline: Decline
|
||||||
@ -384,6 +388,8 @@ UnauthorizedTokenNotStarted: Your authorisation-token is not yet valid.
|
|||||||
UnauthorizedTokenInvalid: Your authorisation-token could not be processed.
|
UnauthorizedTokenInvalid: Your authorisation-token could not be processed.
|
||||||
UnauthorizedTokenInvalidRoute: Your authorisation-token is not valid for this page.
|
UnauthorizedTokenInvalidRoute: Your authorisation-token is not valid for this page.
|
||||||
UnauthorizedTokenInvalidAuthority: Your authorisation-token is based in an user's rights who does not exist anymore.
|
UnauthorizedTokenInvalidAuthority: Your authorisation-token is based in an user's rights who does not exist anymore.
|
||||||
|
UnauthorizedTokenInvalidAuthorityGroup: Your authorisation-token is based in an user groups rights which does not exist anymore.
|
||||||
|
UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which your authorisation-token is based, could not be interpreted.
|
||||||
UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages.
|
UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages.
|
||||||
UnauthorizedSiteAdmin: You are no system-wide administrator.
|
UnauthorizedSiteAdmin: You are no system-wide administrator.
|
||||||
UnauthorizedSchoolAdmin: You are no administrator for this department.
|
UnauthorizedSchoolAdmin: You are no administrator for this department.
|
||||||
@ -756,9 +762,15 @@ AdminFeaturesHeading: Features of study
|
|||||||
StudyTerms: Fields of study
|
StudyTerms: Fields of study
|
||||||
StudyTerm: Field of study
|
StudyTerm: Field of study
|
||||||
NoStudyTermsKnown: No known features of study
|
NoStudyTermsKnown: No known features of study
|
||||||
StudyFeatureInference: Infer field of study mapping
|
StudyFeaturesDegrees: Degrees
|
||||||
StudyFeatureInferenceNoConflicts: No observed conflicts
|
StudyFeaturesTerms: Terms of Study
|
||||||
StudyFeatureInferenceConflictsHeading: Fields of study with observed conflicts
|
StudyFeaturesNameCandidates: Name candidates
|
||||||
|
StudyFeaturesParentCandidates: Parent candidates
|
||||||
|
StudyFeaturesStandaloneCandidates: Standalone candidates
|
||||||
|
StudyFeatureNameInference: Infer field of study mapping
|
||||||
|
StudyFeatureParentInference: Infer field of study parent relation
|
||||||
|
StudyFeatureInferenceNoNameConflicts: No observed conflicts
|
||||||
|
StudyFeatureInferenceNameConflictsHeading: Fields of study with observed conflicts
|
||||||
StudyFeatureAge: Semester
|
StudyFeatureAge: Semester
|
||||||
StudyFeatureDegree: Degree
|
StudyFeatureDegree: Degree
|
||||||
FieldPrimary: Major
|
FieldPrimary: Major
|
||||||
@ -779,11 +791,17 @@ StudyTermsShort: Field shorthand
|
|||||||
StudyTermsChangeSuccess: Successfully updated fields of study
|
StudyTermsChangeSuccess: Successfully updated fields of study
|
||||||
StudyDegreeChangeSuccess: Successfully updated degrees
|
StudyDegreeChangeSuccess: Successfully updated degrees
|
||||||
StudyCandidateIncidence: Synchronisation
|
StudyCandidateIncidence: Synchronisation
|
||||||
AmbiguousCandidatesRemoved n: Successfully removed #{n} ambiguous #{pluralEN n "candidate" "candidates"}
|
AmbiguousNameCandidatesRemoved n: Successfully removed #{n} ambiguous #{pluralEN n "candidate" "candidates"}
|
||||||
RedundantCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "candidate" "candidates"}
|
RedundantNameCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "name-candidate" "name-candidates"}
|
||||||
CandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "mapping" "mappings"}
|
RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "parent-candidate" "parent-candidates"}
|
||||||
NoCandidatesInferred: No new mappings inferred
|
RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "standalone-candidate" "standalone-candidates"}
|
||||||
AllIncidencesDeleted: Successfully deleted all observations
|
NameCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "mapping" "mappings"}
|
||||||
|
NoNameCandidatesInferred: No new name-mappings inferred
|
||||||
|
AllNameIncidencesDeleted: Successfully deleted all name observations
|
||||||
|
AllParentIncidencesDeleted: Successfully deleted all parent-relation observations
|
||||||
|
AllStandaloneIncidencesDeleted: Successfully deleted all standalone observations
|
||||||
|
ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "parent-relation" "parent-reliations"}
|
||||||
|
NoParentCandidatesInferred: No new parent-relations inferred
|
||||||
IncidencesDeleted n: Successfully deleted #{show n} #{pluralEN n "observation" "observations"}
|
IncidencesDeleted n: Successfully deleted #{show n} #{pluralEN n "observation" "observations"}
|
||||||
StudyTermIsNew: New
|
StudyTermIsNew: New
|
||||||
StudyFeatureConflict: Observed conflicts in field mapping
|
StudyFeatureConflict: Observed conflicts in field mapping
|
||||||
@ -2070,6 +2088,12 @@ ShortSexNotApplicable: N/A
|
|||||||
ShowSex: Show sex of other users
|
ShowSex: Show sex of other users
|
||||||
ShowSexTip: Should users' sex be displayed in (among others) lists of course participants?
|
ShowSexTip: Should users' sex be displayed in (among others) lists of course participants?
|
||||||
|
|
||||||
|
StudySubTermsChildKey: Child
|
||||||
|
StudySubTermsChildName: Child-Name
|
||||||
|
StudySubTermsParentKey: Parent
|
||||||
|
StudySubTermsParentName: Parent-Name
|
||||||
|
StudyTermsDefaultDegree: Default degree
|
||||||
|
StudyTermsDefaultFieldType: Default type
|
||||||
|
|
||||||
MenuLanguage: Language
|
MenuLanguage: Language
|
||||||
LanguageChanged: Language changed successfully
|
LanguageChanged: Language changed successfully
|
||||||
|
|||||||
@ -64,5 +64,5 @@ ExamCorrector
|
|||||||
UniqueExamCorrector exam user
|
UniqueExamCorrector exam user
|
||||||
ExamPartCorrector
|
ExamPartCorrector
|
||||||
part ExamPartId
|
part ExamPartId
|
||||||
corrector ExamCorrector
|
corrector ExamCorrectorId
|
||||||
UniqueExamPartCorrector part corrector
|
UniqueExamPartCorrector part corrector
|
||||||
@ -55,11 +55,13 @@ StudyFeatures -- multiple entries possible for students pursuing several degree
|
|||||||
user UserId
|
user UserId
|
||||||
degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc.
|
degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc.
|
||||||
field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc.
|
field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc.
|
||||||
|
subField StudyTermsId Maybe
|
||||||
type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach
|
type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach
|
||||||
semester Int
|
semester Int
|
||||||
updated UTCTime default=now() -- last update from LDAP
|
updated UTCTime default=now() -- last update from LDAP
|
||||||
valid Bool default=true -- marked as active in LDAP (students may switch, but LDAP never forgets)
|
valid Bool default=true -- marked as active in LDAP (students may switch, but LDAP never forgets)
|
||||||
UniqueStudyFeatures user degree field type semester
|
UniqueStudyFeatures user degree field type semester
|
||||||
|
deriving Eq Show
|
||||||
-- UniqueUserSubject ubuser degree field -- There exists a counterexample
|
-- UniqueUserSubject ubuser degree field -- There exists a counterexample
|
||||||
StudyDegree -- Studienabschluss
|
StudyDegree -- Studienabschluss
|
||||||
key Int -- LMU-internal key
|
key Int -- LMU-internal key
|
||||||
@ -67,22 +69,37 @@ StudyDegree -- Studienabschluss
|
|||||||
name Text Maybe -- description given by LDAP
|
name Text Maybe -- description given by LDAP
|
||||||
Primary key -- column key is used as actual DB row key
|
Primary key -- column key is used as actual DB row key
|
||||||
-- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int }
|
-- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int }
|
||||||
deriving Show
|
deriving Eq Show
|
||||||
StudyTerms -- Studiengang
|
StudyTerms -- Studiengang
|
||||||
key Int -- LMU-internal key
|
key Int -- standardised key
|
||||||
shorthand Text Maybe -- admin determined shorthand
|
shorthand Text Maybe -- admin determined shorthand
|
||||||
name Text Maybe -- description given by LDAP
|
name Text Maybe -- description given by LDAP
|
||||||
|
defaultDegree StudyDegreeId Maybe
|
||||||
|
defaultType StudyFieldType Maybe
|
||||||
Primary key -- column key is used as actual DB row key
|
Primary key -- column key is used as actual DB row key
|
||||||
-- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int }
|
-- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int }
|
||||||
deriving Show
|
deriving Eq Ord Show
|
||||||
StudyTermCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms.
|
StudySubTerms
|
||||||
|
child StudyTermsId
|
||||||
|
parent StudyTermsId
|
||||||
|
UniqueStudySubTerms child parent
|
||||||
|
StudyTermNameCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms.
|
||||||
-- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence.
|
-- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence.
|
||||||
-- This table helps us to infer which key belongs to which plain text by recording possible combinations at login.
|
-- This table helps us to infer which key belongs to which plain text by recording possible combinations at login.
|
||||||
-- If a login provides n keys and n plan texts, then n^2 rows with the same incidence are created, storing all combinations
|
-- If a login provides n keys and n plan texts, then n^2 rows with the same incidence are created, storing all combinations
|
||||||
incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs
|
incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs
|
||||||
key Int -- a possible key for the studyTermName
|
key Int -- a possible key for the studyTermName or studySubTermName
|
||||||
name Text -- studyTermName as plain text from LDAP
|
name Text -- studyTermName as plain text from LDAP
|
||||||
deriving Show Eq Ord
|
deriving Show Eq Ord
|
||||||
|
StudySubTermParentCandidate
|
||||||
|
incidence TermCandidateIncidence
|
||||||
|
key Int
|
||||||
|
parent Int
|
||||||
|
deriving Show Eq Ord
|
||||||
|
StudyTermStandaloneCandidate
|
||||||
|
incidence TermCandidateIncidence
|
||||||
|
key Int
|
||||||
|
deriving Show Eq Ord
|
||||||
|
|
||||||
UserGroupMember
|
UserGroupMember
|
||||||
group UserGroupName
|
group UserGroupName
|
||||||
@ -91,4 +108,4 @@ UserGroupMember
|
|||||||
|
|
||||||
UniquePrimaryUserGroupMember group primary !force
|
UniquePrimaryUserGroupMember group primary !force
|
||||||
UniqueUserGroupMember group user
|
UniqueUserGroupMember group user
|
||||||
|
|
||||||
|
|||||||
@ -68,7 +68,7 @@ dependencies:
|
|||||||
- cereal
|
- cereal
|
||||||
- mtl
|
- mtl
|
||||||
- sandi
|
- sandi
|
||||||
- esqueleto
|
- esqueleto >=3.1.0
|
||||||
- mime-types
|
- mime-types
|
||||||
- generic-deriving
|
- generic-deriving
|
||||||
- blaze-html
|
- blaze-html
|
||||||
|
|||||||
@ -7,7 +7,7 @@ module Auth.LDAP
|
|||||||
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
||||||
, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
|
, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
|
||||||
, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
|
, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
|
||||||
, ldapUserSchoolAssociation, ldapSex
|
, ldapUserSchoolAssociation, ldapUserSubTermsSemester, ldapSex
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Import.NoFoundation
|
import Import.NoFoundation
|
||||||
@ -62,7 +62,7 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not
|
|||||||
, Ldap.derefAliases Ldap.DerefAlways
|
, Ldap.derefAliases Ldap.DerefAlways
|
||||||
]
|
]
|
||||||
|
|
||||||
ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex :: Ldap.Attr
|
ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester :: Ldap.Attr
|
||||||
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
||||||
ldapUserDisplayName = Ldap.Attr "displayName"
|
ldapUserDisplayName = Ldap.Attr "displayName"
|
||||||
ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
|
ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
|
||||||
@ -70,9 +70,10 @@ ldapUserFirstName = Ldap.Attr "givenName"
|
|||||||
ldapUserSurname = Ldap.Attr "sn"
|
ldapUserSurname = Ldap.Attr "sn"
|
||||||
ldapUserTitle = Ldap.Attr "title"
|
ldapUserTitle = Ldap.Attr "title"
|
||||||
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
|
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
|
||||||
ldapUserFieldName = Ldap.Attr "dfnEduPersonFieldOfStudyString"
|
ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach"
|
||||||
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
|
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
|
||||||
ldapSex = Ldap.Attr "schacGender"
|
ldapSex = Ldap.Attr "schacGender"
|
||||||
|
ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS"
|
||||||
|
|
||||||
ldapUserEmail :: NonEmpty Ldap.Attr
|
ldapUserEmail :: NonEmpty Ldap.Attr
|
||||||
ldapUserEmail = Ldap.Attr "mail" :|
|
ldapUserEmail = Ldap.Attr "mail" :|
|
||||||
|
|||||||
@ -20,6 +20,7 @@ module Database.Esqueleto.Utils
|
|||||||
, maybe
|
, maybe
|
||||||
, SqlProject(..)
|
, SqlProject(..)
|
||||||
, (->.)
|
, (->.)
|
||||||
|
, fromSqlKey
|
||||||
, module Database.Esqueleto.Utils.TH
|
, module Database.Esqueleto.Utils.TH
|
||||||
) where
|
) where
|
||||||
|
|
||||||
@ -250,3 +251,6 @@ instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.E
|
|||||||
|
|
||||||
(->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
|
(->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
|
||||||
(->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t
|
(->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t
|
||||||
|
|
||||||
|
fromSqlKey :: (ToBackendKey SqlBackend entity, PersistField (Key entity)) => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value Int64)
|
||||||
|
fromSqlKey = E.veryUnsafeCoerceSqlExprValue
|
||||||
|
|||||||
@ -1,8 +1,10 @@
|
|||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
module Database.Esqueleto.Utils.TH
|
module Database.Esqueleto.Utils.TH
|
||||||
( SqlIn(..)
|
( SqlIn(..)
|
||||||
, sqlInTuple, sqlInTuples
|
, sqlInTuple, sqlInTuples
|
||||||
, unValueN, unValueNIs
|
, unValueN, unValueNIs
|
||||||
, sqlIJproj, sqlLOJproj
|
, sqlIJproj, sqlLOJproj, sqlFOJproj
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
@ -21,8 +23,17 @@ import Utils.TH
|
|||||||
class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
|
class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
|
||||||
sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
|
sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
|
||||||
|
|
||||||
instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
|
instance SqlEq a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
|
||||||
x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs)
|
sqlIn x = foldr (\x' e -> e E.||. sqlEq (E.val $ E.unValue x') x) (E.val False)
|
||||||
|
|
||||||
|
class PersistField a => SqlEq a where
|
||||||
|
sqlEq :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Bool)
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} PersistField a => SqlEq a where
|
||||||
|
sqlEq = (E.==.)
|
||||||
|
|
||||||
|
instance PersistField a => SqlEq (Maybe a) where
|
||||||
|
sqlEq a b = (E.isNothing a E.&&. E.isNothing b) E.||. a E.==. b
|
||||||
|
|
||||||
sqlInTuples :: [Int] -> DecsQ
|
sqlInTuples :: [Int] -> DecsQ
|
||||||
sqlInTuples = mapM sqlInTuple
|
sqlInTuples = mapM sqlInTuple
|
||||||
@ -35,10 +46,10 @@ sqlInTuple arity = do
|
|||||||
xsV <- newName "xs"
|
xsV <- newName "xs"
|
||||||
|
|
||||||
let
|
let
|
||||||
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs)
|
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) $ zip vVs xVs)
|
||||||
tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
|
tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
|
||||||
|
|
||||||
instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
|
instanceD (cxt $ map (\v -> [t|SqlEq $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
|
||||||
[ funD 'sqlIn
|
[ funD 'sqlIn
|
||||||
[ clause [tupP $ map varP xVs, varP xsV]
|
[ clause [tupP $ map varP xVs, varP xsV]
|
||||||
( guardedB
|
( guardedB
|
||||||
@ -84,3 +95,6 @@ sqlIJproj = leftAssociativePairProjection 'E.InnerJoin
|
|||||||
|
|
||||||
sqlLOJproj :: Int -> Int -> ExpQ
|
sqlLOJproj :: Int -> Int -> ExpQ
|
||||||
sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin
|
sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin
|
||||||
|
|
||||||
|
sqlFOJproj :: Int -> Int -> ExpQ
|
||||||
|
sqlFOJproj = leftAssociativePairProjection 'E.FullOuterJoin
|
||||||
|
|||||||
@ -34,6 +34,3 @@ uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistU
|
|||||||
|
|
||||||
instance PersistEntity record => Eq (Unique record) where
|
instance PersistEntity record => Eq (Unique record) where
|
||||||
(==) = (==) `on` uniqueToMap
|
(==) = (==) `on` uniqueToMap
|
||||||
|
|
||||||
instance PersistEntity record => Show (Unique record) where
|
|
||||||
showsPrec p = showsPrec p . uniqueToMap
|
|
||||||
|
|||||||
@ -47,6 +47,7 @@ import qualified Data.Map as Map
|
|||||||
import qualified Data.HashSet as HashSet
|
import qualified Data.HashSet as HashSet
|
||||||
|
|
||||||
import Data.List (nubBy, (!!), findIndex, inits)
|
import Data.List (nubBy, (!!), findIndex, inits)
|
||||||
|
import qualified Data.List as List
|
||||||
|
|
||||||
import Web.Cookie
|
import Web.Cookie
|
||||||
|
|
||||||
@ -3390,36 +3391,113 @@ upsertCampusUser ldapData Creds{..} = do
|
|||||||
Right str <- return $ Text.decodeUtf8' v'
|
Right str <- return $ Text.decodeUtf8' v'
|
||||||
return str
|
return str
|
||||||
|
|
||||||
fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
|
userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester
|
||||||
|
userSubTermsSemesters' = do
|
||||||
|
(k, v) <- ldapData
|
||||||
|
guard $ k == ldapUserSubTermsSemester
|
||||||
|
v' <- v
|
||||||
|
Right str <- return $ Text.decodeUtf8' v'
|
||||||
|
return str
|
||||||
|
|
||||||
|
fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
|
||||||
|
sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters
|
||||||
|
|
||||||
let
|
let
|
||||||
studyTermCandidates = Set.fromList $ do
|
studyTermCandidates = Set.fromList $ do
|
||||||
name <- termNames
|
let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs'
|
||||||
StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
|
subTermsKeys = unStudyTermsKey . fst <$> sts
|
||||||
return (key, name)
|
|
||||||
|
(,) <$> sfKeys ++ subTermsKeys <*> termNames
|
||||||
|
|
||||||
|
let
|
||||||
|
assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) DB [StudyFeatures]
|
||||||
|
assimilateSubTerms [] xs = return xs
|
||||||
|
assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do
|
||||||
|
standalone <- lift $ get subterm
|
||||||
|
case standalone of
|
||||||
|
_other
|
||||||
|
| (match : matches, unusedFeats') <- partition
|
||||||
|
(\StudyFeatures{..} -> subterm == studyFeaturesField
|
||||||
|
&& subSemester == studyFeaturesSemester
|
||||||
|
) unusedFeats
|
||||||
|
-> do
|
||||||
|
$logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|]
|
||||||
|
(:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats')
|
||||||
|
| any ((== subterm) . studyFeaturesField) unusedFeats
|
||||||
|
-> do
|
||||||
|
$logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|]
|
||||||
|
assimilateSubTerms subterms unusedFeats
|
||||||
|
Just StudyTerms{..}
|
||||||
|
| Just defDegree <- studyTermsDefaultDegree
|
||||||
|
, Just defType <- studyTermsDefaultType
|
||||||
|
-> do
|
||||||
|
$logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|]
|
||||||
|
(:) (StudyFeatures userId defDegree subterm Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats
|
||||||
|
Nothing
|
||||||
|
| [] <- unusedFeats -> do
|
||||||
|
$logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|]
|
||||||
|
tell $ Set.singleton (subterm, Nothing)
|
||||||
|
assimilateSubTerms subterms []
|
||||||
|
_other -> do
|
||||||
|
knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
|
||||||
|
let matchingFeatures = case knownParents of
|
||||||
|
[] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
|
||||||
|
ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> any (== studyFeaturesField) ps && studyFeaturesSemester == subSemester) unusedFeats
|
||||||
|
when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
|
||||||
|
tell $ Set.singleton (subterm, Just studyFeaturesField)
|
||||||
|
if
|
||||||
|
| not $ null knownParents -> do
|
||||||
|
$logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|]
|
||||||
|
(++) (matchingFeatures & traverse . _studyFeaturesSubField %~ (<|> Just subterm)) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures)
|
||||||
|
| otherwise -> do
|
||||||
|
$logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|]
|
||||||
|
assimilateSubTerms subterms unusedFeats
|
||||||
|
$logDebugS "Campus" [st|Terms for “#{credsIdent}”: #{tshow (sts, fs')}|]
|
||||||
|
(fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs'
|
||||||
|
|
||||||
|
let
|
||||||
studyTermCandidateIncidence
|
studyTermCandidateIncidence
|
||||||
= fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
|
= fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
|
||||||
. UUID.fromByteString
|
. UUID.fromByteString
|
||||||
. fromStrict
|
. fromStrict
|
||||||
. (convert :: Digest (SHAKE128 128) -> ByteString)
|
. (convert :: Digest (SHAKE128 128) -> ByteString)
|
||||||
. runConduitPure
|
. runConduitPure
|
||||||
$ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) .| sinkHash
|
$ sourceList ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash
|
||||||
|
|
||||||
candidatesRecorded <- E.selectExists . E.from $ \candidate ->
|
candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do
|
||||||
E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
|
E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence
|
||||||
|
E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence
|
||||||
|
E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
||||||
|
E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
||||||
|
E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
||||||
|
|
||||||
unless candidatesRecorded $ do
|
unless candidatesRecorded $ do
|
||||||
let
|
let
|
||||||
studyTermCandidates' = do
|
studyTermCandidates' = do
|
||||||
(studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
|
(studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates
|
||||||
return StudyTermCandidate{..}
|
let studyTermNameCandidateIncidence = studyTermCandidateIncidence
|
||||||
|
return StudyTermNameCandidate{..}
|
||||||
insertMany_ studyTermCandidates'
|
insertMany_ studyTermCandidates'
|
||||||
|
|
||||||
|
let
|
||||||
|
studySubTermParentCandidates' = do
|
||||||
|
(StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates
|
||||||
|
let studySubTermParentCandidateIncidence = studyTermCandidateIncidence
|
||||||
|
return StudySubTermParentCandidate{..}
|
||||||
|
insertMany_ studySubTermParentCandidates'
|
||||||
|
|
||||||
|
let
|
||||||
|
studyTermStandaloneCandidates' = do
|
||||||
|
(StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates
|
||||||
|
let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence
|
||||||
|
return StudyTermStandaloneCandidate{..}
|
||||||
|
insertMany_ studyTermStandaloneCandidates'
|
||||||
|
|
||||||
E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
|
E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
|
||||||
forM_ fs $ \f@StudyFeatures{..} -> do
|
forM_ fs $ \f@StudyFeatures{..} -> do
|
||||||
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||||
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
|
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
|
||||||
void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
|
void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True, StudyFeaturesSubField =. studyFeaturesSubField]
|
||||||
associateUserSchoolsByTerms userId
|
associateUserSchoolsByTerms userId
|
||||||
|
|
||||||
let
|
let
|
||||||
|
|||||||
@ -1,507 +1,18 @@
|
|||||||
module Handler.Admin where
|
module Handler.Admin
|
||||||
|
( module Handler.Admin
|
||||||
|
) where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Jobs
|
|
||||||
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
|
|
||||||
|
|
||||||
import Control.Monad.Trans.Except
|
import Handler.Admin.Test as Handler.Admin
|
||||||
import Control.Monad.Trans.Writer (mapWriterT)
|
import Handler.Admin.ErrorMessage as Handler.Admin
|
||||||
|
import Handler.Admin.StudyFeatures as Handler.Admin
|
||||||
-- import Data.Time
|
|
||||||
import Data.Char (isDigit)
|
|
||||||
import qualified Data.Text as Text
|
|
||||||
-- import Data.Function ((&))
|
|
||||||
-- import Yesod.Form.Bootstrap3
|
|
||||||
|
|
||||||
import qualified Data.Set as Set
|
|
||||||
import qualified Data.Map as Map
|
|
||||||
|
|
||||||
import Database.Persist.Sql (fromSqlKey)
|
|
||||||
import qualified Database.Esqueleto as E
|
|
||||||
import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
|
|
||||||
|
|
||||||
import qualified Handler.Utils.TermCandidates as Candidates
|
|
||||||
|
|
||||||
-- import Colonnade hiding (fromMaybe)
|
|
||||||
-- import Yesod.Colonnade
|
|
||||||
|
|
||||||
-- import qualified Data.UUID.Cryptographic as UUID
|
|
||||||
|
|
||||||
|
|
||||||
getAdminR :: Handler Html
|
getAdminR :: Handler Html
|
||||||
getAdminR = -- do
|
getAdminR =
|
||||||
siteLayoutMsg MsgAdminHeading $ do
|
siteLayoutMsg MsgAdminHeading $ do
|
||||||
setTitleI MsgAdminHeading
|
setTitleI MsgAdminHeading
|
||||||
i18n MsgAdminPageEmpty
|
i18n MsgAdminPageEmpty
|
||||||
|
|
||||||
-- BEGIN - Buttons needed only here
|
|
||||||
data ButtonCreate = CreateMath | CreateInf -- Dummy for Example
|
|
||||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
||||||
instance Universe ButtonCreate
|
|
||||||
instance Finite ButtonCreate
|
|
||||||
|
|
||||||
nullaryPathPiece ''ButtonCreate camelToPathPiece
|
|
||||||
|
|
||||||
instance Button UniWorX ButtonCreate where
|
|
||||||
btnLabel CreateMath = [whamlet|Ma<i>thema</i>tik|]
|
|
||||||
btnLabel CreateInf = "Informatik"
|
|
||||||
|
|
||||||
btnClasses CreateMath = [BCIsButton, BCInfo]
|
|
||||||
btnClasses CreateInf = [BCIsButton, BCPrimary]
|
|
||||||
-- END Button needed only here
|
|
||||||
|
|
||||||
emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext)
|
|
||||||
emailTestForm = (,)
|
|
||||||
<$> areq emailField (fslI MsgMailTestFormEmail) Nothing
|
|
||||||
<*> ( MailContext
|
|
||||||
<$> (Languages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
|
|
||||||
<*> (toMailDateTimeFormat
|
|
||||||
<$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
|
|
||||||
<*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
|
|
||||||
<*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
|
|
||||||
)
|
|
||||||
)
|
|
||||||
where
|
|
||||||
toMailDateTimeFormat dt d t = \case
|
|
||||||
SelFormatDateTime -> dt
|
|
||||||
SelFormatDate -> d
|
|
||||||
SelFormatTime -> t
|
|
||||||
|
|
||||||
makeDemoForm :: Int -> Form (Int,Bool,Double)
|
|
||||||
makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
|
|
||||||
(result, widget) <- flip (renderAForm FormStandard) html $ (,,)
|
|
||||||
<$> areq (minIntFieldI n ("Zahl" :: Text)) (fromString $ "Ganzzahl > " ++ show n) Nothing
|
|
||||||
<* aformSection MsgFormBehaviour
|
|
||||||
<*> areq checkBoxField "Muss nächste Zahl größer sein?" (Just True)
|
|
||||||
<*> areq doubleField "Fliesskommazahl" Nothing
|
|
||||||
-- NO LONGER DESIRED IN AFORMS:
|
|
||||||
-- <* submitButton
|
|
||||||
return $ case result of
|
|
||||||
FormSuccess fsres
|
|
||||||
| errorMsgs <- validateResult fsres
|
|
||||||
, not $ null errorMsgs -> (FormFailure errorMsgs, widget)
|
|
||||||
_otherwise -> (result, widget)
|
|
||||||
where
|
|
||||||
validateResult :: (Int,Bool,Double) -> [Text]
|
|
||||||
validateResult (i,True,d) | fromIntegral i >= d = [tshow d <> " ist nicht größer als " <> tshow i, "Zweite Fehlermeldung", "Dritte Fehlermeldung"]
|
|
||||||
validateResult _other = []
|
|
||||||
|
|
||||||
|
|
||||||
getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
|
|
||||||
getAdminTestR = postAdminTestR
|
|
||||||
postAdminTestR = do
|
|
||||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate)
|
|
||||||
let btnForm = wrapForm btnWdgt def
|
|
||||||
{ formAction = Just $ SomeRoute AdminTestR
|
|
||||||
, formEncoding = btnEnctype
|
|
||||||
, formSubmit = FormNoSubmit
|
|
||||||
}
|
|
||||||
case btnResult of
|
|
||||||
(FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt"
|
|
||||||
(FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
|
|
||||||
FormMissing -> return ()
|
|
||||||
_other -> addMessage Warning "KEIN Knopf erkannt"
|
|
||||||
|
|
||||||
((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
|
|
||||||
formResultModal emailResult AdminTestR $ \(email, ls) -> do
|
|
||||||
jId <- mapWriterT runDB $ do
|
|
||||||
jId <- queueJob $ JobSendTestEmail email ls
|
|
||||||
tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
|
|
||||||
return jId
|
|
||||||
runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
|
|
||||||
addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`
|
|
||||||
|
|
||||||
let emailWidget' = wrapForm emailWidget def
|
|
||||||
{ formAction = Just . SomeRoute $ AdminTestR
|
|
||||||
, formEncoding = emailEnctype
|
|
||||||
, formAttrs = [("uw-async-form", "")]
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
let demoFormAction (_i,_b,_d) = addMessage Info "All ok."
|
|
||||||
((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7
|
|
||||||
formResult demoResult demoFormAction
|
|
||||||
let showDemoResult = [whamlet|
|
|
||||||
$maybe (i,b,d) <- formResult' demoResult
|
|
||||||
Received values:
|
|
||||||
<ul>
|
|
||||||
<li>#{show i}
|
|
||||||
<li>#{show b}
|
|
||||||
<li>#{show d}
|
|
||||||
$nothing
|
|
||||||
No form values received, due to #
|
|
||||||
$# Using formResult' above means that we usually to not distinguish the following two cases here, sind formResult does this already:
|
|
||||||
$case demoResult
|
|
||||||
$of FormSuccess _
|
|
||||||
$# Already dealt with above, to showecase usage of formResult' as normally done.
|
|
||||||
success, which should not happen here.
|
|
||||||
$of FormMissing
|
|
||||||
Form data missing, probably empty.
|
|
||||||
$of FormFailure msgs
|
|
||||||
<ul>
|
|
||||||
$forall m <- msgs
|
|
||||||
<li>#{m}
|
|
||||||
|]
|
|
||||||
let testTooltipMsg = toWidget [whamlet| So sehen aktuell Tooltips via iconTooltip aus. |] :: WidgetFor UniWorX ()
|
|
||||||
|
|
||||||
msgInfoTooltip <- messageI Info ("Info-Tooltip via messageI" :: Text)
|
|
||||||
msgSuccessTooltip <- messageI Success ("Success-Tooltip via messageI" :: Text)
|
|
||||||
msgWarningTooltip <- messageI Warning ("Warning-Tooltip via messageI" :: Text)
|
|
||||||
msgErrorTooltip <- messageI Error ("Error-Tooltip via messageI" :: Text)
|
|
||||||
|
|
||||||
msgNonDefaultIconTooltip <- messageIconI Info IconEmail ("Info-Tooltip mit lustigem Icon" :: Text)
|
|
||||||
|
|
||||||
{- The following demonstrates the use of @massInput@.
|
|
||||||
|
|
||||||
@massInput@ takes as arguments:
|
|
||||||
- A configuration struct describing how the Widget should behave (how is the space of sub-forms structured, how many dimensions does it have, which additions/deletions are permitted, what data do they need to operate and what should their effect on the overall shape be?)
|
|
||||||
- Information on how the resulting field fits into the form as a whole (@FieldSettings@ and whether the @massInput@ should be marked required)
|
|
||||||
- An initial value to pre-fill the field with
|
|
||||||
|
|
||||||
@massInput@ then returns an @MForm@ structured for easy downstream consumption of the result
|
|
||||||
-}
|
|
||||||
let
|
|
||||||
-- We define the fields of the configuration struct @MassInput@:
|
|
||||||
|
|
||||||
-- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell)
|
|
||||||
--
|
|
||||||
-- This /needs/ to replace all occurrences of @mreq@ with @mpreq@ (no fields should be /actually/ required)
|
|
||||||
mkAddForm :: ListPosition -- ^ Approximate position of the add-widget
|
|
||||||
-> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
|
|
||||||
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
|
|
||||||
-> FieldView UniWorX -- ^ Submit-Button for this add-widget
|
|
||||||
-> Maybe (Form (Map ListPosition Int -> FormResult (Map ListPosition Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cells and data needed to initialize cells
|
|
||||||
mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do
|
|
||||||
(addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration
|
|
||||||
let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done
|
|
||||||
addRes'' = addRes' <&> \dat prev -> FormSuccess (Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) dat) -- Construct the callback to determine new cell positions and data within @FormResult@ as required, nested @FormResult@ allows aborting the add depending on previous data
|
|
||||||
return (addRes'', toWidget csrf >> fvInput addView >> fvInput submitBtn)
|
|
||||||
mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"
|
|
||||||
|
|
||||||
-- | Make a single massInput-Cell
|
|
||||||
--
|
|
||||||
-- This /needs/ to use @nudge@ and deterministic field naming (this allows for correct value-shifting when cells are deleted)
|
|
||||||
mkCellForm :: ListPosition -- ^ Position of this cell
|
|
||||||
-> Int -- ^ Data needed to initialize the cell (see return of @mkAddForm@)
|
|
||||||
-> Maybe Int -- ^ Initial cell result from Argument to `massInput`
|
|
||||||
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
|
|
||||||
-> Form Int
|
|
||||||
mkCellForm _pos cData initial nudge csrf = do -- Extremely simple cell
|
|
||||||
(intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData
|
|
||||||
return (intRes, toWidget csrf >> fvInput intView)
|
|
||||||
-- | How does the shape (`ListLength`) change if a certain cell is deleted?
|
|
||||||
deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
|
|
||||||
-> ListPosition -- ^ Coordinate to delete
|
|
||||||
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
|
|
||||||
deleteCell = miDeleteList
|
|
||||||
-- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
|
|
||||||
allowAdd :: ListPosition -> Natural -> ListLength -> Bool
|
|
||||||
allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)
|
|
||||||
-- | Where to send the user when they click a shape-changing button, given the id of the Wrapper of the `massInput`-`Widget`
|
|
||||||
buttonAction :: PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
||||||
buttonAction frag = Just . SomeRoute $ AdminTestR :#: frag
|
|
||||||
|
|
||||||
-- The actual call to @massInput@ is comparatively simple:
|
|
||||||
|
|
||||||
((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing
|
|
||||||
|
|
||||||
|
|
||||||
let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
|
|
||||||
siteLayout locallyDefinedPageHeading $ do
|
|
||||||
-- defaultLayout $ do
|
|
||||||
setTitle "Uni2work Admin Testpage"
|
|
||||||
$(i18nWidgetFile "admin-test")
|
|
||||||
|
|
||||||
[whamlet|<h2>Formular Demonstration|]
|
|
||||||
wrapForm formWidget FormSettings
|
|
||||||
{ formMethod = POST
|
|
||||||
, formAction = Just . SomeRoute $ AdminTestR :#: FIDAdminDemo
|
|
||||||
, formEncoding = formEnctype
|
|
||||||
, formAttrs = []
|
|
||||||
, formSubmit = FormSubmit
|
|
||||||
, formAnchor = Just FIDAdminDemo
|
|
||||||
}
|
|
||||||
showDemoResult
|
|
||||||
|
|
||||||
miIdent <- newIdent
|
|
||||||
let miForm' = wrapForm miForm FormSettings
|
|
||||||
{ formMethod = POST
|
|
||||||
, formAction = Just . SomeRoute $ AdminTestR :#: miIdent
|
|
||||||
, formEncoding = miEnc
|
|
||||||
, formAttrs = []
|
|
||||||
, formSubmit = FormSubmit
|
|
||||||
, formAnchor = Just miIdent
|
|
||||||
}
|
|
||||||
[whamlet|
|
|
||||||
<h2>Mass-Input
|
|
||||||
^{miForm'}
|
|
||||||
$case miResult
|
|
||||||
$of FormMissing
|
|
||||||
$of FormFailure errs
|
|
||||||
<ul>
|
|
||||||
$forall err <- errs
|
|
||||||
<li>#{err}
|
|
||||||
$of FormSuccess res
|
|
||||||
<p style="white-space:pre-wrap; font-family:monospace;">
|
|
||||||
#{tshow res}
|
|
||||||
|]
|
|
||||||
|
|
||||||
|
|
||||||
getAdminErrMsgR, postAdminErrMsgR :: Handler Html
|
|
||||||
getAdminErrMsgR = postAdminErrMsgR
|
|
||||||
postAdminErrMsgR = do
|
|
||||||
MsgRenderer mr <- getMsgRenderer
|
|
||||||
((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
|
|
||||||
unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext (mr MsgErrMsgCiphertext)) Nothing
|
|
||||||
|
|
||||||
plaintext <- formResultMaybe ctResult $ exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) . (encodedSecretBoxOpen :: Text -> ExceptT EncodedSecretBoxException Handler Value)
|
|
||||||
|
|
||||||
let ctView' = wrapForm ctView def{ formAction = Just . SomeRoute $ AdminErrMsgR, formEncoding = ctEncoding }
|
|
||||||
defaultLayout
|
|
||||||
[whamlet|
|
|
||||||
$maybe t <- plaintext
|
|
||||||
<pre style="white-space:pre-wrap; font-family:monospace">
|
|
||||||
$case t
|
|
||||||
$of String t'
|
|
||||||
#{t'}
|
|
||||||
$of t'
|
|
||||||
#{encodePrettyToTextBuilder t'}
|
|
||||||
|
|
||||||
^{ctView'}
|
|
||||||
|]
|
|
||||||
|
|
||||||
|
|
||||||
-- BEGIN - Buttons needed only for StudyTermCandidateManagement
|
|
||||||
data ButtonAdminStudyTerms
|
|
||||||
= BtnCandidatesInfer
|
|
||||||
| BtnCandidatesDeleteConflicts
|
|
||||||
| BtnCandidatesDeleteAll
|
|
||||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
||||||
instance Universe ButtonAdminStudyTerms
|
|
||||||
instance Finite ButtonAdminStudyTerms
|
|
||||||
|
|
||||||
nullaryPathPiece ''ButtonAdminStudyTerms camelToPathPiece
|
|
||||||
embedRenderMessage ''UniWorX ''ButtonAdminStudyTerms id
|
|
||||||
|
|
||||||
instance Button UniWorX ButtonAdminStudyTerms where
|
|
||||||
btnClasses BtnCandidatesInfer = [BCIsButton, BCPrimary]
|
|
||||||
btnClasses BtnCandidatesDeleteConflicts = [BCIsButton, BCDanger]
|
|
||||||
btnClasses BtnCandidatesDeleteAll = [BCIsButton, BCDanger]
|
|
||||||
-- END Button needed only here
|
|
||||||
|
|
||||||
getAdminFeaturesR, postAdminFeaturesR :: Handler Html
|
|
||||||
getAdminFeaturesR = postAdminFeaturesR
|
|
||||||
postAdminFeaturesR = do
|
|
||||||
uid <- requireAuthId
|
|
||||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonAdminStudyTerms)
|
|
||||||
let btnForm = wrapForm btnWdgt def
|
|
||||||
{ formAction = Just $ SomeRoute AdminFeaturesR
|
|
||||||
, formEncoding = btnEnctype
|
|
||||||
, formSubmit = FormNoSubmit
|
|
||||||
}
|
|
||||||
infConflicts <- case btnResult of
|
|
||||||
FormSuccess BtnCandidatesInfer -> do
|
|
||||||
(infConflicts, infAmbiguous, infRedundant, infAccepted) <- Candidates.inferHandler
|
|
||||||
unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
|
|
||||||
unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
|
|
||||||
let newKeys = map (StudyTermsKey' . fst) infAccepted
|
|
||||||
setSessionJson SessionNewStudyTerms newKeys
|
|
||||||
if | null infAccepted
|
|
||||||
-> addMessageI Info MsgNoCandidatesInferred
|
|
||||||
| otherwise
|
|
||||||
-> addMessageI Success . MsgCandidatesInferred $ length infAccepted
|
|
||||||
return infConflicts
|
|
||||||
FormSuccess BtnCandidatesDeleteConflicts -> runDB $ do
|
|
||||||
confs <- Candidates.conflicts
|
|
||||||
incis <- Candidates.getIncidencesFor (entityKey <$> confs)
|
|
||||||
deleteWhere [StudyTermCandidateIncidence <-. (E.unValue <$> incis)]
|
|
||||||
addMessageI Success $ MsgIncidencesDeleted $ length incis
|
|
||||||
return []
|
|
||||||
FormSuccess BtnCandidatesDeleteAll -> runDB $ do
|
|
||||||
deleteWhere ([] :: [Filter StudyTermCandidate])
|
|
||||||
addMessageI Success MsgAllIncidencesDeleted
|
|
||||||
Candidates.conflicts
|
|
||||||
_other -> runDB Candidates.conflicts
|
|
||||||
|
|
||||||
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
|
|
||||||
( (degreeResult,degreeTable)
|
|
||||||
, (studyTermsResult,studytermsTable)
|
|
||||||
, ((), candidateTable)
|
|
||||||
, userSchools) <- runDB $ do
|
|
||||||
schools <- E.select . E.from $ \school -> do
|
|
||||||
E.where_ . E.exists . E.from $ \schoolFunction ->
|
|
||||||
E.where_ $ schoolFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId
|
|
||||||
E.&&. schoolFunction E.^. UserFunctionUser E.==. E.val uid
|
|
||||||
E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
|
||||||
return school
|
|
||||||
(,,,)
|
|
||||||
<$> mkDegreeTable
|
|
||||||
<*> mkStudytermsTable (Set.fromList newStudyTermKeys)
|
|
||||||
(Set.fromList $ map entityKey infConflicts)
|
|
||||||
(Set.fromList schools)
|
|
||||||
<*> mkCandidateTable
|
|
||||||
<*> pure schools
|
|
||||||
|
|
||||||
-- This needs to happen after calls to `dbTable` so they can short-circuit correctly
|
|
||||||
unless (null infConflicts) $ addMessageI Warning MsgStudyFeatureConflict
|
|
||||||
|
|
||||||
let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
|
|
||||||
degreeResult' = degreeResult <&> getDBFormResult
|
|
||||||
(\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
|
|
||||||
, row ^. _dbrOutput . _entityVal . _studyDegreeShorthand
|
|
||||||
))
|
|
||||||
updateDegree degreeKey (name,short) = update degreeKey [StudyDegreeName =. name, StudyDegreeShorthand =. short]
|
|
||||||
formResult degreeResult' $ \res -> do
|
|
||||||
void . runDB $ Map.traverseWithKey updateDegree res
|
|
||||||
addMessageI Success MsgStudyDegreeChangeSuccess
|
|
||||||
|
|
||||||
let studyTermsResult' :: FormResult (Map (Key StudyTerms) (Maybe Text, Maybe Text, Set SchoolId))
|
|
||||||
studyTermsResult' = studyTermsResult <&> getDBFormResult
|
|
||||||
(\row -> ( row ^. _dbrOutput . _1 . _entityVal . _studyTermsName
|
|
||||||
, row ^. _dbrOutput . _1 . _entityVal . _studyTermsShorthand
|
|
||||||
, row ^. _dbrOutput . _2
|
|
||||||
))
|
|
||||||
updateStudyTerms studyTermsKey (name,short,schools) = do
|
|
||||||
update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short]
|
|
||||||
forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey
|
|
||||||
deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools]
|
|
||||||
formResult studyTermsResult' $ \res -> do
|
|
||||||
void . runDB $ Map.traverseWithKey updateStudyTerms res
|
|
||||||
addMessageI Success MsgStudyTermsChangeSuccess
|
|
||||||
|
|
||||||
siteLayoutMsg MsgAdminFeaturesHeading $ do
|
|
||||||
setTitleI MsgAdminFeaturesHeading
|
|
||||||
$(widgetFile "adminFeatures")
|
|
||||||
where
|
|
||||||
textInputCell :: Ord i
|
|
||||||
=> Lens' a (Maybe Text)
|
|
||||||
-> Getter (DBRow r) (Maybe Text)
|
|
||||||
-> Getter (DBRow r) i
|
|
||||||
-> DBRow r
|
|
||||||
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
|
||||||
textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
|
||||||
(\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
|
|
||||||
<$> mopt textField "" (Just $ row ^. lensDefault)
|
|
||||||
)
|
|
||||||
|
|
||||||
checkboxCell :: Ord i
|
|
||||||
=> Lens' a Bool
|
|
||||||
-> Getter (DBRow r) Bool
|
|
||||||
-> Getter (DBRow r) i
|
|
||||||
-> DBRow r
|
|
||||||
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
|
||||||
checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
|
||||||
( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
|
|
||||||
<$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
|
|
||||||
mkDegreeTable =
|
|
||||||
let dbtIdent = "admin-studydegrees" :: Text
|
|
||||||
dbtStyle = def
|
|
||||||
dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
|
|
||||||
dbtSQLQuery = return
|
|
||||||
dbtRowKey = (E.^. StudyDegreeKey)
|
|
||||||
dbtProj = return
|
|
||||||
dbtColonnade = formColonnade $ mconcat
|
|
||||||
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
|
|
||||||
, sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
|
|
||||||
, sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand) (_dbrOutput . _entityKey))
|
|
||||||
, dbRow
|
|
||||||
]
|
|
||||||
dbtSorting = Map.fromList
|
|
||||||
[ ("key" , SortColumn (E.^. StudyDegreeKey))
|
|
||||||
, ("name" , SortColumn (E.^. StudyDegreeName))
|
|
||||||
, ("short", SortColumn (E.^. StudyDegreeShorthand))
|
|
||||||
]
|
|
||||||
dbtFilter = mempty
|
|
||||||
dbtFilterUI = mempty
|
|
||||||
dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
|
|
||||||
}
|
|
||||||
psValidator = def -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
|
|
||||||
& defaultSorting [SortAscBy "key"]
|
|
||||||
dbtCsvEncode = noCsvEncode
|
|
||||||
dbtCsvDecode = Nothing
|
|
||||||
in dbTable psValidator DBTable{..}
|
|
||||||
|
|
||||||
mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> Set (Entity School) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text, Set SchoolId) (DBRow (Entity StudyTerms, Set SchoolId))), Widget)
|
|
||||||
mkStudytermsTable newKeys badKeys schools =
|
|
||||||
let dbtIdent = "admin-studyterms" :: Text
|
|
||||||
dbtStyle = def
|
|
||||||
dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
|
|
||||||
dbtSQLQuery = return
|
|
||||||
dbtRowKey = (E.^. StudyTermsKey)
|
|
||||||
dbtProj field = do
|
|
||||||
fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
|
|
||||||
E.where_ . E.exists . E.from $ \schoolTerms ->
|
|
||||||
E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
|
|
||||||
E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val (field ^. _dbrOutput . _entityKey)
|
|
||||||
E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
|
|
||||||
return $ school E.^. SchoolId
|
|
||||||
return $ field & _dbrOutput %~ (, fieldSchools)
|
|
||||||
dbtColonnade = formColonnade $ mconcat
|
|
||||||
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermsKey))
|
|
||||||
, sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey))
|
|
||||||
, sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey))
|
|
||||||
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) (_dbrOutput . _1 . _entityKey))
|
|
||||||
, sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) (_dbrOutput . _1 . _entityKey))
|
|
||||||
, flip foldMap schools $ \(Entity ssh School{schoolName}) ->
|
|
||||||
sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _2 . at ssh . _Maybe) (_dbrOutput . _1 . _entityKey))
|
|
||||||
, dbRow
|
|
||||||
]
|
|
||||||
dbtSorting = Map.fromList
|
|
||||||
[ ("key" , SortColumn (E.^. StudyTermsKey))
|
|
||||||
, ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsKey `E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys))) -- works only once
|
|
||||||
-- Remember: sorting with E.in_ by StudyTermsId instead will produce esqueleto-error "unsafeSqlBinOp: non-id/composite keys not expected here"
|
|
||||||
, ("isbad" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsKey `E.in_` E.valList (unStudyTermsKey <$> Set.toList badKeys)))
|
|
||||||
, ("name" , SortColumn (E.^. StudyTermsName))
|
|
||||||
, ("short" , SortColumn (E.^. StudyTermsShorthand))
|
|
||||||
]
|
|
||||||
dbtFilter = mempty
|
|
||||||
dbtFilterUI = mempty
|
|
||||||
dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
|
|
||||||
}
|
|
||||||
psValidator = def
|
|
||||||
-- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
|
|
||||||
& defaultSorting [SortDescBy "isnew", SortDescBy "isbad", SortAscBy "key"]
|
|
||||||
dbtCsvEncode = noCsvEncode
|
|
||||||
dbtCsvDecode = Nothing
|
|
||||||
in dbTable psValidator DBTable{..}
|
|
||||||
|
|
||||||
mkCandidateTable =
|
|
||||||
let dbtIdent = "admin-termcandidate" :: Text
|
|
||||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
||||||
dbtSQLQuery :: E.SqlExpr (Entity StudyTermCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermCandidate))
|
|
||||||
dbtSQLQuery = return
|
|
||||||
dbtRowKey = (E.^. StudyTermCandidateId)
|
|
||||||
dbtProj = return
|
|
||||||
dbtColonnade = dbColonnade $ mconcat
|
|
||||||
[ dbRow
|
|
||||||
, sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermCandidateKey))
|
|
||||||
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermCandidateName))
|
|
||||||
, sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermCandidateIncidence))
|
|
||||||
]
|
|
||||||
dbtSorting = Map.fromList
|
|
||||||
[ ("key" , SortColumn (E.^. StudyTermCandidateKey))
|
|
||||||
, ("name" , SortColumn (E.^. StudyTermCandidateName))
|
|
||||||
, ("incidence", SortColumn (E.^. StudyTermCandidateIncidence))
|
|
||||||
]
|
|
||||||
dbtFilter = Map.fromList
|
|
||||||
[ ("key", FilterColumn $ mkExactFilter (E.^. StudyTermCandidateKey))
|
|
||||||
, ("name", FilterColumn $ mkContainsFilter (E.^. StudyTermCandidateName))
|
|
||||||
, ("incidence", FilterColumn $ mkExactFilter (E.^. StudyTermCandidateIncidence)) -- contains filter desired, but impossible here
|
|
||||||
]
|
|
||||||
dbtFilterUI mPrev = mconcat
|
|
||||||
-- [ prismAForm (singletonFilter "key") mPrev $ aopt intField (fslI MsgStudyTermsKey) -- Typing problem exactFilter suffices here
|
|
||||||
[ prismAForm (singletonFilter "key") mPrev $ aopt textField (fslI MsgStudyTermsKey)
|
|
||||||
, prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgStudyTermsName)
|
|
||||||
, prismAForm (singletonFilter "incidence") mPrev $ aopt textField (fslI MsgStudyCandidateIncidence)
|
|
||||||
]
|
|
||||||
dbtParams = def
|
|
||||||
psValidator = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"]
|
|
||||||
dbtCsvEncode = noCsvEncode
|
|
||||||
dbtCsvDecode = Nothing
|
|
||||||
in dbTable psValidator DBTable{..}
|
|
||||||
|
|
||||||
|
|||||||
32
src/Handler/Admin/ErrorMessage.hs
Normal file
32
src/Handler/Admin/ErrorMessage.hs
Normal file
@ -0,0 +1,32 @@
|
|||||||
|
module Handler.Admin.ErrorMessage
|
||||||
|
( getAdminErrMsgR, postAdminErrMsgR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
import Handler.Utils
|
||||||
|
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
|
||||||
|
|
||||||
|
import Control.Monad.Trans.Except
|
||||||
|
|
||||||
|
|
||||||
|
getAdminErrMsgR, postAdminErrMsgR :: Handler Html
|
||||||
|
getAdminErrMsgR = postAdminErrMsgR
|
||||||
|
postAdminErrMsgR = do
|
||||||
|
((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
|
||||||
|
unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext "Ciphertext") Nothing
|
||||||
|
|
||||||
|
plaintext <- formResultMaybe ctResult $ exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) . (encodedSecretBoxOpen :: Text -> ExceptT EncodedSecretBoxException Handler Value)
|
||||||
|
|
||||||
|
let ctView' = wrapForm ctView def{ formAction = Just . SomeRoute $ AdminErrMsgR, formEncoding = ctEncoding }
|
||||||
|
defaultLayout
|
||||||
|
[whamlet|
|
||||||
|
$maybe t <- plaintext
|
||||||
|
<pre style="white-space:pre-wrap; font-family:monospace">
|
||||||
|
$case t
|
||||||
|
$of String t'
|
||||||
|
#{t'}
|
||||||
|
$of t'
|
||||||
|
#{encodePrettyToTextBuilder t'}
|
||||||
|
|
||||||
|
^{ctView'}
|
||||||
|
|]
|
||||||
528
src/Handler/Admin/StudyFeatures.hs
Normal file
528
src/Handler/Admin/StudyFeatures.hs
Normal file
@ -0,0 +1,528 @@
|
|||||||
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||||
|
|
||||||
|
module Handler.Admin.StudyFeatures
|
||||||
|
( getAdminFeaturesR, postAdminFeaturesR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
import Handler.Utils
|
||||||
|
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
|
||||||
|
|
||||||
|
import qualified Handler.Utils.TermCandidates as Candidates
|
||||||
|
|
||||||
|
|
||||||
|
data ButtonAdminStudyTermsNames
|
||||||
|
= BtnNameCandidatesInfer
|
||||||
|
| BtnNameCandidatesDeleteConflicts
|
||||||
|
| BtnNameCandidatesDeleteAll
|
||||||
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||||
|
instance Universe ButtonAdminStudyTermsNames
|
||||||
|
instance Finite ButtonAdminStudyTermsNames
|
||||||
|
|
||||||
|
nullaryPathPiece ''ButtonAdminStudyTermsNames $ camelToPathPiece' 1
|
||||||
|
embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsNames id
|
||||||
|
|
||||||
|
instance Button UniWorX ButtonAdminStudyTermsNames where
|
||||||
|
btnClasses BtnNameCandidatesInfer = [BCIsButton, BCPrimary]
|
||||||
|
btnClasses BtnNameCandidatesDeleteConflicts = [BCIsButton, BCDanger]
|
||||||
|
btnClasses BtnNameCandidatesDeleteAll = [BCIsButton, BCDanger]
|
||||||
|
|
||||||
|
data ButtonAdminStudyTermsParents
|
||||||
|
= BtnParentCandidatesInfer
|
||||||
|
| BtnParentCandidatesDeleteAll
|
||||||
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||||
|
instance Universe ButtonAdminStudyTermsParents
|
||||||
|
instance Finite ButtonAdminStudyTermsParents
|
||||||
|
|
||||||
|
nullaryPathPiece ''ButtonAdminStudyTermsParents $ camelToPathPiece' 1
|
||||||
|
embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsParents id
|
||||||
|
|
||||||
|
instance Button UniWorX ButtonAdminStudyTermsParents where
|
||||||
|
btnClasses BtnParentCandidatesInfer = [BCIsButton, BCPrimary]
|
||||||
|
btnClasses BtnParentCandidatesDeleteAll = [BCIsButton, BCDanger]
|
||||||
|
|
||||||
|
data ButtonAdminStudyTermsStandalone
|
||||||
|
= BtnStandaloneCandidatesDeleteRedundant
|
||||||
|
| BtnStandaloneCandidatesDeleteAll
|
||||||
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||||
|
instance Universe ButtonAdminStudyTermsStandalone
|
||||||
|
instance Finite ButtonAdminStudyTermsStandalone
|
||||||
|
|
||||||
|
nullaryPathPiece ''ButtonAdminStudyTermsStandalone $ camelToPathPiece' 1
|
||||||
|
embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsStandalone id
|
||||||
|
|
||||||
|
instance Button UniWorX ButtonAdminStudyTermsStandalone where
|
||||||
|
btnClasses BtnStandaloneCandidatesDeleteRedundant = [BCIsButton, BCPrimary]
|
||||||
|
btnClasses BtnStandaloneCandidatesDeleteAll = [BCIsButton, BCDanger]
|
||||||
|
|
||||||
|
|
||||||
|
getAdminFeaturesR, postAdminFeaturesR :: Handler Html
|
||||||
|
getAdminFeaturesR = postAdminFeaturesR
|
||||||
|
postAdminFeaturesR = do
|
||||||
|
uid <- requireAuthId
|
||||||
|
((nameBtnResult, nameBtnWdgt), nameBtnEnctype) <- runFormPost $ identifyForm ("infer-names-button" :: Text) buttonForm
|
||||||
|
let nameBtnForm = wrapForm nameBtnWdgt def
|
||||||
|
{ formAction = Just $ SomeRoute AdminFeaturesR
|
||||||
|
, formEncoding = nameBtnEnctype
|
||||||
|
, formSubmit = FormNoSubmit
|
||||||
|
}
|
||||||
|
infNameConflicts <- case nameBtnResult of
|
||||||
|
FormSuccess BtnNameCandidatesInfer -> do
|
||||||
|
(infConflicts, infAmbiguous, infRedundantNames, infAccepted) <- Candidates.inferNamesHandler
|
||||||
|
unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousNameCandidatesRemoved $ length infAmbiguous
|
||||||
|
unless (null infRedundantNames) . addMessageI Info . MsgRedundantNameCandidatesRemoved $ length infRedundantNames
|
||||||
|
unless (null infConflicts) $ do
|
||||||
|
let badKeys = map entityKey infConflicts
|
||||||
|
setSessionJson SessionConflictingStudyTerms badKeys
|
||||||
|
addMessageI Warning MsgStudyFeatureConflict
|
||||||
|
|
||||||
|
let newKeys = map fst infAccepted
|
||||||
|
setSessionJson SessionNewStudyTerms newKeys
|
||||||
|
|
||||||
|
if | null infAccepted
|
||||||
|
-> addMessageI Info MsgNoNameCandidatesInferred
|
||||||
|
| otherwise
|
||||||
|
-> addMessageI Success . MsgNameCandidatesInferred $ length infAccepted
|
||||||
|
redirect AdminFeaturesR
|
||||||
|
FormSuccess BtnNameCandidatesDeleteConflicts -> do
|
||||||
|
runDB $ do
|
||||||
|
confs <- Candidates.nameConflicts
|
||||||
|
incis <- Candidates.getNameIncidencesFor $ map entityKey confs
|
||||||
|
deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)]
|
||||||
|
addMessageI Success $ MsgIncidencesDeleted $ length incis
|
||||||
|
redirect AdminFeaturesR
|
||||||
|
FormSuccess BtnNameCandidatesDeleteAll -> do
|
||||||
|
runDB $ do
|
||||||
|
deleteWhere ([] :: [Filter StudyTermNameCandidate])
|
||||||
|
addMessageI Success MsgAllNameIncidencesDeleted
|
||||||
|
redirect AdminFeaturesR
|
||||||
|
_other -> runDB Candidates.nameConflicts
|
||||||
|
|
||||||
|
((parentsBtnResult, parentsBtnWdgt), parentsBtnEnctype) <- runFormPost $ identifyForm ("infer-parents-button" :: Text) buttonForm
|
||||||
|
let parentsBtnForm = wrapForm parentsBtnWdgt def
|
||||||
|
{ formAction = Just $ SomeRoute AdminFeaturesR
|
||||||
|
, formEncoding = parentsBtnEnctype
|
||||||
|
, formSubmit = FormNoSubmit
|
||||||
|
}
|
||||||
|
formResult parentsBtnResult $ \case
|
||||||
|
BtnParentCandidatesInfer -> do
|
||||||
|
(infRedundantParents, infAccepted) <- Candidates.inferParentsHandler
|
||||||
|
unless (null infRedundantParents) . addMessageI Info . MsgRedundantParentCandidatesRemoved $ length infRedundantParents
|
||||||
|
|
||||||
|
let newKeys = map (studySubTermsChild . entityVal) infAccepted
|
||||||
|
setSessionJson SessionNewStudyTerms newKeys
|
||||||
|
|
||||||
|
if | null infAccepted
|
||||||
|
-> addMessageI Info MsgNoParentCandidatesInferred
|
||||||
|
| otherwise
|
||||||
|
-> addMessageI Success . MsgParentCandidatesInferred $ length infAccepted
|
||||||
|
redirect AdminFeaturesR
|
||||||
|
BtnParentCandidatesDeleteAll -> do
|
||||||
|
runDB $ do
|
||||||
|
deleteWhere ([] :: [Filter StudySubTermParentCandidate])
|
||||||
|
addMessageI Success MsgAllParentIncidencesDeleted
|
||||||
|
redirect AdminFeaturesR
|
||||||
|
|
||||||
|
((standaloneBtnResult, standaloneBtnWdgt), standaloneBtnEnctype) <- runFormPost $ identifyForm ("infer-standalone-button" :: Text) buttonForm
|
||||||
|
let standaloneBtnForm = wrapForm standaloneBtnWdgt def
|
||||||
|
{ formAction = Just $ SomeRoute AdminFeaturesR
|
||||||
|
, formEncoding = standaloneBtnEnctype
|
||||||
|
, formSubmit = FormNoSubmit
|
||||||
|
}
|
||||||
|
formResult standaloneBtnResult $ \case
|
||||||
|
BtnStandaloneCandidatesDeleteRedundant -> do
|
||||||
|
infRedundantStandalone <- runDB Candidates.removeRedundantStandalone
|
||||||
|
unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
|
||||||
|
redirect AdminFeaturesR
|
||||||
|
BtnStandaloneCandidatesDeleteAll -> do
|
||||||
|
runDB $ do
|
||||||
|
deleteWhere ([] :: [Filter StudyTermStandaloneCandidate])
|
||||||
|
addMessageI Success MsgAllStandaloneIncidencesDeleted
|
||||||
|
redirect AdminFeaturesR
|
||||||
|
|
||||||
|
|
||||||
|
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
|
||||||
|
badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms
|
||||||
|
( (degreeResult,degreeTable)
|
||||||
|
, (studyTermsResult,studytermsTable)
|
||||||
|
, ((), candidateTable)
|
||||||
|
, userSchools
|
||||||
|
, ((), parentCandidateTable)
|
||||||
|
, (standaloneResult, standaloneCandidateTable)) <- runDB $ do
|
||||||
|
schools <- E.select . E.from $ \school -> do
|
||||||
|
E.where_ . E.exists . E.from $ \schoolFunction ->
|
||||||
|
E.where_ $ schoolFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId
|
||||||
|
E.&&. schoolFunction E.^. UserFunctionUser E.==. E.val uid
|
||||||
|
E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
||||||
|
return school
|
||||||
|
(,,,,,)
|
||||||
|
<$> mkDegreeTable
|
||||||
|
<*> mkStudytermsTable (Set.fromList newStudyTermKeys)
|
||||||
|
(Set.fromList $ fromMaybe (map entityKey infNameConflicts) badStudyTermKeys)
|
||||||
|
(Set.fromList schools)
|
||||||
|
<*> mkCandidateTable
|
||||||
|
<*> pure schools
|
||||||
|
<*> mkParentCandidateTable
|
||||||
|
<*> mkStandaloneCandidateTable
|
||||||
|
|
||||||
|
let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
|
||||||
|
degreeResult' = degreeResult <&> getDBFormResult
|
||||||
|
(\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
|
||||||
|
, row ^. _dbrOutput . _entityVal . _studyDegreeShorthand
|
||||||
|
))
|
||||||
|
updateDegree degreeKey (name,short) = update degreeKey [StudyDegreeName =. name, StudyDegreeShorthand =. short]
|
||||||
|
formResult degreeResult' $ \res -> do
|
||||||
|
void . runDB $ Map.traverseWithKey updateDegree res
|
||||||
|
addMessageI Success MsgStudyDegreeChangeSuccess
|
||||||
|
redirect $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
|
||||||
|
|
||||||
|
let standaloneResult' :: FormResult (Map (Key StudyTermStandaloneCandidate) (Maybe StudyDegreeId, Maybe StudyFieldType))
|
||||||
|
standaloneResult' = standaloneResult <&> getDBFormResult
|
||||||
|
(\row -> ( row ^? _dbrOutput . _2 . _Just . _entityVal . _studyTermsDefaultDegree . _Just
|
||||||
|
, row ^? _dbrOutput . _2 . _Just . _entityVal . _studyTermsDefaultType . _Just
|
||||||
|
))
|
||||||
|
formResult standaloneResult' $ \res -> do
|
||||||
|
updated <- runDB . iforM res $ \candidateId (mDegree, mType) -> do
|
||||||
|
StudyTermStandaloneCandidate{..} <- getJust candidateId
|
||||||
|
let termsId = StudyTermsKey' studyTermStandaloneCandidateKey
|
||||||
|
updated <- case (,) <$> mDegree <*> mType of
|
||||||
|
Nothing -> return Nothing
|
||||||
|
Just (degree, typ) -> do
|
||||||
|
ifM (existsKey termsId)
|
||||||
|
( update termsId
|
||||||
|
[ StudyTermsDefaultDegree =. Just degree
|
||||||
|
, StudyTermsDefaultType =. Just typ
|
||||||
|
]
|
||||||
|
)
|
||||||
|
( insert_ $ StudyTerms studyTermStandaloneCandidateKey Nothing Nothing (Just degree) (Just typ)
|
||||||
|
)
|
||||||
|
return $ Just termsId
|
||||||
|
infRedundantStandalone <- Candidates.removeRedundantStandalone
|
||||||
|
unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
|
||||||
|
return updated
|
||||||
|
|
||||||
|
let newKeys = catMaybes $ Map.elems updated
|
||||||
|
unless (null newKeys) $ do
|
||||||
|
setSessionJson SessionNewStudyTerms newKeys
|
||||||
|
|
||||||
|
redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
|
||||||
|
|
||||||
|
|
||||||
|
let studyTermsResult' :: FormResult (Map StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType))
|
||||||
|
studyTermsResult' = studyTermsResult <&> getDBFormResult
|
||||||
|
(\row -> ( row ^? _dbrOutput . _1 . _entityVal . _studyTermsName . _Just
|
||||||
|
, row ^? _dbrOutput . _1 . _entityVal . _studyTermsShorthand . _Just
|
||||||
|
, row ^. _dbrOutput . _3
|
||||||
|
, row ^. _dbrOutput . _2 . to (Set.map entityKey)
|
||||||
|
, row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree . _Just
|
||||||
|
, row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultType . _Just
|
||||||
|
))
|
||||||
|
updateStudyTerms studyTermsKey (name,short,schools,parents,degree,sType) = do
|
||||||
|
degreeExists <- fmap (fromMaybe False) . for degree $ fmap (is _Just) . get
|
||||||
|
update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short, StudyTermsDefaultDegree =. guard degreeExists *> degree, StudyTermsDefaultType =. sType]
|
||||||
|
|
||||||
|
forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey
|
||||||
|
deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools]
|
||||||
|
|
||||||
|
forM_ parents $ void . insertUnique . StudySubTerms studyTermsKey
|
||||||
|
deleteWhere [StudySubTermsChild ==. studyTermsKey, StudySubTermsParent /<-. Set.toList parents]
|
||||||
|
formResult studyTermsResult' $ \res -> do
|
||||||
|
void . runDB $ Map.traverseWithKey updateStudyTerms res
|
||||||
|
addMessageI Success MsgStudyTermsChangeSuccess
|
||||||
|
redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
|
||||||
|
|
||||||
|
siteLayoutMsg MsgAdminFeaturesHeading $ do
|
||||||
|
setTitleI MsgAdminFeaturesHeading
|
||||||
|
$(widgetFile "adminFeatures")
|
||||||
|
where
|
||||||
|
textInputCell :: Ord i
|
||||||
|
=> Lens' a (Maybe Text)
|
||||||
|
-> Getter (DBRow r) (Maybe Text)
|
||||||
|
-> Getter (DBRow r) i
|
||||||
|
-> DBRow r
|
||||||
|
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
||||||
|
textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
||||||
|
(\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
|
||||||
|
<$> mopt (textField & cfStrip) "" (Just $ row ^. lensDefault)
|
||||||
|
)
|
||||||
|
|
||||||
|
checkboxCell :: Ord i
|
||||||
|
=> Lens' a Bool
|
||||||
|
-> Getter (DBRow r) Bool
|
||||||
|
-> Getter (DBRow r) i
|
||||||
|
-> DBRow r
|
||||||
|
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
||||||
|
checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
||||||
|
( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
|
||||||
|
<$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
|
||||||
|
)
|
||||||
|
|
||||||
|
-- termKeyCell :: Ord i
|
||||||
|
-- => Lens' a (Maybe StudyTermsId)
|
||||||
|
-- -> Getter (DBRow r) (Maybe StudyTermsId)
|
||||||
|
-- -> Getter (DBRow r) i
|
||||||
|
-- -> DBRow r
|
||||||
|
-- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
||||||
|
-- termKeyCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
||||||
|
-- ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
|
||||||
|
-- <$> mopt (intField & isoField (from _StudyTermsId)) "" (Just $ row ^. lensDefault)
|
||||||
|
-- )
|
||||||
|
|
||||||
|
parentsCell :: Ord i
|
||||||
|
=> Lens' a (Set StudyTermsId)
|
||||||
|
-> Getter (DBRow r) (Set StudyTermsId)
|
||||||
|
-> Getter (DBRow r) i
|
||||||
|
-> DBRow r
|
||||||
|
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
||||||
|
parentsCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
||||||
|
( \row mkUnique -> (\(res, fieldView) -> (set lensRes . Set.fromList <$> res, fvInput fieldView))
|
||||||
|
<$> massInputList
|
||||||
|
(intField & isoField (from _StudyTermsId))
|
||||||
|
(const "")
|
||||||
|
(Just . SomeRoute . (AdminFeaturesR :#:))
|
||||||
|
(mkUnique ("parents" :: Text))
|
||||||
|
""
|
||||||
|
False
|
||||||
|
(Just . Set.toList $ row ^. lensDefault)
|
||||||
|
mempty
|
||||||
|
)
|
||||||
|
|
||||||
|
degreeCell :: Ord i
|
||||||
|
=> Lens' a (Maybe StudyDegreeId)
|
||||||
|
-> Getter (DBRow r) (Maybe StudyDegreeId)
|
||||||
|
-> Getter (DBRow r) i
|
||||||
|
-> DBRow r
|
||||||
|
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
||||||
|
degreeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
||||||
|
( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
|
||||||
|
<$> mopt degreeField "" (Just $ row ^. lensDefault)
|
||||||
|
)
|
||||||
|
|
||||||
|
fieldTypeCell :: Ord i
|
||||||
|
=> Lens' a (Maybe StudyFieldType)
|
||||||
|
-> Getter (DBRow r) (Maybe StudyFieldType)
|
||||||
|
-> Getter (DBRow r) i
|
||||||
|
-> DBRow r
|
||||||
|
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
|
||||||
|
fieldTypeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
|
||||||
|
( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
|
||||||
|
<$> mopt (selectField optionsFinite) "" (Just $ row ^. lensDefault)
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
|
||||||
|
mkDegreeTable =
|
||||||
|
let dbtIdent = "admin-studydegrees" :: Text
|
||||||
|
dbtStyle = def
|
||||||
|
dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
|
||||||
|
dbtSQLQuery = return
|
||||||
|
dbtRowKey = (E.^. StudyDegreeKey)
|
||||||
|
dbtProj = return
|
||||||
|
dbtColonnade = formColonnade $ mconcat
|
||||||
|
[ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
|
||||||
|
, sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
|
||||||
|
, sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand) (_dbrOutput . _entityKey))
|
||||||
|
, dbRow
|
||||||
|
]
|
||||||
|
dbtSorting = Map.fromList
|
||||||
|
[ ("key" , SortColumn (E.^. StudyDegreeKey))
|
||||||
|
, ("name" , SortColumn (E.^. StudyDegreeName))
|
||||||
|
, ("short", SortColumn (E.^. StudyDegreeShorthand))
|
||||||
|
]
|
||||||
|
dbtFilter = mempty
|
||||||
|
dbtFilterUI = mempty
|
||||||
|
dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
|
||||||
|
}
|
||||||
|
psValidator = def -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
|
||||||
|
& defaultPagesize PagesizeAll
|
||||||
|
& defaultSorting [SortAscBy "key"]
|
||||||
|
dbtCsvEncode = noCsvEncode
|
||||||
|
dbtCsvDecode = Nothing
|
||||||
|
in dbTable psValidator DBTable{..}
|
||||||
|
|
||||||
|
mkStudytermsTable :: Set StudyTermsId -> Set StudyTermsId -> Set (Entity School) -> DB (FormResult (DBFormResult StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTerms, Set (Entity StudyTerms), Set SchoolId))), Widget)
|
||||||
|
mkStudytermsTable newKeys badKeys schools =
|
||||||
|
let dbtIdent = "admin-studyterms" :: Text
|
||||||
|
dbtStyle = def
|
||||||
|
dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
|
||||||
|
dbtSQLQuery = return
|
||||||
|
dbtRowKey = (E.^. StudyTermsKey)
|
||||||
|
dbtProj field@(view _dbrOutput -> Entity fId _) = do
|
||||||
|
fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
|
||||||
|
E.where_ . E.exists . E.from $ \schoolTerms ->
|
||||||
|
E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
|
||||||
|
E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId
|
||||||
|
E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
|
||||||
|
return $ school E.^. SchoolId
|
||||||
|
fieldParents <- fmap (setOf folded) . lift . E.select . E.from $ \terms -> do
|
||||||
|
E.where_ . E.exists . E.from $ \subTerms ->
|
||||||
|
E.where_ $ subTerms E.^. StudySubTermsChild E.==. E.val fId
|
||||||
|
E.&&. subTerms E.^. StudySubTermsParent E.==. terms E.^. StudyTermsId
|
||||||
|
return terms
|
||||||
|
return $ field & _dbrOutput %~ (\field' -> (field', fieldParents, fieldSchools))
|
||||||
|
dbtColonnade = formColonnade $ mconcat
|
||||||
|
[ sortable (Just "key") (i18nCell MsgGenericKey) (maybe mempty numCell . preview (_dbrOutput . _1 . _entityVal . _studyTermsKey))
|
||||||
|
, sortable Nothing (i18nCell MsgStudySubTermsParentKey) (parentsCell _4 (_dbrOutput . _2 . to (Set.map entityKey)) _dbrKey')
|
||||||
|
, sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey))
|
||||||
|
, sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey))
|
||||||
|
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) _dbrKey')
|
||||||
|
, sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) _dbrKey')
|
||||||
|
, sortable (Just "degree") (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _5 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree) _dbrKey')
|
||||||
|
, sortable (Just "field-type") (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _6 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultType) _dbrKey')
|
||||||
|
, flip foldMap schools $ \(Entity ssh School{schoolName}) ->
|
||||||
|
sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _3 . at ssh . _Maybe) _dbrKey')
|
||||||
|
, dbRow
|
||||||
|
]
|
||||||
|
dbtSorting = Map.fromList
|
||||||
|
[ ("key" , SortColumn $ queryField >>> (E.^. StudyTermsKey))
|
||||||
|
-- , ("parent", SortColumn $ \t -> querySubField t E.?. StudySubTermsParent)
|
||||||
|
, ("isnew" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys))
|
||||||
|
)
|
||||||
|
, ("isbad" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList badKeys))
|
||||||
|
)
|
||||||
|
, ("name" , SortColumn $ queryField >>> (E.^. StudyTermsName))
|
||||||
|
, ("short" , SortColumn $ queryField >>> (E.^. StudyTermsShorthand))
|
||||||
|
, ("degree" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultDegree))
|
||||||
|
, ("field-type" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultType))
|
||||||
|
]
|
||||||
|
dbtFilter = mempty
|
||||||
|
dbtFilterUI = mempty
|
||||||
|
dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
|
||||||
|
}
|
||||||
|
psValidator = def
|
||||||
|
& defaultPagesize PagesizeAll
|
||||||
|
& defaultSorting [SortAscBy "isnew", SortAscBy "isbad", SortAscBy "key"]
|
||||||
|
dbtCsvEncode = noCsvEncode
|
||||||
|
dbtCsvDecode = Nothing
|
||||||
|
|
||||||
|
queryField = id
|
||||||
|
_dbrKey' :: Getter (DBRow (Entity StudyTerms, _, _)) StudyTermsId
|
||||||
|
_dbrKey' = _dbrOutput . _1 . _entityKey
|
||||||
|
in dbTable psValidator DBTable{..}
|
||||||
|
|
||||||
|
mkCandidateTable =
|
||||||
|
let dbtIdent = "admin-termcandidate" :: Text
|
||||||
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||||
|
dbtSQLQuery :: E.SqlExpr (Entity StudyTermNameCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermNameCandidate))
|
||||||
|
dbtSQLQuery = return
|
||||||
|
dbtRowKey = (E.^. StudyTermNameCandidateId)
|
||||||
|
dbtProj = return
|
||||||
|
dbtColonnade = dbColonnade $ mconcat
|
||||||
|
[ dbRow
|
||||||
|
, sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateKey))
|
||||||
|
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateName))
|
||||||
|
, sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateIncidence))
|
||||||
|
]
|
||||||
|
dbtSorting = Map.fromList
|
||||||
|
[ ("key" , SortColumn (E.^. StudyTermNameCandidateKey))
|
||||||
|
, ("name" , SortColumn (E.^. StudyTermNameCandidateName))
|
||||||
|
, ("incidence", SortColumn (E.^. StudyTermNameCandidateIncidence))
|
||||||
|
]
|
||||||
|
dbtFilter = Map.fromList
|
||||||
|
[ ("key", FilterColumn $ mkExactFilter (E.^. StudyTermNameCandidateKey))
|
||||||
|
, ("name", FilterColumn $ mkContainsFilter (E.^. StudyTermNameCandidateName))
|
||||||
|
, ("incidence", FilterColumn $ mkExactFilter (E.^. StudyTermNameCandidateIncidence)) -- contains filter desired, but impossible here
|
||||||
|
]
|
||||||
|
dbtFilterUI mPrev = mconcat
|
||||||
|
[ prismAForm (singletonFilter "key" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field _ Int) (fslI MsgStudyTermsKey)
|
||||||
|
, prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgStudyTermsName)
|
||||||
|
, prismAForm (singletonFilter "incidence") mPrev $ aopt textField (fslI MsgStudyCandidateIncidence)
|
||||||
|
]
|
||||||
|
dbtParams = def
|
||||||
|
psValidator = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"]
|
||||||
|
dbtCsvEncode = noCsvEncode
|
||||||
|
dbtCsvDecode = Nothing
|
||||||
|
in dbTable psValidator DBTable{..}
|
||||||
|
|
||||||
|
mkParentCandidateTable =
|
||||||
|
let dbtIdent = "admin-termparentcandidate" :: Text
|
||||||
|
dbtStyle = def
|
||||||
|
dbtSQLQuery :: E.SqlExpr (Entity StudySubTermParentCandidate)
|
||||||
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
||||||
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
||||||
|
-> E.SqlQuery ( E.SqlExpr (Entity StudySubTermParentCandidate)
|
||||||
|
, E.SqlExpr (Maybe (Entity StudyTerms))
|
||||||
|
, E.SqlExpr (Maybe (Entity StudyTerms))
|
||||||
|
)
|
||||||
|
dbtSQLQuery (candidate `E.LeftOuterJoin` parent `E.LeftOuterJoin` child) = do
|
||||||
|
E.on $ child E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateKey)
|
||||||
|
E.on $ parent E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateParent)
|
||||||
|
return (candidate, parent, child)
|
||||||
|
dbtRowKey = queryCandidate >>> (E.^. StudySubTermParentCandidateId)
|
||||||
|
dbtProj = return
|
||||||
|
dbtColonnade = dbColonnade $ mconcat
|
||||||
|
[ dbRow
|
||||||
|
, sortable (Just "child") (i18nCell MsgStudySubTermsChildKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey))
|
||||||
|
, sortable (Just "child-name") (i18nCell MsgStudySubTermsChildName) (maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _studyTermsName . _Just))
|
||||||
|
, sortable (Just "parent") (i18nCell MsgStudySubTermsParentKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateParent))
|
||||||
|
, sortable (Just "parent-name") (i18nCell MsgStudySubTermsParentName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
|
||||||
|
, sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateIncidence))
|
||||||
|
]
|
||||||
|
dbtSorting = Map.fromList
|
||||||
|
[ ("child" , SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateKey))
|
||||||
|
, ("child-name", SortColumn $ queryChild >>> (E.?. StudyTermsName) >>> E.joinV)
|
||||||
|
, ("parent" , SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateParent))
|
||||||
|
, ("parent-name", SortColumn $ queryParent >>> (E.?. StudyTermsName) >>> E.joinV)
|
||||||
|
, ("incidence", SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateIncidence))
|
||||||
|
]
|
||||||
|
dbtFilter = mempty
|
||||||
|
dbtFilterUI = mempty
|
||||||
|
dbtParams = def
|
||||||
|
psValidator = def
|
||||||
|
& defaultSorting [SortAscBy "child", SortAscBy "incidence", SortAscBy "parent"]
|
||||||
|
dbtCsvEncode = noCsvEncode
|
||||||
|
dbtCsvDecode = Nothing
|
||||||
|
|
||||||
|
queryCandidate (c `E.LeftOuterJoin` _ `E.LeftOuterJoin` _) = c
|
||||||
|
queryParent (_ `E.LeftOuterJoin` p `E.LeftOuterJoin` _) = p
|
||||||
|
queryChild (_ `E.LeftOuterJoin` _ `E.LeftOuterJoin` c) = c
|
||||||
|
in dbTable psValidator DBTable{..}
|
||||||
|
|
||||||
|
mkStandaloneCandidateTable :: DB (FormResult (DBFormResult StudyTermStandaloneCandidateId (Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTermStandaloneCandidate, Maybe (Entity StudyTerms)))), Widget)
|
||||||
|
mkStandaloneCandidateTable =
|
||||||
|
let dbtIdent = "admin-termstandalonecandidate" :: Text
|
||||||
|
dbtStyle = def
|
||||||
|
dbtSQLQuery :: E.SqlExpr (Entity StudyTermStandaloneCandidate)
|
||||||
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
||||||
|
-> E.SqlQuery ( E.SqlExpr (Entity StudyTermStandaloneCandidate)
|
||||||
|
, E.SqlExpr (Maybe (Entity StudyTerms))
|
||||||
|
)
|
||||||
|
dbtSQLQuery (candidate `E.LeftOuterJoin` sterm) = do
|
||||||
|
E.on $ sterm E.?. StudyTermsKey E.==. E.just (candidate E.^. StudyTermStandaloneCandidateKey)
|
||||||
|
return (candidate, sterm)
|
||||||
|
dbtRowKey = queryCandidate >>> (E.^. StudyTermStandaloneCandidateId)
|
||||||
|
dbtProj = return
|
||||||
|
dbtColonnade = formColonnade $ mconcat
|
||||||
|
[ dbRow
|
||||||
|
, sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateKey))
|
||||||
|
, sortable (Just "name") (i18nCell MsgStudyTermsName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
|
||||||
|
, sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateIncidence))
|
||||||
|
, sortable Nothing (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _1 (pre $ _dbrOutput . _2 . _Just . _studyTermsDefaultDegree . _Just) _dbrKey')
|
||||||
|
, sortable Nothing (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _2 (pre $ _dbrOutput . _2 . _Just . _studyTermsDefaultType . _Just) _dbrKey')
|
||||||
|
]
|
||||||
|
dbtSorting = Map.fromList
|
||||||
|
[ ("key" , SortColumn $ queryCandidate >>> (E.^. StudyTermStandaloneCandidateKey))
|
||||||
|
, ("name" , SortColumn $ queryTerm >>> (E.?. StudyTermsName) >>> E.joinV)
|
||||||
|
, ("incidence", SortColumn $ queryCandidate >>> (E.^. StudyTermStandaloneCandidateIncidence))
|
||||||
|
]
|
||||||
|
dbtFilter = mempty
|
||||||
|
dbtFilterUI = mempty
|
||||||
|
dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
|
||||||
|
}
|
||||||
|
psValidator = def
|
||||||
|
& defaultSorting [SortAscBy "key", SortAscBy "incidence"]
|
||||||
|
dbtCsvEncode = noCsvEncode
|
||||||
|
dbtCsvDecode = Nothing
|
||||||
|
|
||||||
|
queryCandidate (c `E.LeftOuterJoin` _) = c
|
||||||
|
queryTerm (_ `E.LeftOuterJoin` t) = t
|
||||||
|
_dbrKey' :: Getter (DBRow (Entity StudyTermStandaloneCandidate, _)) StudyTermStandaloneCandidateId
|
||||||
|
_dbrKey' = _dbrOutput . _1 . _entityKey
|
||||||
|
in dbTable psValidator DBTable{..}
|
||||||
231
src/Handler/Admin/Test.hs
Normal file
231
src/Handler/Admin/Test.hs
Normal file
@ -0,0 +1,231 @@
|
|||||||
|
module Handler.Admin.Test
|
||||||
|
( getAdminTestR
|
||||||
|
, postAdminTestR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
import Handler.Utils
|
||||||
|
import Jobs
|
||||||
|
|
||||||
|
import Control.Monad.Trans.Writer (mapWriterT)
|
||||||
|
|
||||||
|
import Data.Char (isDigit)
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
|
import Database.Persist.Sql (fromSqlKey)
|
||||||
|
|
||||||
|
|
||||||
|
-- BEGIN - Buttons needed only here
|
||||||
|
data ButtonCreate = CreateMath | CreateInf -- Dummy for Example
|
||||||
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||||
|
instance Universe ButtonCreate
|
||||||
|
instance Finite ButtonCreate
|
||||||
|
|
||||||
|
nullaryPathPiece ''ButtonCreate camelToPathPiece
|
||||||
|
|
||||||
|
instance Button UniWorX ButtonCreate where
|
||||||
|
btnLabel CreateMath = [whamlet|Ma<i>thema</i>tik|]
|
||||||
|
btnLabel CreateInf = "Informatik"
|
||||||
|
|
||||||
|
btnClasses CreateMath = [BCIsButton, BCInfo]
|
||||||
|
btnClasses CreateInf = [BCIsButton, BCPrimary]
|
||||||
|
-- END Button needed only here
|
||||||
|
|
||||||
|
emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext)
|
||||||
|
emailTestForm = (,)
|
||||||
|
<$> areq emailField (fslI MsgMailTestFormEmail) Nothing
|
||||||
|
<*> ( MailContext
|
||||||
|
<$> (Languages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
|
||||||
|
<*> (toMailDateTimeFormat
|
||||||
|
<$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
|
||||||
|
<*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
|
||||||
|
<*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
|
||||||
|
)
|
||||||
|
)
|
||||||
|
where
|
||||||
|
toMailDateTimeFormat dt d t = \case
|
||||||
|
SelFormatDateTime -> dt
|
||||||
|
SelFormatDate -> d
|
||||||
|
SelFormatTime -> t
|
||||||
|
|
||||||
|
makeDemoForm :: Int -> Form (Int,Bool,Double)
|
||||||
|
makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
|
||||||
|
(result, widget) <- flip (renderAForm FormStandard) html $ (,,)
|
||||||
|
<$> areq (minIntFieldI n ("Zahl" :: Text)) (fromString $ "Ganzzahl > " ++ show n) Nothing
|
||||||
|
<* aformSection MsgFormBehaviour
|
||||||
|
<*> areq checkBoxField "Muss nächste Zahl größer sein?" (Just True)
|
||||||
|
<*> areq doubleField "Fliesskommazahl" Nothing
|
||||||
|
-- NO LONGER DESIRED IN AFORMS:
|
||||||
|
-- <* submitButton
|
||||||
|
return $ case result of
|
||||||
|
FormSuccess fsres
|
||||||
|
| errorMsgs <- validateResult fsres
|
||||||
|
, not $ null errorMsgs -> (FormFailure errorMsgs, widget)
|
||||||
|
_otherwise -> (result, widget)
|
||||||
|
where
|
||||||
|
validateResult :: (Int,Bool,Double) -> [Text]
|
||||||
|
validateResult (i,True,d) | fromIntegral i >= d = [tshow d <> " ist nicht größer als " <> tshow i, "Zweite Fehlermeldung", "Dritte Fehlermeldung"]
|
||||||
|
validateResult _other = []
|
||||||
|
|
||||||
|
|
||||||
|
getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
|
||||||
|
getAdminTestR = postAdminTestR
|
||||||
|
postAdminTestR = do
|
||||||
|
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate)
|
||||||
|
let btnForm = wrapForm btnWdgt def
|
||||||
|
{ formAction = Just $ SomeRoute AdminTestR
|
||||||
|
, formEncoding = btnEnctype
|
||||||
|
, formSubmit = FormNoSubmit
|
||||||
|
}
|
||||||
|
case btnResult of
|
||||||
|
(FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt"
|
||||||
|
(FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
|
||||||
|
FormMissing -> return ()
|
||||||
|
_other -> addMessage Warning "KEIN Knopf erkannt"
|
||||||
|
|
||||||
|
((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
|
||||||
|
formResultModal emailResult AdminTestR $ \(email, ls) -> do
|
||||||
|
jId <- mapWriterT runDB $ do
|
||||||
|
jId <- queueJob $ JobSendTestEmail email ls
|
||||||
|
tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
|
||||||
|
return jId
|
||||||
|
runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
|
||||||
|
addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`
|
||||||
|
|
||||||
|
let emailWidget' = wrapForm emailWidget def
|
||||||
|
{ formAction = Just . SomeRoute $ AdminTestR
|
||||||
|
, formEncoding = emailEnctype
|
||||||
|
, formAttrs = [("uw-async-form", "")]
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
let demoFormAction (_i,_b,_d) = addMessage Info "All ok."
|
||||||
|
((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7
|
||||||
|
formResult demoResult demoFormAction
|
||||||
|
let showDemoResult = [whamlet|
|
||||||
|
$maybe (i,b,d) <- formResult' demoResult
|
||||||
|
Received values:
|
||||||
|
<ul>
|
||||||
|
<li>#{show i}
|
||||||
|
<li>#{show b}
|
||||||
|
<li>#{show d}
|
||||||
|
$nothing
|
||||||
|
No form values received, due to #
|
||||||
|
$# Using formResult' above means that we usually to not distinguish the following two cases here, sind formResult does this already:
|
||||||
|
$case demoResult
|
||||||
|
$of FormSuccess _
|
||||||
|
$# Already dealt with above, to showecase usage of formResult' as normally done.
|
||||||
|
success, which should not happen here.
|
||||||
|
$of FormMissing
|
||||||
|
Form data missing, probably empty.
|
||||||
|
$of FormFailure msgs
|
||||||
|
<ul>
|
||||||
|
$forall m <- msgs
|
||||||
|
<li>#{m}
|
||||||
|
|]
|
||||||
|
let testTooltipMsg = toWidget [whamlet| So sehen aktuell Tooltips via iconTooltip aus. |] :: WidgetFor UniWorX ()
|
||||||
|
|
||||||
|
msgInfoTooltip <- messageI Info ("Info-Tooltip via messageI" :: Text)
|
||||||
|
msgSuccessTooltip <- messageI Success ("Success-Tooltip via messageI" :: Text)
|
||||||
|
msgWarningTooltip <- messageI Warning ("Warning-Tooltip via messageI" :: Text)
|
||||||
|
msgErrorTooltip <- messageI Error ("Error-Tooltip via messageI" :: Text)
|
||||||
|
|
||||||
|
msgNonDefaultIconTooltip <- messageIconI Info IconEmail ("Info-Tooltip mit lustigem Icon" :: Text)
|
||||||
|
|
||||||
|
{- The following demonstrates the use of @massInput@.
|
||||||
|
|
||||||
|
@massInput@ takes as arguments:
|
||||||
|
- A configuration struct describing how the Widget should behave (how is the space of sub-forms structured, how many dimensions does it have, which additions/deletions are permitted, what data do they need to operate and what should their effect on the overall shape be?)
|
||||||
|
- Information on how the resulting field fits into the form as a whole (@FieldSettings@ and whether the @massInput@ should be marked required)
|
||||||
|
- An initial value to pre-fill the field with
|
||||||
|
|
||||||
|
@massInput@ then returns an @MForm@ structured for easy downstream consumption of the result
|
||||||
|
-}
|
||||||
|
let
|
||||||
|
-- We define the fields of the configuration struct @MassInput@:
|
||||||
|
|
||||||
|
-- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell)
|
||||||
|
--
|
||||||
|
-- This /needs/ to replace all occurrences of @mreq@ with @mpreq@ (no fields should be /actually/ required)
|
||||||
|
mkAddForm :: ListPosition -- ^ Approximate position of the add-widget
|
||||||
|
-> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
|
||||||
|
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
|
||||||
|
-> FieldView UniWorX -- ^ Submit-Button for this add-widget
|
||||||
|
-> Maybe (Form (Map ListPosition Int -> FormResult (Map ListPosition Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cells and data needed to initialize cells
|
||||||
|
mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do
|
||||||
|
(addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration
|
||||||
|
let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done
|
||||||
|
addRes'' = addRes' <&> \dat prev -> FormSuccess (Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) dat) -- Construct the callback to determine new cell positions and data within @FormResult@ as required, nested @FormResult@ allows aborting the add depending on previous data
|
||||||
|
return (addRes'', toWidget csrf >> fvInput addView >> fvInput submitBtn)
|
||||||
|
mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"
|
||||||
|
|
||||||
|
-- | Make a single massInput-Cell
|
||||||
|
--
|
||||||
|
-- This /needs/ to use @nudge@ and deterministic field naming (this allows for correct value-shifting when cells are deleted)
|
||||||
|
mkCellForm :: ListPosition -- ^ Position of this cell
|
||||||
|
-> Int -- ^ Data needed to initialize the cell (see return of @mkAddForm@)
|
||||||
|
-> Maybe Int -- ^ Initial cell result from Argument to `massInput`
|
||||||
|
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
|
||||||
|
-> Form Int
|
||||||
|
mkCellForm _pos cData initial nudge csrf = do -- Extremely simple cell
|
||||||
|
(intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData
|
||||||
|
return (intRes, toWidget csrf >> fvInput intView)
|
||||||
|
-- | How does the shape (`ListLength`) change if a certain cell is deleted?
|
||||||
|
deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
|
||||||
|
-> ListPosition -- ^ Coordinate to delete
|
||||||
|
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
|
||||||
|
deleteCell = miDeleteList
|
||||||
|
-- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
|
||||||
|
allowAdd :: ListPosition -> Natural -> ListLength -> Bool
|
||||||
|
allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)
|
||||||
|
-- | Where to send the user when they click a shape-changing button, given the id of the Wrapper of the `massInput`-`Widget`
|
||||||
|
buttonAction :: PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
||||||
|
buttonAction frag = Just . SomeRoute $ AdminTestR :#: frag
|
||||||
|
|
||||||
|
-- The actual call to @massInput@ is comparatively simple:
|
||||||
|
|
||||||
|
((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing
|
||||||
|
|
||||||
|
|
||||||
|
let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
|
||||||
|
siteLayout locallyDefinedPageHeading $ do
|
||||||
|
-- defaultLayout $ do
|
||||||
|
setTitle "Uni2work Admin Testpage"
|
||||||
|
$(i18nWidgetFile "admin-test")
|
||||||
|
|
||||||
|
[whamlet|<h2>Formular Demonstration|]
|
||||||
|
wrapForm formWidget FormSettings
|
||||||
|
{ formMethod = POST
|
||||||
|
, formAction = Just . SomeRoute $ AdminTestR :#: FIDAdminDemo
|
||||||
|
, formEncoding = formEnctype
|
||||||
|
, formAttrs = []
|
||||||
|
, formSubmit = FormSubmit
|
||||||
|
, formAnchor = Just FIDAdminDemo
|
||||||
|
}
|
||||||
|
showDemoResult
|
||||||
|
|
||||||
|
miIdent <- newIdent
|
||||||
|
let miForm' = wrapForm miForm FormSettings
|
||||||
|
{ formMethod = POST
|
||||||
|
, formAction = Just . SomeRoute $ AdminTestR :#: miIdent
|
||||||
|
, formEncoding = miEnc
|
||||||
|
, formAttrs = []
|
||||||
|
, formSubmit = FormSubmit
|
||||||
|
, formAnchor = Just miIdent
|
||||||
|
}
|
||||||
|
[whamlet|
|
||||||
|
<h2>Mass-Input
|
||||||
|
^{miForm'}
|
||||||
|
$case miResult
|
||||||
|
$of FormMissing
|
||||||
|
$of FormFailure errs
|
||||||
|
<ul>
|
||||||
|
$forall err <- errs
|
||||||
|
<li>#{err}
|
||||||
|
$of FormSuccess res
|
||||||
|
<p style="white-space:pre-wrap; font-family:monospace;">
|
||||||
|
#{tshow res}
|
||||||
|
|]
|
||||||
@ -26,10 +26,9 @@ countCourses :: (Num n, PersistField n)
|
|||||||
=> (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool))
|
=> (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool))
|
||||||
-> E.SqlExpr (Entity Allocation)
|
-> E.SqlExpr (Entity Allocation)
|
||||||
-> E.SqlExpr (E.Value n)
|
-> E.SqlExpr (E.Value n)
|
||||||
countCourses addWhere allocation = E.sub_select . E.from $ \allocationCourse -> do
|
countCourses addWhere allocation = E.subSelectCount . E.from $ \allocationCourse ->
|
||||||
E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
|
E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
|
||||||
E.&&. addWhere allocationCourse
|
E.&&. addWhere allocationCourse
|
||||||
return E.countRows
|
|
||||||
|
|
||||||
queryAvailable :: Getter AllocationTableExpr (E.SqlExpr (E.Value Natural))
|
queryAvailable :: Getter AllocationTableExpr (E.SqlExpr (E.Value Natural))
|
||||||
queryAvailable = queryAllocation . to (countCourses $ const E.true)
|
queryAvailable = queryAllocation . to (countCourses $ const E.true)
|
||||||
|
|||||||
@ -75,7 +75,7 @@ correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet
|
|||||||
|
|
||||||
lastEditQuery :: Database.Esqueleto.Internal.Language.From (E.SqlExpr (Entity SubmissionEdit))
|
lastEditQuery :: Database.Esqueleto.Internal.Language.From (E.SqlExpr (Entity SubmissionEdit))
|
||||||
=> E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime))
|
=> E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime))
|
||||||
lastEditQuery submission = E.sub_select $ E.from $ \edit -> do
|
lastEditQuery submission = E.subSelectMaybe $ E.from $ \edit -> do
|
||||||
E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
|
E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
|
||||||
return $ E.max_ $ edit E.^. SubmissionEditTime
|
return $ E.max_ $ edit E.^. SubmissionEditTime
|
||||||
|
|
||||||
@ -297,7 +297,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
|
|||||||
)
|
)
|
||||||
, ( "submittors"
|
, ( "submittors"
|
||||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) ->
|
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) ->
|
||||||
E.sub_select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
E.subSelectUnsafe . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||||
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||||
@ -1215,9 +1215,8 @@ assignHandler tid ssh csh cid assignSids = do
|
|||||||
|
|
||||||
submissions <- E.select . E.from $ \submission -> do
|
submissions <- E.select . E.from $ \submission -> do
|
||||||
E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
|
E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
|
||||||
let numSubmittors = E.sub_select . E.from $ \subUser -> do
|
let numSubmittors = E.subSelectCount . E.from $ \subUser ->
|
||||||
E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
|
E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
|
||||||
return E.countRows
|
|
||||||
return (submission, numSubmittors)
|
return (submission, numSubmittors)
|
||||||
-- prepare map
|
-- prepare map
|
||||||
let infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo)
|
let infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo)
|
||||||
|
|||||||
@ -599,11 +599,10 @@ postCApplicationsR tid ssh csh = do
|
|||||||
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
|
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
|
||||||
E.&&. allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
|
E.&&. allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
|
||||||
|
|
||||||
let numApps addWhere = E.sub_select . E.from $ \courseApplication -> do
|
let numApps addWhere = E.subSelectCount . E.from $ \courseApplication -> do
|
||||||
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
||||||
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
|
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
|
||||||
addWhere courseApplication
|
addWhere courseApplication
|
||||||
return E.countRows
|
|
||||||
|
|
||||||
numApps' = numApps . const $ return ()
|
numApps' = numApps . const $ return ()
|
||||||
|
|
||||||
|
|||||||
@ -371,7 +371,7 @@ getCourseNewR = do
|
|||||||
E.&&. user E.^. UserFunctionSchool E.==. course E.^. CourseSchool
|
E.&&. user E.^. UserFunctionSchool E.==. course E.^. CourseSchool
|
||||||
E.&&. user E.^. UserFunctionFunction E.==. E.val SchoolLecturer
|
E.&&. user E.^. UserFunctionFunction E.==. E.val SchoolLecturer
|
||||||
let courseCreated c =
|
let courseCreated c =
|
||||||
E.sub_select . E.from $ \edit -> do -- oldest edit must be creation
|
E.subSelectMaybe . E.from $ \edit -> do -- oldest edit must be creation
|
||||||
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
|
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
|
||||||
return $ E.min_ $ edit E.^. CourseEditTime
|
return $ E.min_ $ edit E.^. CourseEditTime
|
||||||
E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
|
E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
|
||||||
|
|||||||
@ -61,9 +61,8 @@ colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
|
|||||||
type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
|
type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
|
||||||
|
|
||||||
course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
|
course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
|
||||||
course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do
|
course2Participants (course `E.InnerJoin` _school) = E.subSelectCount . E.from $ \courseParticipant ->
|
||||||
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||||
return (E.countRows :: E.SqlExpr (E.Value Int))
|
|
||||||
|
|
||||||
course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
|
course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
|
||||||
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
|
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
|
||||||
|
|||||||
@ -269,9 +269,7 @@ deregisterParticipant uid cid = do
|
|||||||
audit $ TransactionExamResultDeleted examResultExam uid
|
audit $ TransactionExamResultDeleted examResultExam uid
|
||||||
|
|
||||||
E.delete . E.from $ \tutorialParticipant -> do
|
E.delete . E.from $ \tutorialParticipant -> do
|
||||||
let tutorialCourse = E.sub_select . E.from $ \tutorial -> do
|
let tutorialCourse = E.subSelectForeign tutorialParticipant TutorialParticipantTutorial (E.^. TutorialCourse)
|
||||||
E.where_ $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
|
||||||
return $ tutorial E.^. TutorialCourse
|
|
||||||
|
|
||||||
E.where_ $ tutorialCourse E.==. E.val cid
|
E.where_ $ tutorialCourse E.==. E.val cid
|
||||||
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
|
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
|
||||||
|
|||||||
@ -37,9 +37,9 @@ getCShowR tid ssh csh = do
|
|||||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
E.limit 1 -- we know that there is at most one match, but we tell the DB this info too
|
E.limit 1 -- we know that there is at most one match, but we tell the DB this info too
|
||||||
let numParticipants = E.sub_select . E.from $ \part -> do
|
let numParticipants :: E.SqlExpr (E.Value Int)
|
||||||
|
numParticipants = E.subSelectCount . E.from $ \part ->
|
||||||
E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||||
return ( E.countRows :: E.SqlExpr (E.Value Int))
|
|
||||||
return (course,school E.^. SchoolName, numParticipants, participant)
|
return (course,school E.^. SchoolName, numParticipants, participant)
|
||||||
staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
|
staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
|
||||||
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
||||||
@ -146,9 +146,9 @@ getCShowR tid ssh csh = do
|
|||||||
Nothing -> mempty
|
Nothing -> mempty
|
||||||
Just tutorialCapacity' -> sqlCell $ do
|
Just tutorialCapacity' -> sqlCell $ do
|
||||||
freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe)
|
freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe)
|
||||||
. E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
|
. E.select $ let numParticipants :: E.SqlExpr (E.Value Int)
|
||||||
|
numParticipants = E.subSelectCount . E.from $ \participant ->
|
||||||
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||||
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
|
|
||||||
in return $ E.val tutorialCapacity' E.-. numParticipants
|
in return $ E.val tutorialCapacity' E.-. numParticipants
|
||||||
return . toWidget $ tshow freeCapacity
|
return . toWidget $ tshow freeCapacity
|
||||||
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
|
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
|
||||||
|
|||||||
@ -301,12 +301,12 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
|||||||
, single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
, single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||||
, single $ ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
, single $ ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
||||||
, single $ ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
, single $ ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
||||||
E.sub_select . E.from $ \edit -> do
|
E.subSelectMaybe . E.from $ \edit -> do
|
||||||
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
||||||
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
||||||
)
|
)
|
||||||
, single $ ("tutorials" , SortColumn $ queryUser >>> \user ->
|
, single $ ("tutorials" , SortColumn $ queryUser >>> \user ->
|
||||||
E.sub_select . E.from $ \(tutorial `E.InnerJoin` participant) -> do
|
E.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do
|
||||||
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
|
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
|
||||||
E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
|
E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
|
||||||
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
|
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
|
||||||
|
|||||||
@ -110,7 +110,7 @@ queryExamPart :: forall a.
|
|||||||
-> (E.SqlExpr (Entity ExamPart) -> E.SqlExpr (Maybe (Entity ExamPartResult)) -> E.SqlQuery (E.SqlExpr (E.Value a)))
|
-> (E.SqlExpr (Entity ExamPart) -> E.SqlExpr (Maybe (Entity ExamPartResult)) -> E.SqlQuery (E.SqlExpr (E.Value a)))
|
||||||
-> ExamUserTableExpr
|
-> ExamUserTableExpr
|
||||||
-> E.SqlExpr (E.Value a)
|
-> E.SqlExpr (E.Value a)
|
||||||
queryExamPart epId cont inp = E.sub_select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> flip runReaderT inp $ do
|
queryExamPart epId cont inp = E.subSelectUnsafe . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> flip runReaderT inp $ do
|
||||||
examRegistration <- asks queryExamRegistration
|
examRegistration <- asks queryExamRegistration
|
||||||
|
|
||||||
lift $ do
|
lift $ do
|
||||||
@ -528,7 +528,7 @@ postEUsersR tid ssh csh examn = do
|
|||||||
, singletonMap "result" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult)
|
, singletonMap "result" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult)
|
||||||
, singletonMap "result-bool" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]
|
, singletonMap "result-bool" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]
|
||||||
, singletonMap "note" . SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
|
, singletonMap "note" . SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
|
||||||
E.sub_select . E.from $ \edit -> do
|
E.subSelectMaybe . E.from $ \edit -> do
|
||||||
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
||||||
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
||||||
]
|
]
|
||||||
|
|||||||
@ -33,21 +33,19 @@ querySynchronised :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlE
|
|||||||
querySynchronised office = to . runReader $ do
|
querySynchronised office = to . runReader $ do
|
||||||
exam <- view queryExam
|
exam <- view queryExam
|
||||||
let
|
let
|
||||||
synchronised = E.sub_select . E.from $ \examResult -> do
|
synchronised = E.subSelectCount . E.from $ \examResult -> do
|
||||||
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
||||||
E.where_ $ Exam.examOfficeExamResultAuth office examResult
|
E.where_ $ Exam.examOfficeExamResultAuth office examResult
|
||||||
E.where_ $ Exam.resultIsSynced office examResult
|
E.where_ $ Exam.resultIsSynced office examResult
|
||||||
return E.countRows
|
|
||||||
return synchronised
|
return synchronised
|
||||||
|
|
||||||
queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural))
|
queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural))
|
||||||
queryResults office = to . runReader $ do
|
queryResults office = to . runReader $ do
|
||||||
exam <- view queryExam
|
exam <- view queryExam
|
||||||
let
|
let
|
||||||
results = E.sub_select . E.from $ \examResult -> do
|
results = E.subSelectCount . E.from $ \examResult -> do
|
||||||
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
||||||
E.where_ $ Exam.examOfficeExamResultAuth office examResult
|
E.where_ $ Exam.examOfficeExamResultAuth office examResult
|
||||||
return E.countRows
|
|
||||||
return results
|
return results
|
||||||
|
|
||||||
queryIsSynced :: UTCTime -> E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Bool))
|
queryIsSynced :: UTCTime -> E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Bool))
|
||||||
|
|||||||
@ -158,7 +158,7 @@ homeUpcomingExams uid = do
|
|||||||
startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
|
startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
|
||||||
E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now)
|
E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now)
|
||||||
E.&&. E.isJust (register E.?. ExamRegistrationId)
|
E.&&. E.isJust (register E.?. ExamRegistrationId)
|
||||||
earliestOccurrence = E.sub_select $ E.from $ \occ -> do
|
earliestOccurrence = E.subSelectMaybe $ E.from $ \occ -> do
|
||||||
E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId
|
E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId
|
||||||
E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now
|
E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now
|
||||||
return $ E.min_ $ occ E.^. ExamOccurrenceStart
|
return $ E.min_ $ occ E.^. ExamOccurrenceStart
|
||||||
|
|||||||
@ -114,9 +114,9 @@ getMaterialListR tid ssh csh = do
|
|||||||
, dbtParams = def
|
, dbtParams = def
|
||||||
, dbtSQLQuery = \material -> do
|
, dbtSQLQuery = \material -> do
|
||||||
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
|
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
|
||||||
let filesNum = E.sub_select . E.from $ \materialFile -> do
|
let filesNum :: E.SqlExpr (E.Value Int64)
|
||||||
|
filesNum = E.subSelectCount . E.from $ \materialFile ->
|
||||||
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
|
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
|
||||||
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64))
|
|
||||||
return (material, filesNum)
|
return (material, filesNum)
|
||||||
, dbtRowKey = (E.^. MaterialId)
|
, dbtRowKey = (E.^. MaterialId)
|
||||||
-- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr
|
-- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr
|
||||||
@ -331,9 +331,9 @@ postMDelR tid ssh csh mnm = do
|
|||||||
{ drRecords = Set.singleton $ entityKey matEnt
|
{ drRecords = Set.singleton $ entityKey matEnt
|
||||||
, drGetInfo = \(material `E.InnerJoin` course) -> do
|
, drGetInfo = \(material `E.InnerJoin` course) -> do
|
||||||
E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId
|
E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId
|
||||||
let filecount = E.sub_select . E.from $ \matfile -> do
|
let filecount :: E.SqlExpr (E.Value Int64)
|
||||||
|
filecount = E.subSelectCount . E.from $ \matfile ->
|
||||||
E.where_ $ matfile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
|
E.where_ $ matfile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
|
||||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
|
||||||
return (material,course,filecount)
|
return (material,course,filecount)
|
||||||
, drUnjoin = \(material `E.InnerJoin` _course) -> material
|
, drUnjoin = \(material `E.InnerJoin` _course) -> material
|
||||||
, drRenderRecord = \(Entity _ Material{..}, Entity _ Course{..}, E.Value fileCount) -> do
|
, drRenderRecord = \(Entity _ Material{..}, Entity _ Course{..}, E.Value fileCount) -> do
|
||||||
|
|||||||
@ -359,10 +359,13 @@ makeProfileData (Entity uid User{..}) = do
|
|||||||
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
||||||
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
|
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
|
||||||
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
|
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
|
||||||
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
|
studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) ->
|
||||||
|
E.distinctOnOrderBy [ E.asc $ studyfeat E.^. StudyFeaturesId ] $ do
|
||||||
|
E.orderBy [ E.desc $ studyfeat E.^. StudyFeaturesSubField E.==. E.just (studyterms E.^. StudyTermsId) ]
|
||||||
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
|
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
|
||||||
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
|
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
|
||||||
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
|
E.||. studyfeat E.^. StudyFeaturesSubField E.==. E.just (studyterms E.^. StudyTermsId)
|
||||||
|
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
|
||||||
return (studyfeat, studydegree, studyterms)
|
return (studyfeat, studydegree, studyterms)
|
||||||
--Tables
|
--Tables
|
||||||
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
|
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
|
||||||
@ -507,7 +510,7 @@ mkSubmissionTable =
|
|||||||
dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId
|
dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId
|
||||||
|
|
||||||
lastSubEdit uid submission = -- latest Edit-Time of this user for submission
|
lastSubEdit uid submission = -- latest Edit-Time of this user for submission
|
||||||
E.sub_select . E.from $ \subEdit -> do
|
E.subSelectMaybe . E.from $ \subEdit -> do
|
||||||
E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
|
E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
|
||||||
E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid
|
E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid
|
||||||
return . E.max_ $ subEdit E.^. SubmissionEditTime
|
return . E.max_ $ subEdit E.^. SubmissionEditTime
|
||||||
@ -590,7 +593,7 @@ mkSubmissionGroupTable =
|
|||||||
dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId
|
dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId
|
||||||
|
|
||||||
lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
|
lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
|
||||||
E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do
|
E.subSelectMaybe . E.from $ \(user `E.InnerJoin` sgEdit) -> do
|
||||||
E.on $ user E.^. UserId E.==. sgEdit E.^. SubmissionGroupEditUser
|
E.on $ user E.^. UserId E.==. sgEdit E.^. SubmissionGroupEditUser
|
||||||
E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
|
E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
|
||||||
return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime
|
return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime
|
||||||
@ -649,16 +652,14 @@ mkCorrectionsTable =
|
|||||||
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
|
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
|
||||||
withType = id
|
withType = id
|
||||||
|
|
||||||
corrsAssigned uid sheet = E.sub_select . E.from $ \submission -> do
|
corrsAssigned uid sheet = E.subSelectCount . E.from $ \submission ->
|
||||||
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||||
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||||
return E.countRows
|
|
||||||
|
|
||||||
corrsCorrected uid sheet = E.sub_select . E.from $ \submission -> do
|
corrsCorrected uid sheet = E.subSelectCount . E.from $ \submission ->
|
||||||
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||||
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||||
E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)
|
E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)
|
||||||
return E.countRows
|
|
||||||
|
|
||||||
dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do
|
dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do
|
||||||
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
||||||
|
|||||||
@ -201,7 +201,7 @@ getSheetListR tid ssh csh = do
|
|||||||
, sft /= SheetSolution || hasSolution
|
, sft /= SheetSolution || hasSolution
|
||||||
, sft /= SheetMarking || hasMarking
|
, sft /= SheetMarking || hasMarking
|
||||||
]
|
]
|
||||||
lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
|
lastSheetEdit sheet = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
||||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||||
return . E.max_ $ sheetEdit E.^. SheetEditTime
|
return . E.max_ $ sheetEdit E.^. SheetEditTime
|
||||||
|
|
||||||
@ -504,14 +504,14 @@ getSheetNewR tid ssh csh = do
|
|||||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
searchShn sheet
|
searchShn sheet
|
||||||
-- let lastSheetEdit = E.sub_select . E.from $ \sheetEdit -> do
|
-- let lastSheetEdit = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
||||||
-- E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
-- E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||||
-- return . E.max_ $ sheetEdit E.^. SheetEditTime
|
-- return . E.max_ $ sheetEdit E.^. SheetEditTime
|
||||||
-- Preferring last edited sheet may lead to suggesting duplicated sheet name numbers
|
-- Preferring last edited sheet may lead to suggesting duplicated sheet name numbers
|
||||||
-- E.orderBy [E.desc lastSheetEdit, E.desc (sheet E.^. SheetActiveFrom)]
|
-- E.orderBy [E.desc lastSheetEdit, E.desc (sheet E.^. SheetActiveFrom)]
|
||||||
E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
|
E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
|
||||||
E.limit 1
|
E.limit 1
|
||||||
let firstEdit = E.sub_select . E.from $ \sheetEdit -> do
|
let firstEdit = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
||||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||||
return . E.min_ $ sheetEdit E.^. SheetEditTime
|
return . E.min_ $ sheetEdit E.^. SheetEditTime
|
||||||
return (sheet, firstEdit)
|
return (sheet, firstEdit)
|
||||||
@ -711,7 +711,7 @@ defaultLoads cId = do
|
|||||||
fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
|
fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
|
||||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||||
|
|
||||||
let creationTime = E.sub_select . E.from $ \sheetEdit -> do
|
let creationTime = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
||||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||||
return . E.min_ $ sheetEdit E.^. SheetEditTime
|
return . E.min_ $ sheetEdit E.^. SheetEditTime
|
||||||
|
|
||||||
|
|||||||
@ -43,9 +43,8 @@ getTermShowR = do
|
|||||||
termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64))
|
termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64))
|
||||||
termData term = do
|
termData term = do
|
||||||
-- E.orderBy [E.desc $ term E.^. TermStart ]
|
-- E.orderBy [E.desc $ term E.^. TermStart ]
|
||||||
let courseCount = E.sub_select . E.from $ \course -> do
|
let courseCount = E.subSelectCount . E.from $ \course ->
|
||||||
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
|
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
|
||||||
return E.countRows
|
|
||||||
return (term, courseCount)
|
return (term, courseCount)
|
||||||
selectRep $ do
|
selectRep $ do
|
||||||
provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
|
provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
|
||||||
|
|||||||
@ -23,9 +23,8 @@ postTDeleteR tid ssh csh tutn = do
|
|||||||
, drUnjoin = \(_ `E.InnerJoin` tutorial) -> tutorial
|
, drUnjoin = \(_ `E.InnerJoin` tutorial) -> tutorial
|
||||||
, drGetInfo = \(course `E.InnerJoin` tutorial) -> do
|
, drGetInfo = \(course `E.InnerJoin` tutorial) -> do
|
||||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||||
let participants = E.sub_select . E.from $ \participant -> do
|
let participants = E.subSelectCount . E.from $ \participant ->
|
||||||
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
||||||
return E.countRows
|
|
||||||
return (course, tutorial, participants :: E.SqlExpr (E.Value Int))
|
return (course, tutorial, participants :: E.SqlExpr (E.Value Int))
|
||||||
, drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
|
, drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
|
||||||
return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (_{MsgParticipantsN ps})|]
|
return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (_{MsgParticipantsN ps})|]
|
||||||
|
|||||||
@ -22,9 +22,9 @@ getCTutorialListR tid ssh csh = do
|
|||||||
where
|
where
|
||||||
dbtSQLQuery tutorial = do
|
dbtSQLQuery tutorial = do
|
||||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||||
let participants = E.sub_select . E.from $ \tutorialParticipant -> do
|
let participants :: E.SqlExpr (E.Value Int)
|
||||||
|
participants = E.subSelectCount . E.from $ \tutorialParticipant ->
|
||||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
||||||
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
|
|
||||||
return (tutorial, participants)
|
return (tutorial, participants)
|
||||||
dbtRowKey = (E.^. TutorialId)
|
dbtRowKey = (E.^. TutorialId)
|
||||||
dbtProj = return . over (_dbrOutput . _2) E.unValue
|
dbtProj = return . over (_dbrOutput . _2) E.unValue
|
||||||
@ -58,9 +58,10 @@ getCTutorialListR tid ssh csh = do
|
|||||||
dbtSorting = Map.fromList
|
dbtSorting = Map.fromList
|
||||||
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
|
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
|
||||||
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
|
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
|
||||||
, ("participants", SortColumn $ \tutorial -> E.sub_select . E.from $ \tutorialParticipant -> do
|
, ("participants", SortColumn $ \tutorial -> let participantCount :: E.SqlExpr (E.Value Int)
|
||||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
participantCount = E.subSelectCount . E.from $ \tutorialParticipant ->
|
||||||
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
||||||
|
in participantCount
|
||||||
)
|
)
|
||||||
, ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity )
|
, ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity )
|
||||||
, ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
|
, ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
|
||||||
|
|||||||
@ -439,10 +439,9 @@ deleteUser duid = do
|
|||||||
selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)]
|
selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)]
|
||||||
selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do
|
selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do
|
||||||
E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission
|
E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission
|
||||||
let numBuddies = E.sub_select $ E.from $ \subUsers -> do
|
let numBuddies = E.subSelectCount $ E.from $ \subUsers ->
|
||||||
E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||||
E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid
|
E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid
|
||||||
return E.countRows
|
|
||||||
E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
|
E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
|
||||||
E.&&. whereBuddies numBuddies
|
E.&&. whereBuddies numBuddies
|
||||||
return $ submission E.^. SubmissionId
|
return $ submission E.^. SubmissionId
|
||||||
|
|||||||
@ -91,12 +91,11 @@ computeAllocation allocId cRestr = do
|
|||||||
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allocId
|
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allocId
|
||||||
|
|
||||||
let participants = E.sub_select . E.from $ \participant -> do
|
let participants = E.subSelectCount . E.from $ \participant -> do
|
||||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||||
E.where_ . E.not_ . E.exists . E.from $ \lecturer -> do
|
E.where_ . E.not_ . E.exists . E.from $ \lecturer ->
|
||||||
E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||||
E.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser
|
E.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser
|
||||||
return E.countRows
|
|
||||||
|
|
||||||
whenIsJust cRestr $ \restrSet ->
|
whenIsJust cRestr $ \restrSet ->
|
||||||
E.where_ $ course E.^. CourseId `E.in_` E.valList (Set.toList restrSet)
|
E.where_ $ course E.^. CourseId `E.in_` E.valList (Set.toList restrSet)
|
||||||
|
|||||||
@ -353,6 +353,12 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
|
|||||||
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
|
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
|
||||||
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
|
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
|
||||||
|
|
||||||
|
degreeField :: Field Handler StudyDegreeId
|
||||||
|
degreeField = selectField $ optionsPersistKey [] [Asc StudyDegreeName, Asc StudyDegreeShorthand, Asc StudyDegreeKey] id
|
||||||
|
|
||||||
|
degreeFieldEnt :: Field Handler (Entity StudyDegree)
|
||||||
|
degreeFieldEnt = selectField $ optionsPersist [] [Asc StudyDegreeName, Asc StudyDegreeShorthand, Asc StudyDegreeKey] id
|
||||||
|
|
||||||
|
|
||||||
-- | Select one of the user's primary active study features, or from a given list of StudyFeatures (regardless of user)
|
-- | Select one of the user's primary active study features, or from a given list of StudyFeatures (regardless of user)
|
||||||
studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)?
|
studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)?
|
||||||
|
|||||||
@ -274,6 +274,7 @@ sourceInvitations :: forall junction m backend.
|
|||||||
, MonadThrow m
|
, MonadThrow m
|
||||||
, PersistRecordBackend Invitation backend
|
, PersistRecordBackend Invitation backend
|
||||||
, HasPersistBackend backend
|
, HasPersistBackend backend
|
||||||
|
, PersistQueryRead backend
|
||||||
)
|
)
|
||||||
=> Key (InvitationFor junction)
|
=> Key (InvitationFor junction)
|
||||||
-> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) ()
|
-> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) ()
|
||||||
@ -293,6 +294,7 @@ sourceInvitationsF :: forall junction map m backend.
|
|||||||
, MonadThrow m
|
, MonadThrow m
|
||||||
, PersistRecordBackend Invitation backend
|
, PersistRecordBackend Invitation backend
|
||||||
, HasPersistBackend backend
|
, HasPersistBackend backend
|
||||||
|
, PersistQueryRead backend
|
||||||
)
|
)
|
||||||
=> Key (InvitationFor junction)
|
=> Key (InvitationFor junction)
|
||||||
-> ReaderT backend m map
|
-> ReaderT backend m map
|
||||||
|
|||||||
@ -58,9 +58,8 @@ sheetDeleteRoute drRecords = DeleteRoute
|
|||||||
, drGetInfo = \(sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
|
, drGetInfo = \(sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
|
||||||
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
|
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
|
||||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||||
let submissions = E.sub_select . E.from $ \submission -> do
|
let submissions = E.subSelectCount . E.from $ \submission ->
|
||||||
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||||
return E.countRows
|
|
||||||
E.orderBy [E.asc $ sheet E.^. SheetName]
|
E.orderBy [E.asc $ sheet E.^. SheetName]
|
||||||
return (submissions, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
|
return (submissions, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
|
||||||
, drUnjoin = \(sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet
|
, drUnjoin = \(sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet
|
||||||
|
|||||||
@ -1,5 +1,6 @@
|
|||||||
module Handler.Utils.StudyFeatures
|
module Handler.Utils.StudyFeatures
|
||||||
( parseStudyFeatures
|
( parseStudyFeatures
|
||||||
|
, parseSubTermsSemester
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Import.NoFoundation hiding (try, (<|>))
|
import Import.NoFoundation hiding (try, (<|>))
|
||||||
@ -7,9 +8,19 @@ import Import.NoFoundation hiding (try, (<|>))
|
|||||||
import Text.Parsec
|
import Text.Parsec
|
||||||
import Text.Parsec.Text
|
import Text.Parsec.Text
|
||||||
|
|
||||||
|
import Auth.LDAP (ldapUserSubTermsSemester, ldapUserStudyFeatures)
|
||||||
|
import qualified Ldap.Client as Ldap
|
||||||
|
|
||||||
|
|
||||||
parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures]
|
parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures]
|
||||||
parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) ""
|
parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key)
|
||||||
|
where
|
||||||
|
Ldap.Attr key = ldapUserStudyFeatures
|
||||||
|
|
||||||
|
parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int)
|
||||||
|
parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key)
|
||||||
|
where
|
||||||
|
Ldap.Attr key = ldapUserSubTermsSemester
|
||||||
|
|
||||||
|
|
||||||
pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]
|
pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]
|
||||||
@ -19,9 +30,9 @@ pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do
|
|||||||
|
|
||||||
let
|
let
|
||||||
pStudyFeature = do
|
pStudyFeature = do
|
||||||
_ <- pKey -- Meaning unknown at this time
|
_ <- pKey -- "Fächergruppe"
|
||||||
void $ char '!'
|
void $ char '!'
|
||||||
_ <- pKey -- Meaning unknown
|
_ <- pKey -- "Studienbereich"
|
||||||
void $ char '!'
|
void $ char '!'
|
||||||
studyFeaturesField <- StudyTermsKey' <$> pKey
|
studyFeaturesField <- StudyTermsKey' <$> pKey
|
||||||
void $ char '!'
|
void $ char '!'
|
||||||
@ -29,6 +40,7 @@ pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do
|
|||||||
void $ char '!'
|
void $ char '!'
|
||||||
studyFeaturesSemester <- decimal
|
studyFeaturesSemester <- decimal
|
||||||
let studyFeaturesValid = True
|
let studyFeaturesValid = True
|
||||||
|
studyFeaturesSubField = Nothing
|
||||||
return StudyFeatures{..}
|
return StudyFeatures{..}
|
||||||
|
|
||||||
pStudyFeature `sepBy1` char '#'
|
pStudyFeature `sepBy1` char '#'
|
||||||
@ -45,3 +57,12 @@ decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit'
|
|||||||
where
|
where
|
||||||
digit' = dVal <$> digit
|
digit' = dVal <$> digit
|
||||||
dVal c = fromEnum c - fromEnum '0'
|
dVal c = fromEnum c - fromEnum '0'
|
||||||
|
|
||||||
|
|
||||||
|
pLMUTermsSemester :: Parser (StudyTermsId, Int)
|
||||||
|
pLMUTermsSemester = do
|
||||||
|
subTermsKey <- StudyTermsKey' <$> pKey
|
||||||
|
void $ char '$'
|
||||||
|
semester <- decimal
|
||||||
|
|
||||||
|
return (subTermsKey, semester)
|
||||||
|
|||||||
@ -724,7 +724,7 @@ submissionDeleteRoute drRecords = DeleteRoute
|
|||||||
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
|
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
|
||||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||||
let lastEdit = E.sub_select . E.from $ \submissionEdit -> do
|
let lastEdit = E.subSelectMaybe . E.from $ \submissionEdit -> do
|
||||||
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
|
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
|
||||||
return . E.max_ $ submissionEdit E.^. SubmissionEditTime
|
return . E.max_ $ submissionEdit E.^. SubmissionEditTime
|
||||||
E.orderBy [E.desc lastEdit]
|
E.orderBy [E.desc lastEdit]
|
||||||
|
|||||||
@ -25,11 +25,11 @@ import qualified Data.Map as Map
|
|||||||
|
|
||||||
|
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
-- import Database.Esqueleto.Utils as E
|
import qualified Database.Esqueleto.Internal.Sql as E
|
||||||
|
|
||||||
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
|
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
|
||||||
|
|
||||||
type STKey = Int -- for convenience, assmued identical to field StudyTermCandidateKey
|
type STKey = Int -- for convenience, assmued identical to field StudyTermNameCandidateKey
|
||||||
|
|
||||||
data FailedCandidateInference = FailedCandidateInference [Entity StudyTerms]
|
data FailedCandidateInference = FailedCandidateInference [Entity StudyTerms]
|
||||||
deriving (Typeable, Show)
|
deriving (Typeable, Show)
|
||||||
@ -46,26 +46,44 @@ instance Exception FailedCandidateInference
|
|||||||
-- * list of problems, ie. StudyTerms that contradict observed incidences
|
-- * list of problems, ie. StudyTerms that contradict observed incidences
|
||||||
-- * list of redundants, i.e. redundant observed incidences
|
-- * list of redundants, i.e. redundant observed incidences
|
||||||
-- * list of accepted, i.e. newly accepted key/name pairs
|
-- * list of accepted, i.e. newly accepted key/name pairs
|
||||||
inferHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],[Entity StudyTermCandidate],[(STKey,Text)])
|
inferNamesHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],[Entity StudyTermNameCandidate],[(StudyTermsId,Text)])
|
||||||
inferHandler = runDB $ inferAcc ([],[],[])
|
inferNamesHandler = runDB $ inferAcc mempty
|
||||||
where
|
where
|
||||||
inferAcc (accAmbiguous, accRedundants, accAccepted) =
|
inferAcc (accAmbiguous, accRedundants, accAccepted) =
|
||||||
handle (\(FailedCandidateInference fails) -> (fails,accAmbiguous,accRedundants,accAccepted) <$ E.transactionUndo) $ do
|
handle (\(FailedCandidateInference fails) -> (fails, accAmbiguous, accRedundants, accAccepted') <$ E.transactionUndo) $ do
|
||||||
(infAmbis, infReds,infAccs) <- inferStep
|
(infAmbis, infReds, infAccs) <- inferStep
|
||||||
if null infAccs
|
if
|
||||||
then return ([], accAmbiguous, infReds ++ accRedundants, accAccepted)
|
| null infAccs ->
|
||||||
else do
|
return ([], accAmbiguous, infReds <> accRedundants, accAccepted')
|
||||||
|
| otherwise -> do
|
||||||
E.transactionSave -- commit transaction if there are no problems
|
E.transactionSave -- commit transaction if there are no problems
|
||||||
inferAcc (infAmbis ++ accAmbiguous, infReds ++ accRedundants, infAccs ++ accAccepted)
|
inferAcc (infAmbis <> accAmbiguous, infReds <> accRedundants, infAccs <> accAccepted)
|
||||||
|
where
|
||||||
|
accAccepted' = over (traversed . _1) StudyTermsKey' accAccepted
|
||||||
|
|
||||||
inferStep = do
|
inferStep = do
|
||||||
ambiguous <- removeAmbiguous
|
ambiguous <- removeAmbiguousNames
|
||||||
redundants <- removeRedundant
|
redundants <- removeRedundantNames
|
||||||
accepted <- acceptSingletons
|
accepted <- acceptSingletonNames
|
||||||
problems <- conflicts
|
problems <- nameConflicts
|
||||||
unless (null problems) $ throwM $ FailedCandidateInference problems
|
unless (null problems) $ throwM $ FailedCandidateInference problems
|
||||||
return (ambiguous, redundants, accepted)
|
return (ambiguous, redundants, accepted)
|
||||||
|
|
||||||
|
inferParentsHandler :: Handler ([Entity StudySubTermParentCandidate], [Entity StudySubTerms])
|
||||||
|
inferParentsHandler = runDB $ inferAcc mempty
|
||||||
|
where
|
||||||
|
inferAcc (infReds', infAccs') = do
|
||||||
|
(infReds, infAccs) <- inferStep
|
||||||
|
if
|
||||||
|
| null infAccs ->
|
||||||
|
return (infReds' <> infReds, infAccs')
|
||||||
|
| otherwise ->
|
||||||
|
inferAcc (infReds' <> infReds, infAccs' <> infAccs)
|
||||||
|
inferStep = do
|
||||||
|
redundants <- removeRedundantParents
|
||||||
|
accepted <- acceptSingletonParents
|
||||||
|
return (redundants, accepted)
|
||||||
|
|
||||||
{-
|
{-
|
||||||
Candidate 1 11 "A"
|
Candidate 1 11 "A"
|
||||||
Candidate 1 11 "B"
|
Candidate 1 11 "B"
|
||||||
@ -87,35 +105,65 @@ as a fix we simply eliminate all observations that have the same name twice, see
|
|||||||
-- | remove candidates with ambiguous observations,
|
-- | remove candidates with ambiguous observations,
|
||||||
-- ie. candidates that have duplicated term names with differing keys
|
-- ie. candidates that have duplicated term names with differing keys
|
||||||
-- which may happen in rare cases
|
-- which may happen in rare cases
|
||||||
removeAmbiguous :: DB [TermCandidateIncidence]
|
removeAmbiguousNames :: DB [TermCandidateIncidence]
|
||||||
removeAmbiguous = do
|
removeAmbiguousNames = do
|
||||||
ambiList <- E.select $ E.from $ \candidate -> do
|
ambiList <- E.select $ E.from $ \candidate -> do
|
||||||
E.groupBy ( candidate E.^. StudyTermCandidateIncidence
|
E.groupBy ( candidate E.^. StudyTermNameCandidateIncidence
|
||||||
, candidate E.^. StudyTermCandidateKey
|
, candidate E.^. StudyTermNameCandidateKey
|
||||||
, candidate E.^. StudyTermCandidateName
|
, candidate E.^. StudyTermNameCandidateName
|
||||||
)
|
)
|
||||||
E.having $ E.countRows E.!=. E.val (1 :: Int64)
|
E.having $ E.countRows E.!=. E.val (1 :: Int64)
|
||||||
return $ candidate E.^. StudyTermCandidateIncidence
|
return $ candidate E.^. StudyTermNameCandidateIncidence
|
||||||
let ambiSet = E.unValue <$> List.nub ambiList
|
let ambiSet = E.unValue <$> List.nub ambiList
|
||||||
-- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
|
-- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
|
||||||
deleteWhere [StudyTermCandidateIncidence <-. ambiSet]
|
deleteWhere [StudyTermNameCandidateIncidence <-. ambiSet]
|
||||||
return ambiSet
|
return ambiSet
|
||||||
|
|
||||||
|
|
||||||
-- | remove known StudyTerm from candidates that have the _exact_ name,
|
-- | remove known StudyTerm from candidates that have the _exact_ name,
|
||||||
-- ie. if a candidate contains a known key, we remove it and its associated fullname
|
-- ie. if a candidate contains a known key, we remove it and its associated fullname
|
||||||
-- only save if ambiguous candidates haven been removed
|
-- only save if ambiguous candidates haven been removed
|
||||||
removeRedundant :: DB [Entity StudyTermCandidate]
|
removeRedundantNames :: DB [Entity StudyTermNameCandidate]
|
||||||
removeRedundant = do
|
removeRedundantNames = do
|
||||||
redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do
|
redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do
|
||||||
E.on $ candidate E.^. StudyTermCandidateKey E.==. sterm E.^. StudyTermsKey
|
E.on $ candidate E.^. StudyTermNameCandidateKey E.==. sterm E.^. StudyTermsKey
|
||||||
E.&&. E.just (candidate E.^. StudyTermCandidateName) E.==. sterm E.^. StudyTermsName
|
E.&&. ( E.just (candidate E.^. StudyTermNameCandidateName) E.==. sterm E.^. StudyTermsName
|
||||||
|
E.||. E.exists (E.from $ \(subTerm `E.InnerJoin` sterm2) -> do
|
||||||
|
E.on $ subTerm E.^. StudySubTermsParent E.==. sterm E.^. StudyTermsId
|
||||||
|
E.&&. subTerm E.^. StudySubTermsChild E.==. sterm2 E.^. StudyTermsId
|
||||||
|
E.where_ $ E.just (candidate E.^. StudyTermNameCandidateName) E.==. sterm2 E.^. StudyTermsName
|
||||||
|
)
|
||||||
|
)
|
||||||
return candidate
|
return candidate
|
||||||
-- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
|
-- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
|
||||||
forM_ redundants $ \Entity{entityVal=StudyTermCandidate{..}} ->
|
forM_ redundants $ \Entity{entityVal=StudyTermNameCandidate{..}} ->
|
||||||
deleteWhere $ ( StudyTermCandidateIncidence ==. studyTermCandidateIncidence )
|
deleteWhere $ ( StudyTermNameCandidateIncidence ==. studyTermNameCandidateIncidence )
|
||||||
: ([ StudyTermCandidateKey ==. studyTermCandidateKey ]
|
: ([ StudyTermNameCandidateKey ==. studyTermNameCandidateKey ]
|
||||||
||. [ StudyTermCandidateName ==. studyTermCandidateName ])
|
||. [ StudyTermNameCandidateName ==. studyTermNameCandidateName ])
|
||||||
|
return redundants
|
||||||
|
|
||||||
|
removeRedundantParents :: DB [Entity StudySubTermParentCandidate]
|
||||||
|
removeRedundantParents = do
|
||||||
|
redundants <- E.select . E.distinct . E.from $ \(candidate `E.InnerJoin` subTerm) -> do
|
||||||
|
E.on $ candidate E.^. StudySubTermParentCandidateKey E.==. E.veryUnsafeCoerceSqlExprValue (subTerm E.^. StudySubTermsChild)
|
||||||
|
E.&&. candidate E.^. StudySubTermParentCandidateParent E.==. E.veryUnsafeCoerceSqlExprValue (subTerm E.^. StudySubTermsParent)
|
||||||
|
return candidate
|
||||||
|
forM_ redundants $ \(Entity _ StudySubTermParentCandidate{..}) ->
|
||||||
|
E.delete . E.from $ \candidate ->
|
||||||
|
E.where_ $ candidate E.^. StudySubTermParentCandidateIncidence E.==. E.val studySubTermParentCandidateIncidence
|
||||||
|
E.&&. ( candidate E.^. StudySubTermParentCandidateParent `E.in_` E.valList [studySubTermParentCandidateParent, studySubTermParentCandidateKey]
|
||||||
|
E.||. candidate E.^. StudySubTermParentCandidateKey `E.in_` E.valList [studySubTermParentCandidateParent, studySubTermParentCandidateKey]
|
||||||
|
)
|
||||||
|
return redundants
|
||||||
|
|
||||||
|
removeRedundantStandalone :: DB [Entity StudyTermStandaloneCandidate]
|
||||||
|
removeRedundantStandalone = do
|
||||||
|
redundants <- E.select . E.distinct . E.from $ \(candidate `E.InnerJoin` sterm) -> do
|
||||||
|
E.on $ candidate E.^. StudyTermStandaloneCandidateKey E.==. sterm E.^. StudyTermsKey
|
||||||
|
E.&&. E.not_ (E.isNothing $ sterm E.^. StudyTermsDefaultDegree)
|
||||||
|
E.&&. E.not_ (E.isNothing $ sterm E.^. StudyTermsDefaultType)
|
||||||
|
return candidate
|
||||||
|
deleteWhere [ StudyTermStandaloneCandidateId <-. map entityKey redundants ]
|
||||||
return redundants
|
return redundants
|
||||||
|
|
||||||
|
|
||||||
@ -124,12 +172,12 @@ removeRedundant = do
|
|||||||
-- Does not delete the used candidates, user @removeRedundant@ for this later on.
|
-- Does not delete the used candidates, user @removeRedundant@ for this later on.
|
||||||
-- Esqueleto does not provide the INTERESECT operator, thus
|
-- Esqueleto does not provide the INTERESECT operator, thus
|
||||||
-- we load the table into Haskell and operate there. Memory usage problem? StudyTermsCandidate may become huge.
|
-- we load the table into Haskell and operate there. Memory usage problem? StudyTermsCandidate may become huge.
|
||||||
acceptSingletons :: DB [(STKey,Text)]
|
acceptSingletonNames :: DB [(STKey,Text)]
|
||||||
acceptSingletons = do
|
acceptSingletonNames = do
|
||||||
knownKeys <- fmap unStudyTermsKey <$> selectKeysList [StudyTermsName !=. Nothing] [Asc StudyTermsKey]
|
knownKeys <- fmap unStudyTermsKey <$> selectKeysList [StudyTermsName !=. Nothing] [Asc StudyTermsKey]
|
||||||
-- let knownKeysSet = Set.fromAscList knownKeys
|
-- let knownKeysSet = Set.fromAscList knownKeys
|
||||||
-- In case of memory problems, change next lines to conduit proper:
|
-- In case of memory problems, change next lines to conduit proper:
|
||||||
incidences <- fmap entityVal <$> selectList [StudyTermCandidateKey /<-. knownKeys] [] -- LimitTo might be dangerous here, if we get a partial incidence. Possibly first select N incidences, then retrieving all those only.
|
incidences <- fmap entityVal <$> selectList [StudyTermNameCandidateKey /<-. knownKeys] [] -- LimitTo might be dangerous here, if we get a partial incidence. Possibly first select N incidences, then retrieving all those only.
|
||||||
-- incidences <- E.select $ E.from $ \candidate -> do
|
-- incidences <- E.select $ E.from $ \candidate -> do
|
||||||
-- E.where_ $ candidate E.^. StudyTermCandidayeKey `E.notIn` E.valList knownKeys
|
-- E.where_ $ candidate E.^. StudyTermCandidayeKey `E.notIn` E.valList knownKeys
|
||||||
-- return candidate
|
-- return candidate
|
||||||
@ -139,11 +187,11 @@ acceptSingletons = do
|
|||||||
groupedCandidates = foldl' groupFun mempty incidences
|
groupedCandidates = foldl' groupFun mempty incidences
|
||||||
|
|
||||||
-- given a key, map each incidence to set of possible names for this key
|
-- given a key, map each incidence to set of possible names for this key
|
||||||
groupFun :: Map STKey (Map TermCandidateIncidence (Set Text)) -> StudyTermCandidate -> Map STKey (Map TermCandidateIncidence (Set Text))
|
groupFun :: Map STKey (Map TermCandidateIncidence (Set Text)) -> StudyTermNameCandidate -> Map STKey (Map TermCandidateIncidence (Set Text))
|
||||||
groupFun m StudyTermCandidate{..} =
|
groupFun m StudyTermNameCandidate{..} =
|
||||||
insertWith (Map.unionWith Set.union)
|
insertWith (Map.unionWith Set.union)
|
||||||
studyTermCandidateKey
|
studyTermNameCandidateKey
|
||||||
(Map.singleton studyTermCandidateIncidence $ Set.singleton studyTermCandidateName)
|
(Map.singleton studyTermNameCandidateIncidence $ Set.singleton studyTermNameCandidateName)
|
||||||
m
|
m
|
||||||
|
|
||||||
-- pointwise intersection per incidence gives possible candidates per key
|
-- pointwise intersection per incidence gives possible candidates per key
|
||||||
@ -152,36 +200,99 @@ acceptSingletons = do
|
|||||||
|
|
||||||
-- filter candidates having a unique possibility left
|
-- filter candidates having a unique possibility left
|
||||||
fixedKeys :: [(STKey,Text)]
|
fixedKeys :: [(STKey,Text)]
|
||||||
fixedKeys = Map.foldlWithKey' combFixed [] keyCandidates
|
fixedKeys = fst $ Map.foldlWithKey' combFixed mempty keyCandidates
|
||||||
|
where
|
||||||
combFixed :: [(STKey,Text)] -> STKey -> Set Text -> [(STKey,Text)]
|
combFixed :: ([(STKey,Text)], Set STKey) -> STKey -> Set Text -> ([(STKey,Text)], Set STKey)
|
||||||
combFixed acc k s | Set.size s == 1 -- possibly redundant
|
combFixed (acc, bad) k s
|
||||||
, [n] <- Set.elems s = (k,n):acc
|
| Set.member k bad
|
||||||
-- empty sets should not occur here , if LDAP is consistent. Maybe raise a warning?!
|
= (acc, bad)
|
||||||
| otherwise = acc
|
| maybe False (`Set.notMember` s) (lookup k acc)
|
||||||
|
= (filter (\(k', _) -> k /= k') acc, Set.insert k bad)
|
||||||
|
| [n] <- Set.elems s
|
||||||
|
= ((k,n) : acc, bad)
|
||||||
|
| otherwise = (acc, bad)
|
||||||
|
|
||||||
-- registerFixed :: (STKey, Text) -> DB (Key StudyTerms)
|
-- registerFixed :: (STKey, Text) -> DB (Key StudyTerms)
|
||||||
registerFixed :: (STKey, Text) -> DB ()
|
registerFixed :: (STKey, Text) -> DB ()
|
||||||
registerFixed (key, name) = repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name)
|
registerFixed (key, name) =
|
||||||
|
repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name) Nothing Nothing
|
||||||
|
|
||||||
-- register newly fixed candidates
|
-- register newly fixed candidates
|
||||||
forM_ fixedKeys registerFixed
|
forM_ fixedKeys registerFixed
|
||||||
return fixedKeys
|
return fixedKeys
|
||||||
|
|
||||||
|
acceptSingletonParents :: DB [Entity StudySubTerms]
|
||||||
|
acceptSingletonParents = do
|
||||||
|
candidates <- map entityVal <$> selectList [] []
|
||||||
|
|
||||||
|
let
|
||||||
|
groupedCandidates :: Map STKey (Map UUID (Set STKey))
|
||||||
|
groupedCandidates = foldl' groupFun mempty candidates
|
||||||
|
where
|
||||||
|
groupFun :: Map STKey (Map UUID (Set STKey)) -> StudySubTermParentCandidate -> Map STKey (Map UUID (Set STKey))
|
||||||
|
groupFun m StudySubTermParentCandidate{..} =
|
||||||
|
Map.insertWith (Map.unionWith Set.union)
|
||||||
|
studySubTermParentCandidateKey
|
||||||
|
(Map.singleton studySubTermParentCandidateIncidence $ Set.singleton studySubTermParentCandidateParent)
|
||||||
|
m
|
||||||
|
|
||||||
|
parentCandidates :: Map STKey (Set STKey)
|
||||||
|
parentCandidates = Map.map (setIntersections . Map.elems) groupedCandidates
|
||||||
|
|
||||||
|
fixedParents :: [(STKey, STKey)]
|
||||||
|
fixedParents = fst $ Map.foldlWithKey' combFixed mempty parentCandidates
|
||||||
|
where
|
||||||
|
combFixed :: ([(STKey, STKey)], Set STKey) -> STKey -> Set STKey -> ([(STKey, STKey)], Set STKey)
|
||||||
|
combFixed (acc, bad) k s
|
||||||
|
| Set.member k bad
|
||||||
|
= (acc, bad)
|
||||||
|
| maybe False (`Set.notMember` s) (lookup k acc)
|
||||||
|
= (filter (\(k', _) -> k /= k') acc, Set.insert k bad)
|
||||||
|
| [p] <- Set.elems s
|
||||||
|
= ((k, p) : acc, bad)
|
||||||
|
| otherwise = (acc, bad)
|
||||||
|
|
||||||
|
inserted <- forM fixedParents $ \(key, parent) -> do
|
||||||
|
unlessM (existsKey $ StudyTermsKey' key) $
|
||||||
|
insert_ (StudyTerms key Nothing Nothing Nothing Nothing)
|
||||||
|
unlessM (existsKey $ StudyTermsKey' parent) $
|
||||||
|
insert_ (StudyTerms parent Nothing Nothing Nothing Nothing)
|
||||||
|
insertUnique $ StudySubTerms
|
||||||
|
{ studySubTermsChild = StudyTermsKey' key
|
||||||
|
, studySubTermsParent = StudyTermsKey' parent
|
||||||
|
}
|
||||||
|
|
||||||
|
mapM getJustEntity $ catMaybes inserted
|
||||||
|
|
||||||
|
|
||||||
-- | all existing StudyTerms that are contradiced by current observations
|
-- | all existing StudyTerms that are contradiced by current observations
|
||||||
conflicts :: DB [Entity StudyTerms]
|
nameConflicts :: DB [Entity StudyTerms]
|
||||||
conflicts = E.select $ E.from $ \studyTerms -> do
|
nameConflicts = E.select $ E.from $ \studyTerms -> do
|
||||||
E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName
|
E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName
|
||||||
E.where_ $ E.exists $ E.from $ \candidateOne -> do
|
E.where_ $ E.exists $ E.from $ \candidateOne -> do
|
||||||
E.where_ $ candidateOne E.^. StudyTermCandidateKey E.==. studyTerms E.^. StudyTermsKey
|
E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studyTerms E.^. StudyTermsKey
|
||||||
E.where_ $ E.notExists . E.from $ \candidateTwo -> do
|
E.where_ $ E.notExists . E.from $ \candidateTwo -> do
|
||||||
E.where_ $ candidateTwo E.^. StudyTermCandidateIncidence E.==. candidateOne E.^. StudyTermCandidateIncidence
|
E.where_ $ candidateTwo E.^. StudyTermNameCandidateIncidence E.==. candidateOne E.^. StudyTermNameCandidateIncidence
|
||||||
E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermCandidateName)
|
E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
|
||||||
|
E.||. E.exists ( E.from $ \(pCandidate `E.LeftOuterJoin` termsTwo) -> do
|
||||||
|
E.on $ pCandidate E.^. StudySubTermParentCandidateParent E.==. studyTerms E.^. StudyTermsKey
|
||||||
|
E.&&. E.just (pCandidate E.^. StudySubTermParentCandidateKey) E.==. termsTwo E.?. StudyTermsKey
|
||||||
|
E.where_ $ E.joinV (termsTwo E.?. StudyTermsName) E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
|
||||||
|
E.||. E.isNothing (E.joinV $ termsTwo E.?. StudyTermsName)
|
||||||
|
)
|
||||||
|
E.||. E.exists ( E.from $ \(subTerms `E.InnerJoin` termsTwo) -> do
|
||||||
|
E.on $ subTerms E.^. StudySubTermsParent E.==. studyTerms E.^. StudyTermsId
|
||||||
|
E.&&. subTerms E.^. StudySubTermsChild E.==. termsTwo E.^. StudyTermsId
|
||||||
|
E.where_ $ termsTwo E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
|
||||||
|
E.||. E.isNothing (termsTwo E.^. StudyTermsName)
|
||||||
|
)
|
||||||
return studyTerms
|
return studyTerms
|
||||||
|
|
||||||
|
|
||||||
-- | retrieve all incidence keys having containing a certain @StudyTermKey @
|
-- | retrieve all incidence keys having containing a certain @StudyTermKey @
|
||||||
getIncidencesFor :: [Key StudyTerms] -> DB [E.Value TermCandidateIncidence]
|
getNameIncidencesFor :: [StudyTermsId] -> DB [E.Value TermCandidateIncidence]
|
||||||
getIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do
|
getNameIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do
|
||||||
E.where_ $ candidate E.^. StudyTermCandidateKey `E.in_` E.valList (unStudyTermsKey <$> stks)
|
E.where_ $ candidate E.^. StudyTermNameCandidateKey `E.in_` E.valList stks'
|
||||||
return $ candidate E.^. StudyTermCandidateIncidence
|
return $ candidate E.^. StudyTermNameCandidateIncidence
|
||||||
|
where
|
||||||
|
stks' = stks <&> unStudyTermsKey
|
||||||
|
|||||||
@ -86,11 +86,10 @@ dispatchNotificationAllocationUnratedApplications nAllocation jRecipient = do
|
|||||||
|
|
||||||
let
|
let
|
||||||
unratedAppCount :: E.SqlExpr (E.Value Natural)
|
unratedAppCount :: E.SqlExpr (E.Value Natural)
|
||||||
unratedAppCount = E.sub_select . E.from $ \application -> do
|
unratedAppCount = E.subSelectCount . E.from $ \application ->
|
||||||
E.where_ $ application E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
E.where_ $ application E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
||||||
E.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation)
|
E.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation)
|
||||||
E.&&. E.isNothing (application E.^. CourseApplicationRatingTime)
|
E.&&. E.isNothing (application E.^. CourseApplicationRatingTime)
|
||||||
return E.countRows
|
|
||||||
|
|
||||||
return ( course E.^. CourseTerm
|
return ( course E.^. CourseTerm
|
||||||
, course E.^. CourseSchool
|
, course E.^. CourseSchool
|
||||||
@ -128,11 +127,10 @@ dispatchNotificationAllocationOutdatedRatings nAllocation jRecipient = do
|
|||||||
|
|
||||||
let
|
let
|
||||||
outdatedRatingsAppCount :: E.SqlExpr (E.Value Natural)
|
outdatedRatingsAppCount :: E.SqlExpr (E.Value Natural)
|
||||||
outdatedRatingsAppCount = E.sub_select . E.from $ \application -> do
|
outdatedRatingsAppCount = E.subSelectCount . E.from $ \application ->
|
||||||
E.where_ $ application E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
E.where_ $ application E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
||||||
E.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation)
|
E.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation)
|
||||||
E.&&. E.maybe E.false (E.<. application E.^. CourseApplicationTime) (application E.^. CourseApplicationRatingTime)
|
E.&&. E.maybe E.false (E.<. application E.^. CourseApplicationTime) (application E.^. CourseApplicationRatingTime)
|
||||||
return E.countRows
|
|
||||||
|
|
||||||
return ( course E.^. CourseTerm
|
return ( course E.^. CourseTerm
|
||||||
, course E.^. CourseSchool
|
, course E.^. CourseSchool
|
||||||
@ -170,13 +168,13 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi
|
|||||||
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
|
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
|
||||||
)
|
)
|
||||||
let allocatedCount = E.sub_select . E.from $ \participant -> do
|
let allocatedCount :: E.SqlExpr (E.Value Int64)
|
||||||
|
allocatedCount = E.subSelectCount . E.from $ \participant ->
|
||||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
|
E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
|
||||||
E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
|
E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
|
||||||
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64))
|
let participantCount :: E.SqlExpr (E.Value Int64)
|
||||||
let participantCount = E.sub_select . E.from $ \participant -> do
|
participantCount = E.subSelectCount . E.from $ \participant ->
|
||||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
|
E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
|
||||||
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64))
|
|
||||||
return (course, allocatedCount, participantCount)
|
return (course, allocatedCount, participantCount)
|
||||||
let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, E.Value allocCount, E.Value partCount) -> SomeMessage $ if
|
let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, E.Value allocCount, E.Value partCount) -> SomeMessage $ if
|
||||||
| allocCount == partCount -> MsgAllocationResultLecturerAll courseShorthand allocCount
|
| allocCount == partCount -> MsgAllocationResultLecturerAll courseShorthand allocCount
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
|
||||||
|
|
||||||
module Model
|
module Model
|
||||||
( module Model
|
( module Model
|
||||||
|
|||||||
@ -1,3 +1,5 @@
|
|||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
module Model.Migration
|
module Model.Migration
|
||||||
( migrateAll
|
( migrateAll
|
||||||
, requiresMigration
|
, requiresMigration
|
||||||
@ -585,6 +587,10 @@ customMigrations = Map.fromListWith (>>)
|
|||||||
ALTER TABLE "user" DROP COLUMN "mail_languages";
|
ALTER TABLE "user" DROP COLUMN "mail_languages";
|
||||||
|]
|
|]
|
||||||
)
|
)
|
||||||
|
, ( AppliedMigrationKey [migrationVersion|27.0.0|] [version|28.0.0|]
|
||||||
|
, whenM (tableExists "exam_part_corrector") $
|
||||||
|
tableDropEmpty "exam_part_corrector"
|
||||||
|
)
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -30,6 +30,7 @@ type StudyDegreeKey = Int
|
|||||||
type StudyTermsName = Text
|
type StudyTermsName = Text
|
||||||
type StudyTermsShorthand = Text
|
type StudyTermsShorthand = Text
|
||||||
type StudyTermsKey = Int
|
type StudyTermsKey = Int
|
||||||
|
type StudySubTermsKey = Int
|
||||||
|
|
||||||
type SchoolName = CI Text
|
type SchoolName = CI Text
|
||||||
type SchoolShorthand = CI Text
|
type SchoolShorthand = CI Text
|
||||||
|
|||||||
@ -34,6 +34,7 @@ data StudyFieldType = FieldPrimary | FieldSecondary
|
|||||||
derivePersistField "StudyFieldType"
|
derivePersistField "StudyFieldType"
|
||||||
instance Universe StudyFieldType
|
instance Universe StudyFieldType
|
||||||
instance Finite StudyFieldType
|
instance Finite StudyFieldType
|
||||||
|
nullaryPathPiece ''StudyFieldType $ camelToPathPiece' 1
|
||||||
|
|
||||||
|
|
||||||
data Theme
|
data Theme
|
||||||
|
|||||||
@ -237,10 +237,6 @@ stepTextCounter text
|
|||||||
-- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo Ue3bung00322 34 (H)"
|
-- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo Ue3bung00322 34 (H)"
|
||||||
-- ["12",".ProMo Ue","3","bung","00322"," ","34"," (H)"]
|
-- ["12",".ProMo Ue","3","bung","00322"," ","34"," (H)"]
|
||||||
|
|
||||||
-- | Ignore warnings for unused variables with a more specific type
|
|
||||||
notUsedT :: a -> Text
|
|
||||||
notUsedT = notUsed
|
|
||||||
|
|
||||||
fromText :: (IsString a, Textual t) => t -> a
|
fromText :: (IsString a, Textual t) => t -> a
|
||||||
fromText = fromString . unpack
|
fromText = fromString . unpack
|
||||||
|
|
||||||
@ -732,7 +728,7 @@ choice = foldr (<|>) empty
|
|||||||
--------------
|
--------------
|
||||||
|
|
||||||
data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
|
data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
|
||||||
| SessionNewStudyTerms
|
| SessionNewStudyTerms | SessionConflictingStudyTerms
|
||||||
| SessionBearer
|
| SessionBearer
|
||||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||||
instance Universe SessionKey
|
instance Universe SessionKey
|
||||||
|
|||||||
@ -49,6 +49,12 @@ _nullable = prism' toNullable fromNullable
|
|||||||
_SchoolId :: Iso' SchoolId SchoolShorthand
|
_SchoolId :: Iso' SchoolId SchoolShorthand
|
||||||
_SchoolId = iso unSchoolKey SchoolKey
|
_SchoolId = iso unSchoolKey SchoolKey
|
||||||
|
|
||||||
|
_StudyTermsId :: Iso' StudyTermsId StudyTermsKey
|
||||||
|
_StudyTermsId = iso unStudyTermsKey StudyTermsKey'
|
||||||
|
|
||||||
|
_StudyDegreeId :: Iso' StudyDegreeId StudyDegreeKey
|
||||||
|
_StudyDegreeId = iso unStudyDegreeKey StudyDegreeKey'
|
||||||
|
|
||||||
_Maybe :: Iso' (Maybe ()) Bool
|
_Maybe :: Iso' (Maybe ()) Bool
|
||||||
_Maybe = iso (is _Just) (bool Nothing (Just ()))
|
_Maybe = iso (is _Just) (bool Nothing (Just ()))
|
||||||
|
|
||||||
@ -83,6 +89,7 @@ makeClassyFor_ ''StudyFeatures
|
|||||||
makeClassyFor_ ''StudyDegree
|
makeClassyFor_ ''StudyDegree
|
||||||
|
|
||||||
makeClassyFor_ ''StudyTerms
|
makeClassyFor_ ''StudyTerms
|
||||||
|
makeClassyFor_ ''StudySubTerms
|
||||||
|
|
||||||
|
|
||||||
_entityKey :: Getter (Entity record) (Key record)
|
_entityKey :: Getter (Entity record) (Key record)
|
||||||
@ -126,7 +133,6 @@ hasEntityUser = hasEntity
|
|||||||
-- instance (HasUser a) => HasUser (Entity a) where
|
-- instance (HasUser a) => HasUser (Entity a) where
|
||||||
-- hasUser = _entityVal . hasUser
|
-- hasUser = _entityVal . hasUser
|
||||||
|
|
||||||
|
|
||||||
makeLenses_ ''SheetCorrector
|
makeLenses_ ''SheetCorrector
|
||||||
|
|
||||||
makeLenses_ ''Load
|
makeLenses_ ''Load
|
||||||
@ -143,7 +149,9 @@ makePrisms ''AuthResult
|
|||||||
|
|
||||||
makePrisms ''FormResult
|
makePrisms ''FormResult
|
||||||
|
|
||||||
makeLenses_ ''StudyTermCandidate
|
makeLenses_ ''StudyTermNameCandidate
|
||||||
|
makeLenses_ ''StudySubTermParentCandidate
|
||||||
|
makeLenses_ ''StudyTermStandaloneCandidate
|
||||||
|
|
||||||
makeLenses_ ''FieldView
|
makeLenses_ ''FieldView
|
||||||
makeLenses_ ''FieldSettings
|
makeLenses_ ''FieldSettings
|
||||||
|
|||||||
@ -39,7 +39,11 @@ extra-deps:
|
|||||||
- directory-1.3.4.0
|
- directory-1.3.4.0
|
||||||
|
|
||||||
- HaXml-1.25.5
|
- HaXml-1.25.5
|
||||||
- esqueleto-3.0.0
|
|
||||||
|
- persistent-2.10.4
|
||||||
|
- persistent-postgresql-2.10.1
|
||||||
|
- persistent-template-2.7.3
|
||||||
|
- esqueleto-3.2.3
|
||||||
|
|
||||||
- HaskellNet-SSL-0.3.4.1
|
- HaskellNet-SSL-0.3.4.1
|
||||||
- sandi-0.5
|
- sandi-0.5
|
||||||
|
|||||||
3
templates/adminFeatures.cassius
Normal file
3
templates/adminFeatures.cassius
Normal file
@ -0,0 +1,3 @@
|
|||||||
|
#admin-studyterms
|
||||||
|
select, option, input
|
||||||
|
min-width: 50px
|
||||||
@ -1,19 +1,40 @@
|
|||||||
$newline never
|
$newline never
|
||||||
<section>
|
<section>
|
||||||
|
<h2>
|
||||||
|
_{MsgStudyFeaturesDegrees}
|
||||||
^{degreeTable}
|
^{degreeTable}
|
||||||
<section>
|
<section>
|
||||||
|
<h2>
|
||||||
|
_{MsgStudyFeaturesTerms}
|
||||||
^{studytermsTable}
|
^{studytermsTable}
|
||||||
<section>
|
<section>
|
||||||
<h2>_{MsgStudyFeatureInference}
|
<h2>
|
||||||
$if null infConflicts
|
_{MsgStudyFeatureNameInference}
|
||||||
<p>
|
<p>
|
||||||
_{MsgStudyFeatureInferenceNoConflicts}
|
$if null infNameConflicts
|
||||||
$else
|
_{MsgStudyFeatureInferenceNoNameConflicts}
|
||||||
<h3>_{MsgStudyFeatureInferenceConflictsHeading}
|
$else
|
||||||
<ul>
|
<h3>_{MsgStudyFeatureInferenceNameConflictsHeading}
|
||||||
$forall (Entity _ (StudyTerms ky _ nm)) <- infConflicts
|
<ul>
|
||||||
<li> #{show ky} - #{foldMap id nm}
|
$forall Entity _ (StudyTerms ky _ nm _ _) <- infNameConflicts
|
||||||
^{btnForm}
|
<li>
|
||||||
|
#{show ky} - #{foldMap id nm}
|
||||||
|
^{nameBtnForm}
|
||||||
|
|
||||||
|
<h2>
|
||||||
|
_{MsgStudyFeaturesNameCandidates}
|
||||||
|
^{candidateTable}
|
||||||
|
<section>
|
||||||
|
<h2>
|
||||||
|
_{MsgStudyFeatureParentInference}
|
||||||
|
^{parentsBtnForm}
|
||||||
|
|
||||||
<div .container>
|
<h2>
|
||||||
^{candidateTable}
|
_{MsgStudyFeaturesParentCandidates}
|
||||||
|
^{parentCandidateTable}
|
||||||
|
<section>
|
||||||
|
<h2>
|
||||||
|
_{MsgStudyFeaturesStandaloneCandidates}
|
||||||
|
^{standaloneBtnForm}
|
||||||
|
|
||||||
|
^{standaloneCandidateTable}
|
||||||
|
|||||||
@ -37,11 +37,10 @@ $newline never
|
|||||||
<th .table__th>_{MsgStudyFeatureAge}
|
<th .table__th>_{MsgStudyFeatureAge}
|
||||||
<th .table__th>_{MsgStudyFeatureValid}
|
<th .table__th>_{MsgStudyFeatureValid}
|
||||||
<th .table__th>_{MsgStudyFeatureUpdate}
|
<th .table__th>_{MsgStudyFeatureUpdate}
|
||||||
$forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
|
$forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesUpdated}), (Entity _ degree), (Entity _ field)) <- studies
|
||||||
$with _ <- notUsedT studyFeaturesUser
|
|
||||||
<tr .table__row>
|
<tr .table__row>
|
||||||
<td .table__td>_{field}#{notUsedT studyFeaturesField}
|
<td .table__td>_{field}
|
||||||
<td .table__td>_{degree}#{notUsedT studyFeaturesDegree}
|
<td .table__td>_{degree}
|
||||||
<td .table__td>_{studyFeaturesType}
|
<td .table__td>_{studyFeaturesType}
|
||||||
<td .table__td>#{studyFeaturesSemester}
|
<td .table__td>#{studyFeaturesSemester}
|
||||||
<td .table__td>#{hasTickmark studyFeaturesValid}
|
<td .table__td>#{hasTickmark studyFeaturesValid}
|
||||||
|
|||||||
@ -43,11 +43,10 @@ $newline never
|
|||||||
<th .table__th>_{MsgStudyFeatureValid}
|
<th .table__th>_{MsgStudyFeatureValid}
|
||||||
<th .table__th>_{MsgStudyFeatureUpdate}
|
<th .table__th>_{MsgStudyFeatureUpdate}
|
||||||
|
|
||||||
$forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
|
$forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesUpdated}), (Entity _ degree), (Entity _ field)) <- studies
|
||||||
$with _ <- notUsedT studyFeaturesUser
|
|
||||||
<tr.table__row>
|
<tr.table__row>
|
||||||
<td .table__td>_{field}#{notUsedT studyFeaturesField}
|
<td .table__td>_{field}
|
||||||
<td .table__td>_{degree}#{notUsedT studyFeaturesDegree}
|
<td .table__td>_{degree}
|
||||||
<td .table__td>_{studyFeaturesType}
|
<td .table__td>_{studyFeaturesType}
|
||||||
<td .table__td>#{studyFeaturesSemester}
|
<td .table__td>#{studyFeaturesSemester}
|
||||||
<td .table__td>#{hasTickmark studyFeaturesValid}
|
<td .table__td>#{hasTickmark studyFeaturesValid}
|
||||||
|
|||||||
134
test/Database.hs
134
test/Database.hs
@ -317,87 +317,88 @@ fillDb = do
|
|||||||
sdChem2 = StudyTermsKey' 113
|
sdChem2 = StudyTermsKey' 113
|
||||||
sdBWL = StudyTermsKey' 21
|
sdBWL = StudyTermsKey' 21
|
||||||
sdDeut = StudyTermsKey' 103
|
sdDeut = StudyTermsKey' 103
|
||||||
repsert sdInf $ StudyTerms 79 (Just "Inf") (Just "Informatikk")
|
repsert sdInf $ StudyTerms 79 (Just "Inf") (Just "Informatikk") Nothing Nothing
|
||||||
repsert sdMath $ StudyTerms 105 (Just "Math" ) (Just "Mathematik")
|
repsert sdMath $ StudyTerms 105 (Just "Math" ) (Just "Mathematik") Nothing Nothing
|
||||||
repsert sdMedi $ StudyTerms 121 Nothing (Just "Fehler hier")
|
repsert sdMedi $ StudyTerms 121 Nothing (Just "Fehler hier") Nothing Nothing
|
||||||
repsert sdPhys $ StudyTerms 128 Nothing Nothing -- intentionally left unknown
|
repsert sdPhys $ StudyTerms 128 Nothing Nothing Nothing Nothing -- intentionally left unknown
|
||||||
repsert sdBioI1 $ StudyTerms 221 Nothing Nothing -- intentionally left unknown
|
repsert sdBioI1 $ StudyTerms 221 Nothing Nothing Nothing Nothing -- intentionally left unknown
|
||||||
repsert sdBioI2 $ StudyTerms 228 Nothing Nothing -- intentionally left unknown
|
repsert sdBioI2 $ StudyTerms 228 Nothing Nothing Nothing Nothing -- intentionally left unknown
|
||||||
repsert sdBiol $ StudyTerms 26 Nothing Nothing -- intentionally left unknown
|
repsert sdBiol $ StudyTerms 26 Nothing Nothing Nothing Nothing -- intentionally left unknown
|
||||||
repsert sdChem1 $ StudyTerms 61 Nothing Nothing -- intentionally left unknown
|
repsert sdChem1 $ StudyTerms 61 Nothing Nothing Nothing Nothing -- intentionally left unknown
|
||||||
repsert sdChem2 $ StudyTerms 113 Nothing Nothing -- intentionally left unknown
|
repsert sdChem2 $ StudyTerms 113 Nothing Nothing Nothing Nothing -- intentionally left unknown
|
||||||
repsert sdBWL $ StudyTerms 21 Nothing Nothing -- intentionally left unknown
|
repsert sdBWL $ StudyTerms 21 Nothing Nothing Nothing Nothing -- intentionally left unknown
|
||||||
repsert sdDeut $ StudyTerms 103 Nothing Nothing -- intentionally left unknown
|
repsert sdDeut $ StudyTerms 103 Nothing Nothing Nothing Nothing -- intentionally left unknown
|
||||||
incidence1 <- liftIO getRandom
|
incidence1 <- liftIO getRandom
|
||||||
void . insert $ StudyTermCandidate incidence1 221 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence1 221 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence1 221 "Mathematik"
|
void . insert $ StudyTermNameCandidate incidence1 221 "Mathematik"
|
||||||
void . insert $ StudyTermCandidate incidence1 105 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence1 105 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence1 105 "Mathematik"
|
void . insert $ StudyTermNameCandidate incidence1 105 "Mathematik"
|
||||||
incidence2 <- liftIO getRandom
|
incidence2 <- liftIO getRandom
|
||||||
void . insert $ StudyTermCandidate incidence2 221 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence2 221 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence2 221 "Chemie"
|
void . insert $ StudyTermNameCandidate incidence2 221 "Chemie"
|
||||||
void . insert $ StudyTermCandidate incidence2 61 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence2 61 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence2 61 "Chemie"
|
void . insert $ StudyTermNameCandidate incidence2 61 "Chemie"
|
||||||
incidence3 <- liftIO getRandom
|
incidence3 <- liftIO getRandom
|
||||||
void . insert $ StudyTermCandidate incidence3 113 "Chemie"
|
void . insert $ StudyTermNameCandidate incidence3 113 "Chemie"
|
||||||
incidence4 <- liftIO getRandom -- ambiguous incidence
|
incidence4 <- liftIO getRandom -- ambiguous incidence
|
||||||
void . insert $ StudyTermCandidate incidence4 221 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence4 221 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence4 221 "Chemie"
|
void . insert $ StudyTermNameCandidate incidence4 221 "Chemie"
|
||||||
void . insert $ StudyTermCandidate incidence4 221 "Biologie"
|
void . insert $ StudyTermNameCandidate incidence4 221 "Biologie"
|
||||||
void . insert $ StudyTermCandidate incidence4 61 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence4 61 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence4 61 "Chemie"
|
void . insert $ StudyTermNameCandidate incidence4 61 "Chemie"
|
||||||
void . insert $ StudyTermCandidate incidence4 61 "Biologie"
|
void . insert $ StudyTermNameCandidate incidence4 61 "Biologie"
|
||||||
void . insert $ StudyTermCandidate incidence4 61 "Chemie"
|
void . insert $ StudyTermNameCandidate incidence4 61 "Chemie"
|
||||||
void . insert $ StudyTermCandidate incidence4 26 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence4 26 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence4 26 "Chemie"
|
void . insert $ StudyTermNameCandidate incidence4 26 "Chemie"
|
||||||
void . insert $ StudyTermCandidate incidence4 26 "Biologie"
|
void . insert $ StudyTermNameCandidate incidence4 26 "Biologie"
|
||||||
incidence5 <- liftIO getRandom
|
incidence5 <- liftIO getRandom
|
||||||
void . insert $ StudyTermCandidate incidence5 228 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence5 228 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence5 228 "Physik"
|
void . insert $ StudyTermNameCandidate incidence5 228 "Physik"
|
||||||
void . insert $ StudyTermCandidate incidence5 128 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence5 128 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence5 128 "Physik"
|
void . insert $ StudyTermNameCandidate incidence5 128 "Physik"
|
||||||
incidence6 <- liftIO getRandom
|
incidence6 <- liftIO getRandom
|
||||||
void . insert $ StudyTermCandidate incidence6 228 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence6 228 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence6 228 "Physik"
|
void . insert $ StudyTermNameCandidate incidence6 228 "Physik"
|
||||||
void . insert $ StudyTermCandidate incidence6 128 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence6 128 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence6 128 "Physik"
|
void . insert $ StudyTermNameCandidate incidence6 128 "Physik"
|
||||||
incidence7 <- liftIO getRandom
|
incidence7 <- liftIO getRandom
|
||||||
void . insert $ StudyTermCandidate incidence7 228 "Physik"
|
void . insert $ StudyTermNameCandidate incidence7 228 "Physik"
|
||||||
void . insert $ StudyTermCandidate incidence7 228 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence7 228 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence7 128 "Physik"
|
void . insert $ StudyTermNameCandidate incidence7 128 "Physik"
|
||||||
void . insert $ StudyTermCandidate incidence7 128 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence7 128 "Bioinformatik"
|
||||||
incidence8 <- liftIO getRandom
|
incidence8 <- liftIO getRandom
|
||||||
void . insert $ StudyTermCandidate incidence8 128 "Physik"
|
void . insert $ StudyTermNameCandidate incidence8 128 "Physik"
|
||||||
void . insert $ StudyTermCandidate incidence8 128 "Medieninformatik"
|
void . insert $ StudyTermNameCandidate incidence8 128 "Medieninformatik"
|
||||||
void . insert $ StudyTermCandidate incidence8 121 "Physik"
|
void . insert $ StudyTermNameCandidate incidence8 121 "Physik"
|
||||||
void . insert $ StudyTermCandidate incidence8 121 "Medieninformatik"
|
void . insert $ StudyTermNameCandidate incidence8 121 "Medieninformatik"
|
||||||
incidence9 <- liftIO getRandom
|
incidence9 <- liftIO getRandom
|
||||||
void . insert $ StudyTermCandidate incidence9 79 "Informatik"
|
void . insert $ StudyTermNameCandidate incidence9 79 "Informatik"
|
||||||
incidence10 <- liftIO getRandom
|
incidence10 <- liftIO getRandom
|
||||||
void . insert $ StudyTermCandidate incidence10 103 "Deutsch"
|
void . insert $ StudyTermNameCandidate incidence10 103 "Deutsch"
|
||||||
void . insert $ StudyTermCandidate incidence10 103 "Betriebswirtschaftslehre"
|
void . insert $ StudyTermNameCandidate incidence10 103 "Betriebswirtschaftslehre"
|
||||||
void . insert $ StudyTermCandidate incidence10 21 "Deutsch"
|
void . insert $ StudyTermNameCandidate incidence10 21 "Deutsch"
|
||||||
void . insert $ StudyTermCandidate incidence10 21 "Betriebswirtschaftslehre"
|
void . insert $ StudyTermNameCandidate incidence10 21 "Betriebswirtschaftslehre"
|
||||||
incidence11 <- liftIO getRandom
|
incidence11 <- liftIO getRandom
|
||||||
void . insert $ StudyTermCandidate incidence11 221 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence11 221 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence11 221 "Chemie"
|
void . insert $ StudyTermNameCandidate incidence11 221 "Chemie"
|
||||||
void . insert $ StudyTermCandidate incidence11 221 "Biologie"
|
void . insert $ StudyTermNameCandidate incidence11 221 "Biologie"
|
||||||
void . insert $ StudyTermCandidate incidence11 61 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence11 61 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence11 61 "Chemie"
|
void . insert $ StudyTermNameCandidate incidence11 61 "Chemie"
|
||||||
void . insert $ StudyTermCandidate incidence11 61 "Biologie"
|
void . insert $ StudyTermNameCandidate incidence11 61 "Biologie"
|
||||||
void . insert $ StudyTermCandidate incidence11 26 "Bioinformatik"
|
void . insert $ StudyTermNameCandidate incidence11 26 "Bioinformatik"
|
||||||
void . insert $ StudyTermCandidate incidence11 26 "Chemie"
|
void . insert $ StudyTermNameCandidate incidence11 26 "Chemie"
|
||||||
void . insert $ StudyTermCandidate incidence11 26 "Biologie"
|
void . insert $ StudyTermNameCandidate incidence11 26 "Biologie"
|
||||||
incidence12 <- liftIO getRandom
|
incidence12 <- liftIO getRandom
|
||||||
void . insert $ StudyTermCandidate incidence12 103 "Deutsch"
|
void . insert $ StudyTermNameCandidate incidence12 103 "Deutsch"
|
||||||
void . insert $ StudyTermCandidate incidence12 103 "Betriebswirtschaftslehre"
|
void . insert $ StudyTermNameCandidate incidence12 103 "Betriebswirtschaftslehre"
|
||||||
void . insert $ StudyTermCandidate incidence12 21 "Deutsch"
|
void . insert $ StudyTermNameCandidate incidence12 21 "Deutsch"
|
||||||
void . insert $ StudyTermCandidate incidence12 21 "Betriebswirtschaftslehre"
|
void . insert $ StudyTermNameCandidate incidence12 21 "Betriebswirtschaftslehre"
|
||||||
|
|
||||||
sfMMp <- insert $ StudyFeatures -- keyword type prevents record syntax here
|
sfMMp <- insert $ StudyFeatures -- keyword type prevents record syntax here
|
||||||
maxMuster
|
maxMuster
|
||||||
sdBsc
|
sdBsc
|
||||||
sdInf
|
sdInf
|
||||||
|
Nothing
|
||||||
FieldPrimary
|
FieldPrimary
|
||||||
2
|
2
|
||||||
now
|
now
|
||||||
@ -406,6 +407,7 @@ fillDb = do
|
|||||||
maxMuster
|
maxMuster
|
||||||
sdBsc
|
sdBsc
|
||||||
sdMath
|
sdMath
|
||||||
|
Nothing
|
||||||
FieldSecondary
|
FieldSecondary
|
||||||
2
|
2
|
||||||
now
|
now
|
||||||
@ -414,6 +416,7 @@ fillDb = do
|
|||||||
tinaTester
|
tinaTester
|
||||||
sdBsc
|
sdBsc
|
||||||
sdInf
|
sdInf
|
||||||
|
Nothing
|
||||||
FieldPrimary
|
FieldPrimary
|
||||||
4
|
4
|
||||||
now
|
now
|
||||||
@ -422,6 +425,7 @@ fillDb = do
|
|||||||
tinaTester
|
tinaTester
|
||||||
sdLAG
|
sdLAG
|
||||||
sdPhys
|
sdPhys
|
||||||
|
Nothing
|
||||||
FieldPrimary
|
FieldPrimary
|
||||||
1
|
1
|
||||||
now
|
now
|
||||||
@ -430,6 +434,7 @@ fillDb = do
|
|||||||
tinaTester
|
tinaTester
|
||||||
sdLAR
|
sdLAR
|
||||||
sdMedi
|
sdMedi
|
||||||
|
Nothing
|
||||||
FieldPrimary
|
FieldPrimary
|
||||||
7
|
7
|
||||||
now
|
now
|
||||||
@ -438,6 +443,7 @@ fillDb = do
|
|||||||
tinaTester
|
tinaTester
|
||||||
sdMst
|
sdMst
|
||||||
sdMath
|
sdMath
|
||||||
|
Nothing
|
||||||
FieldPrimary
|
FieldPrimary
|
||||||
3
|
3
|
||||||
now
|
now
|
||||||
|
|||||||
Reference in New Issue
Block a user