add pagination to rest api

3 files changed, 59 insertions, 7 deletions

diff --git a/backend/app/Main.hs b/backend/app/Main.hs
index 3f0072b..2b461e5 100644
--- a/backend/app/Main.hs
+++ b/backend/app/Main.hs
@@ -33,6 +33,7 @@ import Data.Tagged (Tagged (..), untag)
 import Data.Text qualified as T
 import Data.UUID qualified as U
 import Data.UUID.V4 qualified as U
+import Data.Vector qualified as V
 import Git qualified as G
 import Git.Libgit2 qualified as GB
 import Network.HTTP.Types.Status qualified as W
@@ -173,7 +174,7 @@ initRepo root ref = do
                   M.toList . M.unionsWith (++) $
                     map (\f -> M.singleton (takeDirectory f) [f]) fs
             colls <- forM cls $ \(path, files) -> do
-              (value : values) <- do
+              J.Array (V.toList -> (value : values)) <- do
                 liftIO . Q.withStore root ref . Q.withCommit cid $ do
                   Q.query (fromString ("SELECT " <> path <> " FROM " <> path))
               let schema = U.autoTypes' value values
@@ -405,18 +406,32 @@ restApi root ref repoT app req resp = do
             =<< ( Q.withStore root ref $ Q.withCommit rev do
                     Q.query (fromString (printf "SELECT %s FROM %s" c c))
                 )
+        ("GET", ["collection", c, "paginated", read @Int . T.unpack -> limit, read @Int . T.unpack -> offset]) -> do
+          resp . W.responseLBS W.status200 [] . J.encode
+            =<< ( Q.withStore root ref $ Q.withCommit rev do
+                    Q.query
+                      ( fromString
+                          ( printf
+                              "SELECT %s FROM %s%s%s"
+                              c
+                              c
+                              (printf " LIMIT %d" limit :: String)
+                              (printf " OFFSET %d" offset :: String)
+                          )
+                      )
+                )
         ("GET", ["collection", c, i]) -> do
-          resp . W.responseLBS W.status200 [] . J.encode . headMay
+          resp . W.responseLBS W.status200 [] . J.encode . arrayHead
             =<< ( Q.withStore root ref $ Q.withCommit rev do
                     Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
                 )
         ("PUT", ["collection", c, i]) -> do
           when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented"
           o <- J.throwDecode @J.Object =<< W.lazyRequestBody req
-          resp . W.responseLBS W.status200 [] . J.encode . headMay
+          resp . W.responseLBS W.status200 [] . J.encode . arrayHead
             =<< ( Q.withStore root ref do
                     _ <- Q.query (fromString (printf "UPDATE %s SET %s WHERE %s.$fileName == \"%s\"" c (LB.toString (J.encode o)) c i))
-                    [J.Object r] <- Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
+                    J.Array (V.toList -> [J.Object r]) <- Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
                     _ <- Q.query (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (dropNulls r))) c))
                     _ <- buildRefMap
                     Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
@@ -425,15 +440,15 @@ restApi root ref repoT app req resp = do
           when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented"
           i <- ((<> ".json") . U.toText) <$> getUUID
           o <- fmap dropNulls . J.throwDecode @J.Object =<< W.lazyRequestBody req
-          resp . W.responseLBS W.status200 [] . J.encode
+          resp . W.responseLBS W.status200 [] . J.encode . arrayHead
             =<< ( Q.withStore root ref do
                     _ <- Q.query (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (JM.insert "$fileName" (J.String i) o))) c))
                     _ <- buildRefMap
-                    headMay <$> Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
+                    Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
                 )
         ("DELETE", ["collection", c, i]) -> do
           when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented"
-          resp . W.responseLBS W.status200 [] . J.encode . headMay
+          resp . W.responseLBS W.status200 [] . J.encode . arrayHead
             =<< ( Q.withStore root ref do
                     r <- Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
                     Q.query (fromString (printf "DELETE FROM %s WHERE %s.$fileName == \"%s\"" c c i))
@@ -461,3 +476,6 @@ dropNulls =
           (J.Object v') -> Just (J.Object (dropNulls v'))
           _ -> Just v
     )
+
+arrayHead :: J.Value -> J.Value
+arrayHead (J.Array v) = V.head v
diff --git a/backend/backend.cabal b/backend/backend.cabal
index fd0502a..5286cc8 100644
--- a/backend/backend.cabal
+++ b/backend/backend.cabal
@@ -11,6 +11,7 @@ library
     exposed-modules:
         ACMS.API.REST
         ACMS.API.REST.Collection
+        ACMS.API.REST.Collection.Paginated
 
     hs-source-dirs:     lib
     default-language:   GHC2021
@@ -72,6 +73,7 @@ executable backend
         text,
         utf8-string,
         uuid,
+        vector,
         wai,
         warp
 
diff --git a/backend/lib/ACMS/API/REST/Collection/Paginated.hs b/backend/lib/ACMS/API/REST/Collection/Paginated.hs
new file mode 100644
index 0000000..ad98888
--- /dev/null
+++ b/backend/lib/ACMS/API/REST/Collection/Paginated.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module ACMS.API.REST.Collection.Paginated where
+
+import ACMS.API.REST (APIMonad, fetch, restRequest)
+import Collection
+import Data.Aeson qualified as A
+import Data.Function ((&))
+import GHC.Generics (Generic)
+import Text.Printf (printf)
+
+data Pagination = Pagination
+  { limit :: Int,
+    offset :: Int
+  }
+
+data Paginated a = Paginated
+  { count :: Int,
+    data_ :: [a]
+  }
+  deriving (Eq, Show, Generic)
+
+instance (A.FromJSON a) => A.FromJSON (Paginated a)
+
+instance (A.ToJSON a) => A.ToJSON (Paginated a)
+
+list :: (APIMonad m) => Pagination -> Collection -> m (Paginated A.Object)
+list p c =
+  restRequest (printf "/collection/%s/paginated/%d/%d" c.name p.limit p.offset)
+    & fetch
+    >>= A.throwDecode