Make ejpd data model exhaustive

changelog.d/5-internal/wpb-6329_ejpd_stuff

@@ -0,0 +1,6 @@
+Add assets to output of ejpd-info end-point in stern; also:
+
+- [brig] now talks to carghold for profile picture extraction;
+- [integration] migrate ejpd tests;
+- [integration] enhanced `shouldMatch` shows a diff on failure now;
+- [integration] added `shouldMatchLeniently` for rule-based canonicalization of arguments

integration/default.nix

@@ -4,6 +4,7 @@
 # dependencies are added or removed.
 { mkDerivation
 , aeson
+, aeson-diff
 , aeson-pretty
 , array
 , async
@@ -72,6 +73,7 @@
 , warp-tls
 , websockets
 , wire-message-proto-lens
+, wreq
 , xml
 , yaml
 }:
@@ -91,6 +93,7 @@ mkDerivation {
   ];
   libraryHaskellDepends = [
     aeson
+    aeson-diff
     aeson-pretty
     array
     async
@@ -155,6 +158,7 @@ mkDerivation {
     warp-tls
     websockets
     wire-message-proto-lens
+    wreq
     xml
     yaml
   ];

integration/integration.cabal

@@ -118,6 +118,7 @@ library
     Test.Connection
     Test.Conversation
     Test.Demo
+    Test.EJPD
     Test.Errors
     Test.ExternalPartner
     Test.FeatureFlags
@@ -166,6 +167,7 @@ library
 
   build-depends:
     , aeson
+    , aeson-diff
     , aeson-pretty
     , array
     , async
@@ -230,5 +232,6 @@ library
     , warp-tls
     , websockets
     , wire-message-proto-lens
+    , wreq
     , xml
     , yaml

integration/test/API/BrigInternal.hs

@@ -243,3 +243,13 @@ getClientsFull user users = do
   val <- make users
   baseRequest user Brig Unversioned do joinHttpPath ["i", "clients", "full"]
     >>= submit "POST" . addJSONObject ["users" .= val]
+
+-- | https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/brig/#/brig/post_i_ejpd_request
+getEJPDInfo :: (HasCallStack, MakesValue dom) => dom -> [String] -> String -> App Response
+getEJPDInfo dom handles mode = do
+  req <- rawBaseRequest dom Brig Unversioned "/i/ejpd-request"
+  let query = case mode of
+        "" -> []
+        "include_contacts" -> [("include_contacts", "true")]
+        bad -> error $ show bad
+  submit "POST" $ req & addJSONObject ["ejpd_request" .= handles] & addQueryParams query

integration/test/API/Cargohold.hs

@@ -37,7 +37,10 @@ uploadAssetV3 user isPublic retention mimeType bdy = do
     multipartMixedMime = "multipart/mixed; boundary=" <> multipartBoundary
 
 uploadAsset :: (HasCallStack, MakesValue user) => user -> App Response
-uploadAsset user = do
+uploadAsset = flip uploadFreshAsset "Hello World!"
+
+uploadFreshAsset :: (HasCallStack, MakesValue user) => user -> String -> App Response
+uploadFreshAsset user payload = do
   uid <- user & objId
   req <- baseRequest user Cargohold Versioned "/assets"
   bdy <- txtAsset
@@ -51,7 +54,7 @@ uploadAsset user = do
       buildUploadAssetRequestBody
         True
         (Nothing :: Maybe String)
-        (LBSC.pack "Hello World!")
+        (LBSC.pack payload)
         textPlainMime
 
     textPlainMime :: MIME.MIMEType
@@ -104,13 +107,25 @@ instance MakesValue loc => IsAssetLocation loc where
 noRedirect :: Request -> Request
 noRedirect r = r {redirectCount = 0}
 
-downloadAsset' :: (HasCallStack, MakesValue user, IsAssetLocation loc, IsAssetToken tok) => user -> loc -> tok -> App Response
+downloadAsset' ::
+  (HasCallStack, MakesValue user, IsAssetLocation loc, IsAssetToken tok) =>
+  user ->
+  loc ->
+  tok ->
+  App Response
 downloadAsset' user loc tok = do
   locPath <- locationPathFragment loc
   req <- baseRequest user Cargohold Unversioned $ locPath
   submit "GET" $ req & tokenParam tok & noRedirect
 
-downloadAsset :: (HasCallStack, MakesValue user, MakesValue key, MakesValue assetDomain) => user -> assetDomain -> key -> String -> (HTTP.Request -> HTTP.Request) -> App Response
+downloadAsset ::
+  (HasCallStack, MakesValue user, MakesValue key, MakesValue assetDomain) =>
+  user ->
+  assetDomain ->
+  key ->
+  String ->
+  (HTTP.Request -> HTTP.Request) ->
+  App Response
 downloadAsset user assetDomain key zHostHeader trans = do
   domain <- objDomain assetDomain
   key' <- asString key

integration/test/API/Common.hs

@@ -14,8 +14,10 @@ teamRole "admin" = 5951
 teamRole "owner" = 8191
 teamRole bad = error $ "unknown team role: " <> bad
 
+-- | please don't use special shell characters like '!' here.  it makes writing shell lines
+-- that use test data a lot less straight-forward.
 defPassword :: String
-defPassword = "hunter2!"
+defPassword = "hunter2."
 
 randomEmail :: App String
 randomEmail = do

integration/test/SetupHelpers.hs

@@ -5,6 +5,7 @@ module SetupHelpers where
 
 import API.Brig
 import API.BrigInternal
+import API.Cargohold
 import API.Common
 import API.Galley
 import API.GalleyInternal (legalholdWhitelistTeam)
@@ -14,8 +15,10 @@ import Data.Aeson hiding ((.=))
 import qualified Data.Aeson.Types as Aeson
 import qualified Data.ByteString.Base64.URL as B64Url
 import Data.ByteString.Char8 (unpack)
+import qualified Data.CaseInsensitive as CI
 import Data.Default
 import Data.Function
+import Data.String.Conversions (cs)
 import Data.UUID.V1 (nextUUID)
 import Data.UUID.V4 (nextRandom)
 import GHC.Stack
@@ -90,7 +93,7 @@ connectTwoUsers alice bob = do
   bindResponse (postConnection alice bob) (\resp -> resp.status `shouldMatchInt` 201)
   bindResponse (putConnection bob alice "accepted") (\resp -> resp.status `shouldMatchInt` 200)
 
-connectUsers :: HasCallStack => [Value] -> App ()
+connectUsers :: (HasCallStack, MakesValue usr) => [usr] -> App ()
 connectUsers users = traverse_ (uncurry connectTwoUsers) $ do
   t <- tails users
   (a, others) <- maybeToList (uncons t)
@@ -326,3 +329,45 @@ randomScimUser = do
         "userName" .= handle,
         "displayName" .= handle
       ]
