never executed always true always false
1 module PureClaw.Tools.Process
2 ( -- * Tool registration
3 processTool
4 ) where
5
6 import Data.Aeson
7 import Data.Aeson.Types
8 import Data.ByteString.Char8 qualified as BS8
9 import Data.Text (Text)
10 import Data.Text qualified as T
11 import System.Exit
12
13 import PureClaw.Handles.Process
14 import PureClaw.Providers.Class
15 import PureClaw.Security.Command
16 import PureClaw.Security.Policy
17 import PureClaw.Tools.Registry
18
19 -- | Create a process tool for background command management.
20 -- Supports: spawn, list, poll, kill, write_stdin.
21 processTool :: SecurityPolicy -> ProcessHandle -> (ToolDefinition, ToolHandler)
22 processTool policy ph = (def, handler)
23 where
24 def = ToolDefinition
25 { _td_name = "process"
26 , _td_description = "Manage background processes. Actions: spawn (start a background command), list (show all), poll (check status and output), kill (terminate), write_stdin (send input)."
27 , _td_inputSchema = object
28 [ "type" .= ("object" :: Text)
29 , "properties" .= object
30 [ "action" .= object
31 [ "type" .= ("string" :: Text)
32 , "enum" .= (["spawn", "list", "poll", "kill", "write_stdin"] :: [Text])
33 , "description" .= ("The action to perform" :: Text)
34 ]
35 , "command" .= object
36 [ "type" .= ("string" :: Text)
37 , "description" .= ("The command to run (for spawn)" :: Text)
38 ]
39 , "id" .= object
40 [ "type" .= ("integer" :: Text)
41 , "description" .= ("Process ID (for poll, kill, write_stdin)" :: Text)
42 ]
43 , "input" .= object
44 [ "type" .= ("string" :: Text)
45 , "description" .= ("Input to send to stdin (for write_stdin)" :: Text)
46 ]
47 ]
48 , "required" .= (["action"] :: [Text])
49 ]
50 }
51
52 handler = ToolHandler $ \input ->
53 case parseEither parseAction input of
54 Left err -> pure (T.pack err, True)
55 Right action -> dispatch action input
56
57 dispatch :: Text -> Value -> IO (Text, Bool)
58 dispatch "spawn" input =
59 case parseEither parseSpawn input of
60 Left err -> pure (T.pack err, True)
61 Right cmd -> doSpawn cmd
62 dispatch "list" _ = doList
63 dispatch "poll" input =
64 case parseEither parseId input of
65 Left err -> pure (T.pack err, True)
66 Right pid -> doPoll pid
67 dispatch "kill" input =
68 case parseEither parseId input of
69 Left err -> pure (T.pack err, True)
70 Right pid -> doKill pid
71 dispatch "write_stdin" input =
72 case parseEither parseWriteStdin input of
73 Left err -> pure (T.pack err, True)
74 Right (pid, bytes) -> doWriteStdin pid bytes
75 dispatch action _ = pure ("Unknown action: " <> action, True)
76
77 doSpawn :: Text -> IO (Text, Bool)
78 doSpawn cmd = do
79 let parts = T.words cmd
80 case parts of
81 [] -> pure ("Empty command", True)
82 (prog:args) ->
83 case authorize policy (T.unpack prog) args of
84 Left (CommandNotAllowed c) ->
85 pure ("Command not allowed: " <> c, True)
86 Left CommandInAutonomyDeny ->
87 pure ("All commands denied by security policy", True)
88 Right authorized -> do
89 pid <- _ph_spawn ph authorized
90 pure ("Started process " <> T.pack (show (unProcessId pid)), False)
91
92 doList :: IO (Text, Bool)
93 doList = do
94 procs <- _ph_list ph
95 if null procs
96 then pure ("No background processes", False)
97 else pure (formatList procs, False)
98
99 doPoll :: Int -> IO (Text, Bool)
100 doPoll pid = do
101 status <- _ph_poll ph (ProcessId pid)
102 case status of
103 Nothing -> pure ("Process " <> T.pack (show pid) <> " not found", True)
104 Just (ProcessRunning stdout stderr) ->
105 let out = T.pack (BS8.unpack stdout)
106 err = T.pack (BS8.unpack stderr)
107 in pure ("Status: running\n" <> formatOutput out err, False)
108 Just (ProcessDone exitCode stdout stderr) ->
109 let out = T.pack (BS8.unpack stdout)
110 err = T.pack (BS8.unpack stderr)
111 exitInfo = case exitCode of
112 ExitSuccess -> "0"
113 ExitFailure n -> T.pack (show n)
114 in pure ("Status: done (exit " <> exitInfo <> ")\n" <> formatOutput out err, False)
115
116 doKill :: Int -> IO (Text, Bool)
117 doKill pid = do
118 ok <- _ph_kill ph (ProcessId pid)
119 if ok
120 then pure ("Killed process " <> T.pack (show pid), False)
121 else pure ("Process " <> T.pack (show pid) <> " not found", True)
122
123 doWriteStdin :: Int -> Text -> IO (Text, Bool)
124 doWriteStdin pid input = do
125 ok <- _ph_writeStdin ph (ProcessId pid) (BS8.pack (T.unpack input))
126 if ok
127 then pure ("Sent input to process " <> T.pack (show pid), False)
128 else pure ("Process " <> T.pack (show pid) <> " not found or not running", True)
129
130 formatList :: [ProcessInfo] -> Text
131 formatList = T.intercalate "\n" . map formatInfo
132
133 formatInfo :: ProcessInfo -> Text
134 formatInfo pi' =
135 let status = if _pi_running pi'
136 then "running"
137 else case _pi_exitCode pi' of
138 Just ExitSuccess -> "done (exit 0)"
139 Just (ExitFailure n) -> "done (exit " <> T.pack (show n) <> ")"
140 Nothing -> "unknown"
141 in "[" <> T.pack (show (unProcessId (_pi_id pi'))) <> "] "
142 <> _pi_command pi' <> " — " <> status
143
144 formatOutput :: Text -> Text -> Text
145 formatOutput out err =
146 let parts = filter (not . T.null)
147 [ if T.null out then "" else "stdout:\n" <> out
148 , if T.null err then "" else "stderr:\n" <> err
149 ]
150 in if null parts then "(no output)" else T.intercalate "\n" parts
151
152 parseAction :: Value -> Parser Text
153 parseAction = withObject "ProcessInput" $ \o -> o .: "action"
154
155 parseSpawn :: Value -> Parser Text
156 parseSpawn = withObject "ProcessSpawnInput" $ \o -> o .: "command"
157
158 parseId :: Value -> Parser Int
159 parseId = withObject "ProcessIdInput" $ \o -> o .: "id"
160
161 parseWriteStdin :: Value -> Parser (Int, Text)
162 parseWriteStdin = withObject "ProcessWriteStdinInput" $ \o ->
163 (,) <$> o .: "id" <*> o .: "input"