fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor: bump esqueleto & redo StudySubTerms

Browse Source 
BREAKING CHANGE: Bumped esqueleto
This commit is contained in:
Gregor Kleen 2019-11-26 17:43:19 +01:00
parent dd2210da1f
commit 0e027b129e
41 changed files with 387 additions and 275 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -761,6 +761,10 @@ AdminFeaturesHeading: Studiengänge
StudyTerms: Studiengänge StudyTerms: Studiengänge
StudyTerm: Studiengang StudyTerm: Studiengang
NoStudyTermsKnown: Keine Studiengänge bekannt NoStudyTermsKnown: Keine Studiengänge bekannt
StudyFeaturesDegrees: Abschlüsse
StudyFeaturesTerms: Studiengänge
StudyFeaturesNameCandidates: Namens-Kandidaten
StudyFeaturesParentCandidates: Eltern-Kandidaten
StudyFeatureInference: Studiengangschlüssel-Inferenz StudyFeatureInference: Studiengangschlüssel-Inferenz
StudyFeatureInferenceNoConflicts: Keine Konflikte beobachtet StudyFeatureInferenceNoConflicts: Keine Konflikte beobachtet
StudyFeatureInferenceConflictsHeading: Studiengangseinträge mit beobachteten Konflikten StudyFeatureInferenceConflictsHeading: Studiengangseinträge mit beobachteten Konflikten
@ -785,7 +789,9 @@ 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 AmbiguousCandidatesRemoved 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
RedundantParentCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Elternkandidat" "bekannte Elternkandiaten"} entfernt
RedundantStandaloneCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Einzelstudiengangskandidat" "bekannte Einzelstudiengangskandiaten"} entfernt
CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
AllIncidencesDeleted: Alle Beobachtungen wurden gelöscht. AllIncidencesDeleted: Alle Beobachtungen wurden gelöscht.
@ -2077,7 +2083,10 @@ 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 StudySubTermsParentKey: Elter
StudySubTermsParentName: Eltername
StudyTermsDefaultDegree: Default Abschluss StudyTermsDefaultDegree: Default Abschluss
StudyTermsDefaultFieldType: Default Typ StudyTermsDefaultFieldType: Default Typ

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

@ -758,6 +758,10 @@ 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
StudyFeaturesDegrees: Degrees
StudyFeaturesTerms: Terms of Study
StudyFeaturesNameCandidates: Name candidates
StudyFeaturesParentCandidates: Parent candidates
StudyFeatureInference: Infer field of study mapping StudyFeatureInference: Infer field of study mapping
StudyFeatureInferenceNoConflicts: No observed conflicts StudyFeatureInferenceNoConflicts: No observed conflicts
StudyFeatureInferenceConflictsHeading: Fields of study with observed conflicts StudyFeatureInferenceConflictsHeading: Fields of study with observed conflicts
@ -782,7 +786,9 @@ 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"} AmbiguousCandidatesRemoved 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"}
RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "parent-candidate" "parent-candidates"}
RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "standalone-candidate" "standalone-candidates"}
CandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "mapping" "mappings"} CandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "mapping" "mappings"}
NoCandidatesInferred: No new mappings inferred NoCandidatesInferred: No new mappings inferred
AllIncidencesDeleted: Successfully deleted all observations AllIncidencesDeleted: Successfully deleted all observations
@ -2072,7 +2078,10 @@ 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 StudySubTermsParentKey: Parent
StudySubTermsParentName: Parent-Name
StudyTermsDefaultDegree: Default degree StudyTermsDefaultDegree: Default degree
StudyTermsDefaultFieldType: Default type StudyTermsDefaultFieldType: Default type

2
models/exams.model
View File

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

17
models/users.model
View File

@ -55,13 +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 StudySubTermsId Maybe 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 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
@ -69,7 +69,7 @@ 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 -- standardised key key Int -- standardised key
shorthand Text Maybe -- admin determined shorthand shorthand Text Maybe -- admin determined shorthand
@ -78,14 +78,11 @@ StudyTerms -- Studiengang
defaultType StudyFieldType 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
StudySubTerms StudySubTerms
key Int child StudyTermsId
parent StudyTermsId Maybe parent StudyTermsId
shorthand Text Maybe UniqueStudySubTerms child parent
name Text Maybe
Primary key
deriving Show
StudyTermNameCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms. 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.

2
package.yaml
View File

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

