Fix pagination, add roundtrip / golden tests.

Author: fisx

libs/wire-api/src/Wire/API/Error/Brig.hs

@@ -115,6 +115,7 @@ data BrigError
   | RateLimitExceeded
   | MlsRemovalNotAllowed
   | UserGroupNotFound
+  | UserGroupInvalidQueryParams
   | UserGroupNotATeamAdmin
   | UserGroupMemberIsNotInTheSameTeam
 
@@ -346,6 +347,8 @@ type instance MapError 'MlsRemovalNotAllowed = 'StaticError 409 "mls-protocol-er
 
 type instance MapError 'UserGroupNotFound = 'StaticError 404 "user-group-not-found" "User group not found"
 
+type instance MapError 'UserGroupInvalidQueryParams = 'StaticError 400 "user-group-invalid-query" "Query parameters for listing user groups are invalid"
+
 type instance MapError 'UserGroupNotATeamAdmin = 'StaticError 403 "user-group-write-forbidden" "Only team admins can create, update, or delete user groups."
 
 type instance MapError 'UserGroupMemberIsNotInTheSameTeam = 'StaticError 400 "user-group-invalid" "Only team members of the same team can be added to a user group."

libs/wire-api/src/Wire/API/Pagination.hs

@@ -18,20 +18,26 @@
 module Wire.API.Pagination where
 
 import Data.Aeson qualified as A
+import Data.Bifunctor (first)
+import Data.ByteString.Lazy qualified as LB
 import Data.Default
-import Data.Json.Util
+import Data.Kind
 import Data.OpenApi qualified as S
 import Data.OpenApi.ParamSchema qualified as O
+import Data.Proxy
 import Data.Range
 import Data.Schema
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
 import GHC.Generics
 import GHC.TypeLits
 import Imports
 import Servant.API
-import Wire.Arbitrary
+import Test.QuickCheck.Gen as Arbitrary
+import Wire.Arbitrary as Arbitrary
 
 -- | (Is there an elegant way to enforce `allowedKeyFieldsInfo` before the handler kicks in?)
-type PaginationQuery (allowedKeyFieldsInfo :: Symbol) api =
+type PaginationQuery (allowedKeyFieldsInfo :: Symbol) (rowKeys :: Type) (row :: Type) =
   QueryParam'
     '[Optional, Strict, Description "Search string"]
     "q"
@@ -43,6 +49,7 @@ type PaginationQuery (allowedKeyFieldsInfo :: Symbol) api =
               ( "Sort key(s): comma-separated list of field names.  Must \
                 \match sort keys encoded in pagination state.  Allowed Fields: "
                   `AppendSymbol` allowedKeyFieldsInfo
+                  -- we need `allowedKeyFieldInfo` because `SortBy` contains that information only on the value level.
               )
           ]
          "sortBy"
@@ -58,25 +65,31 @@ type PaginationQuery (allowedKeyFieldsInfo :: Symbol) api =
     :> QueryParam'
          '[Optional, Strict, Description "Pagination state from last response (opaque to clients)"]
          "paginationState"
-         PaginationState
-    :> api
+         (PaginationState rowKeys)
+    :> Get '[JSON] (PaginationResult rowKeys row)
 
 data SortBy = SortBy {fromSortBy :: [Text]}
   deriving (Eq, Ord, Show, Generic)
   deriving (A.FromJSON, A.ToJSON, S.ToSchema) via Schema SortBy
 
+instance Arbitrary SortBy where
+  arbitrary = SortBy <$> arbitrary
+
 instance ToSchema SortBy where
-  schema = undefined
+  schema = object "SortBy" $ SortBy <$> (.fromSortBy) .= field "keys" (array schema)
 
 instance FromHttpApiData SortBy where
-  parseUrlPiece = undefined
+  parseUrlPiece = parseUrlPieceViaSchema
 
 instance O.ToParamSchema SortBy
 
 data SortOrder = Asc | Desc
-  deriving (Eq, Show, Ord, Enum, Generic)
+  deriving (Eq, Show, Ord, Enum, Bounded, Generic)
   deriving (A.FromJSON, A.ToJSON, S.ToSchema) via Schema SortOrder
 
