{- Copyright 2017 Joey Hess - - 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 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 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