fix(dbtable): fix pagination bug

This commit is contained in:
Steffen Jost 2023-03-01 17:40:55 +01:00
parent 6bbcc2006b
commit b43f2364bb
9 changed files with 43 additions and 132 deletions

1
routes
View File

@ -269,7 +269,6 @@
/lms LmsAllR GET POST
/lms/#SchoolId LmsSchoolR GET
/lms/#SchoolId/#QualificationShorthand LmsR GET POST
/lms/#SchoolId/#QualificationShorthand/limit/#Int64/skip/#Int64 LmsLSR GET POST -- FIXME Pagination does not work here somehow
/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET
/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS

View File

@ -175,9 +175,6 @@ 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 (LmsLSR 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
@ -2329,48 +2326,6 @@ pageActions (LmsR sid qsh) = return
-- navLink = defNavLink MsgMenuLmsFake $ LmsFakeR sid qsh
-- }
]
pageActions (LmsLSR sid qsh pagLimit pagOffset) = return
[ NavPageActionPrimary
{ navLink = defNavLink MsgMenuPrevPage $ LmsLSR sid qsh pagLimit $ pred pagOffset
, navChildren =
[ defNavLink MsgMenuPageIncrease $ LmsLSR sid qsh (pagLimit + 500) pagOffset
, defNavLink MsgMenuPageDecrease $ LmsLSR sid qsh (pagLimit - 500) pagOffset
]
}
, NavPageActionPrimary
{ navLink = defNavLink MsgMenuNextPage $ LmsLSR sid qsh pagLimit $ succ pagOffset
, navChildren =
[ defNavLink MsgMenuPageIncrease $ LmsLSR sid qsh (pagLimit + 500) pagOffset
, defNavLink MsgMenuPageDecrease $ LmsLSR sid qsh (pagLimit - 500) pagOffset
]
}
, NavPageActionPrimary
{ navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh
, navChildren =
[ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh
]
}
, NavPageActionPrimary
{ navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh
, navChildren =
[ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh
, defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh
]
}
, NavPageActionPrimary
{ navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh
, navChildren =
[ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh
, defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh
]
}
, NavPageActionSecondary {
navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh
}
-- , NavPageActionSecondary {
-- navLink = defNavLink MsgMenuLmsFake $ LmsFakeR sid qsh
-- }
]
pageActions ApiDocsR = return
[ NavPageActionPrimary
{ navLink = NavLink

View File

@ -35,30 +35,6 @@ import qualified Database.Esqueleto.Experimental as X (from, on) -- needs TypeAp
import qualified Database.Esqueleto.Utils as E
-- import Database.Esqueleto.Utils.TH
---------------------------
-- PAGINATION WORKAROUND --
data PaginationParameters = PaginationParameters { pagLimit, pagOffset:: Int64 }
deriving (Eq, Show)
instance Default PaginationParameters where
def = PaginationParameters { pagLimit = 100, pagOffset = 0}
makePaginationForm :: Maybe PaginationParameters -> Form PaginationParameters
makePaginationForm tmpl = identifyForm FIDPaginationWorkaround . validateForm validatePaginationForm $ \html ->
flip (renderAForm FormStandard) html $ PaginationParameters
<$> areq intField (fslI MsgPaginationSize) (pagLimit <$> tmpl)
<*> areq intField (fslI MsgPaginationPage) (pagOffset <$> tmpl)
validatePaginationForm :: FormValidator PaginationParameters Handler ()
validatePaginationForm = do
PaginationParameters{..} <- State.get
guardValidation MsgPaginationError $ pagLimit >= 0 && pagOffset >= 0
-- END PAGINATION WORKAROUND --
-------------------------------
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
@ -398,18 +374,14 @@ getProblemAvsSynchR = do
if oks < no_revokes
then addMessageI Error MsgRevokeUnknownLicencesFail
else addMessageI Info MsgRevokeUnknownLicencesOk
redirect ProblemAvsSynchR
currentRoute <- fromMaybe (error "getProblemsAvsSynchR called from 404-handler") <$> liftHandler getCurrentRoute
((fromMaybe def . formResultToMaybe -> pagResult, pagWidget), pagEnctype) <- runFormGet $ makePaginationForm def
let pagForm = wrapForm pagWidget def { formMethod = GET, formEncoding = pagEnctype, formAction = Just $ SomeRoute currentRoute }
redirect ProblemAvsSynchR
-- licence differences
((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,)
<$> mkLicenceTable pagResult "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
<*> mkLicenceTable pagResult "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
<*> mkLicenceTable pagResult "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld
<*> mkLicenceTable pagResult "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
<$> mkLicenceTable "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
<*> mkLicenceTable "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
<*> mkLicenceTable "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld
<*> mkLicenceTable "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
now <- liftIO getCurrentTime
let nowaday = utctDay now
@ -488,8 +460,8 @@ instance HasUser LicenceTableData where
hasUser = resultUser . _entityVal
mkLicenceTable :: PaginationParameters -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable PaginationParameters{..} dbtIdent aLic apids = do
mkLicenceTable :: Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable dbtIdent aLic apids = do
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
now <- liftIO getCurrentTime
@ -503,8 +475,7 @@ mkLicenceTable PaginationParameters{..} dbtIdent aLic apids = do
E.on $ qual E.?. QualificationId E.==. qualUser E.?. QualificationUserQualification
E.on $ user E.^. UserId E.=?. qualUser E.?. QualificationUserUser
E.on $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
E.where_ $ fltrLic qual E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids)
when (pagLimit > 0) $ E.limit pagLimit >> E.offset (pagLimit * pagOffset) -- TODO: why does pagination not work here?
E.where_ $ fltrLic qual E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids)
return (usrAvs, user, qualUser, qual)
dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR?
-- Not sure what changes here:

View File

@ -10,7 +10,6 @@ module Handler.LMS
( getLmsAllR , postLmsAllR
, getLmsSchoolR
, getLmsR , postLmsR
, getLmsLSR , postLmsLSR
, getLmsEditR , postLmsEditR
, getLmsUsersR , getLmsUsersDirectR
, getLmsUserlistR , postLmsUserlistR
@ -326,13 +325,13 @@ isRenewPinAct LmsActNotifyData = False
isRenewPinAct LmsActRenewNotifyData = True
isRenewPinAct LmsActRenewPinData = True
lmsTableQuery :: QualificationId -> LmsTableExpr -> Int64 -> Int64
lmsTableQuery :: QualificationId -> LmsTableExpr
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity LmsUser))
, E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
)
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) nlimit noffset = do
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do
-- RECALL: another outer join on PrintJob did not work out well, since
-- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting;
-- - using noExsists on printJob join condition works, but only deliver single value;
@ -341,7 +340,6 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) nlimit
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
when (nlimit > 0) $ E.limit nlimit >> E.offset (nlimit * noffset) -- FIXME Pagination does not work here somehow
-- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other!
-- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
@ -366,14 +364,13 @@ mkLmsTable :: forall h p cols act act'.
, Ord act, PathPiece act, RenderMessage UniWorX act
, AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols
)
=> Int64 -> Int64
-> Bool
=> Bool
-> Entity Qualification
-> Map act (AForm Handler act')
-> cols
-> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))
-> DB (FormResult (act', Set UserId), Widget)
mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do
mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
now <- liftIO getCurrentTime
currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here
let
@ -383,18 +380,18 @@ mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
dbtIdent :: Text
dbtIdent = "qualification"
dbtSQLQuery q = lmsTableQuery qid q nlimit noffset
dbtSQLQuery q = lmsTableQuery qid q
dbtRowKey = queryUser >>> (E.^. UserId)
--dbtProj = dbtProjFilteredPostId
dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
qusr <- view $ _dbtProjRow . resultQualUser
user <- view $ _dbtProjRow . resultUser
lusr <- preview $ _dbtProjRow . resultLmsUser
pjac <- preview $ _dbtProjRow . resultPrintAck
forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do
euid <- encrypt $ user ^. _entityKey
guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ ForProfileDataR euid -- TODO create a page with proper rights; this is only for admins!
return (qusr,user,lusr,E.Value pjac)
dbtProj = dbtProjFilteredPostId
-- dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
-- qusr <- view $ _dbtProjRow . resultQualUser
-- user <- view $ _dbtProjRow . resultUser
-- lusr <- preview $ _dbtProjRow . resultLmsUser
-- pjac <- preview $ _dbtProjRow . resultPrintAck
-- forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do
-- euid <- encrypt $ user ^. _entityKey
-- guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ ForProfileDataR euid -- TODO create a page with proper rights; this is only for admins!
-- return (qusr,user,lusr,E.Value pjac)
dbtColonnade = cols
dbtSorting = mconcat
@ -416,8 +413,8 @@ mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do
]
dbtFilter = mconcat
[ single ("may-access" , FilterProjected $ (_ltProjFilterMayAccess ?~) . getAny)
, single $ fltrUserNameEmail queryUser
[ --single ("may-access" , FilterProjected $ (_ltProjFilterMayAccess ?~) . getAny)
single $ fltrUserNameEmail queryUser
, single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent))
-- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB
-- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
@ -517,13 +514,7 @@ mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do
getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR
postLmsR sid qsh = redirect $ LmsLSR sid qsh 2000 0
getLmsLSR, postLmsLSR :: SchoolId -> QualificationShorthand -> Int64 -> Int64 -> Handler Html
getLmsLSR = postLmsLSR
postLmsLSR sid qsh nlimit noffset
| nlimit < 0 || noffset < 0 = redirect $ LmsLSR sid qsh 2000 0
| otherwise = do
postLmsR sid qsh = do
isAdmin <- hasReadAccessTo AdminR
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
@ -600,8 +591,8 @@ postLmsLSR sid qsh nlimit noffset
where
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
psValidator = def & forceFilter "may-access" (Any True)
tbl <- mkLmsTable nlimit noffset isAdmin qent acts colChoices psValidator
psValidator = def -- & forceFilter "may-access" (Any True)
tbl <- mkLmsTable isAdmin qent acts colChoices psValidator
return (tbl, qent)
formResult lmsRes $ \case

View File

@ -234,7 +234,7 @@ mkPJTable = do
, single ("course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName))
, single ("qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
, single ("lmsid" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob) (E.^. PrintJobLmsUser))
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
]
dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName)
@ -248,7 +248,7 @@ mkPJTable = do
, prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse)
, prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification)
, prismAForm (singletonFilter "lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser)
, prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
, prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
dbtIdent :: Text
@ -280,7 +280,7 @@ mkPJTable = do
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
return (act, jobSet)
psValidator = def & defaultSorting [SortAscBy "created"]
-- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: interferes with sorting!
-- & defaultFilter (singletonMap "acknowledged" [toPathPiece False]) -- TODO: sorting with Nothing restores this filter
over _1 postprocess <$> dbTable psValidator DBTable{..}
getPrintCenterR, postPrintCenterR :: Handler Html

View File

@ -1171,10 +1171,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool)))
filterSql = map (\(fc, args) -> ($ args) <$> filterColumn fc) $ psFilter'
selectPagesize = primarySortSql
&& all (is _Just) filterSql
-- selectPagesize = primarySortSql
-- && all (is _Just) filterSql
psLimit' = bool PagesizeAll psLimit selectPagesize
-- psLimit' = bool PagesizeAll psLimit selectPagesize
rows' <- E.select . E.from $ \t -> do
res <- dbtSQLQuery t
@ -1185,8 +1185,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
_other -> do
case previousKeys of
Nothing
| PagesizeLimit l <- psLimit'
, selectPagesize
| PagesizeLimit l <- psLimit
-- , selectPagesize
, hasn't (_FormSuccess . _DBCsvExport) csvMode
-> do
E.limit l
@ -1199,7 +1199,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
let mapMaybeM' f = mapMaybeM $ \(k, v) -> (,) <$> pure k <*> f v
firstRow :: Int64
firstRow
| PagesizeLimit l <- psLimit'
| PagesizeLimit l <- psLimit
= succ (psPage * l)
| otherwise
= 1
@ -1432,9 +1432,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
lift $ sendResponse =<< altRep
let
rowCount
| selectPagesize = fromMaybe 0 $ rows' ^? _head . _1 . _Value
| otherwise = olength64 rows
rowCount = fromMaybe 0 $ rows' ^? _head . _1 . _Value
-- | selectPagesize = fromMaybe 0 $ rows' ^? _head . _1 . _Value
-- | otherwise = olength64 rows
rawAction = tblLink
$ setParam (wIdent "sorting") Nothing
@ -1534,7 +1534,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
return $(widgetFile "table/colonnade")
pageCount
| PagesizeLimit l <- psLimit'
| PagesizeLimit l <- psLimit
= max 1 . ceiling $ rowCount % l
| otherwise
= 1
@ -1549,7 +1549,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
, formAnchor = Just $ wIdent "pagesize-form"
}
showPagesizeWdgt = toEnum (fromIntegral rowCount) > minimum (pagesizeOptions referencePagesize)
&& selectPagesize
-- && selectPagesize
csvWdgt = $(widgetFile "table/csv-transcode")

View File

@ -306,8 +306,7 @@ data FormIdentifier
| FIDAvsQueryLicence
| FIDAvsSetLicence
| FIDBtnAvsImportUnknown
| FIDBtnAvsRevokeUnknown
| FIDPaginationWorkaround
| FIDBtnAvsRevokeUnknown
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where

View File

@ -36,8 +36,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
zwischen dem AVS und den in FRADrive vorliegenden Fahrberechtigungen. #
Es wird dringend empfohlen, die Fahrberechtigungen im AVS anzupassen
und nicht umgekehrt.
<p>
^{pagForm}
<h3>
Fahrberechtigung Rollfeld gültig in FRADrive, fehlt aber im AVS

View File

@ -29,8 +29,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
The following sections show all discrepancies
between AVS and FRADrive with respect to driving licences. #
It is recommended to adjust AVS driving licences and keep FRADrive as it is.
<p>
^{pagForm}
<h3>
Maneuvering area driving licence 'R' valid in FRADrive, but not in AVS