From 1f9a5e377d741886593246441827ccf3e5f9f108 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 22 Mar 2022 17:13:40 +0100 Subject: [PATCH] chore(lms): lms overview cleaned --- .../categories/qualification/de-de-formal.msg | 3 +- .../categories/qualification/en-eu.msg | 3 +- .../utils/navigation/menu/de-de-formal.msg | 4 ++- .../uniworx/utils/navigation/menu/en-eu.msg | 4 ++- routes | 1 + src/Foundation/Navigation.hs | 36 +++++++++++++++++++ src/Handler/LMS.hs | 32 ++++++++++------- templates/lms.hamlet | 13 ++++++- 8 files changed, 78 insertions(+), 18 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index fa4fc8214..322e768b4 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -20,4 +20,5 @@ LmsResultInsert: Neues LMS Ergebnis LmsResultUpdate: LMS Ergebnis aktualisierung LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel -LmsDirectUpload: Direkter Upload für automatisierte Systeme \ No newline at end of file +LmsDirectUpload: Direkter Upload für automatisierte Systeme +QualificationDescription: Beschreibung \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index c6391e536..887571665 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -20,4 +20,5 @@ LmsResultInsert: New LMS result LmsResultUpdate: Update of LMS result LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key -LmsDirectUpload: Direct upload for automated Systems \ No newline at end of file +LmsDirectUpload: Direct upload for automated Systems +QualificationDescription: Description \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index c9cf02674..f16b9310d 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -125,7 +125,9 @@ MenuLanguage: Sprache MenuQualification: Qualifkationen MenuLms: Schnittstelle E-Lernen +MenuLmsEdit: Bearbeiten E-Lernen MenuLmsUsers: Empfang E-Lernen Benutzer MenuLmsUserlist: Melden E-Lernen Benutzer MenuLmsResult: Melden Ergebnisse E-Lernen -MenuLmsUpload: Direkter Upload \ No newline at end of file +MenuLmsUpload: Hochladen +MenuLmsDirect: Direkter Upload \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index f29b95c77..8ecc3918d 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -126,7 +126,9 @@ MenuLanguage: Language MenuQualification: Qualifcations MenuLms: Interface E-Learning +MenuLmsEdit: Edit E-Learning MenuLmsUsers: Download E-Learning Users MenuLmsUserlist: Upload E-Learning Users MenuLmsResult: Upload E-Learning Results -MenuLmsUpload: Direct Upload \ No newline at end of file +MenuLmsUpload: Upload +MenuLmsDirect: Direct Upload diff --git a/routes b/routes index 3da507604..b068df1ed 100644 --- a/routes +++ b/routes @@ -258,6 +258,7 @@ /lms LmsAllR GET /lms/#SchoolId LmsSchoolR GET /lms/#SchoolId/#QualificationShorthand LmsR GET POST +/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST /lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET /lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index e726df70b..e8e65d895 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -140,6 +140,7 @@ breadcrumb (LmsSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBrea breadcrumb (LmsR ssh qsh) =useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ LmsSchoolR ssh) $ do guardM . lift . existsBy $ SchoolQualificationShort ssh qsh return (CI.original qsh, Just $ LmsSchoolR ssh) +breadcrumb (LmsEditR ssh qsh) = i18nCrumb MsgMenuLmsEdit $ Just $ LmsR ssh qsh breadcrumb (LmsUsersR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsR ssh qsh breadcrumb (LmsUsersDirectR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsUsersR ssh qsh -- never displayed, TypedContent breadcrumb (LmsUserlistR ssh qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR ssh qsh @@ -428,6 +429,15 @@ makeLenses_ ''NavLink instance RenderMessage UniWorX NavLink where renderMessage app ls NavLink{..} = renderMessage app ls navLabel +-- | NavLink default with most common settings +defNavLink :: (RenderMessage UniWorX msg, HasRoute UniWorX route) => msg -> route -> NavLink +defNavLink navLabel navRoute = NavLink {..} + where + navAccess' = NavAccessTrue + navType = NavTypeLink { navModal = False} + navQuick' = mempty + navForceActive = False + navBaseRoute :: NavLink -> Route UniWorX navBaseRoute NavLink{navRoute} = urlRoute navRoute @@ -2392,6 +2402,32 @@ pageActions ParticipantsListR = return , navChildren = [] } ] +pageActions (LmsR sid qsh) = return + [ NavPageActionPrimary + { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh + , navChildren = + [ defNavLink MsgMenuLmsDirect $ LmsUsersDirectR sid qsh + ] + } + , NavPageActionPrimary + { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh + , navChildren = + [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh + , defNavLink MsgMenuLmsDirect $ LmsUserlistDirectR sid qsh + ] + } + , NavPageActionPrimary + { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh + , navChildren = + [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh + , defNavLink MsgMenuLmsDirect $ LmsResultDirectR sid qsh + ] + } + , NavPageActionSecondary { + navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh + } + ] + pageActions _ = return [] submissionList :: ( MonadIO m diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 7b8c5618a..5671b0613 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -8,6 +8,7 @@ module Handler.LMS ( getLmsAllR , getLmsSchoolR , getLmsR , postLmsR + , getLmsEditR , postLmsEditR , getLmsUsersR , getLmsUsersDirectR , getLmsUserlistR , postLmsUserlistR , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR @@ -39,6 +40,13 @@ getLmsAllR = error "TODO" getLmsSchoolR :: SchoolId -> Handler Html getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-school", toPathPiece ssh)]) + +getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html +getLmsEditR = postLmsEditR +postLmsEditR = error "TODO" + + + {- --redirect with filering getLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR ssh qsh = redirect (LmsAllR, [("qualification-school" , toPathPiece ssh) @@ -204,8 +212,7 @@ mkLmsTable qid = do dbtRowKey = queryLmsResult >>> (E.^. LmsResultId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "school") (i18nCell MsgTableSchool) $ \(view $ resultQualification . _entityVal . _qualificationSchool -> schoolShorthand) -> wgtCell $ toWgt schoolShorthand - , sortable (Just "user") (i18nCell MsgTableLmsUser) $ -- \(preview resultUser -> entuser) -> maybeCell entuser (cellHasUserLink AdminUserR) + [ sortable (Just "user") (i18nCell MsgTableLmsUser) $ -- \(preview resultUser -> entuser) -> maybeCell entuser (cellHasUserLink AdminUserR) foldMap (cellHasUserLink AdminUserR) . (^? resultUser) , sortable (Just "email") (i18nCell MsgTableEmail) $ -- \(preview $ resultUser . _entityVal -> user) -> maybeCell user cellHasEMail foldMap cellHasEMail . (^? resultUser) @@ -213,23 +220,20 @@ mkLmsTable qid = do , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success ] -- TODO: add more columns for manual debugging view !!! dbtSorting = Map.fromList - [ ("school" , SortColumn $ queryQualification >>> (E.^. QualificationSchool)) - , ("user" , SortColumn $ queryUser >>> (E.?. UserDisplayName)) + [ ("user" , SortColumn $ queryUser >>> (E.?. UserDisplayName)) , ("email" , SortColumn $ queryUser >>> (E.?. UserEmail)) , (csvLmsIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent)) -- , (csvLmsSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) , (csvLmsSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess)) ] dbtFilter = Map.fromList - [ ("school" , FilterColumn . E.mkExactFilter $ views (to queryQualification) (E.^. QualificationSchool)) - , ("user" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryUser) (E.?. UserDisplayName)) + [ ("user" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryUser) (E.?. UserDisplayName)) , ("email" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryUser) (E.?. UserEmail)) , (csvLmsIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent)) , (csvLmsSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess)) ] dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter "school" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgTableCourseSchool) - , prismAForm (singletonFilter "user" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsUser) + [ prismAForm (singletonFilter "user" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsUser) , prismAForm (singletonFilter "email" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableEmail) , prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess) @@ -249,9 +253,11 @@ mkLmsTable qid = do getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do - lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkLmsTable qid - siteLayoutMsg MsgMenuLmsResult $ do - setTitleI MsgMenuLmsResult + (lmsTable, quali) <- runDB $ do + Entity qid quali <- getBy404 $ SchoolQualificationShort sid qsh + tbl <- view _2 <$> mkLmsTable qid + return (tbl, quali) + let heading = citext2widget $ qualificationName quali + siteLayout heading $ do + setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh $(widgetFile "lms") diff --git a/templates/lms.hamlet b/templates/lms.hamlet index b04cf5204..b384cbd5c 100644 --- a/templates/lms.hamlet +++ b/templates/lms.hamlet @@ -1,10 +1,21 @@ -LMS Overview +$newline never +
+ $maybe descr <- qualificationDescription quali +
_{MsgQualificationDescription} +
+
+ #{descr} +