SimpleX Chat bot example (#499)

* SimpleX Chat bot example

* extract repl bot

* update .cabal

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"

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

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"

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

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:

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

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")