commit 1a0fa5ea4e410e377e8333401b0f56b38007b37e
Author: Ben Sima <ben@bensima.com>
Date: Thu Jan 1 14:59:09 2026
Add stop/cancel command to halt orchestrator work (t-280.2.3)
Implemented by coder subagent, reviewed and committed manually.
## Changes
### Telegram.hs
- Added handleStopCommand for 'stop', '/stop', 'cancel', '/cancel'
- Calls Orchestrator.stopOrchestrator to kill subprocess
- Shows inline keyboard: [Resume] [Discard] [Review]
### Orchestrator.hs
- Added StopResult type (StopSuccess taskId | StopNotRunning)
- Added osCurrentProcess field to track running subprocess
- Added stopOrchestrator: kills process group + terminates
- Added updateOrchestratorProcess helper
- Updated runCoder/runBuild/runReviewer to register process handles
- Set create_group=True to enable killing child processes
### Actions.hs
- stop_resume: Marks task in-progress, tells user to restart
- stop_discard: Runs git checkout + clean to discard changes
- stop_review: Provides guidance on manual review
Task-Id: t-280.2.3
diff --git a/Omni/Agent/Telegram.hs b/Omni/Agent/Telegram.hs
index 4a41c497..9c75b307 100644
--- a/Omni/Agent/Telegram.hs
+++ b/Omni/Agent/Telegram.hs
@@ -64,6 +64,7 @@ module Omni.Agent.Telegram
handleRemindersCommand,
handleReadyCommand,
handleStatusCommand,
+ handleStopCommand,
-- * System Prompt
telegramSystemPrompt,
@@ -817,8 +818,9 @@ handleAuthorizedMessage tgConfig provider engineCfg msg uid userName chatId = do
remindersHandled <- if outreachHandled then pure True else handleRemindersCommand uid chatId threadId msgText
readyHandled <- if remindersHandled then pure True else handleReadyCommand chatId threadId msgText
statusHandled <- if readyHandled then pure True else handleStatusCommand chatId threadId msgText
+ stopHandled <- if statusHandled then pure True else handleStopCommand tgConfig chatId threadId msgText
- unless statusHandled <| handleAuthorizedMessageContinued tgConfig provider engineCfg msg uid userName chatId
+ unless stopHandled <| handleAuthorizedMessageContinued tgConfig provider engineCfg msg uid userName chatId
handleAuthorizedMessageContinued ::
Types.TelegramConfig ->
@@ -1005,8 +1007,9 @@ handleAuthorizedMessageBatch tgConfig provider engineCfg msg uid userName chatId
remindersHandled <- if outreachHandled then pure True else handleRemindersCommand uid chatId threadId batchedText
readyHandled <- if remindersHandled then pure True else handleReadyCommand chatId threadId batchedText
statusHandled <- if readyHandled then pure True else handleStatusCommand chatId threadId batchedText
+ stopHandled <- if statusHandled then pure True else handleStopCommand tgConfig chatId threadId batchedText
- unless statusHandled <| handleAuthorizedMessageBatchContinued tgConfig provider engineCfg msg uid userName chatId batchedText
+ unless stopHandled <| handleAuthorizedMessageBatchContinued tgConfig provider engineCfg msg uid userName chatId batchedText
handleAuthorizedMessageBatchContinued ::
Types.TelegramConfig ->
@@ -1816,6 +1819,28 @@ handleStatusCommand chatId mThreadId cmd
Orchestrator.PhaseComplete _ -> "Complete"
Orchestrator.PhaseFailed _ -> "Failed"
+-- | Handle stop/cancel command - stop current orchestrator work
+handleStopCommand :: Types.TelegramConfig -> Int -> Maybe Int -> Text -> IO Bool
+handleStopCommand tgConfig chatId mThreadId cmd
+ | cmd == "stop" || cmd == "/stop" || cmd == "cancel" || cmd == "/cancel" || cmd == "stop work" = do
+ result <- Orchestrator.stopOrchestrator chatId
+ case result of
+ Orchestrator.StopNotRunning -> do
+ _ <- Messages.enqueueImmediate Nothing chatId mThreadId "I'm not working on anything right now." (Just "system") Nothing
+ pure True
+ Orchestrator.StopSuccess taskId -> do
+ let msg = "⛔ Stopped work on " <> taskId <> ". Changes are uncommitted."
+ keyboard =
+ Types.InlineKeyboardMarkup
+ [ [ Types.InlineKeyboardButton "▶️ Resume" (Just ("stop_resume:" <> taskId)) Nothing,
+ Types.InlineKeyboardButton "🗑️ Discard" (Just ("stop_discard:" <> taskId)) Nothing,
+ Types.InlineKeyboardButton "👁️ Review" (Just ("stop_review:" <> taskId)) Nothing
+ ]
+ ]
+ _ <- sendMessageWithKeyboard tgConfig chatId msg keyboard
+ pure True
+ | otherwise = pure False
+
-- | Handle /reminders commands
-- /reminders - List active reminders
-- /reminders add <time> <message> - Add new reminder
diff --git a/Omni/Agent/Telegram/Actions.hs b/Omni/Agent/Telegram/Actions.hs
index e889dd01..97a57b7f 100644
--- a/Omni/Agent/Telegram/Actions.hs
+++ b/Omni/Agent/Telegram/Actions.hs
@@ -12,6 +12,7 @@
-- : out omni-agent-telegram-actions
-- : dep aeson
-- : dep containers
+-- : dep process
module Omni.Agent.Telegram.Actions
( -- * Core Types
Action (..),
@@ -40,7 +41,10 @@ import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Omni.Agent.Subagent as Subagent
import qualified Omni.Agent.Telegram.Reminders as Reminders
+import qualified Omni.Task.Core as Task
import qualified Omni.Test as Test
+import qualified System.Exit as Exit
+import qualified System.Process as Process
main :: IO ()
main = Test.run test
@@ -68,6 +72,9 @@ test =
("reminder_complete" `elem` keys) Test.@=? True
("reminder_snooze_1h" `elem` keys) Test.@=? True
("reminder_snooze_1d" `elem` keys) Test.@=? True
+ ("stop_resume" `elem` keys) Test.@=? True
+ ("stop_discard" `elem` keys) Test.@=? True
+ ("stop_review" `elem` keys) Test.@=? True
]
-- | Input provided to an action execution
@@ -122,7 +129,10 @@ actionRegistry =
("subagent_reject", rejectSubagentAction),
("reminder_complete", completeReminderAction),
("reminder_snooze_1h", snooze1hAction),
- ("reminder_snooze_1d", snooze1dAction)
+ ("reminder_snooze_1d", snooze1dAction),
+ ("stop_resume", stopResumeAction),
+ ("stop_discard", stopDiscardAction),
+ ("stop_review", stopReviewAction)
]
-- | Look up an action by its ID
@@ -290,3 +300,77 @@ snooze1dAction =
arOutcome = ActionFailed "reminder not found"
}
}
+
+-- | Action to resume work on a stopped task
+-- Re-spawns the orchestrator for the task
+stopResumeAction :: Action
+stopResumeAction =
+ Action
+ { actionId = "stop_resume",
+ actionExecute = \input -> do
+ let taskId = aiPayload input
+ -- Mark task as in-progress again
+ Task.updateTaskStatus taskId Task.InProgress []
+ pure
+ ActionResult
+ { arUserMessage = "[Resume: " <> taskId <> "]",
+ arAssistantMessage = "▶️ Resuming work on " <> taskId <> ". Use `work on " <> taskId <> "` to restart the orchestrator.",
+ arOutcome = ActionSuccess
+ }
+ }
+
+-- | Action to discard changes from a stopped task
+-- Runs git checkout to revert uncommitted changes
+stopDiscardAction :: Action
+stopDiscardAction =
+ Action
+ { actionId = "stop_discard",
+ actionExecute = \input -> do
+ let taskId = aiPayload input
+ workDir = "/home/ben/omni/ava"
+ -- Run git checkout to discard changes
+ (_, _, _, ph) <- Process.createProcess
+ (Process.proc "git" ["checkout", "."])
+ { Process.cwd = Just workDir }
+ exitCode <- Process.waitForProcess ph
+ case exitCode of
+ Exit.ExitSuccess -> do
+ -- Also clean up any untracked files from the task
+ _ <- Process.createProcess
+ (Process.proc "git" ["clean", "-fd"])
+ { Process.cwd = Just workDir }
+ pure
+ ActionResult
+ { arUserMessage = "[Discard: " <> taskId <> "]",
+ arAssistantMessage = "🗑️ Discarded all uncommitted changes for " <> taskId <> ".",
+ arOutcome = ActionSuccess
+ }
+ Exit.ExitFailure code ->
+ pure
+ ActionResult
+ { arUserMessage = "[Discard: " <> taskId <> " (failed)]",
+ arAssistantMessage = "❌ Failed to discard changes (git exit " <> tshow code <> "). You may need to do this manually.",
+ arOutcome = ActionFailed ("git checkout failed: " <> tshow code)
+ }
+ }
+
+-- | Action to review changes manually
+-- Just provides guidance to the user
+stopReviewAction :: Action
+stopReviewAction =
+ Action
+ { actionId = "stop_review",
+ actionExecute = \input -> do
+ let taskId = aiPayload input
+ pure
+ ActionResult
+ { arUserMessage = "[Review: " <> taskId <> "]",
+ arAssistantMessage =
+ "👁️ Changes for " <> taskId <> " are ready for manual review.\n\n"
+ <> "• `git diff` to see changes\n"
+ <> "• `git add -p` to stage selectively\n"
+ <> "• `git commit -m \"...\"` when ready\n"
+ <> "• `git checkout .` to discard",
+ arOutcome = ActionSuccess
+ }
+ }
diff --git a/Omni/Agent/Telegram/Orchestrator.hs b/Omni/Agent/Telegram/Orchestrator.hs
index d063d17e..78a7158d 100644
--- a/Omni/Agent/Telegram/Orchestrator.hs
+++ b/Omni/Agent/Telegram/Orchestrator.hs
@@ -35,6 +35,10 @@ module Omni.Agent.Telegram.Orchestrator
OrchestratorStatus (..),
getActiveOrchestrators,
getOrchestratorStatus,
+
+ -- * Stopping
+ stopOrchestrator,
+ StopResult (..),
-- * Testing
main,
@@ -87,6 +91,7 @@ defaultConfig taskId chatId =
}
-- | Status of an active orchestrator job
+-- Note: osCurrentProcess is not shown (ProcessHandle has no Show instance)
data OrchestratorStatus = OrchestratorStatus
{ osTaskId :: Text,
osTaskTitle :: Text,
@@ -94,9 +99,15 @@ data OrchestratorStatus = OrchestratorStatus
osPhase :: OrchestratorPhase,
osIteration :: Int,
osMaxIterations :: Int,
- osStartedAt :: Time.UTCTime
+ osStartedAt :: Time.UTCTime,
+ osCurrentProcess :: Maybe Process.ProcessHandle
}
- deriving (Show, Generic)
+
+-- | Result of stopping an orchestrator
+data StopResult
+ = StopSuccess Text -- Task ID that was stopped
+ | StopNotRunning -- No orchestrator was running
+ deriving (Show, Eq)
-- | Global registry of active orchestrators (keyed by chatId)
{-# NOINLINE activeOrchestrators #-}
@@ -113,6 +124,11 @@ updateOrchestratorPhase :: Int -> OrchestratorPhase -> Int -> IO ()
updateOrchestratorPhase chatId newPhase iteration = STM.atomically <|
STM.modifyTVar' activeOrchestrators (Map.adjust (\s -> s { osPhase = newPhase, osIteration = iteration }) chatId)
+-- | Update the current process handle for an orchestrator
+updateOrchestratorProcess :: Int -> Maybe Process.ProcessHandle -> IO ()
+updateOrchestratorProcess chatId mHandle = STM.atomically <|
+ STM.modifyTVar' activeOrchestrators (Map.adjust (\s -> s { osCurrentProcess = mHandle }) chatId)
+
-- | Remove an orchestrator from active registry
unregisterOrchestrator :: Int -> IO ()
unregisterOrchestrator chatId = STM.atomically <|
@@ -126,6 +142,27 @@ getActiveOrchestrators = Map.elems <$> STM.readTVarIO activeOrchestrators
getOrchestratorStatus :: Int -> IO (Maybe OrchestratorStatus)
getOrchestratorStatus chatId = Map.lookup chatId <$> STM.readTVarIO activeOrchestrators
+-- | Stop a running orchestrator by killing its subprocess
+-- Returns the task ID that was stopped, or Nothing if none was running
+stopOrchestrator :: Int -> IO StopResult
+stopOrchestrator chatId = do
+ mStatus <- getOrchestratorStatus chatId
+ case mStatus of
+ Nothing -> pure StopNotRunning
+ Just status -> do
+ -- Kill the current subprocess if any
+ case osCurrentProcess status of
+ Just ph -> do
+ -- Use interruptProcessGroupOf to also kill child processes
+ Process.interruptProcessGroupOf ph
+ -- Give it a moment, then force terminate
+ threadDelay 100000 -- 100ms
+ Process.terminateProcess ph
+ Nothing -> pure ()
+ -- Unregister the orchestrator
+ unregisterOrchestrator chatId
+ pure (StopSuccess (osTaskId status))
+
-- | Current phase of the orchestrator
data OrchestratorPhase
= PhaseStarting
@@ -194,7 +231,8 @@ spawnOrchestrator tgCfg cfg = do
osPhase = PhaseStarting,
osIteration = 0,
osMaxIterations = orchMaxIterations cfg,
- osStartedAt = now
+ osStartedAt = now,
+ osCurrentProcess = Nothing
}
registerOrchestrator status
@@ -307,15 +345,23 @@ runCoder cfg = do
-- Inherit stdout/stderr so output goes to parent (visible in logs)
-- and we don't block on full pipe buffers
Process.std_out = Process.Inherit,
- Process.std_err = Process.Inherit
+ Process.std_err = Process.Inherit,
+ -- Create new process group so we can kill children
+ Process.create_group = True
}
(_, _, _, ph) <- Process.createProcess proc
+ -- Register the process handle so it can be stopped
+ updateOrchestratorProcess (orchChatId cfg) (Just ph)
+
-- Wait with timeout
let timeoutMicros = orchCoderTimeout cfg * 1000000
mExit <- Timeout.timeout timeoutMicros (Process.waitForProcess ph)
+ -- Clear the process handle
+ updateOrchestratorProcess (orchChatId cfg) Nothing
+
case mExit of
Nothing -> do
-- Timeout - kill process
@@ -337,12 +383,20 @@ runBuild cfg = do
proc = (Process.proc "bild" [Text.unpack namespace])
{ Process.cwd = Just (orchWorkDir cfg),
Process.std_out = Process.Inherit,
- Process.std_err = Process.Inherit
+ Process.std_err = Process.Inherit,
+ Process.create_group = True
}
(_, _, _, ph) <- Process.createProcess proc
+
+ -- Register the process handle
+ updateOrchestratorProcess (orchChatId cfg) (Just ph)
+
exitCode <- Process.waitForProcess ph
+ -- Clear the process handle
+ updateOrchestratorProcess (orchChatId cfg) Nothing
+
case exitCode of
Exit.ExitSuccess -> pure (Right ())
Exit.ExitFailure code ->
@@ -355,15 +409,22 @@ runReviewer cfg = do
let proc = (Process.proc "./Omni/Ide/pi-review.sh" [Text.unpack (orchTaskId cfg)])
{ Process.cwd = Just (orchWorkDir cfg),
Process.std_out = Process.Inherit,
- Process.std_err = Process.Inherit
+ Process.std_err = Process.Inherit,
+ Process.create_group = True
}
(_, _, _, ph) <- Process.createProcess proc
+ -- Register the process handle
+ updateOrchestratorProcess (orchChatId cfg) (Just ph)
+
-- Wait with timeout
let timeoutMicros = orchReviewerTimeout cfg * 1000000
mExit <- Timeout.timeout timeoutMicros (Process.waitForProcess ph)
+ -- Clear the process handle
+ updateOrchestratorProcess (orchChatId cfg) Nothing
+
case mExit of
Nothing -> do
Process.terminateProcess ph
diff --git a/Omni/Agent/Telegram/Telegram.hs b/Omni/Agent/Telegram/Telegram.hs
new file mode 100644
index 00000000..9c75b307
--- /dev/null
+++ b/Omni/Agent/Telegram/Telegram.hs
@@ -0,0 +1,1984 @@
+{-# LANGUAGE LambdaCase #-}
+{-# 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 directory
+-- : dep http-conduit
+-- : dep mustache
+-- : 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,
+ sendMessageWithKeyboard,
+ editMessage,
+ answerCallbackQuery,
+ 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,
+ handleRemindersCommand,
+ handleReadyCommand,
+ handleStatusCommand,
+ handleStopCommand,
+
+ -- * 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 Data.IORef (newIORef, readIORef, writeIORef)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as TE
+import Data.Time (UTCTime, getCurrentTime, utcToLocalTime)
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import Data.Time.LocalTime (getCurrentTimeZone, minutesToTimeZone)
+import qualified Network.HTTP.Client as HTTPClient
+import qualified Network.HTTP.Simple as HTTP
+import qualified Omni.Agent.AuditLog as AuditLog
+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.Prompts.Core as Prompts
+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.Subagent.Jobs as Jobs
+import qualified Omni.Agent.Telegram.Actions as Actions
+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.Orchestrator as Orchestrator
+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.AvaLogs as AvaLogs
+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.Tasks as Tasks
+import qualified Omni.Task.Core as Task
+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.Ava.Trace as Trace
+import qualified Omni.Test as Test
+import System.Environment (lookupEnv)
+import Text.Printf (printf)
+
+safePutText :: Text -> IO ()
+safePutText msg = do
+ result <- try @SomeException (putText msg)
+ case result of
+ Left _ -> putText "[log encoding error - message contained unrepresentable characters]"
+ Right () -> pure ()
+
+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
+
+-- | Load system prompt from template (required)
+loadTelegramSystemPrompt :: IO Text
+loadTelegramSystemPrompt = do
+ result <- Prompts.renderPrompt "agents/telegram/system" (Aeson.object [])
+ case result of
+ Right prompt -> pure prompt
+ Left err -> panic <| "Failed to load telegram system prompt: " <> err
+
+-- | Legacy fallback prompt (deprecated - use template instead)
+telegramSystemPrompt :: Text
+telegramSystemPrompt = telegramSystemPromptFallback
+
+telegramSystemPromptFallback :: Text
+telegramSystemPromptFallback =
+ 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.",
+ "",
+ "## TELEGRAM FORMATTING (CRITICAL)",
+ "",
+ "you MUST use telegram MarkdownV2 syntax. this is DIFFERENT from standard markdown:",
+ "",
+ "CORRECT telegram syntax:",
+ " *bold* (SINGLE asterisks only)",
+ " _italic_ (underscores)",
+ " `code` (backticks)",
+ " ```pre``` (triple backticks)",
+ " [link text](url)",
+ "",
+ "WRONG - DO NOT USE:",
+ " **double asterisks** - WRONG, use *single*",
+ " # headers - WRONG, breaks rendering",
+ " - bullet points - WRONG, breaks rendering",
+ " * list items - WRONG, conflicts with bold",
+ "",
+ "for lists, just use plain text with numbers or dashes inline.",
+ "",
+ "## 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'",
+ "",
+ "## subagent delegation",
+ "",
+ "delegate external actions to subagents rather than executing them directly.",
+ "this allows you to monitor progress, debug failures, and respawn with adjusted parameters.",
+ "",
+ "when to use subagents:",
+ "- code changes: spawn coder subagent (requires namespace and context)",
+ "- research tasks: spawn researcher subagent",
+ "- web scraping: spawn webcrawler subagent",
+ "- general multi-step tasks: spawn general subagent",
+ "- custom needs: spawn custom role with specific tools",
+ "",
+ "customize each spawn with:",
+ "- tools: override default tools with specific tool names",
+ "- system_prompt: additional instructions for this specific task",
+ "- guardrails: per-spawn limits (max_cost_cents, max_tokens, max_iterations)",
+ "",
+ "if a subagent fails, analyze the failure, adjust parameters, and respawn.",
+ "",
+ "## 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
+ <> "&allowed_updates="
+ <> "%5B%22message%22%2C%22callback_query%22%5D"
+ 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)
+
+-- | 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,
+ "parse_mode" .= ("Markdown" :: 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
+
+-- | Create the send function for the message dispatch loop.
+-- This handles different message types, adding inline keyboards for reminders.
+makeMessageSendFn :: Types.TelegramConfig -> Messages.ScheduledMessage -> IO (Maybe Int)
+makeMessageSendFn cfg msg =
+ case Messages.smMessageType msg of
+ Just "reminder" -> sendReminderWithButtons cfg msg
+ _ -> sendMessageReturningId cfg (Messages.smChatId msg) (Messages.smThreadId msg) (Messages.smContent msg)
+
+-- | Send a reminder message with Complete/Snooze buttons
+sendReminderWithButtons :: Types.TelegramConfig -> Messages.ScheduledMessage -> IO (Maybe Int)
+sendReminderWithButtons cfg msg = do
+ -- Extract reminder ID from correlation_id (which we set when enqueueing)
+ let reminderId = fromMaybe "" (Messages.smCorrelationId msg)
+ -- Clean up the message content (remove the [reminder_id:X] tag if present)
+ content = cleanReminderContent (Messages.smContent msg)
+ keyboard =
+ Types.InlineKeyboardMarkup
+ [ [ Types.InlineKeyboardButton "✅ Complete" (Just ("reminder_complete:" <> reminderId)) Nothing,
+ Types.InlineKeyboardButton "⏰ 1h" (Just ("reminder_snooze_1h:" <> reminderId)) Nothing,
+ Types.InlineKeyboardButton "⏰ 1d" (Just ("reminder_snooze_1d:" <> reminderId)) Nothing
+ ]
+ ]
+ sendMessageWithKeyboard cfg (Messages.smChatId msg) content keyboard
+
+-- | Remove the [reminder_id:X] tag from reminder messages
+cleanReminderContent :: Text -> Text
+cleanReminderContent content =
+ -- Remove the "[reminder_id:123]" suffix we added for tracking
+ let lines' = Text.lines content
+ cleanedLines = filter (not <. Text.isPrefixOf "[reminder_id:") lines'
+ in Text.unlines cleanedLines
+
+-- | 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 =
+ 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..."
+
+ cleanedCount <- Memory.withMemoryDb Trace.cleanupOldTraces
+ when (cleanedCount > 0)
+ <| putText
+ <| "Cleaned up "
+ <> tshow cleanedCount
+ <> " old tool traces"
+
+ 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 = makeMessageSendFn 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,
+ Engine.engineOnToolTrace = \toolName input output durationMs -> do
+ now <- getCurrentTime
+ let truncatedOutput = Text.take 1000000 output
+ traceRecord =
+ Trace.TraceRecord
+ { Trace.trcId = "",
+ Trace.trcCreatedAt = tshow now,
+ Trace.trcToolName = toolName,
+ Trace.trcInput = input,
+ Trace.trcOutput = truncatedOutput,
+ Trace.trcDurationMs = durationMs,
+ Trace.trcUserId = Nothing,
+ Trace.trcChatId = Nothing
+ }
+ tid <- Memory.withMemoryDb <| \conn -> Trace.insertTrace conn traceRecord
+ pure (Just tid)
+ }
+
+ 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
+ let hasCallbackField = case rawUpdate of
+ Aeson.Object obj -> isJust (KeyMap.lookup "callback_query" obj)
+ _ -> False
+ when hasCallbackField <| putText <| "Raw callback update received: " <> Text.take 300 (tshow rawUpdate)
+ case Types.parseCallbackQuery rawUpdate of
+ Just cq -> do
+ putText <| "Parsed callback query: " <> Types.cqData cq
+ 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
+ safePutText <| "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
+ hasCallback = case rawUpdate of
+ Aeson.Object obj -> isJust (KeyMap.lookup "callback_query" obj)
+ _ -> False
+ if hasCallback
+ then putText <| "Failed to parse callback_query: " <> Text.take 500 (tshow rawUpdate)
+ else 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
+
+-- | 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
+ result <- try @SomeException <| handleCallbackQueryInner tgConfig cq chatId userId callbackData
+ case result of
+ Left err -> putText <| "Callback handler error: " <> tshow err
+ Right () -> pure ()
+
+handleCallbackQueryInner :: Types.TelegramConfig -> Types.CallbackQuery -> Int -> Int -> Text -> IO ()
+handleCallbackQueryInner tgConfig cq chatId userId callbackData = do
+ if not (Types.isUserAllowed tgConfig userId)
+ then do
+ answerCallbackQuery tgConfig (Types.cqId cq) (Just "Not authorized")
+ putText <| "Unauthorized callback from user " <> tshow userId
+ else do
+ let (actionId, payload) = Actions.parseCallbackData callbackData
+ input = Actions.ActionInput userId chatId payload
+ result <- Actions.executeAction actionId input
+ case result of
+ Nothing -> do
+ answerCallbackQuery tgConfig (Types.cqId cq) (Just "Unknown action")
+ putText <| "Unknown callback: " <> callbackData
+ Just ar -> do
+ -- Log to conversation history
+ _ <- Memory.saveMessage (tshow userId) chatId Memory.UserRole Nothing (Actions.arUserMessage ar)
+ _ <- Memory.saveMessage (tshow userId) chatId Memory.AssistantRole Nothing (Actions.arAssistantMessage ar)
+ -- Send response
+ sendMessage tgConfig chatId (Actions.arAssistantMessage ar)
+ answerCallbackQuery tgConfig (Types.cqId cq) (Just "Done")
+
+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
+ unless (Types.isGroupChat msg) <| Reminders.recordUserChat uid chatId
+
+ let msgText = Types.tmText msg
+ threadId = Types.tmThreadId msg
+
+ -- Check for special commands before LLM processing
+ outreachHandled <- handleOutreachCommand tgConfig chatId threadId msgText
+ remindersHandled <- if outreachHandled then pure True else handleRemindersCommand uid chatId threadId msgText
+ readyHandled <- if remindersHandled then pure True else handleReadyCommand chatId threadId msgText
+ statusHandled <- if readyHandled then pure True else handleStatusCommand chatId threadId msgText
+ stopHandled <- if statusHandled then pure True else handleStopCommand tgConfig chatId threadId msgText
+
+ unless stopHandled <| 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"
+
+ now <- getCurrentTime
+ _ <- forkIO <| Memory.saveChatHistoryEntry chatId (Just uid) "user" (Just userName) userMessage now
+
+ _ <-
+ forkIO <| do
+ entry <-
+ AuditLog.mkLogEntry
+ (AuditLog.SessionId (tshow chatId))
+ (AuditLog.AgentId "ava")
+ (Just userName)
+ AuditLog.UserMessage
+ (Aeson.String userMessage)
+ AuditLog.emptyMetadata
+ AuditLog.writeAvaLog entry
+
+ 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
+ unless (Types.isGroupChat msg) <| Reminders.recordUserChat uid chatId
+
+ let threadId = Types.tmThreadId msg
+
+ -- Check for special commands before LLM processing
+ outreachHandled <- handleOutreachCommand tgConfig chatId threadId batchedText
+ remindersHandled <- if outreachHandled then pure True else handleRemindersCommand uid chatId threadId batchedText
+ readyHandled <- if remindersHandled then pure True else handleReadyCommand chatId threadId batchedText
+ statusHandled <- if readyHandled then pure True else handleStatusCommand chatId threadId batchedText
+ stopHandled <- if statusHandled then pure True else handleStopCommand tgConfig chatId threadId batchedText
+
+ unless stopHandled <| handleAuthorizedMessageBatchContinued tgConfig provider engineCfg msg uid userName chatId batchedText
+
+handleAuthorizedMessageBatchContinued ::
+ Types.TelegramConfig ->
+ Provider.Provider ->
+ Engine.EngineConfig ->
+ Types.TelegramMessage ->
+ Text ->
+ Text ->
+ Int ->
+ Text ->
+ IO ()
+handleAuthorizedMessageBatchContinued tgConfig provider engineCfg msg uid userName chatId batchedText = 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 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"
+
+ now <- getCurrentTime
+ _ <- forkIO <| Memory.saveChatHistoryEntry chatId (Just uid) "user" (Just userName) userMessage now
+
+ _ <-
+ forkIO <| do
+ entry <-
+ AuditLog.mkLogEntry
+ (AuditLog.SessionId (tshow chatId))
+ (AuditLog.AgentId "ava")
+ (Just userName)
+ AuditLog.UserMessage
+ (Aeson.String userMessage)
+ AuditLog.emptyMetadata
+ AuditLog.writeAvaLog entry
+
+ 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
+
+ lastTraceRef <- newIORef (Nothing :: Maybe (Text, Text))
+ let engineCfgWithTrace =
+ engineCfg
+ { Engine.engineOnToolTrace = \toolName input output durationMs -> do
+ maybeTid <- Engine.engineOnToolTrace engineCfg toolName input output durationMs
+ case maybeTid of
+ Just tid -> writeIORef lastTraceRef (Just (tid, toolName))
+ Nothing -> pure ()
+ pure maybeTid
+ }
+
+ 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 ""
+
+ -- Get active subagent status for context
+ subagentSummary <- Jobs.getActiveJobsSummary chatId
+ let subagentContext =
+ if isBenAuthorized userName && subagentSummary /= "No active or recent subagents."
+ then
+ Text.unlines
+ [ "",
+ "## Subagent Status",
+ "",
+ subagentSummary,
+ "You can discuss subagent progress, errors, or results with the user."
+ ]
+ else ""
+
+ basePrompt <- loadTelegramSystemPrompt
+
+ let systemPrompt =
+ basePrompt
+ <> "\n\n## Current Date and Time\n"
+ <> timeStr
+ <> chatContext
+ <> hledgerContext
+ <> emailContext
+ <> subagentContext
+ <> "\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
+ ]
+ subagentToolList =
+ if isBenAuthorized userName
+ then
+ let keys =
+ Subagent.SubagentApiKeys
+ { Subagent.subagentOpenRouterKey = Types.tgOpenRouterApiKey tgConfig,
+ Subagent.subagentKagiKey = Types.tgKagiApiKey tgConfig
+ }
+ 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 (Types.tmThreadId msg) approvalCallback
+ else []
+ auditLogTools =
+ [AvaLogs.readAvaLogsTool | isBenAuthorized userName]
+ <> [AvaLogs.searchChatHistoryTool]
+ taskTools =
+ if isBenAuthorized userName
+ then
+ let taskCtx =
+ Tasks.TaskToolContext
+ { Tasks.ttcTelegramConfig = tgConfig,
+ Tasks.ttcChatId = chatId,
+ Tasks.ttcThreadId = Types.tmThreadId msg
+ }
+ in [ Tasks.workOnTaskTool taskCtx,
+ Tasks.listReadyTasksTool,
+ Tasks.showTaskTool,
+ Tasks.updateTaskStatusTool,
+ Tasks.createTaskTool,
+ Tasks.addTaskCommentTool,
+ Tasks.listTasksTool,
+ Tasks.taskStatsTool,
+ Tasks.taskTreeTool
+ ]
+ else []
+ tools = memoryTools <> searchTools <> webReaderTools <> pdfTools <> notesTools <> calendarTools <> todoTools <> messageTools <> hledgerTools <> emailTools <> pythonTools <> httpTools <> outreachTools <> feedbackTools <> fileTools <> skillsTools <> subagentToolList <> auditLogTools <> taskTools
+
+ 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 engineCfgWithTrace provider agentCfg userMessage
+
+ lastTrace <- readIORef lastTraceRef
+ maybeWebUrl <- lookupEnv "AVA_WEB_URL"
+ let traceLink = formatTraceLink lastTrace (Text.pack </ maybeWebUrl)
+
+ 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 baseResponse = Engine.resultFinalMessage agentResult
+ response = baseResponse <> traceLink
+ threadId = Types.tmThreadId msg
+ safePutText <| "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
+
+ unless (Text.null response) <| do
+ nowResp <- getCurrentTime
+ _ <- forkIO <| Memory.saveChatHistoryEntry chatId (Just uid) "assistant" (Just "Ava") response nowResp
+ _ <-
+ forkIO <| do
+ entry <-
+ AuditLog.mkLogEntry
+ (AuditLog.SessionId (tshow chatId))
+ (AuditLog.AgentId "ava")
+ Nothing
+ AuditLog.AssistantMessage
+ (Aeson.String response)
+ AuditLog.emptyMetadata
+ AuditLog.writeAvaLog entry
+ pure ()
+
+ 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)
+
+formatTraceLink :: Maybe (Text, Text) -> Maybe Text -> Text
+formatTraceLink Nothing _ = ""
+formatTraceLink _ Nothing = ""
+formatTraceLink (Just (tid, toolName)) (Just baseUrl) =
+ "\n\n[view " <> toolName <> " trace](" <> baseUrl <> "/trace/" <> tid <> ")"
+
+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]`"
+ ]
+
+-- | Handle /reminders commands
+-- Commands:
+-- /reminders - List active reminders
+-- | Handle /ready command - show tasks ready for work
+handleReadyCommand :: Int -> Maybe Int -> Text -> IO Bool
+handleReadyCommand chatId mThreadId cmd
+ | cmd == "/ready" || cmd == "/ready " || cmd == "ready" || cmd == "show ready" || cmd == "what's ready" = do
+ readyTasks <- Task.getReadyTasks
+ let msg = if null readyTasks
+ then "No tasks ready right now."
+ else formatReadyTasks (take 10 readyTasks)
+ _ <- Messages.enqueueImmediate Nothing chatId mThreadId msg (Just "system") Nothing
+ pure True
+ | otherwise = pure False
+ where
+ formatReadyTasks :: [Task.Task] -> Text
+ formatReadyTasks tasks =
+ "📋 *Ready tasks:*\n\n"
+ <> Text.intercalate "\n" (map formatTask tasks)
+ <> "\n\n_Reply with a task ID to start work._"
+
+ formatTask :: Task.Task -> Text
+ formatTask t =
+ "• `" <> Task.taskId t <> "` [" <> tshow (Task.taskPriority t) <> "] "
+ <> Text.take 50 (Task.taskTitle t)
+ <> if Text.length (Task.taskTitle t) > 50 then "..." else ""
+
+-- | Handle /status command - show current orchestrator work
+handleStatusCommand :: Int -> Maybe Int -> Text -> IO Bool
+handleStatusCommand chatId mThreadId cmd
+ | cmd == "/status" || cmd == "/status " || cmd == "status" || cmd == "what are you working on" = do
+ mStatus <- Orchestrator.getOrchestratorStatus chatId
+ let msg = case mStatus of
+ Nothing -> "I'm not working on anything right now. Send me a task ID to start work."
+ Just status -> formatOrchestratorStatus status
+ _ <- Messages.enqueueImmediate Nothing chatId mThreadId msg (Just "system") Nothing
+ pure True
+ | otherwise = pure False
+ where
+ formatOrchestratorStatus :: Orchestrator.OrchestratorStatus -> Text
+ formatOrchestratorStatus status =
+ "🔧 *Working on " <> Orchestrator.osTaskId status <> "*\n"
+ <> Orchestrator.osTaskTitle status <> "\n\n"
+ <> "Phase: " <> formatPhaseSimple (Orchestrator.osPhase status) <> "\n"
+ <> "Iteration: " <> tshow (Orchestrator.osIteration status) <> "/" <> tshow (Orchestrator.osMaxIterations status)
+
+ formatPhaseSimple :: Orchestrator.OrchestratorPhase -> Text
+ formatPhaseSimple = \case
+ Orchestrator.PhaseStarting -> "Starting"
+ Orchestrator.PhaseCoder _ -> "Coder running"
+ Orchestrator.PhaseCoderDone _ -> "Coder done"
+ Orchestrator.PhaseVerifyBuild _ -> "Verifying build"
+ Orchestrator.PhaseBuildPassed _ -> "Build passed"
+ Orchestrator.PhaseBuildFailed _ _ -> "Build failed"
+ Orchestrator.PhaseReviewer _ -> "Reviewer running"
+ Orchestrator.PhaseReviewerApproved -> "Reviewer approved"
+ Orchestrator.PhaseReviewerRejected _ _ -> "Reviewer rejected"
+ Orchestrator.PhaseCommitting -> "Committing"
+ Orchestrator.PhaseComplete _ -> "Complete"
+ Orchestrator.PhaseFailed _ -> "Failed"
+
+-- | Handle stop/cancel command - stop current orchestrator work
+handleStopCommand :: Types.TelegramConfig -> Int -> Maybe Int -> Text -> IO Bool
+handleStopCommand tgConfig chatId mThreadId cmd
+ | cmd == "stop" || cmd == "/stop" || cmd == "cancel" || cmd == "/cancel" || cmd == "stop work" = do
+ result <- Orchestrator.stopOrchestrator chatId
+ case result of
+ Orchestrator.StopNotRunning -> do
+ _ <- Messages.enqueueImmediate Nothing chatId mThreadId "I'm not working on anything right now." (Just "system") Nothing
+ pure True
+ Orchestrator.StopSuccess taskId -> do
+ let msg = "⛔ Stopped work on " <> taskId <> ". Changes are uncommitted."
+ keyboard =
+ Types.InlineKeyboardMarkup
+ [ [ Types.InlineKeyboardButton "▶️ Resume" (Just ("stop_resume:" <> taskId)) Nothing,
+ Types.InlineKeyboardButton "🗑️ Discard" (Just ("stop_discard:" <> taskId)) Nothing,
+ Types.InlineKeyboardButton "👁️ Review" (Just ("stop_review:" <> taskId)) Nothing
+ ]
+ ]
+ _ <- sendMessageWithKeyboard tgConfig chatId msg keyboard
+ pure True
+ | otherwise = pure False
+
+-- | Handle /reminders commands
+-- /reminders - List active reminders
+-- /reminders add <time> <message> - Add new reminder
+-- /reminders delete <id> - Delete a reminder
+-- /reminders edit <id> <new message> - Edit reminder text
+handleRemindersCommand :: Text -> Int -> Maybe Int -> Text -> IO Bool
+handleRemindersCommand uid chatId mThreadId cmd
+ | cmd == "/reminders" || cmd == "/reminders " = do
+ reminders <- Reminders.listReminders uid
+ if null reminders
+ then do
+ _ <- Messages.enqueueImmediate (Just uid) chatId mThreadId "no active reminders" (Just "system") Nothing
+ pure True
+ else do
+ let msg = formatRemindersForDisplay reminders
+ _ <- Messages.enqueueImmediate (Just uid) chatId mThreadId msg (Just "system") Nothing
+ pure True
+ | "/reminders add " `Text.isPrefixOf` cmd = do
+ let rest = Text.strip (Text.drop 15 cmd)
+ case parseAddCommand rest of
+ Nothing -> do
+ _ <- Messages.enqueueImmediate (Just uid) chatId mThreadId "usage: /reminders add <time> <message>\nexamples:\n /reminders add tomorrow 3pm Pick up groceries\n /reminders add in 2 hours Check on laundry\n /reminders add Dec 31 5pm New Year prep" (Just "system") Nothing
+ pure True
+ Just (timeStr, message) -> do
+ mTime <- Reminders.parseReminderTime timeStr
+ case mTime of
+ Nothing -> do
+ _ <- Messages.enqueueImmediate (Just uid) chatId mThreadId ("couldn't parse time: \"" <> timeStr <> "\"\ntry: tomorrow 3pm, in 2 hours, Dec 31 5pm, or 2024-12-31 17:00") (Just "system") Nothing
+ pure True
+ Just dueAt -> do
+ reminder <- Reminders.addReminder uid dueAt message
+ let formattedTime = formatReminderTime (Reminders.reminderDueAt reminder)
+ _ <- Messages.enqueueImmediate (Just uid) chatId mThreadId ("✅ Reminder set for " <> formattedTime <> ": " <> Reminders.reminderMessage reminder) (Just "system") Nothing
+ pure True
+ | "/reminders delete " `Text.isPrefixOf` cmd = do
+ let idStr = Text.strip (Text.drop 18 cmd)
+ case readMaybe (Text.unpack idStr) of
+ Nothing -> do
+ _ <- Messages.enqueueImmediate (Just uid) chatId mThreadId "usage: /reminders delete <id>" (Just "system") Nothing
+ pure True
+ Just rid -> do
+ mTitle <- Reminders.deleteReminder uid rid
+ case mTitle of
+ Nothing -> do
+ _ <- Messages.enqueueImmediate (Just uid) chatId mThreadId ("reminder #" <> tshow rid <> " not found") (Just "system") Nothing
+ pure True
+ Just title -> do
+ _ <- Messages.enqueueImmediate (Just uid) chatId mThreadId ("✅ Deleted reminder: " <> title) (Just "system") Nothing
+ pure True
+ | "/reminders edit " `Text.isPrefixOf` cmd = do
+ let rest = Text.strip (Text.drop 16 cmd)
+ (idStr, newMessage) = Text.breakOn " " rest
+ case readMaybe (Text.unpack idStr) of
+ Nothing -> do
+ _ <- Messages.enqueueImmediate (Just uid) chatId mThreadId "usage: /reminders edit <id> <new message>" (Just "system") Nothing
+ pure True
+ Just rid -> do
+ let msg = Text.strip newMessage
+ if Text.null msg
+ then do
+ _ <- Messages.enqueueImmediate (Just uid) chatId mThreadId "usage: /reminders edit <id> <new message>" (Just "system") Nothing
+ pure True
+ else do
+ success <- Reminders.editReminder uid rid msg
+ if success
+ then do
+ _ <- Messages.enqueueImmediate (Just uid) chatId mThreadId ("✅ Updated reminder #" <> tshow rid <> ": " <> msg) (Just "system") Nothing
+ pure True
+ else do
+ _ <- Messages.enqueueImmediate (Just uid) chatId mThreadId ("reminder #" <> tshow rid <> " not found") (Just "system") Nothing
+ pure True
+ | "/reminders" `Text.isPrefixOf` cmd = do
+ -- Unknown subcommand - show help
+ _ <- Messages.enqueueImmediate (Just uid) chatId mThreadId remindersHelpText (Just "system") Nothing
+ pure True
+ | otherwise = pure False
+
+-- | Parse "add" command: extract time and message from input
+-- E.g., "tomorrow 3pm Pick up groceries" -> Just ("tomorrow 3pm", "Pick up groceries")
+parseAddCommand :: Text -> Maybe (Text, Text)
+parseAddCommand input = do
+ let txt = Text.strip input
+ guard (not (Text.null txt))
+ -- Try to find where time ends and message begins
+ -- Strategy: try progressively longer time prefixes until parsing fails
+ let words' = Text.words txt
+ findSplit words' 1
+ where
+ findSplit words' n
+ | n > length words' = Nothing
+ | n > 4 = Nothing -- Max 4 words for time specification
+ | otherwise =
+ let timeWords = take n words'
+ msgWords = drop n words'
+ timeStr = Text.unwords timeWords
+ in if null msgWords
+ then findSplit words' (n + 1) -- Need at least one message word
+ else Just (timeStr, Text.unwords msgWords)
+
+-- | Format reminders for display in Telegram
+formatRemindersForDisplay :: [Reminders.Reminder] -> Text
+formatRemindersForDisplay reminders =
+ Text.unlines
+ <| ["*Your reminders:*", ""]
+ <> zipWith formatReminder [1 :: Int ..] reminders
+ where
+ formatReminder n r =
+ tshow n
+ <> ". ["
+ <> formatReminderTime (Reminders.reminderDueAt r)
+ <> "] "
+ <> Reminders.reminderMessage r
+ <> " (id: "
+ <> tshow (Reminders.reminderId r)
+ <> ")"
+
+-- | Format a reminder time for display
+formatReminderTime :: UTCTime -> Text
+formatReminderTime utc =
+ let localTime = utcToLocalTime easternTZ utc
+ in Text.pack (formatTime defaultTimeLocale "%b %d %-l:%M%P" localTime)
+ where
+ easternTZ = minutesToTimeZone (-300)
+
+-- | Help text for /reminders command
+remindersHelpText :: Text
+remindersHelpText =
+ Text.unlines
+ [ "*Reminders Commands:*",
+ "",
+ "`/reminders` - List active reminders",
+ "`/reminders add <time> <message>` - Add reminder",
+ "`/reminders delete <id>` - Delete reminder",
+ "`/reminders edit <id> <message>` - Edit reminder",
+ "",
+ "*Time formats:*",
+ " tomorrow 3pm",
+ " in 2 hours",
+ " Dec 31 5pm",
+ " 2024-12-31 17:00"
+ ]