Merge branch 'fix/sub-study-terms'

messages/uniworx/de-de-formal.msg

@@ -17,9 +17,13 @@ BtnHijack: Sitzung übernehmen
 BtnSave: Speichern
 PressSaveToSave: Änderungen werden erst durch Drücken des Knopfes "Speichern" gespeichert.
 BtnHandIn: Abgeben
-BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
+BtnNameCandidatesInfer: Studienfach-Namens-Zuordnung automatisch lernen
-BtnCandidatesDeleteConflicts: Konflikte löschen
+BtnNameCandidatesDeleteConflicts: Namenskonflikte löschen
-BtnCandidatesDeleteAll: Alle Beobachtungen löschen
+BtnNameCandidatesDeleteAll: Alle Namens-Beobachtungen löschen
+BtnParentCandidatesInfer: Unterstudiengangs-Zuordnung automatisch lernen
+BtnParentCandidatesDeleteAll: Alle Unterstudiengangs-Beobachtungen löschen
+BtnStandaloneCandidatesDeleteAll: Alle Einzelstudiengangs-Beobachtungen löschen
+BtnStandaloneCandidatesDeleteRedundant: Redundante Einzelstudiengangs-Beobachtungen löschen
 BtnResetTokens: Authorisierungs-Tokens invalidieren
 BtnLecInvAccept: Annehmen
 BtnLecInvDecline: Ablehnen
@@ -761,9 +765,15 @@ AdminFeaturesHeading: Studiengänge
 StudyTerms: Studiengänge
 StudyTerm: Studiengang
 NoStudyTermsKnown: Keine Studiengänge bekannt
-StudyFeatureInference: Studiengangschlüssel-Inferenz
+StudyFeaturesDegrees: Abschlüsse
-StudyFeatureInferenceNoConflicts: Keine Konflikte beobachtet
+StudyFeaturesTerms: Studiengänge
-StudyFeatureInferenceConflictsHeading: Studiengangseinträge mit beobachteten Konflikten
+StudyFeaturesNameCandidates: Namens-Kandidaten
+StudyFeaturesParentCandidates: Kandidaten für Unterstudiengänge
+StudyFeaturesStandaloneCandidates: Kandidaten für Einzelstudiengänge
+StudyFeatureNameInference: Studiengangschlüssel-Inferenz
+StudyFeatureParentInference: Unterstudiengang-Inferenz
+StudyFeatureInferenceNoNameConflicts: Keine Konflikte beobachtet
+StudyFeatureInferenceNameConflictsHeading: Studiengangseinträge mit beobachteten Konflikten
 StudyFeatureAge: Fachsemester
 StudyFeatureDegree: Abschluss
 FieldPrimary: Hauptfach
@@ -784,11 +794,17 @@ StudyTermsShort: Studiengangkürzel
 StudyTermsChangeSuccess: Zuordnung Studiengänge aktualisiert
 StudyDegreeChangeSuccess: Zuordnung Abschlüsse aktualisiert
 StudyCandidateIncidence: Synchronisation
-AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt
+AmbiguousNameCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt
-RedundantCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Kandidat" "bekannte Kandiaten"} entfernt
+RedundantNameCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Namenskandidat" "bekannte Namenskandiaten"} entfernt
-CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
+RedundantParentCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Elternkandidat" "bekannte Elternkandiaten"} entfernt
-NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
+RedundantStandaloneCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Einzelstudiengangskandidat" "bekannte Einzelstudiengangskandiaten"} entfernt
-AllIncidencesDeleted: Alle Beobachtungen wurden gelöscht.
+NameCandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
+NoNameCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
+ParentCandidatesInferred n@Int: #{show n} #{pluralDE n "neuer Unterstudiengang" "neue Unterstudiengänge"} inferiert
+NoParentCandidatesInferred: Keine neuen Unterstudiengänge inferiert
+AllNameIncidencesDeleted: Alle Namens-Beobachtungen wurden gelöscht.
+AllParentIncidencesDeleted: Alle Unterstudiengang-Beobachtungen wurden gelöscht.
+AllStandaloneIncidencesDeleted: Alle Einzelstudiengang-Beobachtungen wurden gelöscht.
 IncidencesDeleted n@Int: #{show n} #{pluralDE n "Beobachtung" "Beobachtungen"} gelöscht
 StudyTermIsNew: Neu
 StudyFeatureConflict: Es wurden Konflikte in der Studiengang-Zuordnung gefunden
@@ -2077,6 +2093,13 @@ 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
+
 MenuLanguage: Sprache
 LanguageChanged: Sprache erfolgreich geändert
 

messages/uniworx/en-eu.msg

@@ -17,9 +17,13 @@ BtnHijack: Hijack session
 BtnSave: Save
 PressSaveToSave: Changes will only be saved after clicking "Save".
 BtnHandIn: Hand in submission
-BtnCandidatesInfer: Infer mapping
+BtnNameCandidatesInfer: Infer name-mapping
-BtnCandidatesDeleteConflicts: Delete conflicts
+BtnNameCandidatesDeleteConflicts: Delete name-conflicts
-BtnCandidatesDeleteAll: Delete all observations
+BtnNameCandidatesDeleteAll: Delete all name-observations
+BtnParentCandidatesInfer: Infer parent-relation
+BtnParentCandidatesDeleteAll: Delete all parent-observations
+BtnStandaloneCandidatesDeleteAll: Delete all standalone-observations
+BtnStandaloneCandidatesDeleteRedundant: Delete redundant standalone-observations
 BtnResetTokens: Invalidate tokens
 BtnLecInvAccept: Accept
 BtnLecInvDecline: Decline
@@ -384,6 +388,8 @@ UnauthorizedTokenNotStarted: Your authorisation-token is not yet valid.
 UnauthorizedTokenInvalid: Your authorisation-token could not be processed.
 UnauthorizedTokenInvalidRoute: Your authorisation-token is not valid for this page.
 UnauthorizedTokenInvalidAuthority: Your authorisation-token is based in an user's rights who does not exist anymore.
+UnauthorizedTokenInvalidAuthorityGroup: Your authorisation-token is based in an user groups rights which does not exist anymore.
+UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which your authorisation-token is based, could not be interpreted.
 UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages.
 UnauthorizedSiteAdmin: You are no system-wide administrator.
 UnauthorizedSchoolAdmin: You are no administrator for this department.
@@ -756,9 +762,15 @@ AdminFeaturesHeading: Features of study
 StudyTerms: Fields of study
 StudyTerm: Field of study
 NoStudyTermsKnown: No known features of study
-StudyFeatureInference: Infer field of study mapping
+StudyFeaturesDegrees: Degrees
-StudyFeatureInferenceNoConflicts: No observed conflicts
+StudyFeaturesTerms: Terms of Study
-StudyFeatureInferenceConflictsHeading: Fields of study with observed conflicts
+StudyFeaturesNameCandidates: Name candidates
+StudyFeaturesParentCandidates: Parent candidates
+StudyFeaturesStandaloneCandidates: Standalone candidates
+StudyFeatureNameInference: Infer field of study mapping
+StudyFeatureParentInference: Infer field of study parent relation
+StudyFeatureInferenceNoNameConflicts: No observed conflicts
+StudyFeatureInferenceNameConflictsHeading: Fields of study with observed conflicts
 StudyFeatureAge: Semester
 StudyFeatureDegree: Degree
 FieldPrimary: Major
@@ -779,11 +791,17 @@ StudyTermsShort: Field shorthand
 StudyTermsChangeSuccess: Successfully updated fields of study
 StudyDegreeChangeSuccess: Successfully updated degrees
 StudyCandidateIncidence: Synchronisation
-AmbiguousCandidatesRemoved n: Successfully removed #{n} ambiguous #{pluralEN n "candidate" "candidates"}
+AmbiguousNameCandidatesRemoved n: Successfully removed #{n} ambiguous #{pluralEN n "candidate" "candidates"}
-RedundantCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "candidate" "candidates"}
+RedundantNameCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "name-candidate" "name-candidates"}
-CandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "mapping" "mappings"}
+RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "parent-candidate" "parent-candidates"}
-NoCandidatesInferred: No new mappings inferred
+RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "standalone-candidate" "standalone-candidates"}
-AllIncidencesDeleted: Successfully deleted all observations
+NameCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "mapping" "mappings"}
+NoNameCandidatesInferred: No new name-mappings inferred
+AllNameIncidencesDeleted: Successfully deleted all name observations
+AllParentIncidencesDeleted: Successfully deleted all parent-relation observations
+AllStandaloneIncidencesDeleted: Successfully deleted all standalone observations
+ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "parent-relation" "parent-reliations"}
+NoParentCandidatesInferred: No new parent-relations inferred
 IncidencesDeleted n: Successfully deleted #{show n} #{pluralEN n "observation" "observations"}
 StudyTermIsNew: New
 StudyFeatureConflict: Observed conflicts in field mapping
@@ -2070,6 +2088,12 @@ 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
 
 MenuLanguage: Language
 LanguageChanged: Language changed successfully

models/exams.model

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

models/users.model

@@ -55,11 +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      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 Show
     -- UniqueUserSubject ubuser degree field -- There exists a counterexample
 StudyDegree   -- Studienabschluss
     key           Int            -- LMU-internal key
@@ -67,22 +69,37 @@ 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            -- LMU-internal key
+    key           Int            -- standardised key
     shorthand     Text Maybe     -- admin determined shorthand
     name          Text Maybe     -- description given by LDAP
+    defaultDegree StudyDegreeId Maybe
+    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
-StudyTermCandidate    -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms.
+StudySubTerms
+    child         StudyTermsId
+    parent        StudyTermsId
+    UniqueStudySubTerms child parent
+StudyTermNameCandidate    -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms.
     -- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence.
     -- This table helps us to infer which key belongs to which plain text by recording possible combinations at login.
     -- If a login provides n keys and n plan texts, then n^2 rows with the same incidence are created, storing all combinations
     incidence     TermCandidateIncidence -- random id, generated once per login to associate matching pairs
-    key           Int      -- a possible key for the studyTermName
+    key           Int      -- a possible key for the studyTermName or studySubTermName
     name          Text     -- studyTermName as plain text from LDAP
     deriving Show Eq Ord
+StudySubTermParentCandidate
+    incidence     TermCandidateIncidence
+    key           Int
+    parent        Int
+    deriving Show Eq Ord
+StudyTermStandaloneCandidate
+    incidence     TermCandidateIncidence
+    key           Int
+    deriving Show Eq Ord
 
 UserGroupMember
     group         UserGroupName

package.yaml

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

src/Auth/LDAP.hs

@@ -7,7 +7,7 @@ module Auth.LDAP
   , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
   , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
   , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
-  , ldapUserSchoolAssociation, ldapSex
+  , ldapUserSchoolAssociation, ldapUserSubTermsSemester, ldapSex
   ) where
 
 import Import.NoFoundation
@@ -62,7 +62,7 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not
       , Ldap.derefAliases Ldap.DerefAlways
       ]
 
-ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex :: Ldap.Attr
+ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester :: Ldap.Attr
 ldapUserPrincipalName     = Ldap.Attr "userPrincipalName"
 ldapUserDisplayName       = Ldap.Attr "displayName"
 ldapUserMatriculation     = Ldap.Attr "LMU-Stud-Matrikelnummer"
@@ -70,9 +70,10 @@ ldapUserFirstName         = Ldap.Attr "givenName"
 ldapUserSurname           = Ldap.Attr "sn"
 ldapUserTitle             = Ldap.Attr "title"
 ldapUserStudyFeatures     = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
-ldapUserFieldName         = Ldap.Attr "dfnEduPersonFieldOfStudyString" 
+ldapUserFieldName         = Ldap.Attr "LMU-Stg-Fach" 
 ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" 
 ldapSex                   = Ldap.Attr "schacGender"
+ldapUserSubTermsSemester  = Ldap.Attr "LMU-Stg-FachundFS"
 
 ldapUserEmail :: NonEmpty Ldap.Attr
 ldapUserEmail = Ldap.Attr "mail" :|

src/Database/Esqueleto/Utils.hs

@@ -20,6 +20,7 @@ module Database.Esqueleto.Utils
   , maybe
   , SqlProject(..)
   , (->.)
+  , fromSqlKey
   , module Database.Esqueleto.Utils.TH
   ) where
 
