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

---
 Server.hs | 40 ++++++++++++++++++++++++++++++++--------
 1 file changed, 32 insertions(+), 8 deletions(-)

(limited to 'Server.hs')

diff --git a/Server.hs b/Server.hs
index 26e274b..4fa80a7 100644
--- a/Server.hs
+++ b/Server.hs
@@ -10,6 +10,7 @@ import Log
 import Network.Wai
 import Network.Wai.Handler.Warp
 import Network.Wai.Handler.WebSockets
+import Network.WebSockets hiding (Message)
 import qualified Network.WebSockets as WS
 import Network.HTTP.Types
 import Control.Concurrent.STM
@@ -23,6 +24,8 @@ import Data.Time.Clock.POSIX
 server :: ServerOpts -> IO ()
 server o = run (serverPort o) . app o =<< newServerState
 
+-- | A server is a map of sessions, each of which consists of a broadcast
+-- TMChan, which both users and developers write messages to.
 type ServerState = M.Map SessionID (TMChan Log)
 
 newServerState :: IO (TVar ServerState)
@@ -46,7 +49,8 @@ websocketApp o ssv pending_conn = do
 			Just sid -> developer o ssv sid conn
 
 user :: ServerOpts -> TVar ServerState -> WS.Connection -> IO ()
-user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) ->
+user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> do
+	sendTextData conn sid
 	bracket (setup sid) (cleanup sid) (go logh)
   where
 	setup sid = do
@@ -66,7 +70,14 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) ->
 			`concurrently` relayfromuser bchan
 		return ()
 	
-	-- Read from logchan and store each value to the log file.
+	-- Relay all messages from the user's websocket to the
+	-- broadcast channel.
+	relayfromuser bchan = relayFromSocket conn $ \msg -> do
+		print ("got from user", msg)
+		l <- mkLog (User msg) <$> getPOSIXTime
+		atomically $ writeTMChan bchan l
+	
+	-- Read from logchan and store each message to the log file.
 	storelog logh logchan = do
 		v <- atomically $ readTMChan logchan
 		case v of
@@ -75,6 +86,7 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) ->
 				writeLogHandle l logh
 				storelog logh logchan
 	
+	-- Relay developer messages from the channel to the user's websocket.
 	relaytouser userchan = relayToSocket conn $ do
 		v <- atomically $ readTMChan userchan
 		return $ case v of
@@ -82,10 +94,6 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) ->
 				Developer m -> Just m
 				User _ -> Nothing
 			Nothing -> Nothing
-	
-	relayfromuser bchan = relayFromSocket conn $ \msg -> do
-		l <- mkLog (User msg) <$> getPOSIXTime
-		atomically $ writeTMChan bchan l
 
 developer ::  ServerOpts -> TVar ServerState -> SessionID -> WS.Connection -> IO ()
 developer o ssv sid conn = bracket setup cleanup go
@@ -93,8 +101,24 @@ developer o ssv sid conn = bracket setup cleanup go
 	setup = atomically $ M.lookup sid <$> readTVar ssv
 	cleanup _ = return ()
 	go Nothing = error "Invalid session id!"
-	go (Just logchan) = relayToSocket conn $ do
-		v <- atomically $ readTMChan logchan
+	go (Just bchan) = do
+		sendTextData conn sid
+		-- TODO replay backlog
+		devchan <- atomically $ dupTMChan bchan
+		_ <- relayfromdeveloper bchan
+			`concurrently` relaytodeveloper devchan
+		return ()
+	
+	-- Relay all messages from the developer's websocket to the
+	-- broadcast channel.
+	relayfromdeveloper bchan = relayFromSocket conn $ \msg -> do
+		print ("got from developer", msg)
+		l <- mkLog (Developer msg) <$> getPOSIXTime
+		atomically $ writeTMChan bchan l
+	
+	-- Relay user messages from the channel to the developer's websocket.
+	relaytodeveloper devchan = relayToSocket conn $ do
+		v <- atomically $ readTMChan devchan
 		return $ case v of
 			Just l -> case loggedMessage l of
 				User m -> Just m
-- 
cgit v1.2.3