1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
|
{-# 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.Provider as Provider
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.Calendar as Calendar
import qualified Omni.Agent.Tools.Email as Email
import qualified Omni.Agent.Tools.Hledger as Hledger
import qualified Omni.Agent.Tools.Notes as Notes
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'",
"",
"## 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
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]
tools = memoryTools <> searchTools <> webReaderTools <> pdfTools <> notesTools <> calendarTools <> todoTools <> messageTools <> hledgerTools <> emailTools <> pythonTools
let agentCfg =
Engine.defaultAgentConfig
{ Engine.agentSystemPrompt = systemPrompt,
Engine.agentTools = tools,
Engine.agentMaxIterations = 10,
Engine.agentGuardrails =
Engine.defaultGuardrails
{ Engine.guardrailMaxCostCents = 10.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
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
if Text.length message < 200
then pure [message]
else do
let haiku = Provider.defaultOpenRouter openRouterKey "anthropic/claude-haiku-4.5"
result <-
Provider.chat
haiku
[]
[ Provider.Message
Provider.System
( Text.unlines
[ "Split this message into separate chat messages that feel natural in a messaging app.",
"Each part should be logically independent - a complete thought.",
"Separate parts with exactly '---' on its own line.",
"Keep the original text, just add separators. Don't add any commentary.",
"If the message is already short/simple, return it unchanged (no separators).",
"Aim for 2-4 parts maximum. Don't over-split.",
"",
"Good splits: between topics, after questions, between a statement and follow-up",
"Bad splits: mid-sentence, between closely related points"
]
)
Nothing
Nothing,
Provider.Message Provider.User message Nothing Nothing
]
case result of
Left err -> do
putText <| "Message split failed: " <> err
pure [message]
Right msg -> do
let parts = map Text.strip (Text.splitOn "---" (Provider.msgContent msg))
validParts = filter (not <. Text.null) parts
if null validParts
then pure [message]
else pure validParts
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
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
|