@@ -250,3 +251,6 @@ instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.E
 
 (->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
 (->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t
+
+fromSqlKey :: (ToBackendKey SqlBackend entity, PersistField (Key entity)) => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value Int64)
+fromSqlKey = E.veryUnsafeCoerceSqlExprValue

src/Database/Esqueleto/Utils/TH.hs

@@ -1,8 +1,10 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 module Database.Esqueleto.Utils.TH
   ( SqlIn(..)
   , sqlInTuple, sqlInTuples
   , unValueN, unValueNIs
-  , sqlIJproj, sqlLOJproj
+  , sqlIJproj, sqlLOJproj, sqlFOJproj
   ) where
 
 import ClassyPrelude
@@ -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
+instance SqlEq a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
-  x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs)
+  sqlIn x = foldr (\x' e -> e E.||. sqlEq (E.val $ E.unValue x') x) (E.val False)
+
+class PersistField a => SqlEq a where
+  sqlEq :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Bool)
+
+instance {-# OVERLAPPABLE #-} PersistField a => SqlEq a where
+  sqlEq = (E.==.)
+
+instance PersistField a => SqlEq (Maybe a) where
+  sqlEq a b = (E.isNothing a E.&&. E.isNothing b) E.||. a E.==. b
 
 sqlInTuples :: [Int] -> DecsQ
 sqlInTuples = 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
@@ -84,3 +95,6 @@ sqlIJproj = leftAssociativePairProjection 'E.InnerJoin
 
 sqlLOJproj :: Int -> Int -> ExpQ
 sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin
+
+sqlFOJproj :: Int -> Int -> ExpQ
+sqlFOJproj = leftAssociativePairProjection 'E.FullOuterJoin

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

src/Foundation.hs

@@ -47,6 +47,7 @@ import qualified Data.Map as Map
 import qualified Data.HashSet as HashSet
 
 import Data.List (nubBy, (!!), findIndex, inits)
+import qualified Data.List as List
 
 import Web.Cookie
 
@@ -3390,36 +3391,113 @@ upsertCampusUser ldapData Creds{..} = do
       Right str <- return $ Text.decodeUtf8' v'
       return str
 
-  fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
+    userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester
+    userSubTermsSemesters' = do
+      (k, v) <- ldapData
+      guard $ k == ldapUserSubTermsSemester
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+
+  fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
+  sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters
 
   let
     studyTermCandidates = Set.fromList $ do
-      name <- termNames
+      let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs'
-      StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
+          subTermsKeys = unStudyTermsKey . fst <$> sts
-      return (key, name)
+
+      (,) <$> sfKeys ++ subTermsKeys <*> termNames
+
+  let
+    assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) DB [StudyFeatures]
+    assimilateSubTerms [] xs = return xs
+    assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do
+      standalone <- lift $ get subterm
+      case standalone of
+        _other
+          | (match : matches, unusedFeats') <- partition
+              (\StudyFeatures{..} -> subterm     == studyFeaturesField
+                                  && subSemester == studyFeaturesSemester
+              ) unusedFeats
+            -> do
+              $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|]
+              (:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats')
+          | any ((== subterm) . studyFeaturesField) unusedFeats
+            -> do
+              $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|]
+              assimilateSubTerms subterms unusedFeats
+        Just StudyTerms{..}
+          | Just defDegree <- studyTermsDefaultDegree
+          , Just defType   <- studyTermsDefaultType
+            -> do
+              $logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|]
+              (:) (StudyFeatures userId defDegree subterm Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats
+        Nothing
+          | [] <- unusedFeats -> do
+              $logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|]
+              tell $ Set.singleton (subterm, Nothing)
+              assimilateSubTerms subterms []
+        _other -> do
+          knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
+          let matchingFeatures = case knownParents of
+                []      -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
+                ps      -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> any (== studyFeaturesField) ps && studyFeaturesSemester == subSemester) unusedFeats
+          when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
+            tell $ Set.singleton (subterm, Just studyFeaturesField)
+          if
+            | not $ null knownParents -> do
+                $logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|]
+                (++) (matchingFeatures & traverse . _studyFeaturesSubField %~ (<|> Just subterm)) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures)
+            | otherwise -> do
+                $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|]
+                assimilateSubTerms subterms unusedFeats
+  $logDebugS "Campus" [st|Terms for “#{credsIdent}”: #{tshow (sts, fs')}|]
+  (fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs'
+
+  let
     studyTermCandidateIncidence
       = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
       . UUID.fromByteString
       . fromStrict
       . (convert :: Digest (SHAKE128 128) -> ByteString)
       . runConduitPure
-      $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) .| sinkHash
+      $ sourceList ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash
 
-  candidatesRecorded <- E.selectExists . E.from $ \candidate ->
+  candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do
-    E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
+    E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence
+    E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence
+    E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
+         E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
+         E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
 
   unless candidatesRecorded $ do
     let
       studyTermCandidates' = do
-        (studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
+        (studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates
-        return StudyTermCandidate{..}
+        let studyTermNameCandidateIncidence = studyTermCandidateIncidence
+        return StudyTermNameCandidate{..}
     insertMany_ studyTermCandidates'
 
+    let
+      studySubTermParentCandidates' = do
+        (StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates
+        let studySubTermParentCandidateIncidence = studyTermCandidateIncidence
+        return StudySubTermParentCandidate{..}
+    insertMany_ studySubTermParentCandidates'
+
+    let
+      studyTermStandaloneCandidates' = do
+        (StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates
+        let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence
+        return StudyTermStandaloneCandidate{..}
+    insertMany_ studyTermStandaloneCandidates'
+
   E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
   forM_ fs $ \f@StudyFeatures{..} -> do
     insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
-    insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
+    insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
-    void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
+    void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True, StudyFeaturesSubField =. studyFeaturesSubField]
   associateUserSchoolsByTerms userId
 
   let

src/Handler/Admin.hs

@@ -1,507 +1,18 @@
-module Handler.Admin where
+module Handler.Admin
+  ( module Handler.Admin
+  ) where
 
 import Import
+
 import Handler.Utils
-import Jobs
-import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
 
-import Control.Monad.Trans.Except
+import Handler.Admin.Test as Handler.Admin
-import Control.Monad.Trans.Writer (mapWriterT)
+import Handler.Admin.ErrorMessage as Handler.Admin
-
+import Handler.Admin.StudyFeatures as Handler.Admin
--- import Data.Time
-import Data.Char (isDigit)
-import qualified Data.Text as Text
--- import Data.Function ((&))
--- import Yesod.Form.Bootstrap3
-
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-
-import Database.Persist.Sql (fromSqlKey)
-import qualified Database.Esqueleto as E
-import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
-
-import qualified Handler.Utils.TermCandidates as Candidates
-
--- import Colonnade hiding (fromMaybe)
--- import Yesod.Colonnade
-
--- import qualified Data.UUID.Cryptographic as UUID
 
 
 getAdminR :: Handler Html
-getAdminR = -- do
+getAdminR =
    siteLayoutMsg MsgAdminHeading $ do
       setTitleI MsgAdminHeading
       i18n MsgAdminPageEmpty
-
--- BEGIN - Buttons needed only here
-data ButtonCreate = CreateMath | CreateInf  -- Dummy for Example
-  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-instance Universe ButtonCreate
-instance Finite ButtonCreate
-
-nullaryPathPiece ''ButtonCreate camelToPathPiece
-
-instance Button UniWorX ButtonCreate where
-  btnLabel CreateMath = [whamlet|Ma<i>thema</i>tik|]
-  btnLabel CreateInf  = "Informatik"
-
-  btnClasses CreateMath = [BCIsButton, BCInfo]
-  btnClasses CreateInf  = [BCIsButton, BCPrimary]
--- END Button needed only here
-
-emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext)
-emailTestForm = (,)
-            <$> areq emailField (fslI MsgMailTestFormEmail) Nothing
-            <*> ( MailContext
-                  <$> (Languages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
-                  <*> (toMailDateTimeFormat
-                        <$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
-                        <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
-                        <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
-                      )
-                )
-  where
-    toMailDateTimeFormat dt d t = \case
-      SelFormatDateTime -> dt
-      SelFormatDate -> d
-      SelFormatTime -> t
-
-makeDemoForm :: Int -> Form (Int,Bool,Double)
-makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
-    (result, widget) <- flip (renderAForm FormStandard) html $ (,,)
-        <$> areq (minIntFieldI n ("Zahl" :: Text)) (fromString $ "Ganzzahl > " ++ show n) Nothing
-        <*  aformSection MsgFormBehaviour
-        <*> areq checkBoxField "Muss nächste Zahl größer sein?" (Just True)
-        <*> areq doubleField "Fliesskommazahl" Nothing
-        -- NO LONGER DESIRED IN AFORMS:
-        -- <*  submitButton
-    return $ case result of
-      FormSuccess fsres
-        | errorMsgs <- validateResult fsres
-        , not $ null errorMsgs -> (FormFailure errorMsgs, widget)
-      _otherwise -> (result, widget)
-  where
-    validateResult :: (Int,Bool,Double) -> [Text]
-    validateResult (i,True,d) | fromIntegral i >= d = [tshow d <> " ist nicht größer als " <> tshow i, "Zweite Fehlermeldung", "Dritte Fehlermeldung"]
-    validateResult _other = []
-
-
-getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
-getAdminTestR = postAdminTestR
-postAdminTestR = do
-  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate)
-  let btnForm = wrapForm btnWdgt def
-        { formAction = Just $ SomeRoute AdminTestR
-        , formEncoding = btnEnctype
-        , formSubmit = FormNoSubmit
-        }
-  case btnResult of
-    (FormSuccess CreateInf)  -> addMessage Info "Informatik-Knopf gedrückt"
-    (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
-    FormMissing -> return ()
-    _other -> addMessage Warning "KEIN Knopf erkannt"
-
-  ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
-  formResultModal emailResult AdminTestR $ \(email, ls) -> do
-    jId <- mapWriterT runDB $ do
-      jId <- queueJob $ JobSendTestEmail email ls
-      tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
-      return jId
-    runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
-    addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`
-
-  let emailWidget' = wrapForm emailWidget def
-        { formAction = Just . SomeRoute $ AdminTestR
-        , formEncoding = emailEnctype
-        , formAttrs = [("uw-async-form", "")]
-        }
-
-
-  let demoFormAction (_i,_b,_d) = addMessage Info "All ok."
-  ((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7
-  formResult demoResult demoFormAction
-  let showDemoResult = [whamlet|
-          $maybe (i,b,d) <- formResult' demoResult
-            Received values:
-              <ul>
-                <li>#{show i}
-                <li>#{show b}
-                <li>#{show d}
-          $nothing
-            No form values received, due to #
-            $# Using formResult' above means that we usually to not distinguish the following two cases here, sind formResult does this already:
-            $case demoResult
-              $of FormSuccess _
-                $# Already dealt with above, to showecase usage of formResult' as normally done.
-                success, which should not happen here.
-              $of FormMissing
-                Form data missing, probably empty.
-              $of FormFailure msgs
-                <ul>
-                  $forall m <- msgs
-                    <li>#{m}
-        |]
-  let testTooltipMsg = toWidget [whamlet| So sehen aktuell Tooltips via iconTooltip aus. |] :: WidgetFor UniWorX ()
-
-  msgInfoTooltip    <- messageI Info ("Info-Tooltip via messageI" :: Text)
-  msgSuccessTooltip <- messageI Success ("Success-Tooltip via messageI" :: Text)
-  msgWarningTooltip <- messageI Warning ("Warning-Tooltip via messageI" :: Text)
-  msgErrorTooltip   <- messageI Error ("Error-Tooltip via messageI" :: Text)
-
-  msgNonDefaultIconTooltip <- messageIconI Info IconEmail ("Info-Tooltip mit lustigem Icon" :: Text)
-
-  {- The following demonstrates the use of @massInput@.
-
-     @massInput@ takes as arguments:
-       - A configuration struct describing how the Widget should behave (how is the space of sub-forms structured, how many dimensions does it have, which additions/deletions are permitted, what data do they need to operate and what should their effect on the overall shape be?)
-       - Information on how the resulting field fits into the form as a whole (@FieldSettings@ and whether the @massInput@ should be marked required)
-       - An initial value to pre-fill the field with
-
-     @massInput@ then returns an @MForm@ structured for easy downstream consumption of the result
-   -}
-  let
-    -- We define the fields of the configuration struct @MassInput@:
-
-    -- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell)
-    --
-    -- This /needs/ to replace all occurrences of @mreq@ with @mpreq@ (no fields should be /actually/ required)
-    mkAddForm :: ListPosition -- ^ Approximate position of the add-widget
-              -> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
-              -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
-              -> FieldView UniWorX -- ^ Submit-Button for this add-widget
-              -> Maybe (Form (Map ListPosition Int -> FormResult (Map ListPosition Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cells and data needed to initialize cells
-    mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do
-      (addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration
-      let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done
-          addRes'' = addRes' <&> \dat prev -> FormSuccess (Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) dat) -- Construct the callback to determine new cell positions and data within @FormResult@ as required, nested @FormResult@ allows aborting the add depending on previous data
-      return (addRes'', toWidget csrf >> fvInput addView >> fvInput submitBtn)
-    mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"
-
-    -- | Make a single massInput-Cell
-    --
-    -- This /needs/ to use @nudge@ and deterministic field naming (this allows for correct value-shifting when cells are deleted)
-    mkCellForm :: ListPosition -- ^ Position of this cell
-               -> Int -- ^ Data needed to initialize the cell (see return of @mkAddForm@)
-               -> Maybe Int -- ^ Initial cell result from Argument to `massInput`
-               -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
-               -> Form Int
-    mkCellForm _pos cData initial nudge csrf = do -- Extremely simple cell
-      (intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData
-      return (intRes, toWidget csrf >> fvInput intView)
-    -- | How does the shape (`ListLength`) change if a certain cell is deleted?
-    deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
-               -> ListPosition -- ^ Coordinate to delete
-               -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
-    deleteCell = miDeleteList
-    -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
-    allowAdd :: ListPosition -> Natural -> ListLength -> Bool
-    allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)
-    -- | Where to send the user when they click a shape-changing button, given the id of the Wrapper of the `massInput`-`Widget`
-    buttonAction :: PathPiece p => p -> Maybe (SomeRoute UniWorX)
-    buttonAction frag = Just . SomeRoute $ AdminTestR :#: frag
-
-  -- The actual call to @massInput@ is comparatively simple:
-
-  ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing
-
-
-  let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
-  siteLayout locallyDefinedPageHeading $ do
-  -- defaultLayout $ do
-    setTitle "Uni2work Admin Testpage"
-    $(i18nWidgetFile "admin-test")
-
-    [whamlet|<h2>Formular Demonstration|]
-    wrapForm formWidget FormSettings
-      { formMethod   = POST
-      , formAction   = Just . SomeRoute $ AdminTestR :#: FIDAdminDemo
-      , formEncoding = formEnctype
-      , formAttrs    = []
-      , formSubmit   = FormSubmit
-      , formAnchor   = Just FIDAdminDemo
-      }
-    showDemoResult
-
-    miIdent <- newIdent
-    let miForm' = wrapForm miForm FormSettings
-          { formMethod   = POST
-          , formAction   = Just . SomeRoute $ AdminTestR :#: miIdent
-          , formEncoding = miEnc
-          , formAttrs    = []
-          , formSubmit   = FormSubmit
-          , formAnchor   = Just miIdent
-          }
-    [whamlet|
-      <h2>Mass-Input
-      ^{miForm'}
-      $case miResult
-        $of FormMissing
-        $of FormFailure errs
-          <ul>
-            $forall err <- errs
-              <li>#{err}
-        $of FormSuccess res
-          <p style="white-space:pre-wrap; font-family:monospace;">
-            #{tshow res}
-    |]
-
-
-getAdminErrMsgR, postAdminErrMsgR :: Handler Html
-getAdminErrMsgR = postAdminErrMsgR
-postAdminErrMsgR = do
-  MsgRenderer mr <- getMsgRenderer
-  ((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
-        unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext (mr MsgErrMsgCiphertext)) Nothing
-
-  plaintext <- formResultMaybe ctResult $ exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) . (encodedSecretBoxOpen :: Text -> ExceptT EncodedSecretBoxException Handler Value)
-
-  let ctView' = wrapForm ctView def{ formAction = Just . SomeRoute $ AdminErrMsgR, formEncoding = ctEncoding }
-  defaultLayout
-    [whamlet|
-      $maybe t <- plaintext
-        <pre style="white-space:pre-wrap; font-family:monospace">
-          $case t
-            $of String t'
-              #{t'}
-            $of t'
-              #{encodePrettyToTextBuilder t'}
-
-      ^{ctView'}
-    |]
-
-
--- BEGIN - Buttons needed only for StudyTermCandidateManagement
-data ButtonAdminStudyTerms
-  = BtnCandidatesInfer
-  | BtnCandidatesDeleteConflicts
-  | BtnCandidatesDeleteAll
-  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-instance Universe ButtonAdminStudyTerms
-instance Finite ButtonAdminStudyTerms
-
-nullaryPathPiece ''ButtonAdminStudyTerms camelToPathPiece
-embedRenderMessage ''UniWorX ''ButtonAdminStudyTerms id
-
-instance Button UniWorX ButtonAdminStudyTerms where
-  btnClasses BtnCandidatesInfer           = [BCIsButton, BCPrimary]
-  btnClasses BtnCandidatesDeleteConflicts = [BCIsButton, BCDanger]
-  btnClasses BtnCandidatesDeleteAll       = [BCIsButton, BCDanger]
--- END Button needed only here
-
-getAdminFeaturesR, postAdminFeaturesR :: Handler Html
-getAdminFeaturesR = postAdminFeaturesR
-postAdminFeaturesR = do
-    uid <- requireAuthId
-    ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonAdminStudyTerms)
-    let btnForm = wrapForm btnWdgt def
-          { formAction = Just $ SomeRoute AdminFeaturesR
-          , formEncoding = btnEnctype
-          , formSubmit = FormNoSubmit
-          }
-    infConflicts <- case btnResult of
-      FormSuccess BtnCandidatesInfer -> do
-        (infConflicts, infAmbiguous, infRedundant, infAccepted) <- Candidates.inferHandler
-        unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
-        unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
-        let newKeys = map (StudyTermsKey' . fst) infAccepted
-        setSessionJson SessionNewStudyTerms newKeys
-        if  | null infAccepted
-              -> addMessageI Info      MsgNoCandidatesInferred
-            | otherwise
-               -> addMessageI Success . MsgCandidatesInferred $ length infAccepted
-        return infConflicts
-      FormSuccess BtnCandidatesDeleteConflicts -> runDB $ do
-        confs <- Candidates.conflicts
-        incis <- Candidates.getIncidencesFor (entityKey <$> confs)
-        deleteWhere [StudyTermCandidateIncidence <-. (E.unValue <$> incis)]
-        addMessageI Success $ MsgIncidencesDeleted $ length incis
-        return []
-      FormSuccess BtnCandidatesDeleteAll -> runDB $ do
-        deleteWhere ([] :: [Filter StudyTermCandidate])
-        addMessageI Success MsgAllIncidencesDeleted
-        Candidates.conflicts
-      _other -> runDB Candidates.conflicts
-
-    newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
-    (   (degreeResult,degreeTable)
-      , (studyTermsResult,studytermsTable)
-      , ((), candidateTable)
-      , userSchools) <- runDB $ do
-      schools <- E.select . E.from $ \school -> do
-        E.where_ . E.exists . E.from $ \schoolFunction ->
-          E.where_ $ schoolFunction E.^. UserFunctionSchool   E.==. school E.^. SchoolId
-               E.&&. schoolFunction E.^. UserFunctionUser     E.==. E.val uid
-               E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
-        return school
-      (,,,)
-        <$> mkDegreeTable
-        <*> mkStudytermsTable (Set.fromList newStudyTermKeys)
-                              (Set.fromList $ map entityKey infConflicts)
-                              (Set.fromList schools)
-        <*> mkCandidateTable
-        <*> pure schools
-
-    -- This needs to happen after calls to `dbTable` so they can short-circuit correctly
-    unless (null infConflicts) $ addMessageI Warning MsgStudyFeatureConflict
-
-    let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
-        degreeResult' = degreeResult <&> getDBFormResult
-          (\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
-                   , row ^. _dbrOutput . _entityVal . _studyDegreeShorthand
-          ))
-        updateDegree degreeKey (name,short) = update degreeKey [StudyDegreeName =. name, StudyDegreeShorthand =. short]
-    formResult degreeResult' $ \res -> do
-      void . runDB $ Map.traverseWithKey updateDegree res
-      addMessageI Success MsgStudyDegreeChangeSuccess
-
-    let studyTermsResult' :: FormResult (Map (Key StudyTerms) (Maybe Text, Maybe Text, Set SchoolId))
-        studyTermsResult' = studyTermsResult <&> getDBFormResult
-          (\row -> ( row ^. _dbrOutput . _1 . _entityVal . _studyTermsName
-                   , row ^. _dbrOutput . _1 . _entityVal . _studyTermsShorthand
-                   , row ^. _dbrOutput . _2
-          ))
-        updateStudyTerms studyTermsKey (name,short,schools) = do
-          update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short]
-          forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey
-          deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools]
-    formResult studyTermsResult' $ \res -> do
-      void . runDB $ Map.traverseWithKey updateStudyTerms res
-      addMessageI Success MsgStudyTermsChangeSuccess
-
-    siteLayoutMsg MsgAdminFeaturesHeading $ do
-      setTitleI MsgAdminFeaturesHeading
-      $(widgetFile "adminFeatures")
-  where
-    textInputCell :: Ord i
-                  => Lens' a (Maybe Text)
-                  -> Getter (DBRow r) (Maybe Text)
-                  -> Getter (DBRow r) i
-                  -> DBRow r 
-                  -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
-    textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
-      (\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
-        <$> mopt textField "" (Just $ row ^. lensDefault)
-      )
-  
-    checkboxCell :: Ord i
-                 => Lens' a Bool
-                 -> Getter (DBRow r) Bool
-                 -> Getter (DBRow r) i
-                 -> DBRow r 
-                 -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
-    checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
-      ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
-        <$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
-      )
-
-
-    mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
-    mkDegreeTable =
-      let dbtIdent      = "admin-studydegrees" :: Text
-          dbtStyle      = def
-          dbtSQLQuery   :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
-          dbtSQLQuery   = return
-          dbtRowKey     = (E.^. StudyDegreeKey)
-          dbtProj       = return
-          dbtColonnade  = formColonnade $ mconcat
-            [ sortable (Just "key")   (i18nCell MsgGenericKey)  (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
-            , sortable (Just "name")  (i18nCell MsgDegreeName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
-            , sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand) (_dbrOutput . _entityKey))
-            , dbRow
-            ]
-          dbtSorting    = Map.fromList
-            [ ("key"  , SortColumn (E.^. StudyDegreeKey))
-            , ("name" , SortColumn (E.^. StudyDegreeName))
-            , ("short", SortColumn (E.^. StudyDegreeShorthand))
-            ]
-          dbtFilter     = mempty
-          dbtFilterUI   = mempty
-          dbtParams     = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
-                              }
-          psValidator   = def  -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
-                        & defaultSorting [SortAscBy "key"]
-          dbtCsvEncode  = noCsvEncode
-          dbtCsvDecode  = Nothing
-      in dbTable psValidator DBTable{..}
-
-    mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> Set (Entity School) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text, Set SchoolId) (DBRow (Entity StudyTerms, Set SchoolId))), Widget)
-    mkStudytermsTable newKeys badKeys schools =
-      let dbtIdent      = "admin-studyterms" :: Text
-          dbtStyle      = def
-          dbtSQLQuery   :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
-          dbtSQLQuery   = return
-          dbtRowKey     = (E.^. StudyTermsKey)
-          dbtProj field = do
-            fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
-              E.where_ . E.exists . E.from $ \schoolTerms ->
-                E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
-                     E.&&. schoolTerms E.^. SchoolTermsTerms  E.==. E.val (field ^. _dbrOutput . _entityKey)
-              E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
-              return $ school E.^. SchoolId
-            return $ field & _dbrOutput %~ (, fieldSchools)
-          dbtColonnade  = formColonnade $ mconcat
-            [ sortable (Just "key")   (i18nCell MsgGenericKey)         (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermsKey))
-            , sortable (Just "isnew") (i18nCell MsgGenericIsNew)       (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey))
-            , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey))
-            , sortable (Just "name")  (i18nCell MsgStudyTermsName)     (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) (_dbrOutput . _1 . _entityKey))
-            , sortable (Just "short") (i18nCell MsgStudyTermsShort)    (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) (_dbrOutput . _1 . _entityKey))
-            , flip foldMap schools $ \(Entity ssh School{schoolName}) ->
-                sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _2 . at ssh . _Maybe) (_dbrOutput . _1 . _entityKey))
-            , dbRow
-            ]
-          dbtSorting    = Map.fromList
-            [ ("key"   , SortColumn (E.^. StudyTermsKey))
-            , ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsKey `E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys))) -- works only once
-            -- Remember: sorting with E.in_ by StudyTermsId instead will produce esqueleto-error "unsafeSqlBinOp: non-id/composite keys not expected here"
-            , ("isbad" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsKey `E.in_` E.valList (unStudyTermsKey <$> Set.toList badKeys)))
-            , ("name"  , SortColumn (E.^. StudyTermsName))
-            , ("short" , SortColumn (E.^. StudyTermsShorthand))
-            ]
-          dbtFilter     = mempty
-          dbtFilterUI   = mempty
-          dbtParams     = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
-                              }
-          psValidator   = def
-                        -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
-                        & defaultSorting [SortDescBy "isnew", SortDescBy "isbad", SortAscBy "key"]
-          dbtCsvEncode  = noCsvEncode
-          dbtCsvDecode  = Nothing
-      in dbTable psValidator DBTable{..}
-
-    mkCandidateTable =
-      let dbtIdent      = "admin-termcandidate" :: Text
-          dbtStyle      = def { dbsFilterLayout = defaultDBSFilterLayout }
-          dbtSQLQuery   :: E.SqlExpr (Entity StudyTermCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermCandidate))
-          dbtSQLQuery   = return
-          dbtRowKey     = (E.^. StudyTermCandidateId)
-          dbtProj       = return
-          dbtColonnade  = dbColonnade $ mconcat
-            [ dbRow
-            , sortable (Just "key")       (i18nCell MsgStudyTermsKey)           (numCell  . view (_dbrOutput . _entityVal . _studyTermCandidateKey))
-            , sortable (Just "name")      (i18nCell MsgStudyTermsName)          (textCell . view (_dbrOutput . _entityVal . _studyTermCandidateName))
-            , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermCandidateIncidence))
-            ]
-          dbtSorting    = Map.fromList
-            [ ("key"      , SortColumn (E.^. StudyTermCandidateKey))
-            , ("name"     , SortColumn (E.^. StudyTermCandidateName))
-            , ("incidence", SortColumn (E.^. StudyTermCandidateIncidence))
-            ]
-          dbtFilter     = Map.fromList
-            [ ("key",       FilterColumn $ mkExactFilter    (E.^. StudyTermCandidateKey))
-            , ("name",      FilterColumn $ mkContainsFilter (E.^. StudyTermCandidateName))
-            , ("incidence", FilterColumn $ mkExactFilter    (E.^. StudyTermCandidateIncidence)) -- contains filter desired, but impossible here
-            ]
-          dbtFilterUI mPrev = mconcat
-            -- [ prismAForm (singletonFilter "key")       mPrev $ aopt intField            (fslI MsgStudyTermsKey) -- Typing problem exactFilter suffices here
-            [ prismAForm (singletonFilter "key")       mPrev $ aopt textField (fslI MsgStudyTermsKey)
-            , prismAForm (singletonFilter "name")      mPrev $ aopt textField (fslI MsgStudyTermsName)
-            , prismAForm (singletonFilter "incidence") mPrev $ aopt textField (fslI MsgStudyCandidateIncidence)
-            ]
-          dbtParams     = def
-          psValidator   = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"]
-          dbtCsvEncode  = noCsvEncode
-          dbtCsvDecode  = Nothing
-      in dbTable psValidator DBTable{..}
-

src/Handler/Admin/ErrorMessage.hs

@@ -0,0 +1,32 @@
+module Handler.Admin.ErrorMessage
+  ( getAdminErrMsgR, postAdminErrMsgR
+  ) where
+
+import Import
+import Handler.Utils
+import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
+
+import Control.Monad.Trans.Except
+
+
+getAdminErrMsgR, postAdminErrMsgR :: Handler Html
+getAdminErrMsgR = postAdminErrMsgR
+postAdminErrMsgR = do
+  ((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
+        unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext "Ciphertext") Nothing
+
+  plaintext <- formResultMaybe ctResult $ exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) . (encodedSecretBoxOpen :: Text -> ExceptT EncodedSecretBoxException Handler Value)
+
+  let ctView' = wrapForm ctView def{ formAction = Just . SomeRoute $ AdminErrMsgR, formEncoding = ctEncoding }
+  defaultLayout
+    [whamlet|
+      $maybe t <- plaintext
+        <pre style="white-space:pre-wrap; font-family:monospace">
+          $case t
+            $of String t'
+              #{t'}
+            $of t'
+              #{encodePrettyToTextBuilder t'}
+
+      ^{ctView'}
+    |]

src/Handler/Admin/StudyFeatures.hs

@@ -0,0 +1,528 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
+module Handler.Admin.StudyFeatures
+  ( getAdminFeaturesR, postAdminFeaturesR
+  ) where
+
+import Import
+import Handler.Utils
+
+import qualified Data.Text as Text
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+import qualified Database.Esqueleto as E
+import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
+
+import qualified Handler.Utils.TermCandidates as Candidates
+
+
+data ButtonAdminStudyTermsNames
+  = BtnNameCandidatesInfer
+  | BtnNameCandidatesDeleteConflicts
+  | BtnNameCandidatesDeleteAll
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonAdminStudyTermsNames
+instance Finite ButtonAdminStudyTermsNames
+
+nullaryPathPiece ''ButtonAdminStudyTermsNames $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsNames id
+
+instance Button UniWorX ButtonAdminStudyTermsNames where
+  btnClasses BtnNameCandidatesInfer           = [BCIsButton, BCPrimary]
+  btnClasses BtnNameCandidatesDeleteConflicts = [BCIsButton, BCDanger]
+  btnClasses BtnNameCandidatesDeleteAll       = [BCIsButton, BCDanger]
+
+data ButtonAdminStudyTermsParents
+  = BtnParentCandidatesInfer
+  | BtnParentCandidatesDeleteAll
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonAdminStudyTermsParents
+instance Finite ButtonAdminStudyTermsParents
+
+nullaryPathPiece ''ButtonAdminStudyTermsParents $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsParents id
+
+instance Button UniWorX ButtonAdminStudyTermsParents where
+  btnClasses BtnParentCandidatesInfer     = [BCIsButton, BCPrimary]
+  btnClasses BtnParentCandidatesDeleteAll = [BCIsButton, BCDanger]
+  
+data ButtonAdminStudyTermsStandalone
+  = BtnStandaloneCandidatesDeleteRedundant
+  | BtnStandaloneCandidatesDeleteAll
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonAdminStudyTermsStandalone
+instance Finite ButtonAdminStudyTermsStandalone
+
+nullaryPathPiece ''ButtonAdminStudyTermsStandalone $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsStandalone id
+
+instance Button UniWorX ButtonAdminStudyTermsStandalone where
+  btnClasses BtnStandaloneCandidatesDeleteRedundant = [BCIsButton, BCPrimary]
+  btnClasses BtnStandaloneCandidatesDeleteAll       = [BCIsButton, BCDanger]
+
+  
+getAdminFeaturesR, postAdminFeaturesR :: Handler Html
+getAdminFeaturesR = postAdminFeaturesR
+postAdminFeaturesR = do
+    uid <- requireAuthId
+    ((nameBtnResult, nameBtnWdgt), nameBtnEnctype) <- runFormPost $ identifyForm ("infer-names-button" :: Text) buttonForm
+    let nameBtnForm = wrapForm nameBtnWdgt def
+          { formAction = Just $ SomeRoute AdminFeaturesR
+          , formEncoding = nameBtnEnctype
+          , formSubmit = FormNoSubmit
+          }
+    infNameConflicts <- case nameBtnResult of
+      FormSuccess BtnNameCandidatesInfer -> do
+        (infConflicts, infAmbiguous, infRedundantNames, infAccepted) <- Candidates.inferNamesHandler
+        unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousNameCandidatesRemoved $ length infAmbiguous
+        unless (null infRedundantNames) . addMessageI Info . MsgRedundantNameCandidatesRemoved $ length infRedundantNames
+        unless (null infConflicts) $ do
+          let badKeys = map entityKey infConflicts
+          setSessionJson SessionConflictingStudyTerms badKeys
+          addMessageI Warning MsgStudyFeatureConflict
+
+        let newKeys = map fst infAccepted
+        setSessionJson SessionNewStudyTerms newKeys
+
+        if  | null infAccepted
+              -> addMessageI Info      MsgNoNameCandidatesInferred
+            | otherwise
+               -> addMessageI Success . MsgNameCandidatesInferred $ length infAccepted
+        redirect AdminFeaturesR
+      FormSuccess BtnNameCandidatesDeleteConflicts -> do
+        runDB $ do
+          confs <- Candidates.nameConflicts
+          incis <- Candidates.getNameIncidencesFor $ map entityKey confs
+          deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)]
+          addMessageI Success $ MsgIncidencesDeleted $ length incis
+        redirect AdminFeaturesR
+      FormSuccess BtnNameCandidatesDeleteAll -> do
+        runDB $ do
+          deleteWhere ([] :: [Filter StudyTermNameCandidate])
+          addMessageI Success MsgAllNameIncidencesDeleted
+        redirect AdminFeaturesR
+      _other -> runDB Candidates.nameConflicts
+
+    ((parentsBtnResult, parentsBtnWdgt), parentsBtnEnctype) <- runFormPost $ identifyForm ("infer-parents-button" :: Text) buttonForm
+    let parentsBtnForm = wrapForm parentsBtnWdgt def
+          { formAction = Just $ SomeRoute AdminFeaturesR
+          , formEncoding = parentsBtnEnctype
+          , formSubmit = FormNoSubmit
+          }
+    formResult parentsBtnResult $ \case
+      BtnParentCandidatesInfer -> do
+        (infRedundantParents, infAccepted) <- Candidates.inferParentsHandler
+        unless (null infRedundantParents) . addMessageI Info . MsgRedundantParentCandidatesRemoved $ length infRedundantParents
+
+        let newKeys = map (studySubTermsChild . entityVal) infAccepted
+        setSessionJson SessionNewStudyTerms newKeys
+
+        if  | null infAccepted
+              -> addMessageI Info      MsgNoParentCandidatesInferred
+            | otherwise
+               -> addMessageI Success . MsgParentCandidatesInferred $ length infAccepted
+        redirect AdminFeaturesR
+      BtnParentCandidatesDeleteAll -> do
+        runDB $ do
+          deleteWhere ([] :: [Filter StudySubTermParentCandidate])
+          addMessageI Success MsgAllParentIncidencesDeleted
+        redirect AdminFeaturesR
+
+    ((standaloneBtnResult, standaloneBtnWdgt), standaloneBtnEnctype) <- runFormPost $ identifyForm ("infer-standalone-button" :: Text) buttonForm
+    let standaloneBtnForm = wrapForm standaloneBtnWdgt def
+          { formAction = Just $ SomeRoute AdminFeaturesR
+          , formEncoding = standaloneBtnEnctype
+          , formSubmit = FormNoSubmit
+          }
+    formResult standaloneBtnResult $ \case
+      BtnStandaloneCandidatesDeleteRedundant -> do
+        infRedundantStandalone <- runDB Candidates.removeRedundantStandalone
+        unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
+        redirect AdminFeaturesR
+      BtnStandaloneCandidatesDeleteAll -> do
+        runDB $ do
+          deleteWhere ([] :: [Filter StudyTermStandaloneCandidate])
+          addMessageI Success MsgAllStandaloneIncidencesDeleted
+        redirect AdminFeaturesR
+  
+
+    newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
+    badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms
+    (   (degreeResult,degreeTable)
+      , (studyTermsResult,studytermsTable)
+      , ((), candidateTable)
+      , userSchools
+      , ((), parentCandidateTable)
+      , (standaloneResult, standaloneCandidateTable)) <- runDB $ do
+      schools <- E.select . E.from $ \school -> do
+        E.where_ . E.exists . E.from $ \schoolFunction ->
+          E.where_ $ schoolFunction E.^. UserFunctionSchool   E.==. school E.^. SchoolId
+               E.&&. schoolFunction E.^. UserFunctionUser     E.==. E.val uid
+               E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
+        return school
+      (,,,,,)
+        <$> mkDegreeTable
+        <*> mkStudytermsTable (Set.fromList newStudyTermKeys)
+                              (Set.fromList $ fromMaybe (map entityKey infNameConflicts) badStudyTermKeys)
+                              (Set.fromList schools)
+        <*> mkCandidateTable
+        <*> pure schools
+        <*> mkParentCandidateTable
+        <*> mkStandaloneCandidateTable
+
+    let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
+        degreeResult' = degreeResult <&> getDBFormResult
+          (\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
+                   , row ^. _dbrOutput . _entityVal . _studyDegreeShorthand
+          ))
+        updateDegree degreeKey (name,short) = update degreeKey [StudyDegreeName =. name, StudyDegreeShorthand =. short]
+    formResult degreeResult' $ \res -> do
+      void . runDB $ Map.traverseWithKey updateDegree res
+      addMessageI Success MsgStudyDegreeChangeSuccess
+      redirect $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
+
+    let standaloneResult' :: FormResult (Map (Key StudyTermStandaloneCandidate) (Maybe StudyDegreeId, Maybe StudyFieldType))
+        standaloneResult' = standaloneResult <&> getDBFormResult
+          (\row -> ( row ^? _dbrOutput . _2 . _Just . _entityVal . _studyTermsDefaultDegree . _Just
+                   , row ^? _dbrOutput . _2 . _Just . _entityVal . _studyTermsDefaultType . _Just
+          ))
+    formResult standaloneResult' $ \res -> do
+      updated <- runDB . iforM res $ \candidateId (mDegree, mType) -> do
+        StudyTermStandaloneCandidate{..} <- getJust candidateId
+        let termsId = StudyTermsKey' studyTermStandaloneCandidateKey
+        updated <- case (,) <$> mDegree <*> mType of
+          Nothing -> return Nothing
+          Just (degree, typ) -> do
+            ifM (existsKey termsId)
+              ( update termsId
+                  [ StudyTermsDefaultDegree =. Just degree
+                  , StudyTermsDefaultType =. Just typ
+                  ]
+              )
+              ( insert_ $ StudyTerms studyTermStandaloneCandidateKey Nothing Nothing (Just degree) (Just typ)
+              )
+            return $ Just termsId
+        infRedundantStandalone <- Candidates.removeRedundantStandalone
+        unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
+        return updated
+      
+      let newKeys = catMaybes $ Map.elems updated
+      unless (null newKeys) $ do
+        setSessionJson SessionNewStudyTerms newKeys
+
+        redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
+
+
+    let studyTermsResult' :: FormResult (Map StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType))
+        studyTermsResult' = studyTermsResult <&> getDBFormResult
+          (\row -> ( row ^? _dbrOutput . _1 . _entityVal . _studyTermsName . _Just
+                   , row ^? _dbrOutput . _1 . _entityVal . _studyTermsShorthand . _Just
+                   , row ^. _dbrOutput . _3
+                   , row ^. _dbrOutput . _2 . to (Set.map entityKey)
+                   , row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree . _Just
+                   , row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultType . _Just
+          ))
+        updateStudyTerms studyTermsKey (name,short,schools,parents,degree,sType) = do
+          degreeExists <- fmap (fromMaybe False) . for degree $ fmap (is _Just) . get
+          update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short, StudyTermsDefaultDegree =. guard degreeExists *> degree, StudyTermsDefaultType =. sType]
+
+          forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey
+          deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools]
+
+          forM_ parents $ void . insertUnique . StudySubTerms studyTermsKey
+          deleteWhere [StudySubTermsChild ==. studyTermsKey, StudySubTermsParent /<-. Set.toList parents]
+    formResult studyTermsResult' $ \res -> do
+      void . runDB $ Map.traverseWithKey updateStudyTerms res
+      addMessageI Success MsgStudyTermsChangeSuccess
+      redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
+
+    siteLayoutMsg MsgAdminFeaturesHeading $ do
+      setTitleI MsgAdminFeaturesHeading
+      $(widgetFile "adminFeatures")
+  where
+    textInputCell :: Ord i
+                  => Lens' a (Maybe Text)
+                  -> Getter (DBRow r) (Maybe Text)
+                  -> Getter (DBRow r) i
+                  -> DBRow r 
+                  -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
+    textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
+      (\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView))
+        <$> mopt (textField & cfStrip) "" (Just $ row ^. lensDefault)
+      )
+  
+    checkboxCell :: Ord i
+                 => Lens' a Bool
+                 -> Getter (DBRow r) Bool
+                 -> Getter (DBRow r) i
+                 -> DBRow r 
+                 -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) 
+    checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
+      ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
+        <$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
+      )
+
+    -- termKeyCell :: Ord i
+    --             => Lens' a (Maybe StudyTermsId)
+    --             -> Getter (DBRow r) (Maybe StudyTermsId)
+    --             -> Getter (DBRow r) i
+    --             -> DBRow r
+    --             -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
+    -- termKeyCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
+    --   ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
+    --     <$> mopt (intField & isoField (from _StudyTermsId)) "" (Just $ row ^. lensDefault)
+    --   )
+
+    parentsCell :: Ord i
+                => Lens' a (Set StudyTermsId)
+                -> Getter (DBRow r) (Set StudyTermsId)
+                -> Getter (DBRow r) i
+                -> DBRow r
+                -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
+    parentsCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
+      ( \row mkUnique -> (\(res, fieldView) -> (set lensRes . Set.fromList <$> res, fvInput fieldView))
+        <$> massInputList
+              (intField & isoField (from _StudyTermsId))
+              (const "")
+              (Just . SomeRoute . (AdminFeaturesR :#:))
+              (mkUnique ("parents" :: Text))
+              ""
+              False
+              (Just . Set.toList $ row ^. lensDefault)
+              mempty
+      )
+
+    degreeCell :: Ord i
+               => Lens' a (Maybe StudyDegreeId)
+               -> Getter (DBRow r) (Maybe StudyDegreeId)
+               -> Getter (DBRow r) i
+               -> DBRow r
+               -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
+    degreeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
+      ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
+        <$> mopt degreeField "" (Just $ row ^. lensDefault)
+      )
+  
+    fieldTypeCell :: Ord i
+                  => Lens' a (Maybe StudyFieldType)
+                  -> Getter (DBRow r) (Maybe StudyFieldType)
+                  -> Getter (DBRow r) i
+                  -> DBRow r
+                  -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
+    fieldTypeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
+      ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView))
+        <$> mopt (selectField optionsFinite) "" (Just $ row ^. lensDefault)
+      )
+
+
+    mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
+    mkDegreeTable =
+      let dbtIdent      = "admin-studydegrees" :: Text
+          dbtStyle      = def
+          dbtSQLQuery   :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
+          dbtSQLQuery   = return
+          dbtRowKey     = (E.^. StudyDegreeKey)
+          dbtProj       = return
+          dbtColonnade  = formColonnade $ mconcat
+            [ sortable (Just "key")   (i18nCell MsgGenericKey)  (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
+            , sortable (Just "name")  (i18nCell MsgDegreeName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
+            , sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand) (_dbrOutput . _entityKey))
+            , dbRow
+            ]
+          dbtSorting    = Map.fromList
+            [ ("key"  , SortColumn (E.^. StudyDegreeKey))
+            , ("name" , SortColumn (E.^. StudyDegreeName))
+            , ("short", SortColumn (E.^. StudyDegreeShorthand))
+            ]
+          dbtFilter     = mempty
+          dbtFilterUI   = mempty
+          dbtParams     = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
+                              }
+          psValidator   = def  -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+                        & defaultPagesize PagesizeAll
+                        & defaultSorting [SortAscBy "key"]
+          dbtCsvEncode  = noCsvEncode
+          dbtCsvDecode  = Nothing
+      in dbTable psValidator DBTable{..}
+
+    mkStudytermsTable :: Set StudyTermsId -> Set StudyTermsId -> Set (Entity School) -> DB (FormResult (DBFormResult StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTerms, Set (Entity StudyTerms), Set SchoolId))), Widget)
+    mkStudytermsTable newKeys badKeys schools =
+      let dbtIdent      = "admin-studyterms" :: Text
+          dbtStyle      = def
+          dbtSQLQuery   :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
+          dbtSQLQuery = return
+          dbtRowKey = (E.^. StudyTermsKey)
+          dbtProj field@(view _dbrOutput -> Entity fId _) = do
+            fieldSchools <- fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
+              E.where_ . E.exists . E.from $ \schoolTerms ->
+                E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
+                     E.&&. schoolTerms E.^. SchoolTermsTerms  E.==. E.val fId 
+              E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
+              return $ school E.^. SchoolId
+            fieldParents <- fmap (setOf folded) . lift . E.select . E.from $ \terms -> do
+              E.where_ . E.exists . E.from $ \subTerms ->
+                E.where_ $ subTerms E.^. StudySubTermsChild E.==. E.val fId
+                     E.&&. subTerms E.^. StudySubTermsParent E.==. terms E.^. StudyTermsId
+              return terms
+            return $ field & _dbrOutput %~ (\field' -> (field', fieldParents, fieldSchools))
+          dbtColonnade  = formColonnade $ mconcat
+            [ sortable (Just "key")   (i18nCell MsgGenericKey)         (maybe mempty numCell . preview (_dbrOutput . _1 . _entityVal . _studyTermsKey))
+            , sortable Nothing (i18nCell MsgStudySubTermsParentKey) (parentsCell _4 (_dbrOutput . _2 . to (Set.map entityKey)) _dbrKey')
+            , sortable (Just "isnew") (i18nCell MsgGenericIsNew)       (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey))
+            , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey))
+            , sortable (Just "name")  (i18nCell MsgStudyTermsName)     (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) _dbrKey')
+            , sortable (Just "short") (i18nCell MsgStudyTermsShort)    (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) _dbrKey')
+            , sortable (Just "degree") (i18nCell MsgStudyTermsDefaultDegree)    (degreeCell _5 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree) _dbrKey')
+            , sortable (Just "field-type") (i18nCell MsgStudyTermsDefaultFieldType)    (fieldTypeCell _6 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultType) _dbrKey')
+            , flip foldMap schools $ \(Entity ssh School{schoolName}) ->
+                sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _3 . at ssh . _Maybe) _dbrKey')
+            , dbRow
+            ]
+          dbtSorting    = Map.fromList
+            [ ("key"   , SortColumn $ queryField >>> (E.^. StudyTermsKey))
+            -- , ("parent", SortColumn $ \t -> querySubField t E.?. StudySubTermsParent)
+            , ("isnew" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys))
+              )
+            , ("isbad" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList badKeys))
+              )
+            , ("name"  , SortColumn $ queryField >>> (E.^. StudyTermsName))
+            , ("short" , SortColumn $ queryField >>> (E.^. StudyTermsShorthand))
+            , ("degree" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultDegree))
+            , ("field-type" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultType))
+            ]
+          dbtFilter     = mempty
+          dbtFilterUI   = mempty
+          dbtParams     = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
+                              }
+          psValidator   = def
+                        & defaultPagesize PagesizeAll
+                        & defaultSorting [SortAscBy "isnew", SortAscBy "isbad", SortAscBy "key"]
+          dbtCsvEncode  = noCsvEncode
+          dbtCsvDecode  = Nothing
+
+          queryField = id
+          _dbrKey' :: Getter (DBRow (Entity StudyTerms, _, _)) StudyTermsId
+          _dbrKey' = _dbrOutput . _1 . _entityKey
+      in dbTable psValidator DBTable{..}
+
+    mkCandidateTable =
+      let dbtIdent      = "admin-termcandidate" :: Text
+          dbtStyle      = def { dbsFilterLayout = defaultDBSFilterLayout }
+          dbtSQLQuery   :: E.SqlExpr (Entity StudyTermNameCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermNameCandidate))
+          dbtSQLQuery   = return
+          dbtRowKey     = (E.^. StudyTermNameCandidateId)
+          dbtProj       = return
+          dbtColonnade  = dbColonnade $ mconcat
+            [ dbRow
+            , sortable (Just "key")       (i18nCell MsgStudyTermsKey)           (numCell  . view (_dbrOutput . _entityVal . _studyTermNameCandidateKey))
+            , sortable (Just "name")      (i18nCell MsgStudyTermsName)          (textCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateName))
+            , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateIncidence))
+            ]
+          dbtSorting    = Map.fromList
+            [ ("key"      , SortColumn (E.^. StudyTermNameCandidateKey))
+            , ("name"     , SortColumn (E.^. StudyTermNameCandidateName))
+            , ("incidence", SortColumn (E.^. StudyTermNameCandidateIncidence))
+            ]
+          dbtFilter     = Map.fromList
+            [ ("key",       FilterColumn $ mkExactFilter    (E.^. StudyTermNameCandidateKey))
+            , ("name",      FilterColumn $ mkContainsFilter (E.^. StudyTermNameCandidateName))
+            , ("incidence", FilterColumn $ mkExactFilter    (E.^. StudyTermNameCandidateIncidence)) -- contains filter desired, but impossible here
+            ]
+          dbtFilterUI mPrev = mconcat
+            [ prismAForm (singletonFilter "key" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field _ Int) (fslI MsgStudyTermsKey)
+            , prismAForm (singletonFilter "name")      mPrev $ aopt textField (fslI MsgStudyTermsName)
+            , prismAForm (singletonFilter "incidence") mPrev $ aopt textField (fslI MsgStudyCandidateIncidence)
+            ]
+          dbtParams     = def
+          psValidator   = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"]
+          dbtCsvEncode  = noCsvEncode
+          dbtCsvDecode  = Nothing
+      in dbTable psValidator DBTable{..}
+
+    mkParentCandidateTable =
+      let dbtIdent      = "admin-termparentcandidate" :: Text
+          dbtStyle      = def
+          dbtSQLQuery   ::                   E.SqlExpr (Entity StudySubTermParentCandidate)
+                           `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
+                           `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
+                        -> E.SqlQuery ( E.SqlExpr (Entity StudySubTermParentCandidate)
+                                      , E.SqlExpr (Maybe (Entity StudyTerms))
+                                      , E.SqlExpr (Maybe (Entity StudyTerms))
+                                      )
+          dbtSQLQuery (candidate `E.LeftOuterJoin` parent `E.LeftOuterJoin` child) = do
+            E.on $ child E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateKey)
+            E.on $ parent E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateParent)
+            return (candidate, parent, child)
+          dbtRowKey = queryCandidate >>> (E.^. StudySubTermParentCandidateId)
+          dbtProj       = return
+          dbtColonnade  = dbColonnade $ mconcat
+            [ dbRow
+            , sortable (Just "child") (i18nCell MsgStudySubTermsChildKey)   (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey))
+            , sortable (Just "child-name") (i18nCell MsgStudySubTermsChildName)  (maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _studyTermsName . _Just))
+            , sortable (Just "parent") (i18nCell MsgStudySubTermsParentKey)  (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateParent))
+            , sortable (Just "parent-name") (i18nCell MsgStudySubTermsParentName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
+            , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateIncidence))
+            ]
+          dbtSorting    = Map.fromList
+            [ ("child"    , SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateKey))
+            , ("child-name", SortColumn $ queryChild >>> (E.?. StudyTermsName) >>> E.joinV)
+            , ("parent"   , SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateParent))
+            , ("parent-name", SortColumn $ queryParent >>> (E.?. StudyTermsName) >>> E.joinV)
+            , ("incidence", SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateIncidence))
+            ]
+          dbtFilter     = mempty
+          dbtFilterUI   = mempty
+          dbtParams     = def
+          psValidator   = def
+                        & defaultSorting [SortAscBy "child", SortAscBy "incidence", SortAscBy "parent"]
+          dbtCsvEncode  = noCsvEncode
+          dbtCsvDecode  = Nothing
+
+          queryCandidate (c `E.LeftOuterJoin` _ `E.LeftOuterJoin` _) = c
+          queryParent (_ `E.LeftOuterJoin` p `E.LeftOuterJoin` _) = p
+          queryChild (_ `E.LeftOuterJoin` _ `E.LeftOuterJoin` c) = c
+      in dbTable psValidator DBTable{..}
+
+    mkStandaloneCandidateTable :: DB (FormResult (DBFormResult StudyTermStandaloneCandidateId (Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTermStandaloneCandidate, Maybe (Entity StudyTerms)))), Widget)
+    mkStandaloneCandidateTable =
+      let dbtIdent      = "admin-termstandalonecandidate" :: Text
+          dbtStyle      = def
+          dbtSQLQuery   ::                   E.SqlExpr (Entity StudyTermStandaloneCandidate)
+                           `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
+                        -> E.SqlQuery ( E.SqlExpr (Entity StudyTermStandaloneCandidate)
+                                      , E.SqlExpr (Maybe (Entity StudyTerms))
+                                      )
+          dbtSQLQuery (candidate `E.LeftOuterJoin` sterm) = do
+            E.on $ sterm E.?. StudyTermsKey E.==. E.just (candidate E.^. StudyTermStandaloneCandidateKey)
+            return (candidate, sterm)
+          dbtRowKey = queryCandidate >>> (E.^. StudyTermStandaloneCandidateId)
+          dbtProj       = return
+          dbtColonnade  = formColonnade $ mconcat
+            [ dbRow
+            , sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateKey))
+            , sortable (Just "name") (i18nCell MsgStudyTermsName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
+            , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateIncidence))
+            , sortable Nothing (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _1 (pre $ _dbrOutput . _2 . _Just . _studyTermsDefaultDegree . _Just) _dbrKey')
+            , sortable Nothing (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _2 (pre $ _dbrOutput . _2 . _Just . _studyTermsDefaultType . _Just) _dbrKey')
+            ]
+          dbtSorting    = Map.fromList
+            [ ("key"      , SortColumn $ queryCandidate >>> (E.^. StudyTermStandaloneCandidateKey))
+            , ("name"     , SortColumn $ queryTerm      >>> (E.?. StudyTermsName) >>> E.joinV)
+            , ("incidence", SortColumn $ queryCandidate >>> (E.^. StudyTermStandaloneCandidateIncidence))
+            ]
+          dbtFilter     = mempty
+          dbtFilterUI   = mempty
+          dbtParams     = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
+                              }
+          psValidator   = def
+                        & defaultSorting [SortAscBy "key", SortAscBy "incidence"]
+          dbtCsvEncode  = noCsvEncode
+          dbtCsvDecode  = Nothing
+
+          queryCandidate (c `E.LeftOuterJoin` _) = c
+          queryTerm (_ `E.LeftOuterJoin` t) = t
+          _dbrKey' :: Getter (DBRow (Entity StudyTermStandaloneCandidate, _)) StudyTermStandaloneCandidateId
+          _dbrKey' = _dbrOutput . _1 . _entityKey
+      in dbTable psValidator DBTable{..}

src/Handler/Admin/Test.hs

@@ -0,0 +1,231 @@
+module Handler.Admin.Test
+  ( getAdminTestR
+  , postAdminTestR
+  ) where
+
+import Import
+import Handler.Utils
+import Jobs
+
+import Control.Monad.Trans.Writer (mapWriterT)
+
+import Data.Char (isDigit)
+import qualified Data.Text as Text
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+import Database.Persist.Sql (fromSqlKey)
+
+
+-- BEGIN - Buttons needed only here
+data ButtonCreate = CreateMath | CreateInf  -- Dummy for Example
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonCreate
+instance Finite ButtonCreate
+
+nullaryPathPiece ''ButtonCreate camelToPathPiece
+
+instance Button UniWorX ButtonCreate where
+  btnLabel CreateMath = [whamlet|Ma<i>thema</i>tik|]
+  btnLabel CreateInf  = "Informatik"
+
+  btnClasses CreateMath = [BCIsButton, BCInfo]
+  btnClasses CreateInf  = [BCIsButton, BCPrimary]
+-- END Button needed only here
+
+emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext)
+emailTestForm = (,)
+            <$> areq emailField (fslI MsgMailTestFormEmail) Nothing
+            <*> ( MailContext
+                  <$> (Languages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
+                  <*> (toMailDateTimeFormat
+                        <$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
+                        <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
+                        <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
+                      )
+                )
+  where
+    toMailDateTimeFormat dt d t = \case
+      SelFormatDateTime -> dt
+      SelFormatDate -> d
+      SelFormatTime -> t
+
+makeDemoForm :: Int -> Form (Int,Bool,Double)
+makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
+    (result, widget) <- flip (renderAForm FormStandard) html $ (,,)
+        <$> areq (minIntFieldI n ("Zahl" :: Text)) (fromString $ "Ganzzahl > " ++ show n) Nothing
+        <*  aformSection MsgFormBehaviour
+        <*> areq checkBoxField "Muss nächste Zahl größer sein?" (Just True)
+        <*> areq doubleField "Fliesskommazahl" Nothing
+        -- NO LONGER DESIRED IN AFORMS:
+        -- <*  submitButton
+    return $ case result of
+      FormSuccess fsres
+        | errorMsgs <- validateResult fsres
+        , not $ null errorMsgs -> (FormFailure errorMsgs, widget)
+      _otherwise -> (result, widget)
+  where
+    validateResult :: (Int,Bool,Double) -> [Text]
+    validateResult (i,True,d) | fromIntegral i >= d = [tshow d <> " ist nicht größer als " <> tshow i, "Zweite Fehlermeldung", "Dritte Fehlermeldung"]
+    validateResult _other = []
+
+
+getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
+getAdminTestR = postAdminTestR
+postAdminTestR = do
+  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate)
+  let btnForm = wrapForm btnWdgt def
+        { formAction = Just $ SomeRoute AdminTestR
+        , formEncoding = btnEnctype
+        , formSubmit = FormNoSubmit
+        }
+  case btnResult of
+    (FormSuccess CreateInf)  -> addMessage Info "Informatik-Knopf gedrückt"
+    (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
+    FormMissing -> return ()
+    _other -> addMessage Warning "KEIN Knopf erkannt"
+
+  ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
+  formResultModal emailResult AdminTestR $ \(email, ls) -> do
+    jId <- mapWriterT runDB $ do
+      jId <- queueJob $ JobSendTestEmail email ls
+      tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
+      return jId
+    runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
+    addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`
+
+  let emailWidget' = wrapForm emailWidget def
+        { formAction = Just . SomeRoute $ AdminTestR
+        , formEncoding = emailEnctype
+        , formAttrs = [("uw-async-form", "")]
+        }
+
+
+  let demoFormAction (_i,_b,_d) = addMessage Info "All ok."
+  ((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7
+  formResult demoResult demoFormAction
+  let showDemoResult = [whamlet|
+          $maybe (i,b,d) <- formResult' demoResult
+            Received values:
+              <ul>
+                <li>#{show i}
+                <li>#{show b}
+                <li>#{show d}
+          $nothing
+            No form values received, due to #
+            $# Using formResult' above means that we usually to not distinguish the following two cases here, sind formResult does this already:
+            $case demoResult
+              $of FormSuccess _
+                $# Already dealt with above, to showecase usage of formResult' as normally done.
+                success, which should not happen here.
+              $of FormMissing
+                Form data missing, probably empty.
+              $of FormFailure msgs
+                <ul>
+                  $forall m <- msgs
+                    <li>#{m}
+        |]
+  let testTooltipMsg = toWidget [whamlet| So sehen aktuell Tooltips via iconTooltip aus. |] :: WidgetFor UniWorX ()
+
+  msgInfoTooltip    <- messageI Info ("Info-Tooltip via messageI" :: Text)
+  msgSuccessTooltip <- messageI Success ("Success-Tooltip via messageI" :: Text)
+  msgWarningTooltip <- messageI Warning ("Warning-Tooltip via messageI" :: Text)
+  msgErrorTooltip   <- messageI Error ("Error-Tooltip via messageI" :: Text)
+
+  msgNonDefaultIconTooltip <- messageIconI Info IconEmail ("Info-Tooltip mit lustigem Icon" :: Text)
+
+  {- The following demonstrates the use of @massInput@.
+
+     @massInput@ takes as arguments:
+       - A configuration struct describing how the Widget should behave (how is the space of sub-forms structured, how many dimensions does it have, which additions/deletions are permitted, what data do they need to operate and what should their effect on the overall shape be?)
+       - Information on how the resulting field fits into the form as a whole (@FieldSettings@ and whether the @massInput@ should be marked required)
+       - An initial value to pre-fill the field with
+
+     @massInput@ then returns an @MForm@ structured for easy downstream consumption of the result
+   -}
+  let
+    -- We define the fields of the configuration struct @MassInput@:
+
+    -- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell)
+    --
+    -- This /needs/ to replace all occurrences of @mreq@ with @mpreq@ (no fields should be /actually/ required)
+    mkAddForm :: ListPosition -- ^ Approximate position of the add-widget
+              -> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
+              -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
+              -> FieldView UniWorX -- ^ Submit-Button for this add-widget
+              -> Maybe (Form (Map ListPosition Int -> FormResult (Map ListPosition Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cells and data needed to initialize cells
+    mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do
+      (addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration
+      let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done
+          addRes'' = addRes' <&> \dat prev -> FormSuccess (Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) dat) -- Construct the callback to determine new cell positions and data within @FormResult@ as required, nested @FormResult@ allows aborting the add depending on previous data
+      return (addRes'', toWidget csrf >> fvInput addView >> fvInput submitBtn)
+    mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"
+
+    -- | Make a single massInput-Cell
+    --
+    -- This /needs/ to use @nudge@ and deterministic field naming (this allows for correct value-shifting when cells are deleted)
+    mkCellForm :: ListPosition -- ^ Position of this cell
+               -> Int -- ^ Data needed to initialize the cell (see return of @mkAddForm@)
+               -> Maybe Int -- ^ Initial cell result from Argument to `massInput`
+               -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
+               -> Form Int
+    mkCellForm _pos cData initial nudge csrf = do -- Extremely simple cell
+      (intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData
+      return (intRes, toWidget csrf >> fvInput intView)
+    -- | How does the shape (`ListLength`) change if a certain cell is deleted?
+    deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
+               -> ListPosition -- ^ Coordinate to delete
+               -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
+    deleteCell = miDeleteList
+    -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
+    allowAdd :: ListPosition -> Natural -> ListLength -> Bool
+    allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)
+    -- | Where to send the user when they click a shape-changing button, given the id of the Wrapper of the `massInput`-`Widget`
+    buttonAction :: PathPiece p => p -> Maybe (SomeRoute UniWorX)
+    buttonAction frag = Just . SomeRoute $ AdminTestR :#: frag
+
+  -- The actual call to @massInput@ is comparatively simple:
+
+  ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing
+
+
+  let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
+  siteLayout locallyDefinedPageHeading $ do
+  -- defaultLayout $ do
+    setTitle "Uni2work Admin Testpage"
+    $(i18nWidgetFile "admin-test")
+
+    [whamlet|<h2>Formular Demonstration|]
+    wrapForm formWidget FormSettings
+      { formMethod   = POST
+      , formAction   = Just . SomeRoute $ AdminTestR :#: FIDAdminDemo
+      , formEncoding = formEnctype
+      , formAttrs    = []
+      , formSubmit   = FormSubmit
+      , formAnchor   = Just FIDAdminDemo
+      }
+    showDemoResult
+
+    miIdent <- newIdent
+    let miForm' = wrapForm miForm FormSettings
+          { formMethod   = POST
+          , formAction   = Just . SomeRoute $ AdminTestR :#: miIdent
+          , formEncoding = miEnc
+          , formAttrs    = []
+          , formSubmit   = FormSubmit
+          , formAnchor   = Just miIdent
+          }
+    [whamlet|
+      <h2>Mass-Input
+      ^{miForm'}
+      $case miResult
+        $of FormMissing
+        $of FormFailure errs
+          <ul>
+            $forall err <- errs
+              <li>#{err}
+        $of FormSuccess res
+          <p style="white-space:pre-wrap; font-family:monospace;">
+            #{tshow res}
+    |]

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)

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)

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

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

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

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
+    let tutorialCourse = E.subSelectForeign tutorialParticipant TutorialParticipantTutorial (E.^. TutorialCourse)
-          E.where_ $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
-          return $ tutorial E.^. TutorialCourse
 
     E.where_ $ tutorialCourse E.==. E.val cid
          E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid

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

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

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
             ]

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

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

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

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.^. StudyFeaturesField    E.==. studyterms  E.^. StudyTermsId
-      E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
+       E.||. studyfeat E.^. StudyFeaturesSubField E.==. E.just (studyterms  E.^. StudyTermsId)
+      E.on $ studyfeat E.^. StudyFeaturesDegree   E.==. studydegree E.^. StudyDegreeId
       return  (studyfeat, studydegree, studyterms)
   --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

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
 

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)

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

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
+          , ("participants", SortColumn $ \tutorial -> let participantCount :: E.SqlExpr (E.Value Int)
-                E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
+                                                           participantCount = E.subSelectCount . E.from $ \tutorialParticipant ->
-                return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
+                                                             E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
+                                                        in participantCount
             )
           , ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity )
           , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )

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

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)

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

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 

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

