diff options
| -rw-r--r-- | Control.hs | 74 |
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) |