Start work on server side pagination

src/Handler/Utils/Table/Pagination.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE NoImplicitPrelude
+           , ExistentialQuantification
+           , RecordWildCards
+           , OverloadedStrings
+           , TemplateHaskell
+  #-}
+
+module Handler.Utils.Table.Pagination where
+
+import Import
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
+import Text.Blaze (Attribute)
+
+import Data.Map (Map)
+
+import Colonnade hiding (bool)
+import Yesod.Colonnade
+
+import Text.Hamlet (hamletFile)
+
+
+data SortColumn = forall a. PersistField a => SortColumn { getSortColumn :: E.SqlExpr (E.Value a) }
+data SortDirection = SortAsc | SortDesc
+  deriving (Eq, Ord, Enum, Show, Read)
+
+sqlSortDirection :: (SortColumn, SortDirection) -> E.SqlExpr E.OrderBy
+sqlSortDirection (SortColumn e, SortAsc ) = E.asc  e
+sqlSortDirection (SortColumn e, SortDesc) = E.desc e
+  
+data DBTable = forall a r h.
+  ( Headedness h
+  , E.SqlSelect a r
+  ) => DBTable
+  { dbtSQLQuery :: E.SqlQuery a
+  , dbtColonnade :: Colonnade h r (Cell UniWorX)
+  , dbtSorting :: Map Text SortColumn
+  , dbtAttrs :: Attribute
+  }
+
+data PaginationSettings = PaginationSettings
+  { psSorting      :: [(SortColumn, SortDirection)]
+  , psLimit        :: Int64
+  , psPage         :: Int64
+  , psShortcircuit :: Bool
+  }
+
+instance Default PaginationSettings where
+  def = PaginationSettings
+    { psSorting      = []
+    , psLimit        = 50
+    , psPage         = 0
+    , psShortcircuit = False
+    }
+
+dbTable :: PaginationSettings -> DBTable -> Handler Widget
+dbTable defPS DBTable{..} = do
+  let
+    sortingOptions = mkOptionList
+      [ Option t' (c, d) t'
+      | (t, c) <- mapToList dbtSorting
+      , d <- [SortAsc, SortDesc]
+      , let t' = t <> "-" <> tshow d
+      ]
+    sortingField = Field parse (\_ _ _ _ _ -> return ()) UrlEncoded
+      where
+        parse optlist _ = case mapM (olReadExternal sortingOptions) optlist of
+          Nothing -> return $ Left "Error parsing values"
+          Just res -> return $ Right $ Just res
+  psResult <- runInputGetResult $ PaginationSettings
+    <$> ireq sortingField "sorting"
+    <*> ireq intField "pagesize"
+    <*> ireq intField "page"
+    <*> ireq checkBoxField "table-only"
+
+  $(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)
+     
+  rows <- runDB $ E.select sqlQuery'
+
+  bool return (sendResponse <=< tblLayout) psShortcircuit $ do
+    encodeCellTable dbtAttrs dbtColonnade rows
+  where
+    tblLayout :: Widget -> Handler Html
+    tblLayout = widgetToPageContent >=> (\tbl -> withUrlRenderer $(hamletFile "templates/table-layout.hamlet"))

templates/table-layout.hamlet

@@ -0,0 +1 @@
+^{pageBody tbl}