src/Handler/Utils/StudyFeatures.hs

@@ -1,5 +1,6 @@
 module Handler.Utils.StudyFeatures
   ( parseStudyFeatures
+  , parseSubTermsSemester
   ) where
 
 import Import.NoFoundation hiding (try, (<|>))
@@ -7,9 +8,19 @@ import Import.NoFoundation hiding (try, (<|>))
 import Text.Parsec
 import Text.Parsec.Text
 
+import Auth.LDAP (ldapUserSubTermsSemester, ldapUserStudyFeatures)
+import qualified Ldap.Client as Ldap
+
 
 parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures]
-parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) ""
+parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key)
+  where
+    Ldap.Attr key = ldapUserStudyFeatures
+  
+parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int)
+parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key)
+  where
+    Ldap.Attr key = ldapUserSubTermsSemester
 
 
 pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]
@@ -19,9 +30,9 @@ pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do
 
   let
     pStudyFeature = do
-      _ <- pKey -- Meaning unknown at this time
+      _ <- pKey -- "Fächergruppe"
       void $ char '!'
-      _ <- pKey -- Meaning unknown
+      _ <- pKey -- "Studienbereich"
       void $ char '!'
       studyFeaturesField <- StudyTermsKey' <$> pKey
       void $ char '!'
@@ -29,6 +40,7 @@ pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do
       void $ char '!'
       studyFeaturesSemester <- decimal
       let studyFeaturesValid = True
