{-# 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.Except
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as B
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.Store.Shared (StoreError (..))
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences (FeatureAllowed (..), FilesPreference (..), Preferences (..), emptyChatPrefs)
import Simplex.Chat.View (ChatResponseEvent, serializeChatError, serializeChatResponse, simplexChatContact)
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..))
import Simplex.Messaging.Encoding.String
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
$sel:confirmMigrations:ChatConfig :: ChatConfig -> MigrationConfirmation
confirmMigrations, Bool
testView :: Bool
$sel:testView:ChatConfig :: ChatConfig -> Bool
testView, ChatHooks
chatHooks :: ChatHooks
$sel:chatHooks:ChatConfig :: ChatConfig -> ChatHooks
chatHooks} opts :: ChatOpts
opts@ChatOpts {$sel:coreOptions:ChatOpts :: ChatOpts -> CoreChatOpts
coreOptions = coreOptions :: CoreChatOpts
coreOptions@CoreChatOpts {ChatDbOpts
dbOptions :: ChatDbOpts
$sel:dbOptions:CoreChatOpts :: CoreChatOpts -> ChatDbOpts
dbOptions, Maybe LogLevel
logAgent :: Maybe LogLevel
$sel:logAgent:CoreChatOpts :: CoreChatOpts -> Maybe LogLevel
logAgent, Bool
yesToUpMigrations :: Bool
$sel:yesToUpMigrations:CoreChatOpts :: CoreChatOpts -> Bool
yesToUpMigrations, Maybe String
migrationBackupPath :: Maybe String
$sel:migrationBackupPath:CoreChatOpts :: CoreChatOpts -> Maybe String
migrationBackupPath, Bool
maintenance :: Bool
$sel:maintenance:CoreChatOpts :: CoreChatOpts -> Bool
maintenance}, Maybe CreateBotOpts
createBot :: Maybe CreateBotOpts
$sel:createBot:ChatOpts :: ChatOpts -> Maybe CreateBotOpts
createBot} 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
$sel:chatStore:ChatDatabase :: ChatDatabase -> DBStore
chatStore} = do
      [User]
users <- DBStore -> (Connection -> IO [User]) -> IO [User]
forall a. DBStore -> (Connection -> IO a) -> IO a
withTransaction DBStore
chatStore Connection -> IO [User]
getUsers
      Maybe User
u_ <- CoreChatOpts -> DBStore -> [User] -> IO (Maybe User)
selectActiveUser CoreChatOpts
coreOptions DBStore
chatStore [User]
users
      let backgroundMode :: Bool
backgroundMode = Bool
maintenance
      ChatController
cc <- ChatDatabase
-> Maybe User
-> ChatConfig
-> ChatOpts
-> Bool
-> IO ChatController
newChatController ChatDatabase
db Maybe User
u_ ChatConfig
cfg ChatOpts
opts Bool
backgroundMode
      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)
      User
u <- IO User -> (User -> IO User) -> Maybe User -> IO User
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO ()
noMaintenance 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
>> ChatController -> CoreChatOpts -> Maybe CreateBotOpts -> IO User
createActiveUser ChatController
cc CoreChatOpts
coreOptions 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
      ChatConfig
-> ChatOpts
-> User
-> ChatController
-> (User -> ChatController -> IO ())
-> IO ()
runSimplexChat ChatConfig
cfg ChatOpts
opts User
u ChatController
cc User -> ChatController -> IO ()
chat
    noMaintenance :: IO ()
