Fix: Sink all message chunks into a lazy ByteString

Calling sendBinaryData on every chunk leads to one web socket event per
chunk. The expected behaviour is to send the whole stream's content as
one event, though.

services/cannon/src/Cannon/WS.hs

@@ -55,9 +55,9 @@ import Control.Concurrent.Timeout
 import Control.Monad.Catch
 import Control.Retry
 import Data.Aeson hiding (Error)
-import qualified Data.ByteString
 import Data.ByteString.Char8 (pack)
 import Data.ByteString.Conversion
+import qualified Data.ByteString.Lazy as L
 import Data.Default (def)
 import Data.Hashable
 import Data.Id (ClientId, ConnId (..), UserId)
@@ -225,25 +225,21 @@ isRemoteRegistered u c = do
   cs <- map connId <$> parseResponse (mkError status502 "server-error") rs
   return $ c `elem` cs
 
-sendMsgIO :: WebSocketsData a => a -> Websocket -> IO ()
-sendMsgIO m c = do
+sendMsgIO :: (WebSocketsData a) => a -> Websocket -> IO ()
+sendMsgIO m c =
   recoverAll retry3x $ const $ sendBinaryData (connection c) m
 
 sendMsgConduit :: Key -> Websocket -> ConduitT ByteString Void (ResourceT WS) ()
 sendMsgConduit k c = do
-  m <- await
-  case m of
-    Just m' -> do
-      lift $ traceLog m'
-      liftIO $ sendMsgIO m' c
-      sendMsgConduit k c
-    Nothing -> pure ()
+  m <- sinkLazy
+  lift $ traceLog m
+  liftIO $ sendMsgIO m c
   where
-    traceLog :: ByteString -> (ResourceT WS) ()
+    traceLog :: L.ByteString -> (ResourceT WS) ()
     traceLog m = lift $ trace $ client kb . msg (logMsg m)
 
-    logMsg :: ByteString -> Builder
-    logMsg m = val "sendMsgConduit: \"" +++ Data.ByteString.take 128 m +++ val "...\""
+    logMsg :: L.ByteString -> Builder
+    logMsg m = val "sendMsgConduit: \"" +++ L.take 128 m +++ val "...\""
 
     kb = key2bytes k
 

services/gundeck/test/integration/API.hs

@@ -76,6 +76,7 @@ tests s =
           test s "Replace presence" replacePresence,
           test s "Remove stale presence" removeStalePresence,
           test s "Single user push" singleUserPush,
+          test s "Single user push with large message" singleUserPushLargeMessage,
           test s "Push many to Cannon via bulkpush (via gundeck; group notif)" $ bulkPush False 50 8,
           test s "Push many to Cannon via bulkpush (via gundeck; e2e notif)" $ bulkPush True 50 8,
           test s "Send a push, ensure origin does not receive it" sendSingleUserNoPiggyback,
@@ -195,7 +196,13 @@ removeStalePresence = do
     push u us = newPush u (toRecipients us) pload & pushOriginConnection .~ Just (ConnId "dev")
 
 singleUserPush :: TestM ()
-singleUserPush = do
+singleUserPush = testSingleUserPush smallMsgPayload
+  where
+    -- JSON: {"foo":42}
+    smallMsgPayload = List1.singleton $ HashMap.fromList ["foo" .= (42 :: Int)]
+
+testSingleUserPush :: List1 Object -> TestM ()
+testSingleUserPush msgPayload = do
   ca <- view tsCannon
   uid <- randomId
   ch <- connectUser ca uid =<< randomConnId
@@ -205,12 +212,18 @@ singleUserPush = do
     assertBool "No push message received" (isJust msg)
     assertEqual
       "Payload altered during transmission"
-      (Just pload)
+      (Just msgPayload)
       (ntfPayload <$> (decode . fromStrict . fromJust) msg)
   where
-    pload = List1.singleton $ HashMap.fromList ["foo" .= (42 :: Int)]
-    push u us = newPush (Just u) (toRecipients us) pload & pushOriginConnection .~ Just (ConnId "dev")
+    push u us = newPush (Just u) (toRecipients us) msgPayload & pushOriginConnection .~ Just (ConnId "dev")
+
+singleUserPushLargeMessage :: TestM ()
+singleUserPushLargeMessage = testSingleUserPush largeMsgPayload
+  where
+    -- JSON: {"list":["1","2", ... ,"10000"]}
+    largeMsgPayload = List1.singleton $ HashMap.fromList ["list" .= [show i | i <- [1 .. 10000] :: [Int]]]
 
+-- | Create a number of users with a number of connections each, and connect each user's connections
 -- | Create a number of users with a number of connections each, and connect each user's connections
 -- to one of two cannons at random.  Push either encrypted notifications (@isE2E == True@) or
 -- notifications from server (@isE2E == False@) to all connections, and make sure they all arrive at