{-# LANGUAGE DeriveGeneric #-}

-- | debug-me session control unix socket

module ControlSocket where

import Types
import DotDir
import JSON

import System.IO
import System.Posix
import System.FilePath
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Concurrent.STM.TMChan
import Control.Exception
import qualified Network.Socket as S
import qualified Data.ByteString.Lazy as L
import Data.Char

data ControlInput
	= ControlInputAction ControlAction
	deriving (Show, Generic)

data ControlOutput
	= ControlOutputAction ControlAction
	| ControlWindowOpened
	deriving (Show, Generic)

instance ToJSON ControlInput
instance FromJSON ControlInput
instance ToJSON ControlOutput
instance FromJSON ControlOutput

defaultSocketFile :: IO FilePath
defaultSocketFile = (</> "control") <$> dotDir

-- | 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
	putStrLn "You need to open another shell prompt, and run: debug-me --control"
	controlsocket <- defaultSocketFile
	ichan <- newTMChanIO
	ochan <- newTMChanIO
	_ <- async $ serveControlSocket controlsocket ichan ochan
	-- 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)

-- | Serve connections to the control socket, feeding data between it and
-- the TMChans.
--
-- Returns once either of the TMChans is closed.
serveControlSocket :: FilePath -> TMChan ControlInput -> TMChan ControlOutput -> IO ()
serveControlSocket socketfile ichan ochan = do
	_ <- bracket setup cleanup serve
		`race` waitclose
	return ()
  where
	setup = do
		-- Delete any existing socket file.
		removeLink socketfile
		soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
		S.bind soc (S.SockAddrUnix socketfile)
		setFileMode socketfile (unionFileModes ownerWriteMode ownerReadMode)
		S.listen soc 2
		return soc
	cleanup = S.close
	serve soc = do
		(sconn, _) <- S.accept soc
		conn <- S.socketToHandle sconn ReadWriteMode
		hSetBinaryMode conn True
		_ <- async $ sendToConn conn ichan
			`race` receiveFromConn conn ochan
		serve soc
	waitclose = atomically $ do
		ic <- isClosedTMChan ichan
		oc <- isClosedTMChan ochan
		if ic || oc
			then return ()
			else retry

-- | Connects to the control socket and feeds data between it and the
-- TMChans.
--
-- Returns when the socket server exits or the TMChan ControlInput is
-- closed.
connectControlSocket :: FilePath -> TMChan ControlInput -> TMChan ControlOutput -> IO ()
connectControlSocket socketfile ichan ochan = bracket setup cleanup connected
  where
	setup = do
		soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
		S.connect soc (S.SockAddrUnix socketfile)
		conn <- S.socketToHandle soc ReadWriteMode
		hSetBinaryMode conn True
		return conn
	cleanup conn = do
		hClose conn
		atomically $ do
			closeTMChan ichan
			closeTMChan ochan
	connected conn = do
		_ <- sendToConn conn ochan
			`race` receiveFromConn conn ichan
		return ()

sendToConn :: ToJSON a => Handle -> TMChan a -> IO ()
sendToConn conn chan = go =<< atomically (readTMChan chan)
  where
	go Nothing = return ()
	go (Just v) = do
		L.hPut conn (encode v)
		hPutStr conn "\n"
		hFlush conn
		sendToConn conn chan

receiveFromConn :: FromJSON a => Handle -> TMChan a -> IO ()
receiveFromConn conn chan = withLines conn go
  where
	go [] = return ()
	go (l:ls)
		| L.null l = go ls
		| otherwise = case decode l of
			Nothing -> error "internal control message parse error"
			Just v -> do
				atomically $ writeTMChan chan v
				go ls

withLines :: Handle -> ([L.ByteString] -> IO a) -> IO a
withLines conn a = do
	ls <- L.split nl <$> L.hGetContents conn
	a ls
  where
	nl = fromIntegral (ord '\n')