From 0e027b129eada45ce90f6b32223aab3fde8cf9cd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 26 Nov 2019 17:43:19 +0100 Subject: [PATCH] refactor: bump esqueleto & redo StudySubTerms BREAKING CHANGE: Bumped esqueleto --- messages/uniworx/de-de-formal.msg | 11 +- messages/uniworx/en-eu.msg | 11 +- models/exams.model | 2 +- models/users.model | 17 +- package.yaml | 2 +- src/Database/Esqueleto/Utils/TH.hs | 19 +- src/Database/Persist/Class/Instances.hs | 3 - src/Foundation.hs | 61 +++-- src/Handler/Admin/StudyFeatures.hs | 226 ++++++++++++------ src/Handler/Allocation/List.hs | 3 +- src/Handler/Corrections.hs | 7 +- src/Handler/Course/Application/List.hs | 3 +- src/Handler/Course/Edit.hs | 2 +- src/Handler/Course/List.hs | 3 +- src/Handler/Course/Register.hs | 4 +- src/Handler/Course/Show.hs | 8 +- src/Handler/Course/Users.hs | 4 +- src/Handler/Exam/Users.hs | 4 +- src/Handler/ExamOffice/Exams.hs | 6 +- src/Handler/Home.hs | 2 +- src/Handler/Material.hs | 8 +- src/Handler/Profile.hs | 19 +- src/Handler/Sheet.hs | 8 +- src/Handler/Term.hs | 3 +- src/Handler/Tutorial/Delete.hs | 3 +- src/Handler/Tutorial/List.hs | 11 +- src/Handler/Users.hs | 3 +- src/Handler/Utils/Allocation.hs | 5 +- src/Handler/Utils/Form.hs | 6 + src/Handler/Utils/Invitations.hs | 2 + src/Handler/Utils/Sheet.hs | 3 +- src/Handler/Utils/StudyFeatures.hs | 6 +- src/Handler/Utils/Submission.hs | 2 +- src/Handler/Utils/TermCandidates.hs | 110 ++++----- .../Handler/SendNotification/Allocation.hs | 14 +- src/Model.hs | 2 +- src/Model/Migration.hs | 6 + src/Utils.hs | 2 +- src/Utils/Lens.hs | 2 + stack.yaml | 6 +- templates/adminFeatures.hamlet | 43 ++-- 41 files changed, 387 insertions(+), 275 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index c133390fe..89f9dc9b9 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -761,6 +761,10 @@ AdminFeaturesHeading: Studiengänge StudyTerms: Studiengänge StudyTerm: Studiengang NoStudyTermsKnown: Keine Studiengänge bekannt +StudyFeaturesDegrees: Abschlüsse +StudyFeaturesTerms: Studiengänge +StudyFeaturesNameCandidates: Namens-Kandidaten +StudyFeaturesParentCandidates: Eltern-Kandidaten StudyFeatureInference: Studiengangschlüssel-Inferenz StudyFeatureInferenceNoConflicts: Keine Konflikte beobachtet StudyFeatureInferenceConflictsHeading: Studiengangseinträge mit beobachteten Konflikten @@ -785,7 +789,9 @@ StudyTermsChangeSuccess: Zuordnung Studiengänge aktualisiert StudyDegreeChangeSuccess: Zuordnung Abschlüsse aktualisiert StudyCandidateIncidence: Synchronisation 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 NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert AllIncidencesDeleted: Alle Beobachtungen wurden gelöscht. @@ -2077,7 +2083,10 @@ ShortSexNotApplicable: k.A. ShowSex: Geschlechter anderer Nutzer anzeigen ShowSexTip: Sollen in Kursteilnehmer-Tabellen u.Ä. die Geschlechter der Nutzer angezeigt werden? +StudySubTermsChildKey: Kind +StudySubTermsChildName: Kindname StudySubTermsParentKey: Elter +StudySubTermsParentName: Eltername StudyTermsDefaultDegree: Default Abschluss StudyTermsDefaultFieldType: Default Typ diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 5307eb03e..5634fd495 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -758,6 +758,10 @@ AdminFeaturesHeading: Features of study StudyTerms: Fields of study StudyTerm: Field 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 StudyFeatureInferenceNoConflicts: No observed conflicts StudyFeatureInferenceConflictsHeading: Fields of study with observed conflicts @@ -782,7 +786,9 @@ StudyTermsChangeSuccess: Successfully updated fields of study StudyDegreeChangeSuccess: Successfully updated degrees StudyCandidateIncidence: Synchronisation 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"} NoCandidatesInferred: No new mappings inferred AllIncidencesDeleted: Successfully deleted all observations @@ -2072,7 +2078,10 @@ ShortSexNotApplicable: N/A ShowSex: Show sex of other users ShowSexTip: Should users' sex be displayed in (among others) lists of course participants? +StudySubTermsChildKey: Child +StudySubTermsChildName: Child-Name StudySubTermsParentKey: Parent +StudySubTermsParentName: Parent-Name StudyTermsDefaultDegree: Default degree StudyTermsDefaultFieldType: Default type diff --git a/models/exams.model b/models/exams.model index 7eff47789..c23917bc7 100644 --- a/models/exams.model +++ b/models/exams.model @@ -64,5 +64,5 @@ ExamCorrector UniqueExamCorrector exam user ExamPartCorrector part ExamPartId - corrector ExamCorrector + corrector ExamCorrectorId UniqueExamPartCorrector part corrector \ No newline at end of file diff --git a/models/users.model b/models/users.model index 4210cd5ac..87c9c6a87 100644 --- a/models/users.model +++ b/models/users.model @@ -55,13 +55,13 @@ StudyFeatures -- multiple entries possible for students pursuing several degree user UserId degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc. field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc. - subField StudySubTermsId Maybe + subField StudyTermsId Maybe type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach semester Int updated UTCTime default=now() -- last update from LDAP valid Bool default=true -- marked as active in LDAP (students may switch, but LDAP never forgets) UniqueStudyFeatures user degree field type semester - deriving Eq + deriving Eq Show -- UniqueUserSubject ubuser degree field -- There exists a counterexample StudyDegree -- Studienabschluss key Int -- LMU-internal key @@ -69,7 +69,7 @@ StudyDegree -- Studienabschluss name Text Maybe -- description given by LDAP Primary key -- column key is used as actual DB row key -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int } - deriving Show + deriving Eq Show StudyTerms -- Studiengang key Int -- standardised key shorthand Text Maybe -- admin determined shorthand @@ -78,14 +78,11 @@ StudyTerms -- Studiengang defaultType StudyFieldType Maybe Primary key -- column key is used as actual DB row key -- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int } - deriving Show + deriving Eq Ord Show StudySubTerms - key Int - parent StudyTermsId Maybe - shorthand Text Maybe - name Text Maybe - Primary key - deriving Show + child StudyTermsId + parent StudyTermsId + UniqueStudySubTerms child parent StudyTermNameCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms. -- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence. -- This table helps us to infer which key belongs to which plain text by recording possible combinations at login. diff --git a/package.yaml b/package.yaml index c5339dc30..ea41ab47e 100644 --- a/package.yaml +++ b/package.yaml @@ -68,7 +68,7 @@ dependencies: - cereal - mtl - sandi - - esqueleto + - esqueleto >=3.1.0 - mime-types - generic-deriving - blaze-html diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index 4d0f5b536..b0c6a3699 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UndecidableInstances #-} + module Database.Esqueleto.Utils.TH ( SqlIn(..) , sqlInTuple, sqlInTuples @@ -21,8 +23,17 @@ import Utils.TH class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool) -instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where - x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs) +instance SqlEq a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where + 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 = mapM sqlInTuple @@ -35,10 +46,10 @@ sqlInTuple arity = do xsV <- newName "xs" 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 - 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 [ clause [tupP $ map varP xVs, varP xsV] ( guardedB diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs index 8666a2c87..8fc9eb20b 100644 --- a/src/Database/Persist/Class/Instances.hs +++ b/src/Database/Persist/Class/Instances.hs @@ -34,6 +34,3 @@ uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistU instance PersistEntity record => Eq (Unique record) where (==) = (==) `on` uniqueToMap - -instance PersistEntity record => Show (Unique record) where - showsPrec p = showsPrec p . uniqueToMap diff --git a/src/Foundation.hs b/src/Foundation.hs index 12b181aa1..389163364 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -3405,43 +3405,54 @@ upsertCampusUser ldapData Creds{..} = do let studyTermCandidates = Set.fromList $ do let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs' - subTermsKeys = unStudySubTermsKey . fst <$> sts + subTermsKeys = unStudyTermsKey . fst <$> sts (,) <$> sfKeys ++ subTermsKeys <*> termNames 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 ((subterm'@(StudySubTermsKey' subterm), subSemester) : subterms) unusedFeats = do - standalone <- lift . get $ StudyTermsKey' subterm + assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do + standalone <- lift $ get subterm case standalone of _other - | (_ : matches, unusedFeats') <- partition (\StudyFeatures{..} -> subterm == unStudyTermsKey studyFeaturesField - && subSemester == studyFeaturesSemester - ) unusedFeats - -> assimilateSubTerms subterms $ unusedFeats' ++ matches - | any ((== subterm) . unStudyTermsKey . studyFeaturesField) unusedFeats - -> assimilateSubTerms subterms unusedFeats + | (match : matches, unusedFeats') <- partition + (\StudyFeatures{..} -> subterm == studyFeaturesField + && subSemester == studyFeaturesSemester + ) unusedFeats + -> do + $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|] + (:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats') + | any ((== subterm) . studyFeaturesField) unusedFeats + -> do + $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|] + assimilateSubTerms subterms unusedFeats Just StudyTerms{..} | Just defDegree <- studyTermsDefaultDegree , Just defType <- studyTermsDefaultType - -> (:) (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 | [] <- unusedFeats -> do + $logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|] tell $ Set.singleton (subterm, Nothing) - assimilateSubTerms subterms unusedFeats + assimilateSubTerms subterms [] _other -> do - knownParent <- lift $ (>>= studySubTermsParent) <$> get subterm' - let matchingFeatures = case knownParent of - Just p -> filter ((== p) . studyFeaturesField) unusedFeats - Nothing -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats - unless (is _Just knownParent) . forM_ matchingFeatures $ \StudyFeatures{..} -> + knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] [] + let matchingFeatures = case knownParents of + [] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats + ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> any (== studyFeaturesField) ps && studyFeaturesSemester == subSemester) unusedFeats + when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} -> tell $ Set.singleton (subterm, Just studyFeaturesField) if - | is _Just knownParent - -> (++) (matchingFeatures & traverse . _studyFeaturesSubField %~ (<|> Just subterm')) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures) - | otherwise - -> assimilateSubTerms subterms unusedFeats + | not $ null knownParents -> do + $logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|] + (++) (matchingFeatures & traverse . _studyFeaturesSubField %~ (<|> Just subterm)) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures) + | otherwise -> do + $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|] + assimilateSubTerms subterms unusedFeats + $logDebugS "Campus" [st|Terms for “#{credsIdent}”: #{tshow (sts, fs')}|] (fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs' let @@ -3453,10 +3464,12 @@ upsertCampusUser ldapData Creds{..} = do . runConduitPure $ 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.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence) E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence) + E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence) unless candidatesRecorded $ do let @@ -3468,11 +3481,11 @@ upsertCampusUser ldapData Creds{..} = do let studySubTermParentCandidates' = do - (studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates + (StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates let studySubTermParentCandidateIncidence = studyTermCandidateIncidence return StudySubTermParentCandidate{..} studyTermStandaloneCandidates' = do - (studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates + (StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence return StudyTermStandaloneCandidate{..} insertMany_ studySubTermParentCandidates' diff --git a/src/Handler/Admin/StudyFeatures.hs b/src/Handler/Admin/StudyFeatures.hs index 99b657f99..b66884123 100644 --- a/src/Handler/Admin/StudyFeatures.hs +++ b/src/Handler/Admin/StudyFeatures.hs @@ -13,13 +13,10 @@ import qualified Data.Set as Set import qualified Data.Map as Map import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Utils as E -import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter, sqlFOJproj) +import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter) import qualified Handler.Utils.TermCandidates as Candidates -import qualified Data.Maybe as Maybe - -- BEGIN - Buttons needed only for StudyTermNameCandidateManagement data ButtonAdminStudyTerms @@ -51,49 +48,63 @@ postAdminFeaturesR = do } infConflicts <- case btnResult of 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 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 setSessionJson SessionNewStudyTerms newKeys + if | null infAccepted -> addMessageI Info MsgNoCandidatesInferred | otherwise -> addMessageI Success . MsgCandidatesInferred $ length infAccepted - return infConflicts - FormSuccess BtnCandidatesDeleteConflicts -> runDB $ do - confs <- Candidates.conflicts - incis <- Candidates.getIncidencesFor (bimap entityKey entityKey <$> confs) - deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)] - addMessageI Success $ MsgIncidencesDeleted $ length incis - return [] - FormSuccess BtnCandidatesDeleteAll -> runDB $ do - deleteWhere ([] :: [Filter StudyTermNameCandidate]) - addMessageI Success MsgAllIncidencesDeleted - Candidates.conflicts + redirect AdminFeaturesR + FormSuccess BtnCandidatesDeleteConflicts -> do + runDB $ do + confs <- Candidates.conflicts + incis <- Candidates.getIncidencesFor $ map entityKey confs + deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)] + deleteWhere [StudySubTermParentCandidateIncidence <-. (E.unValue <$> incis)] + deleteWhere [StudyTermStandaloneCandidateIncidence <-. (E.unValue <$> incis)] + addMessageI Success $ MsgIncidencesDeleted $ length incis + redirect AdminFeaturesR + FormSuccess BtnCandidatesDeleteAll -> do + runDB $ do + deleteWhere ([] :: [Filter StudyTermNameCandidate]) + deleteWhere ([] :: [Filter StudySubTermParentCandidate]) + deleteWhere ([] :: [Filter StudyTermStandaloneCandidate]) + addMessageI Success MsgAllIncidencesDeleted + redirect AdminFeaturesR _other -> runDB Candidates.conflicts newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms + badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms ( (degreeResult,degreeTable) , (studyTermsResult,studytermsTable) , ((), candidateTable) - , userSchools) <- runDB $ do + , userSchools + , ((), parentCandidateTable)) <- runDB $ do schools <- E.select . E.from $ \school -> do E.where_ . E.exists . E.from $ \schoolFunction -> E.where_ $ schoolFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId E.&&. schoolFunction E.^. UserFunctionUser E.==. E.val uid E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin return school - (,,,) + (,,,,) <$> mkDegreeTable <*> mkStudytermsTable (Set.fromList newStudyTermKeys) - (Set.fromList $ map (bimap entityKey entityKey) infConflicts) + (Set.fromList $ fromMaybe (map entityKey infConflicts) badStudyTermKeys) (Set.fromList schools) <*> mkCandidateTable <*> pure schools - - -- This needs to happen after calls to `dbTable` so they can short-circuit correctly - unless (null infConflicts) $ addMessageI Warning MsgStudyFeatureConflict + <*> mkParentCandidateTable let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text)) degreeResult' = degreeResult <&> getDBFormResult @@ -104,27 +115,30 @@ postAdminFeaturesR = do formResult degreeResult' $ \res -> do void . runDB $ Map.traverseWithKey updateDegree res 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)) - studyTermsResult' = studyTermsResult <&> Map.mapKeys (\(mbL, mbR) -> Maybe.fromJust $ fmap Left mbR <|> fmap Right mbL) . getDBFormResult - (\row -> ( row ^? (_dbrOutput . _1 . _Just . _entityVal . _studyTermsName . _Just <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsName . _Just) - , row ^? (_dbrOutput . _1 . _Just . _entityVal . _studyTermsShorthand . _Just <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsShorthand . _Just) + let studyTermsResult' :: FormResult (Map StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType)) + studyTermsResult' = studyTermsResult <&> getDBFormResult + (\row -> ( row ^? _dbrOutput . _1 . _entityVal . _studyTermsName . _Just + , row ^? _dbrOutput . _1 . _entityVal . _studyTermsShorthand . _Just , row ^. _dbrOutput . _3 - , row ^? _dbrOutput . _2 . _Just . _entityVal . _studySubTermsParent . _Just - , row ^? _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultDegree . _Just - , row ^? _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultType . _Just + , row ^. _dbrOutput . _2 . to (Set.map entityKey) + , row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree . _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 update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short, StudyTermsDefaultDegree =. guard degreeExists *> degree, StudyTermsDefaultType =. sType] + forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools] - updateStudyTerms (Left studySubTermsKey) (name,short,_schools,parent,_degree,_type) = do - parentExists <- fmap (fromMaybe False) . for parent $ fmap (is _Just) . get - update studySubTermsKey [StudySubTermsName =. name, StudySubTermsShorthand =. short, StudySubTermsParent =. guard parentExists *> parent] + + forM_ parents $ void . insertUnique . StudySubTerms studyTermsKey + deleteWhere [StudySubTermsChild ==. studyTermsKey, StudySubTermsParent /<-. Set.toList parents] formResult studyTermsResult' $ \res -> do void . runDB $ Map.traverseWithKey updateStudyTerms res addMessageI Success MsgStudyTermsChangeSuccess + redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text) siteLayoutMsg MsgAdminFeaturesHeading $ do setTitleI MsgAdminFeaturesHeading @@ -152,17 +166,36 @@ postAdminFeaturesR = do <$> mpopt checkBoxField "" (Just $ row ^. lensDefault) ) - termKeyCell :: Ord i - => Lens' a (Maybe StudyTermsId) - -> Getter (DBRow r) (Maybe StudyTermsId) + -- termKeyCell :: Ord i + -- => Lens' a (Maybe StudyTermsId) + -- -> Getter (DBRow r) (Maybe StudyTermsId) + -- -> Getter (DBRow r) i + -- -> DBRow r + -- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) + -- termKeyCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) + -- ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView)) + -- <$> mopt (intField & isoField (from _StudyTermsId)) "" (Just $ row ^. lensDefault) + -- ) + + parentsCell :: Ord i + => Lens' a (Set StudyTermsId) + -> Getter (DBRow r) (Set StudyTermsId) -> Getter (DBRow r) i -> DBRow r -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) - 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 lensRes lensDefault lensIndex = formCell id (return . view lensIndex) + ( \row mkUnique -> (\(res, fieldView) -> (set lensRes . Set.fromList <$> res, fvInput fieldView)) + <$> massInputList + (intField & isoField (from _StudyTermsId)) + (const "") + (Just . SomeRoute . (AdminFeaturesR :#:)) + (mkUnique ("parents" :: Text)) + "" + False + (Just . Set.toList $ row ^. lensDefault) + mempty ) - + degreeCell :: Ord i => Lens' a (Maybe StudyDegreeId) -> Getter (DBRow r) (Maybe StudyDegreeId) @@ -171,7 +204,7 @@ postAdminFeaturesR = do -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) degreeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView)) - <$> mopt (intField & isoField (from _StudyDegreeId)) "" (Just $ row ^. lensDefault) + <$> mopt degreeField "" (Just $ row ^. lensDefault) ) fieldTypeCell :: Ord i @@ -216,49 +249,50 @@ postAdminFeaturesR = do dbtCsvDecode = Nothing 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 newKeys badKeys' schools = + mkStudytermsTable :: Set StudyTermsId -> Set StudyTermsId -> Set (Entity School) -> DB (FormResult (DBFormResult StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTerms, Set (Entity StudyTerms), Set SchoolId))), Widget) + mkStudytermsTable newKeys badKeys schools = let dbtIdent = "admin-studyterms" :: Text dbtStyle = def - dbtSQLQuery :: E.SqlExpr (Maybe (Entity StudyTerms)) `E.FullOuterJoin` E.SqlExpr (Maybe (Entity StudySubTerms)) -> E.SqlQuery (E.SqlExpr (Maybe (Entity StudyTerms)), E.SqlExpr (Maybe (Entity StudySubTerms))) - dbtSQLQuery (studyTerms `E.FullOuterJoin` studySubTerms) = do - E.on $ studyTerms E.?. StudyTermsKey E.==. studySubTerms E.?. StudySubTermsKey - return (studyTerms, studySubTerms) - dbtRowKey (studyTerms `E.FullOuterJoin` studySubTerms) = (studyTerms E.?. StudyTermsKey, studySubTerms E.?. StudySubTermsKey) - dbtProj field = do - fieldSchools <- for (field ^. _dbrOutput . _1) $ \field' -> fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do + dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms)) + dbtSQLQuery = return + dbtRowKey = (E.^. StudyTermsKey) + dbtProj field@(view _dbrOutput -> Entity fId _) = do + fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do E.where_ . E.exists . E.from $ \schoolTerms -> E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId - E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val (field' ^. _entityKey) + E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools) return $ school E.^. SchoolId - 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 - [ sortable (Just "key") (i18nCell MsgGenericKey) (maybe mempty numCell . preview (_dbrOutput . _1 . _Just . _entityVal . _studyTermsKey)) - , sortable (Just "parent") (i18nCell MsgStudySubTermsParentKey) (termKeyCell _4 (pre $ _dbrOutput . _2 . _Just . _entityVal . _studySubTermsParent . _Just) _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 "isbad") (i18nCell MsgGenericHasConflict) (maybe mempty (isBadCell . flip Set.member badKeys) . preview (_dbrOutput . _1 . _Just . _entityVal . _studyTermsKey <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsKey)) - , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (singular $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsName <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsName) _dbrKey') - , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (singular $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsShorthand <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsShorthand) _dbrKey') - , sortable (Just "degree") (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _5 (pre $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultDegree . _Just) _dbrKey') - , sortable (Just "field-type") (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _6 (pre $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultType . _Just) _dbrKey') + [ sortable (Just "key") (i18nCell MsgGenericKey) (maybe mempty numCell . preview (_dbrOutput . _1 . _entityVal . _studyTermsKey)) + , sortable Nothing (i18nCell MsgStudySubTermsParentKey) (parentsCell _4 (_dbrOutput . _2 . to (Set.map entityKey)) _dbrKey') + , sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey)) + , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey)) + , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) _dbrKey') + , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) _dbrKey') + , sortable (Just "degree") (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _5 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree) _dbrKey') + , sortable (Just "field-type") (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _6 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultType) _dbrKey') , flip foldMap schools $ \(Entity ssh School{schoolName}) -> sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _3 . at ssh . _Maybe) _dbrKey') , dbRow ] dbtSorting = Map.fromList - [ ("key" , SortColumn $ \t -> E.maybe (querySubField t E.?. StudySubTermsKey) E.just $ queryField t E.?. StudyTermsKey) - , ("parent", SortColumn $ \t -> querySubField t E.?. StudySubTermsParent) - , ("isnew" , SortColumn $ \t -> queryField t E.?. StudyTermsKey `E.in_` E.valList (Just <$> Set.toList newKeys) - E.||. querySubField t E.?. StudySubTermsKey `E.in_` E.valList (Just <$> Set.toList newKeys) + [ ("key" , SortColumn $ queryField >>> (E.^. StudyTermsKey)) + -- , ("parent", SortColumn $ \t -> querySubField t E.?. StudySubTermsParent) + , ("isnew" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys)) ) - , ("isbad" , SortColumn $ \t -> queryField t E.?. StudyTermsKey `E.in_` E.valList (Just <$> Set.toList badKeys) - E.||. querySubField t E.?. StudySubTermsKey `E.in_` E.valList (Just <$> Set.toList badKeys) + , ("isbad" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList badKeys)) ) - , ("name" , SortColumn $ \t -> E.maybe (E.joinV $ querySubField t E.?. StudySubTermsName) E.just . E.joinV $ queryField t E.?. StudyTermsName) - , ("short" , SortColumn $ \t -> E.maybe (E.joinV $ querySubField t E.?. StudySubTermsShorthand) E.just . E.joinV $ queryField t E.?. StudyTermsShorthand) - , ("degree" , SortColumn $ \t -> queryField t E.?. StudyTermsDefaultDegree) - , ("field-type" , SortColumn $ \t -> queryField t E.?. StudyTermsDefaultType) + , ("name" , SortColumn $ queryField >>> (E.^. StudyTermsName)) + , ("short" , SortColumn $ queryField >>> (E.^. StudyTermsShorthand)) + , ("degree" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultDegree)) + , ("field-type" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultType)) ] dbtFilter = mempty dbtFilterUI = mempty @@ -270,13 +304,9 @@ postAdminFeaturesR = do dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing - queryField = $(sqlFOJproj 2 1) - querySubField = $(sqlFOJproj 2 2) - _dbrKey' :: Getter (DBRow (Maybe (Entity StudyTerms), Maybe (Entity StudySubTerms), Set SchoolId)) - (Maybe StudyTermsId, Maybe StudySubTermsId) - _dbrKey' = $(multifocusL 2) (_dbrOutput . _1 . applying (_Entity . _1)) (_dbrOutput . _2 . applying (_Entity . _1)) - - badKeys = Set.map (either unStudySubTermsKey unStudyTermsKey) badKeys' + queryField = id + _dbrKey' :: Getter (DBRow (Entity StudyTerms, _, _)) StudyTermsId + _dbrKey' = _dbrOutput . _1 . _entityKey in dbTable psValidator DBTable{..} mkCandidateTable = @@ -313,3 +343,43 @@ postAdminFeaturesR = do dbtCsvDecode = Nothing in dbTable psValidator DBTable{..} + mkParentCandidateTable = + let dbtIdent = "admin-termparentcandidate" :: Text + dbtStyle = def + dbtSQLQuery :: E.SqlExpr (Entity StudySubTermParentCandidate) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms)) + -> E.SqlQuery ( E.SqlExpr (Entity StudySubTermParentCandidate) + , E.SqlExpr (Maybe (Entity StudyTerms)) + , E.SqlExpr (Maybe (Entity StudyTerms)) + ) + dbtSQLQuery (candidate `E.LeftOuterJoin` parent `E.LeftOuterJoin` child) = do + E.on $ child E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateKey) + E.on $ parent E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateParent) + return (candidate, parent, child) + dbtRowKey = queryCandidate >>> (E.^. StudySubTermParentCandidateId) + dbtProj = return + dbtColonnade = dbColonnade $ mconcat + [ dbRow + , sortable (Just "child") (i18nCell MsgStudySubTermsChildKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey)) + , sortable 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{..} + diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index d64bd13e7..9d52233ed 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -26,10 +26,9 @@ countCourses :: (Num n, PersistField n) => (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Allocation) -> 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.&&. addWhere allocationCourse - return E.countRows queryAvailable :: Getter AllocationTableExpr (E.SqlExpr (E.Value Natural)) queryAvailable = queryAllocation . to (countCourses $ const E.true) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 8a39796fc..8e126e2bb 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -75,7 +75,7 @@ correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet lastEditQuery :: Database.Esqueleto.Internal.Language.From (E.SqlExpr (Entity SubmissionEdit)) => 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 return $ E.max_ $ edit E.^. SubmissionEditTime @@ -297,7 +297,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d ) , ( "submittors" , 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.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId 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 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 - return E.countRows return (submission, numSubmittors) -- prepare map let infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index f3f8de21b..b4e5b7f51 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -599,11 +599,10 @@ postCApplicationsR tid ssh csh = do E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation 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.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation) addWhere courseApplication - return E.countRows numApps' = numApps . const $ return () diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index b8fcf5748..9f5bc8c7f 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -371,7 +371,7 @@ getCourseNewR = do E.&&. user E.^. UserFunctionSchool E.==. course E.^. CourseSchool E.&&. user E.^. UserFunctionFunction E.==. E.val SchoolLecturer 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 return $ E.min_ $ edit E.^. CourseEditTime E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index a9075cee3..10192bdd5 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -61,9 +61,8 @@ colRegistered = sortable (Just "registered") (i18nCell MsgRegistered) type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School) 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 - return (E.countRows :: E.SqlExpr (E.Value Int)) course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool) course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index fc687713a..bda498e20 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -269,9 +269,7 @@ deregisterParticipant uid cid = do audit $ TransactionExamResultDeleted examResultExam uid E.delete . E.from $ \tutorialParticipant -> do - let tutorialCourse = E.sub_select . E.from $ \tutorial -> do - E.where_ $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial - return $ tutorial E.^. TutorialCourse + let tutorialCourse = E.subSelectForeign tutorialParticipant TutorialParticipantTutorial (E.^. TutorialCourse) E.where_ $ tutorialCourse E.==. E.val cid E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 39ec5b047..ccc97291f 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -37,9 +37,9 @@ getCShowR tid ssh csh = do E.&&. course E.^. CourseSchool E.==. E.val ssh 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 - 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 - return ( E.countRows :: E.SqlExpr (E.Value Int)) return (course,school E.^. SchoolName, numParticipants, participant) staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId @@ -146,9 +146,9 @@ getCShowR tid ssh csh = do Nothing -> mempty Just tutorialCapacity' -> sqlCell $ do 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 - return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) in return $ E.val tutorialCapacity' E.-. numParticipants return . toWidget $ tshow freeCapacity , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 6f3c7e6cc..3ba3d9801 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -301,12 +301,12 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) , single $ ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) , 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) return . E.max_ $ edit E.^. CourseUserNoteEditTime ) , 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.&&. tutorial E.^. TutorialCourse E.==. E.val cid E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index a5f49fb46..046d6c7f4 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -110,7 +110,7 @@ queryExamPart :: forall a. -> (E.SqlExpr (Entity ExamPart) -> E.SqlExpr (Maybe (Entity ExamPartResult)) -> E.SqlQuery (E.SqlExpr (E.Value a))) -> ExamUserTableExpr -> 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 lift $ do @@ -528,7 +528,7 @@ postEUsersR tid ssh csh examn = do , singletonMap "result" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) , 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 - E.sub_select . E.from $ \edit -> do + E.subSelectMaybe . E.from $ \edit -> do E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) return . E.max_ $ edit E.^. CourseUserNoteEditTime ] diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 9fd949692..ba3a8f68e 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -33,21 +33,19 @@ querySynchronised :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlE querySynchronised office = to . runReader $ do exam <- view queryExam 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_ $ Exam.examOfficeExamResultAuth office examResult E.where_ $ Exam.resultIsSynced office examResult - return E.countRows return synchronised queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural)) queryResults office = to . runReader $ do exam <- view queryExam 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_ $ Exam.examOfficeExamResultAuth office examResult - return E.countRows return results queryIsSynced :: UTCTime -> E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Bool)) diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 7608b1195..532326ec3 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -158,7 +158,7 @@ homeUpcomingExams uid = do startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight) E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now) 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.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now return $ E.min_ $ occ E.^. ExamOccurrenceStart diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 740ed670d..650d69d36 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -114,9 +114,9 @@ getMaterialListR tid ssh csh = do , dbtParams = def , dbtSQLQuery = \material -> do 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 - return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64)) return (material, filesNum) , dbtRowKey = (E.^. MaterialId) -- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr @@ -331,9 +331,9 @@ postMDelR tid ssh csh mnm = do { drRecords = Set.singleton $ entityKey matEnt , drGetInfo = \(material `E.InnerJoin` course) -> do 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 - return (E.countRows :: E.SqlExpr (E.Value Int64)) return (material,course,filecount) , drUnjoin = \(material `E.InnerJoin` _course) -> material , drRenderRecord = \(Entity _ Material{..}, Entity _ Course{..}, E.Value fileCount) -> do diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index d6de8d24e..4611c004e 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -359,10 +359,13 @@ makeProfileData (Entity uid User{..}) = do E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid 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.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId - E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId + E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId + E.||. studyfeat E.^. StudyFeaturesSubField E.==. E.just (studyterms E.^. StudyTermsId) + E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId return (studyfeat, studydegree, studyterms) --Tables (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen @@ -507,7 +510,7 @@ mkSubmissionTable = dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId 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.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid return . E.max_ $ subEdit E.^. SubmissionEditTime @@ -590,7 +593,7 @@ mkSubmissionGroupTable = dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId 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.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId 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) 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.&&. 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.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime) - return E.countRows dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index bc5c308d4..ff7cc41ea 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -201,7 +201,7 @@ getSheetListR tid ssh csh = do , sft /= SheetSolution || hasSolution , 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 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.^. CourseShorthand E.==. E.val csh 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 -- return . E.max_ $ sheetEdit E.^. SheetEditTime -- 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 (sheet E.^. SheetActiveFrom)] 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 return . E.min_ $ sheetEdit E.^. SheetEditTime 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 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 return . E.min_ $ sheetEdit E.^. SheetEditTime diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index abce61c63..f43384eac 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -43,9 +43,8 @@ getTermShowR = do termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64)) termData term = do -- 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 - return E.countRows return (term, courseCount) selectRep $ do provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData) diff --git a/src/Handler/Tutorial/Delete.hs b/src/Handler/Tutorial/Delete.hs index 58931f1aa..2fc9e8627 100644 --- a/src/Handler/Tutorial/Delete.hs +++ b/src/Handler/Tutorial/Delete.hs @@ -23,9 +23,8 @@ postTDeleteR tid ssh csh tutn = do , drUnjoin = \(_ `E.InnerJoin` tutorial) -> tutorial , drGetInfo = \(course `E.InnerJoin` tutorial) -> do 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 - return E.countRows return (course, tutorial, participants :: E.SqlExpr (E.Value Int)) , drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) -> return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (_{MsgParticipantsN ps})|] diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index 11d05bc00..11ae3dc41 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -22,9 +22,9 @@ getCTutorialListR tid ssh csh = do where dbtSQLQuery tutorial = do 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 - return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) return (tutorial, participants) dbtRowKey = (E.^. TutorialId) dbtProj = return . over (_dbrOutput . _2) E.unValue @@ -58,9 +58,10 @@ getCTutorialListR tid ssh csh = do dbtSorting = Map.fromList [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType ) , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName ) - , ("participants", SortColumn $ \tutorial -> E.sub_select . E.from $ \tutorialParticipant -> do - E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId - return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) + , ("participants", SortColumn $ \tutorial -> let participantCount :: E.SqlExpr (E.Value Int) + participantCount = E.subSelectCount . E.from $ \tutorialParticipant -> + E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId + in participantCount ) , ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity ) , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom ) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index c2d944690..a803af4df 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -439,10 +439,9 @@ deleteUser duid = do 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 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.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid - return E.countRows E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid E.&&. whereBuddies numBuddies return $ submission E.^. SubmissionId diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index ae9cffcb1..92ced534b 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/src/Handler/Utils/Allocation.hs @@ -91,12 +91,11 @@ computeAllocation allocId cRestr = do E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId 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_ . 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.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser - return E.countRows whenIsJust cRestr $ \restrSet -> E.where_ $ course E.^. CourseId `E.in_` E.valList (Set.toList restrSet) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 85467b5f7..c11514a07 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -353,6 +353,12 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName schoolFieldFor :: [SchoolId] -> Field Handler SchoolId 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) studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)? diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index c4230890b..99bd99691 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -274,6 +274,7 @@ sourceInvitations :: forall junction m backend. , MonadThrow m , PersistRecordBackend Invitation backend , HasPersistBackend backend + , PersistQueryRead backend ) => Key (InvitationFor junction) -> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) () @@ -293,6 +294,7 @@ sourceInvitationsF :: forall junction map m backend. , MonadThrow m , PersistRecordBackend Invitation backend , HasPersistBackend backend + , PersistQueryRead backend ) => Key (InvitationFor junction) -> ReaderT backend m map diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index 723461206..2d4c78c0f 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -58,9 +58,8 @@ sheetDeleteRoute drRecords = DeleteRoute , drGetInfo = \(sheet `E.InnerJoin` course `E.InnerJoin` school) -> do E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool 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 - return E.countRows 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) , drUnjoin = \(sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 62599a9c7..bbd194617 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -17,7 +17,7 @@ parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key) where Ldap.Attr key = ldapUserStudyFeatures -parseSubTermsSemester :: Text -> Either ParseError (StudySubTermsId, Int) +parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int) parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key) where Ldap.Attr key = ldapUserSubTermsSemester @@ -59,9 +59,9 @@ decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit' dVal c = fromEnum c - fromEnum '0' -pLMUTermsSemester :: Parser (StudySubTermsId, Int) +pLMUTermsSemester :: Parser (StudyTermsId, Int) pLMUTermsSemester = do - subTermsKey <- StudySubTermsKey' <$> pKey + subTermsKey <- StudyTermsKey' <$> pKey void $ char '$' semester <- decimal diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 694ba01e7..d9d093618 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -724,7 +724,7 @@ submissionDeleteRoute drRecords = DeleteRoute E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse 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 return . E.max_ $ submissionEdit E.^. SubmissionEditTime E.orderBy [E.desc lastEdit] diff --git a/src/Handler/Utils/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs index e31338dac..2726ee0e6 100644 --- a/src/Handler/Utils/TermCandidates.hs +++ b/src/Handler/Utils/TermCandidates.hs @@ -25,13 +25,12 @@ import qualified Data.Map as Map import qualified Database.Esqueleto as E -import Database.Esqueleto.Utils as E {-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-} 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) instance Exception FailedCandidateInference @@ -46,17 +45,19 @@ instance Exception FailedCandidateInference -- * list of problems, ie. StudyTerms that contradict observed incidences -- * list of redundants, i.e. redundant observed incidences -- * list of accepted, i.e. newly accepted key/name pairs -inferHandler :: Handler ([Either (Entity StudySubTerms) (Entity StudyTerms)],[TermCandidateIncidence],[Entity StudyTermNameCandidate],[(STKey,Text)]) -inferHandler = runDB $ inferAcc ([],[],[]) +inferHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],_,[(StudyTermsId,Text)]) +inferHandler = runDB $ inferAcc mempty where inferAcc (accAmbiguous, accRedundants, accAccepted) = - handle (\(FailedCandidateInference fails) -> (fails,accAmbiguous,accRedundants,accAccepted) <$ E.transactionUndo) $ do - (infAmbis, infReds,infAccs) <- inferStep + handle (\(FailedCandidateInference fails) -> (fails, accAmbiguous, accRedundants, accAccepted') <$ E.transactionUndo) $ do + (infAmbis, infReds, infAccs) <- inferStep if null infAccs - then return ([], accAmbiguous, infReds ++ accRedundants, accAccepted) + then return ([], accAmbiguous, infReds <> accRedundants, accAccepted') else do 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 ambiguous <- removeAmbiguous @@ -102,27 +103,30 @@ removeAmbiguous = do return ambiSet --- | remove known StudyTerm from candidates that have the _exact_ name, --- ie. if a candidate contains a known key, we remove it and its associated fullname --- only save if ambiguous candidates haven been removed -removeRedundant :: DB [Entity StudyTermNameCandidate] -removeRedundant = do - redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` (sterm `E.FullOuterJoin` ssubterm)) -> do - E.on E.true - E.on $ ( E.just (candidate E.^. StudyTermNameCandidateKey) E.==. sterm E.?. StudyTermsKey - E.&&. E.just (candidate E.^. StudyTermNameCandidateName) E.==. E.joinV (sterm E.?. StudyTermsName) - ) - E.||. ( E.just (candidate E.^. StudyTermNameCandidateKey) E.==. ssubterm E.?. StudySubTermsKey - 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. - forM_ redundants $ \Entity{entityVal=StudyTermNameCandidate{..}} -> - deleteWhere $ ( StudyTermNameCandidateIncidence ==. studyTermNameCandidateIncidence ) - : ([ StudyTermNameCandidateKey ==. studyTermNameCandidateKey ] - ||. [ StudyTermNameCandidateName ==. studyTermNameCandidateName ]) - return redundants +removeRedundant :: DB ([Entity StudyTermNameCandidate], [Entity StudySubTermParentCandidate], [Entity StudyTermStandaloneCandidate]) +removeRedundant = (,,) <$> removeRedundantNames <*> removeRedundantParents <*> removeRedundantStandalone + where + -- | remove known StudyTerm from candidates that have the _exact_ name, + -- ie. if a candidate contains a known key, we remove it and its associated fullname + -- only save if ambiguous candidates haven been removed + removeRedundantNames :: DB [Entity StudyTermNameCandidate] + removeRedundantNames = do + 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.^. StudyTermNameCandidateName) E.==. E.joinV (sterm E.?. StudyTermsName) + return candidate + -- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps. + forM_ redundants $ \Entity{entityVal=StudyTermNameCandidate{..}} -> + deleteWhere $ ( StudyTermNameCandidateIncidence ==. studyTermNameCandidateIncidence ) + : ([ StudyTermNameCandidateKey ==. studyTermNameCandidateKey ] + ||. [ 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. -- 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 = do knownKeys <- fmap unStudyTermsKey <$> selectKeysList [StudyTermsName !=. Nothing] [Asc StudyTermsKey] - knownSubKeys <- fmap unStudySubTermsKey <$> selectKeysList [StudySubTermsName !=. Nothing] [Asc StudySubTermsKey] -- let knownKeysSet = Set.fromAscList knownKeys -- 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 -- E.where_ $ candidate E.^. StudyTermCandidayeKey `E.notIn` E.valList knownKeys -- return candidate @@ -168,13 +171,8 @@ acceptSingletons = do -- registerFixed :: (STKey, Text) -> DB (Key StudyTerms) registerFixed :: (STKey, Text) -> DB () - registerFixed (key, name) = do - isSub <- is _Just <$> get (StudySubTermsKey' key) - if - | isSub - -> repsert (StudySubTermsKey' key) $ StudySubTerms key Nothing Nothing (Just name) - | otherwise - -> repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name) Nothing Nothing + registerFixed (key, name) = + repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name) Nothing Nothing -- register newly fixed candidates forM_ fixedKeys registerFixed @@ -182,31 +180,27 @@ acceptSingletons = do -- | all existing StudyTerms that are contradiced by current observations -conflicts :: DB [Either (Entity StudySubTerms) (Entity StudyTerms)] -conflicts = (++) <$> fmap (map Left) conflictingSubTerms <*> fmap (map Right) conflictingTerms - where - conflictingTerms = E.select $ E.from $ \studyTerms -> do - E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName - E.where_ $ E.exists $ E.from $ \candidateOne -> do - E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studyTerms E.^. StudyTermsKey - E.where_ $ E.notExists . E.from $ \candidateTwo -> do - E.where_ $ candidateTwo E.^. StudyTermNameCandidateIncidence E.==. candidateOne E.^. StudyTermNameCandidateIncidence - E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName) - return studyTerms - conflictingSubTerms = E.select $ E.from $ \studySubTerms -> do - E.where_ $ E.not_ $ E.isNothing $ studySubTerms E.^. StudySubTermsName - E.where_ $ E.exists $ E.from $ \candidateOne -> do - E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studySubTerms E.^. StudySubTermsKey - 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 +conflicts :: DB [Entity StudyTerms] +conflicts = E.select $ E.from $ \studyTerms -> do + E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName + E.where_ $ E.exists $ E.from $ \candidateOne -> do + E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studyTerms E.^. StudyTermsKey + E.where_ $ E.notExists . E.from $ \candidateTwo -> do + E.where_ $ candidateTwo E.^. StudyTermNameCandidateIncidence E.==. candidateOne E.^. StudyTermNameCandidateIncidence + E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName) + E.||. E.exists ( E.from $ \(pCandidate `E.LeftOuterJoin` termsTwo) -> do + E.on $ pCandidate E.^. StudySubTermParentCandidateParent E.==. studyTerms E.^. StudyTermsKey + E.&&. E.just (pCandidate E.^. StudySubTermParentCandidateKey) E.==. termsTwo E.?. StudyTermsKey + E.where_ $ E.joinV (termsTwo E.?. StudyTermsName) E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName) + E.||. E.isNothing (E.joinV $ termsTwo E.?. StudyTermsName) + ) + return studyTerms -- | 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 E.where_ $ candidate E.^. StudyTermNameCandidateKey `E.in_` E.valList stks' return $ candidate E.^. StudyTermNameCandidateIncidence where - stks' = stks <&> either unStudySubTermsKey unStudyTermsKey + stks' = stks <&> unStudyTermsKey diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs index 30fc48c25..20e816c26 100644 --- a/src/Jobs/Handler/SendNotification/Allocation.hs +++ b/src/Jobs/Handler/SendNotification/Allocation.hs @@ -86,11 +86,10 @@ dispatchNotificationAllocationUnratedApplications nAllocation jRecipient = do let 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.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) E.&&. E.isNothing (application E.^. CourseApplicationRatingTime) - return E.countRows return ( course E.^. CourseTerm , course E.^. CourseSchool @@ -128,11 +127,10 @@ dispatchNotificationAllocationOutdatedRatings nAllocation jRecipient = do let 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.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) E.&&. E.maybe E.false (E.<. application E.^. CourseApplicationTime) (application E.^. CourseApplicationRatingTime) - return E.countRows return ( course E.^. CourseTerm , course E.^. CourseSchool @@ -170,13 +168,13 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId 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.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation) - return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64)) - let participantCount = E.sub_select . E.from $ \participant -> do + let participantCount :: E.SqlExpr (E.Value Int64) + participantCount = E.subSelectCount . E.from $ \participant -> E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse - return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64)) return (course, allocatedCount, participantCount) let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, E.Value allocCount, E.Value partCount) -> SomeMessage $ if | allocCount == partCount -> MsgAllocationResultLecturerAll courseShorthand allocCount diff --git a/src/Model.hs b/src/Model.hs index 5e049e254..f59815c79 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-} module Model ( module Model diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index f75aa2ef5..dde364c03 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UndecidableInstances #-} + module Model.Migration ( migrateAll , requiresMigration @@ -585,6 +587,10 @@ customMigrations = Map.fromListWith (>>) 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" + ) ] diff --git a/src/Utils.hs b/src/Utils.hs index d1e1373e1..ddfb60acd 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -728,7 +728,7 @@ choice = foldr (<|>) empty -------------- data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags - | SessionNewStudyTerms + | SessionNewStudyTerms | SessionConflictingStudyTerms | SessionBearer deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe SessionKey diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 3364c924a..e64bc46a7 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -150,6 +150,8 @@ makePrisms ''AuthResult makePrisms ''FormResult makeLenses_ ''StudyTermNameCandidate +makeLenses_ ''StudySubTermParentCandidate +makeLenses_ ''StudyTermStandaloneCandidate makeLenses_ ''FieldView makeLenses_ ''FieldSettings diff --git a/stack.yaml b/stack.yaml index a5abb45dd..a1cd45876 100644 --- a/stack.yaml +++ b/stack.yaml @@ -39,7 +39,11 @@ extra-deps: - directory-1.3.4.0 - 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 - sandi-0.5 diff --git a/templates/adminFeatures.hamlet b/templates/adminFeatures.hamlet index 5a6dc40d0..7a81e3a55 100644 --- a/templates/adminFeatures.hamlet +++ b/templates/adminFeatures.hamlet @@ -1,25 +1,30 @@ $newline never
+

