Add servant-paginated-client

see https://stackoverflow.com/q/78947054/5247502

.github/workflows/build.yml

@@ -43,3 +43,8 @@ jobs:
         run: |
           stack build --system-ghc --test --coverage --copy-bins --local-bin-path .
 
+      - name: Build servant-paginated-client
+        working-directory: ./servant-paginated-client
+        run: |
+          stack build --system-ghc --test --coverage --copy-bins --local-bin-path .
+

servant-paginated-client/.gitignore

@@ -0,0 +1,4 @@
+.stack-work/
+*~
+tags
+.idea/

servant-paginated-client/ChangeLog.md

@@ -0,0 +1,3 @@
+# Changelog for servant-paginated-client
+
+## Unreleased changes

servant-paginated-client/LICENSE

@@ -0,0 +1,30 @@
+Copyright Leonhard Riedißer (c) 2022
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Leonhard Riedißer nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

servant-paginated-client/README.md

@@ -0,0 +1,5 @@
+# servant-paginated-client
+
+Example project for implementing client-side pagination with servant-client.
+
+Related to [this stackoverflow question](https://stackoverflow.com/q/78947054/5247502)

servant-paginated-client/app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Lib
+
+main :: IO ()
+main = startServer

servant-paginated-client/package.yaml

@@ -0,0 +1,74 @@
+name: servant-paginated-client
+version: 0.1.0.0
+github: "L7R7/haskell-incubator/servant-paginated-client"
+license: BSD3
+author: "Leonhard Riedißer"
+maintainer: "[email protected]"
+copyright: "2024 Leonhard Riedißer"
+
+extra-source-files:
+  - README.md
+  - ChangeLog.md
+
+description: Please see the README on GitHub at <https://github.com/L7R7/haskell-incubator/servant-type-roles#readme>
+
+dependencies:
+  - base >= 4.7 && < 5
+
+ghc-options:
+  - -fwrite-ide-info
+  - -hiedir=.hie
+  - -Wall
+  - -Wcompat
+  - -Widentities
+  - -Wincomplete-uni-patterns
+  - -Wincomplete-record-updates
+  - -Wredundant-constraints
+  - -fhide-source-paths
+  - -Wpartial-fields
+  - -Wmissing-deriving-strategies
+  - -Wunused-packages
+
+library:
+  source-dirs: src
+  dependencies:
+    - http-client
+    - http-link-header
+    - mtl
+    - servant
+    - servant-client
+    - servant-server
+    - text
+    - utf8-string
+    - warp
+  ghc-options:
+    - -O2
+    - -flate-specialise
+    - -fspecialise-aggressively
+    - -Wmissing-export-lists
+
+executables:
+  servant-paginated-client-exe:
+    main: Main.hs
+    source-dirs: app
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
+    dependencies:
+      - servant-paginated-client
+
+tests:
+  servant-paginated-client-test:
+    main: Spec.hs
+    source-dirs: test
+    build-tools: sydtest-discover
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
+    dependencies:
+      - servant-paginated-client
+      - servant-server
+      - sydtest
+      - sydtest-servant

servant-paginated-client/servant-paginated-client.cabal

@@ -0,0 +1,78 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.37.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:           servant-paginated-client
+version:        0.1.0.0
+description:    Please see the README on GitHub at <https://github.com/L7R7/haskell-incubator/servant-type-roles#readme>
+homepage:       https://github.com/L7R7/haskell-incubator#readme
+bug-reports:    https://github.com/L7R7/haskell-incubator/issues
+author:         Leonhard Riedißer
+maintainer:     [email protected]
+copyright:      2024 Leonhard Riedißer
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+    ChangeLog.md
+
+source-repository head
+  type: git
+  location: https://github.com/L7R7/haskell-incubator
+  subdir: servant-paginated-client
+
+library
+  exposed-modules:
+      Lib
+      Pagination
+  other-modules:
+      Paths_servant_paginated_client
+  hs-source-dirs:
+      src
+  ghc-options: -fwrite-ide-info -hiedir=.hie -Wall -Wcompat -Widentities -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -fhide-source-paths -Wpartial-fields -Wmissing-deriving-strategies -Wunused-packages -O2 -flate-specialise -fspecialise-aggressively -Wmissing-export-lists
+  build-depends:
+      base >=4.7 && <5
+    , http-client
+    , http-link-header
+    , mtl
+    , servant
+    , servant-client
+    , servant-server
+    , text
+    , utf8-string
+    , warp
+  default-language: Haskell2010
+
+executable servant-paginated-client-exe
+  main-is: Main.hs
+  other-modules:
+      Paths_servant_paginated_client
+  hs-source-dirs:
+      app
+  ghc-options: -fwrite-ide-info -hiedir=.hie -Wall -Wcompat -Widentities -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -fhide-source-paths -Wpartial-fields -Wmissing-deriving-strategies -Wunused-packages -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , servant-paginated-client
+  default-language: Haskell2010
+
+test-suite servant-paginated-client-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      ServerSpec
+      Paths_servant_paginated_client
+  hs-source-dirs:
+      test
+  ghc-options: -fwrite-ide-info -hiedir=.hie -Wall -Wcompat -Widentities -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -fhide-source-paths -Wpartial-fields -Wmissing-deriving-strategies -Wunused-packages -threaded -rtsopts -with-rtsopts=-N
+  build-tool-depends:
+      sydtest-discover:sydtest-discover
+  build-depends:
+      base >=4.7 && <5
+    , servant-paginated-client
+    , servant-server
+    , sydtest
+    , sydtest-servant
+  default-language: Haskell2010

servant-paginated-client/src/Lib.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Lib (API, startServer, server, singleClient, paginatedClient) where
+
+import Data.Maybe (fromMaybe)
+import Data.Proxy
+import Data.Text hiding (all, find, take)
+import Network.Wai.Handler.Warp (run)
+import Pagination
+import Servant.API
+import Servant.Client
+import Servant.Server
+
+type API =
+  "single-content" :> Get '[JSON] Int
+    :<|> "contents" :> QueryParam "page" Int :> Get '[JSON] (Headers '[Header "Link" Text] [Int])
+
+server :: Server API
+server =
+  pure 5
+    :<|> ( \maybePage -> do
+             let page = fromMaybe 0 maybePage
+                 nextLink =
+                   if page < 5
+                     then addHeader ("</contents?page=" <> pack (show (page + 1)) <> ">; rel=\"next\"")
+                     else noHeader
+             pure $ nextLink $ take 10 [(page * 10) ..]
+         )
+
+app :: Application
+app = serve (Proxy @API) server
+
+startServer :: IO ()
+startServer = do
+  let port = 8080
+  putStrLn $ "Serving endpoint " ++ show port
+  run port app
+
+paginatedClientInner :: Maybe Int -> ClientM (Headers '[Header "Link" Text] [Int])
+singleClientInner :: ClientM Int
+singleClientInner :<|> paginatedClientInner = client (Proxy :: Proxy API)
+
+paginatedClient :: Maybe Int -> ClientM (Headers '[Header "Link" Text] [Int])
+paginatedClient = paginated . paginatedClientInner
+
+singleClient :: ClientM Int
+singleClient = singleClientInner

servant-paginated-client/src/Pagination.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Pagination (paginated) where
+
+import Control.Exception (throwIO)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Reader (local)
+import qualified Data.ByteString.UTF8 as BS
+import Data.Foldable
+import Data.Text hiding (all, find, take)
+import GHC.TypeLits (Symbol)
+import qualified Network.HTTP.Client.Internal as Http
+import Network.HTTP.Link
+import Servant.API
+import Servant.Client
+
+-- see: https://stackoverflow.com/a/78954717/5247502
+paginated ::
+  forall (s :: Symbol) rest a.
+  (Monoid a) =>
+  ClientM (Headers (Header s Text ': rest) a) ->
+  ClientM (Headers (Header s Text ': rest) a)
+paginated initial = do
+  let overrideUrl :: URI -> ClientM b -> ClientM b
+      overrideUrl uri action = do
+        let transformClientRequest original =
+              original {Http.path = BS.fromString (uriPath uri), Http.queryString = BS.fromString (uriQuery uri)}
+            transformMakeClientRequest f host servantReq = do
+              httpReq <- f host servantReq
+              pure $ transformClientRequest httpReq
+            transformClientEnv clientEnv =
+              clientEnv {makeClientRequest = transformMakeClientRequest (makeClientRequest clientEnv)}
+        local transformClientEnv action
+
+      go :: ClientM (Headers (Header s Text ': rest) a) -> a -> ClientM (Headers (Header s Text ': rest) a)
+      go action acc = do
+        r <- action
+        let acc' = acc <> getResponse r
+            HCons header _ = getHeadersHList r
+        case header of
+          UndecodableHeader {} -> do
+            liftIO $ throwIO $ userError "undecodable header"
+          MissingHeader -> do
+            pure $ r {getResponse = acc'}
+          Header next -> do
+            let maybeNextLink = do
+                  linkHeaders <- parseLinkHeader next
+                  nextLink <- find (all (\tpl -> tpl == (Rel, "next")) . linkParams) linkHeaders
+                  pure $ href nextLink
+            case maybeNextLink of
+              Just nextLink -> go (overrideUrl nextLink initial) acc'
+              Nothing -> pure $ r {getResponse = acc'}
+  go initial mempty

servant-paginated-client/stack.yaml

@@ -0,0 +1,6 @@
+resolver: lts-22.34
+
+packages:
+  - .
+
+extra-deps: []

servant-paginated-client/stack.yaml.lock

@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    sha256: edbd50d7e7c85c13ad5f5835ae2db92fab1e9cf05ecf85340e2622ec0a303df1
+    size: 720020
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/34.yaml
+  original: lts-22.34

servant-paginated-client/test/ServerSpec.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module ServerSpec (spec) where
+
+import Lib
+import Servant
+import Test.Syd
+import Test.Syd.Servant
+
+spec :: Spec
+spec = do
+  servantSpec (Proxy :: Proxy API) server $ do
+    it "single endpoint" $ do
+      res <- singleClient
+      liftIO $ res `shouldBe` 5
+    it "list endpoint" $ do
+      (Headers res _) <- paginatedClient Nothing
+      liftIO $ res `shouldBe` [0 .. 59]

servant-paginated-client/test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}