+          studyFeaturesSubField = Nothing
       return StudyFeatures{..}
 
   pStudyFeature `sepBy1` char '#'
@@ -45,3 +57,12 @@ decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit'
   where
     digit' = dVal <$> digit
     dVal c = fromEnum c - fromEnum '0'
+
+
+pLMUTermsSemester :: Parser (StudyTermsId, Int)
+pLMUTermsSemester = do
+  subTermsKey <- StudyTermsKey' <$> pKey
+  void $ char '$'
+  semester <- decimal
+
+  return (subTermsKey, semester)

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]

src/Handler/Utils/TermCandidates.hs

@@ -25,11 +25,11 @@ import qualified Data.Map as Map
 
 
 import qualified Database.Esqueleto as E
--- import Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Internal.Sql as E
 
 {-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
 
-type STKey = Int -- for convenience, assmued identical to field StudyTermCandidateKey
+type STKey = Int -- for convenience, assmued identical to field StudyTermNameCandidateKey
 
 data FailedCandidateInference = FailedCandidateInference [Entity StudyTerms]
   deriving (Typeable, Show)
@@ -46,26 +46,44 @@ 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 ([Entity StudyTerms],[TermCandidateIncidence],[Entity StudyTermCandidate],[(STKey,Text)])
+inferNamesHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],[Entity StudyTermNameCandidate],[(StudyTermsId,Text)])
-inferHandler = runDB $ inferAcc ([],[],[])
+inferNamesHandler = runDB $ inferAcc mempty
   where
     inferAcc (accAmbiguous, accRedundants, accAccepted) =
