Better PSValidator

messages/de.msg

@@ -1,2 +1,3 @@
 SummerTerm year@Integer: Sommersemester #{tshow year}
-WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
+WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
+PSLimitNonPositive: “pagesize” muss größer als null sein

src/Handler/Utils/Table/Pagination.hs

@@ -3,6 +3,7 @@
            , RecordWildCards
            , OverloadedStrings
            , TemplateHaskell
+           , LambdaCase
   #-}
 
 module Handler.Utils.Table.Pagination where
@@ -12,9 +13,11 @@ import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
 import Text.Blaze (Attribute)
 
+import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_)
+
 import Data.Map (Map)
 
-import Colonnade hiding (bool)
+import Colonnade hiding (bool, fromMaybe)
 import Yesod.Colonnade
 
 import Text.Hamlet (hamletFile)
@@ -53,8 +56,19 @@ instance Default PaginationSettings where
     , psShortcircuit = False
     }
 
-dbTable :: PaginationSettings -> DBTable -> Handler Widget
+newtype PSValidator = PSValidator { runPSValidator :: Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
-dbTable defPS DBTable{..} = do
+
+instance Default PSValidator where
+  def = PSValidator $ \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
+
+dbTable :: PSValidator -> DBTable -> Handler Widget
+dbTable PSValidator{..} DBTable{..} = do
   let
     sortingOptions = mkOptionList
       [ Option t' (c, d) t'
@@ -67,25 +81,30 @@ dbTable defPS DBTable{..} = do
         parse optlist _ = case mapM (olReadExternal sortingOptions) optlist of
           Nothing -> return $ Left "Error parsing values"
           Just res -> return $ Right $ Just res
+    (_, defPS) = runPSValidator Nothing
+    
   psResult <- runInputGetResult $ PaginationSettings
     <$> ireq sortingField "sorting"
-    <*> ireq intField "pagesize"
+    <*> (fromMaybe (psLimit defPS) <$> iopt intField "pagesize")
-    <*> ireq intField "page"
+    <*> (fromMaybe (psPage  defPS) <$> iopt intField "page")
     <*> ireq checkBoxField "table-only"
 
-  $(logDebug) $ tshow (length . psSorting <$> psResult, psLimit <$> psResult, psPage <$> psResult, psShortcircuit <$> psResult)
+  $(logDebug) . tshow $ (,,,) <$> (length . psSorting <$> psResult)
+                              <*> (psLimit <$> psResult)
+                              <*> (psPage <$> psResult)
+                              <*> (psShortcircuit <$> psResult)
 
-  PaginationSettings{..} <- case psResult of
+  let
-    (FormSuccess ps) -> return ps
+    (errs, PaginationSettings{..}) = case psResult of
-    -- (FormSuccess ps) -> case dbtValidatePS ps of
+      FormSuccess ps   -> runPSValidator $ Just ps
-    --   Right ps' -> return ps'
+      FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing
-    --   Left errs -> defPS <$ mapM_ (addMessageI "error") errs
+      FormMissing      -> runPSValidator Nothing
-    _ -> return defPS
+    sqlQuery' = dbtSQLQuery
-  
+      <* E.orderBy (map sqlSortDirection psSorting)
-  let sqlQuery' = dbtSQLQuery
+      <* E.limit psLimit
-        <* E.orderBy (map sqlSortDirection psSorting)
+      <* E.offset (psPage * psLimit)
-        <* E.limit psLimit
+
-        <* E.offset (psPage * psLimit)
+  mapM_ (addMessageI "warning") errs
      
   rows <- runDB $ E.select sqlQuery'