fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

revert(lms): back to working version of qualification table

Browse Source
This commit is contained in:
Steffen Jost 2022-04-01 15:35:51 +02:00
parent 5d8614cc1a
commit 8991bdd41f
1 changed files with 41 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
src/Handler/LMS.hs
View File

@ -45,90 +45,66 @@ getLmsAllR = do
setTitleI MsgMenuQualifications setTitleI MsgMenuQualifications
$(widgetFile "lms-all") $(widgetFile "lms-all")
type AllQualicationTableExpr = E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity QualificationUser) type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64)
queryAllQualification :: IndexPreservingGetter AllQualicationTableExpr (E.SqlExpr (Entity Qualification)) queryAllQualification :: Lens' AllQualificationTableData Qualification
queryAllQualification = to $(sqlIJproj 2 1) queryAllQualification = _dbrOutput . _1 . _entityVal
queryAllQualificationUser :: IndexPreservingGetter AllQualicationTableExpr (E.SqlExpr (Entity QualificationUser)) mkLmsAllTable :: DB (Any, Widget)
queryAllQualificationUser = to $(sqlIJproj 2 2)
type AllQualificationTableData = DBRow (Entity Qualification, Entity QualificationUser) -- E.Value Word64)
resultAllQualification :: Lens' AllQualificationTableData (Entity Qualification)
resultAllQualification = _dbrOutput . _1
--resultAllQualificationCount :: Lens' AllQualificationTableData Word64
--resultAllQualificationCount = _dbrOutput . _2 . _unValue
resultAllQualificationUser :: Lens' AllQualificationTableData (Entity QualificationUser)
resultAllQualificationUser = _dbrOutput . _2
mkLmsAllTable :: DB (Widget)
mkLmsAllTable = do mkLmsAllTable = do
let let
resultDBTable = DBTable{..} resultDBTable = DBTable{..}
where where
dbtSQLQuery :: AllQualicationTableExpr -> E.SqlQuery _ dbtSQLQuery quali = do
dbtSQLQuery = runReaderT $ do -- 1. Just a constant dummy for debugging:
quali <- view queryAllQualification -- let x = E.val (42::Word64)
quser <- view queryAllQualificationUser -- return (quali, x)
lift $ do --
-- 1. Just a constant dummy for debugging: -- 2. SubSelect with old syntax:
-- let x = E.val (42::Word64) -- x <- pure . E.subSelectCount . E.from $ \quser ->
-- return (quali, x) -- E.where_ $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
-- -- return (quali, x)
-- 2. SubSelect with old syntax: --
-- x <- pure . E.subSelectCount . E.from $ \quser -> -- 3. SubSelect with new syntax:
-- E.where_ $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId x <- pure . Ex.subSelectCount $ do
-- return (quali, x) quser <- Ex.from $ Ex.table @QualificationUser
-- Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
-- 3. SubSelect with new syntax: return (quali, x)
--x <- pure . Ex.subSelectCount $ do --
-- quser <- Ex.from $ Ex.table @QualificationUser -- 4. Join / GroupBy
-- Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId --Ex.on $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
--return (quali, x) --Ex.groupBy (quali E.^. QualificationId)
-- --return (quali, count $ quser E.^. QualificationUserId)
-- 4. Join / GroupBy dbtRowKey = (E.^. QualificationId)
E.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
-- E.groupBy (quali E.^. QualificationId)
return (quali, quser) -- E.count $ quser E.^. QualificationUserId)
dbtRowKey = views queryAllQualification (E.^. QualificationId)
dbtProj :: _ AllQualificationTableData
dbtProj = dbtProjId -- dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
dbtColonnade = mconcat
[
sortable (Just "qualification-school") (i18nCell MsgTableLmsIdent) $ \(view resultAllQualification -> Entity _ quali) ->
let qsh = qualificationShorthand quali
in anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh
]
dbtSorting = mempty
dbtFilter = mempty
dbtFilterUI = mempty
{-
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ colSchool $ resultAllQualification . _qualificationSchool [ colSchool $ queryAllQualification . _qualificationSchool
, sortable (Just "qualification-short") (i18nCell MsgTableLmsIdent) $ \(view resultAllQualification -> quali) -> , sortable (Just "qualification-short") (i18nCell MsgTableLmsIdent) $ \(view queryAllQualification -> quali) ->
let qsh = qualificationShorthand quali in let qsh = qualificationShorthand quali in
anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh
, sortable Nothing (i18nCell MsgTableLmsUser) $ \(view $ _dbrOutput . _1 . _entityKey -> qualid) -> sqlCell $ do
num <- fmap (maybe 0 (max 0 . Ex.unValue) . listToMaybe) .
Ex.select $ do
quser <- Ex.from $ Ex.table @QualificationUser
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qualid
pure Ex.countRows
return $ word2widget num
, sortable Nothing (i18nCell MsgMenuAdminTest) $ \(view $ _dbrOutput . _2 . _unValue -> n) -> wgtCell $ word2widget n , sortable Nothing (i18nCell MsgMenuAdminTest) $ \(view $ _dbrOutput . _2 . _unValue -> n) -> wgtCell $ word2widget n
] -- TODO: add more columns for manual debugging view !!! ] -- TODO: add more columns for manual debugging view !!!
dbtSorting = mconcat dbtSorting = mconcat
[ [
sortSchool $ views queryAllQualification (E.^. QualificationSchool) sortSchool $ to (E.^. QualificationSchool)
, singletonMap "qualification-short" $ SortColumn $ views queryAllQualification (E.^. QualificationShorthand) , singletonMap "qualification-short" $ SortColumn (E.^. QualificationShorthand)
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ [
fltrSchool $ views queryAllQualification (E.^. QualificationSchool) fltrSchool $ to (E.^. QualificationSchool)
] ]
dbtFilterUI = mconcat dbtFilterUI = mconcat
[ [
fltrSchoolUI fltrSchoolUI
] ]
-} dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def dbtParams = def
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "qualification-overview" dbtIdent = "qualification-overview"
@ -137,7 +113,7 @@ mkLmsAllTable = do
dbtExtraReps = [] dbtExtraReps = []
resultDBTableValidator = def resultDBTableValidator = def
-- & defaultSorting [SortAscBy "school", SortAscBy "qualification-short"] & defaultSorting [SortAscBy "school", SortAscBy "qualification-short"]
dbTable resultDBTableValidator resultDBTable dbTable resultDBTableValidator resultDBTable
@ -249,7 +225,7 @@ getLmsR = postLmsR
postLmsR sid qsh = do postLmsR sid qsh = do
(lmsTable, quali) <- runDB $ do (lmsTable, quali) <- runDB $ do
Entity qid quali <- getBy404 $ SchoolQualificationShort sid qsh Entity qid quali <- getBy404 $ SchoolQualificationShort sid qsh
tbl <- mkLmsTable qid tbl <- view _2 <$> mkLmsTable qid
return (tbl, quali) return (tbl, quali)
let heading = citext2widget $ qualificationName quali let heading = citext2widget $ qualificationName quali
siteLayout heading $ do siteLayout heading $ do