-      handle (\(FailedCandidateInference fails) -> (fails,accAmbiguous,accRedundants,accAccepted) <$ E.transactionUndo) $ do
+      handle (\(FailedCandidateInference fails) -> (fails, accAmbiguous, accRedundants, accAccepted') <$ E.transactionUndo) $ do
-        (infAmbis, infReds,infAccs) <- inferStep
+        (infAmbis, infReds, infAccs) <- inferStep
-        if null infAccs
+        if
-          then return ([],          accAmbiguous, infReds ++ accRedundants,            accAccepted)
+          | null infAccs ->
-          else do
+            return ([],          accAmbiguous, infReds <> accRedundants,            accAccepted')
+          | otherwise -> do
             E.transactionSave -- commit transaction if there are no problems
-            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
+      ambiguous  <- removeAmbiguousNames
-      redundants <- removeRedundant
+      redundants <- removeRedundantNames
-      accepted <- acceptSingletons
+      accepted <- acceptSingletonNames
-      problems <- conflicts
+      problems <- nameConflicts
       unless (null problems) $ throwM $ FailedCandidateInference problems
       return (ambiguous, redundants, accepted)
 
+inferParentsHandler :: Handler ([Entity StudySubTermParentCandidate], [Entity StudySubTerms])
+inferParentsHandler = runDB $ inferAcc mempty
+  where
+    inferAcc (infReds', infAccs') = do
+      (infReds, infAccs) <- inferStep
+      if
+        | null infAccs ->
+          return (infReds' <> infReds, infAccs')
+        | otherwise ->
+          inferAcc (infReds' <> infReds, infAccs' <> infAccs)
+    inferStep = do
+      redundants <- removeRedundantParents
+      accepted <- acceptSingletonParents
+      return (redundants, accepted)
+
 {-
 Candidate 1 11 "A"
 Candidate 1 11 "B"
@@ -87,35 +105,65 @@ as a fix we simply eliminate all observations that have the same name twice, see
 -- | remove candidates with ambiguous observations,
 --   ie. candidates that have duplicated term names with differing keys
 --   which may happen in rare cases
-removeAmbiguous :: DB [TermCandidateIncidence]
+removeAmbiguousNames :: DB [TermCandidateIncidence]
-removeAmbiguous = do
+removeAmbiguousNames = do
   ambiList <- E.select $ E.from $ \candidate -> do
-    E.groupBy ( candidate E.^. StudyTermCandidateIncidence
+    E.groupBy ( candidate E.^. StudyTermNameCandidateIncidence
-              , candidate E.^. StudyTermCandidateKey
+              , candidate E.^. StudyTermNameCandidateKey
-              , candidate E.^. StudyTermCandidateName
+              , candidate E.^. StudyTermNameCandidateName
               )
     E.having $ E.countRows E.!=. E.val (1 :: Int64)
-    return $ candidate E.^. StudyTermCandidateIncidence
+    return $ candidate E.^. StudyTermNameCandidateIncidence
   let ambiSet = E.unValue <$> List.nub ambiList
   -- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
-  deleteWhere [StudyTermCandidateIncidence <-. ambiSet]
+  deleteWhere [StudyTermNameCandidateIncidence <-. ambiSet]
   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 StudyTermCandidate]
+removeRedundantNames :: DB [Entity StudyTermNameCandidate]
-removeRedundant = do
+removeRedundantNames = do
   redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do
-    E.on $  candidate E.^. StudyTermCandidateKey  E.==. sterm E.^. StudyTermsKey
+    E.on $ candidate E.^. StudyTermNameCandidateKey E.==. sterm E.^. StudyTermsKey
-      E.&&. E.just (candidate E.^. StudyTermCandidateName) E.==. sterm E.^. StudyTermsName
+     E.&&. (       E.just (candidate E.^. StudyTermNameCandidateName) E.==. sterm E.^. StudyTermsName
+             E.||. E.exists (E.from $ \(subTerm `E.InnerJoin` sterm2) -> do
+                                E.on $ subTerm E.^. StudySubTermsParent E.==. sterm  E.^. StudyTermsId
+                                 E.&&. subTerm E.^. StudySubTermsChild  E.==. sterm2 E.^. StudyTermsId
+                                E.where_ $ E.just (candidate E.^. StudyTermNameCandidateName) E.==. sterm2 E.^. StudyTermsName
+                            )
+           )
     return candidate
   -- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
-  forM_ redundants $ \Entity{entityVal=StudyTermCandidate{..}} ->
+  forM_ redundants $ \Entity{entityVal=StudyTermNameCandidate{..}} ->
-    deleteWhere $   ( StudyTermCandidateIncidence ==. studyTermCandidateIncidence )
+    deleteWhere $   ( StudyTermNameCandidateIncidence ==. studyTermNameCandidateIncidence )
-                :  ([ StudyTermCandidateKey       ==. studyTermCandidateKey       ]
+                :  ([ StudyTermNameCandidateKey       ==. studyTermNameCandidateKey       ]
-                ||. [ StudyTermCandidateName      ==. studyTermCandidateName      ])
+                ||. [ StudyTermNameCandidateName      ==. studyTermNameCandidateName      ])
+  return redundants
+
+removeRedundantParents :: DB [Entity StudySubTermParentCandidate]
+removeRedundantParents = do
+  redundants <- E.select . E.distinct . E.from $ \(candidate `E.InnerJoin` subTerm) -> do
+    E.on $ candidate E.^. StudySubTermParentCandidateKey E.==. E.veryUnsafeCoerceSqlExprValue (subTerm E.^. StudySubTermsChild)
+     E.&&. candidate E.^. StudySubTermParentCandidateParent E.==. E.veryUnsafeCoerceSqlExprValue (subTerm E.^. StudySubTermsParent)
+    return candidate
+  forM_ redundants $ \(Entity _ StudySubTermParentCandidate{..}) ->
+    E.delete . E.from $ \candidate ->
+      E.where_ $ candidate E.^. StudySubTermParentCandidateIncidence E.==. E.val studySubTermParentCandidateIncidence
+           E.&&. (       candidate E.^. StudySubTermParentCandidateParent `E.in_` E.valList [studySubTermParentCandidateParent, studySubTermParentCandidateKey]
+                   E.||. candidate E.^. StudySubTermParentCandidateKey `E.in_` E.valList [studySubTermParentCandidateParent, studySubTermParentCandidateKey]
+                 )
+  return redundants
+
+removeRedundantStandalone :: DB [Entity StudyTermStandaloneCandidate]
+removeRedundantStandalone = do
+  redundants <- E.select . E.distinct . E.from $ \(candidate `E.InnerJoin` sterm) -> do
+    E.on $ candidate E.^. StudyTermStandaloneCandidateKey E.==. sterm E.^. StudyTermsKey
+     E.&&. E.not_ (E.isNothing $ sterm E.^. StudyTermsDefaultDegree)
+     E.&&. E.not_ (E.isNothing $ sterm E.^. StudyTermsDefaultType)
+    return candidate
+  deleteWhere [ StudyTermStandaloneCandidateId <-. map entityKey redundants ]
   return redundants
 
 
@@ -124,12 +172,12 @@ removeRedundant = do
 --   Does not delete the used candidates, user @removeRedundant@ for this later on.
 --   Esqueleto does not provide the INTERESECT operator, thus
 --   we load the table into Haskell and operate there. Memory usage problem? StudyTermsCandidate may become huge.
-acceptSingletons :: DB [(STKey,Text)]
+acceptSingletonNames :: DB [(STKey,Text)]
-acceptSingletons = do
+acceptSingletonNames = do
   knownKeys <- fmap unStudyTermsKey <$> selectKeysList [StudyTermsName !=. Nothing] [Asc StudyTermsKey]
   -- let knownKeysSet = Set.fromAscList knownKeys
   -- In case of memory problems, change next lines to conduit proper:
-  incidences <- fmap entityVal <$> selectList [StudyTermCandidateKey /<-. knownKeys] [] -- LimitTo might be dangerous here, if we get a partial incidence. Possibly first select N incidences, then retrieving all those only.
+  incidences <- fmap entityVal <$> selectList [StudyTermNameCandidateKey /<-. knownKeys] [] -- LimitTo might be dangerous here, if we get a partial incidence. Possibly first select N incidences, then retrieving all those only.
   -- incidences <- E.select $ E.from $ \candidate -> do
   --   E.where_ $ candidate E.^. StudyTermCandidayeKey `E.notIn` E.valList knownKeys
   --   return candidate
@@ -139,11 +187,11 @@ acceptSingletons = do
       groupedCandidates = foldl' groupFun mempty incidences
 
       -- given a key, map each incidence to set of possible names for this key
-      groupFun :: Map STKey (Map TermCandidateIncidence (Set Text)) -> StudyTermCandidate -> Map STKey (Map TermCandidateIncidence (Set Text))
+      groupFun :: Map STKey (Map TermCandidateIncidence (Set Text)) -> StudyTermNameCandidate -> Map STKey (Map TermCandidateIncidence (Set Text))
-      groupFun m StudyTermCandidate{..} =
+      groupFun m StudyTermNameCandidate{..} =
         insertWith (Map.unionWith Set.union)
-                   studyTermCandidateKey
+                   studyTermNameCandidateKey
-                   (Map.singleton studyTermCandidateIncidence $ Set.singleton studyTermCandidateName)
+                   (Map.singleton studyTermNameCandidateIncidence $ Set.singleton studyTermNameCandidateName)
                    m
 
       -- pointwise intersection per incidence gives possible candidates per key
@@ -152,36 +200,99 @@ acceptSingletons = do
 
       -- filter candidates having a unique possibility left
       fixedKeys :: [(STKey,Text)]
-      fixedKeys = Map.foldlWithKey' combFixed [] keyCandidates
+      fixedKeys = fst $ Map.foldlWithKey' combFixed mempty keyCandidates
-
+        where
-      combFixed :: [(STKey,Text)] -> STKey -> Set Text ->  [(STKey,Text)]
+          combFixed :: ([(STKey,Text)], Set STKey) -> STKey -> Set Text -> ([(STKey,Text)], Set STKey)
-      combFixed acc k s | Set.size s == 1 -- possibly redundant
+          combFixed (acc, bad) k s
-                        , [n] <- Set.elems s = (k,n):acc
+            | Set.member k bad
-                        -- empty sets should not occur here , if LDAP is consistent. Maybe raise a warning?!
+            = (acc, bad)
-                        | otherwise = acc
+            | maybe False (`Set.notMember` s) (lookup k acc)
+            = (filter (\(k', _) -> k /= k') acc, Set.insert k bad)
+            | [n] <- Set.elems s
+            = ((k,n) : acc, bad)
+            | otherwise = (acc, bad)
 
       -- registerFixed :: (STKey, Text) -> DB (Key StudyTerms)
       registerFixed :: (STKey, Text) -> DB ()
-      registerFixed (key, name) = repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name)
+      registerFixed (key, name) =
+        repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name) Nothing Nothing
 
   -- register newly fixed candidates
   forM_ fixedKeys registerFixed
   return fixedKeys
 
+acceptSingletonParents :: DB [Entity StudySubTerms]
+acceptSingletonParents = do
+  candidates <- map entityVal <$> selectList [] []
+
+  let
+    groupedCandidates :: Map STKey (Map UUID (Set STKey))
+    groupedCandidates = foldl' groupFun mempty candidates
+      where
+        groupFun :: Map STKey (Map UUID (Set STKey)) -> StudySubTermParentCandidate -> Map STKey (Map UUID (Set STKey))
+        groupFun m StudySubTermParentCandidate{..} =
+          Map.insertWith (Map.unionWith Set.union)
+            studySubTermParentCandidateKey
+            (Map.singleton studySubTermParentCandidateIncidence $ Set.singleton studySubTermParentCandidateParent)
+            m
+
+    parentCandidates :: Map STKey (Set STKey)
+    parentCandidates = Map.map (setIntersections . Map.elems) groupedCandidates
+
+    fixedParents :: [(STKey, STKey)]
+    fixedParents = fst $ Map.foldlWithKey' combFixed mempty parentCandidates
+      where
+        combFixed :: ([(STKey, STKey)], Set STKey) -> STKey -> Set STKey -> ([(STKey, STKey)], Set STKey)
+        combFixed (acc, bad) k s
+          | Set.member k bad
+          = (acc, bad)
+          | maybe False (`Set.notMember` s) (lookup k acc)
+          = (filter (\(k', _) -> k /= k') acc, Set.insert k bad)
+          | [p] <- Set.elems s
+          = ((k, p) : acc, bad)
+          | otherwise = (acc, bad)
+
+  inserted <- forM fixedParents $ \(key, parent) -> do
+    unlessM (existsKey $ StudyTermsKey' key) $
+      insert_ (StudyTerms key Nothing Nothing Nothing Nothing)
+    unlessM (existsKey $ StudyTermsKey' parent) $
+      insert_ (StudyTerms parent Nothing Nothing Nothing Nothing)
+    insertUnique $ StudySubTerms
+      { studySubTermsChild  = StudyTermsKey' key
+      , studySubTermsParent = StudyTermsKey' parent
+      }
+  
+  mapM getJustEntity $ catMaybes inserted
+
 
 -- | all existing StudyTerms that are contradiced by current observations
-conflicts :: DB [Entity StudyTerms]
+nameConflicts :: DB [Entity StudyTerms]
-conflicts = E.select $ E.from $ \studyTerms -> do
+nameConflicts = E.select $ E.from $ \studyTerms -> do
   E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName
   E.where_ $ E.exists $ E.from $ \candidateOne -> do
-    E.where_ $ candidateOne E.^. StudyTermCandidateKey E.==. studyTerms E.^. StudyTermsKey
+    E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studyTerms E.^. StudyTermsKey
     E.where_ $ E.notExists . E.from $ \candidateTwo ->  do
-        E.where_ $ candidateTwo E.^. StudyTermCandidateIncidence E.==. candidateOne E.^. StudyTermCandidateIncidence
+        E.where_ $ candidateTwo E.^. StudyTermNameCandidateIncidence E.==. candidateOne E.^. StudyTermNameCandidateIncidence
-        E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermCandidateName)
+        E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
+             E.||. E.exists ( E.from $ \(pCandidate `E.LeftOuterJoin` termsTwo) -> do
+                                E.on $ pCandidate E.^. StudySubTermParentCandidateParent E.==. studyTerms E.^. StudyTermsKey
+                                 E.&&. E.just (pCandidate E.^. StudySubTermParentCandidateKey) E.==. termsTwo E.?. StudyTermsKey
+                                E.where_ $ E.joinV (termsTwo E.?. StudyTermsName) E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
+                                     E.||. E.isNothing (E.joinV $ termsTwo E.?. StudyTermsName)
+                            )
+             E.||. E.exists ( E.from $ \(subTerms `E.InnerJoin` termsTwo) -> do
+                                E.on $ subTerms E.^. StudySubTermsParent E.==. studyTerms E.^. StudyTermsId
+                                 E.&&. subTerms E.^. StudySubTermsChild  E.==. termsTwo   E.^. StudyTermsId
+                                E.where_ $ termsTwo E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
+                                     E.||. E.isNothing (termsTwo E.^. StudyTermsName)
+                            )
   return studyTerms
 
+
 -- | retrieve all incidence keys having containing a certain @StudyTermKey @
-getIncidencesFor :: [Key StudyTerms] -> DB [E.Value TermCandidateIncidence]
+getNameIncidencesFor :: [StudyTermsId] -> DB [E.Value TermCandidateIncidence]
-getIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do
+getNameIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do
-  E.where_ $ candidate E.^. StudyTermCandidateKey `E.in_` E.valList (unStudyTermsKey <$> stks)
+  E.where_ $ candidate E.^. StudyTermNameCandidateKey `E.in_` E.valList stks'
-  return $ candidate E.^. StudyTermCandidateIncidence
+  return $ candidate E.^. StudyTermNameCandidateIncidence
+  where
+    stks' = stks <&> unStudyTermsKey

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.SqlExpr (E.Value Int64)
-      let participantCount = E.sub_select . E.from $ \participant -> do
+          participantCount = E.subSelectCount . E.from $ \participant ->
             E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
-            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

src/Model.hs

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

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

src/Model/Types/Common.hs

@@ -30,6 +30,7 @@ type StudyDegreeKey          = Int
 type StudyTermsName          = Text
 type StudyTermsShorthand     = Text
 type StudyTermsKey           = Int
+type StudySubTermsKey        = Int
 
 type SchoolName              = CI Text
 type SchoolShorthand         = CI Text

src/Model/Types/Misc.hs

@@ -34,6 +34,7 @@ data StudyFieldType = FieldPrimary | FieldSecondary
 derivePersistField "StudyFieldType"
 instance Universe StudyFieldType
 instance Finite   StudyFieldType
+nullaryPathPiece ''StudyFieldType $ camelToPathPiece' 1
 
 
 data Theme

src/Utils.hs

@@ -237,10 +237,6 @@ stepTextCounter text
 -- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo  Ue3bung00322 34 (H)"
 -- ["12",".ProMo  Ue","3","bung","00322"," ","34"," (H)"]
 
--- | Ignore warnings for unused variables with a more specific type
-notUsedT :: a -> Text
-notUsedT = notUsed
-
 fromText :: (IsString a, Textual t) => t -> a
 fromText = fromString . unpack
 
@@ -732,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

src/Utils/Lens.hs

@@ -49,6 +49,12 @@ _nullable = prism' toNullable fromNullable
 _SchoolId :: Iso' SchoolId SchoolShorthand
 _SchoolId = iso unSchoolKey SchoolKey
 
+_StudyTermsId :: Iso' StudyTermsId StudyTermsKey
+_StudyTermsId = iso unStudyTermsKey StudyTermsKey'
+
+_StudyDegreeId :: Iso' StudyDegreeId StudyDegreeKey
+_StudyDegreeId = iso unStudyDegreeKey StudyDegreeKey'
+
 _Maybe :: Iso' (Maybe ()) Bool
 _Maybe = iso (is _Just) (bool Nothing (Just ()))
 
@@ -83,6 +89,7 @@ makeClassyFor_ ''StudyFeatures
 makeClassyFor_ ''StudyDegree
 
 makeClassyFor_ ''StudyTerms
+makeClassyFor_ ''StudySubTerms
 
 
 _entityKey :: Getter (Entity record) (Key record)
@@ -126,7 +133,6 @@ hasEntityUser = hasEntity
 -- instance (HasUser a) => HasUser (Entity a) where
 --   hasUser = _entityVal . hasUser
 
-
 makeLenses_ ''SheetCorrector
 
 makeLenses_ ''Load
@@ -143,7 +149,9 @@ makePrisms ''AuthResult
 
 makePrisms ''FormResult
 
-makeLenses_ ''StudyTermCandidate
+makeLenses_ ''StudyTermNameCandidate
+makeLenses_ ''StudySubTermParentCandidate
+makeLenses_ ''StudyTermStandaloneCandidate
 
 makeLenses_ ''FieldView
 makeLenses_ ''FieldSettings

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

templates/adminFeatures.cassius

@@ -0,0 +1,3 @@
+#admin-studyterms
+  select, option, input
+    min-width: 50px

templates/adminFeatures.hamlet

@@ -1,19 +1,40 @@
 $newline never
 <section>
+  <h2>
+    _{MsgStudyFeaturesDegrees}
   ^{degreeTable}
 <section>
+  <h2>
+    _{MsgStudyFeaturesTerms}
   ^{studytermsTable}
 <section>
-  <h2>_{MsgStudyFeatureInference}
+  <h2>
-  $if null infConflicts
+    _{MsgStudyFeatureNameInference}
-    <p>
+  <p>
-      _{MsgStudyFeatureInferenceNoConflicts}
+    $if null infNameConflicts
-  $else
+      _{MsgStudyFeatureInferenceNoNameConflicts}
-    <h3>_{MsgStudyFeatureInferenceConflictsHeading}
+    $else
-    <ul>
+      <h3>_{MsgStudyFeatureInferenceNameConflictsHeading}
-      $forall (Entity _ (StudyTerms ky _ nm)) <- infConflicts
+      <ul>
-        <li> #{show ky} - #{foldMap id nm}
+        $forall Entity _ (StudyTerms ky _ nm _ _) <- infNameConflicts
-  ^{btnForm}
+          <li>
+            #{show ky} - #{foldMap id nm}
+  ^{nameBtnForm}
   
-  <div .container>
+  <h2>
-    ^{candidateTable}
+    _{MsgStudyFeaturesNameCandidates}
+  ^{candidateTable}
+<section>
+  <h2>
+    _{MsgStudyFeatureParentInference}
+  ^{parentsBtnForm}
+
+  <h2>
+    _{MsgStudyFeaturesParentCandidates}
+  ^{parentCandidateTable}
+<section>
+  <h2>
+    _{MsgStudyFeaturesStandaloneCandidates}
+  ^{standaloneBtnForm}
+
+  ^{standaloneCandidateTable}

templates/course-user.hamlet

@@ -37,11 +37,10 @@ $newline never
                   <th .table__th>_{MsgStudyFeatureAge}
                   <th .table__th>_{MsgStudyFeatureValid}
                   <th .table__th>_{MsgStudyFeatureUpdate}
-                $forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
+                $forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesUpdated}), (Entity _ degree), (Entity _ field)) <- studies
-                  $with _ <- notUsedT studyFeaturesUser
                   <tr .table__row>
-                    <td .table__td>_{field}#{notUsedT studyFeaturesField}
+                    <td .table__td>_{field}
-                    <td .table__td>_{degree}#{notUsedT studyFeaturesDegree}
+                    <td .table__td>_{degree}
                     <td .table__td>_{studyFeaturesType}
                     <td .table__td>#{studyFeaturesSemester}
                     <td .table__td>#{hasTickmark studyFeaturesValid}

templates/profileData.hamlet

@@ -43,11 +43,10 @@ $newline never
               <th .table__th>_{MsgStudyFeatureValid}
               <th .table__th>_{MsgStudyFeatureUpdate}
 
-            $forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies
+            $forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesUpdated}), (Entity _ degree), (Entity _ field)) <- studies
-              $with _ <- notUsedT studyFeaturesUser
               <tr.table__row>
