[WPB-22549] Add curl to integration test failure reports.

cassandra-schema.cql

@@ -1639,6 +1639,7 @@ CREATE TABLE galley_test.conversation (
     epoch bigint,
     group_conv_type int,
     group_id blob,
+    history_depth bigint,
     message_timer bigint,
     name text,
     parent_conv uuid,

changelog.d/5-internal/WPB-22549-add-curl-to-integration-test-failure-reports

@@ -0,0 +1 @@
+Add curl to integration test failure reports.

integration/test/Testlib/Assertions.hs

@@ -40,6 +40,7 @@ import qualified Data.ByteString.Lazy as BS
 import Data.Char
 import Data.Foldable
 import Data.Hex
+import Data.IORef
 import Data.List
 import qualified Data.Map as Map
 import Data.Maybe
@@ -50,6 +51,7 @@ import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Encoding as TL
 import GHC.Stack as Stack
 import qualified Network.HTTP.Client as HTTP
+import System.Environment
 import System.FilePath
 import Testlib.JSON
 import Testlib.Printing
@@ -400,24 +402,37 @@ super `shouldNotContain` sub = do
   when (sub `isInfixOf` super) $ do
     assertFailure $ "String or List:\n" <> show super <> "\nDoes contain:\n" <> show sub
 
-printFailureDetails :: AssertionFailure -> IO String
-printFailureDetails (AssertionFailure stack mbResponse ctx msg) = do
+printFailureDetails :: Env -> AssertionFailure -> IO String
+printFailureDetails env (AssertionFailure stack mbResponse ctx msg) = do
   s <- prettierCallStack stack
+  ct <- renderCurlTrace env.curlTrace
   pure . unlines $
     colored yellow "assertion failure:"
       : colored red msg
       : "\n" <> s
       : toList (fmap prettyResponse mbResponse)
         <> toList (fmap prettyContext ctx)
+        <> ct
 
-printAppFailureDetails :: AppFailure -> IO String
-printAppFailureDetails (AppFailure msg stack) = do
+printAppFailureDetails :: Env -> AppFailure -> IO String
+printAppFailureDetails env (AppFailure msg stack) = do
   s <- prettierCallStack stack
+  ct <- renderCurlTrace env.curlTrace
   pure . unlines $
     colored yellow "app failure:"
       : colored red msg
       : "\n"
       : [s]
+        <> ct
+
+renderCurlTrace :: IORef [String] -> IO [String]
+renderCurlTrace trace = do
+  isTestVerbose >>= \case
+    True -> ("HTTP trace in curl pseudo-syntax:" :) <$> readIORef trace
+    False -> pure ["Set WIRE_INTEGRATION_TEST_VERBOSITY=1 if you want to see complete trace of the HTTP traffic in curl pseudo-syntax."]
+
+isTestVerbose :: (MonadIO m) => m Bool
+isTestVerbose = liftIO $ (Just "1" ==) <$> lookupEnv "WIRE_INTEGRATION_TEST_VERBOSITY"
 
 prettyContext :: String -> String
 prettyContext ctx = do
@@ -426,12 +441,14 @@ prettyContext ctx = do
       colored blue ctx
     ]
 
-printExceptionDetails :: SomeException -> IO String
-printExceptionDetails e = do
+printExceptionDetails :: Env -> SomeException -> IO String
+printExceptionDetails env e = do
+  ct <- renderCurlTrace env.curlTrace
   pure . unlines $
     [ colored yellow "exception:",
       colored red (displayException e)
     ]
+      <> ct
 
 prettierCallStack :: CallStack -> IO String
 prettierCallStack cstack = do

integration/test/Testlib/Env.hs

@@ -169,6 +169,7 @@ mkEnv currentTestName ge = do
   liftIO $ do
     pks <- newIORef (zip [1 ..] somePrekeys)
     lpks <- newIORef someLastPrekeys
+    curlTrace <- newIORef []
     pure
       Env
         { serviceMap = gServiceMap ge,
@@ -201,7 +202,8 @@ mkEnv currentTestName ge = do
           dnsMockServerConfig = ge.gDNSMockServerConfig,
           cellsEventQueue = ge.gCellsEventQueue,
           cellsEventWatchersLock = ge.gCellsEventWatchersLock,
-          cellsEventWatchers = ge.gCellsEventWatchers
+          cellsEventWatchers = ge.gCellsEventWatchers,
+          curlTrace
         }
 
 allCiphersuites :: [Ciphersuite]

integration/test/Testlib/HTTP.hs

@@ -18,6 +18,7 @@
 module Testlib.HTTP where
 
 import qualified Control.Exception as E
+import Control.Monad.Extra (whenM)
 import Control.Monad.Reader
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
@@ -27,6 +28,7 @@ import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy as L
 import qualified Data.CaseInsensitive as CI
 import Data.Function
+import Data.IORef
 import Data.List
 import Data.List.Split (splitOn)
 import qualified Data.Map as Map
