Merge branch 'master' into feat/transaction-log

FragenSJ.txt

@@ -1,38 +0,0 @@
-** Sicherheitsabfragen?
- - Verschlüsselung des Zugriffs?
-
- - SDelR tid csh sn : GET zeigt Sicherheitsabfrage
-                          POST löscht.
-  Ist das so sinnvoll?
-  Sicherheitsabfrage als PopUpMessage?
-
- - Utils.getKeyBy404 effiziente Variante, welche nur den Key liefert? Esq?
-    (Sheet.hs -> fetchSheet)
-
- - Handler.Sheet.postSDelR: deleteCascade für Files? Klappt das?
-  Kann man abfragen, was bei deleteCascade alles gelöscht wird?
-
-
-
-** i18n:
- - i18n der
-      Links       -> MenuItems verwenden wie bisher
-      Page Titles -> setTitleI
-      Buttons?    -> Kann leicht geändert werden!
-   Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getTermCourseListR, Zeile 66 "pageActions" für menuItemLabel?
-
-** Page pageActions  - Berechtigungen prüfen?
- => Eigener Constructor statt NavbarLeft/Right?!
-
-
-** FORMS
- 3 - Sheets: Multiple Files -> wird später gemacht
-   - Versionen für Studenten/Korrektoren/Lecturers/Admins
-     -> ja über isAuthorizedDB siehe unten,
-     -> Lecturer kann gleich auf Edit-Seite gehen wie in UniWorX
-
-
-Freischaltung von Teilen einer Webseite:
- - Freigabe der Links über Authorisierung in der Foundation
- - Anzeige der Links nach Authorisierung wie in menItemAccessCallback
- - möglichst direkt isAuthorizedDB in einem runDB aufrufen!!!

messages/uniworx/de.msg

@@ -5,6 +5,9 @@ BtnRegister: Anmelden
 BtnDeregister: Abmelden
 BtnHijack: Sitzung übernehmen
 BtnSave: Speichern
+BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
+BtnCandidatesDeleteConflicts: Konflikte löschen
+BtnCandidatesDeleteAll: Alle Beobachtungen löschen
 
 Aborted: Abgebrochen
 Remarks: Hinweise
@@ -15,6 +18,11 @@ RegisterFrom: Anmeldungen von
 RegisterTo: Anmeldungen bis
 DeRegUntil: Abmeldungen bis
 
+GenericKey: Schlüssel
+GenericShort: Kürzel
+GenericIsNew: Neu
+GenericHasConflict: Konflikt
+
 SummerTerm year@Integer: Sommersemester #{display year}
 WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
 SummerTermShort year@Integer: SoSe #{display year}
@@ -36,6 +44,8 @@ TermStartDay: Erster Tag
 TermStartDayTooltip: Üblicherweise immer 1.April oder 1.Oktober
 TermEndDay: Letzter Tag
 TermEndDayTooltip: Üblicherweise immer 30.September oder 31.März
+TermHolidays: Feiertage
+TermHolidayPlaceholder: Feiertag
 TermLectureStart: Beginn Vorlesungen
 TermLectureEnd: Ende Vorlesungen
 TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Wintersemester 15 Wochen.
@@ -439,10 +449,10 @@ StudyFeatureType:
 StudyFeatureValid: Aktiv
 StudyFeatureUpdate: Abgeglichen
 
-DegreeKey: Schlüssel Abschluss
+DegreeKey: Abschlussschlüssel
 DegreeName: Abschluss
 DegreeShort: Abschlusskürzel
-StudyTermsKey: Schlüssel Studiengang
+StudyTermsKey: Studiengangschlüssel
 StudyTermsName: Studiengang
 StudyTermsShort: Studiengangkürzel
 StudyTermsChangeSuccess: Zuordnung Abschlüsse aktualisiert
@@ -452,6 +462,8 @@ AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat
 RedundantCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Kandidat" "bekannte Kandiaten"} entfernt
 CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
 NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
+AllIncidencesDeleted: Alle 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
 

routes

@@ -59,7 +59,7 @@
 /term                      TermShowR         GET             !free
 /term/current              TermCurrentR      GET             !free
 /term/edit                 TermEditR         GET POST
-/term/#TermId/edit         TermEditExistR    GET
+/term/#TermId/edit         TermEditExistR    GET POST
 !/term/#TermId             TermCourseListR   GET             !free
 !/term/#TermId/#SchoolId   TermSchoolCourseListR  GET        !free
 

src/Foundation.hs

