{- 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

-- | Get a name for the debug-me user. When possible this will be the
-- actual username, but failing that, anything reasonable will do,
-- since it's only ever displayed to the person they are communicating
-- with.
getUserName :: IO String
getUserName = do
	loginname <- try getLoginName :: IO (Either SomeException String)
	case loginname of
		Right n -> return n
		Left _ -> return "user"

collectOutput :: TMChan ControlOutput -> PromptChan -> ResponseChan -> IO ()
collectOutput ochan promptchan responsechan = do
	myusername <- fromString <$> getUserName
	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