never executed always true always false
1 module PureClaw.Channels.Telegram
2 ( -- * Telegram channel
3 TelegramChannel (..)
4 , TelegramConfig (..)
5 , mkTelegramChannel
6 -- * Message parsing
7 , parseTelegramUpdate
8 , TelegramUpdate (..)
9 , TelegramMessage (..)
10 , TelegramChat (..)
11 , TelegramUser (..)
12 ) where
13
14 import Control.Concurrent.STM
15 import Control.Exception
16 import Data.Aeson
17 import Data.IORef
18 import Data.Text (Text)
19 import Data.Text qualified as T
20 import Data.Text.Encoding qualified as TE
21 import Network.HTTP.Types.URI qualified as URI
22
23 import PureClaw.Channels.Class
24 import PureClaw.Core.Errors
25 import PureClaw.Core.Types
26 import PureClaw.Handles.Channel
27 import PureClaw.Handles.Log
28 import PureClaw.Handles.Network
29
30 -- | Configuration for Telegram channel.
31 data TelegramConfig = TelegramConfig
32 { _tc_botToken :: Text
33 , _tc_apiBase :: Text
34 }
35 deriving stock (Show, Eq)
36
37 -- | A Telegram channel backed by a message queue. Updates are pushed
38 -- into the queue (e.g. from a webhook endpoint) and the agent loop
39 -- pulls them out via 'receive'. Responses are sent via the Telegram
40 -- Bot API using the provided 'NetworkHandle'.
41 data TelegramChannel = TelegramChannel
42 { _tch_config :: TelegramConfig
43 , _tch_inbox :: TQueue TelegramUpdate
44 , _tch_network :: NetworkHandle
45 , _tch_log :: LogHandle
46 , _tch_lastChat :: IORef (Maybe Int)
47 }
48
49 -- | Create a Telegram channel with an empty inbox.
50 mkTelegramChannel :: TelegramConfig -> NetworkHandle -> LogHandle -> IO TelegramChannel
51 mkTelegramChannel config nh lh = do
52 inbox <- newTQueueIO
53 chatRef <- newIORef Nothing
54 pure TelegramChannel
55 { _tch_config = config
56 , _tch_inbox = inbox
57 , _tch_network = nh
58 , _tch_log = lh
59 , _tch_lastChat = chatRef
60 }
61
62 instance Channel TelegramChannel where
63 toHandle tc = ChannelHandle
64 { _ch_receive = receiveUpdate tc
65 , _ch_send = sendMessage tc
66 , _ch_sendError = sendTelegramError tc
67 , _ch_sendChunk = \_ -> pure () -- Telegram doesn't support streaming
68 , _ch_readSecret = ioError (userError "Vault management requires the CLI interface")
69 }
70
71 -- | Block until a Telegram update arrives in the queue.
72 receiveUpdate :: TelegramChannel -> IO IncomingMessage
73 receiveUpdate tc = do
74 update <- atomically $ readTQueue (_tch_inbox tc)
75 let msg = _tu_message update
76 userId = T.pack (show (_tu_id (_tm_from msg)))
77 chatId = _tcht_id (_tm_chat msg)
78 content = _tm_text msg
79 writeIORef (_tch_lastChat tc) (Just chatId)
80 pure IncomingMessage
81 { _im_userId = UserId userId
82 , _im_content = content
83 }
84
85 -- | Send a message to the last active chat via the Telegram Bot API.
86 sendMessage :: TelegramChannel -> OutgoingMessage -> IO ()
87 sendMessage tc msg = do
88 chatId <- readIORef (_tch_lastChat tc)
89 case chatId of
90 Nothing -> _lh_logWarn (_tch_log tc) "No chat_id available for send"
91 Just cid -> do
92 result <- try @SomeException (postTelegram tc "sendMessage" cid (_om_content msg))
93 case result of
94 Left e -> _lh_logError (_tch_log tc) $ "Telegram send failed: " <> T.pack (show e)
95 Right resp
96 | _hr_statusCode resp == 200 -> pure ()
97 | otherwise ->
98 _lh_logError (_tch_log tc) $
99 "Telegram API error " <> T.pack (show (_hr_statusCode resp))
100
101 -- | Send an error message to the Telegram chat.
102 sendTelegramError :: TelegramChannel -> PublicError -> IO ()
103 sendTelegramError tc err = do
104 chatId <- readIORef (_tch_lastChat tc)
105 case chatId of
106 Nothing -> _lh_logWarn (_tch_log tc) "No chat_id available for error send"
107 Just cid -> do
108 let errText = case err of
109 RateLimitError -> "Rate limited. Please try again in a moment."
110 NotAllowedError -> "Not allowed."
111 TemporaryError t -> t
112 result <- try @SomeException (postTelegram tc "sendMessage" cid errText)
113 case result of
114 Left e -> _lh_logError (_tch_log tc) $ "Telegram error send failed: " <> T.pack (show e)
115 Right _ -> pure ()
116
117 -- | POST to a Telegram Bot API method with chat_id and text parameters.
118 postTelegram :: TelegramChannel -> Text -> Int -> Text -> IO HttpResponse
119 postTelegram tc method chatId text = do
120 let config = _tch_config tc
121 url = _tc_apiBase config <> "/bot" <> _tc_botToken config <> "/" <> method
122 body = "chat_id=" <> URI.urlEncode False (TE.encodeUtf8 (T.pack (show chatId)))
123 <> "&text=" <> URI.urlEncode False (TE.encodeUtf8 text)
124 case mkAllowedUrl AllowAll url of
125 Left e -> throwIO (userError ("Bad Telegram URL: " <> show e))
126 Right allowed -> _nh_httpPost (_tch_network tc) allowed body
127
128 -- | A Telegram Update object (simplified).
129 data TelegramUpdate = TelegramUpdate
130 { _tu_updateId :: Int
131 , _tu_message :: TelegramMessage
132 }
133 deriving stock (Show, Eq)
134
135 -- | A Telegram Message object (simplified).
136 data TelegramMessage = TelegramMessage
137 { _tm_messageId :: Int
138 , _tm_from :: TelegramUser
139 , _tm_chat :: TelegramChat
140 , _tm_text :: Text
141 }
142 deriving stock (Show, Eq)
143
144 -- | A Telegram Chat object (simplified).
145 data TelegramChat = TelegramChat
146 { _tcht_id :: Int
147 , _tcht_type :: Text
148 }
149 deriving stock (Show, Eq)
150
151 -- | A Telegram User object (simplified).
152 data TelegramUser = TelegramUser
153 { _tu_id :: Int
154 , _tu_firstName :: Text
155 }
156 deriving stock (Show, Eq)
157
158 instance FromJSON TelegramUpdate where
159 parseJSON = withObject "TelegramUpdate" $ \o ->
160 TelegramUpdate <$> o .: "update_id" <*> o .: "message"
161
162 instance FromJSON TelegramMessage where
163 parseJSON = withObject "TelegramMessage" $ \o ->
164 TelegramMessage <$> o .: "message_id" <*> o .: "from" <*> o .: "chat" <*> o .: "text"
165
166 instance FromJSON TelegramChat where
167 parseJSON = withObject "TelegramChat" $ \o ->
168 TelegramChat <$> o .: "id" <*> o .: "type"
169
170 instance FromJSON TelegramUser where
171 parseJSON = withObject "TelegramUser" $ \o ->
172 TelegramUser <$> o .: "id" <*> o .: "first_name"
173
174 -- | Parse a JSON value as a Telegram update.
175 parseTelegramUpdate :: Value -> Either String TelegramUpdate
176 parseTelegramUpdate v = case fromJSON v of
177 Error err -> Left err
178 Success upd -> Right upd