never executed always true always false
1 module PureClaw.Handles.Process
2 ( -- * Types
3 ProcessId (..)
4 , ProcessInfo (..)
5 , ProcessStatus (..)
6 -- * Handle type
7 , ProcessHandle (..)
8 -- * Implementations
9 , mkProcessHandle
10 , mkNoOpProcessHandle
11 ) where
12
13 import Control.Concurrent.Async qualified as Async
14 import Control.Exception
15 import Data.ByteString (ByteString)
16 import Data.ByteString qualified as BS
17 import Data.IORef
18 import Data.Map.Strict (Map)
19 import Data.Map.Strict qualified as Map
20 import Data.Text (Text)
21 import Data.Text qualified as T
22 import System.Exit
23 import System.IO (Handle, hFlush)
24 import System.Process.Typed qualified as P
25
26 import PureClaw.Handles.Log
27 import PureClaw.Security.Command
28
29 -- | Identifier for a background process.
30 newtype ProcessId = ProcessId { unProcessId :: Int }
31 deriving stock (Show, Eq, Ord)
32
33 -- | Lightweight process info for listing.
34 data ProcessInfo = ProcessInfo
35 { _pi_id :: ProcessId
36 , _pi_command :: Text
37 , _pi_running :: Bool
38 , _pi_exitCode :: Maybe ExitCode
39 }
40 deriving stock (Show, Eq)
41
42 -- | Full process status with output, returned by poll.
43 data ProcessStatus
44 = ProcessRunning ByteString ByteString -- ^ partial stdout, stderr
45 | ProcessDone ExitCode ByteString ByteString -- ^ exit code, final stdout, stderr
46 deriving stock (Show, Eq)
47
48 -- | Background process management capability.
49 data ProcessHandle = ProcessHandle
50 { _ph_spawn :: AuthorizedCommand -> IO ProcessId
51 , _ph_list :: IO [ProcessInfo]
52 , _ph_poll :: ProcessId -> IO (Maybe ProcessStatus)
53 , _ph_kill :: ProcessId -> IO Bool
54 , _ph_writeStdin :: ProcessId -> ByteString -> IO Bool
55 }
56
57 -- Internal entry tracking a background process.
58 data ProcessEntry = ProcessEntry
59 { _pe_command :: Text
60 , _pe_stdinH :: Handle
61 , _pe_stdoutRef :: IORef ByteString
62 , _pe_stderrRef :: IORef ByteString
63 , _pe_exitAsync :: Async.Async ExitCode
64 , _pe_cleanup :: IO ()
65 }
66
67 data ProcessState = ProcessState
68 { _pst_nextId :: !Int
69 , _pst_processes :: Map Int ProcessEntry
70 }
71
72 -- | Minimal safe environment for subprocesses.
73 safeEnv :: [(String, String)]
74 safeEnv = [("PATH", "/usr/bin:/bin:/usr/local/bin")]
75
76 -- | Real process handle using typed-process and async.
77 mkProcessHandle :: LogHandle -> IO ProcessHandle
78 mkProcessHandle logger = do
79 stateRef <- newIORef ProcessState { _pst_nextId = 1, _pst_processes = Map.empty }
80 pure ProcessHandle
81 { _ph_spawn = \cmd -> do
82 let prog = getCommandProgram cmd
83 args = map T.unpack (getCommandArgs cmd)
84 cmdText = T.pack prog <> " " <> T.unwords (getCommandArgs cmd)
85 config = P.setStdin P.createPipe
86 $ P.setStdout P.createPipe
87 $ P.setStderr P.createPipe
88 $ P.setEnv safeEnv
89 $ P.proc prog args
90 _lh_logInfo logger $ "Spawning background: " <> cmdText
91 proc <- P.startProcess config
92 let stdinH = P.getStdin proc
93 stdoutH = P.getStdout proc
94 stderrH = P.getStderr proc
95 stdoutRef <- newIORef BS.empty
96 stderrRef <- newIORef BS.empty
97 outReader <- Async.async $ readLoop stdoutH stdoutRef
98 errReader <- Async.async $ readLoop stderrH stderrRef
99 exitAsync <- Async.async $ P.waitExitCode proc
100 let cleanup = do
101 Async.cancel outReader
102 Async.cancel errReader
103 Async.cancel exitAsync
104 _ <- try @SomeException (P.stopProcess proc)
105 pure ()
106 let entry = ProcessEntry
107 { _pe_command = cmdText
108 , _pe_stdinH = stdinH
109 , _pe_stdoutRef = stdoutRef
110 , _pe_stderrRef = stderrRef
111 , _pe_exitAsync = exitAsync
112 , _pe_cleanup = cleanup
113 }
114 pid <- atomicModifyIORef' stateRef $ \st ->
115 let pid = _pst_nextId st
116 st' = st { _pst_nextId = pid + 1
117 , _pst_processes = Map.insert pid entry (_pst_processes st)
118 }
119 in (st', pid)
120 pure (ProcessId pid)
121
122 , _ph_list = do
123 st <- readIORef stateRef
124 mapM toProcessInfo (Map.toList (_pst_processes st))
125
126 , _ph_poll = \(ProcessId pid) -> do
127 st <- readIORef stateRef
128 case Map.lookup pid (_pst_processes st) of
129 Nothing -> pure Nothing
130 Just entry -> do
131 status <- getStatus entry
132 pure (Just status)
133
134 , _ph_kill = \(ProcessId pid) -> do
135 st <- readIORef stateRef
136 case Map.lookup pid (_pst_processes st) of
137 Nothing -> pure False
138 Just entry -> do
139 _pe_cleanup entry
140 atomicModifyIORef' stateRef $ \s ->
141 (s { _pst_processes = Map.delete pid (_pst_processes s) }, ())
142 _lh_logInfo logger $ "Killed process " <> T.pack (show pid)
143 pure True
144
145 , _ph_writeStdin = \(ProcessId pid) bytes -> do
146 st <- readIORef stateRef
147 case Map.lookup pid (_pst_processes st) of
148 Nothing -> pure False
149 Just entry -> do
150 result <- try @SomeException $ do
151 BS.hPut (_pe_stdinH entry) bytes
152 hFlush (_pe_stdinH entry)
153 case result of
154 Left _ -> pure False
155 Right () -> pure True
156 }
157
158 -- | Read from a handle in a loop, appending to an IORef.
159 readLoop :: Handle -> IORef ByteString -> IO ()
160 readLoop h ref = go
161 where
162 go = do
163 chunk <- try @SomeException (BS.hGetSome h 4096)
164 case chunk of
165 Left _ -> pure ()
166 Right bs
167 | BS.null bs -> pure ()
168 | otherwise -> do
169 atomicModifyIORef' ref $ \old -> (old <> bs, ())
170 go
171
172 -- | Get current status of a process entry.
173 getStatus :: ProcessEntry -> IO ProcessStatus
174 getStatus entry = do
175 result <- Async.poll (_pe_exitAsync entry)
176 stdout <- readIORef (_pe_stdoutRef entry)
177 stderr <- readIORef (_pe_stderrRef entry)
178 case result of
179 Nothing -> pure (ProcessRunning stdout stderr)
180 Just (Right ec) -> pure (ProcessDone ec stdout stderr)
181 Just (Left _) -> pure (ProcessDone (ExitFailure (-1)) stdout stderr)
182
183 -- | Build a ProcessInfo from a map entry.
184 toProcessInfo :: (Int, ProcessEntry) -> IO ProcessInfo
185 toProcessInfo (pid, entry) = do
186 result <- Async.poll (_pe_exitAsync entry)
187 let running = case result of
188 Nothing -> True
189 Just _ -> False
190 exitCode = case result of
191 Just (Right ec) -> Just ec
192 _ -> Nothing
193 pure ProcessInfo
194 { _pi_id = ProcessId pid
195 , _pi_command = _pe_command entry
196 , _pi_running = running
197 , _pi_exitCode = exitCode
198 }
199
200 -- | No-op process handle for testing.
201 mkNoOpProcessHandle :: ProcessHandle
202 mkNoOpProcessHandle = ProcessHandle
203 { _ph_spawn = \_ -> pure (ProcessId 1)
204 , _ph_list = pure []
205 , _ph_poll = \_ -> pure (Just (ProcessDone ExitSuccess "" ""))
206 , _ph_kill = \_ -> pure True
207 , _ph_writeStdin = \_ _ -> pure True
208 }