never executed always true always false
1 module PureClaw.Channels.Signal
2 ( -- * Signal channel
3 SignalChannel (..)
4 , SignalConfig (..)
5 , mkSignalChannel
6 , withSignalChannel
7 , readerLoop
8 -- * Message parsing
9 , parseSignalEnvelope
10 , SignalEnvelope (..)
11 , SignalDataMessage (..)
12 ) where
13
14 import Control.Concurrent
15 import Control.Concurrent.STM
16 import Control.Exception
17 import Data.Aeson
18 import Data.Aeson.Types (parseEither)
19 import Data.Maybe (fromMaybe)
20 import Data.IORef
21 import Data.Text (Text)
22 import Data.Text qualified as T
23
24 import PureClaw.Channels.Class
25 import PureClaw.Channels.Signal.Transport
26 import PureClaw.Core.Errors
27 import PureClaw.Core.Types
28 import PureClaw.Handles.Channel
29 import PureClaw.Handles.Log
30
31 -- | Configuration for Signal channel.
32 data SignalConfig = SignalConfig
33 { _sc_account :: Text
34 , _sc_textChunkLimit :: Int
35 , _sc_allowFrom :: AllowList UserId
36 }
37 deriving stock (Show, Eq)
38
39 -- | A Signal channel backed by a message queue and a transport.
40 -- The reader thread parses signal-cli output and pushes envelopes to the inbox.
41 -- Send goes through the transport directly.
42 data SignalChannel = SignalChannel
43 { _sch_config :: SignalConfig
44 , _sch_inbox :: TQueue SignalEnvelope
45 , _sch_transport :: SignalTransport
46 , _sch_lastSender :: IORef Text
47 , _sch_log :: LogHandle
48 }
49
50 -- | Create a Signal channel from a config and transport.
51 -- Does NOT start the reader thread — use 'withSignalChannel' for that.
52 mkSignalChannel :: SignalConfig -> SignalTransport -> LogHandle -> IO SignalChannel
53 mkSignalChannel config transport lh = do
54 inbox <- newTQueueIO
55 lastSender <- newIORef (_sc_account config)
56 pure SignalChannel
57 { _sch_config = config
58 , _sch_inbox = inbox
59 , _sch_transport = transport
60 , _sch_lastSender = lastSender
61 , _sch_log = lh
62 }
63
64 -- | Run a Signal channel with full lifecycle management.
65 -- Starts the reader thread, runs the callback, cleans up on exit.
66 withSignalChannel :: SignalConfig -> SignalTransport -> LogHandle -> (ChannelHandle -> IO a) -> IO a
67 withSignalChannel config transport lh action = do
68 sc <- mkSignalChannel config transport lh
69 -- Start the reader thread that pumps signal-cli output into the inbox
70 readerTid <- forkIO (readerLoop sc)
71 let cleanup = do
72 killThread readerTid
73 _st_close transport
74 action (toHandle sc) `finally` cleanup
75
76 -- | Background thread that reads from the transport and pushes
77 -- parsed envelopes into the inbox queue.
78 readerLoop :: SignalChannel -> IO ()
79 readerLoop sc = go
80 where
81 go = do
82 result <- try @SomeException (_st_receive (_sch_transport sc))
83 case result of
84 Left err -> do
85 _lh_logWarn (_sch_log sc) $
86 "signal-cli reader stopped: " <> T.pack (show err)
87 -- Don't restart — let the channel die, agent loop will get IOError
88 Right val -> do
89 case parseSignalEnvelope val of
90 Left err ->
91 _lh_logWarn (_sch_log sc) $ "Ignoring unparseable envelope: " <> T.pack err
92 Right envelope ->
93 case _se_dataMessage envelope of
94 Nothing -> pure () -- Skip non-data envelopes (receipts, typing, etc.)
95 Just _ ->
96 let policy = _sc_allowFrom (_sch_config sc)
97 -- Check both phone number and UUID against the allow list
98 sourceAllowed = isAllowed policy (UserId (_se_source envelope))
99 uuidAllowed = case _se_sourceUuid envelope of
100 Just uuid -> isAllowed policy (UserId uuid)
101 Nothing -> False
102 in if sourceAllowed || uuidAllowed
103 then atomically $ writeTQueue (_sch_inbox sc) envelope
104 else _lh_logWarn (_sch_log sc) $
105 "Blocked message from unauthorized sender: " <> _se_source envelope
106 <> maybe "" (\u -> " (uuid: " <> u <> ")") (_se_sourceUuid envelope)
107 go
108
109 instance Channel SignalChannel where
110 toHandle sc = ChannelHandle
111 { _ch_receive = receiveEnvelope sc
112 , _ch_send = sendSignalMessage sc
113 , _ch_sendError = sendSignalError sc
114 , _ch_sendChunk = \_ -> pure () -- Signal doesn't support streaming
115 , _ch_streaming = False
116 , _ch_readSecret = ioError (userError "Vault management requires the CLI interface")
117 , _ch_prompt = \promptText -> do
118 sendSignalMessage sc (OutgoingMessage promptText)
119 _im_content <$> receiveEnvelope sc
120 , _ch_promptSecret = \_ ->
121 ioError (userError "Vault management requires the CLI interface")
122 }
123
124 -- | Block until a Signal envelope arrives in the queue.
125 receiveEnvelope :: SignalChannel -> IO IncomingMessage
126 receiveEnvelope sc = do
127 envelope <- atomically $ readTQueue (_sch_inbox sc)
128 let sender = _se_source envelope
129 content = maybe "" _sdm_message (_se_dataMessage envelope)
130 writeIORef (_sch_lastSender sc) sender
131 pure IncomingMessage
132 { _im_userId = UserId sender
133 , _im_content = content
134 }
135
136 -- | Send a message via Signal, chunking if necessary.
137 sendSignalMessage :: SignalChannel -> OutgoingMessage -> IO ()
138 sendSignalMessage sc msg = do
139 recipient <- readIORef (_sch_lastSender sc)
140 let limit = _sc_textChunkLimit (_sch_config sc)
141 chunks = chunkMessage limit (_om_content msg)
142 mapM_ (_st_send (_sch_transport sc) recipient) chunks
143
144 -- | Send an error via Signal.
145 sendSignalError :: SignalChannel -> PublicError -> IO ()
146 sendSignalError sc err = do
147 recipient <- readIORef (_sch_lastSender sc)
148 _st_send (_sch_transport sc) recipient ("Error: " <> T.pack (show err))
149
150 -- | A Signal envelope (simplified JSON-RPC format from signal-cli).
151 data SignalEnvelope = SignalEnvelope
152 { _se_source :: Text -- ^ Phone number or UUID (best available)
153 , _se_sourceUuid :: Maybe Text -- ^ UUID if available
154 , _se_timestamp :: Maybe Int -- ^ Not all envelope types have a timestamp
155 , _se_dataMessage :: Maybe SignalDataMessage
156 }
157 deriving stock (Show, Eq)
158
159 -- | A Signal data message.
160 data SignalDataMessage = SignalDataMessage
161 { _sdm_message :: Text
162 , _sdm_timestamp :: Int
163 }
164 deriving stock (Show, Eq)
165
166 instance FromJSON SignalEnvelope where
167 parseJSON = withObject "SignalEnvelope" $ \o -> do
168 mSourceNumber <- o .:? "sourceNumber"
169 mSourceUuid <- o .:? "sourceUuid"
170 mSource <- o .:? "source"
171 -- Prefer phone number as primary identifier, fall back to UUID, then "source"
172 let source = case mSourceNumber of
173 Just s -> s
174 Nothing -> case mSource of
175 Just s -> s
176 Nothing -> fromMaybe "" mSourceUuid
177 SignalEnvelope source mSourceUuid <$> o .:? "timestamp" <*> o .:? "dataMessage"
178
179 instance FromJSON SignalDataMessage where
180 parseJSON = withObject "SignalDataMessage" $ \o ->
181 SignalDataMessage <$> o .: "message" <*> o .: "timestamp"
182
183 -- | Parse a JSON value as a Signal envelope.
184 -- Handles both raw envelopes and JSON-RPC wrapped messages from signal-cli.
185 -- JSON-RPC format: @{"jsonrpc":"2.0","method":"receive","params":{"envelope":{...}}}@
186 parseSignalEnvelope :: Value -> Either String SignalEnvelope
187 parseSignalEnvelope v = case parseEither unwrap v of
188 Left err -> Left err
189 Right env -> Right env
190 where
191 unwrap = withObject "SignalMessage" $ \o -> do
192 -- Try JSON-RPC wrapper first: params.envelope
193 mParams <- o .:? "params"
194 case mParams of
195 Just params -> do
196 mEnvelope <- params .:? "envelope"
197 case mEnvelope of
198 Just envelope -> parseJSON envelope
199 Nothing -> fail "JSON-RPC message has no 'envelope' in 'params'"
200 Nothing -> parseJSON (Object o) -- Try raw envelope