-                <td .table__td>_{field}#{notUsedT studyFeaturesField}
+                <td .table__td>_{field}
-                <td .table__td>_{degree}#{notUsedT studyFeaturesDegree}
+                <td .table__td>_{degree}
                 <td .table__td>_{studyFeaturesType}
                 <td .table__td>#{studyFeaturesSemester}
                 <td .table__td>#{hasTickmark studyFeaturesValid}

test/Database.hs

@@ -317,87 +317,88 @@ fillDb = do
     sdChem2 = StudyTermsKey' 113
     sdBWL   = StudyTermsKey' 21
     sdDeut  = StudyTermsKey' 103
-  repsert sdInf   $ StudyTerms  79 (Just "Inf")   (Just "Informatikk")
+  repsert sdInf   $ StudyTerms  79 (Just "Inf")   (Just "Informatikk") Nothing Nothing
-  repsert sdMath  $ StudyTerms 105 (Just "Math" ) (Just "Mathematik")
+  repsert sdMath  $ StudyTerms 105 (Just "Math" ) (Just "Mathematik")  Nothing Nothing
-  repsert sdMedi  $ StudyTerms 121  Nothing       (Just "Fehler hier")
+  repsert sdMedi  $ StudyTerms 121  Nothing       (Just "Fehler hier") Nothing Nothing
-  repsert sdPhys  $ StudyTerms 128  Nothing        Nothing                  -- intentionally left unknown
+  repsert sdPhys  $ StudyTerms 128  Nothing        Nothing             Nothing Nothing -- intentionally left unknown
-  repsert sdBioI1 $ StudyTerms 221  Nothing        Nothing                  -- intentionally left unknown
+  repsert sdBioI1 $ StudyTerms 221  Nothing        Nothing             Nothing Nothing -- intentionally left unknown
-  repsert sdBioI2 $ StudyTerms 228  Nothing        Nothing                  -- intentionally left unknown
+  repsert sdBioI2 $ StudyTerms 228  Nothing        Nothing             Nothing Nothing -- intentionally left unknown
-  repsert sdBiol  $ StudyTerms 26   Nothing        Nothing                  -- intentionally left unknown
+  repsert sdBiol  $ StudyTerms 26   Nothing        Nothing             Nothing Nothing -- intentionally left unknown
-  repsert sdChem1 $ StudyTerms 61   Nothing        Nothing                  -- intentionally left unknown
+  repsert sdChem1 $ StudyTerms 61   Nothing        Nothing             Nothing Nothing -- intentionally left unknown
-  repsert sdChem2 $ StudyTerms 113  Nothing        Nothing                  -- intentionally left unknown
+  repsert sdChem2 $ StudyTerms 113  Nothing        Nothing             Nothing Nothing -- intentionally left unknown
-  repsert sdBWL   $ StudyTerms 21   Nothing        Nothing                  -- intentionally left unknown
+  repsert sdBWL   $ StudyTerms 21   Nothing        Nothing             Nothing Nothing -- intentionally left unknown
-  repsert sdDeut  $ StudyTerms 103  Nothing        Nothing                  -- intentionally left unknown
+  repsert sdDeut  $ StudyTerms 103  Nothing        Nothing             Nothing Nothing -- intentionally left unknown
   incidence1 <- liftIO getRandom
