From 9456361ed8f6dd094a4c08cc352f9a1fd9d0069f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 1 May 2017 12:23:18 -0400 Subject: move protocol types to top --- WebSockets.hs | 144 +++++++++++++++++++++++++++++----------------------------- 1 file changed, 72 insertions(+), 72 deletions(-) diff --git a/WebSockets.hs b/WebSockets.hs index 98c5946..7750cf8 100644 --- a/WebSockets.hs +++ b/WebSockets.hs @@ -45,6 +45,73 @@ import Text.Read import Control.Monad import Network.URI +-- | Framing protocol used over a websocket connection. +-- +-- This is an asynchronous protocol; both client and server can send +-- messages at the same time. +-- +-- Messages that only one can send are tagged with ClientSends or +-- ServerSends. +data WireProtocol + = Version [WireVersion] + | SelectMode ClientSends Mode + | Ready ServerSends SessionID + | AnyMessage AnyMessage + | Done + | WireProtocolError String + +data ServerSends = ServerSends +data ClientSends = ClientSends + +instance WebSocketsData WireProtocol where + toLazyByteString (Version v) = "V" <> Data.Aeson.encode v + toLazyByteString (SelectMode _ m) = "M" <> Data.Aeson.encode m + toLazyByteString (Ready _ sid) = "R" <> Data.Aeson.encode sid + toLazyByteString (AnyMessage msg) = "L" <> + let pmsg = toProtocolBuffer msg :: AnyMessageP + in Data.Serialize.runPutLazy (encodeMessage pmsg) + toLazyByteString Done = "D" + toLazyByteString (WireProtocolError s) = "E" <> Data.Aeson.encode s + fromLazyByteString b = case L.splitAt 1 b of + ("V", v) -> maybe (WireProtocolError "invalid JSON in Version") + Version + (Data.Aeson.decode v) + ("M", m) -> maybe (WireProtocolError "invalid JSON in Mode") + (SelectMode ClientSends) + (Data.Aeson.decode m) + ("R", sid) -> maybe (WireProtocolError "invalid JSON in SessionID") + (Ready ServerSends) + (Data.Aeson.decode sid) + ("L", l) -> case Data.Serialize.runGetLazy decodeMessage l of + Left err -> WireProtocolError $ "Protocol buffers decode error: " ++ err + Right (pmsg :: AnyMessageP) -> AnyMessage (fromProtocolBuffer pmsg) + ("D", "") -> Done + ("E", s) -> maybe (WireProtocolError "invalid JSON in WireProtocolError") + WireProtocolError + (Data.Aeson.decode s) + _ -> WireProtocolError "received unknown websocket message" + fromDataMessage = fromLazyByteString . fromDataMessage + +-- | Modes of operation that can be requested for a websocket connection. +data Mode + = InitMode EmailAddress + -- ^ initialize a new debug-me session. + | ConnectMode T.Text + -- ^ Text specifies the SessionID to connect to + deriving (Show, Eq, Generic) + +instance FromJSON Mode +instance ToJSON Mode where + +newtype WireVersion = WireVersion T.Text + deriving (Show, Eq, Generic, Ord) + +instance FromJSON WireVersion +instance ToJSON WireVersion + +supportedWireVersions :: [WireVersion] +supportedWireVersions = [WireVersion "1"] + -- | Enable compression. connectionOptions :: ConnectionOptions connectionOptions = defaultConnectionOptions @@ -144,68 +211,6 @@ relayToSocket conn mksent getter = go sendBinaryData conn $ AnyMessage wiremsg go --- | Framing protocol used over a websocket connection. --- --- This is an asynchronous protocol; both client and server can send --- messages at the same time. --- --- Messages that only one can send are tagged with ClientSends or --- ServerSends. -data WireProtocol - = Version [WireVersion] - | SelectMode ClientSends Mode - | Ready ServerSends SessionID - | AnyMessage AnyMessage - | Done - | WireProtocolError String - -data ServerSends = ServerSends -data ClientSends = ClientSends - -instance WebSocketsData WireProtocol where - toLazyByteString (Version v) = "V" <> Data.Aeson.encode v - toLazyByteString (SelectMode _ m) = "M" <> Data.Aeson.encode m - toLazyByteString (Ready _ sid) = "R" <> Data.Aeson.encode sid - toLazyByteString (AnyMessage msg) = "L" <> - let pmsg = toProtocolBuffer msg :: AnyMessageP - in Data.Serialize.runPutLazy (encodeMessage pmsg) - toLazyByteString Done = "D" - toLazyByteString (WireProtocolError s) = "E" <> Data.Aeson.encode s - fromLazyByteString b = case L.splitAt 1 b of - ("V", v) -> maybe (WireProtocolError "invalid JSON in Version") - Version - (Data.Aeson.decode v) - ("M", m) -> maybe (WireProtocolError "invalid JSON in Mode") - (SelectMode ClientSends) - (Data.Aeson.decode m) - ("R", sid) -> maybe (WireProtocolError "invalid JSON in SessionID") - (Ready ServerSends) - (Data.Aeson.decode sid) - ("L", l) -> case Data.Serialize.runGetLazy decodeMessage l of - Left err -> WireProtocolError $ "Protocol buffers decode error: " ++ err - Right (pmsg :: AnyMessageP) -> AnyMessage (fromProtocolBuffer pmsg) - ("D", "") -> Done - ("E", s) -> maybe (WireProtocolError "invalid JSON in WireProtocolError") - WireProtocolError - (Data.Aeson.decode s) - _ -> WireProtocolError "received unknown websocket message" - fromDataMessage = fromLazyByteString . fromDataMessage - -protocolError :: Connection -> String -> IO a -protocolError conn err = do - sendBinaryData conn (WireProtocolError err) - sendClose conn Done - error err - -newtype WireVersion = WireVersion T.Text - deriving (Show, Eq, Generic, Ord) - -instance FromJSON WireVersion -instance ToJSON WireVersion - -supportedWireVersions :: [WireVersion] -supportedWireVersions = [WireVersion "1"] - -- | Send supportedWireVersions and at the same time receive it from -- the remote side. The highest version present in both lists will be used. negotiateWireVersion :: Connection -> IO WireVersion @@ -220,13 +225,8 @@ negotiateWireVersion conn = do "Unable to negotiate protocol Version. I support: " ++ show supportedWireVersions ++ " They support: " ++ show remoteversions _ -> protocolError conn "Protocol error, did not receive Version" --- | Modes of operation that can be requested for a websocket connection. -data Mode - = InitMode EmailAddress - -- ^ initialize a new debug-me session. - | ConnectMode T.Text - -- ^ Text specifies the SessionID to connect to - deriving (Show, Eq, Generic) - -instance FromJSON Mode -instance ToJSON Mode where +protocolError :: Connection -> String -> IO a +protocolError conn err = do + sendBinaryData conn (WireProtocolError err) + sendClose conn Done + error err -- cgit v1.2.3