feat(features-of-study): record parent & standalone candidates

messages/uniworx/de.msg

@@ -1987,3 +1987,7 @@ ShortSexNotApplicable: k.A.
 
 ShowSex: Geschlechter anderer Nutzer anzeigen
 ShowSexTip: Sollen in Kursteilnehmer-Tabellen u.Ä. die Geschlechter der Nutzer angezeigt werden?
+
+StudySubTermsParentKey: Elter
+StudyTermsDefaultDegree: Abschluss
+StudyTermsDefaultFieldType: Typ

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      StudySubTermsId 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
     -- UniqueUserSubject ubuser degree field -- There exists a counterexample
 StudyDegree   -- Studienabschluss
     key           Int            -- LMU-internal key
@@ -69,17 +71,35 @@ StudyDegree   -- Studienabschluss
                                  -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int }
     deriving 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
-StudyTermCandidate    -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms.
+StudySubTerms
+    key           Int
+    parent        StudyTermsId Maybe
+    shorthand     Text Maybe
+    name          Text Maybe
+    Primary key
+    deriving Show
+StudyTermNameCandidate    -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms.
     -- 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

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
@@ -61,7 +61,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"
@@ -69,9 +69,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/TH.hs

@@ -2,7 +2,7 @@ module Database.Esqueleto.Utils.TH
   ( SqlIn(..)
   , sqlInTuple, sqlInTuples
   , unValueN, unValueNIs
-  , sqlIJproj, sqlLOJproj
+  , sqlIJproj, sqlLOJproj, sqlFOJproj
   ) where
 
 import ClassyPrelude
@@ -84,3 +84,6 @@ sqlIJproj = leftAssociativePairProjection 'E.InnerJoin
 
 sqlLOJproj :: Int -> Int -> ExpQ
 sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin
+
+sqlFOJproj :: Int -> Int -> ExpQ
+sqlFOJproj = leftAssociativePairProjection 'E.FullOuterJoin

src/Foundation.hs

@@ -44,6 +44,7 @@ import qualified Data.Map as Map
 import qualified Data.HashSet as HashSet
 
 import Data.List (nubBy, (!!), findIndex)
+import qualified Data.List as List
 
 import Data.Monoid (Any(..))
 
