aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--backend/app/Main.hs32
-rw-r--r--backend/backend.cabal2
-rw-r--r--backend/lib/ACMS/API/REST/Collection/Paginated.hs32
-rw-r--r--frontend/app/Page/ListCollection.hs8
-rw-r--r--frontend/app/Schema.hs24
5 files changed, 84 insertions, 14 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
diff --git a/frontend/app/Page/ListCollection.hs b/frontend/app/Page/ListCollection.hs
index ff659af..9e3caaa 100644
--- a/frontend/app/Page/ListCollection.hs
+++ b/frontend/app/Page/ListCollection.hs
@@ -8,26 +8,28 @@ module Page.ListCollection
where
import ACMS.API.REST.Collection qualified as API.REST.Collection
+import ACMS.API.REST.Collection.Paginated (Paginated (..))
+import ACMS.API.REST.Collection.Paginated qualified as API.REST.Collection.Paginated
+import Collection
import Control.Monad.Catch (SomeException, try)
import Data.Aeson qualified as A
import Data.Aeson.KeyMap qualified as AM
import Effect (Eff)
import Miso
import Schema
-import Collection
data Model = Model
{ collection :: Collection,
input :: A.Object,
schema :: Schema,
- posts :: [A.Object]
+ posts :: Paginated A.Object
}
deriving (Show, Eq)
initialModel :: Collection -> JSM (Either SomeException Model)
initialModel collection = do
schema' <- try (API.REST.Collection.schema collection)
- posts' <- try (API.REST.Collection.list collection)
+ posts' <- try (API.REST.Collection.Paginated.list (API.REST.Collection.Paginated.Pagination 10 0) collection)
pure do
schema <- schema'
posts <- posts'
diff --git a/frontend/app/Schema.hs b/frontend/app/Schema.hs
index c10cffe..be04906 100644
--- a/frontend/app/Schema.hs
+++ b/frontend/app/Schema.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+
module Schema
( Schema,
viewSchema,
@@ -6,6 +8,7 @@ module Schema
)
where
+import ACMS.API.REST.Collection.Paginated (Paginated (..))
import Control.Applicative ((<|>))
import Data.Aeson qualified as A
import Data.Aeson.Key qualified as AK
@@ -20,6 +23,7 @@ import Miso
import Miso.String (MisoString, fromMisoString, intercalate, toMisoString)
import Route
import Safe
+import Text.Printf
data Schema = Schema
{ id :: MisoString,
@@ -76,9 +80,9 @@ viewSchema schema =
)
<$> (M.toList schema.properties)
-schemaTable :: MisoString -> Schema -> [A.Object] -> View action
-schemaTable collection schema values =
- table_ [] [thead, tbody]
+schemaTable :: MisoString -> Schema -> Paginated A.Object -> View action
+schemaTable collection schema paginated =
+ table_ [] [thead, tbody, tfoot]
where
thead =
thead_ [] $
@@ -108,8 +112,20 @@ schemaTable collection schema values =
]
| k <- M.keys schema.properties
]
- | value <- values
+ | value <- paginated.data_
]
+ tfoot =
+ let page, lastPage, perPage :: Int
+ page = 1
+ lastPage = ceiling (fromIntegral paginated.count / fromIntegral perPage)
+ perPage = 15
+ in tfoot_ [] $
+ [ tr_ [] $
+ [ td_ [colspan_ "999"] $
+ [ text (toMisoString (printf "Page %d of %d (%d total results)" page lastPage paginated.count :: String))
+ ]
+ ]
+ ]
schemaForm :: Schema -> F.Form A.Object A.Object
schemaForm schema =
generated by cgit v1.2.3 (git 2.25.1) at 2025-03-15 07:39:25 +0000