reorg

1 files changed, 93 insertions, 0 deletions

diff --git a/ControlWindow.hs b/ControlWindow.hs
new file mode 100644
index 0000000..c22092f
--- /dev/null
+++ b/ControlWindow.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | debug-me session control window
+
+module ControlWindow 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
+
+controlWindow :: ControlOpts -> IO ()
+controlWindow _ = 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 ()
+
+-- | Opens the control window, or if that can't be done, tells the user
+-- to run debug-me --control.
+--
+-- Returns once either of the TMChans is closed.
+openControlWindow :: IO (TMChan ControlInput, TMChan ControlOutput)
+openControlWindow = do
+	socketfile <- defaultSocketFile
+	soc <- bindSocket socketfile
+	ichan <- newTMChanIO
+	ochan <- newTMChanIO
+	_ <- async $ serveControlSocket soc ichan ochan
+	-- Wait for message from control process.
+	putStrLn "You need to open another shell prompt, and run: debug-me --control"
+	v <- atomically $ readTMChan ochan
+	case v of
+		Just ControlWindowOpened -> return ()
+		_ -> error "unexpected message from control process"
+	return (ichan, ochan)
+
+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)