From a03577f97091bd6dae6df68d5fccc61e5fd68d25 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 24 Jan 2019 16:21:30 +0100
Subject: [PATCH] Expose runPaginationSettings'

---
 src/Handler/Utils/Table/Pagination.hs | 70 ++++++++++++++++++---------
 1 file changed, 48 insertions(+), 22 deletions(-)

diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 3ef8450e0..cefe77a89 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -17,6 +17,7 @@ module Handler.Utils.Table.Pagination
   , defaultFilter, defaultSorting
   , restrictFilter, restrictSorting
   , ToSortable(..), Sortable(..)
+  , runPaginationSettings'
   , dbTable
   , dbTableWidget, dbTableWidget'
   , widgetColonnade, formColonnade, dbColonnade
@@ -212,6 +213,7 @@ data PaginationSettings = PaginationSettings
   , psFilter       :: Map FilterKey [Text]
   , psLimit        :: PagesizeLimit
   , psPage         :: Int64
+  , psShortcircuit :: Bool
   }
 
 makeLenses_ ''PaginationSettings
@@ -222,6 +224,7 @@ instance Default PaginationSettings where
     , psFilter       = Map.empty
     , psLimit        = PagesizeLimit 50
     , psPage         = 0
+    , psShortcircuit = False
     }
 
 deriveJSON defaultOptions
@@ -554,29 +557,17 @@ instance IsDBTable m a => IsString (DBCell m a) where
   fromString = cell . fromString
 
 
-dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
-dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
-  let
-    sortingOptions = mkOptionList
-      [ Option t' (SortingSetting t d) t'
-      | (t, _) <- mapToList dbtSorting
-      , d <- [SortAsc, SortDesc]
-      , let t' = toPathPiece $ SortingSetting t d
-      ]
-    wIdent :: Text -> Text
-    wIdent = toPathPiece . WithIdent dbtIdent 
-    dbsAttrs'
-      | not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
-      | otherwise           = dbsAttrs
-    multiTextField = Field
-      { fieldParse = \ts _ -> return . Right $ Just ts
-      , fieldView = error "multiTextField: should not be rendered"
-      , fieldEnctype = UrlEncoded
-      }
+data PaginationState = PaginationState
+  { filterWdgt, pagesizeWdgt :: Widget
+  , filterEnc, pagesizeEnc :: Enctype
+  , paginationInput :: PaginationInput
+  }
 
+runPaginationSettings :: (MonadHandler m', HandlerSite m' ~ UniWorX) => PSValidator m x -> DBTable m x -> ReaderT (YesodPersistBackend UniWorX) m' (PaginationSettings, PaginationState)
+runPaginationSettings PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), .. } = hoist liftHandlerT $ do
+  
   piPrevious <- lift . runInputMaybe $ ireq (jsonField True) (wIdent "pagination")
   let piPreviousRes = maybe FormMissing FormSuccess piPrevious
-  previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous")
 
   piInput <- lift . runInputGetResult $ PaginationInput
     <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
@@ -609,7 +600,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
   psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
 
   let
-    ((errs, PaginationSettings{..}), paginationInput@PaginationInput{..})
+    ((errs, paginationSettings), paginationInput)
       | FormSuccess pi <- piResult
       , not $ piIsUnset pi
       = (, pi) . runPSValidator dbtable $ Just pi
@@ -617,10 +608,45 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       = (, def) . first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
       | otherwise
       = (, def) $ runPSValidator dbtable Nothing
-    psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting
 
   mapM_ (addMessageI Warning) errs
 
+  return (paginationSettings{ psShortcircuit }, PaginationState{..})
+  where
+    wIdent :: Text -> Text
+    wIdent = toPathPiece . WithIdent dbtIdent 
+    sortingOptions = mkOptionList
+      [ Option t' (SortingSetting t d) t'
+      | (t, _) <- mapToList dbtSorting
+      , d <- [SortAsc, SortDesc]
+      , let t' = toPathPiece $ SortingSetting t d
+      ]
+    multiTextField = Field
+      { fieldParse = \ts _ -> return . Right $ Just ts
+      , fieldView = error "multiTextField: should not be rendered"
+      , fieldEnctype = UrlEncoded
+      }
+
+runPaginationSettings' :: forall m' m x. (MonadHandler m', HandlerSite m' ~ UniWorX)
+                       => PSValidator m x -> DBTable m x -> ReaderT (YesodPersistBackend UniWorX) m' PaginationSettings
+runPaginationSettings' psValidator dbtable = fst <$> runPaginationSettings psValidator dbtable
+
+
+dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
+dbTable psValidator dbtable@DBTable{ dbtIdent = toPathPiece -> dbtIdent, dbtStyle = DBStyle{..}, .. } = do
+  let
+    wIdent :: Text -> Text
+    wIdent = toPathPiece . WithIdent dbtIdent 
+    dbsAttrs'
+      | not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
+      | otherwise           = dbsAttrs
+
+  previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous")
+
+  (PaginationSettings{..}, PaginationState{ paginationInput = paginationInput@PaginationInput{..}, .. })
+    <- runPaginationSettings psValidator dbtable
+  let psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting
+
   rows' <- E.select . E.from $ \t -> do
     res <- dbtSQLQuery t
     E.orderBy (map (sqlSortDirection t) psSorting')