diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index aeedaea1f..e7d47b10e 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -22,7 +22,7 @@ module Handler.Utils.Table.Pagination , FilterColumn(..), IsFilterColumn , DBRow(..), DBOutput , DBTable(..), IsDBTable(..) - , PaginationSettings(..) + , PaginationSettings(..), PaginationInput(..), piIsUnset , PSValidator(..) , defaultFilter, defaultSorting , restrictFilter, restrictSorting @@ -160,16 +160,41 @@ instance Default PaginationSettings where , psShortcircuit = False } -newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) } +data PaginationInput = PaginationInput + { piSorting :: Maybe [(CI Text, SortDirection)] + , piFilter :: Maybe (Map (CI Text) [Text]) + , piLimit :: Maybe Int64 + , piPage :: Maybe Int64 + , piShortcircuit :: Bool + } + +piIsUnset :: PaginationInput -> Bool +piIsUnset PaginationInput{..} = and + [ isNothing piSorting + , isNothing piFilter + , isNothing piLimit + , isNothing piPage + , not piShortcircuit + ] + +newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) } instance Default (PSValidator m x) where def = PSValidator $ \DBTable{..} -> \case Nothing -> def - Just ps -> swap . (\act -> execRWS act () ps) $ do - l <- gets psLimit - when (l <= 0) $ do - modify $ \ps -> ps { psLimit = psLimit def } - tell . pure $ SomeMessage MsgPSLimitNonPositive + Just pi -> swap . (\act -> execRWS act pi def) $ do + asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s }) + asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f }) + + l <- asks piLimit + case l of + Just l' + | l' >= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive + | otherwise -> modify $ \ps -> ps { psLimit = l' } + Nothing -> return () + + asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p }) + asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s }) defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x defaultFilter psFilter (runPSValidator -> f) = PSValidator g @@ -281,24 +306,25 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), , fieldEnctype = UrlEncoded } - psResult <- runInputGetResult $ PaginationSettings - <$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")) - <*> (Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter) - <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize")) - <*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page")) + psResult <- runInputGetResult $ PaginationInput + <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting") + <*> ((\m -> m <$ guard (not $ Map.null m)) . Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter) + <*> iopt intField (wIdent "pagesize") + <*> iopt intField (wIdent "page") <*> ireq checkBoxField (wIdent "table-only") - $(logDebug) . tshow $ (,,,,) <$> (length . psSorting <$> psResult) - <*> (Map.keys . psFilter <$> psResult) - <*> (psLimit <$> psResult) - <*> (psPage <$> psResult) - <*> (psShortcircuit <$> psResult) + $(logDebug) . tshow $ (,,,,) <$> (piSorting <$> psResult) + <*> (piFilter <$> psResult) + <*> (piLimit <$> psResult) + <*> (piPage <$> psResult) + <*> (piShortcircuit <$> psResult) let (errs, PaginationSettings{..}) = case psResult of - FormSuccess ps -> runPSValidator dbtable $ Just ps - FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing - FormMissing -> runPSValidator dbtable Nothing + FormSuccess pi + | not (piIsUnset pi) -> runPSValidator dbtable $ Just pi + FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing + _ -> runPSValidator dbtable Nothing psSorting' = map (first (dbtSorting !)) psSorting sqlQuery' = E.from $ \t -> dbtSQLQuery t <* E.orderBy (map (sqlSortDirection t) psSorting') @@ -308,13 +334,13 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), mapM_ (addMessageI "warning") errs - rows' <- runDB . E.select $ (,) <$> pure (E.unsafeSqlValue "row_number() OVER ()" :: E.SqlExpr (E.Value Int64), E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery' + rows' <- runDB . E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery' let rowCount - | ((_, E.Value n), _):_ <- rows' = n + | (E.Value n, _):_ <- rows' = n | otherwise = 0 - rows = map (\((E.Value dbrIndex, E.Value dbrCount), dbrOutput) -> DBRow{..}) rows' + rows = map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows' table' :: WriterT x m Widget table' = do