packages feed

yesod-page-cursor (empty) → 1.0.0.0

raw patch · 9 files changed

+940/−0 lines, 9 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, hspec, hspec-expectations-lifted, http-link-header, http-types, lens, lens-aeson, monad-logger, mtl, network-uri, persistent, persistent-sqlite, persistent-template, scientific, text, time, unliftio, unliftio-core, wai-extra, yesod, yesod-core, yesod-page-cursor, yesod-test

Files

+ ChangeLog.md view
@@ -0,0 +1,9 @@+# Changelog for yesod-cursor++## Unreleased changes++None.++## [v1.0.0.0](https://github.com/freckle/yesod-page-cursor/tree/v1.0.0.0)++Initial release.
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2020 Renaissance Learning Inc++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,121 @@+# yesod-page-cursor++Cursor based pagination for `yesod` using index friendly keyset cursors.++Primer: [No Offset](https://use-the-index-luke.com/no-offset)++```hs+getSomeR :: Handler Value+getSomeR = do+  let+    parseParams =+      (,) <$> Param.required "teacherId" <*> Param.optional "courseId"+  page <- withPage entityPage parseParams $ \Cursor {..} -> do+    let (teacherId, mCourseId) = cursorParams+    fmap (sort cursorPosition) . runDB $ selectList+      (catMaybes+        [ Just $ SomeAssignmentTeacherId ==. teacherId+        , (SomeAssignmentCourseId ==.) <$> mCourseId+        , whereClause cursorPosition+        ]+      )+      [LimitTo $ fromMaybe 100 cursorLimit, orderBy cursorPosition]+  returnJson $ keyValueEntityToJSON <$> page+ where+  whereClause = \case+    First -> Nothing+    Previous p -> Just $ persistIdField <. p+    Next p -> Just $ persistIdField >. p+    Last -> Nothing+  orderBy = \case+    First -> Asc persistIdField+    Previous _ -> Desc persistIdField+    Next _ -> Asc persistIdField+    Last -> Desc persistIdField+  sort = \case+    First -> id+    Previous _ -> reverse+    Next _ -> id+    Last -> reverse+```++`cursorLastPosition` is configurable. A page sorted by `created_at` may look like:++```hs+createdAtPage = PageConfig+  { makePosition = \x ->+      (entityKey x, someAsssignmentCreatedAt $ entityVal x)+  , baseDomain = Nothing+  }++getSortedSomeR :: Handler Value+getSortedSomeR = do+  let parseParams = pure ()+  page <- withPage createdAtPage parseParams $ \Cursor {..} -> do+    fmap (sort cursorPosition) . runDB $ selectList+      (whereClause cursorPosition)+      [ LimitTo $ fromMaybe 100 cursorLimit+      , orderBy cursorPosition+      ]+  returnJson $ keyValueEntityToJSON <$> page+ where+  whereClause = \case+    First -> []+    Previous (pId, createdAt) ->+      [ SomeAssingmentCreatedAt <=. createdAt+      , persistIdField <. pId+      ]+    Next (pId, createdAt) ->+      [ SomeAssingmentCreatedAt >=. createdAt+      , persistIdField >. pId+      ]+    Last -> []+  orderBy = \case+    First -> Asc SomeAssignmentCreatedAt+    Previous _ -> Desc SomeAssignmentCreatedAt+    Next _ -> Asc SomeAssignmentCreatedAt+    Last -> Desc SomeAssignmentCreatedAt+  sort = \case+    First -> id+    Previous _ -> reverse+    Next _ -> id+    Last -> reverse+```++## Usage++Paginated requests return a single page and a link with a cursor token to retrieve the next page.++```sh+$ curl 'some-rest.com/endpoint?limit=3'+{+  "first": : "some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",+  "previous": null,+  "next": "some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",+  "data": [...]+}+```++The link can be used to retrieve the next page.++```sh+$ curl 'some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ=='+{+  "first": : "some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",+  "previous": "some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",+  "next": "some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",+  "data": [...]+}+```++If no pages remain then no link is returned++```sh+$ curl 'some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ=='+{+  "first": : "some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",+  "previous": "some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",+  "next": null,+  "data": [...]+}+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Yesod/Page.hs view
@@ -0,0 +1,224 @@+{-# 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++-- | @'withPage'@ and adding pagination data to a @Link@ response header+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)+  -- ^ 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 makePosition fetchItems = do+  cursor <- parseCursorParams++  -- We have to fetch page-size+1 items to know if there is a next page or not+  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++  pure Page+    { pageData = page+    , pageFirst = cursorRouteAtPosition cursor First+    , pageNext = do+      guard $ length items > realLimit+      item <- lastMay page+      pure+        $ cursorRouteAtPosition cursor+        $ Next+        $ makePosition item+    , pagePrevious = do+      guard $ length items > realLimit+      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+    ]++-- | 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+  { cursorRoute :: RenderedRoute -- ^ The route of the parsed request+  , cursorPosition :: Position position -- ^ The last position seen by the endpoint consumer+  , 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 = \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'
+ src/Yesod/Page/RenderedRoute.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Yesod.Page.RenderedRoute+  ( RenderedRoute+  , renderedRouteLink+  , getRenderedRoute+  , updateQueryParameter+  )+where++import Data.Aeson+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text, intercalate, pack, unpack)+import Network.HTTP.Link+import Network.URI (URI(..), escapeURIString, isUnescapedInURIComponent)+import UnliftIO (throwString)+import Yesod.Core+  ( HandlerSite+  , MonadHandler+  , RenderRoute+  , getCurrentRoute+  , getRequest+  , renderRoute+  , reqGetParams+  )++-- | Information about a relative Route with query string+data RenderedRoute = RenderedRoute+  { renderedRoutePath :: [Text]+  , renderedRouteQuery :: [(Text, Text)]+  }++instance ToJSON RenderedRoute where+  toJSON = String . pack . show . renderedRouteURI++-- | Convert a @'RenderedRoute'@ into a @'Link'@ with the given @'Rel'@+renderedRouteLink :: Text -> RenderedRoute -> Link+renderedRouteLink rel = flip Link [(Rel, rel)] . renderedRouteURI++-- | Convert a @'RenderedRoute'@ into a (relative) @'URI'@+renderedRouteURI :: RenderedRoute -> URI+renderedRouteURI RenderedRoute {..} = URI+  { uriScheme = ""+  , uriAuthority = Nothing+  , uriPath = unpack $ "/" <> intercalate "/" renderedRoutePath+  , uriQuery = unpack $ query renderedRouteQuery+  , uriFragment = ""+  }+ where+  query [] = ""+  query qs = "?" <> intercalate "&" (parts qs)+  parts = map $ \(k, v) -> k <> "=" <> escape v+  escape = pack . escapeURIString isUnescapedInURIComponent . unpack++-- | Get the current route as a @'RenderedRoute'@+getRenderedRoute+  :: (MonadHandler m, RenderRoute (HandlerSite m)) => m RenderedRoute+getRenderedRoute = do+  route <- maybe (throwString "no route") pure =<< getCurrentRoute++  -- When I just use _query, it's always empty. Why would renderRoute return+  -- this tuple if the Route value (apparently) never has the query information?+  let (path, _query) = renderRoute route+  query <- reqGetParams <$> getRequest++  pure $ RenderedRoute {renderedRoutePath = path, renderedRouteQuery = query}++-- | Update a single query parameter and preserve the rest+--+-- If given @'Nothing'@, the parameter is removed.+--+updateQueryParameter :: Text -> Maybe Text -> RenderedRoute -> RenderedRoute+updateQueryParameter name = overQuery . asMap . updateKey name++-- Lens? meh+overQuery+  :: ([(Text, Text)] -> [(Text, Text)]) -> RenderedRoute -> RenderedRoute+overQuery f renderedRoute =+  renderedRoute { renderedRouteQuery = f $ renderedRouteQuery renderedRoute }++asMap :: Ord k => (Map k v -> Map k v) -> [(k, v)] -> [(k, v)]+asMap f = Map.toList . f . Map.fromList++updateKey :: Ord k => k -> Maybe v -> Map k v -> Map k v+updateKey k = maybe (Map.delete k) $ Map.insert k
+ test/Spec.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE OverloadedStrings #-}++module Main+  ( main+  )+where++import Control.Lens ((^..), (^?))+import Control.Monad (replicateM_)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Logger (NoLoggingT, runNoLoggingT)+import Data.Aeson.Lens (key, _Array, _Number, _String)+import Data.ByteString.Lazy (ByteString)+import Data.Foldable (traverse_)+import Data.List (find)+import Data.Maybe (fromMaybe)+import Data.Scientific (Scientific)+import Data.Text (Text, pack, unpack)+import Data.Text.Encoding (decodeUtf8)+import Data.Time (getCurrentTime)+import Database.Persist (Filter, deleteWhere, insert)+import Database.Persist.Sql (SqlPersistT, insertMany_, runMigration)+import GHC.Stack (HasCallStack)+import Network.HTTP.Link+import Network.HTTP.Types.Header (HeaderName)+import Network.Wai.Test (simpleBody, simpleHeaders)+import Test.Hspec (Spec, SpecWith, beforeAll, before_, describe, hspec, it)+import Test.Hspec.Expectations.Lifted (shouldBe, shouldReturn)+import TestApp+import Yesod.Core (RedirectUrl, Yesod)+import Yesod.Test++main :: IO ()+main = hspec spec++spec :: Spec+spec = withApp $ do+  describe "Cursor" $ do+    it "responds with a useful message on invalid limit" $ do+      getPaginated SomeR [("teacherId", "1"), ("limit", "-1")]++      statusIs 400+      bodyContains "must be positive and non-zero"++    it "returns no cursor when there are no items" $ do+      getPaginated SomeR [("teacherId", "1")]++      mayLink "next" `shouldReturn` Nothing++    it "traverses a list with a next Cursor" $ do+      runDB $ insertAssignments 12++      getPaginated SomeR [("teacherId", "1"), ("limit", "4")]++      assertDataKeys [1, 2, 3, 4]+      get =<< getLink "next"+      assertDataKeys [5, 6, 7, 8]+      get =<< getLink "next"+      assertDataKeys [9, 10, 11, 12]++    it "finds a null next when no items are left" $ do+      runDB $ insertAssignments 2++      getPaginated SomeR [("teacherId", "1"), ("limit", "3")]++      assertDataKeys [1, 2]+      mayLink "next" `shouldReturn` Nothing++    it "finds a null next even with limit defaulted" $ do+      runDB $ insertAssignments 2++      getPaginated SomeR [("teacherId", "1")]++      mayLink "next" `shouldReturn` Nothing++    it "finds a null next even with page-aligned data" $ do+      runDB $ insertAssignments 2++      getPaginated SomeR [("teacherId", "1"), ("limit", "2")]++      mayLink "next" `shouldReturn` Nothing++    it "finds a null next on the last page" $ do+      runDB $ insertAssignments 2++      getPaginated SomeR [("teacherId", "1"), ("limit", "2")]++      get =<< getLink "last"+      mayLink "next" `shouldReturn` Nothing++    it "finds a null previous on the first page" $ do+      runDB $ insertAssignments 2++      getPaginated SomeR [("teacherId", "1"), ("limit", "2")]++      mayLink "previous" `shouldReturn` Nothing++    it "returns the same response for the same cursor" $ do+      runDB $ insertAssignments 5++      getPaginated SomeR [("teacherId", "1"), ("limit", "2")]++      assertDataKeys [1, 2]+      next <- getLink "next"+      let+        go = do+          get next+          assertDataKeys [3, 4]+          getBody+      response1 <- go+      response2 <- go+      response1 `shouldBe` response2++    it "limits are optional" $ do+      runDB $ insertAssignments 5++      getPaginated SomeR [("teacherId", "1")]++      _next <- getLink "next"+      assertDataKeys [1, 2, 3, 4, 5]++    it "parses optional params" $ do+      now <- liftIO getCurrentTime+      runDB $ do+        _ <- insert $ SomeAssignment 1 3 now+        replicateM_ 5 . insert $ SomeAssignment 1 2 now++      getPaginated SomeR [("teacherId", "1"), ("courseId", "3")]++      _next <- getLink "next"+      assertDataKeys [1]++    it "can link to first" $ do+      runDB $ insertAssignments 6++      getPaginated SomeR [("teacherId", "1"), ("limit", "2")]++      assertDataKeys [1, 2]+      get =<< getLink "next"+      assertDataKeys [3, 4]+      get =<< getLink "next"+      assertDataKeys [5, 6]+      get =<< getLink "first"+      assertDataKeys [1, 2]++    it "can link to last" $ do+      runDB $ insertAssignments 6++      getPaginated SomeR [("teacherId", "1"), ("limit", "2")]++      assertDataKeys [1, 2]+      get =<< getLink "last"+      assertDataKeys [5, 6]+      get =<< getLink "previous"+      assertDataKeys [3, 4]+      get =<< getLink "previous"+      assertDataKeys [1, 2]++    it "can traverse via Link" $ do+      runDB $ insertAssignments 6++      getPaginated SomeLinkR [("teacherId", "1"), ("limit", "2")]++      assertKeys [1, 2]+      get =<< getLinkViaHeader "next"+      assertKeys [3, 4]+      get =<< getLinkViaHeader "next"+      assertKeys [5, 6]+      get =<< getLinkViaHeader "first"+      assertKeys [1, 2]+      get =<< getLinkViaHeader "last"+      assertKeys [5, 6]+      get =<< getLinkViaHeader "previous"+      assertKeys [3, 4]+      get =<< getLinkViaHeader "previous"+      assertKeys [1, 2]++withApp :: SpecWith (TestApp Simple) -> Spec+withApp = beforeAll (testApp Simple id <$ setupDB) . before_ wipeDB++setupDB :: IO ()+setupDB = liftIO $ runDB $ runMigration migrateAll++wipeDB :: IO ()+wipeDB = liftIO $ runDB deleteAssignments++runDB :: MonadUnliftIO m => SqlPersistT (NoLoggingT m) a -> m a+runDB = runNoLoggingT . runDB'++deleteAssignments :: MonadIO m => SqlPersistT m ()+deleteAssignments = deleteWhere ([] :: [Filter SomeAssignment])++insertAssignments :: MonadIO m => Int -> SqlPersistT m ()+insertAssignments n = do+  now <- liftIO getCurrentTime+  insertMany_ $ replicate n $ SomeAssignment 1 2 now++getPaginated+  :: (Yesod site, RedirectUrl site url)+  => url+  -> [(Text, Text)]+  -> YesodExample site ()+getPaginated url params = request $ do+  setUrl url+  traverse_ (uncurry addGetParam) params++assertDataKeys :: HasCallStack => [Scientific] -> YesodExample site ()+assertDataKeys expectedKeys = do+  statusIs 200+  body <- getBody+  body+    ^.. key "data"+    . _Array+    . traverse+    . key "key"+    . _Number+    `shouldBe` expectedKeys++assertKeys :: HasCallStack => [Scientific] -> YesodExample site ()+assertKeys expectedKeys = do+  statusIs 200+  body <- getBody+  body ^.. _Array . traverse . key "key" . _Number `shouldBe` expectedKeys++getLink :: HasCallStack => Text -> YesodExample site Text+getLink rel =+  fromMaybe (error $ "no " <> unpack rel <> " in JSON response") <$> mayLink rel++mayLink :: Text -> YesodExample site (Maybe Text)+mayLink rel = do+  body <- getBody+  pure $ body ^? key rel . _String++getLinkViaHeader :: HasCallStack => Text -> YesodExample site Text+getLinkViaHeader rel =+  fromMaybe (error $ "no " <> unpack rel <> " in Link header")+    <$> mayLinkViaHeader rel++mayLinkViaHeader :: Text -> YesodExample site (Maybe Text)+mayLinkViaHeader rel = do+  mHeader <- getHeader "Link"++  pure $ do+    header <- mHeader+    parsed <- either (const Nothing) Just $ parseLinkHeader' header+    link <- find (((Rel, rel) `elem`) . linkParams) parsed+    pure $ pack $ show $ href link++getBody :: YesodExample site ByteString+getBody = withResponse $ pure . simpleBody++getHeader :: HeaderName -> YesodExample site (Maybe Text)+getHeader h = withResponse $ pure . fmap decodeUtf8 . lookup h . simpleHeaders
+ test/TestApp.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module TestApp where++import Control.Monad.Logger (MonadLogger)+import Control.Monad.Reader (ReaderT, runReaderT)+import Data.Aeson (ToJSON, Value, defaultOptions, genericToJSON, toJSON)+import Data.List (sortOn)+import Data.Maybe (catMaybes)+import Data.Text (Text, unpack)+import Data.Time (UTCTime)+import Database.Persist+  ( Entity(entityKey)+  , Key+  , SelectOpt(..)+  , keyValueEntityToJSON+  , persistIdField+  , selectList+  , (<.)+  , (==.)+  , (>.)+  )+import Database.Persist.Sql (SqlBackend)+import Database.Persist.Sqlite (withSqliteConn)+import Database.Persist.TH+  (mkMigrate, mkPersist, persistLowerCase, share, sqlSettings)+import GHC.Generics (Generic)+import Network.HTTP.Types.Status (status400)+import Yesod+  ( MonadHandler+  , MonadUnliftIO+  , Yesod+  , YesodPersist+  , YesodPersistBackend+  , lookupGetParam+  , mkYesod+  , parseRoutes+  , renderRoute+  , returnJson+  , runDB+  , sendResponseStatus+  )+import Yesod.Page++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+SomeAssignment+  teacherId Int+  courseId Int+  createdAt UTCTime+  deriving (Generic)+|]++instance ToJSON SomeAssignment where+  toJSON = genericToJSON defaultOptions++data Simple = Simple++instance Yesod Simple++runDB' :: (MonadUnliftIO m, MonadLogger m) => ReaderT SqlBackend m a -> m a+runDB' f = withSqliteConn ":test:" $ runReaderT f++instance YesodPersist Simple where+  type YesodPersistBackend Simple = SqlBackend+  runDB = runDB'++mkYesod "Simple" [parseRoutes|+/some-route SomeR GET+/some-route-link SomeLinkR GET+|]++optionalParam :: Read a => MonadHandler m => Text -> m (Maybe a)+optionalParam name = fmap (read . unpack) <$> lookupGetParam name++requireParam :: (MonadHandler m, Read a) => Text -> m a+requireParam name = maybe badRequest pure =<< optionalParam name+ where+  badRequest =+    sendResponseStatus status400 $ "A " <> name <> " parameter is required."++getSomeR :: Handler Value+getSomeR = makePaginationRoute withPage++getSomeLinkR :: Handler Value+getSomeLinkR = makePaginationRoute withPageLink++type Pagination m f a+  = (Entity a -> Key a) -> (Cursor (Key a) -> m [Entity a]) -> m (f (Entity a))++makePaginationRoute+  :: (Functor f, ToJSON (f Value))+  => Pagination Handler f SomeAssignment+  -> Handler Value+makePaginationRoute withPage' = do+  teacherId <- requireParam "teacherId"+  mCourseId <- optionalParam "courseId"++  items <- withPage' entityKey $ \Cursor {..} ->+    runDB $ sort cursorPosition <$> selectList+      (catMaybes+        [ Just $ SomeAssignmentTeacherId ==. teacherId+        , (SomeAssignmentCourseId ==.) <$> mCourseId+        , whereClause cursorPosition+        ]+      )+      [LimitTo $ unLimit cursorLimit, orderBy cursorPosition]+  returnJson $ keyValueEntityToJSON <$> items+ where+  whereClause = \case+    First -> Nothing+    Next p -> Just $ persistIdField >. p+    Previous p -> Just $ persistIdField <. p+    Last -> Nothing++  orderBy = \case+    First -> Asc persistIdField+    Next{} -> Asc persistIdField+    Previous{} -> Desc persistIdField+    Last -> Desc persistIdField++  sort = \case+    First -> id+    Next{} -> id+    Previous{} -> sortOn entityKey+    Last -> sortOn entityKey
+ yesod-page-cursor.cabal view
@@ -0,0 +1,82 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 234c456d9d19800a8b663bcc97e95b8194624f5d866aba41446788444604a13c++name:           yesod-page-cursor+version:        1.0.0.0+description:    Cursor based pagination for Yesod+homepage:       https://github.com/freckle/yesod-page-cursor#readme+bug-reports:    https://github.com/freckle/yesod-page-cursor/issues+author:         Freckle Engineering+maintainer:     engineering@freckle.com+copyright:      2020 Renaissance Learning Inc+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/freckle/yesod-page-cursor++library+  exposed-modules:+      Yesod.Page+      Yesod.Page.RenderedRoute+  other-modules:+      Paths_yesod_page_cursor+  hs-source-dirs:+      src+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , containers+    , http-link-header+    , network-uri+    , text+    , unliftio+    , yesod-core+  default-language: Haskell2010++test-suite yesod-page-cursor-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      TestApp+      Paths_yesod_page_cursor+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , hspec+    , hspec-expectations-lifted+    , http-link-header+    , http-types+    , lens+    , lens-aeson+    , monad-logger+    , mtl+    , persistent+    , persistent-sqlite+    , persistent-template+    , scientific+    , text+    , time+    , unliftio+    , unliftio-core+    , wai-extra+    , yesod+    , yesod-core+    , yesod-page-cursor+    , yesod-test+  default-language: Haskell2010