@@ -3504,36 +3505,98 @@ 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 = unStudySubTermsKey . fst <$> sts
-      return (key, name)
+
+      (,) <$> sfKeys ++ subTermsKeys <*> termNames
+
+  let
+    assimilateSubTerms :: [(StudySubTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudySubTermsKey, Maybe StudyTermsId)) DB [StudyFeatures]
+    assimilateSubTerms [] xs = return xs
+    assimilateSubTerms ((subterm'@(StudySubTermsKey' subterm), subSemester) : subterms) unusedFeats = do
+      standalone <- lift . get $ StudyTermsKey' subterm
+      case standalone of
+        _other
+          | (_ : matches, unusedFeats') <- partition (\StudyFeatures{..} -> subterm == unStudyTermsKey studyFeaturesField
+                                                                         && subSemester == studyFeaturesSemester
+                                                     ) unusedFeats
+            -> assimilateSubTerms subterms $ unusedFeats' ++ matches
+          | any ((== subterm) . unStudyTermsKey . studyFeaturesField) unusedFeats
+            -> assimilateSubTerms subterms unusedFeats
+        Just StudyTerms{..}
+          | Just defDegree <- studyTermsDefaultDegree
+          , Just defType   <- studyTermsDefaultType
+            -> (:) (StudyFeatures userId defDegree (StudyTermsKey' subterm) Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats
+        Nothing
+          | [] <- unusedFeats -> do
+              tell $ Set.singleton (subterm, Nothing)
+              assimilateSubTerms subterms unusedFeats
+        _other -> do
+          knownParent <- lift $ (>>= studySubTermsParent) <$> get subterm'
+          let matchingFeatures = case knownParent of
+                Just p  -> filter ((== p) . studyFeaturesField) unusedFeats
+                Nothing -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
+          unless (is _Just knownParent) . forM_ matchingFeatures $ \StudyFeatures{..} ->
+            tell $ Set.singleton (subterm, Just studyFeaturesField)
+          if
+            | is _Just knownParent
+              -> (++) (matchingFeatures & traverse . _studyFeaturesSubField %~ (<|> Just subterm')) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures)
+            | otherwise
+              -> assimilateSubTerms subterms unusedFeats
+  (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) -> do
-    E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
+    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)
 
   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
+        (studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates
+        let studySubTermParentCandidateIncidence = studyTermCandidateIncidence
+        return StudySubTermParentCandidate{..}
+      studyTermStandaloneCandidates' = do
+        (studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates
+        let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence
+        return StudyTermStandaloneCandidate{..}
+    insertMany_ studySubTermParentCandidates'
+    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,36 +1,16 @@
-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
       [whamlet|
@@ -38,472 +18,3 @@ getAdminR = -- do
         Its current purpose is to provide links to some important admin functions
       |]
 
--- 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
-                  <$> (MailLanguages <$> 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 (minIntField n "Zahl") (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"
-    $(widgetFile "adminTest")
-
-    [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
-  ((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'}
-    |]
-
-
--- 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,315 @@
+{-# 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 qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter, sqlFOJproj)
+
+import qualified Handler.Utils.TermCandidates as Candidates
+
+import qualified Data.Maybe as Maybe
+
+
+-- BEGIN - Buttons needed only for StudyTermNameCandidateManagement
+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 fst infAccepted
+        setSessionJson SessionNewStudyTerms newKeys
+        if  | null infAccepted
+              -> addMessageI Info      MsgNoCandidatesInferred
+            | otherwise
+               -> addMessageI Success . MsgCandidatesInferred $ length infAccepted
+        return infConflicts
+      FormSuccess BtnCandidatesDeleteConflicts -> runDB $ do
+        confs <- Candidates.conflicts
+        incis <- Candidates.getIncidencesFor (bimap entityKey entityKey <$> confs)
+        deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)]
+        addMessageI Success $ MsgIncidencesDeleted $ length incis
+        return []
+      FormSuccess BtnCandidatesDeleteAll -> runDB $ do
+        deleteWhere ([] :: [Filter StudyTermNameCandidate])
+        addMessageI Success MsgAllIncidencesDeleted
+        Candidates.conflicts
+      _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 (bimap entityKey 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 (Either StudySubTermsId StudyTermsId) (Maybe Text, Maybe Text, Set SchoolId, Maybe StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType))
+        studyTermsResult' = studyTermsResult <&> Map.mapKeys (\(mbL, mbR) -> Maybe.fromJust $ fmap Left mbR <|> fmap Right mbL) . getDBFormResult
+          (\row -> ( row ^? (_dbrOutput . _1 . _Just . _entityVal . _studyTermsName . _Just <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsName . _Just)
+                   , row ^? (_dbrOutput . _1 . _Just . _entityVal . _studyTermsShorthand . _Just <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsShorthand . _Just)
+                   , row ^. _dbrOutput . _3
+                   , row ^? _dbrOutput . _2 . _Just . _entityVal . _studySubTermsParent . _Just
+                   , row ^? _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultDegree . _Just
+                   , row ^? _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultType . _Just
+          ))
+        updateStudyTerms (Right studyTermsKey) (name,short,schools,_parent,degree,sType) = do
+          degreeExists <- fmap (fromMaybe False) . for degree $ fmap (is _Just) . get
+          update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short, StudyTermsDefaultDegree =. guard degreeExists *> degree, StudyTermsDefaultType =. sType]
+          forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey
+          deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools]
+        updateStudyTerms (Left studySubTermsKey) (name,short,_schools,parent,_degree,_type) = do
+          parentExists <- fmap (fromMaybe False) . for parent $ fmap (is _Just) . get
+          update studySubTermsKey [StudySubTermsName =. name, StudySubTermsShorthand =. short, StudySubTermsParent =. guard parentExists *> parent]
+    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 & 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)
+      )
+  
+    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 (intField & isoField (from _StudyDegreeId)) "" (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 Int -> Set (Either StudySubTermsId StudyTermsId) -> Set (Entity School) -> DB (FormResult (DBFormResult (Maybe StudyTermsId, Maybe StudySubTermsId) (Maybe Text, Maybe Text, Set SchoolId, Maybe StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Maybe (Entity StudyTerms), Maybe (Entity StudySubTerms), Set SchoolId))), Widget)
+    mkStudytermsTable newKeys badKeys' schools =
+      let dbtIdent      = "admin-studyterms" :: Text
+          dbtStyle      = def
+          dbtSQLQuery   :: E.SqlExpr (Maybe (Entity StudyTerms)) `E.FullOuterJoin` E.SqlExpr (Maybe (Entity StudySubTerms)) -> E.SqlQuery (E.SqlExpr (Maybe (Entity StudyTerms)), E.SqlExpr (Maybe (Entity StudySubTerms)))
+          dbtSQLQuery (studyTerms `E.FullOuterJoin` studySubTerms) = do
+            E.on $ studyTerms E.?. StudyTermsKey E.==. studySubTerms E.?. StudySubTermsKey
+            return (studyTerms, studySubTerms)
+          dbtRowKey (studyTerms `E.FullOuterJoin` studySubTerms) = (studyTerms E.?. StudyTermsKey, studySubTerms E.?. StudySubTermsKey)
+          dbtProj field = do
+            fieldSchools <- for (field ^. _dbrOutput . _1) $ \field' -> fmap (setOf $ folded . _Value) . lift . E.select . E.from $ \school -> do
+              E.where_ . E.exists . E.from $ \schoolTerms ->
+                E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
+                     E.&&. schoolTerms E.^. SchoolTermsTerms  E.==. E.val (field' ^. _entityKey)
+              E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
+              return $ school E.^. SchoolId
+            return $ field & _dbrOutput %~ (\(field', subField) -> (field', subField, fromMaybe Set.empty fieldSchools))
+          dbtColonnade  = formColonnade $ mconcat
+            [ sortable (Just "key")   (i18nCell MsgGenericKey)         (maybe mempty numCell . preview (_dbrOutput . _1 . _Just . _entityVal . _studyTermsKey))
+            , sortable (Just "parent") (i18nCell MsgStudySubTermsParentKey) (termKeyCell _4 (pre $ _dbrOutput . _2 . _Just . _entityVal . _studySubTermsParent . _Just) _dbrKey')
+            , sortable (Just "isnew") (i18nCell MsgGenericIsNew)       (maybe mempty (isNewCell . flip Set.member newKeys) . preview (_dbrOutput . _1 . _Just . _entityVal . _studyTermsKey <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsKey))
+            , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (maybe mempty (isBadCell . flip Set.member badKeys) . preview (_dbrOutput . _1 . _Just . _entityVal . _studyTermsKey <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsKey))
+            , sortable (Just "name")  (i18nCell MsgStudyTermsName)     (textInputCell _1 (singular $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsName <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsName) _dbrKey')
+            , sortable (Just "short") (i18nCell MsgStudyTermsShort)    (textInputCell _2 (singular $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsShorthand <> _dbrOutput . _2 . _Just . _entityVal . _studySubTermsShorthand) _dbrKey')
+            , sortable (Just "degree") (i18nCell MsgStudyTermsDefaultDegree)    (degreeCell _5 (pre $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultDegree . _Just) _dbrKey')
+            , sortable (Just "field-type") (i18nCell MsgStudyTermsDefaultFieldType)    (fieldTypeCell _6 (pre $ _dbrOutput . _1 . _Just . _entityVal . _studyTermsDefaultType . _Just) _dbrKey')
+            , flip foldMap schools $ \(Entity ssh School{schoolName}) ->
+                sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _3 . at ssh . _Maybe) _dbrKey')
+            , dbRow
+            ]
+          dbtSorting    = Map.fromList
+            [ ("key"   , SortColumn $ \t -> E.maybe (querySubField t E.?. StudySubTermsKey) E.just $ queryField t E.?. StudyTermsKey)
+            , ("parent", SortColumn $ \t -> querySubField t E.?. StudySubTermsParent)
+            , ("isnew" , SortColumn $ \t -> queryField t E.?. StudyTermsKey `E.in_` E.valList (Just <$> Set.toList newKeys)
+                                      E.||. querySubField t E.?. StudySubTermsKey `E.in_` E.valList (Just <$> Set.toList newKeys)
+              )
+            , ("isbad" , SortColumn $ \t -> queryField t E.?. StudyTermsKey `E.in_` E.valList (Just <$> Set.toList badKeys)
+                                      E.||. querySubField t E.?. StudySubTermsKey `E.in_` E.valList (Just <$> Set.toList badKeys)
+              )
+            , ("name"  , SortColumn $ \t -> E.maybe (E.joinV $ querySubField t E.?. StudySubTermsName) E.just . E.joinV $ queryField t E.?. StudyTermsName)
+            , ("short" , SortColumn $ \t -> E.maybe (E.joinV $ querySubField t E.?. StudySubTermsShorthand) E.just . E.joinV $ queryField t E.?. StudyTermsShorthand)
+            , ("degree" , SortColumn $ \t -> queryField t E.?. StudyTermsDefaultDegree)
+            , ("field-type" , SortColumn $ \t -> queryField t E.?. StudyTermsDefaultType)
+            ]
+          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 = $(sqlFOJproj 2 1)
+          querySubField = $(sqlFOJproj 2 2)
+          _dbrKey' :: Getter (DBRow (Maybe (Entity StudyTerms), Maybe (Entity StudySubTerms), Set SchoolId))
+                             (Maybe StudyTermsId, Maybe StudySubTermsId)
+          _dbrKey' = $(multifocusL 2) (_dbrOutput . _1 . applying (_Entity . _1)) (_dbrOutput . _2 . applying (_Entity . _1))
+
+          badKeys = Set.map (either unStudySubTermsKey unStudyTermsKey) badKeys'
+      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{..}
+

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
+                  <$> (MailLanguages <$> 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 (minIntField n "Zahl") (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"
+    $(widgetFile "adminTest")
+
+    [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/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 (StudySubTermsId, 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 (StudySubTermsId, Int)
+pLMUTermsSemester = do
+  subTermsKey <- StudySubTermsKey' <$> pKey
+  void $ char '$'
+  semester <- decimal
+
+  return (subTermsKey, semester)

src/Handler/Utils/TermCandidates.hs

@@ -25,13 +25,13 @@ import qualified Data.Map as Map
 
 
 import qualified Database.Esqueleto as E
--- import Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils as E
 
 {-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
 
-type STKey = Int -- for convenience, assmued identical to field StudyTermCandidateKey
+type STKey = Int -- for convenience, assmued identical to field StudyTermNameCandidateKey
 
-data FailedCandidateInference = FailedCandidateInference [Entity StudyTerms]
+data FailedCandidateInference = FailedCandidateInference [Either (Entity StudySubTerms) (Entity StudyTerms)]
   deriving (Typeable, Show)
 
 instance Exception FailedCandidateInference
@@ -46,7 +46,7 @@ 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)])
+inferHandler :: Handler ([Either (Entity StudySubTerms) (Entity StudyTerms)],[TermCandidateIncidence],[Entity StudyTermNameCandidate],[(STKey,Text)])
 inferHandler = runDB $ inferAcc ([],[],[])
   where
     inferAcc (accAmbiguous, accRedundants, accAccepted) =
@@ -90,32 +90,37 @@ as a fix we simply eliminate all observations that have the same name twice, see
 removeAmbiguous :: DB [TermCandidateIncidence]
 removeAmbiguous = 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]
+removeRedundant :: DB [Entity StudyTermNameCandidate]
 removeRedundant = do
-  redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do
+  redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` (sterm `E.FullOuterJoin` ssubterm)) -> do
-    E.on $  candidate E.^. StudyTermCandidateKey  E.==. sterm E.^. StudyTermsKey
+    E.on   E.true
-      E.&&. E.just (candidate E.^. StudyTermCandidateName) E.==. sterm E.^. StudyTermsName
+    E.on $  (       E.just (candidate E.^. StudyTermNameCandidateKey)  E.==. sterm E.?. StudyTermsKey
+              E.&&. E.just (candidate E.^. StudyTermNameCandidateName) E.==. E.joinV (sterm E.?. StudyTermsName)
+            )
+      E.||. (       E.just (candidate E.^. StudyTermNameCandidateKey)  E.==. ssubterm E.?. StudySubTermsKey
+              E.&&. E.just (candidate E.^. StudyTermNameCandidateName) E.==. E.joinV (ssubterm E.?. StudySubTermsName)
+            )
     return candidate
   -- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
-  forM_ redundants $ \Entity{entityVal=StudyTermCandidate{..}} ->
+  forM_ redundants $ \Entity{entityVal=StudyTermNameCandidate{..}} ->
-    deleteWhere $   ( StudyTermCandidateIncidence ==. studyTermCandidateIncidence )
+    deleteWhere $   ( StudyTermNameCandidateIncidence ==. studyTermNameCandidateIncidence )
-                :  ([ StudyTermCandidateKey       ==. studyTermCandidateKey       ]
+                :  ([ StudyTermNameCandidateKey       ==. studyTermNameCandidateKey       ]
-                ||. [ StudyTermCandidateName      ==. studyTermCandidateName      ])
+                ||. [ StudyTermNameCandidateName      ==. studyTermNameCandidateName      ])
   return redundants
 
 
@@ -127,9 +132,10 @@ removeRedundant = do
 acceptSingletons :: DB [(STKey,Text)]
 acceptSingletons = do
   knownKeys <- fmap unStudyTermsKey <$> selectKeysList [StudyTermsName !=. Nothing] [Asc StudyTermsKey]
+  knownSubKeys <- fmap unStudySubTermsKey <$> selectKeysList [StudySubTermsName !=. Nothing] [Asc StudySubTermsKey]
   -- let knownKeysSet = Set.fromAscList knownKeys
   -- In case of memory problems, change next lines to conduit proper:
-  incidences <- fmap entityVal <$> selectList [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 ++ knownSubKeys] [] -- 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 +145,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
@@ -162,7 +168,13 @@ acceptSingletons = do
 
       -- registerFixed :: (STKey, Text) -> DB (Key StudyTerms)
       registerFixed :: (STKey, Text) -> DB ()
-      registerFixed (key, name) = repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name)
+      registerFixed (key, name) = do
+        isSub <- is _Just <$> get (StudySubTermsKey' key)
+        if
+          | isSub
+            -> repsert (StudySubTermsKey' key) $ StudySubTerms key Nothing Nothing (Just name)
+          | otherwise
+            -> repsert (StudyTermsKey' key) $ StudyTerms key Nothing (Just name) Nothing Nothing
 
   -- register newly fixed candidates
   forM_ fixedKeys registerFixed
@@ -170,18 +182,31 @@ acceptSingletons = do
 
 
 -- | all existing StudyTerms that are contradiced by current observations
-conflicts :: DB [Entity StudyTerms]
+conflicts :: DB [Either (Entity StudySubTerms) (Entity StudyTerms)]
-conflicts = E.select $ E.from $ \studyTerms -> do
+conflicts = (++) <$> fmap (map Left) conflictingSubTerms <*> fmap (map Right) conflictingTerms
-  E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName
+  where
-  E.where_ $ E.exists $ E.from $ \candidateOne -> do
+    conflictingTerms = E.select $ E.from $ \studyTerms -> do
-    E.where_ $ candidateOne E.^. StudyTermCandidateKey E.==. studyTerms E.^. StudyTermsKey
+      E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName
-    E.where_ $ E.notExists . E.from $ \candidateTwo ->  do
+      E.where_ $ E.exists $ E.from $ \candidateOne -> do
-        E.where_ $ candidateTwo E.^. StudyTermCandidateIncidence E.==. candidateOne E.^. StudyTermCandidateIncidence
+        E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studyTerms E.^. StudyTermsKey
-        E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermCandidateName)
+        E.where_ $ E.notExists . E.from $ \candidateTwo ->  do
-  return studyTerms
+            E.where_ $ candidateTwo E.^. StudyTermNameCandidateIncidence E.==. candidateOne E.^. StudyTermNameCandidateIncidence
+            E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
+      return studyTerms
+    conflictingSubTerms = E.select $ E.from $ \studySubTerms -> do
+      E.where_ $ E.not_ $ E.isNothing $ studySubTerms E.^. StudySubTermsName
+      E.where_ $ E.exists $ E.from $ \candidateOne -> do
+        E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studySubTerms E.^. StudySubTermsKey
+        E.where_ $ E.notExists . E.from $ \candidateTwo ->  do
+            E.where_ $ candidateTwo E.^. StudyTermNameCandidateIncidence E.==. candidateOne E.^. StudyTermNameCandidateIncidence
+            E.where_ $ studySubTerms E.^. StudySubTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
+      return studySubTerms
+
 
 -- | retrieve all incidence keys having containing a certain @StudyTermKey @
-getIncidencesFor :: [Key StudyTerms] -> DB [E.Value TermCandidateIncidence]
+getIncidencesFor :: [Either (Key StudySubTerms) (Key StudyTerms)] -> DB [E.Value TermCandidateIncidence]
 getIncidencesFor 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 <&> either unStudySubTermsKey unStudyTermsKey

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
 

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,7 @@ makePrisms ''AuthResult
 
 makePrisms ''FormResult
 
-makeLenses_ ''StudyTermCandidate
+makeLenses_ ''StudyTermNameCandidate
 
 makeLenses_ ''FieldView
 makeLenses_ ''FieldSettings

templates/adminFeatures.cassius

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

templates/adminFeatures.hamlet

@@ -1,3 +1,4 @@
+$newline never
 <section>
   ^{degreeTable}
 <section>
@@ -10,8 +11,13 @@
       $else
         <h3>Studiengangseingträge mit beobachteten Konflikten:
         <ul>
-          $forall (Entity _ (StudyTerms ky _ nm)) <- infConflicts
+          $forall conflict <- infConflicts
-            <li> #{show ky} - #{foldMap id nm}
+            <li>
+              $case conflict
+                $of Right (Entity _ (StudyTerms ky _ nm _ _))
+                  #{show ky} - #{foldMap id nm}
+                $of Left (Entity _ (StudySubTerms ky _ _ nm))
+                  #{show ky} - #{foldMap id nm}
     ^{btnForm}
 
     <div .container>

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

@@ -42,11 +42,10 @@
               <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}