{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TupleSections #-}

module Simplex.Chat.Bot where

import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Simplex.Chat.Controller
import Simplex.Chat.Core
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol (MsgContent (..))
import Simplex.Chat.Store
import Simplex.Chat.Types (Contact (..), ContactId, IsContact (..), User (..))
import Simplex.Messaging.Agent.Protocol (CreatedConnLink (..))
import Simplex.Messaging.Encoding.String (strEncode)
import System.Exit (exitFailure)

chatBotRepl :: String -> (Contact -> String -> IO String) -> User -> ChatController -> IO ()
chatBotRepl :: String
-> (Contact -> String -> IO String)
-> User
-> ChatController
-> IO ()
chatBotRepl String
welcome Contact -> String -> IO String
answer User
_user ChatController
cc = do
  ChatController -> IO ()
initializeBotAddress ChatController
cc
  IO Any -> IO Any -> IO ()
forall a b. IO a -> IO b -> IO ()
race_ (IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ IO String -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO String
getLine) (IO Any -> IO ()) -> (IO () -> IO Any) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (Maybe ContactId
_, Either ChatError ChatEvent
event) <- STM (Maybe ContactId, Either ChatError ChatEvent)
-> IO (Maybe ContactId, Either ChatError ChatEvent)
forall a. STM a -> IO a
atomically (STM (Maybe ContactId, Either ChatError ChatEvent)
 -> IO (Maybe ContactId, Either ChatError ChatEvent))
-> (TBQueue (Maybe ContactId, Either ChatError ChatEvent)
    -> STM (Maybe ContactId, Either ChatError ChatEvent))
-> TBQueue (Maybe ContactId, Either ChatError ChatEvent)
-> IO (Maybe ContactId, Either ChatError ChatEvent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue (Maybe ContactId, Either ChatError ChatEvent)
-> STM (Maybe ContactId, Either ChatError ChatEvent)
forall a. TBQueue a -> STM a
readTBQueue (TBQueue (Maybe ContactId, Either ChatError ChatEvent)
 -> IO (Maybe ContactId, Either ChatError ChatEvent))
-> TBQueue (Maybe ContactId, Either ChatError ChatEvent)
-> IO (Maybe ContactId, Either ChatError ChatEvent)
forall a b. (a -> b) -> a -> b
$ ChatController
-> TBQueue (Maybe ContactId, Either ChatError ChatEvent)
outputQ ChatController
cc
    case Either ChatError ChatEvent
event of
      Right (CEvtContactConnected User
_ Contact
contact Maybe Profile
_) -> do
        Contact -> IO ()
contactConnected Contact
contact
        IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatController -> Contact -> Text -> IO ()
sendMessage ChatController
cc Contact
contact (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
welcome
      Right CEvtNewChatItems {chatItems :: ChatEvent -> [AChatItem]
chatItems = (AChatItem SChatType c
_ SMsgDirection d
SMDRcv (DirectChat Contact
contact) ChatItem {content :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIContent d
content = mc :: CIContent d
mc@CIRcvMsgContent {}}) : [AChatItem]
_} -> do
        let msg :: String
msg = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ CIContent d -> Text
forall (d :: MsgDirection). CIContent d -> Text
ciContentToText CIContent d
mc
        IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatController -> Contact -> Text -> IO ()
sendMessage ChatController
cc Contact
contact (Text -> IO ()) -> (String -> Text) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Contact -> String -> IO String
answer Contact
contact String
msg
      Either ChatError ChatEvent
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    contactConnected :: Contact -> IO ()
contactConnected Contact {Text
localDisplayName :: Text
localDisplayName :: Contact -> Text
localDisplayName} = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
localDisplayName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" connected"

initializeBotAddress :: ChatController -> IO ()
initializeBotAddress :: ChatController -> IO ()
initializeBotAddress = Bool -> ChatController -> IO ()
initializeBotAddress' Bool
True

initializeBotAddress' :: Bool -> ChatController -> IO ()
initializeBotAddress' :: Bool -> ChatController -> IO ()
initializeBotAddress' Bool
logAddress ChatController
cc = do
  ChatController -> ChatCommand -> IO (Either ChatError ChatResponse)
sendChatCmd ChatController
cc ChatCommand
ShowMyAddress IO (Either ChatError ChatResponse)
-> (Either ChatError ChatResponse -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right (CRUserContactLink User
_ UserContactLink {CreatedLinkContact
connLinkContact :: CreatedLinkContact
connLinkContact :: UserContactLink -> CreatedLinkContact
connLinkContact}) -> CreatedLinkContact -> IO ()
showBotAddress CreatedLinkContact
connLinkContact
    Left (ChatErrorStore StoreError
SEUserContactLinkNotFound) -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
logAddress (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"No bot address, creating..."
      -- TODO [short links] create short link by default
      ChatController -> ChatCommand -> IO (Either ChatError ChatResponse)
sendChatCmd ChatController
cc ChatCommand
CreateMyAddress IO (Either ChatError ChatResponse)
-> (Either ChatError ChatResponse -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right (CRUserContactLinkCreated User
_ CreatedLinkContact
ccLink) -> CreatedLinkContact -> IO ()
showBotAddress CreatedLinkContact
ccLink
        Either ChatError ChatResponse
_ -> String -> IO ()
putStrLn String
"can't create bot address" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure
    Either ChatError ChatResponse
_ -> String -> IO ()
putStrLn String
"unexpected response" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure
  where
    showBotAddress :: CreatedLinkContact -> IO ()
showBotAddress (CCLink ConnectionRequestUri 'CMContact
uri Maybe (ConnShortLink 'CMContact)
shortUri) = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
logAddress (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Bot's contact address is: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
B.unpack (ByteString
-> (ConnShortLink 'CMContact -> ByteString)
-> Maybe (ConnShortLink 'CMContact)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ConnectionRequestUri 'CMContact -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ConnectionRequestUri 'CMContact
uri) ConnShortLink 'CMContact -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode Maybe (ConnShortLink 'CMContact)
shortUri)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (ConnShortLink 'CMContact) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (ConnShortLink 'CMContact)
shortUri) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Full contact address for old clients: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
B.unpack (ConnectionRequestUri 'CMContact -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ConnectionRequestUri 'CMContact
uri)
      let settings :: AddressSettings
settings = AddressSettings {businessAddress :: Bool
businessAddress = Bool
False, autoAccept :: Maybe AutoAccept
autoAccept = AutoAccept -> Maybe AutoAccept
forall a. a -> Maybe a
Just AutoAccept {acceptIncognito :: Bool
acceptIncognito = Bool
False}, autoReply :: Maybe MsgContent
autoReply = Maybe MsgContent
forall a. Maybe a
Nothing}
      IO (Either ChatError ChatResponse) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either ChatError ChatResponse) -> IO ())
-> IO (Either ChatError ChatResponse) -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatController -> ChatCommand -> IO (Either ChatError ChatResponse)
sendChatCmd ChatController
cc (ChatCommand -> IO (Either ChatError ChatResponse))
-> ChatCommand -> IO (Either ChatError ChatResponse)
forall a b. (a -> b) -> a -> b
$ AddressSettings -> ChatCommand
SetAddressSettings AddressSettings
settings

sendMessage :: ChatController -> Contact -> Text -> IO ()
sendMessage :: ChatController -> Contact -> Text -> IO ()
sendMessage ChatController
cc Contact
ct = ChatController -> Contact -> Maybe ContactId -> MsgContent -> IO ()
sendComposedMessage ChatController
cc Contact
ct Maybe ContactId
forall a. Maybe a
Nothing (MsgContent -> IO ()) -> (Text -> MsgContent) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MsgContent
MCText

sendMessage' :: ChatController -> ContactId -> Text -> IO ()
sendMessage' :: ChatController -> ContactId -> Text -> IO ()
sendMessage' ChatController
cc ContactId
ctId = ChatController
-> ContactId -> Maybe ContactId -> MsgContent -> IO ()
sendComposedMessage' ChatController
cc ContactId
ctId Maybe ContactId
forall a. Maybe a
Nothing (MsgContent -> IO ()) -> (Text -> MsgContent) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MsgContent
MCText

sendComposedMessage :: ChatController -> Contact -> Maybe ChatItemId -> MsgContent -> IO ()
sendComposedMessage :: ChatController -> Contact -> Maybe ContactId -> MsgContent -> IO ()
sendComposedMessage ChatController
cc = ChatController
-> ContactId -> Maybe ContactId -> MsgContent -> IO ()
sendComposedMessage' ChatController
cc (ContactId -> Maybe ContactId -> MsgContent -> IO ())
-> (Contact -> ContactId)
-> Contact
-> Maybe ContactId
-> MsgContent
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contact -> ContactId
forall a. IsContact a => a -> ContactId
contactId'

sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
sendComposedMessage' :: ChatController
-> ContactId -> Maybe ContactId -> MsgContent -> IO ()
sendComposedMessage' ChatController
cc ContactId
ctId Maybe ContactId
qiId MsgContent
mc = ChatController
-> SendRef -> NonEmpty (Maybe ContactId, MsgContent) -> IO ()
sendComposedMessages_ ChatController
cc (ContactId -> SendRef
SRDirect ContactId
ctId) [(Maybe ContactId
qiId, MsgContent
mc)]

sendComposedMessages :: ChatController -> SendRef -> NonEmpty MsgContent -> IO ()
sendComposedMessages :: ChatController -> SendRef -> NonEmpty MsgContent -> IO ()
sendComposedMessages ChatController
cc SendRef
sendRef = ChatController
-> SendRef -> NonEmpty (Maybe ContactId, MsgContent) -> IO ()
sendComposedMessages_ ChatController
cc SendRef
sendRef (NonEmpty (Maybe ContactId, MsgContent) -> IO ())
-> (NonEmpty MsgContent -> NonEmpty (Maybe ContactId, MsgContent))
-> NonEmpty MsgContent
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgContent -> (Maybe ContactId, MsgContent))
-> NonEmpty MsgContent -> NonEmpty (Maybe ContactId, MsgContent)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (Maybe ContactId
forall a. Maybe a
Nothing,)

sendComposedMessages_ :: ChatController -> SendRef -> NonEmpty (Maybe ChatItemId, MsgContent) -> IO ()
sendComposedMessages_ :: ChatController
-> SendRef -> NonEmpty (Maybe ContactId, MsgContent) -> IO ()
sendComposedMessages_ ChatController
cc SendRef
sendRef NonEmpty (Maybe ContactId, MsgContent)
qmcs = do
  let cms :: NonEmpty ComposedMessage
cms = ((Maybe ContactId, MsgContent) -> ComposedMessage)
-> NonEmpty (Maybe ContactId, MsgContent)
-> NonEmpty ComposedMessage
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\(Maybe ContactId
qiId, MsgContent
mc) -> ComposedMessage {fileSource :: Maybe CryptoFile
fileSource = Maybe CryptoFile
forall a. Maybe a
Nothing, quotedItemId :: Maybe ContactId
quotedItemId = Maybe ContactId
qiId, msgContent :: MsgContent
msgContent = MsgContent
mc, mentions :: Map Text ContactId
mentions = Map Text ContactId
forall k a. Map k a
M.empty}) NonEmpty (Maybe ContactId, MsgContent)
qmcs
  ChatController -> ChatCommand -> IO (Either ChatError ChatResponse)
sendChatCmd ChatController
cc (SendRef
-> Bool -> Maybe Int -> NonEmpty ComposedMessage -> ChatCommand
APISendMessages SendRef
sendRef Bool
False Maybe Int
forall a. Maybe a
Nothing NonEmpty ComposedMessage
cms) IO (Either ChatError ChatResponse)
-> (Either ChatError ChatResponse -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right (CRNewChatItems {}) -> ChatController -> ChatLogLevel -> String -> IO ()
printLog ChatController
cc ChatLogLevel
CLLInfo (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"sent " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (NonEmpty ComposedMessage -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty ComposedMessage
cms) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" messages to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SendRef -> String
forall a. Show a => a -> String
show SendRef
sendRef
    Either ChatError ChatResponse
r -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"unexpected send message response: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Either ChatError ChatResponse -> String
forall a. Show a => a -> String
show Either ChatError ChatResponse
r

deleteMessage :: ChatController -> Contact -> ChatItemId -> IO ()
deleteMessage :: ChatController -> Contact -> ContactId -> IO ()
deleteMessage ChatController
cc Contact
ct ContactId
chatItemId = do
  let cmd :: ChatCommand
cmd = ChatRef -> NonEmpty ContactId -> CIDeleteMode -> ChatCommand
APIDeleteChatItem (Contact -> ChatRef
contactRef Contact
ct) [ContactId
Item (NonEmpty ContactId)
chatItemId] CIDeleteMode
CIDMInternal
  ChatController -> ChatCommand -> IO (Either ChatError ChatResponse)
sendChatCmd ChatController
cc ChatCommand
cmd IO (Either ChatError ChatResponse)
-> (Either ChatError ChatResponse -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right (CRChatItemsDeleted {}) -> ChatController -> ChatLogLevel -> String -> IO ()
printLog ChatController
cc ChatLogLevel
CLLInfo (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"deleted message(s) from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Contact -> String
contactInfo Contact
ct
    Either ChatError ChatResponse
r -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"unexpected delete message response: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Either ChatError ChatResponse -> String
forall a. Show a => a -> String
show Either ChatError ChatResponse
r

contactRef :: Contact -> ChatRef
contactRef :: Contact -> ChatRef
contactRef Contact
ct = ChatType -> ContactId -> Maybe GroupChatScope -> ChatRef
ChatRef ChatType
CTDirect (Contact -> ContactId
forall a. IsContact a => a -> ContactId
contactId' Contact
ct) Maybe GroupChatScope
forall a. Maybe a
Nothing

printLog :: ChatController -> ChatLogLevel -> String -> IO ()
printLog :: ChatController -> ChatLogLevel -> String -> IO ()
printLog ChatController
cc ChatLogLevel
level String
s
  | ChatConfig -> ChatLogLevel
logLevel (ChatController -> ChatConfig
config ChatController
cc) ChatLogLevel -> ChatLogLevel -> Bool
forall a. Ord a => a -> a -> Bool
<= ChatLogLevel
level = String -> IO ()
putStrLn String
s
  | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

contactInfo :: Contact -> String
contactInfo :: Contact -> String
contactInfo Contact {ContactId
contactId :: ContactId
contactId :: Contact -> ContactId
contactId, Text
localDisplayName :: Contact -> Text
localDisplayName :: Text
localDisplayName} = Text -> String
T.unpack Text
localDisplayName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ContactId -> String
forall a. Show a => a -> String
show ContactId
contactId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"