diff --git a/apps/simplex-survey-bot/Main.hs b/apps/simplex-survey-bot/Main.hs new file mode 100644 index 0000000000..a7e9317a4c --- /dev/null +++ b/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" diff --git a/apps/simplex-survey-bot/Options.hs b/apps/simplex-survey-bot/Options.hs new file mode 100644 index 0000000000..91a181f398 --- /dev/null +++ b/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 + } diff --git a/apps/simplex-survey-bot/README.md b/apps/simplex-survey-bot/README.md new file mode 100644 index 0000000000..e69de29bb2 diff --git a/apps/simplex-survey-bot/Survey.hs b/apps/simplex-survey-bot/Survey.hs new file mode 100644 index 0000000000..f805f914e2 --- /dev/null +++ b/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 diff --git a/package.yaml b/package.yaml index 0e0f49a2b7..9e74c4eb41 100644 --- a/package.yaml +++ b/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 diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 8a2bb16a69..d058390bac 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -319,6 +319,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: