{-# 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

-- | @'withPage'@ and adding pagination data to a @Link@ response header
--
-- Links added by this function are relative. See 'withPageLinkAbsolute'.
--
withPageLink
  :: ( MonadHandler m
     , ToJSON position
     , FromJSON position
     , RenderRoute (HandlerSite m)
     )
  => Int
  -- ^ Default limit if not specified in the @'Cursor'@
  --
  -- Must be a positive natural number.
  --
  -> (a -> position)
  -- ^ How to get an item's position
  --
  -- For example, this would be @'entityKey'@ for paginated @'Entity'@ values.
  --
  -> (Cursor position -> m [a])
  -- ^ How to fetch one page of data at the given @'Cursor'@
  -> 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

-- | @'withPage'@ and adding pagination data to a @Link@ response header
--
-- If you've set an 'approot', links added by this function will be absolute
-- using it. If not, this function will be equivalent to 'withPageLink'.
--
withPageLinkAbsolute
  :: ( MonadHandler m
     , ToJSON position
     , FromJSON position
     , Yesod (HandlerSite m)
     , RenderRoute (HandlerSite m)
     )
  => Int
  -- ^ Default limit if not specified in the @'Cursor'@
  --
  -- Must be a positive natural number.
  --
  -> (a -> position)
  -- ^ How to get an item's position
  --
  -- For example, this would be @'entityKey'@ for paginated @'Entity'@ values.
  --
  -> (Cursor position -> m [a])
  -- ^ How to fetch one page of data at the given @'Cursor'@
  -> 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

-- | Paginate data and construct a 'Page' object.
--
-- Links added by this function are relative. See 'withPageAbsolute'.
--
withPage
  :: ( MonadHandler m
     , ToJSON position
     , FromJSON position
     , RenderRoute (HandlerSite m)
     )
  => Int
  -- ^ Default limit if not specified in the @'Cursor'@
  --
  -- Must be a positive natural number.
  --
  -> (a -> position)
  -- ^ How to get an item's position
  --
  -- For example, this would be @'entityKey'@ for paginated @'Entity'@ values.
  --
  -> (Cursor position -> m [a])
  -- ^ How to fetch one page of data at the given @'Cursor'@
  -> 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

  -- We have to fetch page-size+1 items to know if there is a next page or not
  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
    }

-- | 'withPage', but using absolute links
--
-- If you've set an 'approot', links added by this function will be absolute
-- using it. If not, this function will be equivalent to 'withPage'.
--
withPageAbsolute
  :: ( MonadHandler m
     , ToJSON position
     , FromJSON position
     , Yesod (HandlerSite m)
     , RenderRoute (HandlerSite m)
     )
  => Int
  -- ^ Default limit if not specified in the @'Cursor'@
  --
  -- Must be a positive natural number.
  --
  -> (a -> position)
  -- ^ How to get an item's position
  --
  -- For example, this would be @'entityKey'@ for paginated @'Entity'@ values.
  --
  -> (Cursor position -> m [a])
  -- ^ How to fetch one page of data at the given @'Cursor'@
  -> 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

  -- We have to fetch page-size+1 items to know if there is a next page or not
  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
    ]

-- | An encoding of the position in a page
--
-- A Cursor encodes all necessary information to determine the position in a
-- specific page.
--
data Cursor position = Cursor
  { Cursor position -> RenderedRoute
cursorRoute :: RenderedRoute -- ^ The route of the parsed request
  , Cursor position -> Position position
cursorPosition :: Position position -- ^ The last position seen by the endpoint consumer
  , Cursor position -> Limit
cursorLimit :: Limit -- ^ The page size requested by the endpoint consumer
  }

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'