noMaintenance = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
maintenance (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
putStrLn String
"exiting: no active user in maintenance mode"
      IO ()
forall a. IO a
exitFailure

runSimplexChat :: ChatConfig -> ChatOpts -> User -> ChatController -> (User -> ChatController -> IO ()) -> IO ()
runSimplexChat :: ChatConfig
-> ChatOpts
-> User
-> ChatController
-> (User -> ChatController -> IO ())
-> IO ()
runSimplexChat ChatConfig {Bool
$sel:testView:ChatConfig :: ChatConfig -> Bool
testView :: Bool
testView} ChatOpts {$sel:coreOptions:ChatOpts :: ChatOpts -> CoreChatOpts
coreOptions = CoreChatOpts {Bool
chatRelay :: Bool
$sel:chatRelay:CoreChatOpts :: CoreChatOpts -> Bool
chatRelay, Bool
$sel:maintenance:CoreChatOpts :: CoreChatOpts -> Bool
maintenance :: Bool
maintenance}} User
u cc :: ChatController
cc@ChatController {$sel:config:ChatController :: ChatController -> ChatConfig
config = ChatConfig {ChatHooks
$sel:chatHooks:ChatConfig :: 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
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
chatRelay Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
testView) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatController -> User -> IO ()
askCreateRelayAddress ChatController
cc User
u
      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

selectActiveUser :: CoreChatOpts -> DBStore -> [User] -> IO (Maybe User)
selectActiveUser :: CoreChatOpts -> DBStore -> [User] -> IO (Maybe User)
selectActiveUser CoreChatOpts {Bool
$sel:chatRelay:CoreChatOpts :: CoreChatOpts -> Bool
chatRelay :: Bool
chatRelay} DBStore
st [User]
users
  | Bool
chatRelay =
      case (User -> Bool) -> [User] -> Maybe User
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\User {BoolDef
userChatRelay :: BoolDef
$sel:userChatRelay:User :: User -> BoolDef
userChatRelay} -> BoolDef -> Bool
isTrue BoolDef
userChatRelay) [User]
users of
        Just User
u
          | User -> Bool
activeUser 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
          | Bool
otherwise -> 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
u)
        Maybe User
Nothing -> 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
  | Bool
otherwise =
      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 -> IO (Maybe User)
selectUser
  where
    selectUser :: IO (Maybe User)
    selectUser :: IO (Maybe User)
selectUser = case [User]
users of
      [] -> 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 -> IO String
forall a. String -> IO a -> IO a
withPrompt (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
"): ") IO String
getLine
            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 -> CoreChatOpts -> Maybe CreateBotOpts -> IO User
createActiveUser :: ChatController -> CoreChatOpts -> Maybe CreateBotOpts -> IO User
createActiveUser ChatController
cc CoreChatOpts {Bool
$sel:chatRelay:CoreChatOpts :: CoreChatOpts -> Bool
chatRelay :: Bool
chatRelay} = \case
  Just CreateBotOpts {Text
botDisplayName :: Text
$sel:botDisplayName:CreateBotOpts :: CreateBotOpts -> Text
botDisplayName, Bool
allowFiles :: Bool
$sel:allowFiles:CreateBotOpts :: 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
    | Bool
chatRelay -> do
        String -> IO ()
putStrLn
          String
"No chat relay user profile found, it will be created now.\n\
          \Please choose chat relay display name."
        IO User
loop
    | Bool
otherwise -> 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 -> IO String
forall a. String -> IO a -> IO a
withPrompt String
"display name: " IO String
getLine
      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
$sel:displayName:Profile :: Text
displayName, $sel:fullName:Profile :: Text
fullName = Text
"", $sel:shortDescr:Profile :: Maybe Text
shortDescr = Maybe Text
forall a. Maybe a
Nothing, $sel:image:Profile :: Maybe ImageData
image = Maybe ImageData
forall a. Maybe a
Nothing, $sel:contactLink:Profile :: Maybe ConnLinkContact
contactLink = Maybe ConnLinkContact
forall a. Maybe a
Nothing, $sel:peerType:Profile :: Maybe ChatPeerType
peerType = Maybe ChatPeerType
forall a. Maybe a
Nothing, $sel:preferences:Profile :: 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 {$sel:profile:NewUser :: Maybe Profile
profile = Profile -> Maybe Profile
forall a. a -> Maybe a
Just Profile
p, $sel:pastTimestamp:NewUser :: Bool
pastTimestamp = Bool
False, $sel:userChatRelay:NewUser :: Bool
userChatRelay = Bool
chatRelay}) 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

askCreateRelayAddress :: ChatController -> User -> IO ()
askCreateRelayAddress :: ChatController -> User -> IO ()
askCreateRelayAddress cc :: ChatController
cc@ChatController {DBStore
chatStore :: DBStore
$sel:chatStore:ChatController :: ChatController -> DBStore
chatStore} User
user =
  DBStore