+
+-- | This adds one random asset to the `assets` field in the user record and returns an asset
+-- key.  The asset carries a fresh UUIDv4 in text form (even though it is typed 'preview` and
+-- `image').
+uploadProfilePicture :: (HasCallStack, MakesValue usr) => usr -> App (String, String, String)
+uploadProfilePicture usr = do
+  payload <- ("asset_contents=" <>) <$> randomId
+  asset <- bindResponse (uploadFreshAsset usr payload) (getJSON 201)
+  dom <- asset %. "domain" & asString
+  key <- asset %. "key" & asString
+  Success (oldAssets :: [Value]) <- bindResponse (getSelf usr) $ \resp -> do
+    resp.status `shouldMatchInt` 200
+    resp.json %. "assets" <&> fromJSON
+  bindResponse
+    (putSelf usr def {assets = Just (object ["key" .= key, "size" .= "preview", "type" .= "image"] : oldAssets)})
+    assertSuccess
+  pure (dom, key, payload)
+
+-- | Take a calling user (any user will do) and an asset domain and key, and return a
+-- (temporarily valid) s3 url plus asset payload (if created with `uploadProfilePicture`,
+-- that's a UUIDv4).
+downloadProfilePicture :: (HasCallStack, MakesValue caller) => caller -> String -> String -> App (String, String)
+downloadProfilePicture caller assetDomain assetKey = do
+  locurl <- bindResponse (downloadAsset caller caller assetKey assetDomain noRedirect) $ \resp -> do
+    resp.status `shouldMatchInt` 302
+    maybe
+      (error "no location header in 302 response!?")
+      (pure . cs)
+      (lookup (CI.mk (cs "Location")) resp.headers)
+
+  payload <- bindResponse (downloadAsset caller caller assetKey assetDomain id) $ \resp -> do
+    resp.status `shouldMatchInt` 200
+    pure $ cs resp.body
+
+  pure (locurl, payload)
+
+-- | Call 'uploadProfilePicture' and 'downloadPicture', returning the return value of the
+-- latter.
+uploadDownloadProfilePicture :: (HasCallStack, MakesValue usr) => usr -> App (String, String)
+uploadDownloadProfilePicture usr = do
+  (dom, key, _payload) <- uploadProfilePicture usr
+  downloadProfilePicture usr dom key

integration/test/Test/AssetDownload.hs

@@ -2,8 +2,6 @@ module Test.AssetDownload where
 
 import API.Cargohold
 import GHC.Stack
-import Network.HTTP.Client (Request (redirectCount))
-import qualified Network.HTTP.Client as HTTP
 import SetupHelpers
 import Testlib.Prelude
 
@@ -28,42 +26,39 @@ testDownloadAssetMultiIngressS3DownloadUrl = do
   -- multi-ingress disabled
   key <- doUploadAsset user
 
-  bindResponse (downloadAsset user user key "nginz-https.example.com" noRedirects) $ \resp -> do
+  bindResponse (downloadAsset user user key "nginz-https.example.com" noRedirect) $ \resp -> do
     resp.status `shouldMatchInt` 302
 
-  bindResponse (downloadAsset user user key "red.example.com" noRedirects) $ \resp -> do
+  bindResponse (downloadAsset user user key "red.example.com" noRedirect) $ \resp -> do
     resp.status `shouldMatchInt` 302
 
-  bindResponse (downloadAsset user user key "green.example.com" noRedirects) $ \resp -> do
+  bindResponse (downloadAsset user user key "green.example.com" noRedirect) $ \resp -> do
     resp.status `shouldMatchInt` 302
 
-  bindResponse (downloadAsset user user key "unknown.example.com" noRedirects) $ \resp -> do
+  bindResponse (downloadAsset user user key "unknown.example.com" noRedirect) $ \resp -> do
     resp.status `shouldMatchInt` 302
 
   -- multi-ingress enabled
   withModifiedBackend modifyConfig $ \domain -> do
     user' <- randomUser domain def
     key' <- doUploadAsset user'
 
-    bindResponse (downloadAsset user' user' key' "nginz-https.example.com" noRedirects) $ \resp -> do
+    bindResponse (downloadAsset user' user' key' "nginz-https.example.com" noRedirect) $ \resp -> do
       resp.status `shouldMatchInt` 404
       resp.json %. "label" `shouldMatch` "not-found"
 
-    bindResponse (downloadAsset user' user' key' "red.example.com" noRedirects) $ \resp -> do
+    bindResponse (downloadAsset user' user' key' "red.example.com" noRedirect) $ \resp -> do
       resp.status `shouldMatchInt` 302
       locationHeaderHost resp `shouldMatch` "s3-download.red.example.com"
 
-    bindResponse (downloadAsset user' user' key' "green.example.com" noRedirects) $ \resp -> do
+    bindResponse (downloadAsset user' user' key' "green.example.com" noRedirect) $ \resp -> do
       resp.status `shouldMatchInt` 302
       locationHeaderHost resp `shouldMatch` "s3-download.green.example.com"
 
-    bindResponse (downloadAsset user' user' key' "unknown.example.com" noRedirects) $ \resp -> do
+    bindResponse (downloadAsset user' user' key' "unknown.example.com" noRedirect) $ \resp -> do
       resp.status `shouldMatchInt` 404
       resp.json %. "label" `shouldMatch` "not-found"
   where
-    noRedirects :: HTTP.Request -> HTTP.Request
-    noRedirects req = (req {redirectCount = 0})
-
     modifyConfig :: ServiceOverrides
     modifyConfig =
       def