forgot to add earlier

1 files changed, 74 insertions, 0 deletions

diff --git a/Control.hs b/Control.hs
new file mode 100644
index 0000000..55cfc07
--- /dev/null
+++ b/Control.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | debug-me session control window
+
+module Control where
+
+import Types
+import CmdLine
+import ControlSocket
+
+import System.IO
+import System.Posix
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TMChan
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import Data.ByteString.UTF8 (fromString)
+import Data.Monoid
+import Prelude
+
+control :: ControlOpts -> IO ()
+control _ = do
+	putStrLn "** debug-me session control and chat window"
+	socketfile <- defaultSocketFile
+	ichan <- newTMChanIO
+	ochan <- newTMChanIO
+	promptchan <- newTChanIO
+	responsechan <- newTChanIO
+	-- Let the debug-me that's being controlled know that the control
+	-- window is open.
+	atomically $ writeTMChan ochan ControlWindowOpened
+	_ <- connectControlSocket socketfile ichan ochan
+		`race` displayInput ichan promptchan responsechan
+		`race` collectOutput ochan promptchan responsechan
+	return ()
+
+type Prompt = ()
+type Response = L.ByteString
+
+type PromptChan = TChan Prompt
+type ResponseChan = TChan Response
+
+displayInput :: TMChan ControlInput -> PromptChan -> ResponseChan -> IO ()
+displayInput ichan promptchan responsechan = loop
+  where
+	loop = go =<< atomically (readTMChan ichan)
+	go Nothing = return ()
+	go (Just (ControlInputAction (SessionKey (GpgSigned _ devgpgsig)))) = do
+		error "TODO verify developer key"
+	go (Just (ControlInputAction (ChatMessage username msg))) = do
+		B.putStr $ "<" <> val username <> "> " <> val msg
+		putStr "\n"
+		hFlush stdout
+		loop
+	go v = do
+		print v
+		loop
+
+collectOutput :: TMChan ControlOutput -> PromptChan -> ResponseChan -> IO ()
+collectOutput ochan promptchan responsechan = do
+	myusername <- fromString <$> getLoginName
+	withLines stdin $ mapM_ $ processline myusername
+  where
+	processline myusername l
+		| "/" `L.isPrefixOf` l = atomically $ do
+			-- Is any particular input being prompted for now?
+			mp <- tryReadTChan promptchan
+			case mp of
+				Nothing -> return ()
+				Just _ -> writeTChan responsechan (L.drop 1 l)
+		| otherwise = atomically $
+			writeTMChan ochan $ ControlOutputAction $
+				ChatMessage (Val myusername) (Val $ L.toStrict l)