From 85914371f31952b30b062624feec35706382af95 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 28 Apr 2017 17:50:20 -0400 Subject: reorg --- CmdLine.hs | 2 +- Control.hs | 74 ------------------------------------------- ControlSocket.hs | 20 ++---------- ControlWindow.hs | 93 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ Role/Developer.hs | 1 + Role/User.hs | 1 + debug-me.cabal | 2 +- debug-me.hs | 4 +-- 8 files changed, 102 insertions(+), 95 deletions(-) delete mode 100644 Control.hs create mode 100644 ControlWindow.hs diff --git a/CmdLine.hs b/CmdLine.hs index 42c28ee..40437b8 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -52,7 +52,7 @@ data ServerOpts = ServerOpts } data ControlOpts = ControlOpts - { controlWindow :: Bool + { controlWindowEnabled :: Bool } parseCmdLine :: Parser CmdLine diff --git a/Control.hs b/Control.hs deleted file mode 100644 index 55cfc07..0000000 --- a/Control.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# 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) diff --git a/ControlSocket.hs b/ControlSocket.hs index 8aa68cd..6512f4b 100644 --- a/ControlSocket.hs +++ b/ControlSocket.hs @@ -36,29 +36,15 @@ instance FromJSON ControlOutput defaultSocketFile :: IO FilePath defaultSocketFile = ( "control") <$> dotDir --- | 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 +bindSocket :: FilePath -> IO S.Socket +bindSocket socketfile = do -- Delete any existing socket file. _ <- try (removeLink socketfile) :: IO (Either IOException ()) soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol S.bind soc (S.SockAddrUnix socketfile) setFileMode socketfile (unionFileModes ownerWriteMode ownerReadMode) S.listen soc 2 - 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) + return soc -- | Serve connections to the control socket, feeding data between it and -- the TMChans. 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) diff --git a/Role/Developer.hs b/Role/Developer.hs index 448e04e..c48c131 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -20,6 +20,7 @@ import SessionID import Pty import PrevActivity import ControlSocket +import ControlWindow import Control.Concurrent.Async import Control.Concurrent.STM diff --git a/Role/User.hs b/Role/User.hs index 24d85c3..d1e4975 100644 --- a/Role/User.hs +++ b/Role/User.hs @@ -13,6 +13,7 @@ import WebSockets import SessionID import PrevActivity import ControlSocket +import ControlWindow import Control.Concurrent.Async import Control.Concurrent.STM diff --git a/debug-me.cabal b/debug-me.cabal index 7d8cbd7..4ca97d5 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -75,7 +75,7 @@ Executable debug-me , cereal (>= 0.5) , utf8-string (>= 1.0) Other-Modules: - Control + ControlWindow ControlSocket CmdLine Crypto diff --git a/debug-me.hs b/debug-me.hs index 98d2d27..dc40fc3 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -4,7 +4,7 @@ import CmdLine import Graphviz import Replay import Server -import Control +import ControlWindow import qualified Role.User import qualified Role.Developer import qualified Role.Downloader @@ -24,4 +24,4 @@ main = withSocketsDo $ do GraphvizMode o -> graphviz o ReplayMode o -> replay o ServerMode o -> server o - ControlMode o -> control o + ControlMode o -> controlWindow o -- cgit v1.2.3