Merge branch 'master' into ep/survey-bot

apps/simplex-survey-bot/Main.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Control.Concurrent (forkIO)
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import Control.Monad.Reader
+import qualified Data.Text as T
+import Options
+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.Terminal (terminalChatConfig)
+import Simplex.Chat.Types
+import Survey
+import System.Directory (getAppUserDataDirectory)
+
+main :: IO ()
+main = do
+  opts <- welcomeGetOpts
+  state <- readSurveyState opts
+  simplexChatCore terminalChatConfig (mkChatOpts opts) Nothing $ surveyBot state opts
+
+welcomeGetOpts :: IO SurveyBotOpts
+welcomeGetOpts = do
+  appDir <- getAppUserDataDirectory "simplex"
+  opts@SurveyBotOpts {coreOptions = CoreChatOpts {dbFilePrefix}} <- getSurveyBotOpts appDir "simplex_survey_bot"
+  putStrLn $ "SimpleX Chat Survey Bot v" ++ versionNumber
+  putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
+  pure opts
+
+surveyBot :: SurveyState -> SurveyBotOpts -> User -> ChatController -> IO ()
+surveyBot SurveyState {survey = SurveyDescription {welcomeMessage}} SurveyBotOpts {surveyResults} _user cc = do
+  initializeBotAddress cc
+  race_ (forever $ void getLine) . forever $ do
+    (_, resp) <- atomically . readTBQueue $ outputQ cc
+    case resp of
+      CRContactConnected _ ct _ -> do
+        contactConnected ct
+        sendMessage cc ct welcomeMessage
+    --   CRNewChatItem _ (AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc})
+    --     | publisher `elem` publishers ->
+    --       if allowContent mc
+    --         then do
+    --           sendChatCmd cc "/contacts" >>= \case
+    --             CRContactsList _ cts -> void . forkIO $ do
+    --               let cts' = filter broadcastTo cts
+    --               forM_ cts' $ \ct' -> sendComposedMessage cc ct' Nothing mc
+    --               sendReply $ "Forwarded to " <> show (length cts') <> " contact(s)"
+    --             r -> putStrLn $ "Error getting contacts list: " <> show r
+    --         else sendReply "!1 Message is not supported!"
+    --     | otherwise -> do
+    --       sendReply prohibitedMessage
+    --       deleteMessage cc ct $ chatItemId' ci
+    --     where
+    --       sendReply = sendComposedMessage cc ct (Just $ chatItemId' ci) . textMsgContent
+    --       publisher = Publisher {contactId = contactId' ct, localDisplayName = localDisplayName' ct}
+    --       allowContent = \case
+    --         MCText _ -> True
+    --         MCLink {} -> True
+    --         MCImage {} -> True
+    --         _ -> False
+    --       broadcastTo ct'@Contact {activeConn = conn@Connection {connStatus}} =
+    --         (connStatus == ConnSndReady || connStatus == ConnReady)
+    --           && not (connDisabled conn)
+    --           && contactId' ct' /= contactId' ct
+      _ -> pure ()
+  where
+    contactConnected ct = putStrLn $ T.unpack (localDisplayName' ct) <> " connected"

apps/simplex-survey-bot/Options.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Options where
+
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Int (Int64)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Options.Applicative
+import Simplex.Chat.Controller (updateStr, versionNumber, versionString)
+import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts, coreChatOptsP)
+import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Util (safeDecodeUtf8)
+
+data SurveyBotOpts = SurveyBotOpts
+  { coreOptions :: CoreChatOpts,
+    surveyDescription :: FilePath,
+    surveyLog :: FilePath,
+    surveyResults :: FilePath
+  }
+
+surveyBotOpts :: FilePath -> FilePath -> Parser SurveyBotOpts
+surveyBotOpts appDir defaultDbFileName = do
+  coreOptions <- coreChatOptsP appDir defaultDbFileName
+  surveyDescription <-
+    strOption
+      ( long "survey"
+          <> metavar "SURVEY"
+          <> help "Survey description file"
+      )
+  surveyLog <-
+    strOption
+      ( long "answers"
+          <> metavar "ANSWERS"
+          <> help "Survey answers file"
+      )
+  surveyResults <-
+    strOption
+      ( long "results"
+          <> metavar "RESULTS"
+          <> help "Survey results file"
+      )
+  pure
+    SurveyBotOpts
+      { coreOptions,
+        surveyDescription,
+        surveyLog,
+        surveyResults
+      }
+
+getSurveyBotOpts :: FilePath -> FilePath -> IO SurveyBotOpts
+getSurveyBotOpts appDir defaultDbFileName =
+  execParser $
+    info
+      (helper <*> versionOption <*> surveyBotOpts appDir defaultDbFileName)
+      (header versionStr <> fullDesc <> progDesc "Start survey bot with DB_FILE, SURVEY and RESULTS files, and use SERVER as SMP server")
+  where
+    versionStr = versionString versionNumber
+    versionOption = infoOption versionAndUpdate (long "version" <> short 'v' <> help "Show version")
+    versionAndUpdate = versionStr <> "\n" <> updateStr
+
+mkChatOpts :: SurveyBotOpts -> ChatOpts
+mkChatOpts SurveyBotOpts {coreOptions} =
+  ChatOpts
+    { coreOptions,
+      chatCmd = "",
+      chatCmdDelay = 3,
+      chatServerPort = Nothing,
+      optFilesFolder = Nothing,
+      showReactions = False,
+      allowInstantFiles = True,
+      autoAcceptFileSize = 0,
+      muteNotifications = True,
+      maintenance = False
+    }

apps/simplex-survey-bot/Survey.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Survey where
+
+import Control.Concurrent.STM
+import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.Aeson as J
+import qualified Data.ByteString.Char8 as B
+import Data.Int (Int64)
+import Data.List (foldl')
+import Data.List.NonEmpty (NonEmpty)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Time.Clock (UTCTime)
+import qualified Data.Yaml as Y
+import GHC.Generics (Generic)
+import Options
+import Simplex.Messaging.Parsers (taggedObjectJSON, dropPrefix)
+import Simplex.Messaging.TMap (TMap)
+
+data SurveyDescription = SurveyDescription
+  { welcomeMessage :: String,
+    surveyQuestions :: NonEmpty SurveyQuestion,
+    thankYouMessage :: String
+  }
+  deriving (Eq, Show, Generic, FromJSON)
+
+data SurveyQuestion
+  = SQText {question :: String}
+  | SQChoice {question :: String, choices :: NonEmpty String, multiple :: Bool, allowOther :: Bool}
+  deriving (Eq, Show, Generic)
+
+instance FromJSON SurveyQuestion where
+  parseJSON = J.genericParseJSON . taggedObjectJSON $ dropPrefix "SQ"
+
+data SurveyAnswer = SurveyAnswer
+  { answerText :: String,
+    answeredAt :: UTCTime
+  }
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance ToJSON SurveyAnswer where toEncoding = J.genericToEncoding J.defaultOptions
+
+data ContactQuestion = ContactQuestion
+  { contactId :: Int64,
+    contactName :: String,
+    questionNo :: Int
+  }
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance ToJSON ContactQuestion where toEncoding = J.genericToEncoding J.defaultOptions
+
+data SurveyLogRecord
+  = SLQuestion {contactQuestion :: ContactQuestion, question :: SentQuestion}
+  | SLAnswer {contactQuestion :: ContactQuestion, answer :: SurveyAnswer}
+  deriving (Eq, Show, Generic)
+
+data SentQuestion = SentQuestion
+  { questionNo :: Int,
+    questionText :: String,
+    sentAt :: UTCTime
+  }
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance ToJSON SentQuestion where toEncoding = J.genericToEncoding J.defaultOptions
+
+instance ToJSON SurveyLogRecord where
+  toEncoding = J.genericToEncoding . taggedObjectJSON $ dropPrefix "SL"
+  toJSON = J.genericToJSON . taggedObjectJSON $ dropPrefix "SL"
+
+instance FromJSON SurveyLogRecord where
+  parseJSON = J.genericParseJSON . taggedObjectJSON $ dropPrefix "SL"
+
+data SurveyContactState = SurveyContactState
+  { answers :: [SurveyAnswer],
+    sentQuestion :: Maybe SentQuestion,
+    completed :: Bool
+  }
+
+data SurveyState = SurveyState
+  { survey :: SurveyDescription,
+    respondents :: TMap Int64 SurveyContactState
+  }
+
+readSurveyState :: SurveyBotOpts -> IO SurveyState
+readSurveyState SurveyBotOpts {surveyDescription, surveyLog} = do
+  survey <- (Y.decodeEither' <$> B.readFile surveyDescription) >>= either (fail . Y.prettyPrintParseException) pure
+  rs <- map J.eitherDecodeStrict . B.lines <$> B.readFile surveyLog
+  let rs' = foldl' addAnswer M.empty rs
+  respondents <- newTVarIO rs'
+  pure SurveyState {survey, respondents}
+  where
+    addAnswer :: Map Int64 SurveyContactState -> Either String SurveyLogRecord -> Map Int64 SurveyContactState
+    addAnswer m = \case
+      Right r -> M.alter (Just . add) (contactId cq) m
+        where
+          cq = contactQuestion r
+          add = \case
+            Just s@SurveyContactState {answers} -> case r of
+              SLQuestion {question} -> s {sentQuestion = Just question}
+              SLAnswer {answer} -> s {answers = answers <> [answer]}
+            Nothing -> case r of
+              SLQuestion {question} -> SurveyContactState {answers = [], sentQuestion = Just question, completed = False}
+              SLAnswer {answer} -> SurveyContactState {answers = [answer], sentQuestion = Nothing, completed = False}
+      Left e -> error e

package.yaml

@@ -47,6 +47,7 @@ dependencies:
   - time == 1.9.*
   - unliftio == 0.2.*
   - unliftio-core == 0.2.*
+  - yaml == 0.11.*
   - zip == 1.7.*
 
 flags:
@@ -98,6 +99,14 @@ executables:
     ghc-options:
       - -threaded
 
+  simplex-survey-bot:
+    source-dirs: apps/simplex-survey-bot
+    main: Main.hs
+    dependencies:
+      - simplex-chat
+    ghc-options:
+      - -threaded
+
 tests:
   simplex-chat-test:
     source-dirs: tests

simplex-chat.cabal

@@ -323,6 +323,58 @@ executable simplex-broadcast-bot
   if flag(swift)
     cpp-options: -DswiftJSON
 
+executable simplex-survey-bot
+  main-is: Main.hs
+  other-modules:
+      Options
+      Paths_simplex_chat
+      Survey
+  hs-source-dirs:
+      apps/simplex-survey-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.*
+    , constraints >=0.12 && <0.14
+    , containers ==0.6.*
+    , cryptonite >=0.27 && <0.30
+    , direct-sqlcipher ==2.3.*
+    , directory ==1.3.*
+    , email-validate ==2.3.*
+    , exceptions ==0.10.*
+    , filepath ==1.4.*
+    , http-types ==0.12.*
+    , memory ==0.15.*
+    , mtl ==2.2.*
+    , network >=3.1.2.7 && <3.2
+    , optparse-applicative >=0.15 && <0.17
+    , process ==1.6.*
+    , random >=1.1 && <1.3
+    , record-hasfield ==1.0.*
+    , simple-logger ==0.1.*
+    , simplex-chat
+    , simplexmq >=5.0
+    , socks ==0.6.*
+    , sqlcipher-simple ==0.4.*
+    , stm ==2.5.*
+    , template-haskell ==2.16.*
+    , terminal ==0.2.*
+    , text ==1.2.*
+    , time ==1.9.*
+    , unliftio ==0.2.*
+    , unliftio-core ==0.2.*
+    , yaml ==0.11.*
+    , zip ==1.7.*
+  default-language: Haskell2010
+  if flag(swift)
+    cpp-options: -DswiftJSON
+
 executable simplex-chat
   main-is: Main.hs
   other-modules: