diff --git a/elm.cabal b/elm.cabal index 8e2221d7..7c59e202 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 5fcc7b82..98544166 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 @@ -619,10 +583,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 @@ -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 da3b524a..189f5850 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 00000000..2836d22c --- /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