[WPB-23644] add app data to get /list-users

Makefile

@@ -347,9 +347,9 @@ postgres-schema-impl:
 
 .PHONY: cqlsh
 cqlsh:
-	$(eval CASSANDRA_CONTAINER := $(shell docker ps | grep '/cassandra:' | perl -ne '/^(\S+)\s/ && print $$1'))
+	$(eval CASSANDRA_CONTAINER := $(shell docker ps | grep 'cassandra' | perl -ne '/^(\S+)\s/ && print $$1'))
 	@echo "make sure you have ./deploy/dockerephemeral/run.sh running in another window!"
-	docker exec -it $(CASSANDRA_CONTAINER) /usr/bin/cqlsh
+	docker exec -it $(CASSANDRA_CONTAINER) cqlsh
 
 .PHONY: psql
 psql:

changelog.d/1-api-changes/WPB-23644-add-app-data-to-get-list-users

@@ -0,0 +1 @@
+Add `"app"` attribute to `GET /list-users`, `GET /users/:dom/:uid`; make `GET /teams/:tid/apps`, `GET /teams/:tid/apps/:uid` return same schema as `GET /list-users`.

integration/test/Test/Apps.hs

@@ -87,20 +87,21 @@ testCreateApp = do
   void $ getApp regularMember tid appId `bindResponse` \resp -> do
     resp.status `shouldMatchInt` 200
     (resp.json %. "name") `shouldMatch` "chappie"
-    (resp.json %. "description") `shouldMatch` "some description of this app"
-    (resp.json %. "category") `shouldMatch` "ai"
+    (resp.json %. "app.description") `shouldMatch` "some description of this app"
+    (resp.json %. "app.category") `shouldMatch` "ai"
 
   -- A teamless user can't get the app
   outsideUser <- randomUser domain def
   bindResponse (getApp outsideUser tid appId) $ \resp -> do
-    resp.status `shouldMatchInt` 403
-    resp.json %. "label" `shouldMatch` "app-no-permission"
+    -- this may change soon, see
+    -- https://wearezeta.atlassian.net/browse/WPB-23995,
+    -- https://wearezeta.atlassian.net/browse/WPB-23840
+    resp.status `shouldMatchInt` 200
 
-  -- Another team's owner nor member can't get the app
   (owner2, tid2, [regularMember2]) <- createTeam domain 2
-  bindResponse (getApp owner2 tid appId) $ \resp -> resp.status `shouldMatchInt` 403
-  bindResponse (getApp owner2 tid2 appId) $ \resp -> resp.status `shouldMatchInt` 404
-  bindResponse (getApp regularMember2 tid appId) $ \resp -> resp.status `shouldMatchInt` 403
+  bindResponse (getApp owner2 tid appId) $ \resp -> resp.status `shouldMatchInt` 200
+  bindResponse (getApp owner2 tid2 appId) $ \resp -> resp.status `shouldMatchInt` 200
+  bindResponse (getApp regularMember2 tid appId) $ \resp -> resp.status `shouldMatchInt` 200
 
   -- Category must be any of the values for the Category enum
   void $ bindResponse (createApp owner tid new {category = "notinenum"}) $ \resp -> do
@@ -228,14 +229,11 @@ testPutApp = do
   bindResponse (getApp owner tid appId) $ \resp -> do
     resp.status `shouldMatchInt` 200
     resp.json
-      `shouldMatchShape` SObject
+      `shouldMatchShapeLenient` SObject
         [ ("accent_id", SNumber),
           ("assets", SArray (SObject [("key", SString), ("size", SString), ("type", SString)])),
           ("name", SString),
-          ("category", SString),
-          ("description", SString),
-          ("metadata", SObject []),
-          ("picture", SArray SAny)
+          ("app", SObject [("category", SString), ("description", SString)])
         ]
 
   let badAppId = "5e002eca-114f-11f1-b5a3-7306b8837f91"
@@ -252,7 +250,6 @@ testRetrieveUsersIncludingApps = do
             ("locale", SString),
             ("managed_by", SString),
             ("name", SString),
-            ("picture", SArray SAny),
             ("qualified_id", SObject [("domain", SString), ("id", SString)]),
             ("searchable", SBool),
             ("status", SString),
@@ -272,9 +269,7 @@ testRetrieveUsersIncludingApps = do
         SObject
           [ ("accent_id", SNumber),
             ("assets", SArray SAny),
-            ("category", SString),
-            ("description", SString),
-            ("metadata", SObject []),
+            ("app", SObject [("category", SString), ("description", SString)]),
             ("name", SString),
             ("picture", SArray SAny)
           ]
