workaround(pagination): add paginations workarounds to lms and avs synch
This commit is contained in:
Steffen Jost
parent
47f9d60f12
commit
526b38027e
@ -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
|
||||
@ -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
|
||||
@ -133,4 +133,9 @@ MenuPrintSend: Manueller Briefversand
|
||||
MenuPrintDownload: Brief herunterladen
|
||||
|
||||
MenuApiDocs: API-Dokumentation (Englisch)
|
||||
MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)
|
||||
MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)
|
||||
|
||||
MenuNextPage: Nächste Tabellenseite
|
||||
MenuPrevPage: Vorherige Tabellenseite
|
||||
MenuPageIncrease: Tabellenseite vergrößern
|
||||
MenuPageDecrease: Tabellenseite verkleinern
|
||||
@ -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
|
||||
1
routes
1
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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:
|
||||
|
||||
@ -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
|
||||
|
||||
@ -306,6 +306,7 @@ data FormIdentifier
|
||||
| FIDAvsSetLicence
|
||||
| FIDBtnAvsImportUnknown
|
||||
| FIDBtnAvsRevokeUnknown
|
||||
| FIDPaginationWorkaround
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
instance PathPiece FormIdentifier where
|
||||
|
||||
@ -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.
|
||||
<p>
|
||||
^{pagForm}
|
||||
|
||||
<h3>
|
||||
Fahrberechtigung Rollfeld gültig in FRADrive, fehlt aber im AVS
|
||||
<p>
|
||||
|
||||
@ -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.
|
||||
<p>
|
||||
^{pagForm}
|
||||
|
||||
<h3>
|
||||
Maneuvering area driving licence 'R' valid in FRADrive, but not in AVS
|
||||
<p>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user