From 852421315b0d0148f50a6015646b66c78acac6be Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 4 Apr 2022 08:14:42 +0100 Subject: [PATCH] SimpleX Chat bot example (#499) * SimpleX Chat bot example * extract repl bot * update .cabal --- apps/simplex-bot-advanced/Main.hs | 54 ++++++++++++++++++++++ apps/simplex-bot/Main.hs | 27 +++++++++++ apps/simplex-chat/Main.hs | 5 +- package.yaml | 16 +++++++ simplex-chat.cabal | 75 ++++++++++++++++++++++++++++++ src/Simplex/Chat/Bot.hs | 77 +++++++++++++++++++++++++++++++ src/Simplex/Chat/Options.hs | 12 ++--- 7 files changed, 256 insertions(+), 10 deletions(-) create mode 100644 apps/simplex-bot-advanced/Main.hs create mode 100644 apps/simplex-bot/Main.hs create mode 100644 src/Simplex/Chat/Bot.hs diff --git a/apps/simplex-bot-advanced/Main.hs b/apps/simplex-bot-advanced/Main.hs new file mode 100644 index 0000000000..0e270a45a6 --- /dev/null +++ b/apps/simplex-bot-advanced/Main.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Monad.Reader +import qualified Data.Text as T +import Simplex.Chat +import Simplex.Chat.Bot +import Simplex.Chat.Controller +import Simplex.Chat.Messages +import Simplex.Chat.Options +import Simplex.Chat.Types +import System.Directory (getAppUserDataDirectory) +import Text.Read + +main :: IO () +main = do + opts <- welcomeGetOpts + simplexChatBot defaultChatConfig opts mySquaringBot + +welcomeGetOpts :: IO ChatOpts +welcomeGetOpts = do + appDir <- getAppUserDataDirectory "simplex" + opts@ChatOpts {dbFilePrefix} <- getChatOpts appDir "simplex_bot" + putStrLn $ "SimpleX Chat Bot v" ++ versionNumber + putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db" + pure opts + +mySquaringBot :: User -> ChatController -> IO () +mySquaringBot _user cc = do + initializeBotAddress cc + race_ (forever $ void getLine) . forever $ do + (_, resp) <- atomically . readTBQueue $ outputQ cc + case resp of + CRContactConnected contact -> do + contactConnected contact + void . sendMsg contact $ "Hello! I am a simple squaring bot - if you send me a number, I will calculate its square" + CRNewChatItem (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content}) -> do + let msg = T.unpack $ ciContentToText content + number_ = readMaybe msg :: Maybe Integer + void . sendMsg contact $ case number_ of + Nothing -> "\"" <> msg <> "\" is not a number" + Just n -> msg <> " * " <> msg <> " = " <> show (n * n) + _ -> pure () + where + sendMsg Contact {contactId} msg = sendCmd cc $ "/_send @" <> show contactId <> " text " <> msg + contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected" diff --git a/apps/simplex-bot/Main.hs b/apps/simplex-bot/Main.hs new file mode 100644 index 0000000000..70faaf777e --- /dev/null +++ b/apps/simplex-bot/Main.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Main where + +import Simplex.Chat +import Simplex.Chat.Bot +import Simplex.Chat.Controller (versionNumber) +import Simplex.Chat.Options +import System.Directory (getAppUserDataDirectory) +import Text.Read + +main :: IO () +main = do + opts <- welcomeGetOpts + simplexChatBot defaultChatConfig opts $ + chatBotRepl "Hello! I am a simple squaring bot - if you send me a number, I will calculate its square" $ \msg -> + case readMaybe msg :: Maybe Integer of + Just n -> msg <> " * " <> msg <> " = " <> show (n * n) + _ -> "\"" <> msg <> "\" is not a number" + +welcomeGetOpts :: IO ChatOpts +welcomeGetOpts = do + appDir <- getAppUserDataDirectory "simplex" + opts@ChatOpts {dbFilePrefix} <- getChatOpts appDir "simplex_bot" + putStrLn $ "SimpleX Chat Bot v" ++ versionNumber + putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db" + pure opts diff --git a/apps/simplex-chat/Main.hs b/apps/simplex-chat/Main.hs index cb223f6e0a..0465354994 100644 --- a/apps/simplex-chat/Main.hs +++ b/apps/simplex-chat/Main.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} module Main where @@ -21,7 +18,7 @@ main = do welcomeGetOpts :: IO ChatOpts welcomeGetOpts = do appDir <- getAppUserDataDirectory "simplex" - opts@ChatOpts {dbFilePrefix} <- getChatOpts appDir + opts@ChatOpts {dbFilePrefix} <- getChatOpts appDir "simplex_v1" putStrLn $ "SimpleX Chat v" ++ versionNumber putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db" putStrLn "type \"/help\" or \"/h\" for usage info" diff --git a/package.yaml b/package.yaml index 7fe6db1b38..f0917c04aa 100644 --- a/package.yaml +++ b/package.yaml @@ -51,6 +51,22 @@ executables: ghc-options: - -threaded + simplex-bot: + source-dirs: apps/simplex-bot + main: Main.hs + dependencies: + - simplex-chat + ghc-options: + - -threaded + + simplex-bot-advanced: + source-dirs: apps/simplex-bot-advanced + main: Main.hs + dependencies: + - simplex-chat + ghc-options: + - -threaded + tests: simplex-chat-test: source-dirs: tests diff --git a/simplex-chat.cabal b/simplex-chat.cabal index f85424e044..884a7693c8 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -20,6 +20,7 @@ extra-source-files: library exposed-modules: Simplex.Chat + Simplex.Chat.Bot Simplex.Chat.Controller Simplex.Chat.Help Simplex.Chat.Markdown @@ -79,6 +80,80 @@ library , unliftio-core ==0.2.* default-language: Haskell2010 +executable simplex-bot + main-is: Main.hs + other-modules: + Paths_simplex_chat + hs-source-dirs: + apps/simplex-bot + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + build-depends: + aeson ==2.0.* + , ansi-terminal >=0.10 && <0.12 + , async ==2.2.* + , attoparsec ==0.14.* + , base >=4.7 && <5 + , base64-bytestring >=1.0 && <1.3 + , bytestring ==0.10.* + , composition ==1.0.* + , containers ==0.6.* + , cryptonite >=0.27 && <0.30 + , directory ==1.3.* + , email-validate ==2.3.* + , exceptions ==0.10.* + , filepath ==1.4.* + , mtl ==2.2.* + , optparse-applicative >=0.15 && <0.17 + , process ==1.6.* + , simple-logger ==0.1.* + , simplex-chat + , simplexmq ==1.0.* + , sqlite-simple ==0.4.* + , stm ==2.5.* + , terminal ==0.2.* + , text ==1.2.* + , time ==1.9.* + , unliftio ==0.2.* + , unliftio-core ==0.2.* + default-language: Haskell2010 + +executable simplex-bot-advanced + main-is: Main.hs + other-modules: + Paths_simplex_chat + hs-source-dirs: + apps/simplex-bot-advanced + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + build-depends: + aeson ==2.0.* + , ansi-terminal >=0.10 && <0.12 + , async ==2.2.* + , attoparsec ==0.14.* + , base >=4.7 && <5 + , base64-bytestring >=1.0 && <1.3 + , bytestring ==0.10.* + , composition ==1.0.* + , containers ==0.6.* + , cryptonite >=0.27 && <0.30 + , directory ==1.3.* + , email-validate ==2.3.* + , exceptions ==0.10.* + , filepath ==1.4.* + , mtl ==2.2.* + , optparse-applicative >=0.15 && <0.17 + , process ==1.6.* + , simple-logger ==0.1.* + , simplex-chat + , simplexmq ==1.0.* + , sqlite-simple ==0.4.* + , stm ==2.5.* + , terminal ==0.2.* + , text ==1.2.* + , time ==1.9.* + , unliftio ==0.2.* + , unliftio-core ==0.2.* + default-language: Haskell2010 + executable simplex-chat main-is: Main.hs other-modules: diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs new file mode 100644 index 0000000000..93845ba2f0 --- /dev/null +++ b/src/Simplex/Chat/Bot.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Simplex.Chat.Bot where + +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Logger.Simple +import Control.Monad.Reader +import qualified Data.ByteString.Char8 as B +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Simplex.Chat +import Simplex.Chat.Controller +import Simplex.Chat.Messages +import Simplex.Chat.Options (ChatOpts (..)) +import Simplex.Chat.Store +import Simplex.Chat.Types (Contact (..), User (..)) +import Simplex.Messaging.Encoding.String (strEncode) +import System.Exit (exitFailure) + +simplexChatBot :: ChatConfig -> ChatOpts -> (User -> ChatController -> IO ()) -> IO () +simplexChatBot cfg@ChatConfig {dbPoolSize, yesToMigrations} opts chatBot + | logAgent opts = do + setLogLevel LogInfo -- LogError + withGlobalLogging logCfg initRun + | otherwise = initRun + where + initRun = do + let f = chatStoreFile $ dbFilePrefix opts + st <- createStore f dbPoolSize yesToMigrations + u <- getCreateActiveUser st + cc <- newChatController st (Just u) cfg opts (const $ pure ()) + runSimplexChatBot u cc chatBot + +runSimplexChatBot :: User -> ChatController -> (User -> ChatController -> IO ()) -> IO () +runSimplexChatBot u cc chatBot = do + a1 <- async $ chatBot u cc + a2 <- runReaderT (startChatController u) cc + waitEither_ a1 a2 + +chatBotRepl :: String -> (String -> String) -> User -> ChatController -> IO () +chatBotRepl welcome answer _user cc = do + initializeBotAddress cc + race_ (forever $ void getLine) . forever $ do + (_, resp) <- atomically . readTBQueue $ outputQ cc + case resp of + CRContactConnected contact -> do + contactConnected contact + void $ sendMsg contact welcome + CRNewChatItem (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content}) -> do + let msg = T.unpack $ ciContentToText content + void . sendMsg contact $ answer msg + _ -> pure () + where + sendMsg Contact {contactId} msg = sendCmd cc $ "/_send @" <> show contactId <> " text " <> msg + contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected" + +initializeBotAddress :: ChatController -> IO () +initializeBotAddress cc = do + sendCmd cc "/show_address" >>= \case + CRUserContactLink uri _ -> showBotAddress uri + CRChatCmdError (ChatErrorStore SEUserContactLinkNotFound) -> do + putStrLn $ "No bot address, creating..." + sendCmd cc "/address" >>= \case + CRUserContactLinkCreated uri -> showBotAddress uri + _ -> putStrLn "can't create bot address" >> exitFailure + _ -> putStrLn "unexpected response" >> exitFailure + where + showBotAddress uri = do + putStrLn $ "Bot's contact address is: " <> B.unpack (strEncode uri) + void $ sendCmd cc "/auto_accept on" + +sendCmd :: ChatController -> String -> IO ChatResponse +sendCmd cc s = runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index 6fd25a8d33..68b9394db1 100644 --- a/src/Simplex/Chat/Options.hs +++ b/src/Simplex/Chat/Options.hs @@ -23,8 +23,8 @@ data ChatOpts = ChatOpts logAgent :: Bool } -chatOpts :: FilePath -> Parser ChatOpts -chatOpts appDir = +chatOpts :: FilePath -> FilePath -> Parser ChatOpts +chatOpts appDir defaultDbFileName = ChatOpts <$> strOption ( long "database" @@ -54,7 +54,7 @@ chatOpts appDir = <> help "Enable logs from SMP agent" ) where - defaultDbFilePath = combine appDir "simplex_v1" + defaultDbFilePath = combine appDir defaultDbFileName parseSMPServers :: ReadM [SMPServer] parseSMPServers = eitherReader $ parseAll smpServersP . B.pack @@ -62,11 +62,11 @@ parseSMPServers = eitherReader $ parseAll smpServersP . B.pack smpServersP :: A.Parser [SMPServer] smpServersP = strP `A.sepBy1` A.char ',' -getChatOpts :: FilePath -> IO ChatOpts -getChatOpts appDir = +getChatOpts :: FilePath -> FilePath -> IO ChatOpts +getChatOpts appDir defaultDbFileName = execParser $ info - (helper <*> versionOption <*> chatOpts appDir) + (helper <*> versionOption <*> chatOpts appDir defaultDbFileName) (header versionStr <> fullDesc <> progDesc "Start chat with DB_FILE file and use SERVER as SMP server") where versionOption = infoOption versionAndUpdate (long "version" <> short 'v' <> help "Show version")