diff --git a/FragenSJ.txt b/FragenSJ.txt deleted file mode 100644 index 6ddd8de2b..000000000 --- a/FragenSJ.txt +++ /dev/null @@ -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!!! diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 92b904a09..2c90d5524 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/routes b/routes index e2bf2976b..f76fd47b7 100644 --- a/routes +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index b099c86b5..9218d0729 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 9d96a5802..2ee38518b 100644 --- a/src/Handler/Admin.hs +++ b/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 Finite ButtonInferStudyTerms +instance Universe ButtonAdminStudyTerms +instance Finite ButtonAdminStudyTerms -nullaryPathPiece ''ButtonInferStudyTerms camelToPathPiece +nullaryPathPiece ''ButtonAdminStudyTerms camelToPathPiece +embedRenderMessage ''UniWorX ''ButtonAdminStudyTerms id -instance Button UniWorX ButtonInferStudyTerms where - btnLabel ButtonInferStudyTerms = "Studienfachzuordnung automatisch lernen" - btnClasses ButtonInferStudyTerms = [BCIsButton, BCPrimary] +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 - ((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 newKeys = + mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget) + 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 "isnew") (i18nCell MsgStudyTermIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey)) - , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName)) - , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand)) + [ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyTermsKey)) + , sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey)) + , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _entityKey)) + , 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 = diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index dc5d3fcaf..fd7ae019e 100644 --- a/src/Handler/Course.hs +++ b/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 - | 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 + miDelete = miDeleteList miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool miAllowAdd _ _ _ = True diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 4e5b059ac..7feeee791 100644 --- a/src/Handler/Term.hs +++ b/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 Yesod.Form.Bootstrap3 --- import Colonnade hiding (bool) +import Utils.Lens 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 tid = do +getTermEditExistR, postTermEditExistR :: TermId -> Handler Html +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 diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 6b9e35f1b..d1c403ec7 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/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) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 7abd6b4d7..28b3df6b2 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/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 diff --git a/src/Handler/Utils/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs index 5eeba9a56..c986ed61b 100644 --- a/src/Handler/Utils/TermCandidates.hs +++ b/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 diff --git a/src/Utils.hs b/src/Utils.hs index 018babd9d..f6ebd76d6 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -140,8 +140,13 @@ hasTickmark :: Bool -> Markup hasTickmark True = [shamlet||] hasTickmark False = mempty +isBad :: Bool -> Markup +-- ^ Display an icon that denotes that something™ is bad +isBad True = [shamlet||] -- or times?! +isBad False = mempty + isNew :: Bool -> Markup -isNew True = [shamlet||] +isNew True = [shamlet||] -- was exclamation isNew False = mempty diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 4ebf3d1bb..96dec5423 100644 --- a/src/Utils/Form.hs +++ b/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 } diff --git a/templates/widgets/massinput/list/cell.hamlet b/templates/widgets/massinput/list/cell.hamlet new file mode 100644 index 000000000..36caeb9ff --- /dev/null +++ b/templates/widgets/massinput/list/cell.hamlet @@ -0,0 +1,3 @@ +$newline never +#{csrf} +^{fvInput}