{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

module Simplex.Chat.Core
  ( simplexChatCore,
    runSimplexChat,
    sendChatCmdStr,
    sendChatCmd,
    printResponseEvent,
  )
where

import Control.Logger.Simple
import Control.Monad
import Control.Monad.Reader
import Data.List (find)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone)
import Simplex.Chat
import Simplex.Chat.Controller
import Simplex.Chat.Library.Commands
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..), CreateBotOpts (..))
import Simplex.Chat.Remote.Types (RemoteHostId)
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences (FeatureAllowed (..), FilesPreference (..), Preferences (..), emptyChatPrefs)
import Simplex.Chat.View (ChatResponseEvent, serializeChatError, serializeChatResponse)
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..))
import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
import System.Exit (exitFailure)
import System.IO (hFlush, stdout)
import Text.Read (readMaybe)
import UnliftIO.Async

simplexChatCore :: ChatConfig -> ChatOpts -> (User -> ChatController -> IO ()) -> IO ()
simplexChatCore :: ChatConfig
-> ChatOpts -> (User -> ChatController -> IO ()) -> IO ()
simplexChatCore cfg :: ChatConfig
cfg@ChatConfig {MigrationConfirmation
confirmMigrations :: MigrationConfirmation
confirmMigrations :: ChatConfig -> MigrationConfirmation
confirmMigrations, Bool
testView :: Bool
testView :: ChatConfig -> Bool
testView, ChatHooks
chatHooks :: ChatHooks
chatHooks :: ChatConfig -> ChatHooks
chatHooks} opts :: ChatOpts
opts@ChatOpts {coreOptions :: ChatOpts -> CoreChatOpts
coreOptions = CoreChatOpts {ChatDbOpts
dbOptions :: ChatDbOpts
dbOptions :: CoreChatOpts -> ChatDbOpts
dbOptions, Maybe LogLevel
logAgent :: Maybe LogLevel
logAgent :: CoreChatOpts -> Maybe LogLevel
logAgent, Bool
yesToUpMigrations :: Bool
yesToUpMigrations :: CoreChatOpts -> Bool
yesToUpMigrations, Maybe String
migrationBackupPath :: Maybe String
migrationBackupPath :: CoreChatOpts -> Maybe String
migrationBackupPath}, Maybe CreateBotOpts
createBot :: Maybe CreateBotOpts
createBot :: ChatOpts -> Maybe CreateBotOpts
createBot, Bool
maintenance :: Bool
maintenance :: ChatOpts -> Bool
maintenance} User -> ChatController -> IO ()
chat =
  case Maybe LogLevel
logAgent of
    Just LogLevel
level -> do
      LogLevel -> IO ()
setLogLevel LogLevel
level
      LogConfig -> IO () -> IO ()
forall a. LogConfig -> IO a -> IO a
withGlobalLogging LogConfig
logCfg IO ()
initRun
    Maybe LogLevel
_ -> IO ()
initRun
  where
    initRun :: IO ()
