Add Pagination

package.yaml

@@ -24,6 +24,7 @@ dependencies:
 - containers
 - envy
 - lens
+- network-uri
 - openapi3
 - parsec
 - parsec-extra

src/Tutor/Api.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
 
@@ -24,12 +25,16 @@ import qualified Data.Text as T
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
 import GHC.Generics (Generic)
+import Network.URI
 import qualified Paths_tutor as PT
 import Servant
 import Servant.OpenApi (HasOpenApi (toOpenApi))
+import qualified Tutor.Pagination as Pagination
 import Tutor.Card
 import Tutor.Config
 import Tutor.Database
+import Data.Maybe (fromMaybe)
+import qualified Data.Text.Lazy.Lens as T
 
 data Status = Status
   { apiVersion :: T.Text,
@@ -68,6 +73,11 @@ type GetStatus =
     :> "status"
     :> Get '[JSON] Status
 
+type LinkHeaders =
+  '[ Header "Link" T.Text
+   , Header "Link" T.Text
+   , Header "Link" T.Text]
+
 type SearchCards =
   Summary "Search for cards in a collection"
     :> Description
@@ -176,7 +186,9 @@ type SearchCards =
     :> QueryParam' '[Description "Query string"] "q" T.Text
     :> QueryParam' '[Description "Sorting method"] "sort_by" T.Text
     :> QueryParam' '[Description "Search across collection or all cards"] "in_collection" T.Text
-    :> Get '[JSON] [Card]
+    :> QueryParam' '[Description "Pagination limit"] "limit" Int
+    :> QueryParam' '[Description "Pagination offset"] "offset" Int
+    :> Get '[JSON] (Headers LinkHeaders [Card])
 
 type TutorAPI =
   GetStatus
@@ -206,9 +218,25 @@ openapi =
 tutorServer :: Config -> Server TutorAPI
 tutorServer config = status config :<|> searchCards (tutorDatabase config)
   where
-    searchCards :: FilePath -> Maybe T.Text -> Maybe T.Text -> Maybe T.Text -> Handler [Card]
-    searchCards dbFile q sortBy inCollection =
-      liftIO $ Tutor.Database.searchCards dbFile q sortBy inCollection
+    searchCards :: FilePath -> Maybe T.Text -> Maybe T.Text -> Maybe T.Text -> Maybe Int -> Maybe Int -> Handler (Headers LinkHeaders [Card])
+    searchCards dbFile q sortBy inCollection limit offset = do
+      page <- liftIO $ Tutor.Database.searchCards dbFile q sortBy inCollection pagination
+      return $ headers page (Pagination.items page)
+      where pagination = Pagination.Pagination (fromMaybe 10 limit) (fromMaybe 0 offset)
+            headers page = self . next page . prev page
+            self = addHeader $ link "self" $ uri limit offset
+            next Pagination.Page {Pagination.next = Just p} = addHeader $ link "next" $ uri (Just $ Pagination.limit p) (Just $ Pagination.offset p)
+            next _ = noHeader
+            prev Pagination.Page {Pagination.previous = Just p} = addHeader $ link "prev" $ uri (Just $ Pagination.limit p) (Just $ Pagination.offset p)
+            prev _ = noHeader
+            uri :: Maybe Int -> Maybe Int -> URI
+            uri limit' offset' =
+              -- TODO: Apply the generated relative URI to the requested absolute URI
+              relativeTo
+                (linkURI $ safeLink api (Proxy :: Proxy SearchCards) q sortBy inCollection limit' offset')
+                (configuredBaseURI config)
+            link :: T.Text -> URI -> T.Text
+            link rel uri = T.concat ["<", T.pack $ show uri, ">; rel=\"", rel, "\""]
 
 docsServer :: Server DocsAPI
 docsServer = return openapi

src/Tutor/Config.hs

