diff options
Diffstat (limited to 'Omni/Agent/Telegram.hs')
| -rw-r--r-- | Omni/Agent/Telegram.hs | 151 |
1 files changed, 137 insertions, 14 deletions
diff --git a/Omni/Agent/Telegram.hs b/Omni/Agent/Telegram.hs index 59361ac..23a760a 100644 --- a/Omni/Agent/Telegram.hs +++ b/Omni/Agent/Telegram.hs @@ -33,7 +33,9 @@ module Omni.Agent.Telegram getUpdates, sendMessage, sendMessageReturningId, + sendMessageWithKeyboard, editMessage, + answerCallbackQuery, sendTypingAction, leaveChat, @@ -383,6 +385,63 @@ editMessage cfg chatId messageId text = do let respBody = HTTP.getResponseBody response putText <| "Edit message HTTP " <> tshow status <> ": " <> TE.decodeUtf8 (BL.toStrict respBody) +-- | Send a message with inline keyboard buttons +sendMessageWithKeyboard :: Types.TelegramConfig -> Int -> Text -> Types.InlineKeyboardMarkup -> IO (Maybe Int) +sendMessageWithKeyboard cfg chatId text keyboard = do + let url = + Text.unpack (Types.tgApiBaseUrl cfg) + <> "/bot" + <> Text.unpack (Types.tgBotToken cfg) + <> "/sendMessage" + body = + Aeson.object + [ "chat_id" .= chatId, + "text" .= text, + "reply_markup" .= keyboard + ] + req0 <- HTTP.parseRequest url + let req = + HTTP.setRequestMethod "POST" + <| HTTP.setRequestHeader "Content-Type" ["application/json"] + <| HTTP.setRequestBodyLBS (Aeson.encode body) + <| req0 + result <- try @SomeException (HTTP.httpLBS req) + case result of + Left e -> do + putText <| "sendMessageWithKeyboard failed: " <> tshow e + pure Nothing + Right response -> do + let respBody = HTTP.getResponseBody response + case Aeson.decode respBody of + Just (Aeson.Object obj) -> case KeyMap.lookup "result" obj of + Just (Aeson.Object msgObj) -> case KeyMap.lookup "message_id" msgObj of + Just (Aeson.Number n) -> pure (Just (round n)) + _ -> pure Nothing + _ -> pure Nothing + _ -> pure Nothing + +-- | Answer a callback query (acknowledges button press) +answerCallbackQuery :: Types.TelegramConfig -> Text -> Maybe Text -> IO () +answerCallbackQuery cfg callbackId maybeText = do + let url = + Text.unpack (Types.tgApiBaseUrl cfg) + <> "/bot" + <> Text.unpack (Types.tgBotToken cfg) + <> "/answerCallbackQuery" + baseFields = ["callback_query_id" .= callbackId] + textField = case maybeText of + Just txt -> ["text" .= txt] + Nothing -> [] + body = Aeson.object (baseFields <> textField) + req0 <- HTTP.parseRequest url + let req = + HTTP.setRequestMethod "POST" + <| HTTP.setRequestHeader "Content-Type" ["application/json"] + <| HTTP.setRequestBodyLBS (Aeson.encode body) + <| req0 + _ <- try @SomeException (HTTP.httpLBS req) + pure () + sendTypingAction :: Types.TelegramConfig -> Int -> IO () sendTypingAction cfg chatId = do let url = @@ -480,19 +539,24 @@ runTelegramBot tgConfig provider = do offset <- readTVarIO offsetVar rawUpdates <- getRawUpdates tgConfig offset forM_ rawUpdates <| \rawUpdate -> do - case Types.parseBotAddedToGroup botName rawUpdate of - Just addedEvent -> do - atomically (writeTVar offsetVar (Types.bagUpdateId addedEvent + 1)) - handleBotAddedToGroup tgConfig addedEvent - Nothing -> case Types.parseUpdate rawUpdate of - Just msg -> do - putText <| "Received message from " <> Types.tmUserFirstName msg <> " in chat " <> tshow (Types.tmChatId msg) <> " (type: " <> tshow (Types.tmChatType msg) <> "): " <> Text.take 50 (Types.tmText msg) - atomically (writeTVar offsetVar (Types.tmUpdateId msg + 1)) - IncomingQueue.enqueueIncoming incomingQueues IncomingQueue.defaultBatchWindowSeconds msg - Nothing -> do - let updateId = getUpdateId rawUpdate - putText <| "Unparsed update: " <> Text.take 200 (tshow rawUpdate) - forM_ updateId <| \uid -> atomically (writeTVar offsetVar (uid + 1)) + case Types.parseCallbackQuery rawUpdate of + Just cq -> do + let updateId = getUpdateId rawUpdate + forM_ updateId <| \uid -> atomically (writeTVar offsetVar (uid + 1)) + handleCallbackQuery tgConfig cq + Nothing -> case Types.parseBotAddedToGroup botName rawUpdate of + Just addedEvent -> do + atomically (writeTVar offsetVar (Types.bagUpdateId addedEvent + 1)) + handleBotAddedToGroup tgConfig addedEvent + Nothing -> case Types.parseUpdate rawUpdate of + Just msg -> do + putText <| "Received message from " <> Types.tmUserFirstName msg <> " in chat " <> tshow (Types.tmChatId msg) <> " (type: " <> tshow (Types.tmChatType msg) <> "): " <> Text.take 50 (Types.tmText msg) + atomically (writeTVar offsetVar (Types.tmUpdateId msg + 1)) + IncomingQueue.enqueueIncoming incomingQueues IncomingQueue.defaultBatchWindowSeconds msg + Nothing -> do + let updateId = getUpdateId rawUpdate + putText <| "Unparsed update: " <> Text.take 200 (tshow rawUpdate) + forM_ updateId <| \uid -> atomically (writeTVar offsetVar (uid + 1)) when (null rawUpdates) <| threadDelay 1000000 getUpdateId :: Aeson.Value -> Maybe Int @@ -516,6 +580,43 @@ handleBotAddedToGroup tgConfig addedEvent = do _ <- Messages.enqueueImmediate Nothing chatId Nothing "sorry, you're not authorized to add me to groups." (Just "system") Nothing leaveChat tgConfig chatId +-- | Handle callback query from inline keyboard button press +handleCallbackQuery :: Types.TelegramConfig -> Types.CallbackQuery -> IO () +handleCallbackQuery tgConfig cq = do + let callbackData = Types.cqData cq + chatId = Types.cqChatId cq + userId = Types.cqFromId cq + userName = Types.cqFromFirstName cq + putText <| "Callback query from " <> userName <> ": " <> callbackData + if not (Types.isUserAllowed tgConfig userId) + then do + answerCallbackQuery tgConfig (Types.cqId cq) (Just "Not authorized") + putText <| "Unauthorized callback from user " <> tshow userId + else case Text.splitOn ":" callbackData of + ["subagent_approve", pendingId] -> do + answerCallbackQuery tgConfig (Types.cqId cq) (Just "Spawning subagent...") + let keys = + Subagent.SubagentApiKeys + { Subagent.subagentOpenRouterKey = Types.tgOpenRouterApiKey tgConfig, + Subagent.subagentKagiKey = Types.tgKagiApiKey tgConfig + } + result <- Subagent.approveAndSpawnSubagent keys pendingId + case result of + Left err -> do + sendMessage tgConfig chatId ("❌ Failed to spawn subagent: " <> err) + Right subagentId -> do + sendMessage tgConfig chatId ("🚀 Subagent **" <> subagentId <> "** spawned! Use `check_subagent` to monitor progress.") + ["subagent_reject", pendingId] -> do + rejected <- Subagent.rejectPendingSpawn pendingId + if rejected + then do + answerCallbackQuery tgConfig (Types.cqId cq) (Just "Spawn cancelled") + sendMessage tgConfig chatId "❌ Subagent spawn cancelled." + else answerCallbackQuery tgConfig (Types.cqId cq) (Just "Already expired") + _ -> do + answerCallbackQuery tgConfig (Types.cqId cq) (Just "Unknown action") + putText <| "Unknown callback data: " <> callbackData + handleMessageBatch :: Types.TelegramConfig -> Provider.Provider -> @@ -1023,7 +1124,29 @@ processEngagedMessage tgConfig provider engineCfg msg uid userName chatId userMe { Subagent.subagentOpenRouterKey = Types.tgOpenRouterApiKey tgConfig, Subagent.subagentKagiKey = Types.tgKagiApiKey tgConfig } - in Subagent.subagentTools keys + approvalCallback cid pid role task estMins maxCost = do + let approvalMsg = + "🤖 **Spawn Subagent?**\n\n" + <> "**Role:** " + <> role + <> "\n" + <> "**Task:** " + <> task + <> "\n" + <> "**Est. time:** ~" + <> tshow estMins + <> " min\n" + <> "**Max cost:** $" + <> Text.pack (printf "%.2f" (maxCost / 100)) + keyboard = + Types.InlineKeyboardMarkup + [ [ Types.InlineKeyboardButton "✅ Approve" (Just ("subagent_approve:" <> pid)) Nothing, + Types.InlineKeyboardButton "❌ Reject" (Just ("subagent_reject:" <> pid)) Nothing + ] + ] + _ <- sendMessageWithKeyboard tgConfig cid approvalMsg keyboard + pure () + in Subagent.subagentToolsWithApproval keys chatId approvalCallback else [] auditLogTools = [AvaLogs.readAvaLogsTool | isBenAuthorized userName] |