From 341de2d1e1307e7a1a756f0d3ca61a16dc575a67 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 28 Mar 2019 17:14:45 +0100 Subject: [PATCH 1/7] MessageLink added to Admin page --- src/Foundation.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Foundation.hs b/src/Foundation.hs index 6ca7c5128..96d829240 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1372,6 +1372,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 From df0b36a01b98d6e19dffcf4943487f96ddb95ba1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 29 Mar 2019 15:24:16 +0100 Subject: [PATCH 2/7] StudyTermCandidates Deletion Buttons --- messages/uniworx/de.msg | 14 ++++++-- src/Handler/Admin.hs | 55 +++++++++++++++++++---------- src/Handler/Utils/Table/Cells.hs | 4 +++ src/Handler/Utils/TermCandidates.hs | 7 ++-- src/Utils.hs | 7 +++- 5 files changed, 64 insertions(+), 23 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 92b904a09..5e3b77421 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} @@ -439,10 +447,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 +460,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/src/Handler/Admin.hs b/src/Handler/Admin.hs index 9d96a5802..067b17ccd 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,17 @@ 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))) + , ("isbad" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsId `E.in_` E.valList (Set.toList badKeys))) , ("name" , SortColumn (E.^. StudyTermsName)) , ("short" , SortColumn (E.^. StudyTermsShorthand)) ] 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 From bf083c985408d3668f56212c4abe2e926bbf6973 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 29 Mar 2019 17:24:00 +0100 Subject: [PATCH 3/7] Fix sorting new studyterms --- FragenSJ.txt | 38 --------------------------------- src/Database/Esqueleto/Utils.hs | 11 +++++++++- src/Handler/Admin.hs | 8 ++++--- 3 files changed, 15 insertions(+), 42 deletions(-) delete mode 100644 FragenSJ.txt 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/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index f3aec73aa..701ce9616 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -7,6 +7,7 @@ module Database.Esqueleto.Utils , SqlIn(..) , mkExactFilter, mkContainsFilter , anyFilter + , inList ) where import ClassyPrelude.Yesod hiding (isInfixOf, any, all) @@ -99,4 +100,12 @@ anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) -> t -> Set.Set Text-> E.SqlExpr (E.Value Bool) anyFilter fltrs needle criterias = F.foldr aux false fltrs where - aux fltr acc = fltr needle criterias E.||. acc \ No newline at end of file + aux fltr acc = fltr needle criterias E.||. acc + +-- | Convenience for Sorting by a Column being element of a certain List +-- Does not work, may produce esqueleto error +-- `unsafeSqlBinOp: non-id/composite keys not expected here` somehow +inList :: (PersistField typ, PersistEntity val) + => EntityField val typ -> [typ] -> E.SqlExpr (Entity val) -> E.SqlExpr (E.Value Bool) +inList _column [] = const $ E.val True +inList column l = \row -> row E.^. column `E.in_` E.valList l diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 067b17ccd..2322fb0a9 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -404,8 +404,8 @@ postAdminFeaturesR = do ] dbtSorting = Map.fromList [ ("key" , SortColumn (E.^. StudyTermsKey)) - , ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsId `E.in_` E.valList (Set.toList newKeys))) - , ("isbad" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsId `E.in_` E.valList (Set.toList badKeys))) + , ("isnew" , SortColumn (StudyTermsKey `E.inList` (unStudyTermsKey <$> Set.toList newKeys))) + , ("isbad" , SortColumn (StudyTermsKey `E.inList` (unStudyTermsKey <$> Set.toList badKeys))) , ("name" , SortColumn (E.^. StudyTermsName)) , ("short" , SortColumn (E.^. StudyTermsShorthand)) ] @@ -413,7 +413,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 = From 3bb5b6c7fb170e361406dcf438447cfdb130af0d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 29 Mar 2019 17:37:29 +0100 Subject: [PATCH 4/7] Minor refactor --- src/Database/Esqueleto/Utils.hs | 11 +---------- src/Handler/Admin.hs | 5 +++-- 2 files changed, 4 insertions(+), 12 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 701ce9616..f3aec73aa 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -7,7 +7,6 @@ module Database.Esqueleto.Utils , SqlIn(..) , mkExactFilter, mkContainsFilter , anyFilter - , inList ) where import ClassyPrelude.Yesod hiding (isInfixOf, any, all) @@ -100,12 +99,4 @@ anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) -> t -> Set.Set Text-> E.SqlExpr (E.Value Bool) anyFilter fltrs needle criterias = F.foldr aux false fltrs where - aux fltr acc = fltr needle criterias E.||. acc - --- | Convenience for Sorting by a Column being element of a certain List --- Does not work, may produce esqueleto error --- `unsafeSqlBinOp: non-id/composite keys not expected here` somehow -inList :: (PersistField typ, PersistEntity val) - => EntityField val typ -> [typ] -> E.SqlExpr (Entity val) -> E.SqlExpr (E.Value Bool) -inList _column [] = const $ E.val True -inList column l = \row -> row E.^. column `E.in_` E.valList l + aux fltr acc = fltr needle criterias E.||. acc \ No newline at end of file diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 2322fb0a9..2ee38518b 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -404,8 +404,9 @@ postAdminFeaturesR = do ] dbtSorting = Map.fromList [ ("key" , SortColumn (E.^. StudyTermsKey)) - , ("isnew" , SortColumn (StudyTermsKey `E.inList` (unStudyTermsKey <$> Set.toList newKeys))) - , ("isbad" , SortColumn (StudyTermsKey `E.inList` (unStudyTermsKey <$> Set.toList badKeys))) + , ("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)) ] From f5fb82de3ede68e00c30345b1d925d3d69dfa195 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 30 Mar 2019 17:05:54 +0100 Subject: [PATCH 5/7] Improve term creation/editing --- messages/uniworx/de.msg | 1 + routes | 2 +- src/Handler/Course.hs | 4 +- src/Handler/Term.hs | 33 +++++++++++------ src/Handler/Utils/Form/MassInput.hs | 39 ++++++++++++++++++-- src/Utils/Form.hs | 3 ++ templates/widgets/massinput/list/cell.hamlet | 3 ++ 7 files changed, 66 insertions(+), 19 deletions(-) create mode 100644 templates/widgets/massinput/list/cell.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5e3b77421..5ecb2a00e 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -44,6 +44,7 @@ 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 TermLectureStart: Beginn Vorlesungen TermLectureEnd: Ende Vorlesungen TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Wintersemester 15 Wochen. 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/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 31ab90653..6fbfa6c9e 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 @@ -194,7 +196,7 @@ termEditHandler term = do defaultLayout $ do setTitleI MsgTermEditHeading wrapForm formWidget def - { formAction = Just $ SomeRoute TermEditR + { formAction = Just $ SomeRoute eHandler , formEncoding = formEnctype } @@ -247,14 +249,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 (\_ -> "") (\_ -> 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/Utils/Form.hs b/src/Utils/Form.hs index 4ebf3d1bb..0d055bbf4 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -108,6 +108,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} From 066328c56c02c309369614acbb3ab48696dc07cd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 30 Mar 2019 18:50:16 +0100 Subject: [PATCH 6/7] TermHoliday Placeholder --- messages/uniworx/de.msg | 1 + src/Handler/Term.hs | 2 +- src/Utils/Form.hs | 5 +++++ 3 files changed, 7 insertions(+), 1 deletion(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5ecb2a00e..2c90d5524 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -45,6 +45,7 @@ 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. diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 6fbfa6c9e..64f7725a0 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -255,7 +255,7 @@ newTermForm template html = do = aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid | otherwise = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing - holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (\_ -> "") (\_ -> Nothing) (fslI MsgTermHolidays) True (tftHolidays template) mempty + holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (\_ -> "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (\_ -> Nothing) (fslI MsgTermHolidays) True (tftHolidays template) mempty (result, widget) <- flip (renderAForm FormStandard) html $ Term <$> tidForm <*> areq dayField (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 0d055bbf4..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" From 790c1b9433cc819cf7941e57457d1931f0c2104b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 30 Mar 2019 19:25:19 +0100 Subject: [PATCH 7/7] Quiet hlint --- src/Handler/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 64f7725a0..98085d947 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -255,7 +255,7 @@ newTermForm template html = do = aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid | otherwise = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing - holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (\_ -> "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (\_ -> Nothing) (fslI MsgTermHolidays) True (tftHolidays template) mempty + 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 <$> tidForm <*> areq dayField (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)