add framing protocol for websockets

4 files changed, 21 insertions, 12 deletions

diff --git a/Role/Developer.hs b/Role/Developer.hs
index 89f6ea9..4248591 100644
--- a/Role/Developer.hs
+++ b/Role/Developer.hs
@@ -19,14 +19,23 @@ import qualified Data.Text as T
 import Data.List
 
 run :: DeveloperOpts -> IO ()
-run os = runClientApp $ clientApp (ConnectMode (T.pack (debugUrl os))) developer
+run = run' developer . debugUrl
+
+run' :: (TChan (Message Entered) -> TChan (Message Seen) -> SessionID -> IO ()) -> UrlString -> IO ()
+run' runner url = runClientApp $ clientApp connect Developer userMessages runner
+  where
+	connect = ConnectMode (T.pack url)
+
+userMessages :: LogMessage -> Maybe (Message Seen)
+userMessages (User m) = Just m
+userMessages (Developer _) = Nothing
 
 developer :: TChan (Message Entered) -> TChan (Message Seen) -> SessionID -> IO ()
-developer ichan ochan _ = inRawMode $ withLogger "debug-me-developer.log" $ \logger -> do
+developer ichan ochan _ = withLogger "debug-me-developer.log" $ \logger -> do
 	devstate <- processSessionStart ochan logger
 	ok <- authUser ichan ochan devstate logger
 	if ok
-		then do
+		then inRawMode $ do
 			_ <- sendTtyInput ichan devstate logger
 				`concurrently` sendTtyOutput ochan devstate logger
 			return ()
diff --git a/Role/Downloader.hs b/Role/Downloader.hs
index 3981227..d327c8c 100644
--- a/Role/Downloader.hs
+++ b/Role/Downloader.hs
@@ -3,15 +3,13 @@ module Role.Downloader where
 import Types
 import Log
 import CmdLine
-import WebSockets
 import SessionID
 
 import Control.Concurrent.STM
-import qualified Data.Text as T
-import Role.Developer (processSessionStart, getUserMessage, Output(..))
+import Role.Developer (run', processSessionStart, getUserMessage, Output(..))
 
 run :: DownloadOpts -> IO ()
-run os = runClientApp $ clientApp (ConnectMode (T.pack (downloadUrl os))) downloader
+run = run' downloader . downloadUrl
 
 downloader :: TChan (Message Entered) -> TChan (Message Seen) -> SessionID -> IO ()
 downloader _ichan ochan sid = do
diff --git a/Role/User.hs b/Role/User.hs
index daaaa71..1d1702e 100644
--- a/Role/User.hs
+++ b/Role/User.hs
@@ -33,7 +33,7 @@ run os = do
 		putStr "Connecting to debug-me server..."
 		hFlush stdout
 		esv <- newEmptyTMVarIO
-		runClientApp $ clientApp (InitMode mempty) $ \ichan ochan sid -> do
+		runClientApp $ clientApp (InitMode mempty) User developerMessages $ \ichan ochan sid -> do
 			let url = sessionIDUrl sid "localhost" 8081
 			putStrLn ""
 			putStrLn "Others can connect to this session and help you debug by running:"
@@ -47,6 +47,10 @@ run os = do
 		sessionDone
 		fromMaybe (ExitFailure 101) <$> atomically (tryReadTMVar esv)
 
+developerMessages :: LogMessage -> Maybe (Message Entered)
+developerMessages (Developer m) = Just m
+developerMessages (User _) = Nothing
+
 shellCommand :: UserOpts -> IO (String, [String])
 shellCommand os = case cmdToRun os of
 	Just v -> return v
diff --git a/Role/Watcher.hs b/Role/Watcher.hs
index fddd59f..620733c 100644
--- a/Role/Watcher.hs
+++ b/Role/Watcher.hs
@@ -4,15 +4,13 @@ import Types
 import Log
 import Pty
 import CmdLine
-import WebSockets
 import SessionID
 
 import Control.Concurrent.STM
-import qualified Data.Text as T
-import Role.Developer (processSessionStart, getUserMessage, emitOutput)
+import Role.Developer (run', processSessionStart, getUserMessage, emitOutput)
 
 run :: WatchOpts -> IO ()
-run os = runClientApp $ clientApp (ConnectMode (T.pack (watchUrl os))) watcher
+run = run' watcher . watchUrl
 
 watcher :: TChan (Message Entered) -> TChan (Message Seen) -> SessionID -> IO ()
 watcher _ichan ochan _ = inRawMode $ do