diff options
-rw-r--r-- | backend/app/Main.hs | 32 | ||||
-rw-r--r-- | backend/backend.cabal | 2 | ||||
-rw-r--r-- | backend/lib/ACMS/API/REST/Collection/Paginated.hs | 32 | ||||
-rw-r--r-- | frontend/app/Page/ListCollection.hs | 8 | ||||
-rw-r--r-- | frontend/app/Schema.hs | 24 |
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 = |