19
src/Database/Esqueleto/Utils/TH.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE UndecidableInstances #-}
module Database.Esqueleto.Utils.TH module Database.Esqueleto.Utils.TH
( SqlIn(..) ( SqlIn(..)
, sqlInTuple, sqlInTuples , sqlInTuple, sqlInTuples
@ -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

3
src/Database/Persist/Class/Instances.hs
View File

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

61
src/Foundation.hs
View File

@ -3405,43 +3405,54 @@ upsertCampusUser ldapData Creds{..} = do
let let
studyTermCandidates = Set.fromList $ do studyTermCandidates = Set.fromList $ do
let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs' let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs'
subTermsKeys = unStudySubTermsKey . fst <$> sts subTermsKeys = unStudyTermsKey . fst <$> sts
(,) <$> sfKeys ++ subTermsKeys <*> termNames (,) <$> sfKeys ++ subTermsKeys <*> termNames
let let
assimilateSubTerms :: [(StudySubTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudySubTermsKey, Maybe StudyTermsId)) DB [StudyFeatures] assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) DB [StudyFeatures]
assimilateSubTerms [] xs = return xs assimilateSubTerms [] xs = return xs
assimilateSubTerms ((subterm'@(StudySubTermsKey' subterm), subSemester) : subterms) unusedFeats = do assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do
standalone <- lift . get $ StudyTermsKey' subterm standalone <- lift $ get subterm
case standalone of case standalone of
_other _other
| (_ : matches, unusedFeats') <- partition (\StudyFeatures{..} -> subterm == unStudyTermsKey studyFeaturesField | (match : matches, unusedFeats') <- partition
&& subSemester == studyFeaturesSemester (\StudyFeatures{..} -> subterm == studyFeaturesField
) unusedFeats && subSemester == studyFeaturesSemester
-> assimilateSubTerms subterms $ unusedFeats' ++ matches ) unusedFeats
| any ((== subterm) . unStudyTermsKey . studyFeaturesField) unusedFeats -> do
-> assimilateSubTerms subterms unusedFeats $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 StudyTerms{..}
| Just defDegree <- studyTermsDefaultDegree | Just defDegree <- studyTermsDefaultDegree
, Just defType <- studyTermsDefaultType , Just defType <- studyTermsDefaultType
-> (:) (StudyFeatures userId defDegree (StudyTermsKey' subterm) Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats -> 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 Nothing
| [] <- unusedFeats -> do | [] <- unusedFeats -> do
$logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|]
tell $ Set.singleton (subterm, Nothing) tell $ Set.singleton (subterm, Nothing)
assimilateSubTerms subterms unusedFeats assimilateSubTerms subterms []
_other -> do _other -> do
knownParent <- lift $ (>>= studySubTermsParent) <$> get subterm' knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
let matchingFeatures = case knownParent of let matchingFeatures = case knownParents of
Just p -> filter ((== p) . studyFeaturesField) unusedFeats [] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
Nothing -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> any (== studyFeaturesField) ps && studyFeaturesSemester == subSemester) unusedFeats
unless (is _Just knownParent) . forM_ matchingFeatures $ \StudyFeatures{..} -> when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
tell $ Set.singleton (subterm, Just studyFeaturesField) tell $ Set.singleton (subterm, Just studyFeaturesField)
if if
| is _Just knownParent | not $ null knownParents -> do
-> (++) (matchingFeatures & traverse . _studyFeaturesSubField %~ (<|> Just subterm')) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures) $logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|]
| otherwise (++) (matchingFeatures & traverse . _studyFeaturesSubField %~ (<|> Just subterm)) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures)
-> assimilateSubTerms subterms unusedFeats | 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' (fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs'
let let
@ -3453,10 +3464,12 @@ upsertCampusUser ldapData Creds{..} = do
. runConduitPure . runConduitPure
$ sourceList ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash $ sourceList ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash
candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate) -> do candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do
E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence
E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence
E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence) E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence 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
@ -3468,11 +3481,11 @@ upsertCampusUser ldapData Creds{..} = do
let let
studySubTermParentCandidates' = do studySubTermParentCandidates' = do
(studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates (StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates
let studySubTermParentCandidateIncidence = studyTermCandidateIncidence let studySubTermParentCandidateIncidence = studyTermCandidateIncidence
return StudySubTermParentCandidate{..} return StudySubTermParentCandidate{..}
studyTermStandaloneCandidates' = do studyTermStandaloneCandidates' = do
(studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates (StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates
let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence
return StudyTermStandaloneCandidate{..} return StudyTermStandaloneCandidate{..}
insertMany_ studySubTermParentCandidates' insertMany_ studySubTermParentCandidates'

226
src/Handler/Admin/StudyFeatures.hs
View File

@ -13,13 +13,10 @@ import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter, sqlFOJproj)
import qualified Handler.Utils.TermCandidates as Candidates import qualified Handler.Utils.TermCandidates as Candidates
import qualified Data.Maybe as Maybe
-- BEGIN - Buttons needed only for StudyTermNameCandidateManagement -- BEGIN - Buttons needed only for StudyTermNameCandidateManagement
data ButtonAdminStudyTerms data ButtonAdminStudyTerms
@ -51,49 +48,63 @@ postAdminFeaturesR = do
} }
infConflicts <- case btnResult of infConflicts <- case btnResult of
FormSuccess BtnCandidatesInfer -> do FormSuccess BtnCandidatesInfer -> do
(infConflicts, infAmbiguous, infRedundant, infAccepted) <- Candidates.inferHandler (infConflicts, infAmbiguous, (infRedundantNames, infRedundantParents, infRedundantStandalone), infAccepted) <- Candidates.inferHandler
unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant unless (null infRedundantNames) . addMessageI Info . MsgRedundantNameCandidatesRemoved $ length infRedundantNames
unless (null infRedundantParents) . addMessageI Info . MsgRedundantParentCandidatesRemoved $ length infRedundantParents
unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
unless (null infConflicts) $ do
let badKeys = map entityKey infConflicts
setSessionJson SessionConflictingStudyTerms badKeys
addMessageI Warning MsgStudyFeatureConflict
let newKeys = map fst infAccepted let newKeys = map fst infAccepted
setSessionJson SessionNewStudyTerms newKeys setSessionJson SessionNewStudyTerms newKeys
if | null infAccepted if | null infAccepted
-> addMessageI Info MsgNoCandidatesInferred -> addMessageI Info MsgNoCandidatesInferred
| otherwise | otherwise
-> addMessageI Success . MsgCandidatesInferred $ length infAccepted -> addMessageI Success . MsgCandidatesInferred $ length infAccepted
return infConflicts redirect AdminFeaturesR
FormSuccess BtnCandidatesDeleteConflicts -> runDB $ do FormSuccess BtnCandidatesDeleteConflicts -> do
confs <- Candidates.conflicts runDB $ do
incis <- Candidates.getIncidencesFor (bimap entityKey entityKey <$> confs) confs <- Candidates.conflicts
deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)] incis <- Candidates.getIncidencesFor $ map entityKey confs
addMessageI Success $ MsgIncidencesDeleted $ length incis deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)]
return [] deleteWhere [StudySubTermParentCandidateIncidence <-. (E.unValue <$> incis)]
FormSuccess BtnCandidatesDeleteAll -> runDB $ do deleteWhere [StudyTermStandaloneCandidateIncidence <-. (E.unValue <$> incis)]
deleteWhere ([] :: [Filter StudyTermNameCandidate]) addMessageI Success $ MsgIncidencesDeleted $ length incis
addMessageI Success MsgAllIncidencesDeleted redirect AdminFeaturesR
Candidates.conflicts FormSuccess BtnCandidatesDeleteAll -> do
runDB $ do
deleteWhere ([] :: [Filter StudyTermNameCandidate])
deleteWhere ([] :: [Filter StudySubTermParentCandidate])
deleteWhere ([] :: [Filter StudyTermStandaloneCandidate])
addMessageI Success MsgAllIncidencesDeleted
redirect AdminFeaturesR
_other -> runDB Candidates.conflicts _other -> runDB Candidates.conflicts
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms
( (degreeResult,degreeTable) ( (degreeResult,degreeTable)
, (studyTermsResult,studytermsTable) , (studyTermsResult,studytermsTable)
, ((), candidateTable) , ((), candidateTable)
, userSchools) <- runDB $ do , userSchools
, ((), parentCandidateTable)) <- runDB $ do
schools <- E.select . E.from $ \school -> do schools <- E.select . E.from $ \school -> do
E.where_ . E.exists . E.from $ \schoolFunction -> E.where_ . E.exists . E.from $ \schoolFunction ->
E.where_ $ schoolFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId E.where_ $ schoolFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId
E.&&. schoolFunction E.^. UserFunctionUser E.==. E.val uid E.&&. schoolFunction E.^. UserFunctionUser E.==. E.val uid
E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
return school return school
(,,,) (,,,,)
<$> mkDegreeTable <$> mkDegreeTable
<*> mkStudytermsTable (Set.fromList newStudyTermKeys) <*> mkStudytermsTable (Set.fromList newStudyTermKeys)
(Set.fromList $ map (bimap entityKey entityKey) infConflicts) (Set.fromList $ fromMaybe (map entityKey infConflicts) badStudyTermKeys)
(Set.fromList schools) (Set.fromList schools)
<*> mkCandidateTable <*> mkCandidateTable
<*> pure schools <*> pure schools
<*> mkParentCandidateTable
-- 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)) let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
degreeResult' = degreeResult <&> getDBFormResult degreeResult' = degreeResult <&> getDBFormResult
@ -104,27 +115,30 @@ postAdminFeaturesR = do
formResult degreeResult' $ \res -> do formResult degreeResult' $ \res -> do
void . runDB $ Map.traverseWithKey updateDegree res void . runDB $ Map.traverseWithKey updateDegree res
addMessageI Success MsgStudyDegreeChangeSuccess addMessageI Success MsgStudyDegreeChangeSuccess
redirect $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
let studyTermsResult' :: FormResult (Map (Either StudySubTermsId StudyTermsId) (Maybe Text, Maybe Text, Set SchoolId, Maybe StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType)) let studyTermsResult' :: FormResult (Map StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType))
studyTermsResult' = studyTermsResult <&> Map.mapKeys (\(mbL, mbR) -> Maybe.fromJust $ fmap Left mbR <|> fmap Right mbL) . getDBFormResult studyTermsResult' = studyTermsResult <&> getDBFormResult
(\row -> ( row ^? (_dbrOutput . _1 . _Just . _entityVal . _studyTermsName . _Just <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsName . _Just) (\row -> ( row ^? _dbrOutput . _1 . _entityVal . _studyTermsName . _Just
, row ^? (_dbrOutput . _1 . _Just . _entityVal . _studyTermsShorthand . _Just <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsShorthand . _Just) , row ^? _dbrOutput . _1 . _entityVal . _studyTermsShorthand . _Just
, row ^. _dbrOutput . _3 , row ^. _dbrOutput . _3
, row ^? _dbrOutput . _2 . _Just . _entityVal . _studySubTermsParent . _Just , row ^. _dbrOutput . _2 . to (Set.map entityKey)
, row ^? _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultDegree . _Just , row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree . _Just
, row ^? _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultType . _Just , row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultType . _Just
)) ))
updateStudyTerms (Right studyTermsKey) (name,short,schools,_parent,degree,sType) = do updateStudyTerms studyTermsKey (name,short,schools,parents,degree,sType) = do
degreeExists <- fmap (fromMaybe False) . for degree $ fmap (is _Just) . get degreeExists <- fmap (fromMaybe False) . for degree $ fmap (is _Just) . get
update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short, StudyTermsDefaultDegree =. guard degreeExists *> degree, StudyTermsDefaultType =. sType] update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short, StudyTermsDefaultDegree =. guard degreeExists *> degree, StudyTermsDefaultType =. sType]
forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey
deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools] deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools]
updateStudyTerms (Left studySubTermsKey) (name,short,_schools,parent,_degree,_type) = do
parentExists <- fmap (fromMaybe False) . for parent $ fmap (is _Just) . get forM_ parents $ void . insertUnique . StudySubTerms studyTermsKey
update studySubTermsKey [StudySubTermsName =. name, StudySubTermsShorthand =. short, StudySubTermsParent =. guard parentExists *> parent] deleteWhere [StudySubTermsChild ==. studyTermsKey, StudySubTermsParent /<-. Set.toList parents]
formResult studyTermsResult' $ \res -> do formResult studyTermsResult' $ \res -> do
void . runDB $ Map.traverseWithKey updateStudyTerms res void . runDB $ Map.traverseWithKey updateStudyTerms res
addMessageI Success MsgStudyTermsChangeSuccess addMessageI Success MsgStudyTermsChangeSuccess
redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
siteLayoutMsg MsgAdminFeaturesHeading $ do siteLayoutMsg MsgAdminFeaturesHeading $ do
setTitleI MsgAdminFeaturesHeading setTitleI MsgAdminFeaturesHeading
@ -152,17 +166,36 @@ postAdminFeaturesR = do
<$> mpopt checkBoxField "" (Just $ row ^. lensDefault) <$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
) )
termKeyCell :: Ord i -- termKeyCell :: Ord i
=> Lens' a (Maybe StudyTermsId) -- => Lens' a (Maybe StudyTermsId)
-> Getter (DBRow r) (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 -> Getter (DBRow r) i
-> DBRow r -> DBRow r
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
termKeyCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) parentsCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView)) ( \row mkUnique -> (\(res, fieldView) -> (set lensRes . Set.fromList <$> res, fvInput fieldView))
<$> mopt (intField & isoField (from _StudyTermsId)) "" (Just $ row ^. lensDefault) <$> massInputList
(intField & isoField (from _StudyTermsId))
(const "")
(Just . SomeRoute . (AdminFeaturesR :#:))
(mkUnique ("parents" :: Text))
""
False
(Just . Set.toList $ row ^. lensDefault)
mempty
) )
degreeCell :: Ord i degreeCell :: Ord i
=> Lens' a (Maybe StudyDegreeId) => Lens' a (Maybe StudyDegreeId)
-> Getter (DBRow r) (Maybe StudyDegreeId) -> Getter (DBRow r) (Maybe StudyDegreeId)
@ -171,7 +204,7 @@ postAdminFeaturesR = do
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
degreeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) degreeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView)) ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
<$> mopt (intField & isoField (from _StudyDegreeId)) "" (Just $ row ^. lensDefault) <$> mopt degreeField "" (Just $ row ^. lensDefault)
) )
fieldTypeCell :: Ord i fieldTypeCell :: Ord i
@ -216,49 +249,50 @@ postAdminFeaturesR = do
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
in dbTable psValidator DBTable{..} in dbTable psValidator DBTable{..}
mkStudytermsTable :: Set Int -> Set (Either StudySubTermsId StudyTermsId) -> Set (Entity School) -> DB (FormResult (DBFormResult (Maybe StudyTermsId, Maybe StudySubTermsId) (Maybe Text, Maybe Text, Set SchoolId, Maybe StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Maybe (Entity StudyTerms), Maybe (Entity StudySubTerms), Set SchoolId))), Widget) 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 = mkStudytermsTable newKeys badKeys schools =
let dbtIdent = "admin-studyterms" :: Text let dbtIdent = "admin-studyterms" :: Text
dbtStyle = def dbtStyle = def
dbtSQLQuery :: E.SqlExpr (Maybe (Entity StudyTerms)) `E.FullOuterJoin` E.SqlExpr (Maybe (Entity StudySubTerms)) -> E.SqlQuery (E.SqlExpr (Maybe (Entity StudyTerms)), E.SqlExpr (Maybe (Entity StudySubTerms))) dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
dbtSQLQuery (studyTerms `E.FullOuterJoin` studySubTerms) = do dbtSQLQuery = return
E.on $ studyTerms E.?. StudyTermsKey E.==. studySubTerms E.?. StudySubTermsKey dbtRowKey = (E.^. StudyTermsKey)
return (studyTerms, studySubTerms) dbtProj field@(view _dbrOutput -> Entity fId _) = do
dbtRowKey (studyTerms `E.FullOuterJoin` studySubTerms) = (studyTerms E.?. StudyTermsKey, studySubTerms E.?. StudySubTermsKey) fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
dbtProj field = do
fieldSchools <- for (field ^. _dbrOutput . _1) $ \field' -> fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
E.where_ . E.exists . E.from $ \schoolTerms -> E.where_ . E.exists . E.from $ \schoolTerms ->
E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val (field' ^. _entityKey) E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId
E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools) E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
return $ school E.^. SchoolId return $ school E.^. SchoolId
return $ field & _dbrOutput %~ (\(field', subField) -> (field', subField, fromMaybe Set.empty fieldSchools)) 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 dbtColonnade = formColonnade $ mconcat
[ sortable (Just "key") (i18nCell MsgGenericKey) (maybe mempty numCell . preview (_dbrOutput . _1 . _Just . _entityVal . _studyTermsKey)) [ sortable (Just "key") (i18nCell MsgGenericKey) (maybe mempty numCell . preview (_dbrOutput . _1 . _entityVal . _studyTermsKey))
, sortable (Just "parent") (i18nCell MsgStudySubTermsParentKey) (termKeyCell _4 (pre $ _dbrOutput . _2 . _Just . _entityVal . _studySubTermsParent . _Just) _dbrKey') , sortable Nothing (i18nCell MsgStudySubTermsParentKey) (parentsCell _4 (_dbrOutput . _2 . to (Set.map entityKey)) _dbrKey')
, sortable (Just "isnew") (i18nCell MsgGenericIsNew) (maybe mempty (isNewCell . flip Set.member newKeys) . preview (_dbrOutput . _1 . _Just . _entityVal . _studyTermsKey <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsKey)) , sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey))
, sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (maybe mempty (isBadCell . flip Set.member badKeys) . preview (_dbrOutput . _1 . _Just . _entityVal . _studyTermsKey <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsKey)) , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey))
, sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (singular $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsName <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsName) _dbrKey') , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) _dbrKey')
, sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (singular $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsShorthand <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsShorthand) _dbrKey') , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) _dbrKey')
, sortable (Just "degree") (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _5 (pre $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultDegree . _Just) _dbrKey') , sortable (Just "degree") (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _5 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree) _dbrKey')
, sortable (Just "field-type") (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _6 (pre $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultType . _Just) _dbrKey') , sortable (Just "field-type") (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _6 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultType) _dbrKey')
, flip foldMap schools $ \(Entity ssh School{schoolName}) -> , flip foldMap schools $ \(Entity ssh School{schoolName}) ->
sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _3 . at ssh . _Maybe) _dbrKey') sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _3 . at ssh . _Maybe) _dbrKey')
, dbRow , dbRow
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ ("key" , SortColumn $ \t -> E.maybe (querySubField t E.?. StudySubTermsKey) E.just $ queryField t E.?. StudyTermsKey) [ ("key" , SortColumn $ queryField >>> (E.^. StudyTermsKey))
, ("parent", SortColumn $ \t -> querySubField t E.?. StudySubTermsParent) -- , ("parent", SortColumn $ \t -> querySubField t E.?. StudySubTermsParent)
, ("isnew" , SortColumn $ \t -> queryField t E.?. StudyTermsKey `E.in_` E.valList (Just <$> Set.toList newKeys) , ("isnew" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys))
E.||. querySubField t E.?. StudySubTermsKey `E.in_` E.valList (Just <$> Set.toList newKeys)
) )
, ("isbad" , SortColumn $ \t -> queryField t E.?. StudyTermsKey `E.in_` E.valList (Just <$> Set.toList badKeys) , ("isbad" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList badKeys))
E.||. querySubField t E.?. StudySubTermsKey `E.in_` E.valList (Just <$> Set.toList badKeys)
) )
, ("name" , SortColumn $ \t -> E.maybe (E.joinV $ querySubField t E.?. StudySubTermsName) E.just . E.joinV $ queryField t E.?. StudyTermsName) , ("name" , SortColumn $ queryField >>> (E.^. StudyTermsName))
, ("short" , SortColumn $ \t -> E.maybe (E.joinV $ querySubField t E.?. StudySubTermsShorthand) E.just . E.joinV $ queryField t E.?. StudyTermsShorthand) , ("short" , SortColumn $ queryField >>> (E.^. StudyTermsShorthand))
, ("degree" , SortColumn $ \t -> queryField t E.?. StudyTermsDefaultDegree) , ("degree" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultDegree))
, ("field-type" , SortColumn $ \t -> queryField t E.?. StudyTermsDefaultType) , ("field-type" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultType))
] ]
dbtFilter = mempty dbtFilter = mempty
dbtFilterUI = mempty dbtFilterUI = mempty
@ -270,13 +304,9 @@ postAdminFeaturesR = do
dbtCsvEncode = noCsvEncode dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
queryField = $(sqlFOJproj 2 1) queryField = id
querySubField = $(sqlFOJproj 2 2) _dbrKey' :: Getter (DBRow (Entity StudyTerms, _, _)) StudyTermsId
_dbrKey' :: Getter (DBRow (Maybe (Entity StudyTerms), Maybe (Entity StudySubTerms), Set SchoolId)) _dbrKey' = _dbrOutput . _1 . _entityKey
(Maybe StudyTermsId, Maybe StudySubTermsId)
_dbrKey' = $(multifocusL 2) (_dbrOutput . _1 . applying (_Entity . _1)) (_dbrOutput . _2 . applying (_Entity . _1))
badKeys = Set.map (either unStudySubTermsKey unStudyTermsKey) badKeys'
in dbTable psValidator DBTable{..} in dbTable psValidator DBTable{..}
mkCandidateTable = mkCandidateTable =
@ -313,3 +343,43 @@ postAdminFeaturesR = do
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
in dbTable psValidator DBTable{..} 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 Nothing (i18nCell MsgStudySubTermsChildName) (maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _studyTermsName . _Just))
, sortable (Just "parent") (i18nCell MsgStudySubTermsParentKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateParent))
, sortable Nothing (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))
, ("parent" , SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateParent))
, ("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
in dbTable psValidator DBTable{..}

3
src/Handler/Allocation/List.hs
View File

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

7
src/Handler/Corrections.hs
View File

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

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

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

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

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

3
src/Handler/Course/List.hs
View File

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

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

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

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

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

4
src/Handler/Course/Users.hs
View File

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

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

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

6
src/Handler/ExamOffice/Exams.hs
View File

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

2
src/Handler/Home.hs
View File

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

8
src/Handler/Material.hs
View File

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

19
src/Handler/Profile.hs
View File

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

8
src/Handler/Sheet.hs
View File

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

3
src/Handler/Term.hs
View File

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

3
src/Handler/Tutorial/Delete.hs
View File

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

11
src/Handler/Tutorial/List.hs
View File

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

3
src/Handler/Users.hs
View File

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

5
src/Handler/Utils/Allocation.hs
View File

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

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

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

2
src/Handler/Utils/Invitations.hs
View File

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

3
src/Handler/Utils/Sheet.hs
View File

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

6
src/Handler/Utils/StudyFeatures.hs
View File

@ -17,7 +17,7 @@ parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key)
where where
Ldap.Attr key = ldapUserStudyFeatures Ldap.Attr key = ldapUserStudyFeatures
parseSubTermsSemester :: Text -> Either ParseError (StudySubTermsId, Int) parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int)
parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key) parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key)
where where
Ldap.Attr key = ldapUserSubTermsSemester Ldap.Attr key = ldapUserSubTermsSemester
@ -59,9 +59,9 @@ decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit'
dVal c = fromEnum c - fromEnum '0' dVal c = fromEnum c - fromEnum '0'
pLMUTermsSemester :: Parser (StudySubTermsId, Int) pLMUTermsSemester :: Parser (StudyTermsId, Int)
pLMUTermsSemester = do pLMUTermsSemester = do
subTermsKey <- StudySubTermsKey' <$> pKey subTermsKey <- StudyTermsKey' <$> pKey
void $ char '$' void $ char '$'
semester <- decimal semester <- decimal