+instance Arbitrary SortOrder where
+  arbitrary = Arbitrary.elements [minBound ..]
+
 instance Default SortOrder where
   def = Desc
 
@@ -89,7 +102,7 @@ instance ToSchema SortOrder where
         ]
 
 instance FromHttpApiData SortOrder where
-  parseUrlPiece = undefined
+  parseUrlPiece = parseUrlPieceViaSchema
 
 instance O.ToParamSchema SortOrder
 
@@ -102,7 +115,7 @@ pageSizeToInt = fromRange . fromPageSize
 
 -- | Doesn't crash on bad input, but shrinks it into the allowed range.
 pageSizeFromIntUnsafe :: Int -> PageSize
-pageSizeFromIntUnsafe = PageSize . (unsafeRange @Int @1 @500) . (`mod` 500) . (+ 1)
+pageSizeFromIntUnsafe = PageSize . (unsafeRange @Int @1 @500) . (+ 1) . (`mod` 500)
 
 instance Arbitrary PageSize where
   arbitrary = pageSizeFromIntUnsafe <$> arbitrary
@@ -111,49 +124,60 @@ instance ToSchema PageSize where
   schema = PageSize <$> fromPageSize .= schema
 
 instance FromHttpApiData PageSize where
-  parseUrlPiece = undefined
+  parseUrlPiece = parseUrlPieceViaSchema
 
 instance O.ToParamSchema PageSize
 
 instance Default PageSize where
   def = PageSize (unsafeRange 15)
 
