{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Yesod.Page
( withPageLink
, withPageLinkAbsolute
, withPage
, withPageAbsolute
, 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)
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
, Yesod
, addHeader
, invalidArgs
, lookupGetParam
)
import Yesod.Page.RenderedRoute
withPageLink
:: ( MonadHandler m
, ToJSON position
, FromJSON position
, RenderRoute (HandlerSite m)
)
=> Int
-> (a -> position)
-> (Cursor position -> m [a])
-> m [a]
withPageLink :: Int -> (a -> position) -> (Cursor position -> m [a]) -> m [a]
withPageLink Int
defaultLimit a -> position
makePosition Cursor position -> m [a]
fetchItems = do
Page a
page <- Int -> (a -> position) -> (Cursor position -> m [a]) -> m (Page a)
forall (m :: * -> *) position a.
(MonadHandler m, ToJSON position, FromJSON position,
RenderRoute (HandlerSite m)) =>
Int -> (a -> position) -> (Cursor position -> m [a]) -> m (Page a)
withPage Int
defaultLimit a -> position
makePosition Cursor position -> m [a]
fetchItems
let
link :: Text
link = [Link URI] -> Text
forall uri. IsURI uri => [Link uri] -> Text
writeLinkHeader ([Link URI] -> Text) -> [Link URI] -> Text
forall a b. (a -> b) -> a -> b
$ [Maybe (Link URI)] -> [Link URI]
forall a. [Maybe a] -> [a]
catMaybes
[ Link URI -> Maybe (Link URI)
forall a. a -> Maybe a
Just (Link URI -> Maybe (Link URI)) -> Link URI -> Maybe (Link URI)
forall a b. (a -> b) -> a -> b
$ Text -> RenderedRoute -> Link URI
renderedRouteLink Text
"first" (RenderedRoute -> Link URI) -> RenderedRoute -> Link URI
forall a b. (a -> b) -> a -> b
$ Page a -> RenderedRoute
forall a. Page a -> RenderedRoute
pageFirst Page a
page
, Text -> RenderedRoute -> Link URI
renderedRouteLink Text
"next" (RenderedRoute -> Link URI)
-> Maybe RenderedRoute -> Maybe (Link URI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Page a -> Maybe RenderedRoute
forall a. Page a -> Maybe RenderedRoute
pageNext Page a
page
, Text -> RenderedRoute -> Link URI
renderedRouteLink Text
"previous" (RenderedRoute -> Link URI)
-> Maybe RenderedRoute -> Maybe (Link URI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Page a -> Maybe RenderedRoute
forall a. Page a -> Maybe RenderedRoute
pagePrevious Page a
page
, Link URI -> Maybe (Link URI)
forall a. a -> Maybe a
Just (Link URI -> Maybe (Link URI)) -> Link URI -> Maybe (Link URI)
forall a b. (a -> b) -> a -> b
$ Text -> RenderedRoute -> Link URI
renderedRouteLink Text
"last" (RenderedRoute -> Link URI) -> RenderedRoute -> Link URI
forall a b. (a -> b) -> a -> b
$ Page a -> RenderedRoute
forall a. Page a -> RenderedRoute
pageLast Page a
page
]
Page a -> [a]
forall a. Page a -> [a]
pageData Page a
page [a] -> m () -> m [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"Link" Text
link
withPageLinkAbsolute
:: ( MonadHandler m
, ToJSON position
, FromJSON position
, Yesod (HandlerSite m)
, RenderRoute (HandlerSite m)
)
=> Int
-> (a -> position)
-> (Cursor position -> m [a])
-> m [a]
withPageLinkAbsolute :: Int -> (a -> position) -> (Cursor position -> m [a]) -> m [a]
withPageLinkAbsolute Int
defaultLimit a -> position
makePosition Cursor position -> m [a]
fetchItems = do
Page a
page <- Int -> (a -> position) -> (Cursor position -> m [a]) -> m (Page a)
forall (m :: * -> *) position a.
(MonadHandler m, ToJSON position, FromJSON position,
Yesod (HandlerSite m), RenderRoute (HandlerSite m)) =>
Int -> (a -> position) -> (Cursor position -> m [a]) -> m (Page a)
withPageAbsolute Int
defaultLimit a -> position
makePosition Cursor position -> m [a]
fetchItems
let
link :: Text
link = [Link URI] -> Text
forall uri. IsURI uri => [Link uri] -> Text
writeLinkHeader ([Link URI] -> Text) -> [Link URI] -> Text
forall a b. (a -> b) -> a -> b
$ [Maybe (Link URI)] -> [Link URI]
forall a. [Maybe a] -> [a]
catMaybes
[ Link URI -> Maybe (Link URI)
forall a. a -> Maybe a
Just (Link URI -> Maybe (Link URI)) -> Link URI -> Maybe (Link URI)
forall a b. (a -> b) -> a -> b
$ Text -> RenderedRoute -> Link URI
renderedRouteLink Text
"first" (RenderedRoute -> Link URI) -> RenderedRoute -> Link URI
forall a b. (a -> b) -> a -> b
$ Page a -> RenderedRoute
forall a. Page a -> RenderedRoute
pageFirst Page a
page
, Text -> RenderedRoute -> Link URI
renderedRouteLink Text
"next" (RenderedRoute -> Link URI)
-> Maybe RenderedRoute -> Maybe (Link URI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Page a -> Maybe RenderedRoute
forall a. Page a -> Maybe RenderedRoute
pageNext Page a
page
, Text -> RenderedRoute -> Link URI
renderedRouteLink Text
"previous" (RenderedRoute -> Link URI)
-> Maybe RenderedRoute -> Maybe (Link URI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Page a -> Maybe RenderedRoute
forall a. Page a -> Maybe RenderedRoute
pagePrevious Page a
page
, Link URI -> Maybe (Link URI)
forall a. a -> Maybe a
Just (Link URI -> Maybe (Link URI)) -> Link URI -> Maybe (Link URI)
forall a b. (a -> b) -> a -> b
$ Text -> RenderedRoute -> Link URI
renderedRouteLink Text
"last" (RenderedRoute -> Link URI) -> RenderedRoute -> Link URI
forall a b. (a -> b) -> a -> b
$ Page a -> RenderedRoute
forall a. Page a -> RenderedRoute
pageLast Page a
page
]
Page a -> [a]
forall a. Page a -> [a]
pageData Page a
page [a] -> m () -> m [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"Link" Text
link
withPage
:: ( MonadHandler m
, ToJSON position
, FromJSON position
, RenderRoute (HandlerSite m)
)
=> Int
-> (a -> position)
-> (Cursor position -> m [a])
-> m (Page a)
withPage :: Int -> (a -> position) -> (Cursor position -> m [a]) -> m (Page a)
withPage Int
defaultLimit a -> position
makePosition Cursor position -> m [a]
fetchItems = do
Cursor position
cursor <- Int -> m (Cursor position)
forall (m :: * -> *) position.
(MonadHandler m, FromJSON position, RenderRoute (HandlerSite m)) =>
Int -> m (Cursor position)
parseCursorParams Int
defaultLimit
let (Limit Int
realLimit) = Cursor position -> Limit
forall position. Cursor position -> Limit
cursorLimit Cursor position
cursor
[a]
items <- Cursor position -> m [a]
fetchItems Cursor position
cursor { cursorLimit :: Limit
cursorLimit = Int -> Limit
Limit (Int -> Limit) -> Int -> Limit
forall a b. (a -> b) -> a -> b
$ Int
realLimit Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
let
page :: [a]
page = case Cursor position -> Position position
forall position. Cursor position -> Position position
cursorPosition Cursor position
cursor of
Position position
First -> Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
realLimit [a]
items
Next{} -> Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
realLimit [a]
items
Previous{} -> Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
takeEnd Int
realLimit [a]
items
Position position
Last -> Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
takeEnd Int
realLimit [a]
items
hasExtraItem :: Bool
hasExtraItem = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
items Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
realLimit
hasNextLink :: Bool
hasNextLink = case Cursor position -> Position position
forall position. Cursor position -> Position position
cursorPosition Cursor position
cursor of
Position position
First -> Bool
hasExtraItem
Next{} -> Bool
hasExtraItem
Previous{} -> Bool
True
Position position
Last -> Bool
False
hasPreviousLink :: Bool
hasPreviousLink = case Cursor position -> Position position
forall position. Cursor position -> Position position
cursorPosition Cursor position
cursor of
Position position
First -> Bool
False
Next{} -> Bool
True
Previous{} -> Bool
hasExtraItem
Position position
Last -> Bool
hasExtraItem
Page a -> m (Page a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Page :: forall a.
[a]
-> RenderedRoute
-> Maybe RenderedRoute
-> Maybe RenderedRoute
-> RenderedRoute
-> Page a
Page
{ pageData :: [a]
pageData = [a]
page
, pageFirst :: RenderedRoute
pageFirst = Cursor position -> Position position -> RenderedRoute
forall position.
ToJSON position =>
Cursor position -> Position position -> RenderedRoute
cursorRouteAtPosition Cursor position
cursor Position position
forall position. Position position
First
, pageNext :: Maybe RenderedRoute
pageNext = do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
hasNextLink
a
item <- [a] -> Maybe a
forall a. [a] -> Maybe a
lastMay [a]
page
RenderedRoute -> Maybe RenderedRoute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RenderedRoute -> Maybe RenderedRoute)
-> RenderedRoute -> Maybe RenderedRoute
forall a b. (a -> b) -> a -> b
$ Cursor position -> Position position -> RenderedRoute
forall position.
ToJSON position =>
Cursor position -> Position position -> RenderedRoute
cursorRouteAtPosition Cursor position
cursor (Position position -> RenderedRoute)
-> Position position -> RenderedRoute
forall a b. (a -> b) -> a -> b
$ position -> Position position
forall position. position -> Position position
Next (position -> Position position) -> position -> Position position
forall a b. (a -> b) -> a -> b
$ a -> position
makePosition a
item
, pagePrevious :: Maybe RenderedRoute
pagePrevious = do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
hasPreviousLink
a
item <- [a] -> Maybe a
forall a. [a] -> Maybe a
headMay [a]
page
RenderedRoute -> Maybe RenderedRoute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RenderedRoute -> Maybe RenderedRoute)
-> RenderedRoute -> Maybe RenderedRoute
forall a b. (a -> b) -> a -> b
$ Cursor position -> Position position -> RenderedRoute
forall position.
ToJSON position =>
Cursor position -> Position position -> RenderedRoute
cursorRouteAtPosition Cursor position
cursor (Position position -> RenderedRoute)
-> Position position -> RenderedRoute
forall a b. (a -> b) -> a -> b
$ position -> Position position
forall position. position -> Position position
Previous (position -> Position position) -> position -> Position position
forall a b. (a -> b) -> a -> b
$ a -> position
makePosition a
item
, pageLast :: RenderedRoute
pageLast = Cursor position -> Position position -> RenderedRoute
forall position.
ToJSON position =>
Cursor position -> Position position -> RenderedRoute
cursorRouteAtPosition Cursor position
cursor Position position
forall position. Position position
Last
}
withPageAbsolute
:: ( MonadHandler m
, ToJSON position
, FromJSON position
, Yesod (HandlerSite m)
, RenderRoute (HandlerSite m)
)
=> Int
-> (a -> position)
-> (Cursor position -> m [a])
-> m (Page a)
withPageAbsolute :: Int -> (a -> position) -> (Cursor position -> m [a]) -> m (Page a)
withPageAbsolute Int
defaultLimit a -> position
makePosition Cursor position -> m [a]
fetchItems = do
Cursor position
cursor <- Int -> m (Cursor position)
forall (m :: * -> *) position.
(MonadHandler m, FromJSON position, Yesod (HandlerSite m),
RenderRoute (HandlerSite m)) =>
Int -> m (Cursor position)
parseCursorParamsAbsolute Int
defaultLimit
let (Limit Int
realLimit) = Cursor position -> Limit
forall position. Cursor position -> Limit
cursorLimit Cursor position
cursor
[a]
items <- Cursor position -> m [a]
fetchItems Cursor position
cursor { cursorLimit :: Limit
cursorLimit = Int -> Limit
Limit (Int -> Limit) -> Int -> Limit
forall a b. (a -> b) -> a -> b
$ Int
realLimit Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
let
page :: [a]
page = case Cursor position -> Position position
forall position. Cursor position -> Position position
cursorPosition Cursor position
cursor of
Position position
First -> Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
realLimit [a]
items
Next{} -> Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
realLimit [a]
items
Previous{} -> Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
takeEnd Int
realLimit [a]
items
Position position
Last -> Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
takeEnd Int
realLimit [a]
items
hasExtraItem :: Bool
hasExtraItem = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
items Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
realLimit
hasNextLink :: Bool
hasNextLink = case Cursor position -> Position position
forall position. Cursor position -> Position position
cursorPosition Cursor position
cursor of
Position position
First -> Bool
hasExtraItem
Next{} -> Bool
hasExtraItem
Previous{} -> Bool
True
Position position
Last -> Bool
False
hasPreviousLink :: Bool
hasPreviousLink = case Cursor position -> Position position
forall position. Cursor position -> Position position
cursorPosition Cursor position
cursor of
Position position
First -> Bool
False
Next{} -> Bool
True
Previous{} -> Bool
hasExtraItem
Position position
Last -> Bool
hasExtraItem
Page a -> m (Page a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Page :: forall a.
[a]
-> RenderedRoute
-> Maybe RenderedRoute
-> Maybe RenderedRoute
-> RenderedRoute
-> Page a
Page
{ pageData :: [a]
pageData = [a]
page
, pageFirst :: RenderedRoute
pageFirst = Cursor position -> Position position -> RenderedRoute
forall position.
ToJSON position =>
Cursor position -> Position position -> RenderedRoute
cursorRouteAtPosition Cursor position
cursor Position position
forall position. Position position
First
, pageNext :: Maybe RenderedRoute
pageNext = do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
hasNextLink
a
item <- [a] -> Maybe a
forall a. [a] -> Maybe a
lastMay [a]
page
RenderedRoute -> Maybe RenderedRoute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RenderedRoute -> Maybe RenderedRoute)
-> RenderedRoute -> Maybe RenderedRoute
forall a b. (a -> b) -> a -> b
$ Cursor position -> Position position -> RenderedRoute
forall position.
ToJSON position =>
Cursor position -> Position position -> RenderedRoute
cursorRouteAtPosition Cursor position
cursor (Position position -> RenderedRoute)
-> Position position -> RenderedRoute
forall a b. (a -> b) -> a -> b
$ position -> Position position
forall position. position -> Position position
Next (position -> Position position) -> position -> Position position
forall a b. (a -> b) -> a -> b
$ a -> position
makePosition a
item
, pagePrevious :: Maybe RenderedRoute
pagePrevious = do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
hasPreviousLink
a
item <- [a] -> Maybe a
forall a. [a] -> Maybe a
headMay [a]
page
RenderedRoute -> Maybe RenderedRoute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RenderedRoute -> Maybe RenderedRoute)
-> RenderedRoute -> Maybe RenderedRoute
forall a b. (a -> b) -> a -> b
$ Cursor position -> Position position -> RenderedRoute
forall position.
ToJSON position =>
Cursor position -> Position position -> RenderedRoute
cursorRouteAtPosition Cursor position
cursor (Position position -> RenderedRoute)
-> Position position -> RenderedRoute
forall a b. (a -> b) -> a -> b
$ position -> Position position
forall position. position -> Position position
Previous (position -> Position position) -> position -> Position position
forall a b. (a -> b) -> a -> b
$ a -> position
makePosition a
item
, pageLast :: RenderedRoute
pageLast = Cursor position -> Position position -> RenderedRoute
forall position.
ToJSON position =>
Cursor position -> Position position -> RenderedRoute
cursorRouteAtPosition Cursor position
cursor Position position
forall position. Position position
Last
}
data Page a = Page
{ Page a -> [a]
pageData :: [a]
, Page a -> RenderedRoute
pageFirst :: RenderedRoute
, Page a -> Maybe RenderedRoute
pageNext :: Maybe RenderedRoute
, Page a -> Maybe RenderedRoute
pagePrevious :: Maybe RenderedRoute
, Page a -> RenderedRoute
pageLast :: RenderedRoute
}
deriving a -> Page b -> Page a
(a -> b) -> Page a -> Page b
(forall a b. (a -> b) -> Page a -> Page b)
-> (forall a b. a -> Page b -> Page a) -> Functor Page
forall a b. a -> Page b -> Page a
forall a b. (a -> b) -> Page a -> Page b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Page b -> Page a
$c<$ :: forall a b. a -> Page b -> Page a
fmap :: (a -> b) -> Page a -> Page b
$cfmap :: forall a b. (a -> b) -> Page a -> Page b
Functor
instance ToJSON a => ToJSON (Page a) where
toJSON :: Page a -> Value
toJSON Page a
p = [Pair] -> Value
object
[ Key
"data" Key -> [a] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Page a -> [a]
forall a. Page a -> [a]
pageData Page a
p
, Key
"first" Key -> RenderedRoute -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Page a -> RenderedRoute
forall a. Page a -> RenderedRoute
pageFirst Page a
p
, Key
"next" Key -> Maybe RenderedRoute -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Page a -> Maybe RenderedRoute
forall a. Page a -> Maybe RenderedRoute
pageNext Page a
p
, Key
"previous" Key -> Maybe RenderedRoute -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Page a -> Maybe RenderedRoute
forall a. Page a -> Maybe RenderedRoute
pagePrevious Page a
p
, Key
"last" Key -> RenderedRoute -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Page a -> RenderedRoute
forall a. Page a -> RenderedRoute
pageLast Page a
p
]
data Cursor position = Cursor
{ Cursor position -> RenderedRoute
cursorRoute :: RenderedRoute
, Cursor position -> Position position
cursorPosition :: Position position
, Cursor position -> Limit
cursorLimit :: Limit
}
data Position position
= First
| Next position
| Previous position
| Last
instance ToJSON position => ToJSON (Position position) where
toJSON :: Position position -> Value
toJSON = \case
Position position
First -> Text -> Value
String Text
"first"
Next position
p -> [Pair] -> Value
object [Key
"next" Key -> position -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= position
p]
Previous position
p -> [Pair] -> Value
object [Key
"previous" Key -> position -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= position
p]
Position position
Last -> Text -> Value
String Text
"last"
instance FromJSON position => FromJSON (Position position) where
parseJSON :: Value -> Parser (Position position)
parseJSON = \case
Value
Null -> Position position -> Parser (Position position)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Position position
forall position. Position position
First
String Text
t -> case Text
t of
Text
"first" -> Position position -> Parser (Position position)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Position position
forall position. Position position
First
Text
"last" -> Position position -> Parser (Position position)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Position position
forall position. Position position
Last
Text
_ -> Parser (Position position)
forall a. Parser a
invalidPosition
Object Object
o -> do
Maybe position
mNext <- Object
o Object -> Key -> Parser (Maybe position)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"next"
Maybe position
mPrevious <- Object
o Object -> Key -> Parser (Maybe position)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"previous"
Parser (Position position)
-> (Position position -> Parser (Position position))
-> Maybe (Position position)
-> Parser (Position position)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Parser (Position position)
forall a. Parser a
invalidPosition Position position -> Parser (Position position)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Position position) -> Parser (Position position))
-> Maybe (Position position) -> Parser (Position position)
forall a b. (a -> b) -> a -> b
$ [Maybe (Position position)] -> Maybe (Position position)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [position -> Position position
forall position. position -> Position position
Next (position -> Position position)
-> Maybe position -> Maybe (Position position)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe position
mNext, position -> Position position
forall position. position -> Position position
Previous (position -> Position position)
-> Maybe position -> Maybe (Position position)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe position
mPrevious]
Value
_ -> Parser (Position position)
forall a. Parser a
invalidPosition
where
invalidPosition :: Parser a
invalidPosition =
String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
(String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ String
"Position must be the String \"first\" or \"last\","
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" or an Object with a \"next\" or \"previous\" key"
newtype Limit = Limit { Limit -> Int
unLimit :: Int }
validateLimit :: Int -> Either String Limit
validateLimit :: Int -> Either String Limit
validateLimit Int
limit
| Int
limit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Int -> Either String Limit
forall a x. Show a => a -> Either String x
badLimit Int
limit
| Bool
otherwise = Limit -> Either String Limit
forall a b. b -> Either a b
Right (Limit -> Either String Limit) -> Limit -> Either String Limit
forall a b. (a -> b) -> a -> b
$ Int -> Limit
Limit Int
limit
readLimit :: Text -> Either String Limit
readLimit :: Text -> Either String Limit
readLimit Text
t = Either String Limit
-> (Int -> Either String Limit) -> Maybe Int -> Either String Limit
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either String Limit
forall a x. Show a => a -> Either String x
badLimit Text
t) Int -> Either String Limit
validateLimit (Maybe Int -> Either String Limit)
-> Maybe Int -> Either String Limit
forall a b. (a -> b) -> a -> b
$ Read Int => String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe @Int (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
t
badLimit :: Show a => a -> Either String x
badLimit :: a -> Either String x
badLimit a
a = String -> Either String x
forall a b. a -> Either a b
Left (String -> Either String x) -> String -> Either String x
forall a b. (a -> b) -> a -> b
$ String
"Limit must be a positive natural number: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
a
cursorRouteAtPosition
:: ToJSON position => Cursor position -> Position position -> RenderedRoute
cursorRouteAtPosition :: Cursor position -> Position position -> RenderedRoute
cursorRouteAtPosition Cursor position
cursor Position position
position =
Text -> Maybe Text -> RenderedRoute -> RenderedRoute
updateQueryParameter Text
"position" (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Position position -> Text
forall a. ToJSON a => a -> Text
encodeText Position position
position)
(RenderedRoute -> RenderedRoute) -> RenderedRoute -> RenderedRoute
forall a b. (a -> b) -> a -> b
$ Cursor position -> RenderedRoute
forall position. Cursor position -> RenderedRoute
cursorRoute Cursor position
cursor
parseCursorParams
:: (MonadHandler m, FromJSON position, RenderRoute (HandlerSite m))
=> Int
-> m (Cursor position)
parseCursorParams :: Int -> m (Cursor position)
parseCursorParams Int
defaultLimit = do
Maybe (Either String (Position position))
mePosition <- (Text -> Either String (Position position))
-> Maybe Text -> Maybe (Either String (Position position))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Either String (Position position)
forall a. FromJSON a => Text -> Either String a
eitherDecodeText (Maybe Text -> Maybe (Either String (Position position)))
-> m (Maybe Text) -> m (Maybe (Either String (Position position)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"position"
Position position
position <- case Maybe (Either String (Position position))
mePosition of
Maybe (Either String (Position position))
Nothing -> Position position -> m (Position position)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Position position
forall position. Position position
First
Just (Left String
err) -> [Text] -> m (Position position)
forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs [String -> Text
pack String
err]
Just (Right Position position
p) -> Position position -> m (Position position)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Position position
p
Limit
limit <-
(String -> m Limit)
-> (Limit -> m Limit) -> Either String Limit -> m Limit
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Text] -> m Limit
forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs ([Text] -> m Limit) -> (String -> [Text]) -> String -> m Limit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) Limit -> m Limit
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Either String Limit -> m Limit)
-> (Maybe Text -> Either String Limit) -> Maybe Text -> m Limit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Limit
-> (Text -> Either String Limit)
-> Maybe Text
-> Either String Limit
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Either String Limit
validateLimit Int
defaultLimit) Text -> Either String Limit
readLimit
(Maybe Text -> m Limit) -> m (Maybe Text) -> m Limit
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"limit"
RenderedRoute
renderedRoute <- m RenderedRoute
forall (m :: * -> *).
(MonadHandler m, RenderRoute (HandlerSite m)) =>
m RenderedRoute
getRenderedRoute
Cursor position -> m (Cursor position)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cursor position -> m (Cursor position))
-> Cursor position -> m (Cursor position)
forall a b. (a -> b) -> a -> b
$ RenderedRoute -> Position position -> Limit -> Cursor position
forall position.
RenderedRoute -> Position position -> Limit -> Cursor position
Cursor RenderedRoute
renderedRoute Position position
position Limit
limit
parseCursorParamsAbsolute
:: ( MonadHandler m
, FromJSON position
, Yesod (HandlerSite m)
, RenderRoute (HandlerSite m)
)
=> Int
-> m (Cursor position)
parseCursorParamsAbsolute :: Int -> m (Cursor position)
parseCursorParamsAbsolute Int
defaultLimit = do
Maybe (Either String (Position position))
mePosition <- (Text -> Either String (Position position))
-> Maybe Text -> Maybe (Either String (Position position))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Either String (Position position)
forall a. FromJSON a => Text -> Either String a
eitherDecodeText (Maybe Text -> Maybe (Either String (Position position)))
-> m (Maybe Text) -> m (Maybe (Either String (Position position)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"position"
Position position
position <- case Maybe (Either String (Position position))
mePosition of
Maybe (Either String (Position position))
Nothing -> Position position -> m (Position position)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Position position
forall position. Position position
First
Just (Left String
err) -> [Text] -> m (Position position)
forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs [String -> Text
pack String
err]
Just (Right Position position
p) -> Position position -> m (Position position)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Position position
p
Limit
limit <-
(String -> m Limit)
-> (Limit -> m Limit) -> Either String Limit -> m Limit
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Text] -> m Limit
forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs ([Text] -> m Limit) -> (String -> [Text]) -> String -> m Limit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) Limit -> m Limit
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Either String Limit -> m Limit)
-> (Maybe Text -> Either String Limit) -> Maybe Text -> m Limit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Limit
-> (Text -> Either String Limit)
-> Maybe Text
-> Either String Limit
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Either String Limit
validateLimit Int
defaultLimit) Text -> Either String Limit
readLimit
(Maybe Text -> m Limit) -> m (Maybe Text) -> m Limit
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"limit"
RenderedRoute
renderedRoute <- m RenderedRoute
forall (m :: * -> *).
(MonadHandler m, Yesod (HandlerSite m),
RenderRoute (HandlerSite m)) =>
m RenderedRoute
getRenderedRouteAbsolute
Cursor position -> m (Cursor position)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cursor position -> m (Cursor position))
-> Cursor position -> m (Cursor position)
forall a b. (a -> b) -> a -> b
$ RenderedRoute -> Position position -> Limit -> Cursor position
forall position.
RenderedRoute -> Position position -> Limit -> Cursor position
Cursor RenderedRoute
renderedRoute Position position
position Limit
limit
eitherDecodeText :: FromJSON a => Text -> Either String a
eitherDecodeText :: Text -> Either String a
eitherDecodeText = ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String a)
-> (Text -> ByteString) -> Text -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
encodeText :: ToJSON a => a -> Text
encodeText :: a -> Text
encodeText = ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
encode
headMay :: [a] -> Maybe a
headMay :: [a] -> Maybe a
headMay [] = Maybe a
forall a. Maybe a
Nothing
headMay (a
x : [a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
lastMay :: [a] -> Maybe a
lastMay :: [a] -> Maybe a
lastMay [] = Maybe a
forall a. Maybe a
Nothing
lastMay [a
x] = a -> Maybe a
forall a. a -> Maybe a
Just a
x
lastMay (a
_ : [a]
xs) = [a] -> Maybe a
forall a. [a] -> Maybe a
lastMay [a]
xs
takeEnd :: Int -> [a] -> [a]
takeEnd :: Int -> [a] -> [a]
takeEnd Int
i [a]
xs = [a] -> [a] -> [a]
forall a a. [a] -> [a] -> [a]
f [a]
xs (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
i [a]
xs)
where
f :: [a] -> [a] -> [a]
f (a
_ : [a]
xs') (a
_ : [a]
ys) = [a] -> [a] -> [a]
f [a]
xs' [a]
ys
f [a]
xs' [a]
_ = [a]
xs'