simplex-manager/bots/haskell/simplex-deadmans-bot/Main.hs

{-# 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)