blob: edd493ef86dc094636452ff8a35b4e1d207990e7 (
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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
{-# LANGUAGE OverloadedStrings #-}
-- | debug-me session control window
module ControlWindow where
import Types
import CmdLine
import ControlSocket
import VirtualTerminal
import Gpg
import Gpg.Wot
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, toString)
import Data.Char
import Control.Monad
import Data.Monoid
import Prelude
winDesc :: String
winDesc = "debug-me session control and chat window"
displayInControlWindow :: TMChan ControlInput -> String -> IO ()
displayInControlWindow ichan msg = atomically $
writeTMChan ichan (ControlWindowMessage msg)
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 ochan 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 = B.ByteString
type PromptChan = TChan Prompt
type ResponseChan = TChan Response
collectOutput :: TMChan ControlOutput -> PromptChan -> ResponseChan -> IO ()
collectOutput ochan promptchan responsechan = do
myusername <- fromString <$> getLoginName
withLines stdin $ mapM_ $ processline myusername
where
processline myusername l = atomically $ do
-- Is any particular input being prompted for now?
mp <- tryReadTChan promptchan
case mp of
Just _ -> writeTChan responsechan $ L.toStrict l
Nothing -> writeTMChan ochan $ ControlOutputAction $
ChatMessage (Val myusername) (Val $ L.toStrict l)
displayInput :: TMChan ControlOutput -> TMChan ControlInput -> PromptChan -> ResponseChan -> IO ()
displayInput ochan ichan promptchan responsechan = loop
where
loop = go =<< atomically (readTMChan ichan)
go Nothing = return ()
go (Just (ControlWindowMessage m)) = do
putStrLn m
loop
go (Just (ControlInputAction (SessionKey k))) = do
askToAllow ochan promptchan responsechan k
loop
go (Just (ControlInputAction (ChatMessage username msg))) = do
B.putStr $ "<" <> val username <> "> " <> val msg
putStr "\n"
hFlush stdout
loop
go _ = loop
askToAllow :: TMChan ControlOutput -> PromptChan -> ResponseChan -> PerhapsSigned PublicKey -> IO ()
askToAllow ochan _ _ (UnSigned pk) = atomically $ writeTMChan ochan $
ControlOutputAction $ SessionKeyRejected pk
askToAllow ochan promptchan responsechan k@(GpgSigned pk _) = do
putStrLn "Someone wants to connect to this debug-me session."
putStrLn "Checking their Gnupg signature ..."
v <- gpgVerify [] k
let reject = do
putStrLn "Rejecting their connection."
atomically $ writeTMChan ochan $
ControlOutputAction $ SessionKeyRejected pk
let accept = do
putStrLn "Accepting their connection. They can now enter commands in this debug-me session."
atomically $ writeTMChan ochan $
ControlOutputAction $ SessionKeyAccepted pk
case v of
Nothing -> do
putStrLn "Unable to download their Gnupg key, or signature verification failed."
reject
Just gpgkeyid -> do
putStrLn "Checking the Gnupg web of trust ..."
ss <- isInStrongSet gpgkeyid
ws <- downloadWotStats gpgkeyid
putStrLn $ describeWot ws ss
ok <- promptconnect
if ok
then accept
else reject
where
promptconnect = do
atomically $ writeTChan promptchan ()
putStr "Let them connect to the debug-me session and run commands? [y/n] "
hFlush stdout
r <- atomically $ readTChan responsechan
case map toLower (toString r) of
"y" -> return True
"yes" -> return True
"n" -> return False
"no" -> return False
_ -> promptconnect
|
