Initial commit: bots, AI-parameterised support bot, web frontend
- simplex-deadmans-bot: Dead Man's Switch Haskell bot - simplexxx-directory: private SimpleXXX directory bot (fork of simplex-directory-service) - simplex-support-bot: support triage bot with configurable AI backend - --ai-url and --ai-model flags for any OpenAI-compatible provider - works with Grok, Ollama, OpenAI, LM Studio, etc. - AI_API_KEY env var (GROK_API_KEY still accepted as alias) - web: SimpleXXX directory frontend (Groups/Channels tabs, matches simplex.chat/directory style) - manager/: placeholder for Python profile manager (coming soon) Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
Jon
201
bots/haskell/simplex-deadmans-bot/Main.hs
Normal file
201
bots/haskell/simplex-deadmans-bot/Main.hs
Normal file
@@ -0,0 +1,201 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad (forever, void, when)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Read as T
|
||||
import Data.Time.Clock
|
||||
import Network.HTTP.Simple
|
||||
import Simplex.Chat.Bot
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Protocol (MsgContent (..))
|
||||
import Simplex.Chat.Store.Profiles (AddressSettings (..), AutoAccept (..))
|
||||
import Simplex.Chat.Terminal (terminalChatConfig)
|
||||
import Simplex.Chat.Types
|
||||
import System.Directory (getAppUserDataDirectory)
|
||||
|
||||
defaultSwitchDuration :: Int
|
||||
defaultSwitchDuration = 1
|
||||
|
||||
notificationThresholds :: [Int]
|
||||
notificationThresholds = [99, 90, 80, 70, 60, 50, 40, 30, 20, 15, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1]
|
||||
|
||||
deadMansSwitchUrl :: String
|
||||
deadMansSwitchUrl = "http://localhost:8080/deadmanswitch"
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts <- welcomeGetOpts
|
||||
expiryVar <- newTVarIO Nothing
|
||||
lastNotifyVar <- newTVarIO (100 :: Int)
|
||||
durationVar <- newTVarIO defaultSwitchDuration
|
||||
simplexChatCore terminalChatConfig opts (deadmansBot expiryVar lastNotifyVar durationVar)
|
||||
|
||||
welcomeGetOpts :: IO ChatOpts
|
||||
welcomeGetOpts = do
|
||||
appDir <- getAppUserDataDirectory "simplex"
|
||||
opts@ChatOpts {coreOptions} <- getChatOpts appDir "simplex_v1"
|
||||
putStrLn $ "SimpleX Dead Man's Switch Bot v1.0 (default " ++ show defaultSwitchDuration ++ " days)"
|
||||
printDbOpts coreOptions
|
||||
pure opts
|
||||
|
||||
welcomeMessage :: Int -> Text
|
||||
welcomeMessage dur =
|
||||
"Dead Man's Switch controls:\n\
|
||||
\- Send 'arm' to start the timer.\n\
|
||||
\- Send 'rearm' to restart it.\n\
|
||||
\- Send 'status' to check remaining time.\n\
|
||||
\- Send 'reset N' to change timer and reset it.\n\
|
||||
\Current arm duration: " <> T.pack (show dur) <> " days."
|
||||
|
||||
expiryFromNow :: Int -> IO UTCTime
|
||||
expiryFromNow days = do
|
||||
now <- getCurrentTime
|
||||
pure $ addUTCTime (fromIntegral (days * 24 * 60 * 60)) now
|
||||
|
||||
deadmansBot :: TVar (Maybe UTCTime) -> TVar Int -> TVar Int -> User -> ChatController -> IO ()
|
||||
deadmansBot expiryVar lastNotifyVar durationVar _user cc = do
|
||||
initializeBotAddress cc
|
||||
dur <- readTVarIO durationVar
|
||||
void $ sendChatCmd cc $ SetAddressSettings
|
||||
AddressSettings
|
||||
{ businessAddress = True
|
||||
, autoAccept = Just AutoAccept {acceptIncognito = False}
|
||||
, autoReply = Just $ MCText (welcomeMessage dur)
|
||||
}
|
||||
contactVar <- newTVarIO Nothing
|
||||
void . forkIO $ monitorExpiry expiryVar lastNotifyVar durationVar contactVar cc
|
||||
forever $ do
|
||||
(_, evt) <- atomically . readTBQueue $ outputQ cc
|
||||
case evt of
|
||||
Right (CEvtContactConnected _ contact _) -> do
|
||||
putStrLn "A contact just connected."
|
||||
atomically $ writeTVar contactVar (Just contact)
|
||||
dur <- readTVarIO durationVar
|
||||
sendMessage cc contact (welcomeMessage dur)
|
||||
Right CEvtNewChatItems {chatItems = (AChatItem _ _ (DirectChat contact) ChatItem {content = mc}) : _}
|
||||
| let msg = T.toLower (ciContentToText mc) ->
|
||||
do
|
||||
atomically $ writeTVar contactVar (Just contact)
|
||||
dur <- readTVarIO durationVar
|
||||
case T.words msg of
|
||||
["arm"] -> do
|
||||
expiry <- expiryFromNow dur
|
||||
atomically $ writeTVar expiryVar (Just expiry)
|
||||
atomically $ writeTVar lastNotifyVar 100
|
||||
putStrLn $ "Timer ARMED until: " ++ show expiry
|
||||
sendMessage cc contact $ "Dead Man's Switch ARMED! You have " <> T.pack (show dur) <> " days."
|
||||
["rearm"] -> do
|
||||
expiry <- expiryFromNow dur
|
||||
atomically $ writeTVar expiryVar (Just expiry)
|
||||
atomically $ writeTVar lastNotifyVar 100
|
||||
putStrLn $ "Timer RE-ARMED until: " ++ show expiry
|
||||
sendMessage cc contact $ "Dead Man's Switch RE-ARMED! You have " <> T.pack (show dur) <> " days."
|
||||
["status"] -> do
|
||||
mExpiry <- readTVarIO expiryVar
|
||||
now <- getCurrentTime
|
||||
msgToSend <- case mExpiry of
|
||||
Nothing -> pure "Switch not armed."
|
||||
Just expiry -> do
|
||||
let secondsLeft = round $ realToFrac (diffUTCTime expiry now) :: Int
|
||||
daysLeft = secondsLeft `div` (24 * 60 * 60)
|
||||
hoursLeft = (secondsLeft `mod` (24 * 60 * 60)) `div` (60 * 60)
|
||||
minutesLeft = (secondsLeft `mod` (60 * 60)) `div` 60
|
||||
secsLeft = secondsLeft `mod` 60
|
||||
pure $
|
||||
"Time remaining: "
|
||||
<> T.pack (show daysLeft) <> " days, "
|
||||
<> T.pack (show hoursLeft) <> " hours, "
|
||||
<> T.pack (show minutesLeft) <> " minutes, "
|
||||
<> T.pack (show secsLeft) <> " seconds."
|
||||
sendMessage cc contact msgToSend
|
||||
["reset"] -> do
|
||||
expiry <- expiryFromNow dur
|
||||
atomically $ writeTVar expiryVar (Just expiry)
|
||||
atomically $ writeTVar lastNotifyVar 100
|
||||
sendMessage cc contact $ "Timer reset to " <> T.pack (show dur) <> " days."
|
||||
["reset", daysTxt] ->
|
||||
case T.decimal daysTxt of
|
||||
Right (newDur, _) | newDur > 0 -> do
|
||||
atomically $ writeTVar durationVar newDur
|
||||
expiry <- expiryFromNow newDur
|
||||
atomically $ writeTVar expiryVar (Just expiry)
|
||||
atomically $ writeTVar lastNotifyVar 100
|
||||
sendMessage cc contact $ "Timer reset to " <> T.pack (show newDur) <> " days."
|
||||
_ -> sendMessage cc contact "Please provide a valid integer > 0 for days."
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
|
||||
findTriggeredThreshold :: Int -> Int -> Maybe Int
|
||||
findTriggeredThreshold currentPercent lastNotifyPercent =
|
||||
let candidates = filter (\t -> t < lastNotifyPercent && t >= currentPercent) notificationThresholds
|
||||
in if null candidates then Nothing else Just (maximum candidates)
|
||||
|
||||
monitorExpiry :: TVar (Maybe UTCTime) -> TVar Int -> TVar Int -> TVar (Maybe Contact) -> ChatController -> IO ()
|
||||
monitorExpiry expiryVar lastNotifyVar durationVar contactVar cc = forever $ do
|
||||
mExpiry <- readTVarIO expiryVar
|
||||
mContact <- readTVarIO contactVar
|
||||
dur <- readTVarIO durationVar
|
||||
now <- getCurrentTime
|
||||
case mExpiry of
|
||||
Nothing -> threadDelay (15 * 1000000)
|
||||
Just expiry ->
|
||||
if now >= expiry
|
||||
then do
|
||||
putStrLn $ "No activity for " ++ show dur ++ " days! Triggering dead man's switch."
|
||||
case mContact of
|
||||
Just contact ->
|
||||
sendMessage cc contact $
|
||||
"Dead man's switch activated! No response received in " <> T.pack (show dur) <> " days."
|
||||
Nothing -> putStrLn "No contact available to notify on deadline."
|
||||
triggerSwitch
|
||||
atomically $ writeTVar expiryVar Nothing
|
||||
atomically $ writeTVar lastNotifyVar 100
|
||||
else do
|
||||
let secondsLeft = round $ realToFrac (diffUTCTime expiry now) :: Int
|
||||
totalSeconds = dur * 24 * 60 * 60
|
||||
percentRemaining = round ((fromIntegral secondsLeft / fromIntegral totalSeconds :: Double) * 100)
|
||||
daysLeft = secondsLeft `div` (24 * 60 * 60)
|
||||
hoursLeft = (secondsLeft `mod` (24 * 60 * 60)) `div` (60 * 60)
|
||||
minutesLeft = (secondsLeft `mod` (60 * 60)) `div` 60
|
||||
secsLeft = secondsLeft `mod` 60
|
||||
lastNotifyPercent <- readTVarIO lastNotifyVar
|
||||
case findTriggeredThreshold percentRemaining lastNotifyPercent of
|
||||
Just threshold -> do
|
||||
let message =
|
||||
"Warning: " <> T.pack (show threshold) <> "% time remaining ("
|
||||
<> T.pack (show daysLeft) <> " days, "
|
||||
<> T.pack (show hoursLeft) <> " hours, "
|
||||
<> T.pack (show minutesLeft) <> " minutes, "
|
||||
<> T.pack (show secsLeft) <> " seconds)"
|
||||
putStrLn $ "Sending " ++ show threshold ++ "% warning"
|
||||
case mContact of
|
||||
Just contact -> sendMessage cc contact message
|
||||
Nothing -> putStrLn "No contact available to notify at threshold."
|
||||
atomically $ writeTVar lastNotifyVar threshold
|
||||
Nothing -> pure ()
|
||||
putStrLn $
|
||||
"Dead man's switch: " ++ show percentRemaining ++ "% remaining - "
|
||||
++ show daysLeft ++ " days, "
|
||||
++ show hoursLeft ++ " hours, "
|
||||
++ show minutesLeft ++ " minutes, "
|
||||
++ show secsLeft ++ " seconds."
|
||||
threadDelay (60 * 1000000)
|
||||
|
||||
triggerSwitch :: IO ()
|
||||
triggerSwitch = do
|
||||
req <- parseRequest deadMansSwitchUrl
|
||||
response <- httpLBS (setRequestMethod "POST" req)
|
||||
putStrLn $ "Switch triggered, server responded: " ++ show (getResponseStatus response)
|
||||
Reference in New Issue
Block a user