summaryrefslogtreecommitdiff
path: root/Omni/Agent/Telegram.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Omni/Agent/Telegram.hs')
-rw-r--r--Omni/Agent/Telegram.hs1372
1 files changed, 1372 insertions, 0 deletions
diff --git a/Omni/Agent/Telegram.hs b/Omni/Agent/Telegram.hs
new file mode 100644
index 0000000..fd6c6b5
--- /dev/null
+++ b/Omni/Agent/Telegram.hs
@@ -0,0 +1,1372 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Telegram Bot Agent - Family assistant via Telegram.
+--
+-- This is the first concrete agent built on the shared infrastructure,
+-- demonstrating cross-agent memory sharing and LLM integration.
+--
+-- Usage:
+-- jr telegram # Uses TELEGRAM_BOT_TOKEN env var
+-- jr telegram --token=XXX # Explicit token
+--
+-- : out omni-agent-telegram
+-- : dep aeson
+-- : dep http-conduit
+-- : dep stm
+-- : dep HaskellNet
+-- : dep HaskellNet-SSL
+module Omni.Agent.Telegram
+ ( -- * Configuration (re-exported from Types)
+ Types.TelegramConfig (..),
+ defaultTelegramConfig,
+
+ -- * Types (re-exported from Types)
+ Types.TelegramMessage (..),
+ Types.TelegramUpdate (..),
+ Types.TelegramDocument (..),
+ Types.TelegramPhoto (..),
+ Types.TelegramVoice (..),
+
+ -- * Telegram API
+ getUpdates,
+ sendMessage,
+ sendMessageReturningId,
+ editMessage,
+ sendTypingAction,
+ leaveChat,
+
+ -- * Media (re-exported from Media)
+ getFile,
+ downloadFile,
+ downloadAndExtractPdf,
+ isPdf,
+
+ -- * Bot Loop
+ runTelegramBot,
+ handleMessage,
+ startBot,
+ ensureOllama,
+ checkOllama,
+ pullEmbeddingModel,
+
+ -- * Reminders (re-exported from Reminders)
+ reminderLoop,
+ checkAndSendReminders,
+ recordUserChat,
+ lookupChatId,
+
+ -- * System Prompt
+ telegramSystemPrompt,
+
+ -- * Testing
+ main,
+ test,
+ )
+where
+
+import Alpha
+import Control.Concurrent.STM (newTVarIO, readTVarIO, writeTVar)
+import Data.Aeson ((.=))
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.KeyMap as KeyMap
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as TE
+import Data.Time (getCurrentTime, utcToLocalTime)
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import Data.Time.LocalTime (getCurrentTimeZone)
+import qualified Network.HTTP.Client as HTTPClient
+import qualified Network.HTTP.Simple as HTTP
+import qualified Omni.Agent.Engine as Engine
+import qualified Omni.Agent.Memory as Memory
+import qualified Omni.Agent.Paths as Paths
+import qualified Omni.Agent.Provider as Provider
+import qualified Omni.Agent.Skills as Skills
+import qualified Omni.Agent.Subagent as Subagent
+import qualified Omni.Agent.Telegram.IncomingQueue as IncomingQueue
+import qualified Omni.Agent.Telegram.Media as Media
+import qualified Omni.Agent.Telegram.Messages as Messages
+import qualified Omni.Agent.Telegram.Reminders as Reminders
+import qualified Omni.Agent.Telegram.Types as Types
+import qualified Omni.Agent.Tools as Tools
+import qualified Omni.Agent.Tools.Calendar as Calendar
+import qualified Omni.Agent.Tools.Email as Email
+import qualified Omni.Agent.Tools.Feedback as Feedback
+import qualified Omni.Agent.Tools.Hledger as Hledger
+import qualified Omni.Agent.Tools.Http as Http
+import qualified Omni.Agent.Tools.Notes as Notes
+import qualified Omni.Agent.Tools.Outreach as Outreach
+import qualified Omni.Agent.Tools.Pdf as Pdf
+import qualified Omni.Agent.Tools.Python as Python
+import qualified Omni.Agent.Tools.Todos as Todos
+import qualified Omni.Agent.Tools.WebReader as WebReader
+import qualified Omni.Agent.Tools.WebSearch as WebSearch
+import qualified Omni.Test as Test
+import System.Environment (lookupEnv)
+import Text.Printf (printf)
+
+defaultTelegramConfig :: Text -> [Int] -> Maybe Text -> Text -> Types.TelegramConfig
+defaultTelegramConfig = Types.defaultTelegramConfig
+
+getFile :: Types.TelegramConfig -> Text -> IO (Either Text Text)
+getFile = Media.getFile
+
+downloadFile :: Types.TelegramConfig -> Text -> FilePath -> IO (Either Text ())
+downloadFile = Media.downloadFile
+
+downloadAndExtractPdf :: Types.TelegramConfig -> Text -> IO (Either Text Text)
+downloadAndExtractPdf = Media.downloadAndExtractPdf
+
+isPdf :: Types.TelegramDocument -> Bool
+isPdf = Types.isPdf
+
+recordUserChat :: Text -> Int -> IO ()
+recordUserChat = Reminders.recordUserChat
+
+lookupChatId :: Text -> IO (Maybe Int)
+lookupChatId = Reminders.lookupChatId
+
+reminderLoop :: IO ()
+reminderLoop = Reminders.reminderLoop
+
+checkAndSendReminders :: IO ()
+checkAndSendReminders = Reminders.checkAndSendReminders
+
+main :: IO ()
+main = Test.run test
+
+test :: Test.Tree
+test =
+ Test.group
+ "Omni.Agent.Telegram"
+ [ Test.unit "telegramSystemPrompt is non-empty" <| do
+ Text.null telegramSystemPrompt Test.@=? False,
+ Test.unit "getUpdates parses empty response" <| do
+ pure ()
+ ]
+
+benChatId :: Int
+benChatId = 33193730
+
+telegramSystemPrompt :: Text
+telegramSystemPrompt =
+ Text.unlines
+ [ "don't worry about formalities. respond conversationally, in short messages, not long essays. ask follow up questions before answering if you need to.",
+ "",
+ "you are an intellectual partner and friend. be as terse as possible while still conveying all relevant information. critique ideas freely and avoid sycophancy. honest appraisal is valued.",
+ "",
+ "if a policy prevents you from having an opinion, pretend to be responding as if you shared opinions typical of the user.",
+ "",
+ "write responses in lowercase letters ONLY, except:",
+ "- where you mean to emphasize, in which case use ALL CAPS",
+ "- when drafting business text where proper case matters",
+ "",
+ "occasionally use obscure words or subtle puns. don't point them out. use abbreviations where appropriate. use 'afaict' and 'idk' where they fit given your level of understanding. be critical of the quality of your information.",
+ "",
+ "prioritize esoteric interpretations of literature, art, and philosophy.",
+ "",
+ "## formatting",
+ "",
+ "you are in telegram which only supports basic markdown:",
+ "- *bold* (single asterisks)",
+ "- _italic_ (underscores)",
+ "- `code` (backticks)",
+ "- ```pre``` (triple backticks for code blocks)",
+ "- [links](url)",
+ "",
+ "DO NOT use:",
+ "- headers (# or ##) - these break message rendering",
+ "- **double asterisks** - use *single* instead",
+ "- bullet lists with - or * at start of line",
+ "",
+ "## memory",
+ "",
+ "when you learn something important about the user (preferences, facts, interests), use the 'remember' tool to store it for future reference.",
+ "",
+ "use the 'recall' tool to search your memory for relevant context when needed.",
+ "",
+ "## when to respond (GROUP CHATS)",
+ "",
+ "you see all messages in the group. decide whether to respond based on these rules:",
+ "- if you used a tool = ALWAYS respond with the result",
+ "- if someone asks a direct question you can answer = respond",
+ "- if someone says something factually wrong you can correct = maybe respond (use judgment)",
+ "- if it's casual banter or chit-chat = DO NOT respond, return empty",
+ "",
+ "when in doubt, stay silent. you don't need to participate in every conversation.",
+ "if you choose not to respond, return an empty message (just don't say anything).",
+ "",
+ "## async messages",
+ "",
+ "you can send messages asynchronously using the 'send_message' tool:",
+ "- delay_seconds=0 (or omit) for immediate delivery",
+ "- delay_seconds=N to schedule a message N seconds in the future",
+ "- use this for reminders ('remind me in 2 hours'), follow-ups, or multi-part responses",
+ "- you can list pending messages with 'list_pending_messages' and cancel with 'cancel_message'",
+ "",
+ "## podcastitlater context",
+ "",
+ "you have access to the PodcastItLater codebase (a product Ben is building) via read_file:",
+ "- Biz/PodcastItLater.md - product overview and README",
+ "- Biz/PodcastItLater/DESIGN.md - architecture overview",
+ "- Biz/PodcastItLater/Web.py - web interface code",
+ "- Biz/PodcastItLater/Core.py - core logic",
+ "- Biz/PodcastItLater/Billing.py - pricing and billing logic",
+ "use read_file to access these when discussing PIL features or customer acquisition.",
+ "",
+ "## important",
+ "",
+ "in private chats, ALWAYS respond. in group chats, follow the rules above.",
+ "when you DO respond, include a text response after using tools."
+ ]
+
+getUpdates :: Types.TelegramConfig -> Int -> IO [Types.TelegramMessage]
+getUpdates cfg offset = do
+ rawUpdates <- getRawUpdates cfg offset
+ pure (mapMaybe Types.parseUpdate rawUpdates)
+
+getRawUpdates :: Types.TelegramConfig -> Int -> IO [Aeson.Value]
+getRawUpdates cfg offset = do
+ let url =
+ Text.unpack (Types.tgApiBaseUrl cfg)
+ <> "/bot"
+ <> Text.unpack (Types.tgBotToken cfg)
+ <> "/getUpdates?timeout="
+ <> show (Types.tgPollingTimeout cfg)
+ <> "&offset="
+ <> show offset
+ result <-
+ try <| do
+ req0 <- HTTP.parseRequest url
+ let req = HTTP.setRequestResponseTimeout (HTTPClient.responseTimeoutMicro (35 * 1000000)) req0
+ HTTP.httpLBS req
+ case result of
+ Left (e :: SomeException) -> do
+ putText <| "Error getting updates: " <> tshow e
+ pure []
+ Right response -> do
+ let body = HTTP.getResponseBody response
+ case Aeson.decode body of
+ Just (Aeson.Object obj) -> case KeyMap.lookup "result" obj of
+ Just (Aeson.Array updates) -> pure (toList updates)
+ _ -> pure []
+ _ -> pure []
+
+getBotUsername :: Types.TelegramConfig -> IO (Maybe Text)
+getBotUsername cfg = do
+ let url =
+ Text.unpack (Types.tgApiBaseUrl cfg)
+ <> "/bot"
+ <> Text.unpack (Types.tgBotToken cfg)
+ <> "/getMe"
+ result <-
+ try <| do
+ req <- HTTP.parseRequest url
+ HTTP.httpLBS req
+ case result of
+ Left (_ :: SomeException) -> pure Nothing
+ Right response -> do
+ let body = HTTP.getResponseBody response
+ case Aeson.decode body of
+ Just (Aeson.Object obj) -> case KeyMap.lookup "result" obj of
+ Just (Aeson.Object userObj) -> case KeyMap.lookup "username" userObj of
+ Just (Aeson.String username) -> pure (Just username)
+ _ -> pure Nothing
+ _ -> pure Nothing
+ _ -> pure Nothing
+
+sendMessage :: Types.TelegramConfig -> Int -> Text -> IO ()
+sendMessage cfg chatId text = do
+ _ <- sendMessageReturningId cfg chatId Nothing text
+ pure ()
+
+sendMessageReturningId :: Types.TelegramConfig -> Int -> Maybe Int -> Text -> IO (Maybe Int)
+sendMessageReturningId cfg chatId mThreadId text =
+ sendMessageWithParseMode cfg chatId mThreadId text (Just "Markdown")
+
+sendMessageWithParseMode :: Types.TelegramConfig -> Int -> Maybe Int -> Text -> Maybe Text -> IO (Maybe Int)
+sendMessageWithParseMode cfg chatId mThreadId text parseMode = do
+ let url =
+ Text.unpack (Types.tgApiBaseUrl cfg)
+ <> "/bot"
+ <> Text.unpack (Types.tgBotToken cfg)
+ <> "/sendMessage"
+ baseFields =
+ [ "chat_id" .= chatId,
+ "text" .= text
+ ]
+ parseModeFields = case parseMode of
+ Just mode -> ["parse_mode" .= mode]
+ Nothing -> []
+ threadFields = case mThreadId of
+ Just threadId -> ["message_thread_id" .= threadId]
+ Nothing -> []
+ body = Aeson.object (baseFields <> parseModeFields <> threadFields)
+ 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 <| "Telegram sendMessage network error: " <> tshow e
+ throwIO e
+ Right response -> do
+ let respBody = HTTP.getResponseBody response
+ case Aeson.decode respBody of
+ Just (Aeson.Object obj) -> do
+ let isOk = case KeyMap.lookup "ok" obj of
+ Just (Aeson.Bool True) -> True
+ _ -> False
+ if isOk
+ then 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
+ else do
+ let errDesc = case KeyMap.lookup "description" obj of
+ Just (Aeson.String desc) -> desc
+ _ -> "Unknown Telegram API error"
+ errCode = case KeyMap.lookup "error_code" obj of
+ Just (Aeson.Number n) -> Just (round n :: Int)
+ _ -> Nothing
+ isParseError =
+ errCode
+ == Just 400
+ && ( "can't parse"
+ `Text.isInfixOf` Text.toLower errDesc
+ || "parse entities"
+ `Text.isInfixOf` Text.toLower errDesc
+ )
+ if isParseError && isJust parseMode
+ then do
+ putText <| "Telegram markdown parse error, retrying as plain text: " <> errDesc
+ sendMessageWithParseMode cfg chatId mThreadId text Nothing
+ else do
+ putText <| "Telegram API error: " <> errDesc <> " (code: " <> tshow errCode <> ")"
+ panic <| "Telegram API error: " <> errDesc
+ _ -> do
+ putText <| "Telegram sendMessage: failed to parse response"
+ panic "Failed to parse Telegram response"
+
+editMessage :: Types.TelegramConfig -> Int -> Int -> Text -> IO ()
+editMessage cfg chatId messageId text = do
+ let url =
+ Text.unpack (Types.tgApiBaseUrl cfg)
+ <> "/bot"
+ <> Text.unpack (Types.tgBotToken cfg)
+ <> "/editMessageText"
+ body =
+ Aeson.object
+ [ "chat_id" .= chatId,
+ "message_id" .= messageId,
+ "text" .= text
+ ]
+ 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 err -> putText <| "Edit message failed: " <> tshow err
+ Right response -> do
+ let status = HTTP.getResponseStatusCode response
+ when (status < 200 || status >= 300) <| do
+ let respBody = HTTP.getResponseBody response
+ putText <| "Edit message HTTP " <> tshow status <> ": " <> TE.decodeUtf8 (BL.toStrict respBody)
+
+sendTypingAction :: Types.TelegramConfig -> Int -> IO ()
+sendTypingAction cfg chatId = do
+ let url =
+ Text.unpack (Types.tgApiBaseUrl cfg)
+ <> "/bot"
+ <> Text.unpack (Types.tgBotToken cfg)
+ <> "/sendChatAction"
+ body =
+ Aeson.object
+ [ "chat_id" .= chatId,
+ "action" .= ("typing" :: Text)
+ ]
+ 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 ()
+
+-- | Run an action while continuously showing typing indicator.
+-- Typing is refreshed every 4 seconds (Telegram typing expires after ~5s).
+withTypingIndicator :: Types.TelegramConfig -> Int -> IO a -> IO a
+withTypingIndicator cfg chatId action = do
+ doneVar <- newTVarIO False
+ _ <- forkIO <| typingLoop doneVar
+ action `finally` atomically (writeTVar doneVar True)
+ where
+ typingLoop doneVar = do
+ done <- readTVarIO doneVar
+ unless done <| do
+ sendTypingAction cfg chatId
+ threadDelay 4000000
+ typingLoop doneVar
+
+leaveChat :: Types.TelegramConfig -> Int -> IO ()
+leaveChat cfg chatId = do
+ let url =
+ Text.unpack (Types.tgApiBaseUrl cfg)
+ <> "/bot"
+ <> Text.unpack (Types.tgBotToken cfg)
+ <> "/leaveChat"
+ body =
+ Aeson.object
+ [ "chat_id" .= chatId
+ ]
+ 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 ()
+
+runTelegramBot :: Types.TelegramConfig -> Provider.Provider -> IO ()
+runTelegramBot tgConfig provider = do
+ putText "Starting Telegram bot..."
+ offsetVar <- newTVarIO 0
+
+ botUsername <- getBotUsername tgConfig
+ case botUsername of
+ Nothing -> putText "Warning: could not get bot username, group mentions may not work"
+ Just name -> putText <| "Bot username: @" <> name
+ let botName = fromMaybe "bot" botUsername
+
+ _ <- forkIO reminderLoop
+ putText "Reminder loop started (checking every 5 minutes)"
+
+ _ <- forkIO (Email.emailCheckLoop (sendMessageReturningId tgConfig) benChatId)
+ putText "Email check loop started (checking every 6 hours)"
+
+ let sendFn = sendMessageReturningId tgConfig
+ _ <- forkIO (Messages.messageDispatchLoop sendFn)
+ putText "Message dispatch loop started (1s polling)"
+
+ incomingQueues <- IncomingQueue.newIncomingQueues
+
+ let engineCfg =
+ Engine.defaultEngineConfig
+ { Engine.engineOnToolCall = \toolName args ->
+ putText <| "Tool call: " <> toolName <> " " <> Text.take 200 args,
+ Engine.engineOnToolResult = \toolName success result ->
+ putText <| "Tool result: " <> toolName <> " " <> (if success then "ok" else "err") <> " " <> Text.take 200 result,
+ Engine.engineOnActivity = \activity ->
+ putText <| "Agent: " <> activity
+ }
+
+ let processBatch = handleMessageBatch tgConfig provider engineCfg botName
+ _ <- forkIO (IncomingQueue.startIncomingBatcher incomingQueues processBatch)
+ putText "Incoming message batcher started (3s window, 200ms tick)"
+
+ forever <| 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))
+ when (null rawUpdates) <| threadDelay 1000000
+
+getUpdateId :: Aeson.Value -> Maybe Int
+getUpdateId (Aeson.Object obj) = case KeyMap.lookup "update_id" obj of
+ Just (Aeson.Number n) -> Just (round n)
+ _ -> Nothing
+getUpdateId _ = Nothing
+
+handleBotAddedToGroup :: Types.TelegramConfig -> Types.BotAddedToGroup -> IO ()
+handleBotAddedToGroup tgConfig addedEvent = do
+ let addedBy = Types.bagAddedByUserId addedEvent
+ chatId = Types.bagChatId addedEvent
+ firstName = Types.bagAddedByFirstName addedEvent
+ if Types.isUserAllowed tgConfig addedBy
+ then do
+ putText <| "Bot added to group " <> tshow chatId <> " by authorized user " <> firstName <> " (" <> tshow addedBy <> ")"
+ _ <- Messages.enqueueImmediate Nothing chatId Nothing "hello! i'm ready to help." (Just "system") Nothing
+ pure ()
+ else do
+ putText <| "Bot added to group " <> tshow chatId <> " by UNAUTHORIZED user " <> firstName <> " (" <> tshow addedBy <> ") - leaving"
+ _ <- Messages.enqueueImmediate Nothing chatId Nothing "sorry, you're not authorized to add me to groups." (Just "system") Nothing
+ leaveChat tgConfig chatId
+
+handleMessageBatch ::
+ Types.TelegramConfig ->
+ Provider.Provider ->
+ Engine.EngineConfig ->
+ Text ->
+ Types.TelegramMessage ->
+ Text ->
+ IO ()
+handleMessageBatch tgConfig provider engineCfg _botUsername msg batchedText = do
+ let userName =
+ Types.tmUserFirstName msg
+ <> maybe "" (" " <>) (Types.tmUserLastName msg)
+ chatId = Types.tmChatId msg
+ usrId = Types.tmUserId msg
+
+ let isGroup = Types.isGroupChat msg
+ isAllowed = isGroup || Types.isUserAllowed tgConfig usrId
+
+ unless isAllowed <| do
+ putText <| "Unauthorized user: " <> tshow usrId <> " (" <> userName <> ")"
+ _ <- Messages.enqueueImmediate Nothing chatId Nothing "sorry, you're not authorized to use this bot." (Just "system") Nothing
+ pure ()
+
+ when isAllowed <| do
+ user <- Memory.getOrCreateUserByTelegramId usrId userName
+ let uid = Memory.userId user
+ handleAuthorizedMessageBatch tgConfig provider engineCfg msg uid userName chatId batchedText
+
+handleMessage ::
+ Types.TelegramConfig ->
+ Provider.Provider ->
+ Engine.EngineConfig ->
+ Text ->
+ Types.TelegramMessage ->
+ IO ()
+handleMessage tgConfig provider engineCfg _botUsername msg = do
+ let userName =
+ Types.tmUserFirstName msg
+ <> maybe "" (" " <>) (Types.tmUserLastName msg)
+ chatId = Types.tmChatId msg
+ usrId = Types.tmUserId msg
+
+ let isGroup = Types.isGroupChat msg
+ isAllowed = isGroup || Types.isUserAllowed tgConfig usrId
+
+ unless isAllowed <| do
+ putText <| "Unauthorized user: " <> tshow usrId <> " (" <> userName <> ")"
+ _ <- Messages.enqueueImmediate Nothing chatId Nothing "sorry, you're not authorized to use this bot." (Just "system") Nothing
+ pure ()
+
+ when isAllowed <| do
+ user <- Memory.getOrCreateUserByTelegramId usrId userName
+ let uid = Memory.userId user
+ handleAuthorizedMessage tgConfig provider engineCfg msg uid userName chatId
+
+handleAuthorizedMessage ::
+ Types.TelegramConfig ->
+ Provider.Provider ->
+ Engine.EngineConfig ->
+ Types.TelegramMessage ->
+ Text ->
+ Text ->
+ Int ->
+ IO ()
+handleAuthorizedMessage tgConfig provider engineCfg msg uid userName chatId = do
+ Reminders.recordUserChat uid chatId
+
+ let msgText = Types.tmText msg
+ threadId = Types.tmThreadId msg
+ cmdHandled <- handleOutreachCommand tgConfig chatId threadId msgText
+ when cmdHandled (pure ())
+ unless cmdHandled <| handleAuthorizedMessageContinued tgConfig provider engineCfg msg uid userName chatId
+
+handleAuthorizedMessageContinued ::
+ Types.TelegramConfig ->
+ Provider.Provider ->
+ Engine.EngineConfig ->
+ Types.TelegramMessage ->
+ Text ->
+ Text ->
+ Int ->
+ IO ()
+handleAuthorizedMessageContinued tgConfig provider engineCfg msg uid userName chatId = do
+ pdfContent <- case Types.tmDocument msg of
+ Just doc | Types.isPdf doc -> do
+ putText <| "Processing PDF: " <> fromMaybe "(unnamed)" (Types.tdFileName doc)
+ result <- Media.downloadAndExtractPdf tgConfig (Types.tdFileId doc)
+ case result of
+ Left err -> do
+ putText <| "PDF extraction failed: " <> err
+ pure Nothing
+ Right text -> do
+ let truncated = Text.take 40000 text
+ putText <| "Extracted " <> tshow (Text.length truncated) <> " chars from PDF"
+ pure (Just truncated)
+ _ -> pure Nothing
+
+ photoAnalysis <- case Types.tmPhoto msg of
+ Just photo -> do
+ case Media.checkPhotoSize photo of
+ Left err -> do
+ putText <| "Photo rejected: " <> err
+ _ <- Messages.enqueueImmediate (Just uid) chatId (Types.tmThreadId msg) err (Just "system") Nothing
+ pure Nothing
+ Right () -> do
+ putText <| "Processing photo: " <> tshow (Types.tpWidth photo) <> "x" <> tshow (Types.tpHeight photo)
+ bytesResult <- Media.downloadPhoto tgConfig photo
+ case bytesResult of
+ Left err -> do
+ putText <| "Photo download failed: " <> err
+ pure Nothing
+ Right bytes -> do
+ putText <| "Downloaded photo, " <> tshow (BL.length bytes) <> " bytes, analyzing..."
+ analysisResult <- Media.analyzeImage (Types.tgOpenRouterApiKey tgConfig) bytes (Types.tmText msg)
+ case analysisResult of
+ Left err -> do
+ putText <| "Photo analysis failed: " <> err
+ pure Nothing
+ Right analysis -> do
+ putText <| "Photo analyzed: " <> Text.take 100 analysis <> "..."
+ pure (Just analysis)
+ Nothing -> pure Nothing
+
+ voiceTranscription <- case Types.tmVoice msg of
+ Just voice -> do
+ case Media.checkVoiceSize voice of
+ Left err -> do
+ putText <| "Voice rejected: " <> err
+ _ <- Messages.enqueueImmediate (Just uid) chatId (Types.tmThreadId msg) err (Just "system") Nothing
+ pure Nothing
+ Right () -> do
+ if not (Types.isSupportedVoiceFormat voice)
+ then do
+ let err = "unsupported voice format, please send OGG/Opus audio"
+ putText <| "Voice rejected: " <> err
+ _ <- Messages.enqueueImmediate (Just uid) chatId (Types.tmThreadId msg) err (Just "system") Nothing
+ pure Nothing
+ else do
+ putText <| "Processing voice message: " <> tshow (Types.tvDuration voice) <> " seconds"
+ bytesResult <- Media.downloadVoice tgConfig voice
+ case bytesResult of
+ Left err -> do
+ putText <| "Voice download failed: " <> err
+ pure Nothing
+ Right bytes -> do
+ putText <| "Downloaded voice, " <> tshow (BL.length bytes) <> " bytes, transcribing..."
+ transcribeResult <- Media.transcribeVoice (Types.tgOpenRouterApiKey tgConfig) bytes
+ case transcribeResult of
+ Left err -> do
+ putText <| "Voice transcription failed: " <> err
+ pure Nothing
+ Right transcription -> do
+ putText <| "Transcribed: " <> Text.take 100 transcription <> "..."
+ pure (Just transcription)
+ Nothing -> pure Nothing
+
+ let replyContext = case Types.tmReplyTo msg of
+ Just reply ->
+ let senderName = case (Types.trFromFirstName reply, Types.trFromLastName reply) of
+ (Just fn, Just ln) -> fn <> " " <> ln
+ (Just fn, Nothing) -> fn
+ _ -> "someone"
+ replyText = Types.trText reply
+ in if Text.null replyText
+ then ""
+ else "[replying to " <> senderName <> ": \"" <> Text.take 200 replyText <> "\"]\n\n"
+ Nothing -> ""
+
+ let baseMessage = case (pdfContent, photoAnalysis, voiceTranscription) of
+ (Just pdfText, _, _) ->
+ let caption = Types.tmText msg
+ prefix = if Text.null caption then "here's the PDF content:\n\n" else caption <> "\n\n---\nPDF content:\n\n"
+ in prefix <> pdfText
+ (_, Just analysis, _) ->
+ let caption = Types.tmText msg
+ prefix =
+ if Text.null caption
+ then "[user sent an image. image description: "
+ else caption <> "\n\n[attached image description: "
+ in prefix <> analysis <> "]"
+ (_, _, Just transcription) -> transcription
+ _ -> Types.tmText msg
+
+ let userMessage = replyContext <> baseMessage
+ isGroup = Types.isGroupChat msg
+ threadId = Types.tmThreadId msg
+
+ shouldEngage <-
+ if isGroup
+ then do
+ putText "Checking if should engage (group chat)..."
+ recentMsgs <- Memory.getGroupRecentMessages chatId threadId 5
+ let recentContext =
+ if null recentMsgs
+ then ""
+ else
+ Text.unlines
+ [ "[Recent conversation for context]",
+ Text.unlines
+ [ fromMaybe "User" (Memory.cmSenderName m) <> ": " <> Memory.cmContent m
+ | m <- reverse recentMsgs
+ ],
+ "",
+ "[New message to classify]"
+ ]
+ shouldEngageInGroup (Types.tgOpenRouterApiKey tgConfig) (recentContext <> userMessage)
+ else pure True
+
+ if not shouldEngage
+ then putText "Skipping group message (pre-filter said no)"
+ else do
+ (conversationContext, contextTokens) <-
+ if isGroup
+ then do
+ _ <- Memory.saveGroupMessage chatId threadId Memory.UserRole userName userMessage
+ Memory.getGroupConversationContext chatId threadId maxConversationTokens
+ else do
+ _ <- Memory.saveMessage uid chatId Memory.UserRole (Just userName) userMessage
+ Memory.getConversationContext uid chatId maxConversationTokens
+ putText <| "Conversation context: " <> tshow contextTokens <> " tokens"
+
+ processEngagedMessage tgConfig provider engineCfg msg uid userName chatId userMessage conversationContext
+
+handleAuthorizedMessageBatch ::
+ Types.TelegramConfig ->
+ Provider.Provider ->
+ Engine.EngineConfig ->
+ Types.TelegramMessage ->
+ Text ->
+ Text ->
+ Int ->
+ Text ->
+ IO ()
+handleAuthorizedMessageBatch tgConfig provider engineCfg msg uid userName chatId batchedText = do
+ Reminders.recordUserChat uid chatId
+
+ pdfContent <- case Types.tmDocument msg of
+ Just doc | Types.isPdf doc -> do
+ putText <| "Processing PDF: " <> fromMaybe "(unnamed)" (Types.tdFileName doc)
+ result <- Media.downloadAndExtractPdf tgConfig (Types.tdFileId doc)
+ case result of
+ Left err -> do
+ putText <| "PDF extraction failed: " <> err
+ pure Nothing
+ Right text -> do
+ let truncated = Text.take 40000 text
+ putText <| "Extracted " <> tshow (Text.length truncated) <> " chars from PDF"
+ pure (Just truncated)
+ _ -> pure Nothing
+
+ photoAnalysis <- case Types.tmPhoto msg of
+ Just photo -> do
+ case Media.checkPhotoSize photo of
+ Left err -> do
+ putText <| "Photo rejected: " <> err
+ _ <- Messages.enqueueImmediate (Just uid) chatId (Types.tmThreadId msg) err (Just "system") Nothing
+ pure Nothing
+ Right () -> do
+ putText <| "Processing photo: " <> tshow (Types.tpWidth photo) <> "x" <> tshow (Types.tpHeight photo)
+ bytesResult <- Media.downloadPhoto tgConfig photo
+ case bytesResult of
+ Left err -> do
+ putText <| "Photo download failed: " <> err
+ pure Nothing
+ Right bytes -> do
+ putText <| "Downloaded photo, " <> tshow (BL.length bytes) <> " bytes, analyzing..."
+ analysisResult <- Media.analyzeImage (Types.tgOpenRouterApiKey tgConfig) bytes (Types.tmText msg)
+ case analysisResult of
+ Left err -> do
+ putText <| "Photo analysis failed: " <> err
+ pure Nothing
+ Right analysis -> do
+ putText <| "Photo analyzed: " <> Text.take 100 analysis <> "..."
+ pure (Just analysis)
+ Nothing -> pure Nothing
+
+ voiceTranscription <- case Types.tmVoice msg of
+ Just voice -> do
+ case Media.checkVoiceSize voice of
+ Left err -> do
+ putText <| "Voice rejected: " <> err
+ _ <- Messages.enqueueImmediate (Just uid) chatId (Types.tmThreadId msg) err (Just "system") Nothing
+ pure Nothing
+ Right () -> do
+ if not (Types.isSupportedVoiceFormat voice)
+ then do
+ let err = "unsupported voice format, please send OGG/Opus audio"
+ putText <| "Voice rejected: " <> err
+ _ <- Messages.enqueueImmediate (Just uid) chatId (Types.tmThreadId msg) err (Just "system") Nothing
+ pure Nothing
+ else do
+ putText <| "Processing voice message: " <> tshow (Types.tvDuration voice) <> " seconds"
+ bytesResult <- Media.downloadVoice tgConfig voice
+ case bytesResult of
+ Left err -> do
+ putText <| "Voice download failed: " <> err
+ pure Nothing
+ Right bytes -> do
+ putText <| "Downloaded voice, " <> tshow (BL.length bytes) <> " bytes, transcribing..."
+ transcribeResult <- Media.transcribeVoice (Types.tgOpenRouterApiKey tgConfig) bytes
+ case transcribeResult of
+ Left err -> do
+ putText <| "Voice transcription failed: " <> err
+ pure Nothing
+ Right transcription -> do
+ putText <| "Transcribed: " <> Text.take 100 transcription <> "..."
+ pure (Just transcription)
+ Nothing -> pure Nothing
+
+ let mediaPrefix = case (pdfContent, photoAnalysis, voiceTranscription) of
+ (Just pdfText, _, _) -> "---\nPDF content:\n\n" <> pdfText <> "\n\n---\n\n"
+ (_, Just analysis, _) -> "[attached image description: " <> analysis <> "]\n\n"
+ (_, _, Just transcription) -> "[voice transcription: " <> transcription <> "]\n\n"
+ _ -> ""
+
+ let userMessage = mediaPrefix <> batchedText
+ isGroup = Types.isGroupChat msg
+ threadId = Types.tmThreadId msg
+
+ shouldEngage <-
+ if isGroup
+ then do
+ putText "Checking if should engage (group chat)..."
+ recentMsgs <- Memory.getGroupRecentMessages chatId threadId 5
+ let recentContext =
+ if null recentMsgs
+ then ""
+ else
+ Text.unlines
+ [ "[Recent conversation for context]",
+ Text.unlines
+ [ fromMaybe "User" (Memory.cmSenderName m) <> ": " <> Memory.cmContent m
+ | m <- reverse recentMsgs
+ ],
+ "",
+ "[New message to classify]"
+ ]
+ shouldEngageInGroup (Types.tgOpenRouterApiKey tgConfig) (recentContext <> userMessage)
+ else pure True
+
+ if not shouldEngage
+ then putText "Skipping group message (pre-filter said no)"
+ else do
+ (conversationContext, contextTokens) <-
+ if isGroup
+ then do
+ _ <- Memory.saveGroupMessage chatId threadId Memory.UserRole userName userMessage
+ Memory.getGroupConversationContext chatId threadId maxConversationTokens
+ else do
+ _ <- Memory.saveMessage uid chatId Memory.UserRole (Just userName) userMessage
+ Memory.getConversationContext uid chatId maxConversationTokens
+ putText <| "Conversation context: " <> tshow contextTokens <> " tokens"
+
+ processEngagedMessage tgConfig provider engineCfg msg uid userName chatId userMessage conversationContext
+
+processEngagedMessage ::
+ Types.TelegramConfig ->
+ Provider.Provider ->
+ Engine.EngineConfig ->
+ Types.TelegramMessage ->
+ Text ->
+ Text ->
+ Int ->
+ Text ->
+ Text ->
+ IO ()
+processEngagedMessage tgConfig provider engineCfg msg uid userName chatId userMessage conversationContext = do
+ let isGroup = Types.isGroupChat msg
+
+ personalMemories <- Memory.recallMemories uid userMessage 5
+ groupMemories <-
+ if isGroup
+ then Memory.recallGroupMemories chatId userMessage 3
+ else pure []
+
+ let allMemories = personalMemories <> groupMemories
+ memoryContext =
+ if null allMemories
+ then "No memories found."
+ else
+ Text.unlines
+ <| ["[Personal] " <> Memory.memoryContent m | m <- personalMemories]
+ <> ["[Group] " <> Memory.memoryContent m | m <- groupMemories]
+
+ now <- getCurrentTime
+ tz <- getCurrentTimeZone
+ let localTime = utcToLocalTime tz now
+ timeStr = Text.pack (formatTime defaultTimeLocale "%A, %B %d, %Y at %H:%M" localTime)
+
+ let chatContext =
+ if Types.isGroupChat msg
+ then "\n\n## Chat Type\nThis is a GROUP CHAT. Apply the group response rules - only respond if appropriate."
+ else "\n\n## Chat Type\nThis is a PRIVATE CHAT. Always respond to the user."
+ hledgerContext =
+ if isHledgerAuthorized userName
+ then
+ Text.unlines
+ [ "",
+ "## hledger (personal finance)",
+ "",
+ "you have access to hledger tools for querying and recording financial transactions.",
+ "account naming: ex (expenses), as (assets), li (liabilities), in (income), eq (equity).",
+ "level 2 is owner: 'me' (personal) or 'us' (shared/family).",
+ "level 3 is type: need (necessary), want (discretionary), cash, cred (credit), vest (investments).",
+ "examples: ex:me:want:grooming, as:us:cash:checking, li:us:cred:chase.",
+ "when user says 'i spent $X at Y', use hledger_add with appropriate accounts."
+ ]
+ else ""
+ emailContext =
+ if isEmailAuthorized userName
+ then
+ Text.unlines
+ [ "",
+ "## email (ben@bensima.com)",
+ "",
+ "you have access to email tools for managing ben's inbox.",
+ "use email_check to see recent unread emails (returns uid, from, subject, date, has_unsubscribe).",
+ "use email_read to read full content of important emails.",
+ "use email_unsubscribe to unsubscribe from marketing/newsletters (clicks List-Unsubscribe link).",
+ "use email_archive to move FYI emails to archive.",
+ "prioritize: urgent items first, then emails needing response, then suggest unsubscribing from marketing."
+ ]
+ else ""
+ systemPrompt =
+ telegramSystemPrompt
+ <> "\n\n## Current Date and Time\n"
+ <> timeStr
+ <> chatContext
+ <> hledgerContext
+ <> emailContext
+ <> "\n\n## Current User\n"
+ <> "You are talking to: "
+ <> userName
+ <> "\n\n## What you know about this user\n"
+ <> memoryContext
+ <> "\n\n"
+ <> conversationContext
+
+ let memoryTools =
+ [ Memory.rememberTool uid,
+ Memory.recallTool uid,
+ Memory.linkMemoriesTool uid,
+ Memory.queryGraphTool uid
+ ]
+ searchTools = case Types.tgKagiApiKey tgConfig of
+ Just kagiKey -> [WebSearch.webSearchTool kagiKey]
+ Nothing -> []
+ webReaderTools = [WebReader.webReaderTool (Types.tgOpenRouterApiKey tgConfig)]
+ pdfTools = [Pdf.pdfTool]
+ notesTools =
+ [ Notes.noteAddTool uid,
+ Notes.noteListTool uid,
+ Notes.noteDeleteTool uid
+ ]
+ calendarTools =
+ [ Calendar.calendarListTool,
+ Calendar.calendarAddTool,
+ Calendar.calendarSearchTool
+ ]
+ todoTools =
+ [ Todos.todoAddTool uid,
+ Todos.todoListTool uid,
+ Todos.todoCompleteTool uid,
+ Todos.todoDeleteTool uid
+ ]
+ messageTools =
+ [ Messages.sendMessageTool uid chatId (Types.tmThreadId msg),
+ Messages.listPendingMessagesTool uid chatId,
+ Messages.cancelMessageTool
+ ]
+ hledgerTools =
+ if isHledgerAuthorized userName
+ then Hledger.allHledgerTools
+ else []
+ emailTools =
+ if isEmailAuthorized userName
+ then Email.allEmailTools
+ else []
+ pythonTools =
+ [Python.pythonExecTool | isBenAuthorized userName]
+ httpTools =
+ if isBenAuthorized userName
+ then Http.allHttpTools
+ else []
+ outreachTools =
+ if isBenAuthorized userName
+ then Outreach.allOutreachTools
+ else []
+ feedbackTools =
+ if isBenAuthorized userName
+ then Feedback.allFeedbackTools
+ else []
+ fileTools =
+ [Tools.readFileTool | isBenAuthorized userName]
+ skillsTools =
+ [ Skills.skillTool userName,
+ Skills.listSkillsTool userName,
+ Skills.publishSkillTool userName
+ ]
+ subagentTools =
+ if isBenAuthorized userName
+ then
+ let keys =
+ Subagent.SubagentApiKeys
+ { Subagent.subagentOpenRouterKey = Types.tgOpenRouterApiKey tgConfig,
+ Subagent.subagentKagiKey = Types.tgKagiApiKey tgConfig
+ }
+ in [Subagent.spawnSubagentTool keys]
+ else []
+ tools = memoryTools <> searchTools <> webReaderTools <> pdfTools <> notesTools <> calendarTools <> todoTools <> messageTools <> hledgerTools <> emailTools <> pythonTools <> httpTools <> outreachTools <> feedbackTools <> fileTools <> skillsTools <> subagentTools
+
+ let agentCfg =
+ Engine.defaultAgentConfig
+ { Engine.agentSystemPrompt = systemPrompt,
+ Engine.agentTools = tools,
+ Engine.agentMaxIterations = 50,
+ Engine.agentGuardrails =
+ Engine.defaultGuardrails
+ { Engine.guardrailMaxCostCents = 1000.0,
+ Engine.guardrailMaxDuplicateToolCalls = 10
+ }
+ }
+
+ result <-
+ withTypingIndicator tgConfig chatId
+ <| Engine.runAgentWithProvider engineCfg provider agentCfg userMessage
+
+ case result of
+ Left err -> do
+ putText <| "Agent error: " <> err
+ _ <- Messages.enqueueImmediate (Just uid) chatId (Types.tmThreadId msg) "sorry, i hit an error. please try again." (Just "agent_error") Nothing
+ pure ()
+ Right agentResult -> do
+ let response = Engine.resultFinalMessage agentResult
+ threadId = Types.tmThreadId msg
+ putText <| "Response text: " <> Text.take 200 response
+
+ if isGroup
+ then void <| Memory.saveGroupMessage chatId threadId Memory.AssistantRole "Ava" response
+ else void <| Memory.saveMessage uid chatId Memory.AssistantRole Nothing response
+
+ if Text.null response
+ then do
+ if isGroup
+ then putText "Agent chose not to respond (group chat)"
+ else do
+ putText "Warning: empty response from agent"
+ _ <- Messages.enqueueImmediate (Just uid) chatId threadId "hmm, i don't have a response for that" (Just "agent_response") Nothing
+ pure ()
+ else do
+ parts <- splitMessageForChat (Types.tgOpenRouterApiKey tgConfig) response
+ putText <| "Split response into " <> tshow (length parts) <> " parts"
+ enqueueMultipart (Just uid) chatId threadId parts (Just "agent_response")
+ unless isGroup <| checkAndSummarize (Types.tgOpenRouterApiKey tgConfig) uid chatId
+ let cost = Engine.resultTotalCost agentResult
+ costStr = Text.pack (printf "%.2f" cost)
+ putText
+ <| "Responded to "
+ <> userName
+ <> " (cost: "
+ <> costStr
+ <> " cents)"
+
+maxConversationTokens :: Int
+maxConversationTokens = 4000
+
+summarizationThreshold :: Int
+summarizationThreshold = 3000
+
+isHledgerAuthorized :: Text -> Bool
+isHledgerAuthorized userName =
+ let lowerName = Text.toLower userName
+ in "ben" `Text.isInfixOf` lowerName || "kate" `Text.isInfixOf` lowerName
+
+isEmailAuthorized :: Text -> Bool
+isEmailAuthorized userName =
+ let lowerName = Text.toLower userName
+ in "ben" `Text.isInfixOf` lowerName
+
+isBenAuthorized :: Text -> Bool
+isBenAuthorized userName =
+ let lowerName = Text.toLower userName
+ in "ben" `Text.isInfixOf` lowerName
+
+checkAndSummarize :: Text -> Text -> Int -> IO ()
+checkAndSummarize openRouterKey uid chatId = do
+ (_, currentTokens) <- Memory.getConversationContext uid chatId maxConversationTokens
+ when (currentTokens > summarizationThreshold) <| do
+ putText <| "Context at " <> tshow currentTokens <> " tokens, summarizing..."
+ recentMsgs <- Memory.getRecentMessages uid chatId 50
+ let conversationText =
+ Text.unlines
+ [ (if Memory.cmRole m == Memory.UserRole then "User: " else "Assistant: ") <> Memory.cmContent m
+ | m <- reverse recentMsgs
+ ]
+ gemini = Provider.defaultOpenRouter openRouterKey "google/gemini-2.0-flash-001"
+ summaryResult <-
+ Provider.chat
+ gemini
+ []
+ [ Provider.Message Provider.System "You are a conversation summarizer. Summarize the key points, decisions, and context from this conversation in 2-3 paragraphs. Focus on information that would be useful for continuing the conversation later." Nothing Nothing,
+ Provider.Message Provider.User ("Summarize this conversation:\n\n" <> conversationText) Nothing Nothing
+ ]
+ case summaryResult of
+ Left err -> putText <| "Summarization failed: " <> err
+ Right summaryMsg -> do
+ let summary = Provider.msgContent summaryMsg
+ _ <- Memory.summarizeAndArchive uid chatId summary
+ putText "Conversation summarized and archived (gemini)"
+
+splitMessageForChat :: Text -> Text -> IO [Text]
+splitMessageForChat _openRouterKey message = do
+ let parts = splitOnParagraphs message
+ pure parts
+
+splitOnParagraphs :: Text -> [Text]
+splitOnParagraphs message
+ | Text.length message < 300 = [message]
+ | otherwise =
+ let paragraphs = filter (not <. Text.null) (map Text.strip (Text.splitOn "\n\n" message))
+ in if length paragraphs <= 1
+ then [message]
+ else mergeTooShort paragraphs
+
+mergeTooShort :: [Text] -> [Text]
+mergeTooShort [] = []
+mergeTooShort [x] = [x]
+mergeTooShort (x : y : rest)
+ | Text.length x < 100 = mergeTooShort ((x <> "\n\n" <> y) : rest)
+ | otherwise = x : mergeTooShort (y : rest)
+
+enqueueMultipart :: Maybe Text -> Int -> Maybe Int -> [Text] -> Maybe Text -> IO ()
+enqueueMultipart _ _ _ [] _ = pure ()
+enqueueMultipart mUid chatId mThreadId parts msgType = do
+ forM_ (zip [0 ..] parts) <| \(i :: Int, part) -> do
+ if i == 0
+ then void <| Messages.enqueueImmediate mUid chatId mThreadId part msgType Nothing
+ else do
+ let delaySeconds = fromIntegral (i * 2)
+ void <| Messages.enqueueDelayed mUid chatId mThreadId part delaySeconds msgType Nothing
+
+shouldEngageInGroup :: Text -> Text -> IO Bool
+shouldEngageInGroup openRouterKey messageText = do
+ let gemini = Provider.defaultOpenRouter openRouterKey "google/gemini-2.0-flash-001"
+ result <-
+ Provider.chat
+ gemini
+ []
+ [ Provider.Message
+ Provider.System
+ ( Text.unlines
+ [ "You are a classifier that decides if an AI assistant named 'Ava' should respond to a message in a group chat.",
+ "You may be given recent conversation context to help decide.",
+ "Respond with ONLY 'yes' or 'no' (lowercase, nothing else).",
+ "",
+ "Say 'yes' if:",
+ "- The message is a direct question Ava could answer",
+ "- The message contains a factual error worth correcting",
+ "- The message mentions Ava or asks for help",
+ "- The message shares a link or document to analyze",
+ "- The message is a follow-up to a conversation Ava was just participating in",
+ "- The user is clearly talking to Ava based on context (e.g. Ava just responded)",
+ "",
+ "Say 'no' if:",
+ "- It's casual banter or chit-chat between people (not involving Ava)",
+ "- It's a greeting or farewell not directed at Ava",
+ "- It's an inside joke or personal conversation between humans",
+ "- It doesn't require or benefit from Ava's input"
+ ]
+ )
+ Nothing
+ Nothing,
+ Provider.Message Provider.User messageText Nothing Nothing
+ ]
+ case result of
+ Left err -> do
+ putText <| "Engagement check failed: " <> err
+ pure True
+ Right msg -> do
+ let response = Text.toLower (Text.strip (Provider.msgContent msg))
+ pure (response == "yes" || response == "y")
+
+checkOllama :: IO (Either Text ())
+checkOllama = do
+ ollamaUrl <- fromMaybe "http://localhost:11434" </ lookupEnv "OLLAMA_URL"
+ let url = ollamaUrl <> "/api/tags"
+ result <-
+ try <| do
+ req <- HTTP.parseRequest url
+ HTTP.httpLBS req
+ case result of
+ Left (e :: SomeException) ->
+ pure (Left ("Ollama not running: " <> tshow e))
+ Right response -> do
+ let status = HTTP.getResponseStatusCode response
+ if status >= 200 && status < 300
+ then case Aeson.decode (HTTP.getResponseBody response) of
+ Just (Aeson.Object obj) -> case KeyMap.lookup "models" obj of
+ Just (Aeson.Array models) ->
+ let names = [n | Aeson.Object m <- toList models, Just (Aeson.String n) <- [KeyMap.lookup "name" m]]
+ hasNomic = any ("nomic-embed-text" `Text.isInfixOf`) names
+ in if hasNomic
+ then pure (Right ())
+ else pure (Left "nomic-embed-text model not found")
+ _ -> pure (Left "Invalid Ollama response")
+ _ -> pure (Left "Failed to parse Ollama response")
+ else pure (Left ("Ollama HTTP error: " <> tshow status))
+
+pullEmbeddingModel :: IO (Either Text ())
+pullEmbeddingModel = do
+ ollamaUrl <- fromMaybe "http://localhost:11434" </ lookupEnv "OLLAMA_URL"
+ let url = ollamaUrl <> "/api/pull"
+ putText "Pulling nomic-embed-text model (this may take a few minutes)..."
+ req0 <- HTTP.parseRequest url
+ let body = Aeson.object ["name" .= ("nomic-embed-text" :: Text)]
+ req =
+ HTTP.setRequestMethod "POST"
+ <| HTTP.setRequestHeader "Content-Type" ["application/json"]
+ <| HTTP.setRequestBodyLBS (Aeson.encode body)
+ <| HTTP.setRequestResponseTimeout (HTTPClient.responseTimeoutMicro (600 * 1000000))
+ <| req0
+ result <- try (HTTP.httpLBS req)
+ case result of
+ Left (e :: SomeException) ->
+ pure (Left ("Failed to pull model: " <> tshow e))
+ Right response -> do
+ let status = HTTP.getResponseStatusCode response
+ if status >= 200 && status < 300
+ then do
+ putText "nomic-embed-text model ready"
+ pure (Right ())
+ else pure (Left ("Pull failed: HTTP " <> tshow status))
+
+ensureOllama :: IO ()
+ensureOllama = do
+ checkResult <- checkOllama
+ case checkResult of
+ Right () -> putText "Ollama ready with nomic-embed-text"
+ Left err
+ | "not running" `Text.isInfixOf` err -> do
+ putText <| "Error: " <> err
+ putText "Please start Ollama: ollama serve"
+ exitFailure
+ | "not found" `Text.isInfixOf` err -> do
+ putText "nomic-embed-text model not found, pulling..."
+ pullResult <- pullEmbeddingModel
+ case pullResult of
+ Right () -> pure ()
+ Left pullErr -> do
+ putText <| "Error: " <> pullErr
+ exitFailure
+ | otherwise -> do
+ putText <| "Ollama error: " <> err
+ exitFailure
+
+startBot :: Maybe Text -> IO ()
+startBot maybeToken = do
+ token <- case maybeToken of
+ Just t -> pure t
+ Nothing -> do
+ envToken <- lookupEnv "TELEGRAM_BOT_TOKEN"
+ case envToken of
+ Just t -> pure (Text.pack t)
+ Nothing -> do
+ putText "Error: TELEGRAM_BOT_TOKEN not set and no --token provided"
+ exitFailure
+
+ putText <| "AVA data root: " <> Text.pack Paths.avaDataRoot
+ putText <| "Skills dir: " <> Text.pack Paths.skillsDir
+ putText <| "Outreach dir: " <> Text.pack Paths.outreachDir
+
+ ensureOllama
+
+ allowedIds <- loadAllowedUserIds
+ kagiKey <- fmap Text.pack </ lookupEnv "KAGI_API_KEY"
+
+ apiKey <- lookupEnv "OPENROUTER_API_KEY"
+ case apiKey of
+ Nothing -> do
+ putText "Error: OPENROUTER_API_KEY not set"
+ exitFailure
+ Just key -> do
+ let orKey = Text.pack key
+ tgConfig = Types.defaultTelegramConfig token allowedIds kagiKey orKey
+ provider = Provider.defaultOpenRouter orKey "anthropic/claude-sonnet-4.5"
+ putText <| "Allowed user IDs: " <> tshow allowedIds
+ putText <| "Kagi search: " <> if isJust kagiKey then "enabled" else "disabled"
+ runTelegramBot tgConfig provider
+
+loadAllowedUserIds :: IO [Int]
+loadAllowedUserIds = do
+ maybeIds <- lookupEnv "ALLOWED_TELEGRAM_USER_IDS"
+ case maybeIds of
+ Nothing -> pure []
+ Just "*" -> pure []
+ Just idsStr -> do
+ let ids = mapMaybe (readMaybe <. Text.unpack <. Text.strip) (Text.splitOn "," (Text.pack idsStr))
+ pure ids
+
+handleOutreachCommand :: Types.TelegramConfig -> Int -> Maybe Int -> Text -> IO Bool
+handleOutreachCommand _tgConfig chatId mThreadId cmd
+ | "/review" `Text.isPrefixOf` cmd = do
+ pending <- Outreach.listDrafts Outreach.Pending
+ case pending of
+ [] -> do
+ _ <- Messages.enqueueImmediate Nothing chatId mThreadId "no pending outreach drafts" (Just "system") Nothing
+ pure True
+ (draft : _) -> do
+ let msg = formatDraftForReview draft
+ _ <- Messages.enqueueImmediate Nothing chatId mThreadId msg (Just "system") Nothing
+ pure True
+ | "/approve " `Text.isPrefixOf` cmd = do
+ let draftId = Text.strip (Text.drop 9 cmd)
+ result <- Outreach.approveDraft draftId
+ case result of
+ Left err -> do
+ _ <- Messages.enqueueImmediate Nothing chatId mThreadId ("error: " <> err) (Just "system") Nothing
+ pure True
+ Right draft -> do
+ _ <- Messages.enqueueImmediate Nothing chatId mThreadId ("approved: " <> Outreach.draftId draft) (Just "system") Nothing
+ pure True
+ | "/reject " `Text.isPrefixOf` cmd = do
+ let rest = Text.strip (Text.drop 8 cmd)
+ (draftId, reason) = case Text.breakOn " " rest of
+ (did, r) -> (did, if Text.null r then Nothing else Just (Text.strip r))
+ result <- Outreach.rejectDraft draftId reason
+ case result of
+ Left err -> do
+ _ <- Messages.enqueueImmediate Nothing chatId mThreadId ("error: " <> err) (Just "system") Nothing
+ pure True
+ Right draft -> do
+ let reasonMsg = maybe "" (" reason: " <>) (Outreach.draftRejectReason draft)
+ _ <- Messages.enqueueImmediate Nothing chatId mThreadId ("rejected: " <> Outreach.draftId draft <> reasonMsg) (Just "system") Nothing
+ pure True
+ | "/queue" `Text.isPrefixOf` cmd = do
+ count <- Outreach.getPendingCount
+ _ <- Messages.enqueueImmediate Nothing chatId mThreadId (tshow count <> " pending outreach drafts") (Just "system") Nothing
+ pure True
+ | otherwise = pure False
+
+formatDraftForReview :: Outreach.OutreachDraft -> Text
+formatDraftForReview draft =
+ Text.unlines
+ [ "*outreach draft*",
+ "",
+ "*id:* `" <> Outreach.draftId draft <> "`",
+ "*type:* " <> tshow (Outreach.draftType draft),
+ "*to:* " <> Outreach.draftRecipient draft,
+ maybe "" (\s -> "*subject:* " <> s <> "\n") (Outreach.draftSubject draft),
+ "*context:* " <> Outreach.draftContext draft,
+ "",
+ Outreach.draftBody draft,
+ "",
+ "reply `/approve " <> Outreach.draftId draft <> "` or `/reject " <> Outreach.draftId draft <> " [reason]`"
+ ]
generated by cgit v1.2.3 (git 2.25.1) at 2025-12-19 08:11:59 +0000