initRun = ChatDbOpts
-> MigrationConfig -> IO (Either MigrationError ChatDatabase)
createChatDatabase ChatDbOpts
dbOptions MigrationConfig
migrationConfig IO (Either MigrationError ChatDatabase)
-> (Either MigrationError ChatDatabase -> 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
>>= (MigrationError -> IO ())
-> (ChatDatabase -> IO ())
-> Either MigrationError ChatDatabase
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either MigrationError -> IO ()
forall {a} {b}. Show a => a -> IO b
exit ChatDatabase -> IO ()
run
    migrationConfig :: MigrationConfig
migrationConfig = MigrationConfirmation -> Maybe String -> MigrationConfig
MigrationConfig (if MigrationConfirmation
confirmMigrations MigrationConfirmation -> MigrationConfirmation -> Bool
forall a. Eq a => a -> a -> Bool
== MigrationConfirmation
MCConsole Bool -> Bool -> Bool
&& Bool
yesToUpMigrations then MigrationConfirmation
MCYesUp else MigrationConfirmation
confirmMigrations) Maybe String
migrationBackupPath
    exit :: a -> IO b
exit a
e = do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error opening database: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
e
      IO b
forall a. IO a
exitFailure
    run :: ChatDatabase -> IO ()
run db :: ChatDatabase
db@ChatDatabase {DBStore
chatStore :: DBStore
chatStore :: ChatDatabase -> DBStore
chatStore} = do
      Maybe User
u_ <- DBStore -> IO (Maybe User)
getSelectActiveUser DBStore
chatStore
      let backgroundMode :: Bool
backgroundMode = Bool -> Bool
not Bool
maintenance
      ChatController
cc <- ChatDatabase
-> Maybe User
-> ChatConfig
-> ChatOpts
-> Bool
-> IO ChatController
newChatController ChatDatabase
db Maybe User
u_ ChatConfig
cfg ChatOpts
opts Bool
backgroundMode
      User
u <- IO User -> (User -> IO User) -> Maybe User -> IO User
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ChatController -> Maybe CreateBotOpts -> IO User
createActiveUser ChatController
cc Maybe CreateBotOpts
createBot) User -> IO User
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe User
u_
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
testView (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
"Current user: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> User -> String
userStr User
u
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
maintenance (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (ChatController -> IO ())
-> ((ChatController -> IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ChatHooks -> Maybe (ChatController -> IO ())
preStartHook ChatHooks
chatHooks) ((ChatController -> IO ()) -> ChatController -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatController
cc)
      ChatOpts
-> User
-> ChatController
-> (User -> ChatController -> IO ())
-> IO ()
runSimplexChat ChatOpts
opts User
u ChatController
cc User -> ChatController -> IO ()
chat

runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController -> IO ()) -> IO ()
runSimplexChat :: ChatOpts
-> User
-> ChatController
-> (User -> ChatController -> IO ())
-> IO ()
runSimplexChat ChatOpts {Bool
maintenance :: ChatOpts -> Bool
maintenance :: Bool
maintenance} User
u cc :: ChatController
cc@ChatController {config :: ChatController -> ChatConfig
config = ChatConfig {ChatHooks
chatHooks :: ChatConfig -> ChatHooks
chatHooks :: ChatHooks
chatHooks}} User -> ChatController -> IO ()
chat
  | Bool
maintenance = Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait (Async () -> IO ()) -> IO (Async ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (User -> ChatController -> IO ()
chat User
u ChatController
cc)
  | Bool
otherwise = do
      Async ()
a1 <- ReaderT ChatController IO (Async ())
-> ChatController -> IO (Async ())
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Bool -> Bool -> ReaderT ChatController IO (Async ())
startChatController Bool
True Bool
True) ChatController
cc
      Maybe (ChatController -> IO ())
-> ((ChatController -> IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ChatHooks -> Maybe (ChatController -> IO ())
postStartHook ChatHooks
chatHooks) ((ChatController -> IO ()) -> ChatController -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatController
cc)
      Async ()
a2 <- IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ User -> ChatController -> IO ()
chat User
u ChatController
cc
      Async () -> Async () -> IO ()
forall (m :: * -> *) a b. MonadIO m => Async a -> Async b -> m ()
waitEither_ Async ()
a1 Async ()
a2

sendChatCmdStr :: ChatController -> String -> IO (Either ChatError ChatResponse)
sendChatCmdStr :: ChatController -> String -> IO (Either ChatError ChatResponse)
sendChatCmdStr ChatController
cc String
s = ReaderT ChatController IO (Either ChatError ChatResponse)
-> ChatController -> IO (Either ChatError ChatResponse)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Maybe RemoteHostId
-> ByteString
-> Int
-> ReaderT ChatController IO (Either ChatError ChatResponse)
execChatCommand Maybe RemoteHostId
forall a. Maybe a
Nothing (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s) Int
0) ChatController
cc

sendChatCmd :: ChatController -> ChatCommand -> IO (Either ChatError ChatResponse)
sendChatCmd :: ChatController -> ChatCommand -> IO (Either ChatError ChatResponse)
sendChatCmd ChatController
cc ChatCommand
cmd = ReaderT ChatController IO (Either ChatError ChatResponse)
-> ChatController -> IO (Either ChatError ChatResponse)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ChatCommand
-> Int -> ReaderT ChatController IO (Either ChatError ChatResponse)
execChatCommand' ChatCommand
cmd Int
0) ChatController
cc

getSelectActiveUser :: DBStore -> IO (Maybe User)
getSelectActiveUser :: DBStore -> IO (Maybe User)
getSelectActiveUser DBStore
st = do
  [User]
users <- DBStore -> (Connection -> IO [User]) -> IO [User]
forall a. DBStore -> (Connection -> IO a) -> IO a
withTransaction DBStore
st Connection -> IO [User]
getUsers
  case (User -> Bool) -> [User] -> Maybe User
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find User -> Bool
activeUser [User]
users of
    Just User
u -> Maybe User -> IO (Maybe User)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe User -> IO (Maybe User)) -> Maybe User -> IO (Maybe User)
forall a b. (a -> b) -> a -> b
$ User -> Maybe User
forall a. a -> Maybe a
Just User
u
    Maybe User
