diff options
author | Joey Hess <joeyh@joeyh.name> | 2017-04-21 19:45:09 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2017-04-21 19:45:09 -0400 |
commit | 378770cde6fb9fd85983c05eab9eeff2e34398c2 (patch) | |
tree | 761273cdf6cc507db3fb1f6d7a2658d1fd799214 /WebSockets.hs | |
parent | a5f677919c2db47149e545165c9cacbf2c6b07b4 (diff) | |
download | debug-me-378770cde6fb9fd85983c05eab9eeff2e34398c2.tar.gz |
working toward getting developer mode connection to server working
Diffstat (limited to 'WebSockets.hs')
-rw-r--r-- | WebSockets.hs | 31 |
1 files changed, 9 insertions, 22 deletions
diff --git a/WebSockets.hs b/WebSockets.hs index 8816b6b..c7893fb 100644 --- a/WebSockets.hs +++ b/WebSockets.hs @@ -4,15 +4,14 @@ module WebSockets where import Types import Serialization +import SessionID import Network.WebSockets hiding (Message) import Control.Concurrent.STM import Control.Concurrent.Async import Control.Exception import qualified Data.Aeson -import qualified Data.Binary import qualified Data.Text as T -import qualified Data.ByteString.Lazy as L import Data.List import Data.Maybe @@ -21,14 +20,15 @@ runClientApp = runClient "localhost" 8081 "/" -- | Make a client that sends and receives Messages over a websocket. clientApp - :: (WebSocketsData (Message sent), WebSocketsData (Message received)) + :: (Show sent, WebSocketsData (Message sent), WebSocketsData (Message received)) => Mode - -> (TChan (Message sent) -> TChan (Message received) -> IO a) + -> (TChan (Message sent) -> TChan (Message received) -> SessionID -> IO a) -> ClientApp a clientApp mode a conn = do vs <- negotiateWireVersion conn sendMode conn mode - bracket setup cleanup go + sid <- receiveData conn + bracket setup cleanup (go sid) where setup = do schan <- newTChanIO @@ -41,7 +41,7 @@ clientApp mode a conn = do cleanup (_, _, sthread, rthread) = do cancel sthread cancel rthread - go (schan, rchan, _, _) = a schan rchan + go sid (schan, rchan, _, _) = a schan rchan sid relayFromSocket :: WebSocketsData (Message received) => Connection -> (Message received -> IO ()) -> IO () relayFromSocket conn sender = go @@ -51,13 +51,14 @@ relayFromSocket conn sender = go sender msg go -relayToSocket :: WebSocketsData (Message sent) => Connection -> (IO (Maybe (Message sent))) -> IO () +relayToSocket :: Show sent => WebSocketsData (Message sent) => Connection -> (IO (Maybe (Message sent))) -> IO () relayToSocket conn getter = go where go = do mmsg <- getter + print ("got message", mmsg) case mmsg of - Nothing -> return () + Nothing -> go Just msg -> do sendBinaryData conn msg go @@ -83,7 +84,6 @@ negotiateWireVersion conn = do (_, remoteversions) <- concurrently (sendTextData conn supportedWireVersions) (receiveData conn) - print ("got versions" :: String, remoteversions) case reverse (intersect (sort supportedWireVersions) (sort remoteversions)) of (v:_) -> return v [] -> error $ "Unable to negotiate a WireVersion. I support: " ++ show supportedWireVersions ++ " They support: " ++ show remoteversions @@ -107,16 +107,3 @@ sendMode = sendTextData getMode :: Connection -> IO Mode getMode = receiveData - -instance WebSocketsData (Message Seen) where - fromLazyByteString = decodeBinaryMessage - toLazyByteString = Data.Binary.encode - -instance WebSocketsData (Message Entered) where - fromLazyByteString = decodeBinaryMessage - toLazyByteString = Data.Binary.encode - -decodeBinaryMessage :: Binary (Message a) => L.ByteString -> Message a -decodeBinaryMessage b = case Data.Binary.decodeOrFail b of - Right (_, _, msg) -> msg - Left (_, _, err) -> error $ "Binary decode error: " ++ err |