From 378770cde6fb9fd85983c05eab9eeff2e34398c2 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 21 Apr 2017 19:45:09 -0400
Subject: working toward getting developer mode connection to server working

---
 WebSockets.hs | 31 +++++++++----------------------
 1 file changed, 9 insertions(+), 22 deletions(-)

(limited to 'WebSockets.hs')

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
-- 
cgit v1.2.3