@@ -1381,6 +1381,14 @@ pageActions (AdminR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuMessageList
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute MessageListR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   , MenuItem
       { menuItemType  = PageActionPrime
       , menuItemLabel = MsgErrMsgHeading

src/Handler/Admin.hs

@@ -204,7 +204,7 @@ postAdminTestR = do
     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 buttonAction) "" True Nothing
 
 
@@ -269,29 +269,34 @@ postAdminErrMsgR = do
 
 
 -- BEGIN - Buttons needed only for StudyTermCandidateManagement
-data ButtonInferStudyTerms = ButtonInferStudyTerms
+data ButtonAdminStudyTerms
+  = BtnCandidatesInfer
+  | BtnCandidatesDeleteConflicts
+  | BtnCandidatesDeleteAll
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-instance Universe ButtonInferStudyTerms
+instance Universe ButtonAdminStudyTerms
-instance Finite ButtonInferStudyTerms
+instance Finite ButtonAdminStudyTerms
 
-nullaryPathPiece ''ButtonInferStudyTerms camelToPathPiece
+nullaryPathPiece ''ButtonAdminStudyTerms camelToPathPiece
+embedRenderMessage ''UniWorX ''ButtonAdminStudyTerms id
 
-instance Button UniWorX ButtonInferStudyTerms where
+instance Button UniWorX ButtonAdminStudyTerms where
-  btnLabel   ButtonInferStudyTerms = "Studienfachzuordnung automatisch lernen"
+  btnClasses BtnCandidatesInfer           = [BCIsButton, BCPrimary]
-  btnClasses ButtonInferStudyTerms = [BCIsButton, BCPrimary]
+  btnClasses BtnCandidatesDeleteConflicts = [BCIsButton, BCDanger]
+  btnClasses BtnCandidatesDeleteAll       = [BCIsButton, BCDanger]
 -- END Button needed only here
 
 getAdminFeaturesR, postAdminFeaturesR :: Handler Html
 getAdminFeaturesR = postAdminFeaturesR
 postAdminFeaturesR = do
-    ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonInferStudyTerms)
+    ((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,infAccepted) <- case btnResult of
-      FormSuccess ButtonInferStudyTerms -> do
+      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
@@ -301,6 +306,16 @@ postAdminFeaturesR = do
           | otherwise
             -> addMessageI Success . MsgCandidatesInferred $ length infAccepted
         return (infConflicts, infAccepted)
+      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
 
     (   (degreeResult,degreeTable)
@@ -308,6 +323,7 @@ postAdminFeaturesR = do
       , ((), candidateTable)) <- runDB $ (,,)
       <$> mkDegreeTable
       <*> mkStudytermsTable (Set.fromList $ map (StudyTermsKey' . fst) infAccepted)
+                            (Set.fromList $ map entityKey infConflicts)
       <*> mkCandidateTable
 
     -- This needs to happen after calls to `dbTable` so they can short-circuit correctly
@@ -352,7 +368,7 @@ postAdminFeaturesR = do
           dbtRowKey     = (E.^. StudyDegreeKey)
           dbtProj       = return
           dbtColonnade  = formColonnade $ mconcat
-            [ sortable (Just "key")   (i18nCell MsgDegreeKey)   (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
+            [ sortable (Just "key")   (i18nCell MsgGenericKey)  (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
             , sortable (Just "name")  (i18nCell MsgDegreeName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName))
             , sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand))
             , dbRow
@@ -366,11 +382,12 @@ postAdminFeaturesR = do
           dbtFilterUI   = mempty
           dbtParams     = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
                               }
-          psValidator   = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+          psValidator   = def  -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+                        & defaultSorting [SortAscBy "key"]
       in dbTable psValidator DBTable{..}
 
-    mkStudytermsTable :: Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
+    mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
-    mkStudytermsTable newKeys =
+    mkStudytermsTable newKeys badKeys =
       let dbtIdent      = "admin-studyterms" :: Text
           dbtStyle      = def
           dbtSQLQuery   :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery ( E.SqlExpr (Entity StudyTerms))
@@ -378,15 +395,18 @@ postAdminFeaturesR = do
           dbtRowKey     = (E.^. StudyTermsKey)
           dbtProj       = return
           dbtColonnade  = formColonnade $ mconcat
-            [ sortable (Just "key")   (i18nCell MsgStudyTermsKey)   (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
+            [ sortable (Just "key")   (i18nCell MsgGenericKey)         (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
-            , sortable (Just "isnew") (i18nCell MsgStudyTermIsNew)  (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
+            , sortable (Just "isnew") (i18nCell MsgGenericIsNew)       (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
-            , sortable (Just "name")  (i18nCell MsgStudyTermsName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
+            , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _entityKey))
-            , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
+            , sortable (Just "name")  (i18nCell MsgStudyTermsName)     (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
+            , sortable (Just "short") (i18nCell MsgStudyTermsShort)    (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
             , dbRow
             ]
           dbtSorting    = Map.fromList
             [ ("key"   , SortColumn (E.^. StudyTermsKey))
-            , ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsId `E.in_` E.valList (Set.toList newKeys)))
+            , ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsKey `E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys)))
+            -- 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))
             ]
@@ -394,7 +414,9 @@ postAdminFeaturesR = do
           dbtFilterUI   = mempty
           dbtParams     = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
                               }
-          psValidator   = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+          psValidator   = def
+                        -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+                        & defaultSorting [SortDescBy "isbad", SortDescBy "isnew", SortAscBy "key"]
       in dbTable psValidator DBTable{..}
 
     mkCandidateTable =

src/Handler/Course.hs

@@ -636,9 +636,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
         miDelete :: ListLength   -- ^ Current shape
                  -> ListPosition -- ^ Coordinate to delete
                  -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
-        miDelete l pos
+        miDelete = miDeleteList
-          | l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
-          | otherwise = return Map.empty
 
         miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
         miAllowAdd _ _ _ = True

src/Handler/Term.hs

@@ -3,14 +3,16 @@ module Handler.Term where
 import Import
 import Handler.Utils
 import Handler.Utils.Table.Cells
+import Handler.Utils.Form.MassInput
 import qualified Data.Map as Map
 
--- import qualified Data.Text as T
+import Utils.Lens
-import Yesod.Form.Bootstrap3
--- import Colonnade hiding (bool)
 
 import qualified Database.Esqueleto as E
 
+import qualified Data.Set as Set
+  
+
 -- | Default start day of term for season,
 --   @True@: start of term, @False@: end of term
 defaultDay :: Bool -> Season -> Day
@@ -148,7 +150,7 @@ getTermShowR = do
         setTitleI MsgTermsHeading
         $(widgetFile "terms")
 
-getTermEditR :: Handler Html
+getTermEditR, postTermEditR :: Handler Html
 getTermEditR = do
   mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
   let template = case mbLastTerm of
@@ -164,18 +166,18 @@ getTermEditR = do
               , tftEnd   = Just $ defaultDay False seas & setYear yr'
               }
   termEditHandler template
-
-postTermEditR :: Handler Html
 postTermEditR = termEditHandler mempty
 
-getTermEditExistR :: TermId -> Handler Html
+getTermEditExistR, postTermEditExistR :: TermId -> Handler Html
-getTermEditExistR tid = do
+getTermEditExistR = postTermEditExistR
+postTermEditExistR tid = do
   term <- runDB $ get tid
   termEditHandler $ termToTemplate term
 
 
 termEditHandler :: TermFormTemplate -> Handler Html
 termEditHandler term = do
+    Just eHandler <- getCurrentRoute
     ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
     case result of
       (FormSuccess res) -> do
@@ -196,7 +198,7 @@ termEditHandler term = do
     defaultLayout $ do
       setTitleI MsgTermEditHeading
       wrapForm formWidget def
-        { formAction = Just $ SomeRoute TermEditR
+        { formAction = Just $ SomeRoute eHandler
         , formEncoding = formEnctype
         }
 
@@ -249,14 +251,21 @@ termToTemplate (Just Term{..}) = TermFormTemplate
 newTermForm :: TermFormTemplate -> Form Term
 newTermForm template html = do
     mr <- getMessageRender
+    let
+      tidForm
+        | Just tid <- tftName template
+        = aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
+        | otherwise
+        = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing
+      holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const Nothing) (fslI MsgTermHolidays) True (tftHolidays template) mempty
     (result, widget) <- flip (renderAForm FormStandard) html $ Term
-      <$> areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template)
+      <$> tidForm
       <*> areq dayField  (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)
       <*> areq dayField  (fslI MsgTermEndDay   & setTooltip MsgTermEndDayTooltip)   (tftEnd   template)
-      <*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined
+      <*> (Set.toList . Set.fromList <$> holidayForm)
       <*> areq dayField  (fslI MsgTermLectureStart) (tftLectureStart template)
       <*> areq dayField  (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template)
-      <*> areq checkBoxField (bfs ("Aktiv" :: Text)) (tftActive template)
+      <*> areq checkBoxField (fslI MsgTermActive) (tftActive template)
     return $ case result of
       FormSuccess termResult
         | errorMsgs <- validateTerm termResult

src/Handler/Utils/Form/MassInput.hs

@@ -3,10 +3,11 @@
 module Handler.Utils.Form.MassInput
   ( MassInput(..)
   , massInput
+  , massInputList
   , BoxDimension(..)
   , IsBoxCoord(..), boxDimension
   , Liveliness(..)
-  , ListLength(..), ListPosition(..)
+  , ListLength(..), ListPosition(..), miDeleteList
   ) where
 
 import Import
@@ -29,7 +30,6 @@ import Data.List (genericLength, genericIndex, iterate)
 
 import Control.Monad.Trans.Maybe
 import Control.Monad.Reader.Class (MonadReader(local))
-import Control.Monad.Fix
 
 
 data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n)
@@ -96,6 +96,13 @@ instance Liveliness ListLength where
           max' = Set.lookupMax ns
   liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just 0) (1 <$ guard (n == 0)))
 
+
+miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
+miDeleteList l pos
+    -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
+  | l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
+  | otherwise = pure Map.empty
+
 data ButtonMassInput coord
   = MassInputAddDimension Natural coord
   | MassInputDeleteCell coord
@@ -205,7 +212,7 @@ massInput :: forall handler cellData cellResult liveliness.
            ( MonadHandler handler, HandlerSite handler ~ UniWorX
            , ToJSON cellData, FromJSON cellData
            , Liveliness liveliness
-           , MonadFix handler, MonadLogger handler
+           , MonadLogger handler
            )
           => MassInput handler liveliness cellData cellResult
           -> FieldSettings UniWorX
@@ -360,3 +367,29 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
     fvInput = $(widgetFile "widgets/massinput/massinput")
     fvErrors = Nothing
     in return (result, FieldView{..})
+
+
+-- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
+massInputList :: forall handler cellResult.
+                 ( MonadHandler handler, HandlerSite handler ~ UniWorX
+                 , MonadLogger handler
+                 )
+              => Field handler cellResult
+              -> (ListPosition -> FieldSettings UniWorX)
+              -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+              -> FieldSettings UniWorX
+              -> Bool
+              -> Maybe [cellResult]
+              -> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
+massInputList field fieldSettings miButtonAction miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
+  MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
+                return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvInput submitBtn)
+            , miCell = \pos () iRes nudge csrf ->
+                over _2 (\FieldView{..} -> $(widgetFile "widgets/massinput/list/cell")) <$> mreq field (fieldSettings pos & addName (nudge "field")) iRes
+            , miDelete = miDeleteList
+            , miAllowAdd = \_ _ _ -> True
+            , miButtonAction
+            }
+  miSettings
+  miRequired
+  (Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)

src/Handler/Utils/Table/Cells.hs

@@ -57,6 +57,10 @@ sqlCell act = mempty & cellContents .~ lift act
 tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
 tickmarkCell = cell . toWidget . hasTickmark
 
+-- | Maybe display an icon for tainted rows
+isBadCell :: (IsDBTable m a) => Bool -> DBCell m a
+isBadCell = cell . toWidget . isBad
+
 -- | Maybe display a exclamation icon
 isNewCell :: (IsDBTable m a) => Bool -> DBCell m a
 isNewCell = cell . toWidget . isNew

src/Handler/Utils/TermCandidates.hs

@@ -180,5 +180,8 @@ conflicts = E.select $ E.from $ \studyTerms -> do
         E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermCandidateName)
   return studyTerms
 
-
+-- | retrieve all incidence keys having containing a certain @StudyTermKey @
-
+getIncidencesFor :: [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)
+  return $ candidate E.^. StudyTermCandidateIncidence

src/Utils.hs

@@ -140,8 +140,13 @@ hasTickmark :: Bool -> Markup
 hasTickmark True  = [shamlet|<i .fas .fa-check>|]
 hasTickmark False = mempty
 
+isBad :: Bool -> Markup
+-- ^ Display an icon that denotes that something™ is bad
+isBad True  = [shamlet|<i .fas .fa-bolt>|] -- or times?!
+isBad False = mempty
+
 isNew :: Bool -> Markup
-isNew True  = [shamlet|<i .fas .fa-exclamation>|]
+isNew True  = [shamlet|<i .fas .fa-seedling>|] -- was exclamation
 isNew False = mempty
 
 

src/Utils/Form.hs

@@ -99,6 +99,11 @@ addAttrs attr valus fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
       | attr==a   = ( a, T.intercalate " " $ v : valus ) : t
       | otherwise = p : newAttrs t
 
+addPlaceholder :: Text -> FieldSettings site -> FieldSettings site
+addPlaceholder placeholder fs = fs { fsAttrs = (placeholderAttr, placeholder) : filter ((/= placeholderAttr) . fst) (fsAttrs fs) }
+  where
+    placeholderAttr = "placeholder"
+
 addClass :: Text -> FieldSettings site -> FieldSettings site
 addClass = addAttr "class"
 
@@ -108,6 +113,9 @@ addClasses = addAttrs "class"
 addName :: PathPiece p => p -> FieldSettings site -> FieldSettings site
 addName nm fs = fs { fsName = Just $ toPathPiece nm }
 
+addId :: PathPiece p => p -> FieldSettings site -> FieldSettings site
+addId fid fs = fs { fsId = Just $ toPathPiece fid }
+
 addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
 addNameClass gName gClass fs = fs { fsName = Just gName, fsAttrs = ("class",gClass) : fsAttrs fs }
 

templates/widgets/massinput/list/cell.hamlet

@@ -0,0 +1,3 @@
+$newline never
+#{csrf}
+^{fvInput}