blob: 186d359c4d6c619f56a37fe6ff54b4a614fa8e8e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
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')
|