-> (Connection -> IO (Either StoreError UserContactLink))
-> IO (Either StoreError UserContactLink)
forall a. DBStore -> (Connection -> IO a) -> IO a
withTransaction DBStore
chatStore (\Connection
db -> ExceptT StoreError IO UserContactLink
-> IO (Either StoreError UserContactLink)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO UserContactLink
 -> IO (Either StoreError UserContactLink))
-> ExceptT StoreError IO UserContactLink
-> IO (Either StoreError UserContactLink)
forall a b. (a -> b) -> a -> b
$ Connection -> User -> ExceptT StoreError IO UserContactLink
getUserAddress Connection
db User
user) IO (Either StoreError UserContactLink)
-> (Either StoreError UserContactLink -> 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
>>= \case
    Right UserContactLink
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Left StoreError
SEUserContactLinkNotFound -> IO ()
promptCreate
    Left StoreError
e -> ChatConfig -> ChatError -> IO ()
printChatError (ChatController -> ChatConfig
config ChatController
cc) (ChatError -> IO ()) -> ChatError -> IO ()
forall a b. (a -> b) -> a -> b
$ StoreError -> ChatError
ChatErrorStore StoreError
e
  where
    promptCreate :: IO ()
    promptCreate :: IO ()
promptCreate = do
      Bool
ok <- String -> Bool -> IO Bool
onOffPrompt String
"Create relay address" Bool
True
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        ChatCommand
-> Int -> ReaderT ChatController IO (Either ChatError ChatResponse)
execChatCommand' ChatCommand
CreateMyAddress 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 ()) -> IO ()
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 (CRUserContactLinkCreated User
_ CreatedLinkContact
address) -> do
            String -> IO ()
putStrLn String
"Chat relay address is created:"
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ CreatedLinkContact -> String
addressStr CreatedLinkContact
address
          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
    addressStr :: CreatedLinkContact -> String
    addressStr :: CreatedLinkContact -> String
addressStr (CCLink ConnectionRequestUri 'CMContact
cReq Maybe (ConnShortLink 'CMContact)
shortLink) = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString
-> (ConnShortLink 'CMContact -> ByteString)
-> Maybe (ConnShortLink 'CMContact)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
cReqStr ConnShortLink 'CMContact -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode Maybe (ConnShortLink 'CMContact)
shortLink
      where
        cReqStr :: ByteString
cReqStr = ConnectionRequestUri 'CMContact -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (ConnectionRequestUri 'CMContact -> ByteString)
-> ConnectionRequestUri 'CMContact -> ByteString
forall a b. (a -> b) -> a -> b
$ ConnectionRequestUri 'CMContact -> ConnectionRequestUri 'CMContact
simplexChatContact ConnectionRequestUri 'CMContact
cReq

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 -> ChatConfig -> ChatError -> IO ()
printChatError ChatConfig
cfg ChatError
e

printChatError :: ChatConfig -> ChatError -> IO ()
printChatError :: ChatConfig -> ChatError -> IO ()
printChatError ChatConfig
cfg ChatError
e = 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

withPrompt :: String -> IO a -> IO a
withPrompt :: forall a. String -> IO a -> IO a
withPrompt String
s IO a
a = String -> IO ()
putStr String
s 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 a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
a

onOffPrompt :: String -> Bool -> IO Bool
onOffPrompt :: String -> Bool -> IO Bool
onOffPrompt String
prompt Bool
def =
  String -> IO Bool -> IO Bool
forall a. String -> IO a -> IO a
withPrompt (String
prompt String -> String -> String
forall a. Semigroup a => a -> a -> a
<> if Bool
def then String
" (Yn): " else String
" (yN): ") (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
    IO String
getLine IO String -> (String -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      String
"" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
def
      String
"y" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      String
"Y" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      String
"n" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      String
"N" -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      String
_ -> String -> IO ()
putStrLn String
"Invalid input, please enter 'y' or 'n'" IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Bool -> IO Bool
onOffPrompt String
prompt Bool
def

userStr :: User -> String
userStr :: User -> String
userStr User {Text
localDisplayName :: Text
$sel:localDisplayName:User :: User -> Text
localDisplayName, $sel:profile:User :: User -> LocalProfile
profile = LocalProfile {Text
fullName :: Text
$sel:fullName:LocalProfile :: 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
")"