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