module Yesod.Paginate (
paginate, paginateWith, paginateWithConfig,
PageConfig(..), def,
Page(..)
) where
import Control.Monad
import Data.Default
import Data.Int
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text.Read as R
import Database.Esqueleto
import Database.Esqueleto.Internal.Language
import Database.Esqueleto.Internal.Sql
import Prelude
import Text.Shakespeare.Text
import Yesod hiding (Value)
data PageConfig = PageConfig
{ pageSize :: Int64
, currentPage :: Int64
} deriving Show
instance Default PageConfig where
def = PageConfig { pageSize = 10, currentPage = 1 }
data Page r = Page
{ pageResults :: [r]
, nextPage :: Maybe Text
, previousPage :: Maybe Text
} deriving (Eq, Read, Show)
paginate :: (From SqlQuery SqlExpr SqlBackend a, RenderRoute site,
YesodPersist site, SqlSelect a r,
YesodPersistBackend site ~ SqlPersistT)
=> HandlerT site IO (Page r)
paginate = paginateWith return
paginateWith :: (From SqlQuery SqlExpr SqlBackend t, SqlSelect a r,
RenderRoute site, YesodPersist site,
YesodPersistBackend site ~ SqlPersistT)
=> (t -> SqlQuery a)
-> HandlerT site IO (Page r)
paginateWith sel = do
params <- liftM2 (\a b -> fst a ++ reqGetParams b)
runRequestBody getRequest
let currentPage = maybe 1 (fromMaybe 1 . decimalM)
$ lookup "page" params
pageSize = within (5, 50)
. maybe 10 (fromMaybe 10 . decimalM)
$ lookup "count" params
paginateWithConfig def { pageSize, currentPage } sel
paginateWithConfig :: (From SqlQuery SqlExpr SqlBackend t, SqlSelect a r,
RenderRoute site, YesodPersist site,
YesodPersistBackend site ~ SqlPersistT)
=> PageConfig
-> (t -> SqlQuery a)
-> HandlerT site IO (Page r)
paginateWithConfig c sel = do
let filterStmt u = limit (pageSize c) >> return u
cp = max 1 $ currentPage c
es <- runDB $ select $ from $ \u -> do
_ <- filterStmt u
limit (pageSize c + 1)
offset $ max 0 $ pageSize c * (cp 1)
sel u
rt' <- getCurrentRoute
rend <- getUrlRenderParams
let rt = fromMaybe (error "Attempting to use paginate on a server error page.") rt'
qs = snd $ renderRoute rt
np = rend rt $ updateQs qs ("page", [st|#{cp + 1}|])
pp = rend rt $ updateQs qs ("page", [st|#{cp 1}|])
return Page { pageResults = take (fromIntegral $ pageSize c) es
, nextPage = if fromIntegral (length es) == pageSize c + 1
then Just np
else Nothing
, previousPage = if cp == 1 then Nothing else Just pp
}
where
updateQs ((a,b):as) (k,v) | k == a = (k,v):as
| otherwise = (a,b):updateQs as (k,v)
updateQs [] (k,v) = [(k,v)]
decimalM :: Integral a => Text -> Maybe a
decimalM t = case R.decimal t of
Right (i, _) -> Just i
Left _ -> Nothing
within :: Ord a => (a,a) -> a -> a
within (a,b) _ | b < a = error "within error"
within (a,b) q | q <= a = a
| q >= b = b
| otherwise = q