From 577399199aa4a08d285d90f3fe82bacc890b5129 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 23 Mar 2022 15:35:22 +0100 Subject: [PATCH] chore(lms): qualfication overview table stub working --- .../utils/navigation/menu/de-de-formal.msg | 2 +- .../uniworx/utils/navigation/menu/en-eu.msg | 2 +- src/Foundation/Navigation.hs | 2 +- src/Handler/LMS.hs | 166 ++++++------------ 4 files changed, 61 insertions(+), 111 deletions(-) diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 3cffcc93c..3f00c0168 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -123,7 +123,7 @@ MenuCourseEventNew: Neuer Kurstermin MenuCourseEventEdit: Kurstermin bearbeiten MenuLanguage: Sprache -MenuQualification: Qualifkationen +MenuQualifications: Qualifkationen MenuLms: Schnittstelle E-Lernen MenuLmsEdit: Bearbeiten E-Lernen MenuLmsUsers: Export E-Lernen Benutzer diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 8ecc3918d..d6a15dbdb 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -124,7 +124,7 @@ MenuCourseEventNew: New course occurrence MenuCourseEventEdit: Edit course occurrence MenuLanguage: Language -MenuQualification: Qualifcations +MenuQualifications: Qualifcations MenuLms: Interface E-Learning MenuLmsEdit: Edit E-Learning MenuLmsUsers: Download E-Learning Users diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index e8e65d895..19ddc3abf 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -133,7 +133,7 @@ breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed -breadcrumb LmsAllR = i18nCrumb MsgMenuQualification Nothing +breadcrumb LmsAllR = i18nCrumb MsgMenuQualifications Nothing breadcrumb (LmsSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs guardM . lift . existsBy . UniqueSchoolShorthand $ unSchoolKey ssh return (CI.original $ unSchoolKey ssh, Just LmsAllR) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 6019e1560..852d3559a 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -35,7 +35,64 @@ import Handler.LMS.Userlist as Handler.LMS import Handler.LMS.Result as Handler.LMS getLmsAllR :: Handler Html -getLmsAllR = error "TODO" +getLmsAllR = do + lmsTable <- runDB $ do + view _2 <$> mkLmsAllTable + siteLayoutMsg MsgMenuQualifications $ do + setTitleI MsgMenuQualifications + $(widgetFile "lms-all") + +x :: Int64 +x = 42 + +type AllQualificationTableData = DBRow (Entity Qualification, E.Value Int64) +queryAllQualification :: Lens' AllQualificationTableData Qualification +queryAllQualification = _dbrOutput . _1 . _entityVal + +mkLmsAllTable :: DB (Any, Widget) +mkLmsAllTable = do + let + resultDBTable = DBTable{..} + where + dbtSQLQuery = runReaderT $ do + quali <- view id + --count + return (quali, E.val x) + dbtRowKey = (E.^. QualificationId) + dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? + dbtColonnade = dbColonnade $ mconcat + [ colSchool $ queryAllQualification . _qualificationSchool + , sortable (Just "qualification-shorthand") (i18nCell MsgTableLmsIdent) $ \(view queryAllQualification -> quali) -> + let qsh = qualificationShorthand quali in + anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh + ] -- TODO: add more columns for manual debugging view !!! + dbtSorting = mconcat + [ + sortSchool $ to (E.^. QualificationSchool) + , singletonMap "qualification-shorthand" $ SortColumn (E.^. QualificationShorthand) + ] + dbtFilter = mconcat + [ + fltrSchool $ to (E.^. QualificationSchool) + ] + dbtFilterUI = mconcat + [ + fltrSchoolUI + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + dbtIdent :: Text + dbtIdent = "qualification-overview" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + resultDBTableValidator = def + & defaultSorting [SortAscBy "school", SortAscBy "qualification-shorthand"] + dbTable resultDBTableValidator resultDBTable + + + getLmsSchoolR :: SchoolId -> Handler Html getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-school", toPathPiece ssh)]) @@ -46,113 +103,6 @@ getLmsEditR = postLmsEditR postLmsEditR = error "TODO" - -{- --redirect with filering -getLmsR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsR ssh qsh = redirect (LmsAllR, [("qualification-school" , toPathPiece ssh) - ,("qualification-shorthand", toPathPiece qsh) - ]) --} - -{- -data LmsUserTableCsv = LmsUserTableCsv -- for csv export only - { csvLmsUserIdent :: LmsIdent - , csvLmsUserPin :: Text - , csvLmsUserReset, cvsLmsUserRemove, cvsLmsUserIntern :: Int - } - -data LmsCsvExportData = LmsCsvExportData - -type LmsUserTableExpr = E.SqlExpr (Entity LmsUser) - `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) - -type LmsUserTableData = DBRow ( Entity LmsUser - , Maybe (Entity User) - ) - -queryLmsUser :: Getter LmsUserTableExpr (E.SqlExpr (Entity LmsUser)) -queryLmsUser = to $(E.sqlLOJproj 2 1) - -queryUser :: Getter LmsUserTableExpr (E.SqlExpr (Maybe (Entity User))) -queryUser = to $(E.sqlLOJproj 2 2) - -resultLmsUser :: Lens' LmsUserTableData (Entity LmsUser) -resultLmsUser = _dbrOutput . _1 - -resultUser :: Lens' LmsUserTableData (Maybe (Entity User)) -resultUser = _dbrOutput . _2 - - -getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html -getLmsR = postLmsR -postLmsR sid qsh = do - _qid <- runDB . getKeyBy404 $ SchoolQualificationShort sid qsh - -- TODO !!! filter table by qid !!! - - dbtCsvName <- csvLmsUserFilename - let dbtIdent = "lmsUsers" :: Text - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtSQLQuery = runReaderT $ do - lmsUser <- view queryLmsUser - user <- view queryUser - lift $ do - E.on $ E.just (lmsUser E.^. LmsUserUser) E.==. user E.?. UserId - -- TODO where? - return (lmsUser, user) - dbtRowKey = queryLmsUser >>> (E.^. LmsUserId) - dbtProj = dbtProjSimple $ \(lmsUser, user) -> do - -- return ("abcdefgh", "12345678", False, False, True) - return ( lmsUser E.^. LmsUserIdent - , lmsUser E.^. LmsUserPin - , lmsUser E.^. LmsUserResetPin - , lmsUser E.^. LmsUserResetPin - -- , True) -- works, so we need a simple type here indeed - , isJust $ E.unValue (user E.?. UserCompanyPersonalNumber)) - dbtColonnade = mempty --TODO - dbtSorting = mempty - dbtFilter = mempty - dbtFilterUI = mempty - dbtParams = def - -- TODO: wip, for reference, see e.g. Handler.Course.Users or Handler.Exam. - dbtCsvEncode = do - return $ DBTCsvEncode - { dbtCsvExportForm = def - , dbtCsvDoEncode = \LmsCsvExportData{} -> C.mapM $ \(_lmsUserTableId, row) -> do - mitarbeiter <- return 1 - return $ LmsUserTableCsv - (row ^. resultUser . _entityVal . _lmsUserIdent) - (row ^. resultUser . _entityVal . _lmsUserPin) - (row ^. resultUser . _entityVal . _lmsUserResetPin . to fromEnum) - (row ^. resultUser . _entityVal . _lmsUserDelete . to fromEnum) - mitarbeiter - , dbtCsvName - , dbtCsvNoExportData = Nothing - , dbtCsvHeader = def -- return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def - , dbtCsvExampleData = Nothing - } - -- TODO wip, for reference see e.g. Handler.Exam.Users - dbtCsvDecode = Nothing -- Just DBTCsvDecode - -- { dbtCsvRowKey = _1 - -- , dbtCsvComputeActions = _2 - -- , dbtCsvClassifyAction = _3 - -- , dbtCsvCoarsenActionClass = _4 - -- , dbtCsvValidateActions = _5 - -- , dbtCsvExecuteActions = _6 -- <- actions based on sent data here - -- , dbtCsvRenderKey = _7 - -- , dbtCsvRenderActionClass = _8 - -- , dbtCsvRenderException = _9 - -- } - psValidator = def - lmsTable = dbTable psValidator DBTable{..} - - let lmsTable = [whamlet|TODO|] -- TODO: remove me, just for debugging - siteLayoutMsg MsgMenuLms $ do - setTitleI MsgMenuLms - $(widgetFile "lms") --} - ---- old above, new below - type LmsResultTableExpr = ( E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity LmsResult) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))