workaround(pagination): add paginations workarounds to lms and avs synch

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

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

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -134,3 +134,8 @@ MenuPrintDownload: Brief herunterladen
 
 MenuApiDocs: API-Dokumentation (Englisch)
 MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)
+
+MenuNextPage: Nächste Tabellenseite
+MenuPrevPage: Vorherige Tabellenseite
+MenuPageIncrease: Tabellenseite vergrößern
+MenuPageDecrease: Tabellenseite verkleinern

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

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

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

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
@@ -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 pagResult "avsLicDiffRevokeVorfeld"  AvsLicenceVorfeld   avsLicenceDiffRevokeAll      
-          <*> mkLicenceTable "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld   
+          <*> mkLicenceTable pagResult "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld   
-          <*> mkLicenceTable "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld 
+          <*> mkLicenceTable pagResult "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld 
-          <*> mkLicenceTable "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld  
+          <*> 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 :: PaginationParameters -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
-mkLicenceTable dbtIdent aLic apids = do 
+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:

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)
+lmsTableQuery :: QualificationId -> LmsTableExpr -> Int64 -> Int64
-                                                               , E.SqlExpr (Entity User)
+  -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
-                                                               , E.SqlExpr (Maybe (Entity LmsUser))
+                , E.SqlExpr (Entity User)
-                                                               , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
+                , 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 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))
            -> 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

src/Utils/Form.hs

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

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.
+  <p>
+    ^{pagForm}
+    
   <h3>
     Fahrberechtigung Rollfeld gültig in FRADrive, fehlt aber im AVS
   <p>

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.
+  <p>
+    ^{pagForm}
+
   <h3>
     Maneuvering area driving licence 'R' valid in FRADrive, but not in AVS
   <p>