@@ -1,14 +1,16 @@
 {-# LANGUAGE DeriveGeneric #-}
 
-module Tutor.Config (Config (..), defaultConfig) where
+module Tutor.Config (Config (..), defaultConfig, configuredBaseURI) where
 
 import GHC.Generics
+import Network.URI
 import System.Envy
 
 data Config = Config
   { tutorPort :: Int,
     tutorDatabase :: FilePath,
-    tutorStatic :: FilePath
+    tutorStatic :: FilePath,
+    tutorBaseUrl :: Maybe String
   }
   deriving (Generic, Show)
 
@@ -16,7 +18,14 @@ defaultConfig =
   Config
     { tutorPort = 8000,
       tutorDatabase = "tutor.db",
-      tutorStatic = "www/public"
+      tutorStatic = "www/public",
+      tutorBaseUrl = Nothing
     }
 
+configuredBaseURI :: Config -> URI
+configuredBaseURI config =
+  case tutorBaseUrl config >>= parseURI of
+    Just uri -> uri
+    Nothing -> URI "http:" (Just $ URIAuth "" "localhost" (":" ++ show (tutorPort config))) "/" "" ""
+
 instance FromEnv Config

src/Tutor/Database.hs

@@ -14,12 +14,13 @@ import Database.SQLite.Simple.Internal
 import Database.SQLite.Simple.Ok
 import Database.SQLite.Simple.QQ
 import Tutor.Card
+import qualified Tutor.Pagination as Pagination
 import qualified Tutor.Search as Search
 import Tutor.SearchParser
 import Tutor.Select
   ( Select (..),
     join,
-    limit,
+    limitOffset,
     orderBy,
     parameter,
     selectSimple,
@@ -198,14 +199,23 @@ instance FromRow Card where
               }
         }
 
-searchCards :: FilePath -> Maybe T.Text -> Maybe T.Text -> Maybe T.Text -> IO [Card]
-searchCards dbFile q sortBy inCollection =
+searchCards :: FilePath -> Maybe T.Text -> Maybe T.Text -> Maybe T.Text -> Pagination.Pagination -> IO (Pagination.Page Card)
+searchCards dbFile q sortBy inCollection pagination =
   withConnection dbFile $ \conn ->
-    queryNamed
+    asPage <$> queryNamed
       conn
       (toQuery query)
       (selectParameters query)
   where
+    limit = Pagination.limit pagination
+    offset = Pagination.offset pagination
+    asPage results =
+      if length results > limit then
+        Pagination.Page prev (Just $ Pagination.Pagination limit (offset + limit)) (take limit results)
+      else
+        Pagination.Page prev Nothing results
+      where
+        prev = if offset > 0 then Just $ Pagination.Pagination limit (max 0 (offset - limit)) else Nothing
     baseQuery =
       selectSimple
         [ "cards.scryfall_id",
@@ -234,7 +244,7 @@ searchCards dbFile q sortBy inCollection =
              ELSE cards.color_identity END ASC|]
         <> orderBy "cards.name ASC"
         <> parameter ":last_update_key" ("last_update" :: T.Text)
-        <> limit 10
+        <> limitOffset (1 + Pagination.limit pagination) (Pagination.offset pagination)
     query =
       mconcat $
         catMaybes

src/Tutor/Pagination.hs

@@ -0,0 +1,12 @@
+module Tutor.Pagination (Pagination(..), Page(..)) where
+
+data Pagination = Pagination
+  { limit :: Int
+  , offset :: Int
+  }
+
+data Page a = Page
+  { previous :: Maybe Pagination
+  , next :: Maybe Pagination
+  , items :: [a]
+  }

src/Tutor/Select.hs

@@ -96,7 +96,7 @@ toQuery select =
       [] -> Nothing
       xs -> Just $ "ORDER BY " <> sqlJoin ", " xs
     sqlLimitOffset = case (selectLimit select, selectOffset select) of
-      (Just l, Just o) -> Just "LIMIT :__limit, :__offset"
+      (Just l, Just o) -> Just "LIMIT :__limit OFFSET :__offset"
       (Just l, Nothing) -> Just "LIMIT :__limit"
       _ -> Nothing