+ _{MsgStudyFeaturesDegrees} ^{degreeTable}
+

+ _{MsgStudyFeaturesTerms} ^{studytermsTable}
-

_{MsgStudyFeatureInference} - $if null infConflicts -

- $if null infConflicts - _{MsgStudyFeatureInferenceNoConflicts} - $else -

_{MsgStudyFeatureInferenceConflictsHeading} -
    - $forall conflict <- infConflicts -
  • - $case conflict - $of Right (Entity _ (StudyTerms ky _ nm _ _)) - #{show ky} - #{foldMap id nm} - $of Left (Entity _ (StudySubTerms ky _ _ nm)) - #{show ky} - #{foldMap id nm} - ^{btnForm} - -
    - ^{candidateTable} +

    + _{MsgStudyFeaturesNameCandidates} + ^{candidateTable} +
    +

    + _{MsgStudyFeaturesParentCandidates} + ^{parentCandidateTable} +
    +

    + _{MsgStudyFeatureInference} +

    + $if null infConflicts + _{MsgStudyFeatureInferenceNoConflicts} + $else +

    _{MsgStudyFeatureInferenceConflictsHeading} +
      + $forall Entity _ (StudyTerms ky _ nm _ _) <- infConflicts +
    • + #{show ky} - #{foldMap id nm} + ^{btnForm}