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

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

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

2
models/exams.model
View File

@ -64,5 +64,5 @@ ExamCorrector
UniqueExamCorrector exam user
ExamPartCorrector
part ExamPartId
corrector ExamCorrector
corrector ExamCorrectorId
UniqueExamPartCorrector part corrector

17
models/users.model
View File

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

2
package.yaml
View File

@ -68,7 +68,7 @@ dependencies:
- cereal
- mtl
- sandi
- esqueleto
- esqueleto >=3.1.0
- mime-types
- generic-deriving
- blaze-html

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

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

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
(==) = (==) `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
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'

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 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{..}

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

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

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.&&. 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 ()

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.^. 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

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

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

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

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.^. 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

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 $ ("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

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

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

2
src/Handler/Home.hs
View File

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

8
src/Handler/Material.hs
View File

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

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

8
src/Handler/Sheet.hs
View File

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

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

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

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

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

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

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

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.&&. 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)

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

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

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

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

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

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

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

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

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

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

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

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

2
src/Model.hs
View File

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

6
src/Model/Migration.hs
View File

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

2
src/Utils.hs
View File

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

2
src/Utils/Lens.hs
View File

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

6
stack.yaml
View File

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

43
templates/adminFeatures.hamlet
View File

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