diff options
Diffstat (limited to 'ControlSocket.hs')
-rw-r--r-- | ControlSocket.hs | 141 |
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') |