blob: cc63cef88e552f48742140b6109c555ca1558ac7 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
{-# LANGUAGE OverloadedStrings #-}
-- | debug-me session control window
module ControlWindow where
import Types
import CmdLine
import ControlSocket
import VirtualTerminal
import System.IO
import System.Environment
import System.Process
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 Control.Monad
import Data.Monoid
import Prelude
winDesc :: String
winDesc = "debug-me session control and chat window"
controlWindow :: ControlOpts -> IO ()
controlWindow _ = do
putStrLn $ "** " ++ winDesc
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
myexe <- getExecutablePath
mproc <- runInVirtualTerminal winDesc myexe ["--control"]
case mproc of
Nothing -> putStrLn "You need to open another shell prompt, and run: debug-me --control"
Just p -> void $ createProcess p
-- Wait for message from control process.
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)
|