Nothing -> [User] -> IO (Maybe User)
selectUser [User]
users
  where
    selectUser :: [User] -> IO (Maybe User)
    selectUser :: [User] -> IO (Maybe User)
selectUser = \case
      [] -> Maybe User -> IO (Maybe User)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe User
forall a. Maybe a
Nothing
      [User
user] -> User -> Maybe User
forall a. a -> Maybe a
Just (User -> Maybe User) -> IO User -> IO (Maybe User)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DBStore -> (Connection -> IO User) -> IO User
forall a. DBStore -> (Connection -> IO a) -> IO a
withTransaction DBStore
st (Connection -> User -> IO User
`setActiveUser` User
user)
      [User]
users -> do
        String -> IO ()
putStrLn String
"Select user profile:"
        [(Int, User)] -> ((Int, User) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [User] -> [(Int, User)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] [User]
users) (((Int, User) -> IO ()) -> IO ())
-> ((Int, User) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
n, User
user) -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> User -> String
userStr User
user
        IO (Maybe User)
loop
        where
          loop :: IO (Maybe User)
loop = do
            String
nStr <- String -> IO String
getWithPrompt (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"user number (1 .. " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([User] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [User]
users) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
            case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
nStr :: Maybe Int of
              Maybe Int
Nothing -> String -> IO ()
putStrLn String
"not a number" IO () -> IO (Maybe User) -> IO (Maybe User)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Maybe User)
loop
              Just Int
n
                | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [User] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [User]
users -> String -> IO ()
putStrLn String
"invalid user number" IO () -> IO (Maybe User) -> IO (Maybe User)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Maybe User)
loop
                | Bool
otherwise ->
                    let user :: User
user = [User]
users [User] -> Int -> User
forall a. HasCallStack => [a] -> Int -> a
!! (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                     in User -> Maybe User
forall a. a -> Maybe a
Just (User -> Maybe User) -> IO User -> IO (Maybe User)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DBStore -> (Connection -> IO User) -> IO User
forall a. DBStore -> (Connection -> IO a) -> IO a
withTransaction DBStore
st (Connection -> User -> IO User
`setActiveUser` User
user)

createActiveUser :: ChatController -> Maybe CreateBotOpts -> IO User
createActiveUser :: ChatController -> Maybe CreateBotOpts -> IO User
createActiveUser ChatController
cc = \case
  Just CreateBotOpts {Text
botDisplayName :: Text
botDisplayName :: CreateBotOpts -> Text
botDisplayName, Bool
allowFiles :: Bool
allowFiles :: CreateBotOpts -> Bool
allowFiles} -> do
    let preferences :: Maybe Preferences
preferences = if Bool
allowFiles then Maybe Preferences
forall a. Maybe a
Nothing else Preferences -> Maybe Preferences
forall a. a -> Maybe a
Just Preferences
emptyChatPrefs {files = Just FilesPreference {allow = FANo}}
    IO User -> Profile -> IO User
createUser IO User
forall a. IO a
exitFailure (Profile -> IO User) -> Profile -> IO User
forall a b. (a -> b) -> a -> b
$ (Text -> Profile
mkProfile Text
botDisplayName) {peerType = Just CPTBot, preferences}
  Maybe CreateBotOpts
Nothing -> do
    String -> IO ()
putStrLn
      String
"No user profiles found, it will be created now.\n\
      \Please choose your display name.\n\
      \It will be sent to your contacts when you connect.\n\
      \It is only stored on your device and you can change it later."
    IO User
loop
  where
    loop :: IO User
loop = do
      Text
displayName <- String -> Text
T.pack (String -> Text) -> IO String -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
getWithPrompt String
"display name"
      IO User -> Profile -> IO User
createUser IO User
loop (Profile -> IO User) -> Profile -> IO User
forall a b. (a -> b) -> a -> b
$ Text -> Profile
mkProfile Text
displayName
    mkProfile :: Text -> Profile
mkProfile Text
displayName = Profile {Text
displayName :: Text
displayName :: Text
displayName, fullName :: Text
fullName = Text
"", shortDescr :: Maybe Text
shortDescr = Maybe Text
forall a. Maybe a
Nothing, image :: Maybe ImageData
image = Maybe ImageData
forall a. Maybe a
Nothing, contactLink :: Maybe ConnLinkContact
contactLink = Maybe ConnLinkContact
forall a. Maybe a
Nothing, peerType :: Maybe ChatPeerType
peerType = Maybe ChatPeerType
forall a. Maybe a
Nothing, preferences :: Maybe Preferences
preferences = Maybe Preferences
forall a. Maybe a
Nothing}
    createUser :: IO User -> Profile -> IO User
createUser IO User
onError Profile
p =
      ChatCommand
-> Int -> ReaderT ChatController IO (Either ChatError ChatResponse)
execChatCommand' (NewUser -> ChatCommand
CreateActiveUser NewUser {profile :: Maybe Profile
profile = Profile -> Maybe Profile
forall a. a -> Maybe a
Just Profile
p, pastTimestamp :: Bool
pastTimestamp = Bool
False}) Int
0 ReaderT ChatController IO (Either ChatError ChatResponse)
-> ChatController -> IO (Either ChatError ChatResponse)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ChatController
cc IO (Either ChatError ChatResponse)
-> (Either ChatError ChatResponse -> IO User) -> IO User
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 (CRActiveUser User
user) -> User -> IO User
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure User
user
        Either ChatError ChatResponse
