Send pagination data in dbTable-Forms

2018-11-29 12:30:42 +01:00 · 2018-11-29 12:30:42 +01:00 · 997403d6be
commit 997403d6be
parent 6c0f031c4e
11 changed files with 154 additions and 100 deletions
--- a/src/Data/CaseInsensitive/Instances.hs
+++ b/src/Data/CaseInsensitive/Instances.hs
@ -18,6 +18,8 @@ import qualified Data.Text.Encoding as Text

 import Language.Haskell.TH.Syntax (Lift(..))

+import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..))
+

 instance PersistField (CI Text) where
  toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
@ -41,6 +43,14 @@ instance ToJSON a => ToJSON (CI a) where
 instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
  parseJSON = fmap CI.mk . parseJSON

+instance (ToJSONKey a, ToJSON a) => ToJSONKey (CI a) where
+  toJSONKey = case toJSONKey of
+    ToJSONKeyText  toVal toEnc -> ToJSONKeyText (toVal . CI.original) (toEnc . CI.original)
+    ToJSONKeyValue toVal toEnc -> ToJSONKeyValue (toVal . CI.original) (toEnc . CI.original)
+
+instance (FromJSON a, FromJSONKey a, CI.FoldCase a) => FromJSONKey (CI a) where
+  fromJSONKey = CI.mk <$> fromJSONKey
+
 instance ToMessage a => ToMessage (CI a) where
  toMessage = toMessage . CI.original

--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@ -179,7 +179,7 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
 type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))

 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
-                     => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
+                     => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (DBResult m x)
 makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
  let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
      dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
@ -278,7 +278,7 @@ data ActionCorrectionsData = CorrDownloadData

 correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
 correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
-  tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return
+  tableForm <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator return
  ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
    (fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
    (actionRes, action) <- multiAction actions Nothing
@ -763,7 +763,7 @@ postCorrectionsGradeR = do
        & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text)))
      unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)

-  tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do
+  tableForm <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do
    cID <- encrypt subId
    void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
    return i
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@ -109,10 +109,10 @@ course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \cou
    E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
      E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid

-makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h )
-                     => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
+makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) )
+                     => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget
 makeCourseTable whereClause colChoices psValidator = do
-  muid <- maybeAuthId
+  muid <- lift maybeAuthId
  let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
      dbtSQLQuery qin@(course `E.InnerJoin` school) = do
        E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
@ -122,7 +122,7 @@ makeCourseTable whereClause colChoices psValidator = do
        return (course, participants, registered, school)
      dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
      dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
-  dbTable psValidator DBTable
+  fmap snd $ dbTable psValidator DBTable
    { dbtSQLQuery
    , dbtColonnade = colChoices
    , dbtProj
@ -179,7 +179,7 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
      whereClause = const $ E.val True
      validator = def
        & defaultSorting [("course", SortAsc), ("term", SortDesc)]
-  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
+  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
  defaultLayout $ do
    setTitleI MsgCourseListTitle
    [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
@ -211,7 +211,7 @@ getTermSchoolCourseListR tid ssh = do
        E.&&. course E.^. CourseSchool E.==. E.val ssh
      validator = def
        & defaultSorting [("cshort", SortAsc)]
-  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
+  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
  defaultLayout $ do
    setTitleI $ MsgTermSchoolCourseListTitle tid school
    $(widgetFile "courses")
@ -233,7 +233,7 @@ getTermCourseListR tid = do
      whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
      validator = def
        & defaultSorting [("cshort", SortAsc)]
-  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
+  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
  defaultLayout $ do
    setTitleI . MsgTermCourseListTitle $ tid
    $(widgetFile "courses")
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@ -72,7 +72,7 @@ homeAnonymous = do
        , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
            cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
        ]
-  ((), courseTable) <- dbTable def DBTable
+  courseTable <- runDB $ dbTableWidget' def DBTable
    { dbtSQLQuery  = tableData
    , dbtColonnade = colonnade
    , dbtProj      = return
@ -166,7 +166,7 @@ homeUser uid = do
                                        tickmark
        ]
  let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
-  ((), sheetTable) <- dbTable validator DBTable
+  sheetTable <- runDB $ dbTableWidget' validator DBTable
    { dbtSQLQuery  = tableData
    , dbtColonnade = colonnade
    , dbtProj      = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@ -204,25 +204,25 @@ getProfileDataR = do
                  , studyfeat   E.^. StudyFeaturesType
                  , studyfeat   E.^. StudyFeaturesSemester)
      )