-data PaginationState = PaginationState
-  { searchString :: Text,
+data PaginationState key = PaginationState
+  { searchString :: Text, -- TODO: this shouldn't be in the state, but maintained separately. or we need to make it more polymorhpic, maybe?
     sortByKeys :: SortBy,
     sortOrder :: SortOrder,
     pageSize :: PageSize,
-    lastRowSent :: (Text, UTCTimeMillis)
+    lastRowSent :: key
   }
   deriving (Eq, Show, Generic)
-  deriving (A.FromJSON, A.ToJSON, S.ToSchema) via Schema PaginationState
+  deriving (A.FromJSON, A.ToJSON, S.ToSchema) via Schema (PaginationState key)
 
-instance ToSchema PaginationState where
+instance (ToSchema key) => ToSchema (PaginationState key) where
   schema =
     object "PagintationState" $
       PaginationState
         <$> (.searchString) .= field "search_string" schema
-        <*> (.sortBy) .= field "sort_by" (array schema)
+        <*> (.sortByKeys) .= field "sort_by" schema
         <*> (.sortOrder) .= field "sort_order" schema
         <*> (.pageSize) .= field "page_size" schema
-        <*> (.lastRowSent) .= field "last_row_sent" (array schema)
+        <*> (.lastRowSent) .= field "last_row_sent" schema
+
+instance (Arbitrary key) => Arbitrary (PaginationState key) where
+  arbitrary = PaginationState <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
 
-instance FromHttpApiData PaginationState where
-  parseUrlPiece = undefined
+instance (ToSchema key) => FromHttpApiData (PaginationState key) where
+  parseUrlPiece = parseUrlPieceViaSchema
 
-instance O.ToParamSchema PaginationState where
-  toParamSchema = undefined
+instance O.ToParamSchema (PaginationState key) where
+  toParamSchema _ =
+    -- PaginationState is supposed to be opaque for clients, no need to swagger docs.
+    O.toParamSchema (Proxy @Text)
 
-data PaginationResult a = PaginationResult
-  { page :: [a],
-    state :: PaginationState
+data PaginationResult key row = PaginationResult
+  { page :: [row],
+    state :: PaginationState key
   }
   deriving (Eq, Show, Generic)
-  deriving (A.FromJSON, A.ToJSON, S.ToSchema) via Schema (PaginationResult a)
+  deriving (A.FromJSON, A.ToJSON, S.ToSchema) via Schema (PaginationResult key row)
 
-instance (ToSchema a) => ToSchema (PaginationResult a) where
+instance (ToSchema key, ToSchema row) => ToSchema (PaginationResult key row) where
   schema =
     object "PagintationResult" $
       PaginationResult
         <$> page .= field "page" (array schema)
         <*> state .= field "state" schema
+
+instance (Arbitrary key, Arbitrary row) => Arbitrary (PaginationResult key row) where
+  arbitrary = PaginationResult <$> arbitrary <*> arbitrary
+
+parseUrlPieceViaSchema :: (A.FromJSON a) => Text -> Either Text a
+parseUrlPieceViaSchema = first T.pack . A.eitherDecode . LB.fromStrict . T.encodeUtf8

libs/wire-api/src/Wire/API/Routes/Public/Brig.hs

@@ -27,6 +27,7 @@ import Data.CommaSeparatedList (CommaSeparatedList)
 import Data.Domain
 import Data.Handle
 import Data.Id as Id
+import Data.Json.Util (UTCTimeMillis)
 import Data.Misc
 import Data.Nonce (Nonce)
 import Data.OpenApi hiding (Contact, Header, Schema, ToSchema)
@@ -321,7 +322,7 @@ type UserGroupAPI =
            ( From 'V9
                :> ZLocalUser
                :> "user-groups"
-               :> PaginationQuery "created_at, name" (Get '[JSON] (PaginationResult UserGroup))
+               :> PaginationQuery "created_at, name" UserGroupKey UserGroup
            )
     :<|> Named
            "update-user-group"

libs/wire-api/src/Wire/API/UserGroup.hs

@@ -95,3 +95,18 @@ instance ToSchema UserGroup where
         <*> (.members) .= field "members" (vector schema)
         <*> (.managedBy) .= field "managedBy" schema
         <*> (.createdAt) .= field "createdAt" schema
+
+data UserGroupKey = UserGroupKey
+  { name :: UserGroupName,
+    createdAt :: UTCTimeMillis
+  }
+  deriving (Eq, Ord, Show, Generic)
+  deriving (Arbitrary) via GenericUniform UserGroupKey
+  deriving (A.ToJSON, A.FromJSON, OpenApi.ToSchema) via Schema UserGroupKey
+
+instance ToSchema UserGroupKey where
+  schema =
+    object "UserGroupKey" $
+      UserGroupKey
+        <$> (.name) .= field "name" schema
+        <*> (.createdAt) .= field "createdAt" schema

libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs

@@ -47,6 +47,7 @@ import Test.Wire.API.Golden.Manual.ListUsersById
 import Test.Wire.API.Golden.Manual.LoginId_user
 import Test.Wire.API.Golden.Manual.Login_user
 import Test.Wire.API.Golden.Manual.MLSKeys
+import Test.Wire.API.Golden.Manual.Pagination
 import Test.Wire.API.Golden.Manual.Presence
 import Test.Wire.API.Golden.Manual.Push
 import Test.Wire.API.Golden.Manual.PushRemove
@@ -68,7 +69,13 @@ tests :: TestTree
 tests =
   testGroup
     "Manual golden tests"
-    [ testGroup "NewUserGroup" $
+    [ testGroup "PaginationResult" $
+        testObjects
+          [ (testObject_PaginationResult_1, "testObject_PaginationResult_1.json"),
+            (testObject_PaginationResult_2, "testObject_PaginationResult_2.json"),
+            (testObject_PaginationResult_3, "testObject_PaginationResult_3.json")
+          ],
+      testGroup "NewUserGroup" $
         testObjects
           [ (testObject_NewUserGroup_1, "testObject_NewUserGroup_1.json"),
             (testObject_NewUserGroup_2, "testObject_NewUserGroup_2.json")

libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/Pagination.hs

@@ -0,0 +1,50 @@
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module Test.Wire.API.Golden.Manual.Pagination where
+
+import Data.Default
+import Data.Json.Util
+import Imports
+import Wire.API.Pagination
+
+someUTCTime :: UTCTimeMillis
+Just someUTCTime = readUTCTimeMillis "2025-04-16T16:22:21.703Z"
+
+someOtherUTCTime :: UTCTimeMillis
+Just someOtherUTCTime = readUTCTimeMillis "2021-12-12T00:00:00.000Z"
+
+testObject_PaginationResult_1 :: PaginationResult Int Int
+testObject_PaginationResult_1 =
+  PaginationResult
+    []
+    PaginationState
+      { searchString = "",
+        sortByKeys = SortBy [],
+        sortOrder = def,
+        pageSize = def,
+        lastRowSent = -1
+      }
+
+testObject_PaginationResult_2 :: PaginationResult Int Int
+testObject_PaginationResult_2 =
+  PaginationResult
+    [3, 5]
+    PaginationState
+      { searchString = "q",
+        sortByKeys = SortBy ["key1", "key2"],
+        sortOrder = Asc,
+        pageSize = pageSizeFromIntUnsafe 500,
+        lastRowSent = 3
+      }
+
+testObject_PaginationResult_3 :: PaginationResult Int Int
+testObject_PaginationResult_3 =
+  PaginationResult
+    [7 .. 12]
+    PaginationState
+      { searchString = "rst",
+        sortByKeys = SortBy ["key1", "", "key2"],
+        sortOrder = Asc,
+        pageSize = pageSizeFromIntUnsafe 1,
+        lastRowSent = 10
+      }

libs/wire-api/test/golden/testObject_PaginationResult_1.json

@@ -0,0 +1,12 @@
+{
+    "page": [],
+    "state": {
+        "last_row_sent": -1,
+        "page_size": 15,
+        "search_string": "",
+        "sort_by": {
+            "keys": []
+        },
+        "sort_order": "desc"
+    }
+}

libs/wire-api/test/golden/testObject_PaginationResult_2.json

@@ -0,0 +1,18 @@
+{
+    "page": [
+        3,
+        5
+    ],
+    "state": {
+        "last_row_sent": 3,
+        "page_size": 1,
+        "search_string": "q",
+        "sort_by": {
+            "keys": [
+                "key1",
+                "key2"
+            ]
+        },
+        "sort_order": "asc"
+    }
+}

libs/wire-api/test/golden/testObject_PaginationResult_3.json

@@ -0,0 +1,23 @@
+{
+    "page": [
+        7,
+        8,
+        9,
+        10,
+        11,
+        12
+    ],
+    "state": {
+        "last_row_sent": 10,
+        "page_size": 2,
+        "search_string": "rst",
+        "sort_by": {
+            "keys": [
+                "key1",
+                "",
+                "key2"
+            ]
+        },
+        "sort_order": "asc"
+    }
+}

libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs

@@ -44,6 +44,7 @@ import Wire.API.FederationStatus qualified as FederationStatus
 import Wire.API.Locale qualified as Locale
 import Wire.API.Message qualified as Message
 import Wire.API.OAuth qualified as OAuth
+import Wire.API.Pagination qualified as Pagination
 import Wire.API.Properties qualified as Properties
 import Wire.API.Provider qualified as Provider
 import Wire.API.Provider.Bot qualified as Provider.Bot
@@ -168,6 +169,7 @@ tests =
       testRoundTrip @OAuth.CreateOAuthAuthorizationCodeRequest,
       testRoundTrip @OAuth.OAuthAccessTokenRequest,
       testRoundTrip @OAuth.OAuthApplication,
+      testRoundTrip @(Pagination.PaginationResult Int Bool),
       testRoundTrip @Properties.PropertyKey,
       testRoundTrip @Provider.Provider,
       testRoundTrip @Provider.ProviderProfile,
@@ -345,6 +347,7 @@ tests =
       testRoundTrip @UserGroup.NewUserGroup,
       testRoundTrip @UserGroup.UserGroupUpdate,
       testRoundTrip @UserGroup.UserGroup,
+      testRoundTrip @UserGroup.UserGroupKey,
       testRoundTrip @EventWebSocketProtocol.MessageServerToClient,
       testRoundTrip @EventWebSocketProtocol.MessageClientToServer,
       testRoundTrip @(Wrapped.Wrapped "some_int" Int),