yesod-page-cursor 2.0.0.10 → 2.0.1.0

raw patch · 7 files changed

+226/−32 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−2
• README.md +11/−19
• src/Yesod/Page.hs +139/−1
• src/Yesod/Page/RenderedRoute.hs +40/−5
• test/Spec.hs +18/−1
• test/TestApp.hs +13/−3
• yesod-page-cursor.cabal +1/−1

@@ -1,8 +1,10 @@ # Changelog for yesod-cursor -## [Unreleased](https://github.com/freckle/yesod-page-cursor/compare/v2.0.0.10...main)+## [Unreleased](https://github.com/freckle/yesod-page-cursor/compare/v2.0.1.0...main) -- None+## [v2.0.0.10](https://github.com/freckle/yesod-page-cursor/compare/v2.0.0.10...v2.0.1.0)++- Add `withPage{,Link}Absolute` for generate absolute pagination links  ## [v2.0.0.10](https://github.com/freckle/yesod-page-cursor/compare/v2.0.0.9...v2.0.0.10) 

@@ -7,10 +7,9 @@ ```hs getSomeR :: Handler Value getSomeR = do-  let-    parseParams =-      (,) <$> Param.required "teacherId" <*> Param.optional "courseId"-  page <- withPage 100 entityPage parseParams $ \Cursor {..} -> do+  teacherId <- Param.required "teacherId"+  mCourseId <- Param.optional "courseId"+  page <- withPageAbsolute 100 entityKey $ \Cursor {..} -> do     let (teacherId, mCourseId) = cursorParams     fmap (sort cursorPosition) . runDB $ selectList       (catMaybes@@ -43,16 +42,9 @@ like:  ```hs-createdAtPage = PageConfig-  { makePosition = \x ->-      (entityKey x, someAsssignmentCreatedAt $ entityVal x)-  , baseDomain = Nothing-  }- getSortedSomeR :: Handler Value getSortedSomeR = do-  let parseParams = pure ()-  page <- withPage 100 createdAtPage parseParams $ \Cursor {..} -> do+  page <- withPageAbsolute 100 $ \Cursor {..} -> do     fmap (sort cursorPosition) . runDB $ selectList       (whereClause cursorPosition)       [ LimitTo $ fromMaybe 100 cursorLimit@@ -91,9 +83,9 @@ ```sh $ curl 'some-rest.com/endpoint?limit=3' {-  "first": : "some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",+  "first": : "https://some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",   "previous": null,-  "next": "some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",+  "next": "https://some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",   "data": [...] } ```@@ -103,9 +95,9 @@ ```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==",+  "first": : "https://some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",+  "previous": "https://some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",+  "next": "https://some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",   "data": [...] } ```@@ -115,8 +107,8 @@ ```sh $ curl 'some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==' {-  "first": : "some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",-  "previous": "some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",+  "first": : "https://some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",+  "previous": "https://some-rest.com/endpoint?next=eyJsYXN0UG9zaXRpb24iOjMsInBhcmFtcyI6WzEsbnVsbF0sImxpbWl0IjozfQ==",   "next": null,   "data": [...] }

@@ -9,7 +9,9 @@  module Yesod.Page   ( withPageLink+  , withPageLinkAbsolute   , withPage+  , withPageAbsolute   , Page(..)   , Cursor(..)   , Position(..)@@ -31,6 +33,7 @@   ( HandlerSite   , MonadHandler   , RenderRoute+  , Yesod   , addHeader   , invalidArgs   , lookupGetParam@@ -38,6 +41,9 @@ 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@@ -70,6 +76,48 @@    pageData page <$ addHeader "Link" 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 defaultLimit makePosition fetchItems = do+  page <- withPageAbsolute defaultLimit 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++-- | Paginate data and construct a 'Page' object.+--+-- Links added by this function are relative. See 'withPageAbsolute'.+-- withPage   :: ( MonadHandler m      , ToJSON position@@ -131,6 +179,73 @@     , pageLast = cursorRouteAtPosition cursor 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 defaultLimit makePosition fetchItems = do+  cursor <- parseCursorParamsAbsolute defaultLimit++  -- 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++    hasExtraItem = length items > realLimit++    hasNextLink = case cursorPosition cursor of+      First -> hasExtraItem+      Next{} -> hasExtraItem+      Previous{} -> True+      Last -> False++    hasPreviousLink = case cursorPosition cursor of+      First -> False+      Next{} -> True+      Previous{} -> hasExtraItem+      Last -> hasExtraItem++  pure Page+    { pageData = page+    , pageFirst = cursorRouteAtPosition cursor First+    , pageNext = do+      guard hasNextLink+      item <- lastMay page+      pure $ cursorRouteAtPosition cursor $ Next $ makePosition item+    , pagePrevious = do+      guard hasPreviousLink+      item <- headMay page+      pure $ cursorRouteAtPosition cursor $ Previous $ makePosition item+    , pageLast = cursorRouteAtPosition cursor Last+    }+ data Page a = Page   { pageData :: [a]   , pageFirst :: RenderedRoute@@ -138,7 +253,7 @@   , pagePrevious :: Maybe RenderedRoute   , pageLast :: RenderedRoute   }-  deriving (Functor)+  deriving Functor  instance ToJSON a => ToJSON (Page a) where   toJSON p = object@@ -228,6 +343,29 @@     =<< lookupGetParam "limit"    renderedRoute <- getRenderedRoute+  pure $ Cursor renderedRoute position limit++parseCursorParamsAbsolute+  :: ( MonadHandler m+     , FromJSON position+     , Yesod (HandlerSite m)+     , RenderRoute (HandlerSite m)+     )+  => Int+  -> m (Cursor position)+parseCursorParamsAbsolute defaultLimit = 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 (invalidArgs . pure . pack) pure+    . maybe (validateLimit defaultLimit) readLimit+    =<< lookupGetParam "limit"++  renderedRoute <- getRenderedRouteAbsolute   pure $ Cursor renderedRoute position limit  eitherDecodeText :: FromJSON a => Text -> Either String a

@@ -8,6 +8,7 @@   ( RenderedRoute   , renderedRouteLink   , getRenderedRoute+  , getRenderedRouteAbsolute   , updateQueryParameter   ) where@@ -15,23 +16,31 @@ import Data.Aeson import Data.Map (Map) import qualified Data.Map as Map+import Data.Maybe (fromMaybe) import Data.Text (Text, intercalate, pack, unpack) import Network.HTTP.Link.Compat-import Network.URI (URI(..), escapeURIString, isUnescapedInURIComponent)+import Network.URI+  (URI(..), escapeURIString, isUnescapedInURIComponent, parseAbsoluteURI) import UnliftIO (throwString) import Yesod.Core   ( HandlerSite   , MonadHandler   , RenderRoute+  , Yesod+  , approot+  , getApprootText   , getCurrentRoute   , getRequest+  , getYesod   , renderRoute   , reqGetParams+  , waiRequest   )  -- | Information about a relative Route with query string data RenderedRoute = RenderedRoute-  { renderedRoutePath :: [Text]+  { renderedApproot :: Text+  , renderedRoutePath :: [Text]   , renderedRouteQuery :: [(Text, Text)]   } @@ -45,8 +54,8 @@ -- | Convert a @'RenderedRoute'@ into a (relative) @'URI'@ renderedRouteURI :: RenderedRoute -> URI renderedRouteURI RenderedRoute {..} = URI-  { uriScheme = ""-  , uriAuthority = Nothing+  { uriScheme = scheme+  , uriAuthority = authority   , uriPath = unpack $ "/" <> intercalate "/" renderedRoutePath   , uriQuery = unpack $ query renderedRouteQuery   , uriFragment = ""@@ -57,6 +66,10 @@   parts = map $ \(k, v) -> k <> "=" <> escape v   escape = pack . escapeURIString isUnescapedInURIComponent . unpack +  (scheme, authority) = fromMaybe ("", Nothing) $ do+    uri <- parseAbsoluteURI $ unpack renderedApproot+    pure (uriScheme uri, uriAuthority uri)+ -- | Get the current route as a @'RenderedRoute'@ getRenderedRoute   :: (MonadHandler m, RenderRoute (HandlerSite m)) => m RenderedRoute@@ -68,7 +81,29 @@   let (path, _query) = renderRoute route   query <- reqGetParams <$> getRequest -  pure $ RenderedRoute { renderedRoutePath = path, renderedRouteQuery = query }+  pure $ RenderedRoute+    { renderedApproot = ""+    , renderedRoutePath = path+    , renderedRouteQuery = query+    }++getRenderedRouteAbsolute+  :: (MonadHandler m, Yesod (HandlerSite m), RenderRoute (HandlerSite m))+  => m RenderedRoute+getRenderedRouteAbsolute = 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+  root <- getApprootText approot <$> getYesod <*> waiRequest++  pure $ RenderedRoute+    { renderedApproot = root+    , renderedRoutePath = path+    , renderedRouteQuery = query+    }  -- | Update a single query parameter and preserve the rest --

@@ -18,6 +18,7 @@ import Data.Scientific (Scientific) import Data.String (IsString(..)) import Data.Text (Text, pack, unpack)+import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Data.Time (getCurrentTime) import Database.Persist (Filter, deleteWhere, insert)@@ -27,7 +28,7 @@ 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 Test.Hspec.Expectations.Lifted (shouldBe, shouldReturn, shouldSatisfy) import TestApp import Yesod.Core (RedirectUrl, Yesod) import Yesod.Test@@ -180,6 +181,14 @@       get =<< getLink "previous"       assertDataKeys [1, 2] +    it "supports absolute URLS" $ do+      runDB $ insertAssignments 6++      getPaginated SomeAbsoluteR [("teacherId", "1"), ("limit", "2")]++      url <- getLink "next"+      url `shouldSatisfy` ("http://localhost:3000/" `T.isPrefixOf`)+     it "can traverse via Link" $ do       runDB $ insertAssignments 6 @@ -198,6 +207,14 @@       assertKeys [3, 4]       get =<< getLinkViaHeader "previous"       assertKeys [1, 2]++    it "supports absolute URLS via Link" $ do+      runDB $ insertAssignments 6++      getPaginated SomeLinkAbsoluteR [("teacherId", "1"), ("limit", "2")]++      url <- getLinkViaHeader "next"+      url `shouldSatisfy` ("http://localhost:3000/" `T.isPrefixOf`)  withApp :: SpecWith (TestApp Simple) -> Spec withApp = beforeAll (testApp Simple id <$ setupDB) . before_ wipeDB

@@ -41,9 +41,10 @@ import GHC.Generics (Generic) import Network.HTTP.Types.Status (status400) import Yesod-  ( MonadHandler+  ( Approot(..)+  , MonadHandler   , MonadUnliftIO-  , Yesod+  , Yesod(approot)   , YesodPersist   , YesodPersistBackend   , lookupGetParam@@ -71,10 +72,13 @@  mkYesod "Simple" [parseRoutes| /some-route SomeR GET+/some-route-absolute SomeAbsoluteR GET /some-route-link SomeLinkR GET+/some-route-link-absolute SomeLinkAbsoluteR GET |] -instance Yesod Simple+instance Yesod Simple where+  approot = ApprootStatic "http://localhost:3000"  runDB'   :: (MonadUnliftIO m, MonadLogger m, MonadLoggerIO m)@@ -98,8 +102,14 @@ getSomeR :: Handler Value getSomeR = makePaginationRoute withPage +getSomeAbsoluteR :: Handler Value+getSomeAbsoluteR = makePaginationRoute withPageAbsolute+ getSomeLinkR :: Handler Value getSomeLinkR = makePaginationRoute withPageLink++getSomeLinkAbsoluteR :: Handler Value+getSomeLinkAbsoluteR = makePaginationRoute withPageLinkAbsolute  type Pagination m f a   = Int

@@ -1,6 +1,6 @@ cabal-version:   1.18 name:            yesod-page-cursor-version:         2.0.0.10+version:         2.0.1.0 license:         MIT license-file:    LICENSE copyright:       2020 Renaissance Learning Inc