-  -- Tabelle mit eigenen Kursen
-  (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid
-  -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
-  enrolledCoursesTable <- mkEnrolledCoursesTable uid
-  -- Tabelle mit allen Klausuren und Noten
+  (   (hasRows, ownedCoursesTable)
+    , enrolledCoursesTable
+    , submissionTable
+    , submissionGroupTable
+    , correctionsTable
+    ) <- runDB $ (,,,,)
+           <$> mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
+           <*> mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
+           <*> mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
+           <*> mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
+           <*> mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
+  
+  
  let examTable = [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|]
-  -- Tabelle mit allen Abgaben und Abgabe-Gruppen
-  submissionTable <- mkSubmissionTable uid
-  -- Tabelle mit allen Abgabegruppen
-  submissionGroupTable <- mkSubmissionGroupTable uid
-  -- Tabelle mit allen Korrektor-Aufgaben
-  correctionsTable <- mkCorrectionsTable uid
-  -- Tabelle mit allen eigenen Tutorials
  let ownTutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-  -- Tabelle mit allen Tutorials
  let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
+
  -- Delete Button
  (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete)
-  -- TODO: move this into a Message and/or Widget-File
  defaultLayout $ do
    let delWdgt = $(widgetFile "widgets/data-delete")
    $(widgetFile "profileData")
@ -230,7 +230,7 @@ getProfileDataR = do



-mkOwnedCoursesTable :: UserId -> Handler (Bool, Widget)
+mkOwnedCoursesTable :: UserId -> DB (Bool, Widget)
 -- Table listing all courses that the given user is a lecturer for
 mkOwnedCoursesTable =
  let dbtIdent = "courseOwnership" :: Text
@ -277,7 +277,7 @@ mkOwnedCoursesTable =



-mkEnrolledCoursesTable :: UserId -> Handler Widget
+mkEnrolledCoursesTable :: UserId -> DB Widget
 -- Table listing all courses that the given user is enrolled in
 mkEnrolledCoursesTable =
  let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
@ -324,7 +324,7 @@ mkEnrolledCoursesTable =



-mkSubmissionTable :: UserId -> Handler Widget
+mkSubmissionTable :: UserId -> DB Widget
 -- Table listing all submissions for the given user
 mkSubmissionTable =
  let dbtIdent = "submissions" :: Text
@ -405,7 +405,7 @@ mkSubmissionTable =



-mkSubmissionGroupTable :: UserId -> Handler Widget
+mkSubmissionGroupTable :: UserId -> DB Widget
 -- Table listing all submissions for the given user
 mkSubmissionGroupTable =
  let dbtIdent = "subGroups" :: Text
@ -470,7 +470,7 @@ mkSubmissionGroupTable =



-mkCorrectionsTable :: UserId -> Handler Widget
+mkCorrectionsTable :: UserId -> DB Widget
 -- Table listing sum of corrections made by the given user per sheet
 mkCorrectionsTable =
  let dbtIdent = "corrections" :: Text
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@ -194,7 +194,7 @@ getSheetListR tid ssh csh = do
      ]
    psValidator = def
      & defaultSorting [("submission-since", SortAsc)]
-  ((), table) <- dbTable psValidator $ DBTable
+  table <- runDB $ dbTableWidget' psValidator DBTable
    { dbtSQLQuery  = sheetData
    , dbtColonnade = sheetCol
    , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }
@ -286,7 +286,7 @@ getSShowR tid ssh csh shn = do
        ]
  let psValidator = def
        & defaultSorting [("type", SortAsc), ("path", SortAsc)]
-  (Any hasFiles, fileTable) <- dbTable psValidator $ DBTable
+  (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
    { dbtSQLQuery = fileData
    , dbtColonnade = colonnadeFiles
    , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@ -312,7 +312,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
          ]
        , dbtFilter = Map.empty
        }
-  mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
+  mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid

  defaultLayout $ do
    setTitleI $ MsgSubmissionEditHead tid ssh csh shn
--- a/src/Handler/SystemMessage.hs
+++ b/src/Handler/SystemMessage.hs
@ -174,7 +174,7 @@ postMessageListR = do
        , ..
        }
    psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
-  tableForm <- dbTable psValidator DBTable
+  tableForm <- runDB $ dbTable psValidator DBTable
    { dbtSQLQuery
    , dbtColonnade
    , dbtProj
--- a/src/Handler/Term.hs
+++ b/src/Handler/Term.hs
@ -96,7 +96,7 @@ getTermShowR = do
 --                       #{termToText termName}
 --                 |]
 --           ]