@@ -231,19 +233,17 @@ zHost = addHeader "Z-Host"
 
 submit :: String -> HTTP.Request -> App Response
 submit method req0 = do
-  let req = req0 {HTTP.method = T.encodeUtf8 (T.pack method)}
-  -- uncomment this for more debugging noise:
-  -- liftIO $ putStrLn $ requestToCurl req
+  let request = req0 {HTTP.method = T.encodeUtf8 (T.pack method)}
   manager <- asks (.manager)
-  res <- liftIO $ HTTP.httpLbs req manager
-  pure $
-    Response
-      { json = Aeson.decode (HTTP.responseBody res),
-        body = L.toStrict (HTTP.responseBody res),
-        status = HTTP.statusCode (HTTP.responseStatus res),
-        headers = HTTP.responseHeaders res,
-        request = req
-      }
+  response <- liftIO $ HTTP.httpLbs request manager
+  let json = Aeson.decode (HTTP.responseBody response)
+      body = L.toStrict (HTTP.responseBody response)
+      status = HTTP.statusCode (HTTP.responseStatus response)
+      headers = HTTP.responseHeaders response
+  whenM isTestVerbose do
+    curl <- asks (.curlTrace)
+    liftIO $ modifyIORef' curl (<> [requestToCurl request, "# ==> " <> show (status, body, headers), ""])
+  pure Response {..}
 
 locationHeaderHost :: Response -> String
 locationHeaderHost resp =

integration/test/Testlib/Run.hs

@@ -68,11 +68,11 @@ runTest testName ge action = lowerCodensity $ do
                       -- This ensures things like UserInterrupt are properly handled.
                       E.throw e,
                     E.Handler -- AssertionFailure
-                      (fmap Left . printFailureDetails),
+                      (fmap Left . printFailureDetails env),
                     E.Handler -- AppFailure
-                      (fmap Left . printAppFailureDetails),
+                      (fmap Left . printAppFailureDetails env),
                     E.Handler
-                      (fmap Left . printExceptionDetails)
+                      (fmap Left . printExceptionDetails env)
                   ]
 
 pluralise :: Int -> String -> String

integration/test/Testlib/Types.hs

@@ -36,6 +36,7 @@ import Data.Aeson
 import qualified Data.Aeson as Aeson
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy as L
 import qualified Data.CaseInsensitive as CI
@@ -49,6 +50,7 @@ import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.String
+import Data.String.Conversions (cs)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import Data.Time
@@ -271,7 +273,8 @@ data Env = Env
     dnsMockServerConfig :: DNSMockServerConfig,
     cellsEventQueue :: String,
     cellsEventWatchersLock :: MVar (),
-    cellsEventWatchers :: IORef (Map String QueueWatcher)
+    cellsEventWatchers :: IORef (Map String QueueWatcher),
+    curlTrace :: IORef [String]
   }
 
 data Response = Response
@@ -374,7 +377,7 @@ data MLSConv = MLSConv
 
 requestToCurl :: HTTP.Request -> String
 requestToCurl req =
