summaryrefslogtreecommitdiffhomepage
path: root/ControlWindow.hs
blob: bd79d0f55a186d4bb1ce1a21cd30ebff55c2dc18 (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
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
{- Copyright 2017 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE OverloadedStrings #-}

-- | debug-me session control window

module ControlWindow where

import Types
import CmdLine
import ControlSocket
import VirtualTerminal
import Gpg
import Gpg.Wot
import Gpg.Keyring
import Output

import System.IO
import System.Environment
import System.Process
import System.Posix
import Control.Exception
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Concurrent.STM.TMChan
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
	putStrLn "(Enter /quit here at any time to end the debug-me session.)"
	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
	putStrLn $ "** " ++ winDesc ++ " closing; debug-me session is done"
	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 <- getMyExe
	mproc <- runInVirtualTerminal winDesc myexe ["--control"]
	let cannotrun = do
		putStrLn "You need to open another shell prompt, and run: debug-me --control"
		return (ichan, ochan)
	case mproc of
		Nothing -> cannotrun
		Just p -> do
			(_, _, _, pid) <- createProcess p
			-- Wait for message from control process.
			v <- atomically (readTMChan ochan)
				`race` waitForProcess pid
			case v of
				Left (Just ControlWindowOpened) -> return (ichan, ochan)
				Left _ -> error "unexpected message from control process"
				Right _ -> cannotrun
	

-- | Get path to debug-me program.
--
-- The standalone bundle sets DEBUG_ME_EXE to the path to use.
getMyExe :: IO FilePath
getMyExe = maybe getExecutablePath return =<< lookupEnv "DEBUG_ME_EXE"

type Prompt = ()
type Response = String

type PromptChan = TChan Prompt
type ResponseChan = TChan Response

collectOutput :: TMChan ControlOutput -> PromptChan -> ResponseChan -> IO ()
collectOutput ochan promptchan responsechan = do
	myusername <- fromString <$> getLoginName
	loop myusername
  where
	loop myusername = do
		l <- getLine
		if map toLower l == "/quit"
			then atomically $
				writeTMChan ochan ControlWindowRequestedImmediateQuit
			else do
				mc <- atomically $ do
					-- Is any particular input being prompted for now?
					mp <- tryReadTChan promptchan
					case mp of
						Just _ -> do
							writeTChan responsechan l
							return Nothing
						Nothing -> do
							let c = ChatMessage (Val myusername) (Val $ fromString l)
							writeTMChan ochan $ ControlOutputAction c
							return (Just c)
				maybe (return ()) displayChatMessage mc
				loop myusername

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 m@(ChatMessage {}))) = do
		displayChatMessage m
		loop
	go _ = loop

displayChatMessage :: ControlAction -> IO ()
displayChatMessage (ChatMessage username msg) = do
	putStrLn $ sanitizeForDisplay $ toString $
		"<" <> val username <> "> " <> val msg
	hFlush stdout
displayChatMessage _ = return ()

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, gpgoutput) <- gpgVerify k
	putStr $ unlines $ map sanitizeForDisplay $ lines $ toString gpgoutput
	case v of
		Nothing -> do
			putStrLn "Unable to download their GnuPG key, or signature verification failed."
			reject
		Just gpgkeyid -> flip catch woterror $ do
			putStrLn "Checking the GnuPG web of trust ..."
			ss <- isInStrongSet gpgkeyid
			ws <- downloadWotStats gpgkeyid
			putStrLn $ unlines $ map sanitizeForDisplay $
				describeWot ws ss
			mapM_ (putStrLn . keyringToDeveloperDesc ws)
				=<< findKeyringsContaining gpgkeyid
			promptconnect
  where
	promptconnect :: IO ()
	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 r of
			"y" -> accept
			"yes" -> accept
			"n" -> reject
			"no" -> reject
			_ -> promptconnect
	reject = do
		putStrLn "Rejecting their connection."
		atomically $ writeTMChan ochan $
			ControlOutputAction $ SessionKeyRejected pk
	accept = do
		putStrLn "Connection accepted. They can now enter commands in this debug-me session."
		putStrLn "(And, you can type in this window to chat with them.)"
		atomically $ writeTMChan ochan $
			ControlOutputAction $ SessionKeyAccepted pk
	woterror :: SomeException -> IO ()
	woterror e = do
		putStrLn (show e)
		putStrLn "Web of trust check failed!"
		putStrLn ""
		putStrLn "Their identity cannot be verified!"
		promptconnect