-      ((), table) <- dbTable def DBTable
+      table <- runDB $ dbTableWidget' def DBTable
        { dbtSQLQuery = termData
        , dbtColonnade = colonnadeTerms
        , dbtProj = return . dbrOutput
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@ -69,7 +69,7 @@ getUsersR = do
    psValidator = def
      & defaultSorting [("name", SortAsc),("display-name", SortAsc)]
  
-  ((), userList) <- dbTable psValidator DBTable
+  ((), userList) <- runDB $ dbTable psValidator DBTable
    { dbtSQLQuery  = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
    , dbtColonnade
    , dbtProj      = return
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@ -25,6 +25,7 @@ module Handler.Utils.Table.Pagination
  ) where

 import Handler.Utils.Table.Pagination.Types
+import Utils
 import Utils.Lens.TH

 import Import hiding (pi)
@ -59,6 +60,10 @@ import Data.Ratio ((%))

 import Control.Lens

+import Data.Aeson (Options(..), defaultOptions, decodeStrict')
+import Data.Aeson.Text
+import Data.Aeson.TH (deriveJSON)
+

 data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }

@ -72,6 +77,10 @@ instance PathPiece SortDirection where
    | t == "desc" = Just SortDesc
    | otherwise   = Nothing

+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''SortDirection
+
 sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy
 sqlSortDirection t (SortColumn e, SortAsc ) = E.asc  $ e t
 sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
@ -119,15 +128,32 @@ instance Default PaginationSettings where
    , psShortcircuit = False
    }

+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''PaginationSettings
+
 data PaginationInput = PaginationInput
  { piSorting      :: Maybe [(CI Text, SortDirection)]
  , piFilter       :: Maybe (Map (CI Text) [Text])
  , piLimit        :: Maybe Int64
  , piPage         :: Maybe Int64
  , piShortcircuit :: Bool
-  }
+  } deriving (Eq, Ord, Show, Read, Generic)
+
+instance Default PaginationInput where
+  def = PaginationInput
+    { piSorting      = Nothing
+    , piFilter       = Nothing
+    , piLimit        = Nothing
+    , piPage         = Nothing
+    , piShortcircuit = False
+    }

 makeLenses_ ''PaginationInput
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , omitNothingFields = True
+  } ''PaginationInput

 piIsUnset :: PaginationInput -> Bool
 piIsUnset PaginationInput{..} = and
@ -241,9 +267,9 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
    
  -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
  -- | Format @DBTable@ when sort-circuiting
-  dbWidget   :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget
+  dbWidget   :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget
  -- | Format @DBTable@ when not short-circuiting
-  dbHandler  :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
+  dbHandler  :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
  runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)

 cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
@ -266,8 +292,8 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
    (uncurry WidgetCell)
  
  -- dbWidget Proxy Proxy = iso (, ()) $ view _1
-  dbWidget _ = return . snd
-  dbHandler _ f = return . over _2 f
+  dbWidget _ _ = return . snd
+  dbHandler _ _ f = return . over _2 f
  runDBTable = liftHandlerT

 instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
@ -286,8 +312,8 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher
    (\DBCell{..} -> (dbCellAttrs, dbCellContents))
    (uncurry DBCell)

-  dbWidget _ = return . snd
-  dbHandler _ f = return . over _2 f
+  dbWidget _ _ = return . snd
+  dbHandler _ _ f = return . over _2 f
  -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
  runDBTable = mapReaderT liftHandlerT

@ -314,13 +340,22 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
  
  -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
  --                            ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
-  dbWidget _ = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
-  dbHandler _ f form = return $ fmap (over _2 f) . form
+  dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi
+  dbHandler dbtable pi f form = return $ fmap (over _2 f) . addPIHiddenField dbtable pi form
  -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
  -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
  -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
  runDBTable = return . withFragment

+addPIHiddenField :: DBTable m x -> PaginationInput -> Form a -> Form a
+addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragment = form $ fragment <> [shamlet|
+    <input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
+  |]
+  where
+    wIdent n
+      | not $ null dbtIdent = dbtIdent <> "-" <> n
+      | otherwise           = n
+
 instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
  mempty = FormCell mempty (return mempty)
  (FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c')
@ -329,7 +364,7 @@ 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 -> Handler (DBResult m x)
+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
    sortingOptions = mkOptionList
@ -350,80 +385,89 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), d
      , fieldEnctype = UrlEncoded
      }
    