-  void . insert $ StudyTermCandidate incidence1 221 "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence1 221 "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence1 221 "Mathematik"
+  void . insert $ StudyTermNameCandidate incidence1 221 "Mathematik"
-  void . insert $ StudyTermCandidate incidence1 105 "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence1 105 "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence1 105 "Mathematik"
+  void . insert $ StudyTermNameCandidate incidence1 105 "Mathematik"
   incidence2 <- liftIO getRandom
-  void . insert $ StudyTermCandidate incidence2 221 "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence2 221 "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence2 221 "Chemie"
+  void . insert $ StudyTermNameCandidate incidence2 221 "Chemie"
-  void . insert $ StudyTermCandidate incidence2 61  "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence2 61  "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence2 61  "Chemie"
+  void . insert $ StudyTermNameCandidate incidence2 61  "Chemie"
   incidence3 <- liftIO getRandom
-  void . insert $ StudyTermCandidate incidence3 113 "Chemie"
+  void . insert $ StudyTermNameCandidate incidence3 113 "Chemie"
   incidence4 <- liftIO getRandom  -- ambiguous incidence
-  void . insert $ StudyTermCandidate incidence4 221 "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence4 221 "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence4 221 "Chemie"
+  void . insert $ StudyTermNameCandidate incidence4 221 "Chemie"
-  void . insert $ StudyTermCandidate incidence4 221 "Biologie"
+  void . insert $ StudyTermNameCandidate incidence4 221 "Biologie"
-  void . insert $ StudyTermCandidate incidence4 61  "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence4 61  "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence4 61  "Chemie"
+  void . insert $ StudyTermNameCandidate incidence4 61  "Chemie"
-  void . insert $ StudyTermCandidate incidence4 61  "Biologie"
+  void . insert $ StudyTermNameCandidate incidence4 61  "Biologie"
-  void . insert $ StudyTermCandidate incidence4 61  "Chemie"
+  void . insert $ StudyTermNameCandidate incidence4 61  "Chemie"
-  void . insert $ StudyTermCandidate incidence4 26  "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence4 26  "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence4 26  "Chemie"
+  void . insert $ StudyTermNameCandidate incidence4 26  "Chemie"
-  void . insert $ StudyTermCandidate incidence4 26  "Biologie"
+  void . insert $ StudyTermNameCandidate incidence4 26  "Biologie"
   incidence5 <- liftIO getRandom
