From 96cdef253845f7247deaef1faa0691997ae0bbdb Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Fri, 16 Mar 2018 12:54:18 +0100
Subject: [PATCH] Better PSValidator

---
 messages/de.msg                       |  3 +-
 src/Handler/Utils/Table/Pagination.hs | 53 ++++++++++++++++++---------
 2 files changed, 38 insertions(+), 18 deletions(-)

diff --git a/messages/de.msg b/messages/de.msg
index b23e13c99..0f6ec28bb 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -1,2 +1,3 @@
 SummerTerm year@Integer: Sommersemester #{tshow year}
-WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
\ No newline at end of file
+WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
+PSLimitNonPositive: “pagesize” muss größer als null sein
\ No newline at end of file
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index c23b716a7..c564111d3 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/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
-dbTable defPS DBTable{..} = do
+newtype PSValidator = PSValidator { runPSValidator :: Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
+
+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"
-    <*> ireq intField "page"
+    <*> (fromMaybe (psLimit defPS) <$> iopt intField "pagesize")
+    <*> (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
-    (FormSuccess ps) -> return ps
-    -- (FormSuccess ps) -> case dbtValidatePS ps of
-    --   Right ps' -> return ps'
-    --   Left errs -> defPS <$ mapM_ (addMessageI "error") errs
-    _ -> return defPS
-  
-  let sqlQuery' = dbtSQLQuery
-        <* E.orderBy (map sqlSortDirection psSorting)
-        <* E.limit psLimit
-        <* E.offset (psPage * psLimit)
+  let
+    (errs, PaginationSettings{..}) = case psResult of
+      FormSuccess ps   -> runPSValidator $ Just ps
+      FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing
+      FormMissing      -> runPSValidator Nothing
+    sqlQuery' = dbtSQLQuery
+      <* E.orderBy (map sqlSortDirection psSorting)
+      <* E.limit psLimit
+      <* E.offset (psPage * psLimit)
+
+  mapM_ (addMessageI "warning") errs
      
   rows <- runDB $ E.select sqlQuery'