r -> (Maybe RemoteHostId, Maybe User)
-> ChatConfig -> Either ChatError ChatResponse -> IO ()
forall r.
ChatResponseEvent r =>
(Maybe RemoteHostId, Maybe User)
-> ChatConfig -> Either ChatError r -> IO ()
printResponseEvent (Maybe RemoteHostId
forall a. Maybe a
Nothing, Maybe User
forall a. Maybe a
Nothing) (ChatController -> ChatConfig
config ChatController
cc) Either ChatError ChatResponse
r IO () -> IO User -> IO User
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO User
onError

printResponseEvent :: ChatResponseEvent r => (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Either ChatError r -> IO ()
printResponseEvent :: forall r.
ChatResponseEvent r =>
(Maybe RemoteHostId, Maybe User)
-> ChatConfig -> Either ChatError r -> IO ()
printResponseEvent (Maybe RemoteHostId, Maybe User)
hu ChatConfig
cfg = \case
  Right r
r -> do
    UTCTime
ts <- IO UTCTime
getCurrentTime
    TimeZone
tz <- IO TimeZone
getCurrentTimeZone
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (Maybe RemoteHostId, Maybe User)
-> ChatConfig
-> UTCTime
-> TimeZone
-> Maybe RemoteHostId
-> r
-> String
forall r.
ChatResponseEvent r =>
(Maybe RemoteHostId, Maybe User)
-> ChatConfig
-> UTCTime
-> TimeZone
-> Maybe RemoteHostId
-> r
-> String
serializeChatResponse (Maybe RemoteHostId, Maybe User)
hu ChatConfig
cfg UTCTime
ts TimeZone
tz ((Maybe RemoteHostId, Maybe User) -> Maybe RemoteHostId
forall a b. (a, b) -> a
fst (Maybe RemoteHostId, Maybe User)
hu) r
r
  Left ChatError
e -> do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> ChatConfig -> ChatError -> String
serializeChatError Bool
True ChatConfig
cfg ChatError
e

getWithPrompt :: String -> IO String
getWithPrompt :: String -> IO String
getWithPrompt String
s = String -> IO ()
putStr (String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": ") IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout IO () -> IO String -> IO String
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO String
getLine

userStr :: User -> String
userStr :: User -> String
userStr User {Text
localDisplayName :: Text
localDisplayName :: User -> Text
localDisplayName, profile :: User -> LocalProfile
profile = LocalProfile {Text
fullName :: Text
fullName :: LocalProfile -> Text
fullName}} =
  Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
localDisplayName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Text -> Bool
T.null Text
fullName Bool -> Bool -> Bool
|| Text
localDisplayName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
fullName then Text
"" else Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fullName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"