From 526b38027e44034503e0dee7c5bfbb4bc215c45a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 25 Jan 2023 17:10:09 +0100 Subject: [PATCH] workaround(pagination): add paginations workarounds to lms and avs synch --- messages/uniworx/misc/de-de-formal.msg | 4 ++ messages/uniworx/misc/en-eu.msg | 4 ++ .../utils/navigation/menu/de-de-formal.msg | 7 ++- .../uniworx/utils/navigation/menu/en-eu.msg | 5 ++ routes | 1 + src/Foundation/Navigation.hs | 47 ++++++++++++++++++- src/Handler/Admin/Avs.hs | 45 ++++++++++++++---- src/Handler/LMS.hs | 35 +++++++++----- src/Utils/Form.hs | 1 + .../avs-synchronisation/de-de-formal.hamlet | 3 ++ .../i18n/avs-synchronisation/en-eu.hamlet | 3 ++ 11 files changed, 132 insertions(+), 23 deletions(-) diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index 4b8f8b93c..ef68eb735 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -20,3 +20,7 @@ ClusterVolatileQuickActionsEnabled: Schnellzugriffsmenü aktiv AvsNoLicence: Keine Fahrberechtigung AvsLicenceVorfeld: Vorfeld Fahrberechtigung AvsLicenceRollfeld: Rollfeld Fahrberechtigung + +PaginationSize: Einträge pro Seite +PaginationPage: Angzeigte Seite +PaginationError: Paginierung Parameter dürfen nicht negativ sein \ No newline at end of file diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 98cf58952..97423bdda 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -20,3 +20,7 @@ ClusterVolatileQuickActionsEnabled: Quick actions enabled AvsNoLicence: No driving licence AvsLicenceVorfeld: Apron driving licence AvsLicenceRollfeld: Maneuvering area driving licence + +PaginationSize: Rows per Page +PaginationPage: Page to show +PaginationError: Pagination parameter must not be negative \ 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 e22177054..ae5a5eff4 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -133,4 +133,9 @@ MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen MenuApiDocs: API-Dokumentation (Englisch) -MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) \ No newline at end of file +MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) + +MenuNextPage: Nächste Tabellenseite +MenuPrevPage: Vorherige Tabellenseite +MenuPageIncrease: Tabellenseite vergrößern +MenuPageDecrease: Tabellenseite verkleinern \ 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 ba0399da6..938038732 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -135,3 +135,8 @@ MenuPrintDownload: Download Letter MenuApiDocs: API documentation MenuSwagger: OpenAPI 2.0 (Swagger) + +MenuNextPage: Next table page +MenuPrevPage: Previous table page +MenuPageIncrease: Increase table page size +MenuPageDecrease: Decrease table page size \ No newline at end of file diff --git a/routes b/routes index 9813f2df1..5246a375a 100644 --- a/routes +++ b/routes @@ -269,6 +269,7 @@ /lms LmsAllR GET POST !free -- TODO verify that this is ok /lms/#SchoolId LmsSchoolR GET !free -- TODO verify that this is ok /lms/#SchoolId/#QualificationShorthand LmsR GET POST !free -- +/lms/#SchoolId/#QualificationShorthand/limit/#Int64/skip/#Int64 LmsLSR GET POST !free -- 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 -- development only diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index bc5e2476b..5191afa77 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -172,7 +172,10 @@ breadcrumb LmsAllR = i18nCrumb MsgMenuLms 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) -breadcrumb (LmsR ssh qsh) =useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ LmsSchoolR ssh) $ do +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 @@ -2302,6 +2305,48 @@ 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 + 50) pagOffset + , defNavLink MsgMenuPageDecrease $ LmsLSR sid qsh (pagLimit - 50) pagOffset + ] + } + , NavPageActionPrimary + { navLink = defNavLink MsgMenuNextPage $ LmsLSR sid qsh pagLimit $ succ pagOffset + , navChildren = + [ defNavLink MsgMenuPageIncrease $ LmsLSR sid qsh (pagLimit + 50) pagOffset + , defNavLink MsgMenuPageDecrease $ LmsLSR sid qsh (pagLimit - 50) 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 diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index dda27d0aa..8c0f53cd9 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -34,6 +34,31 @@ 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 single = uncurry Map.singleton @@ -75,7 +100,7 @@ makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateA validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler () validateAvsQueryPerson = do AvsQueryPerson{..} <- State.get - guardValidation MsgAvsQueryEmpty $ + guardValidation MsgAvsQueryEmpty $ is _Just avsPersonQueryCardNo || is _Just avsPersonQueryFirstName || is _Just avsPersonQueryLastName || @@ -373,12 +398,16 @@ getProblemAvsSynchR = do 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 } + -- licence differences ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,) - <$> mkLicenceTable "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll - <*> mkLicenceTable "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld - <*> mkLicenceTable "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld - <*> mkLicenceTable "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld + <$> mkLicenceTable pagResult "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll + <*> mkLicenceTable pagResult "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld + <*> mkLicenceTable pagResult "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld + <*> mkLicenceTable pagResult "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld now <- liftIO getCurrentTime let nowaday = utctDay now @@ -457,8 +486,8 @@ instance HasUser LicenceTableData where hasUser = resultUser . _entityVal -mkLicenceTable :: Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget) -mkLicenceTable dbtIdent aLic apids = do +mkLicenceTable :: PaginationParameters -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget) +mkLicenceTable PaginationParameters{..} dbtIdent aLic apids = do currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [] now <- liftIO getCurrentTime @@ -473,7 +502,7 @@ mkLicenceTable dbtIdent aLic apids = do 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) - E.limit 200 -- TODO: why does pagination not work here? + when (pagLimit > 0) $ E.limit pagLimit >> E.offset (pagLimit * pagOffset) -- TODO: why does pagination not work here? return (usrAvs, user, qualUser, qual) dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR? -- Not sure what changes here: diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 9e3754e22..f4ad4555f 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -10,6 +10,7 @@ module Handler.LMS ( getLmsAllR , postLmsAllR , getLmsSchoolR , getLmsR , postLmsR + , getLmsLSR , postLmsLSR , getLmsEditR , postLmsEditR , getLmsUsersR , getLmsUsersDirectR , getLmsUserlistR , postLmsUserlistR @@ -325,12 +326,13 @@ isRenewPinAct LmsActNotifyData = False isRenewPinAct LmsActRenewNotifyData = True isRenewPinAct LmsActRenewPinData = True -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) = do +lmsTableQuery :: QualificationId -> LmsTableExpr -> Int64 -> Int64 + -> 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 -- 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; @@ -339,6 +341,7 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do 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 @@ -363,14 +366,14 @@ 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 ) - => Bool + => Int64 -> Int64 + -> Bool -> Entity Qualification - -> Map act (AForm Handler act') - -> (LmsTableExpr -> E.SqlExpr (E.Value Bool)) + -> Map act (AForm Handler act') -> cols -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) -> DB (FormResult (act', Set UserId), Widget) -mkLmsTable isAdmin (Entity qid quali) acts restrict cols psValidator = do +mkLmsTable nlimit noffset 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 @@ -380,7 +383,7 @@ mkLmsTable isAdmin (Entity qid quali) acts restrict cols psValidator = do csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "qualification" - dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q) + dbtSQLQuery q = lmsTableQuery qid q nlimit noffset dbtRowKey = queryUser >>> (E.^. UserId) --dbtProj = dbtProjFilteredPostId dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do @@ -497,7 +500,13 @@ mkLmsTable isAdmin (Entity qid quali) acts restrict cols psValidator = do getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR -postLmsR sid qsh = do +postLmsR sid qsh = redirect $ LmsLSR sid qsh 250 0 + +getLmsLSR, postLmsLSR :: SchoolId -> QualificationShorthand -> Int64 -> Int64 -> Handler Html +getLmsLSR = postLmsLSR +postLmsLSR sid qsh nlimit noffset + | nlimit < 0 || noffset < 0 = redirect $ LmsLSR sid qsh 200 0 + | otherwise = 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 @@ -573,7 +582,7 @@ postLmsR sid qsh = do -- 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 isAdmin qent acts (const E.true) colChoices psValidator + tbl <- mkLmsTable nlimit noffset isAdmin qent acts colChoices psValidator return (tbl, qent) formResult lmsRes $ \case diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index ade2a0b6a..e9c7203c9 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -306,6 +306,7 @@ data FormIdentifier | FIDAvsSetLicence | FIDBtnAvsImportUnknown | FIDBtnAvsRevokeUnknown + | FIDPaginationWorkaround deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/templates/i18n/avs-synchronisation/de-de-formal.hamlet b/templates/i18n/avs-synchronisation/de-de-formal.hamlet index 26ae63935..f23862a6e 100644 --- a/templates/i18n/avs-synchronisation/de-de-formal.hamlet +++ b/templates/i18n/avs-synchronisation/de-de-formal.hamlet @@ -36,6 +36,9 @@ $# 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. +

+ ^{pagForm} +

Fahrberechtigung Rollfeld gültig in FRADrive, fehlt aber im AVS

diff --git a/templates/i18n/avs-synchronisation/en-eu.hamlet b/templates/i18n/avs-synchronisation/en-eu.hamlet index bcbcdfa86..8a1fa7e6f 100644 --- a/templates/i18n/avs-synchronisation/en-eu.hamlet +++ b/templates/i18n/avs-synchronisation/en-eu.hamlet @@ -29,6 +29,9 @@ $# 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. +

+ ^{pagForm} +

Maneuvering area driving licence 'R' valid in FRADrive, but not in AVS