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