@@ -301,7 +296,7 @@ testRetrieveUsersIncludingApps = do
     resp.status `shouldMatchInt` 200
     pure resp.json
   appCreated
-    `shouldMatchShape` SObject
+    `shouldMatchShapeLenient` SObject
       [ ("cookie", SString),
         ("user", userShape)
       ]
@@ -324,25 +319,25 @@ testRetrieveUsersIncludingApps = do
   getTeamMember owner tid appId `bindResponse` \resp -> do
     resp.status `shouldMatchInt` 200
     resp.json %. "user" `shouldMatch` appId
-    resp.json `shouldMatchShape` memberShape
+    resp.json `shouldMatchShapeLenient` memberShape
 
   -- [`GET /teams/:tid/apps`](https://staging-nginz-https.zinfra.io/v15/api/swagger-ui/#/default/get-apps) (route id: "get-apps")
   getApps owner tid `bindResponse` \resp -> do
     resp.status `shouldMatchInt` 200
     apps <- resp.json & maybe (error "this shouldn't happen") pure
-    apps `shouldMatchShape` SArray appWithIdShape
+    apps `shouldMatchShapeLenient` SArray appWithIdShape
 
   -- [`GET /teams/:tid/apps/:uid`](https://staging-nginz-https.zinfra.io/v15/api/swagger-ui/#/default/get-app) (route id: "get-app")
   getApp owner tid appId `bindResponse` \resp -> do
     resp.status `shouldMatchInt` 200
-    resp.json `shouldMatchShape` appShape
+    resp.json `shouldMatchShapeLenient` appShape
 
   -- [`POST /list-users`](https://staging-nginz-https.zinfra.io/v15/api/swagger-ui/#/default/list-users-by-ids-or-handles) (route id: "list-users-by-ids-or-handles")
   listUsers owner [appCreated %. "user"] `bindResponse` \resp -> do
     resp.status `shouldMatchInt` 200
     resp.json
       %. "found.0"
-      `shouldMatchShape` SObject
+      `shouldMatchShapeLenient` SObject
         [ ("accent_id", SNumber),
           ("assets", SArray SAny),
           ("id", SString),
@@ -367,4 +362,4 @@ testRetrieveUsersIncludingApps = do
       resp.status `shouldMatchInt` 200
       hits :: [Value] <- resp.json %. "documents" & asList
       length hits `shouldMatchInt` 2 -- owner doesn't find itself
-      (`shouldMatchShape` searchResultShape) `mapM_` hits
+      (`shouldMatchShapeLenient` searchResultShape) `mapM_` hits

integration/test/Test/Shape.hs

@@ -17,7 +17,7 @@
 -- You should have received a copy of the GNU Affero General Public License along
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
 
--- | Self-tests for the 'Shape' DSL and 'shouldMatchShape' assertion.
+-- | Self-tests for the 'Shape' DSL and 'shouldMatchShape*' assertions.
 module Test.Shape where
 
 import Testlib.Prelude
@@ -26,35 +26,41 @@ import Testlib.Prelude
 testShapeObjectMatch :: (HasCallStack) => App ()
 testShapeObjectMatch = do
   let v = object ["foo" .= (42 :: Int), "bar" .= ("hello" :: String)]
-  v `shouldMatchShape` SObject [("foo", SNumber), ("bar", SString)]
+  v `shouldMatchShapeExact` SObject [("foo", SNumber), ("bar", SString)]
+
+-- | A matching object shape succeeds.
+testShapeObjectMatchLenient :: (HasCallStack) => App ()
+testShapeObjectMatchLenient = do
+  let v = object ["foo" .= (42 :: Int), "bar" .= ("hello" :: String)]
+  v `shouldMatchShapeLenient` SObject [("foo", SNumber)]
 
 -- | An unexpected key in the actual object causes a failure.
 testShapeUnexpectedKey :: (HasCallStack) => App ()
 testShapeUnexpectedKey = do
   let v = object ["foo" .= (1 :: Int), "extra" .= (2 :: Int)]
   expectFailure (\_ -> pure ()) do
-    v `shouldMatchShape` SObject [("foo", SNumber)]
+    v `shouldMatchShapeExact` SObject [("foo", SNumber)]
 
 -- | A missing key in the actual object causes a failure.
 testShapeMissingKey :: (HasCallStack) => App ()
 testShapeMissingKey = do
   let v = object ["foo" .= (1 :: Int)]
   expectFailure (\_ -> pure ()) do
-    v `shouldMatchShape` SObject [("foo", SNumber), ("bar", SString)]
+    v `shouldMatchShapeExact` SObject [("foo", SNumber), ("bar", SString)]
 
 -- | Providing a non-object value when 'SObject' is expected causes a failure.
 testShapeWrongTypeObject :: (HasCallStack) => App ()
 testShapeWrongTypeObject = do
   let v = toJSON ("hello" :: String)
   expectFailure (\_ -> pure ()) do
-    v `shouldMatchShape` SObject [("foo", SNumber)]
+    v `shouldMatchShapeExact` SObject [("foo", SNumber)]
 
 -- | Providing a non-string when 'SString' is expected causes a failure.
 testShapeWrongTypeString :: (HasCallStack) => App ()
 testShapeWrongTypeString = do
   let v = Number 42
   expectFailure (\_ -> pure ()) do
-    v `shouldMatchShape` SString
+    v `shouldMatchShapeExact` SString
 
 -- | An array element with the wrong type causes a failure, and the error
 -- message includes the element index.
@@ -63,7 +69,7 @@ testShapeArrayElementMismatch = do
   -- First two elements are strings (match), third is a number (mismatch at [2])
   let v = toJSON [toJSON ("a" :: String), toJSON ("b" :: String), toJSON (3 :: Int)]
   expectFailure (\e -> e.msg `shouldContainString` "[2]") do
-    v `shouldMatchShape` SArray SString
+    v `shouldMatchShapeExact` SArray SString
 
 -- | A nested mismatch deep in an object/array reports the full JSON path.
 testShapeNestedPathReported :: (HasCallStack) => App ()
@@ -80,7 +86,7 @@ testShapeNestedPathReported = do
           ]
   expectFailure (\e -> e.msg `shouldContainString` ".assets[0].key") do
     v
-      `shouldMatchShape` SObject
+      `shouldMatchShapeExact` SObject
         [ ( "assets",
             SArray
               ( SObject
@@ -97,15 +103,15 @@ testShapeSAny :: (HasCallStack) => App ()
 testShapeSAny = do
   let vals :: [Value]
       vals = [Null, Bool True, toJSON ("x" :: String), Number 1, toJSON ([] :: [Int]), object []]
-  mapM_ (`shouldMatchShape` SAny) vals
+  mapM_ (`shouldMatchShapeExact` SAny) vals
 
 -- | An empty array matches 'SArray' with any element shape.
 testShapeEmptyArray :: (HasCallStack) => App ()
 testShapeEmptyArray = do
   let v = toJSON ([] :: [Int])
-  v `shouldMatchShape` SArray SString
-  v `shouldMatchShape` SArray SNumber
-  v `shouldMatchShape` SArray (SObject [])
+  v `shouldMatchShapeExact` SArray SString
+  v `shouldMatchShapeExact` SArray SNumber
+  v `shouldMatchShapeExact` SArray (SObject [])
 
 -- | 'valueShape' computes the correct shape of a JSON value.
 testValueShape :: (HasCallStack) => App ()
@@ -120,4 +126,4 @@ testValueShape = do
           ]
   shape <- valueShape v
   -- The computed shape should itself pass the shape-match on v
-  v `shouldMatchShape` shape
+  v `shouldMatchShapeExact` shape

integration/test/Testlib/Assertions.hs

@@ -308,54 +308,80 @@ data Shape
 
 -- | Assert that @actual@ conforms to @shape@.  Provides a JSON-path-like
 -- location in the failure message (e.g. @.assets[0].key@).
-shouldMatchShape ::
+shouldMatchShapeExact ::
   (MakesValue a, HasCallStack) =>
   -- | The actual value
   a ->
   -- | The expected shape
   Shape ->
   App ()
-shouldMatchShape a shape = do
+shouldMatchShapeExact = shouldMatchShapeImpl Reject
+
+-- | Assert that @actual@ conforms to @shape@.  Provides a JSON-path-like
+-- location in the failure message (e.g. @.assets[0].key@).
+shouldMatchShapeLenient ::
+  (MakesValue a, HasCallStack) =>
+  -- | The actual value
+  a ->
+  -- | The expected shape
+  Shape ->
+  App ()
+shouldMatchShapeLenient = shouldMatchShapeImpl Allow
+
+-- | Assert that @actual@ conforms to @shape@.  Provides a JSON-path-like
+-- location in the failure message (e.g. @.assets[0].key@).
+shouldMatchShapeImpl ::
+  (MakesValue a, HasCallStack) =>
+  UnknownAttributes ->
+  -- | The actual value
+  a ->
+  -- | The expected shape
+  Shape ->
+  App ()
+shouldMatchShapeImpl unknownAttributes a shape = do
   val <- make a
-  case matchShape "" val shape of
+  case matchShape unknownAttributes "" val shape of
     Nothing -> pure ()
     Just err -> assertFailure $ "Shape mismatch" <> err
 
+data UnknownAttributes = Allow | Reject
+  deriving (Eq, Show)
+
 -- | Internal recursive shape-matcher.  Returns 'Nothing' on success and
 -- @'Just' errorMessage@ on failure.  The @path@ argument accumulates the
 -- JSON-path-like location prefix.
-matchShape :: String -> Value -> Shape -> Maybe String
-matchShape _ _ SAny = Nothing
-matchShape _ Aeson.Null SNull = Nothing
-matchShape path _ SNull = Just $ " at " <> matchShapeLoc path <> ": expected null"
-matchShape _ (Aeson.Bool _) SBool = Nothing
-matchShape path _ SBool = Just $ " at " <> matchShapeLoc path <> ": expected bool"
-matchShape _ (Aeson.String _) SString = Nothing
-matchShape path _ SString = Just $ " at " <> matchShapeLoc path <> ": expected string"
-matchShape _ (Aeson.Number _) SNumber = Nothing
-matchShape path _ SNumber = Just $ " at " <> matchShapeLoc path <> ": expected number"
-matchShape path (Aeson.Array arr) (SArray elemShape) =
+matchShape :: UnknownAttributes -> String -> Value -> Shape -> Maybe String
+matchShape _ _ _ SAny = Nothing
+matchShape _ _ Aeson.Null SNull = Nothing
+matchShape _ path _ SNull = Just $ " at " <> matchShapeLoc path <> ": expected null"
+matchShape _ _ (Aeson.Bool _) SBool = Nothing
+matchShape _ path _ SBool = Just $ " at " <> matchShapeLoc path <> ": expected bool"
+matchShape _ _ (Aeson.String _) SString = Nothing
+matchShape _ path _ SString = Just $ " at " <> matchShapeLoc path <> ": expected string"
+matchShape _ _ (Aeson.Number _) SNumber = Nothing
+matchShape _ path _ SNumber = Just $ " at " <> matchShapeLoc path <> ": expected number"
+matchShape unknownAttributes path (Aeson.Array arr) (SArray elemShape) =
   listToMaybe
-    . mapMaybe (\(i, v) -> matchShape (path <> "[" <> show (i :: Int) <> "]") v elemShape)
+    . mapMaybe (\(i, v) -> matchShape unknownAttributes (path <> "[" <> show (i :: Int) <> "]") v elemShape)
     $ zip [0 ..] (toList arr)
-matchShape path _ (SArray _) = Just $ " at " <> matchShapeLoc path <> ": expected array"
-matchShape path (Aeson.Object obj) (SObject fields) =
+matchShape _ path _ (SArray _) = Just $ " at " <> matchShapeLoc path <> ": expected array"
+matchShape unknownAttributes path (Aeson.Object obj) (SObject fields) =
   let objPairs = [(Key.toString k, v) | (k, v) <- Aeson.toList obj]
       actualKeys = map fst objPairs
       expectedKeys = map fst fields
       unexpectedKeys = actualKeys \\ expectedKeys
       missingKeys = expectedKeys \\ actualKeys
       go (k, s) = case lookup k objPairs of
         Nothing -> Nothing -- already checked above
-        Just v -> matchShape (path <> "." <> k) v s
-   in case (unexpectedKeys, missingKeys) of
-        (k : _, _) ->
-          Just $ " at " <> matchShapeLoc path <> ": unexpected key \"" <> k <> "\""
-        (_, k : _) ->
-          Just $ " at " <> matchShapeLoc path <> ": missing key \"" <> k <> "\""
+        Just v -> matchShape unknownAttributes (path <> "." <> k) v s
+   in case (unknownAttributes, unexpectedKeys, missingKeys) of
+        (Reject, ks@(_ : _), _) ->
+          Just $ " at " <> matchShapeLoc path <> ": unexpected keys \"" <> show ks <> "\""
+        (_, _, ks@(_ : _)) ->
+          Just $ " at " <> matchShapeLoc path <> ": missing keys \"" <> show ks <> "\""
         _ ->
           listToMaybe . mapMaybe go $ fields
-matchShape path _ (SObject _) = Just $ " at " <> matchShapeLoc path <> ": expected object"
+matchShape _ path _ (SObject _) = Just $ " at " <> matchShapeLoc path <> ": expected object"
 
 -- | Format a path for use in error messages, using the document root (@$@)
 -- when the path is empty.