-  psResult <- runInputGetResult $ PaginationInput
+  piResult <- lift . runInputGetResult $ PaginationInput
    <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
    <*> (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")

-  $(logDebug) . tshow $ (,,,,) <$> (piSorting <$> psResult)
-                               <*> (piFilter <$> psResult)
-                               <*> (piLimit <$> psResult)
-                               <*> (piPage <$> psResult)
-                               <*> (piShortcircuit <$> psResult)
+  piPrevious <- fmap (fmap (set _piShortcircuit False) . maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination")
+
+  $(logDebug) . tshow $ (,,,,) <$> (piSorting <$> piResult)
+                               <*> (piFilter <$> piResult)
+                               <*> (piLimit <$> piResult)
+                               <*> (piPage <$> piResult)
+                               <*> (piShortcircuit <$> piResult)

  let
-    (errs, PaginationSettings{..}) = case psResult of
+    (errs, PaginationSettings{..}) = case piPrevious <|> piResult of
      FormSuccess pi
-        | not (piIsUnset pi) -> runPSValidator dbtable $ Just pi
-      FormFailure errs'      -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
-      _                      -> runPSValidator dbtable Nothing
+        | not (piIsUnset pi)
+          -> runPSValidator dbtable $ Just pi
+      FormFailure errs'
+          -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
+      _   -> runPSValidator dbtable Nothing
+    paginationInput
+      | FormSuccess pi <- piPrevious <|> piResult
+      , not $ piIsUnset pi
+      = pi
+      | otherwise
+      = def
    psSorting' = map (first (dbtSorting !)) psSorting

  mapM_ (addMessageI Warning) errs

-  runDB $ do
-    rows' <- E.select . E.from $ \t -> do
-      res <- dbtSQLQuery t
-      E.orderBy (map (sqlSortDirection t) psSorting')
-      E.limit psLimit
-      E.offset (psPage * psLimit)
-      Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
-      return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), res)
+  rows' <- E.select . E.from $ \t -> do
+    res <- dbtSQLQuery t
+    E.orderBy (map (sqlSortDirection t) psSorting')
+    E.limit psLimit
+    E.offset (psPage * psLimit)
+    Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
+    return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), res)

-    let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f)
-  
-    rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
+  let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f)

-    let
-      rowCount
-        | (E.Value n, _):_ <- rows' = n
-        | otherwise = 0
+  rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'

-      table' :: WriterT x m Widget
-      table' = do
-        getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+  let
+    rowCount
+      | (E.Value n, _):_ <- rows' = n
+      | otherwise = 0

-        let
-          tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
+    table' :: WriterT x m Widget
+    table' = do
+      getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest

-          genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
-            widget <- sortableContent ^. cellContents
-            let
-              directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
-              isSortable = isJust sortableKey
-              isSorted = (`elem` directions)
-              attrs = sortableContent ^. cellAttrs
-            return $(widgetFile "table/cell/header")
+      let
+        tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams

-          columnCount :: Int64
-          columnCount = olength64 $ getColonnade dbtColonnade
+        genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
+          widget <- sortableContent ^. cellContents
+          let
+            directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
+            isSortable = isJust sortableKey
+            isSorted = (`elem` directions)
+            attrs = sortableContent ^. cellAttrs
+          return $(widgetFile "table/cell/header")

-        wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
+        columnCount :: Int64
+        columnCount = olength64 $ getColonnade dbtColonnade

-        wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do
-          widget <- cell' ^. cellContents
-          let attrs = cell' ^. cellAttrs
-          return $(widgetFile "table/cell/body")
-      
-        let table = $(widgetFile "table/colonnade")
-            pageCount = max 1 . ceiling $ rowCount % psLimit
-            pageNumbers = [0..pred pageCount]
+      wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable

-        return $(widgetFile "table/layout")
+      wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do
+        widget <- cell' ^. cellContents
+        let attrs = cell' ^. cellAttrs
+        return $(widgetFile "table/cell/body")

-    bool (dbHandler dbtable $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
+      let table = $(widgetFile "table/colonnade")
+          pageCount = max 1 . ceiling $ rowCount % psLimit
+          pageNumbers = [0..pred pageCount]
+
+      return $(widgetFile "table/layout")
+
+  bool (dbHandler dbtable paginationInput $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
  where
    tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
    tblLayout tbl' = do
@ -434,10 +478,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = (toPathPiece -> dbtIdent), d
    setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]

 dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
-    -> Handler (DBResult (HandlerT UniWorX IO) x)
+    -> DB (DBResult (HandlerT UniWorX IO) x)
 dbTableWidget = dbTable

-dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> Handler Widget
+dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> DB Widget
 dbTableWidget' = fmap (fmap snd) . dbTable

 widgetColonnade :: (Headedness h, Monoid x)