control window and chatting

Works!

1 files changed, 141 insertions, 0 deletions

diff --git a/ControlSocket.hs b/ControlSocket.hs
new file mode 100644
index 0000000..186d359
--- /dev/null
+++ b/ControlSocket.hs
@@ -0,0 +1,141 @@
+{-# 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')