{-# LANGUAGE OverloadedStrings #-}

-- | debug-me session control window

module Control where

import Types
import CmdLine
import ControlSocket

import System.IO
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)
import Data.Monoid
import Prelude

control :: ControlOpts -> IO ()
control _ = do
	putStrLn "** debug-me session control and chat window"
	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 ichan promptchan responsechan
		`race` collectOutput ochan promptchan responsechan
	return ()

type Prompt = ()
type Response = L.ByteString

type PromptChan = TChan Prompt
type ResponseChan = TChan Response

displayInput :: TMChan ControlInput -> PromptChan -> ResponseChan -> IO ()
displayInput ichan promptchan responsechan = loop
  where
	loop = go =<< atomically (readTMChan ichan)
	go Nothing = return ()
	go (Just (ControlInputAction (SessionKey (GpgSigned _ devgpgsig)))) = do
		error "TODO verify developer key"
	go (Just (ControlInputAction (ChatMessage username msg))) = do
		B.putStr $ "<" <> val username <> "> " <> val msg
		putStr "\n"
		hFlush stdout
		loop
	go v = do
		print v
		loop

collectOutput :: TMChan ControlOutput -> PromptChan -> ResponseChan -> IO ()
collectOutput ochan promptchan responsechan = do
	myusername <- fromString <$> getLoginName
	withLines stdin $ mapM_ $ processline myusername
  where
	processline myusername l
		| "/" `L.isPrefixOf` l = atomically $ do
			-- Is any particular input being prompted for now?
			mp <- tryReadTChan promptchan
			case mp of
				Nothing -> return ()
				Just _ -> writeTChan responsechan (L.drop 1 l)
		| otherwise = atomically $
			writeTMChan ochan $ ControlOutputAction $
				ChatMessage (Val myusername) (Val $ L.toStrict l)