-  void . insert $ StudyTermCandidate incidence5 228 "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence5 228 "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence5 228 "Physik"
+  void . insert $ StudyTermNameCandidate incidence5 228 "Physik"
-  void . insert $ StudyTermCandidate incidence5 128 "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence5 128 "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence5 128 "Physik"
+  void . insert $ StudyTermNameCandidate incidence5 128 "Physik"
   incidence6 <- liftIO getRandom
-  void . insert $ StudyTermCandidate incidence6 228 "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence6 228 "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence6 228 "Physik"
+  void . insert $ StudyTermNameCandidate incidence6 228 "Physik"
-  void . insert $ StudyTermCandidate incidence6 128 "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence6 128 "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence6 128 "Physik"
+  void . insert $ StudyTermNameCandidate incidence6 128 "Physik"
   incidence7 <- liftIO getRandom
-  void . insert $ StudyTermCandidate incidence7 228 "Physik"
+  void . insert $ StudyTermNameCandidate incidence7 228 "Physik"
-  void . insert $ StudyTermCandidate incidence7 228 "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence7 228 "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence7 128 "Physik"
+  void . insert $ StudyTermNameCandidate incidence7 128 "Physik"
-  void . insert $ StudyTermCandidate incidence7 128 "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence7 128 "Bioinformatik"
   incidence8 <- liftIO getRandom
-  void . insert $ StudyTermCandidate incidence8 128 "Physik"
+  void . insert $ StudyTermNameCandidate incidence8 128 "Physik"
-  void . insert $ StudyTermCandidate incidence8 128 "Medieninformatik"
+  void . insert $ StudyTermNameCandidate incidence8 128 "Medieninformatik"
-  void . insert $ StudyTermCandidate incidence8 121 "Physik"
+  void . insert $ StudyTermNameCandidate incidence8 121 "Physik"
-  void . insert $ StudyTermCandidate incidence8 121 "Medieninformatik"
+  void . insert $ StudyTermNameCandidate incidence8 121 "Medieninformatik"
   incidence9 <- liftIO getRandom
-  void . insert $ StudyTermCandidate incidence9 79 "Informatik"
+  void . insert $ StudyTermNameCandidate incidence9 79 "Informatik"
   incidence10 <- liftIO getRandom
-  void . insert $ StudyTermCandidate incidence10 103  "Deutsch"
+  void . insert $ StudyTermNameCandidate incidence10 103  "Deutsch"
-  void . insert $ StudyTermCandidate incidence10 103  "Betriebswirtschaftslehre"
+  void . insert $ StudyTermNameCandidate incidence10 103  "Betriebswirtschaftslehre"
-  void . insert $ StudyTermCandidate incidence10 21   "Deutsch"
+  void . insert $ StudyTermNameCandidate incidence10 21   "Deutsch"
-  void . insert $ StudyTermCandidate incidence10 21   "Betriebswirtschaftslehre"
+  void . insert $ StudyTermNameCandidate incidence10 21   "Betriebswirtschaftslehre"
   incidence11 <- liftIO getRandom
-  void . insert $ StudyTermCandidate incidence11 221 "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence11 221 "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence11 221 "Chemie"
+  void . insert $ StudyTermNameCandidate incidence11 221 "Chemie"
-  void . insert $ StudyTermCandidate incidence11 221 "Biologie"
+  void . insert $ StudyTermNameCandidate incidence11 221 "Biologie"
-  void . insert $ StudyTermCandidate incidence11 61  "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence11 61  "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence11 61  "Chemie"
+  void . insert $ StudyTermNameCandidate incidence11 61  "Chemie"
-  void . insert $ StudyTermCandidate incidence11 61  "Biologie"
+  void . insert $ StudyTermNameCandidate incidence11 61  "Biologie"
-  void . insert $ StudyTermCandidate incidence11 26  "Bioinformatik"
+  void . insert $ StudyTermNameCandidate incidence11 26  "Bioinformatik"
-  void . insert $ StudyTermCandidate incidence11 26  "Chemie"
+  void . insert $ StudyTermNameCandidate incidence11 26  "Chemie"
-  void . insert $ StudyTermCandidate incidence11 26  "Biologie"
+  void . insert $ StudyTermNameCandidate incidence11 26  "Biologie"
   incidence12 <- liftIO getRandom
-  void . insert $ StudyTermCandidate incidence12 103  "Deutsch"
+  void . insert $ StudyTermNameCandidate incidence12 103  "Deutsch"
-  void . insert $ StudyTermCandidate incidence12 103  "Betriebswirtschaftslehre"
+  void . insert $ StudyTermNameCandidate incidence12 103  "Betriebswirtschaftslehre"
-  void . insert $ StudyTermCandidate incidence12 21   "Deutsch"
+  void . insert $ StudyTermNameCandidate incidence12 21   "Deutsch"
-  void . insert $ StudyTermCandidate incidence12 21   "Betriebswirtschaftslehre"
+  void . insert $ StudyTermNameCandidate incidence12 21   "Betriebswirtschaftslehre"
 
   sfMMp <- insert $ StudyFeatures -- keyword type prevents record syntax here
     maxMuster
     sdBsc
     sdInf
+    Nothing
     FieldPrimary
     2
     now
@@ -406,6 +407,7 @@ fillDb = do
     maxMuster
     sdBsc
     sdMath
+    Nothing
     FieldSecondary
     2
     now
@@ -414,6 +416,7 @@ fillDb = do
     tinaTester
     sdBsc
     sdInf
+    Nothing
     FieldPrimary
     4
     now
@@ -422,6 +425,7 @@ fillDb = do
     tinaTester
     sdLAG
     sdPhys
+    Nothing
     FieldPrimary
     1
     now
@@ -430,6 +434,7 @@ fillDb = do
     tinaTester
     sdLAR
     sdMedi
+    Nothing
     FieldPrimary
     7
     now
@@ -438,6 +443,7 @@ fillDb = do
     tinaTester
     sdMst
     sdMath
+    Nothing
     FieldPrimary
     3
     now