blob: c22092f05922f13c5c3975099972243d853ad9bf (
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
|
{-# 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)
|
