From cfa114c57134eac31b477864910c1ea321b38ce4 Mon Sep 17 00:00:00 2001 From: Hans Allis Date: Wed, 28 May 2025 13:52:17 +0200 Subject: [PATCH 1/3] Removed redundant quotes around already escaped JSON strings in the Live.serveRpc function --- extra/Lamdera/CLI/Live.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/Lamdera/CLI/Live.hs b/extra/Lamdera/CLI/Live.hs index 5fcc7b827..d452163b3 100644 --- a/extra/Lamdera/CLI/Live.hs +++ b/extra/Lamdera/CLI/Live.hs @@ -619,10 +619,10 @@ serveRpc (mClients, mLeader, mChan, beState) port = do values = case vals of [] -> "null" - val:[] -> T.concat ["\"", (T.decodeUtf8 val & escapeJsonString), "\""] + val:[] -> T.decodeUtf8 val & escapeJsonString _ -> vals - & fmap (\v -> T.concat ["\"", (T.decodeUtf8 v & escapeJsonString), "\""]) + & fmap (escapeJsonString . T.decodeUtf8) & T.intercalate "," & (\v -> T.concat ["[", v, "]"]) in From 11bf9e1e4127fa5a70937d8bb72211c2b3a08c74 Mon Sep 17 00:00:00 2001 From: Hans Allis Date: Thu, 29 May 2025 12:26:50 +0200 Subject: [PATCH 2/3] Add Live RPC request payload generation and corresponding tests - Introduced `generateRpcRequestPayload` function to handle the creation of RPC request payloads based on content type and request data. - Updated `serveRpc` to utilize the new payload generation function. - Added a new test suite for `Test.Lamdera.Live` to validate form-urlencoded parsing logic and ensure correct JSON structure in the generated payload. - Included the new test in `elm.cabal` and `Test.hs` --- elm.cabal | 1 + extra/Lamdera/CLI/Live.hs | 108 ++++++++++++++++++++++---------------- test/Test.hs | 2 + test/Test/Lamdera/Live.hs | 104 ++++++++++++++++++++++++++++++++++++ 4 files changed, 169 insertions(+), 46 deletions(-) create mode 100644 test/Test/Lamdera/Live.hs diff --git a/elm.cabal b/elm.cabal index 8e2221d76..7c59e2025 100644 --- a/elm.cabal +++ b/elm.cabal @@ -313,6 +313,7 @@ Executable lamdera Test.Check Test.Helpers Test.Lamdera + Test.Lamdera.Live Test.Snapshot Test.TypeHashes Test.Wire diff --git a/extra/Lamdera/CLI/Live.hs b/extra/Lamdera/CLI/Live.hs index d452163b3..985441664 100644 --- a/extra/Lamdera/CLI/Live.hs +++ b/extra/Lamdera/CLI/Live.hs @@ -520,53 +520,17 @@ detectEditor editorName editorExistsCheck openIO = do pure Nothing -serveRpc (mClients, mLeader, mChan, beState) port = do - - mEndpoint <- getParam "endpoint" - rbody <- readRequestBody _10MB - mSid <- getCookie "sid" - requestHeaders :: [(BS.ByteString, BS.ByteString)] <- fmap (\(cs, s) -> (CI.original cs, s)) <$> listHeaders <$> getRequest - - -- E.chars perfoms character escaping, as header values can often have " within them - let requestHeadersJson = requestHeaders & fmap (Ext.Common.bsToUtf8 *** (E.chars . Ext.Common.bsToString)) & E.object - - contentType :: Maybe BS.ByteString <- getHeader "Content-Type" <$> getRequest - - debug $ "RPC:↘️ " ++ show (contentType, mEndpoint, mSid, rbody) - - randBytes <- liftIO $ getEntropy 20 - let newSid = BSL.toStrict $ B.toLazyByteString $ B.byteStringHex randBytes - - sid <- - case mSid of - Nothing -> do - let cookie = Cookie "sid" newSid Nothing Nothing Nothing False False - modifyResponse $ addResponseCookie cookie - - pure $ T.decodeUtf8 $ newSid - - Just sid_ -> - pure $ T.decodeUtf8 $ cookieValue sid_ - - onlyWhen (mEndpoint == Nothing) $ error500 "no endpoint present" - - -- Using UUIDv4 here instead of UUIDv1 like in production is merely a matter - -- of ergonomics; The UUIDv1 package only has `nextUUID :: IO (Maybe UUID)` - -- as it returns Nothing for requests too close together, so using UUIDv4 - -- was more practical than implementing a UUIDv1 with retry - reqId <- liftIO $ UUID.toText <$> UUID.nextRandom - outChan <- newBChanListener mChan - +-- | Generate RPC request payload based on content type and request data +generateRpcRequestPayload :: + Maybe BS.ByteString -- ^ Content-Type header + -> BSL.ByteString -- ^ Request body + -> BS.ByteString -- ^ Endpoint + -> Text -- ^ Session ID + -> Text -- ^ Request ID + -> E.Value -- ^ Request headers JSON + -> Text -- ^ Final JSON payload +generateRpcRequestPayload contentType rbody endpoint sid reqId requestHeadersJson = let - endpoint = - case mEndpoint of - Just endpoint_ -> - endpoint_ - - Nothing -> - -- Should be impossible given we already checked above - error "impossible: no endpoint present" - -- Unfortunately the JSON string encoding logic is hidden inside Data.Aeson.Encoding.Internal -- so off we go with all the silly format hops escapeJsonString :: Text -> Text @@ -636,6 +600,58 @@ serveRpc (mClients, mLeader, mChan, beState) port = do fallbackStringBody Nothing -> fallbackStringBody + in + requestPayload + + +serveRpc (mClients, mLeader, mChan, beState) port = do + + mEndpoint <- getParam "endpoint" + rbody <- readRequestBody _10MB + mSid <- getCookie "sid" + requestHeaders :: [(BS.ByteString, BS.ByteString)] <- fmap (\(cs, s) -> (CI.original cs, s)) <$> listHeaders <$> getRequest + + -- E.chars perfoms character escaping, as header values can often have " within them + let requestHeadersJson = requestHeaders & fmap (Ext.Common.bsToUtf8 *** (E.chars . Ext.Common.bsToString)) & E.object + + contentType :: Maybe BS.ByteString <- getHeader "Content-Type" <$> getRequest + + debug $ "RPC:↘️ " ++ show (contentType, mEndpoint, mSid, rbody) + + randBytes <- liftIO $ getEntropy 20 + let newSid = BSL.toStrict $ B.toLazyByteString $ B.byteStringHex randBytes + + sid <- + case mSid of + Nothing -> do + let cookie = Cookie "sid" newSid Nothing Nothing Nothing False False + modifyResponse $ addResponseCookie cookie + + pure $ T.decodeUtf8 $ newSid + + Just sid_ -> + pure $ T.decodeUtf8 $ cookieValue sid_ + + onlyWhen (mEndpoint == Nothing) $ error500 "no endpoint present" + + -- Using UUIDv4 here instead of UUIDv1 like in production is merely a matter + -- of ergonomics; The UUIDv1 package only has `nextUUID :: IO (Maybe UUID)` + -- as it returns Nothing for requests too close together, so using UUIDv4 + -- was more practical than implementing a UUIDv1 with retry + reqId <- liftIO $ UUID.toText <$> UUID.nextRandom + outChan <- newBChanListener mChan + + let + endpoint = + case mEndpoint of + Just endpoint_ -> + endpoint_ + + Nothing -> + -- Should be impossible given we already checked above + error "impossible: no endpoint present" + + requestPayload = generateRpcRequestPayload contentType rbody endpoint sid reqId requestHeadersJson loopRead :: IO Text loopRead = do diff --git a/test/Test.hs b/test/Test.hs index da3b524a1..189f58507 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -21,6 +21,7 @@ import qualified Test.Ext.ElmPages.Check import qualified Test.TypeHashes import qualified Test.JsOutput import qualified Test.WebGL +import qualified Test.Lamdera.Live import qualified Test.Lamdera.Evergreen.TestMigrationHarness import qualified Test.Lamdera.Evergreen.TestMigrationGenerator @@ -159,4 +160,5 @@ allTests = , scope "Lamdera.Evergreen.TestMigrationGenerator -> " $ Test.Lamdera.Evergreen.TestMigrationGenerator.suite , scope "Test.WebGL -> " $ Test.WebGL.suite , scope "Test.JsOutput -> " $ Test.JsOutput.suite + , scope "Test.Lamdera.Live -> " $ Test.Lamdera.Live.suite ] diff --git a/test/Test/Lamdera/Live.hs b/test/Test/Lamdera/Live.hs new file mode 100644 index 000000000..2836d22cd --- /dev/null +++ b/test/Test/Lamdera/Live.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Lamdera.Live where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Map as Map +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.Aeson.Key as Key +import qualified Data.Vector as Vector +import Data.Function ((&)) + +import qualified Json.Decode as D +import qualified Json.Encode as E +import qualified Json.String +import qualified Data.Utf8 as Utf8 + +import qualified Snap.Core as Snap + +import EasyTest +import Test.Helpers + +-- Import the module we're testing +import qualified Lamdera.CLI.Live as Live + +suite :: Test () +suite = tests + [ scope "generateRpcRequestPayload form-urlencoded parsing" $ do + testFormUrlencodedParsing + ] + +-- Test the form-urlencoded parsing logic +testFormUrlencodedParsing :: Test () +testFormUrlencodedParsing = do + let + -- Test data: "singlevalue=test&multivalue=test1&multivalue=test2" + formData = "singlevalue=test&multivalue=test1&multivalue=test2" + contentType = Just "application/x-www-form-urlencoded" + rbody = BSL.fromStrict $ T.encodeUtf8 formData + endpoint = "test-endpoint" + sid = "test-session" + reqId = "test-request-id" + + -- Create a simple headers JSON for testing + requestHeadersJson = E.object [("content-type", E.string "application/x-www-form-urlencoded")] + + -- Generate the payload + let finalPayload = Live.generateRpcRequestPayload contentType rbody endpoint sid reqId requestHeadersJson + + -- Test 1: The result should be a valid JSON string + case Aeson.decode (BSL.fromStrict $ T.encodeUtf8 finalPayload) of + Nothing -> crash $ "Final payload is not valid JSON: " ++ T.unpack finalPayload + Just (outerJson :: Aeson.Value) -> do + + -- Test 2: Check that the outer JSON has the expected structure + case outerJson of + Aeson.Object outerObj -> do + -- Check for required fields + if not (KeyMap.member "t" outerObj) then crash "Missing 't' field" else ok + if not (KeyMap.member "s" outerObj) then crash "Missing 's' field" else ok + if not (KeyMap.member "e" outerObj) then crash "Missing 'e' field" else ok + if not (KeyMap.member "r" outerObj) then crash "Missing 'r' field" else ok + if not (KeyMap.member "h" outerObj) then crash "Missing 'h' field" else ok + if not (KeyMap.member "j" outerObj) then crash "Missing 'j' field" else ok + + -- Test 3: Check that the "j" field contains a valid JSON string + case KeyMap.lookup "j" outerObj of + Just (Aeson.String jValue) -> do + let jString = T.unpack jValue + case Aeson.decode (BSL.fromStrict $ T.encodeUtf8 jValue) of + Nothing -> crash $ "The 'j' field does not contain valid JSON: " ++ jString + Just (innerJson :: Aeson.Value) -> do + + -- Test 4: Check that the inner JSON has the expected form data structure + case innerJson of + Aeson.Object innerObj -> do + -- Check for singlevalue + case KeyMap.lookup "singlevalue" innerObj of + Just (Aeson.String val) -> + if val == "test" then ok else crash "singlevalue should be 'test'" + _ -> crash "singlevalue field missing or not a string" + + -- Check for multivalue (should be an array) + case KeyMap.lookup "multivalue" innerObj of + Just (Aeson.Array arr) -> do + let arrList = Vector.toList arr + if length arrList == 2 then ok else crash "multivalue should have 2 elements" + case arrList of + [Aeson.String val1, Aeson.String val2] -> do + if val1 == "test1" then ok else crash "first multivalue should be 'test1'" + if val2 == "test2" then ok else crash "second multivalue should be 'test2'" + _ -> crash "multivalue array elements are not strings" + _ -> crash "multivalue field missing or not an array" + + _ -> crash "Inner JSON is not an object" + + _ -> crash "The 'j' field is missing or not a string" + + _ -> crash "Outer JSON is not an object" \ No newline at end of file From 521283757fb2ff91f2fc3715be11267ac3a8ca30 Mon Sep 17 00:00:00 2001 From: Mario Rogic Date: Sat, 9 Aug 2025 14:08:56 +1000 Subject: [PATCH 3/3] Drop redundant test --- test/Test/Lamdera/Live.hs | 104 -------------------------------------- 1 file changed, 104 deletions(-) delete mode 100644 test/Test/Lamdera/Live.hs diff --git a/test/Test/Lamdera/Live.hs b/test/Test/Lamdera/Live.hs deleted file mode 100644 index 2836d22cd..000000000 --- a/test/Test/Lamdera/Live.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Test.Lamdera.Live where - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Map as Map -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson -import qualified Data.Aeson.KeyMap as KeyMap -import qualified Data.Aeson.Key as Key -import qualified Data.Vector as Vector -import Data.Function ((&)) - -import qualified Json.Decode as D -import qualified Json.Encode as E -import qualified Json.String -import qualified Data.Utf8 as Utf8 - -import qualified Snap.Core as Snap - -import EasyTest -import Test.Helpers - --- Import the module we're testing -import qualified Lamdera.CLI.Live as Live - -suite :: Test () -suite = tests - [ scope "generateRpcRequestPayload form-urlencoded parsing" $ do - testFormUrlencodedParsing - ] - --- Test the form-urlencoded parsing logic -testFormUrlencodedParsing :: Test () -testFormUrlencodedParsing = do - let - -- Test data: "singlevalue=test&multivalue=test1&multivalue=test2" - formData = "singlevalue=test&multivalue=test1&multivalue=test2" - contentType = Just "application/x-www-form-urlencoded" - rbody = BSL.fromStrict $ T.encodeUtf8 formData - endpoint = "test-endpoint" - sid = "test-session" - reqId = "test-request-id" - - -- Create a simple headers JSON for testing - requestHeadersJson = E.object [("content-type", E.string "application/x-www-form-urlencoded")] - - -- Generate the payload - let finalPayload = Live.generateRpcRequestPayload contentType rbody endpoint sid reqId requestHeadersJson - - -- Test 1: The result should be a valid JSON string - case Aeson.decode (BSL.fromStrict $ T.encodeUtf8 finalPayload) of - Nothing -> crash $ "Final payload is not valid JSON: " ++ T.unpack finalPayload - Just (outerJson :: Aeson.Value) -> do - - -- Test 2: Check that the outer JSON has the expected structure - case outerJson of - Aeson.Object outerObj -> do - -- Check for required fields - if not (KeyMap.member "t" outerObj) then crash "Missing 't' field" else ok - if not (KeyMap.member "s" outerObj) then crash "Missing 's' field" else ok - if not (KeyMap.member "e" outerObj) then crash "Missing 'e' field" else ok - if not (KeyMap.member "r" outerObj) then crash "Missing 'r' field" else ok - if not (KeyMap.member "h" outerObj) then crash "Missing 'h' field" else ok - if not (KeyMap.member "j" outerObj) then crash "Missing 'j' field" else ok - - -- Test 3: Check that the "j" field contains a valid JSON string - case KeyMap.lookup "j" outerObj of - Just (Aeson.String jValue) -> do - let jString = T.unpack jValue - case Aeson.decode (BSL.fromStrict $ T.encodeUtf8 jValue) of - Nothing -> crash $ "The 'j' field does not contain valid JSON: " ++ jString - Just (innerJson :: Aeson.Value) -> do - - -- Test 4: Check that the inner JSON has the expected form data structure - case innerJson of - Aeson.Object innerObj -> do - -- Check for singlevalue - case KeyMap.lookup "singlevalue" innerObj of - Just (Aeson.String val) -> - if val == "test" then ok else crash "singlevalue should be 'test'" - _ -> crash "singlevalue field missing or not a string" - - -- Check for multivalue (should be an array) - case KeyMap.lookup "multivalue" innerObj of - Just (Aeson.Array arr) -> do - let arrList = Vector.toList arr - if length arrList == 2 then ok else crash "multivalue should have 2 elements" - case arrList of - [Aeson.String val1, Aeson.String val2] -> do - if val1 == "test1" then ok else crash "first multivalue should be 'test1'" - if val2 == "test2" then ok else crash "second multivalue should be 'test2'" - _ -> crash "multivalue array elements are not strings" - _ -> crash "multivalue field missing or not an array" - - _ -> crash "Inner JSON is not an object" - - _ -> crash "The 'j' field is missing or not a string" - - _ -> crash "Outer JSON is not an object" \ No newline at end of file