From 8d70518fbb61edec02f411b4488ec28aeccac25d Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 6 Aug 2018 16:46:01 +0200
Subject: [PATCH] Better detect if dbTable-sorting is set by user

Fixes #113
---
 src/Handler/Utils/Table/Pagination.hs | 158 +++++++++++++-------------
 src/Utils.hs                          |   7 +-
 2 files changed, 85 insertions(+), 80 deletions(-)

diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index cc2b06fe6..72ce2e585 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -124,6 +124,86 @@ instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, Mon
         | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is
         | otherwise = go (acc, is' . (i:)) is
 
+data PaginationSettings = PaginationSettings
+  { psSorting      :: [(CI Text, SortDirection)]
+  , psFilter       :: Map (CI Text) [Text]
+  , psLimit        :: Int64
+  , psPage         :: Int64
+  , psShortcircuit :: Bool
+  }
+
+makeClassy_ ''PaginationSettings
+
+instance Default PaginationSettings where
+  def = PaginationSettings
+    { psSorting      = []
+    , psFilter       = Map.empty
+    , psLimit        = 50
+    , psPage         = 0
+    , psShortcircuit = False
+    }
+
+data PaginationInput = PaginationInput
+  { piSorting      :: Maybe [(CI Text, SortDirection)]
+  , piFilter       :: Maybe (Map (CI Text) [Text])
+  , piLimit        :: Maybe Int64
+  , piPage         :: Maybe Int64
+  , piShortcircuit :: Bool
+  }
+
+makeClassy_ ''PaginationInput
+
+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 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 $ \dbTable -> injectDefault <*> f dbTable
+  where
+    injectDefault x = case x >>= piFilter of
+      Just _  -> id
+      Nothing -> set (_2._psFilter) psFilter
+
+defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
+defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable -> injectDefault <*> f dbTable
+  where
+    injectDefault x = case x >>= piSorting of
+      Just _  -> id
+      Nothing -> set (_2._psSorting) psSorting
+
+restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
+restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
+  where
+    restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
+
+restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
+restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
+  where
+    restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }
 
 data DBRow r = DBRow
   { dbrOutput :: r
@@ -173,82 +253,6 @@ data DBTable m x = forall a r r' h i t.
   , dbtIdent :: i
   }
 
-
-data PaginationSettings = PaginationSettings
-  { psSorting      :: [(CI Text, SortDirection)]
-  , psFilter       :: Map (CI Text) [Text]
-  , psLimit        :: Int64
-  , psPage         :: Int64
-  , psShortcircuit :: Bool
-  }
-
-instance Default PaginationSettings where
-  def = PaginationSettings
-    { psSorting      = []
-    , psFilter       = Map.empty
-    , psLimit        = 50
-    , psPage         = 0
-    , psShortcircuit = False
-    }
-
-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 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
-  where
-    g dbTable Nothing = over _2 (\s -> s { psFilter }) $ f dbTable Nothing
-    g dbTable x = f dbTable x
-
-defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
-defaultSorting psSorting (runPSValidator -> f) = PSValidator g
-  where
-    g dbTable Nothing = over _2 (\s -> s { psSorting }) $ f dbTable Nothing
-    g dbTable x = f dbTable x
-
-restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
-restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
-  where
-    restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
-
-restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
-restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
-  where
-    restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }
-
 class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) (x :: *) where
   type DBResult m x :: *
   -- type DBResult' m x :: *
@@ -368,7 +372,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
     
   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)
+    <*> ((assertM' $ not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
     <*> iopt intField (wIdent "pagesize")
     <*> iopt intField (wIdent "page")
     <*> ireq checkBoxField (wIdent "table-only")
diff --git a/src/Utils.hs b/src/Utils.hs
index 5052406c0..a95255a7e 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -303,9 +303,10 @@ guardM :: MonadPlus m => m Bool -> m ()
 guardM f = guard =<< f
 
 assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
-assertM f x = do
-  x' <- x
-  x' <$ guard (f x')
+assertM f x = x >>= assertM' f
+
+assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
+assertM' f x = x <$ guard (f x)
 
 -- Some Utility Functions from Agda.Utils.Monad
 -- | Monadic if-then-else.