-  unwords $ -- FUTUREWORK: amke this multi-line, but so thhhaaaatttt iiiitttt ddddoooesn't go wrong.
+  unwords $ -- FUTUREWORK: make this multi-line, but so thhhaaaatttt iiiitttt ddddoooesn't go wrong.
     Prelude.filter
       (not . Prelude.null)
       [ "curl",
@@ -401,11 +404,29 @@ requestToCurl req =
         defaultPort = if HTTP.secure req then 443 else 80
 
     body' = case HTTP.requestBody req of
-      HTTP.RequestBodyLBS lbs -> if lbs == mempty then "" else "--data-binary " ++ shellEscape (C8.unpack $ L.toStrict lbs)
-      HTTP.RequestBodyBS bs -> if bs == mempty then "" else "--data-binary " ++ shellEscape (C8.unpack bs)
-      HTTP.RequestBodyBuilder _ _ -> "--data-binary '<builder>'"
-      _ -> ""
-
+      HTTP.RequestBodyLBS lbs -> dataBinary (C8.unpack $ L.toStrict lbs)
+      HTTP.RequestBodyBS bs -> dataBinary (C8.unpack bs)
+      _ ->
+        -- this won't work
+        "--data-binary '<unsupported body type>'"
+
+    dataBinary :: String -> String
+    dataBinary "" = ""
+    dataBinary raw =
+      case Aeson.decode @Aeson.Value (cs raw) of
+        -- For JSON bodies, pass the payload directly, properly shell-escaped.
+        Just _val ->
+          "--data-binary " <> shellEscape raw
+        -- For non-JSON (potentially binary) bodies, use a base64 literal
+        -- and decode it at runtime via a valid command substitution.
+        Nothing ->
+          let b64 :: String
+              b64 = cs (Base64.encode (cs raw))
+           in "--data-binary \"$(printf %s " <> shellEscape b64 <> " | base64 -d)\""
+
+    -- this is probably used wrong, and there are still some escape
+    -- issues to be solved.  but it should be safe as long as we're
+    -- only using it in our own integration tests, right?
     shellEscape :: String -> String
     shellEscape s = "'" ++ concatMap escape s ++ "'"
       where

postgres-schema.sql

@@ -9,8 +9,8 @@
 
 \restrict 79bbfb4630959c48307653a5cd3d83f2582b3c2210f75f10d79e3ebf0015620
 
--- Dumped from database version 17.6
--- Dumped by pg_dump version 17.6
+-- Dumped from database version 17.7
+-- Dumped by pg_dump version 17.7
 
 SET statement_timeout = 0;
 SET lock_timeout = 0;
@@ -40,6 +40,20 @@ ALTER SCHEMA public OWNER TO "wire-server";
 COMMENT ON SCHEMA public IS '';
 
 
+--
+-- Name: recurrence_frequency; Type: TYPE; Schema: public; Owner: wire-server
+--
+
+CREATE TYPE public.recurrence_frequency AS ENUM (
+    'daily',
+    'weekly',
+    'monthly',
+    'yearly'
+);
+
+
+ALTER TYPE public.recurrence_frequency OWNER TO "wire-server";
+
 SET default_tablespace = '';
 
 SET default_table_access_method = heap;
@@ -96,7 +110,8 @@ CREATE TABLE public.conversation (
     receipt_mode integer,
     team uuid,
     type integer NOT NULL,
-    parent_conv uuid
+    parent_conv uuid,
+    history_depth bigint
 );
 
 
@@ -177,33 +192,27 @@ CREATE TABLE public.local_conversation_remote_member (
 
 ALTER TABLE public.local_conversation_remote_member OWNER TO "wire-server";
 
---
--- Name: meetings; Type: ENUM; Schema: public; Owner: wire-server
---
-
-CREATE TYPE recurrence_frequency AS ENUM ('daily', 'weekly', 'monthly', 'yearly');
-
-
-ALTER TABLE public.recurrence_frequency OWNER TO "wire-server";
-
 --
 -- Name: meetings; Type: TABLE; Schema: public; Owner: wire-server
 --
 
 CREATE TABLE public.meetings (
-    id uuid NOT NULL DEFAULT gen_random_uuid(),
+    id uuid DEFAULT gen_random_uuid() NOT NULL,
     title text NOT NULL,
     creator uuid NOT NULL,
-    start_time timestamptz NOT NULL,
-    end_time timestamptz NOT NULL,
-    recurrence_frequency recurrence_frequency,
+    start_time timestamp with time zone NOT NULL,
+    end_time timestamp with time zone NOT NULL,
+    recurrence_frequency public.recurrence_frequency,
     recurrence_interval integer,
-    recurrence_until timestamptz,
+    recurrence_until timestamp with time zone,
     conversation_id uuid NOT NULL,
-    invited_emails text[] DEFAULT '{}'::text[],
-    trial boolean DEFAULT false,
-    created_at timestamp with time zone DEFAULT now(),
-    updated_at timestamp with time zone DEFAULT now()
+    invited_emails text[] DEFAULT '{}'::text[] NOT NULL,
+    trial boolean DEFAULT false NOT NULL,
+    created_at timestamp with time zone DEFAULT now() NOT NULL,
+    updated_at timestamp with time zone DEFAULT now() NOT NULL,
+    CONSTRAINT meetings_title_length CHECK ((length(title) <= 256)),
+    CONSTRAINT meetings_title_not_empty CHECK ((length(TRIM(BOTH FROM title)) > 0)),
+    CONSTRAINT meetings_valid_time_range CHECK ((end_time > start_time))
 );
 
 
@@ -385,19 +394,19 @@ ALTER TABLE ONLY public.conversation
 
 
 --
--- Name: meetings meetings_pkey; Type: CONSTRAINT; Schema: public; Owner: wire-server
+-- Name: local_conversation_remote_member local_conversation_remote_member_pkey; Type: CONSTRAINT; Schema: public; Owner: wire-server
 --
 
-ALTER TABLE ONLY public.meetings
-    ADD CONSTRAINT meetings_pkey PRIMARY KEY (id);
+ALTER TABLE ONLY public.local_conversation_remote_member
+    ADD CONSTRAINT local_conversation_remote_member_pkey PRIMARY KEY (conv, user_remote_domain, user_remote_id);
 
 
 --
--- Name: local_conversation_remote_member local_conversation_remote_member_pkey; Type: CONSTRAINT; Schema: public; Owner: wire-server
+-- Name: meetings meetings_pkey; Type: CONSTRAINT; Schema: public; Owner: wire-server
 --
 
-ALTER TABLE ONLY public.local_conversation_remote_member
-    ADD CONSTRAINT local_conversation_remote_member_pkey PRIMARY KEY (conv, user_remote_domain, user_remote_id);
+ALTER TABLE ONLY public.meetings
+    ADD CONSTRAINT meetings_pkey PRIMARY KEY (id);
 
 
 --