diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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": [...] } diff --git a/src/Yesod/Page.hs b/src/Yesod/Page.hs --- a/src/Yesod/Page.hs +++ b/src/Yesod/Page.hs @@ -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 diff --git a/src/Yesod/Page/RenderedRoute.hs b/src/Yesod/Page/RenderedRoute.hs --- a/src/Yesod/Page/RenderedRoute.hs +++ b/src/Yesod/Page/RenderedRoute.hs @@ -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 -- diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/TestApp.hs b/test/TestApp.hs --- a/test/TestApp.hs +++ b/test/TestApp.hs @@ -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 diff --git a/yesod-page-cursor.cabal b/yesod-page-cursor.cabal --- a/yesod-page-cursor.cabal +++ b/yesod-page-cursor.cabal @@ -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