diff --git a/elm.cabal b/elm.cabal index b3bafb3fc..0e75b5c47 100644 --- a/elm.cabal +++ b/elm.cabal @@ -314,6 +314,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 cc58bc598..cf268895f 100644 --- a/extra/Lamdera/CLI/Live.hs +++ b/extra/Lamdera/CLI/Live.hs @@ -514,53 +514,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 $ TE.decodeUtf8 $ newSid - - Just sid_ -> - pure $ TE.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 @@ -613,10 +577,10 @@ serveRpc (mClients, mLeader, mChan, beState) port = do values = case vals of [] -> "null" - val:[] -> T.concat ["\"", (TE.decodeUtf8 val & escapeJsonString), "\""] + val:[] -> TE.decodeUtf8 val & escapeJsonString _ -> vals - & fmap (\v -> T.concat ["\"", (TE.decodeUtf8 v & escapeJsonString), "\""]) + & fmap (escapeJsonString . TE.decodeUtf8) & T.intercalate "," & (\v -> T.concat ["[", v, "]"]) in @@ -630,6 +594,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 $ TE.decodeUtf8 $ newSid + + Just sid_ -> + pure $ TE.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 ]