{-# 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
	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 <- 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 = do
		mc <- atomically $ do
			-- Is any particular input being prompted for now?
			mp <- tryReadTChan promptchan
			case mp of
				Just _ -> do
					writeTChan responsechan $ L.toStrict l
					return Nothing
				Nothing -> do
					let c = ChatMessage (Val myusername) (Val $ L.toStrict l)
					writeTMChan ochan $ ControlOutputAction c
					return (Just c)
		maybe (return ()) displayChatMessage mc

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
	B.putStr $ "<" <> val username <> "> " <> val msg <> "\n"
	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 <- 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."
		putStrLn "(And, you can type in this window to chat with them.)"
		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