{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Yesod.Page
( withPageLink
, withPage
, Page(..)
, Cursor(..)
, Position(..)
, Limit
, unLimit
)
where
import Control.Monad (guard)
import Data.Aeson
import qualified Data.ByteString.Lazy as BSL
import Data.Foldable (asum)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Network.HTTP.Link (writeLinkHeader)
import Text.Read (readMaybe)
import Yesod.Core
( HandlerSite
, MonadHandler
, RenderRoute
, addHeader
, invalidArgs
, lookupGetParam
)
import Yesod.Page.RenderedRoute
withPageLink
:: ( MonadHandler m
, ToJSON position
, FromJSON position
, RenderRoute (HandlerSite m)
)
=> (a -> position)
-> (Cursor position -> m [a])
-> m [a]
withPageLink makePosition fetchItems = do
page <- withPage makePosition fetchItems
let
link = writeLinkHeader $ catMaybes
[ Just $ renderedRouteLink "first" $ pageFirst page
, renderedRouteLink "next" <$> pageNext page
, renderedRouteLink "previous" <$> pagePrevious page
, Just $ renderedRouteLink "last" $ pageLast page
]
pageData page <$ addHeader "Link" link
withPage
:: ( MonadHandler m
, ToJSON position
, FromJSON position
, RenderRoute (HandlerSite m)
)
=> (a -> position)
-> (Cursor position -> m [a])
-> m (Page a)
withPage makePosition fetchItems = do
cursor <- parseCursorParams
let (Limit realLimit) = cursorLimit cursor
items <- fetchItems cursor { cursorLimit = Limit $ realLimit + 1 }
let
page = case cursorPosition cursor of
First -> take realLimit items
Next{} -> take realLimit items
Previous{} -> takeEnd realLimit items
Last -> takeEnd realLimit items
hasExtraItem = length items > realLimit
hasNextLink = case cursorPosition cursor of
First -> hasExtraItem
Next{} -> hasExtraItem
Previous{} -> True
Last -> False
hasPreviousLink = case cursorPosition cursor of
First -> False
Next{} -> True
Previous{} -> hasExtraItem
Last -> hasExtraItem
pure Page
{ pageData = page
, pageFirst = cursorRouteAtPosition cursor First
, pageNext = do
guard hasNextLink
item <- lastMay page
pure
$ cursorRouteAtPosition cursor
$ Next
$ makePosition item
, pagePrevious = do
guard hasPreviousLink
item <- headMay page
pure
$ cursorRouteAtPosition cursor
$ Previous
$ makePosition item
, pageLast = cursorRouteAtPosition cursor Last
}
data Page a = Page
{ pageData :: [a]
, pageFirst :: RenderedRoute
, pageNext :: Maybe RenderedRoute
, pagePrevious :: Maybe RenderedRoute
, pageLast :: RenderedRoute
}
deriving (Functor)
instance ToJSON a => ToJSON (Page a) where
toJSON p = object
[ "data" .= pageData p
, "first" .= pageFirst p
, "next" .= pageNext p
, "previous" .= pagePrevious p
, "last" .= pageLast p
]
data Cursor position = Cursor
{ cursorRoute :: RenderedRoute
, cursorPosition :: Position position
, cursorLimit :: Limit
}
data Position position
= First
| Next position
| Previous position
| Last
instance ToJSON position => ToJSON (Position position) where
toJSON = \case
First -> String "first"
Next p -> object ["next" .= p ]
Previous p -> object ["previous" .= p]
Last -> String "last"
instance FromJSON position => FromJSON (Position position) where
parseJSON = \case
Null -> pure First
String t -> case t of
"first" -> pure First
"last" -> pure Last
_ -> invalidPosition
Object o -> do
mNext <- o .:? "next"
mPrevious <- o .:? "previous"
maybe invalidPosition pure $ asum
[ Next <$> mNext
, Previous <$> mPrevious
]
_ -> invalidPosition
where
invalidPosition =
fail
$ "Position must be the String \"first\" or \"last\","
<> " or an Object with a \"next\" or \"previous\" key"
newtype Limit = Limit { unLimit :: Int }
readLimit :: Text -> Either String Limit
readLimit t = case readMaybe @Int $ unpack t of
Nothing -> limitMustBe "an integer"
Just limit | limit <= 0 -> limitMustBe "positive and non-zero"
Just limit -> Right $ Limit limit
where
limitMustBe msg = Left $ "Limit must be " <> msg <> ": " <> show t
cursorRouteAtPosition
:: ToJSON position => Cursor position -> Position position -> RenderedRoute
cursorRouteAtPosition cursor position =
updateQueryParameter "position" (Just $ encodeText position) $ cursorRoute cursor
parseCursorParams
:: (MonadHandler m, FromJSON position, RenderRoute (HandlerSite m))
=> m (Cursor position)
parseCursorParams = do
mePosition <- fmap eitherDecodeText <$> lookupGetParam "position"
position <- case mePosition of
Nothing -> pure First
Just (Left err) -> invalidArgs [pack err]
Just (Right p) -> pure p
limit <-
either (\e -> invalidArgs [pack e]) pure
. readLimit
. fromMaybe "100"
=<< lookupGetParam "limit"
renderedRoute <- getRenderedRoute
pure $ Cursor renderedRoute position limit
eitherDecodeText :: FromJSON a => Text -> Either String a
eitherDecodeText = eitherDecode . BSL.fromStrict . encodeUtf8
encodeText :: ToJSON a => a -> Text
encodeText = decodeUtf8 . BSL.toStrict . encode
headMay :: [a] -> Maybe a
headMay [] = Nothing
headMay (x:_) = Just x
lastMay :: [a] -> Maybe a
lastMay [] = Nothing
lastMay [x] = Just x
lastMay (_:xs) = lastMay xs
takeEnd :: Int -> [a] -> [a]
takeEnd i xs = f xs (drop i xs)
where f (_:xs') (_:ys) = f xs' ys
f xs' _ = xs'