2
src/Handler/Utils/Submission.hs
View File

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

110
src/Handler/Utils/TermCandidates.hs
View File

@ -25,13 +25,12 @@ import qualified Data.Map as Map
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Database.Esqueleto.Utils 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 StudyTermNameCandidateKey type STKey = Int -- for convenience, assmued identical to field StudyTermNameCandidateKey
data FailedCandidateInference = FailedCandidateInference [Either (Entity StudySubTerms) (Entity StudyTerms)] data FailedCandidateInference = FailedCandidateInference [Entity StudyTerms]
deriving (Typeable, Show) deriving (Typeable, Show)
instance Exception FailedCandidateInference instance Exception FailedCandidateInference
@ -46,17 +45,19 @@ 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 ([Either (Entity StudySubTerms) (Entity StudyTerms)],[TermCandidateIncidence],[Entity StudyTermNameCandidate],[(STKey,Text)]) inferHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],_,[(StudyTermsId,Text)])
inferHandler = runDB $ inferAcc ([],[],[]) inferHandler = 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 null infAccs
then return ([], accAmbiguous, infReds ++ accRedundants, accAccepted) then return ([], accAmbiguous, infReds <> accRedundants, accAccepted')
else do else 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 <- removeAmbiguous
@ -102,27 +103,30 @@ removeAmbiguous = do
return ambiSet return ambiSet
-- | remove known StudyTerm from candidates that have the _exact_ name, removeRedundant :: DB ([Entity StudyTermNameCandidate], [Entity StudySubTermParentCandidate], [Entity StudyTermStandaloneCandidate])
-- ie. if a candidate contains a known key, we remove it and its associated fullname removeRedundant = (,,) <$> removeRedundantNames <*> removeRedundantParents <*> removeRedundantStandalone
-- only save if ambiguous candidates haven been removed where
removeRedundant :: DB [Entity StudyTermNameCandidate] -- | remove known StudyTerm from candidates that have the _exact_ name,
removeRedundant = do -- ie. if a candidate contains a known key, we remove it and its associated fullname
redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` (sterm `E.FullOuterJoin` ssubterm)) -> do -- only save if ambiguous candidates haven been removed
E.on E.true removeRedundantNames :: DB [Entity StudyTermNameCandidate]
E.on $ ( E.just (candidate E.^. StudyTermNameCandidateKey) E.==. sterm E.?. StudyTermsKey removeRedundantNames = do
E.&&. E.just (candidate E.^. StudyTermNameCandidateName) E.==. E.joinV (sterm E.?. StudyTermsName) redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do
) E.on $ E.just (candidate E.^. StudyTermNameCandidateKey) E.==. sterm E.?. StudyTermsKey
E.||. ( E.just (candidate E.^. StudyTermNameCandidateKey) E.==. ssubterm E.?. StudySubTermsKey E.&&. E.just (candidate E.^. StudyTermNameCandidateName) E.==. E.joinV (sterm E.?. StudyTermsName)
E.&&. E.just (candidate E.^. StudyTermNameCandidateName) E.==. E.joinV (ssubterm E.?. StudySubTermsName) return candidate
) -- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
return candidate forM_ redundants $ \Entity{entityVal=StudyTermNameCandidate{..}} ->
-- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps. deleteWhere $ ( StudyTermNameCandidateIncidence ==. studyTermNameCandidateIncidence )
forM_ redundants $ \Entity{entityVal=StudyTermNameCandidate{..}} -> : ([ StudyTermNameCandidateKey ==. studyTermNameCandidateKey ]
deleteWhere $ ( StudyTermNameCandidateIncidence ==. studyTermNameCandidateIncidence ) ||. [ StudyTermNameCandidateName ==. studyTermNameCandidateName ])
: ([ StudyTermNameCandidateKey ==. studyTermNameCandidateKey ] return redundants
||. [ StudyTermNameCandidateName ==. studyTermNameCandidateName ])
return redundants
removeRedundantParents :: DB [Entity StudySubTermParentCandidate]
removeRedundantParents = return []
removeRedundantStandalone :: DB [Entity StudyTermStandaloneCandidate]
removeRedundantStandalone = return []
-- | Search for single candidates and memorize them as StudyTerms. -- | Search for single candidates and memorize them as StudyTerms.
-- Should be called after @removeRedundant@ to increase success chances and reduce cost; otherwise memory heavy! -- Should be called after @removeRedundant@ to increase success chances and reduce cost; otherwise memory heavy!
@ -132,10 +136,9 @@ removeRedundant = do
acceptSingletons :: DB [(STKey,Text)] acceptSingletons :: DB [(STKey,Text)]
acceptSingletons = do acceptSingletons = do
knownKeys <- fmap unStudyTermsKey <$> selectKeysList [StudyTermsName !=. Nothing] [Asc StudyTermsKey] knownKeys <- fmap unStudyTermsKey <$> selectKeysList [StudyTermsName !=. Nothing] [Asc StudyTermsKey]
knownSubKeys <- fmap unStudySubTermsKey <$> selectKeysList [StudySubTermsName !=. Nothing] [Asc StudySubTermsKey]
-- 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 [StudyTermNameCandidateKey /<-. knownKeys ++ knownSubKeys] [] -- 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
@ -168,13 +171,8 @@ acceptSingletons = do
-- registerFixed :: (STKey, Text) -> DB (Key StudyTerms) -- registerFixed :: (STKey, Text) -> DB (Key StudyTerms)
registerFixed :: (STKey, Text) -> DB () registerFixed :: (STKey, Text) -> DB ()
registerFixed (key, name) = do registerFixed (key, name) =
isSub <- is _Just <$> get (StudySubTermsKey' key) repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name) Nothing Nothing
if
| isSub
-> repsert (StudySubTermsKey' key) $ StudySubTerms key Nothing Nothing (Just name)
| otherwise
-> repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name) Nothing Nothing
-- register newly fixed candidates -- register newly fixed candidates
forM_ fixedKeys registerFixed forM_ fixedKeys registerFixed
@ -182,31 +180,27 @@ acceptSingletons = do
-- | all existing StudyTerms that are contradiced by current observations -- | all existing StudyTerms that are contradiced by current observations
conflicts :: DB [Either (Entity StudySubTerms) (Entity StudyTerms)] conflicts :: DB [Entity StudyTerms]
conflicts = (++) <$> fmap (map Left) conflictingSubTerms <*> fmap (map Right) conflictingTerms conflicts = E.select $ E.from $ \studyTerms -> do
where E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName
conflictingTerms = E.select $ E.from $ \studyTerms -> do E.where_ $ E.exists $ E.from $ \candidateOne -> do
E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studyTerms E.^. StudyTermsKey
E.where_ $ E.exists $ E.from $ \candidateOne -> do E.where_ $ E.notExists . E.from $ \candidateTwo -> do
E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studyTerms E.^. StudyTermsKey E.where_ $ candidateTwo E.^. StudyTermNameCandidateIncidence E.==. candidateOne E.^. StudyTermNameCandidateIncidence
E.where_ $ E.notExists . E.from $ \candidateTwo -> do E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
E.where_ $ candidateTwo E.^. StudyTermNameCandidateIncidence E.==. candidateOne E.^. StudyTermNameCandidateIncidence E.||. E.exists ( E.from $ \(pCandidate `E.LeftOuterJoin` termsTwo) -> do
E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName) E.on $ pCandidate E.^. StudySubTermParentCandidateParent E.==. studyTerms E.^. StudyTermsKey
return studyTerms E.&&. E.just (pCandidate E.^. StudySubTermParentCandidateKey) E.==. termsTwo E.?. StudyTermsKey
conflictingSubTerms = E.select $ E.from $ \studySubTerms -> do E.where_ $ E.joinV (termsTwo E.?. StudyTermsName) E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
E.where_ $ E.not_ $ E.isNothing $ studySubTerms E.^. StudySubTermsName E.||. E.isNothing (E.joinV $ termsTwo E.?. StudyTermsName)
E.where_ $ E.exists $ E.from $ \candidateOne -> do )
E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studySubTerms E.^. StudySubTermsKey return studyTerms
E.where_ $ E.notExists . E.from $ \candidateTwo -> do
E.where_ $ candidateTwo E.^. StudyTermNameCandidateIncidence E.==. candidateOne E.^. StudyTermNameCandidateIncidence
E.where_ $ studySubTerms E.^. StudySubTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
return studySubTerms
-- | retrieve all incidence keys having containing a certain @StudyTermKey @ -- | retrieve all incidence keys having containing a certain @StudyTermKey @
getIncidencesFor :: [Either (Key StudySubTerms) (Key StudyTerms)] -> DB [E.Value TermCandidateIncidence] getIncidencesFor :: [StudyTermsId] -> DB [E.Value TermCandidateIncidence]
getIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do getIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do
E.where_ $ candidate E.^. StudyTermNameCandidateKey `E.in_` E.valList stks' E.where_ $ candidate E.^. StudyTermNameCandidateKey `E.in_` E.valList stks'
return $ candidate E.^. StudyTermNameCandidateIncidence return $ candidate E.^. StudyTermNameCandidateIncidence
where where
stks' = stks <&> either unStudySubTermsKey unStudyTermsKey stks' = stks <&> unStudyTermsKey

14
src/Jobs/Handler/SendNotification/Allocation.hs
View File

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

2
src/Model.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
module Model module Model
( module Model ( module Model

6
src/Model/Migration.hs
View File

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

2
src/Utils.hs
View File

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

2
src/Utils/Lens.hs
View File

@ -150,6 +150,8 @@ makePrisms ''AuthResult
makePrisms ''FormResult makePrisms ''FormResult
makeLenses_ ''StudyTermNameCandidate makeLenses_ ''StudyTermNameCandidate
makeLenses_ ''StudySubTermParentCandidate
makeLenses_ ''StudyTermStandaloneCandidate
makeLenses_ ''FieldView makeLenses_ ''FieldView
makeLenses_ ''FieldSettings makeLenses_ ''FieldSettings

6
stack.yaml
View File

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

43
templates/adminFeatures.hamlet
View File

@ -1,25 +1,30 @@
$newline never $newline never
<section> <section>
<h2>
_{MsgStudyFeaturesDegrees}
^{degreeTable} ^{degreeTable}
<section> <section>
<h2>
_{MsgStudyFeaturesTerms}
^{studytermsTable} ^{studytermsTable}
<section> <section>
<h2>_{MsgStudyFeatureInference} <h2>
$if null infConflicts _{MsgStudyFeaturesNameCandidates}
<p> ^{candidateTable}
$if null infConflicts <section>
_{MsgStudyFeatureInferenceNoConflicts} <h2>
$else _{MsgStudyFeaturesParentCandidates}
<h3>_{MsgStudyFeatureInferenceConflictsHeading} ^{parentCandidateTable}
<ul> <section>
$forall conflict <- infConflicts <h2>
<li> _{MsgStudyFeatureInference}
$case conflict <p>
$of Right (Entity _ (StudyTerms ky _ nm _ _)) $if null infConflicts
#{show ky} - #{foldMap id nm} _{MsgStudyFeatureInferenceNoConflicts}
$of Left (Entity _ (StudySubTerms ky _ _ nm)) $else
#{show ky} - #{foldMap id nm} <h3>_{MsgStudyFeatureInferenceConflictsHeading}
^{btnForm} <ul>
$forall Entity _ (StudyTerms ky _ nm _ _) <- infConflicts
<div .container> <li>
^{candidateTable} #{show ky} - #{foldMap id nm}
^{btnForm}