{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fobject-code #-}

module Simplex.Chat.Mobile where

import Control.Concurrent.STM
import Control.Exception (SomeException, catch)
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson (ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import Data.Bifunctor (first)
import qualified Data.ByteString.Base64.URL as U
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Functor (($>))
import Data.List (find)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Word (Word8)
import Foreign.C.String
import Foreign.C.Types (CInt (..))
import Foreign.Ptr
import Foreign.StablePtr
import Foreign.Storable (poke)
import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding)
import Simplex.Chat
import Simplex.Chat.Controller
import Simplex.Chat.Library.Commands
import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList, parseUri, sanitizeUri)
import Simplex.Chat.Mobile.File
import Simplex.Chat.Mobile.Shared
import Simplex.Chat.Mobile.WebRTC
import Simplex.Chat.Options
import Simplex.Chat.Options.DB
import Simplex.Chat.Remote.Types
import Simplex.Chat.Store
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Client (agentClientStore)
import Simplex.Messaging.Agent.Env.SQLite (createAgentStore)
import Simplex.Messaging.Agent.Store.Interface (closeDBStore, reopenDBStore)
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..))
import Simplex.Messaging.Util (catchAll, liftEitherWith, safeDecodeUtf8)
import System.IO (utf8)
import System.Timeout (timeout)
import qualified URI.ByteString as U
#if !defined(dbPostgres)
import Data.ByteArray (ScrubbedBytes)
import Database.SQLite.Simple (SQLError (..))
import qualified Database.SQLite.Simple as DB
import qualified Simplex.Messaging.Agent.Store.DB as DB
#endif

data DBMigrationResult
  = DBMOk
  | DBMInvalidConfirmation
  | DBMErrorNotADatabase {DBMigrationResult -> String
dbFile :: String}
  | DBMErrorMigration {dbFile :: String, DBMigrationResult -> MigrationError
migrationError :: MigrationError}
  | DBMErrorSQL {dbFile :: String, DBMigrationResult -> String
migrationSQLError :: String}
  deriving (Int -> DBMigrationResult -> ShowS
[DBMigrationResult] -> ShowS
DBMigrationResult -> String
(Int -> DBMigrationResult -> ShowS)
-> (DBMigrationResult -> String)
-> ([DBMigrationResult] -> ShowS)
-> Show DBMigrationResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DBMigrationResult -> ShowS
showsPrec :: Int -> DBMigrationResult -> ShowS
$cshow :: DBMigrationResult -> String
show :: DBMigrationResult -> String
$cshowList :: [DBMigrationResult] -> ShowS
showList :: [DBMigrationResult] -> ShowS
Show)

$(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "DBM") ''DBMigrationResult)

data APIResult r
  = APIResult  {forall r. APIResult r -> Maybe Int64
remoteHostId :: Maybe RemoteHostId, forall r. APIResult r -> r
result :: r}
  | APIError {remoteHostId :: Maybe RemoteHostId, forall r. APIResult r -> ChatError
error :: ChatError}

eitherToResult :: Maybe RemoteHostId -> Either ChatError r -> APIResult r
eitherToResult :: forall r. Maybe Int64 -> Either ChatError r -> APIResult r
eitherToResult Maybe Int64
rhId = (ChatError -> APIResult r)
-> (r -> APIResult r) -> Either ChatError r -> APIResult r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Int64 -> ChatError -> APIResult r
forall r. Maybe Int64 -> ChatError -> APIResult r
APIError Maybe Int64
rhId) (Maybe Int64 -> r -> APIResult r
forall r. Maybe Int64 -> r -> APIResult r
APIResult Maybe Int64
rhId)
{-# INLINE eitherToResult #-}

data ParsedUri = ParsedUri
  { ParsedUri -> Maybe UriInfo
uriInfo :: Maybe UriInfo,
    ParsedUri -> Text
parseError :: Text
  }

data UriInfo = UriInfo
  { UriInfo -> Text
scheme :: Text,
    UriInfo -> Maybe Text
sanitized :: Maybe Text
  }

$(JQ.deriveJSON defaultJSON ''UriInfo)

$(JQ.deriveJSON defaultJSON ''ParsedUri)

$(pure [])

instance ToJSON r => ToJSON (APIResult r) where
  toEncoding :: APIResult r -> Encoding
toEncoding = $(JQ.mkToEncoding (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''APIResult)
  toJSON :: APIResult r -> Value
toJSON = $(JQ.mkToJSON (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''APIResult)

foreign export ccall "chat_migrate_init" cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString

foreign export ccall "chat_migrate_init_key" cChatMigrateInitKey :: CString -> CString -> CInt -> CString -> CInt -> Ptr (StablePtr ChatController) -> IO CJSONString

foreign export ccall "chat_close_store" cChatCloseStore :: StablePtr ChatController -> IO CString

foreign export ccall "chat_reopen_store" cChatReopenStore :: StablePtr ChatController -> IO CString

foreign export ccall "chat_send_cmd" cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString

foreign export ccall "chat_send_cmd_retry" cChatSendCmdRetry :: StablePtr ChatController -> CString -> CInt -> IO CJSONString

foreign export ccall "chat_send_remote_cmd" cChatSendRemoteCmd :: StablePtr ChatController -> CInt -> CString -> IO CJSONString

foreign export ccall "chat_send_remote_cmd_retry" cChatSendRemoteCmdRetry :: StablePtr ChatController -> CInt -> CString -> CInt -> IO CJSONString

foreign export ccall "chat_recv_msg" cChatRecvMsg :: StablePtr ChatController -> IO CJSONString

foreign export ccall "chat_recv_msg_wait" cChatRecvMsgWait :: StablePtr ChatController -> CInt -> IO CJSONString

foreign export ccall "chat_parse_markdown" cChatParseMarkdown :: CString -> IO CJSONString

foreign export ccall "chat_parse_server" cChatParseServer :: CString -> IO CJSONString

foreign export ccall "chat_parse_uri" cChatParseUri :: CString -> CInt -> IO CJSONString

foreign export ccall "chat_password_hash" cChatPasswordHash :: CString -> CString -> IO CString

foreign export ccall "chat_valid_name" cChatValidName :: CString -> IO CString

foreign export ccall "chat_json_length" cChatJsonLength :: CString -> IO CInt

foreign export ccall "chat_encrypt_media" cChatEncryptMedia :: StablePtr ChatController -> CString -> Ptr Word8 -> CInt -> IO CString

foreign export ccall "chat_decrypt_media" cChatDecryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString

foreign export ccall "chat_write_file" cChatWriteFile :: StablePtr ChatController -> CString -> Ptr Word8 -> CInt -> IO CJSONString

foreign export ccall "chat_read_file" cChatReadFile :: CString -> CString -> CString -> IO (Ptr Word8)

foreign export ccall "chat_encrypt_file" cChatEncryptFile :: StablePtr ChatController -> CString -> CString -> IO CJSONString

foreign export ccall "chat_decrypt_file" cChatDecryptFile :: CString -> CString -> CString -> CString -> IO CString

-- | check / migrate database and initialize chat controller on success
-- For postgres first param is schema prefix, second param is database connection string.
cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
cChatMigrateInit :: CString
-> CString
-> CString
-> Ptr (StablePtr ChatController)
-> IO CString
cChatMigrateInit CString
fp CString
key CString
conf = CString
-> CString
-> CInt
-> CString
-> CInt
-> Ptr (StablePtr ChatController)
-> IO CString
cChatMigrateInitKey CString
fp CString
key CInt
0 CString
conf CInt
0

-- For postgres first param is schema prefix, second param is database connection string.
cChatMigrateInitKey :: CString -> CString -> CInt -> CString -> CInt -> Ptr (StablePtr ChatController) -> IO CJSONString
cChatMigrateInitKey :: CString
-> CString
-> CInt
-> CString
-> CInt
-> Ptr (StablePtr ChatController)
-> IO CString
cChatMigrateInitKey CString
fp CString
key CInt
keepKey CString
conf CInt
background Ptr (StablePtr ChatController)
ctrl = do
  -- ensure we are set to UTF-8; iOS does not have locale, and will default to
  -- US-ASCII all the time.
  TextEncoding -> IO ()
setLocaleEncoding TextEncoding
utf8
  TextEncoding -> IO ()
setFileSystemEncoding TextEncoding
utf8
  TextEncoding -> IO ()
setForeignEncoding TextEncoding
utf8

  ChatDbOpts
chatDbOpts <- CString -> CString -> IO ChatDbOpts
mobileDbOpts CString
fp CString
key
  String
confirm <- CString -> IO String
peekCAString CString
conf
  DBMigrationResult
r <-
    ChatDbOpts
-> Bool
-> String
-> Bool
-> IO (Either DBMigrationResult ChatController)
chatMigrateInitKey ChatDbOpts
chatDbOpts (CInt
keepKey CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) String
confirm (CInt
background CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) IO (Either DBMigrationResult ChatController)
-> (Either DBMigrationResult ChatController
    -> IO DBMigrationResult)
-> IO DBMigrationResult
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 ChatController
cc -> (ChatController -> IO (StablePtr ChatController)
forall a. a -> IO (StablePtr a)
newStablePtr ChatController
cc IO (StablePtr ChatController)
-> (StablePtr ChatController -> 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
>>= Ptr (StablePtr ChatController) -> StablePtr ChatController -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (StablePtr ChatController)
ctrl) IO () -> DBMigrationResult -> IO DBMigrationResult
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DBMigrationResult
DBMOk
      Left DBMigrationResult
e -> DBMigrationResult -> IO DBMigrationResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DBMigrationResult
e
  JSONByteString -> IO CString
newCStringFromLazyBS (JSONByteString -> IO CString) -> JSONByteString -> IO CString
forall a b. (a -> b) -> a -> b
$ DBMigrationResult -> JSONByteString
forall a. ToJSON a => a -> JSONByteString
J.encode DBMigrationResult
r

cChatCloseStore :: StablePtr ChatController -> IO CString
cChatCloseStore :: StablePtr ChatController -> IO CString
cChatCloseStore StablePtr ChatController
cPtr = StablePtr ChatController -> IO ChatController
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr ChatController
cPtr IO ChatController -> (ChatController -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ChatController -> IO String
chatCloseStore IO String -> (String -> IO CString) -> IO CString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO CString
newCAString

cChatReopenStore :: StablePtr ChatController -> IO CString
cChatReopenStore :: StablePtr ChatController -> IO CString
cChatReopenStore StablePtr ChatController
cPtr = do
  ChatController
c <- StablePtr ChatController -> IO ChatController
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr ChatController
cPtr
  String -> IO CString
newCAString (String -> IO CString) -> IO String -> IO CString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ChatController -> IO String
chatReopenStore ChatController
c

-- | send command to chat
cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString
cChatSendCmd :: StablePtr ChatController -> CString -> IO CString
cChatSendCmd StablePtr ChatController
cPtr CString
cCmd = StablePtr ChatController -> CString -> CInt -> IO CString
cChatSendCmdRetry StablePtr ChatController
cPtr CString
cCmd CInt
0

-- | send command to chat with retry count
cChatSendCmdRetry :: StablePtr ChatController -> CString -> CInt -> IO CJSONString
cChatSendCmdRetry :: StablePtr ChatController -> CString -> CInt -> IO CString
cChatSendCmdRetry StablePtr ChatController
cPtr CString
cCmd CInt
cRetryNum = do
  ChatController
c <- StablePtr ChatController -> IO ChatController
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr ChatController
cPtr
  ByteString
cmd <- CString -> IO ByteString
B.packCString CString
cCmd
  JSONByteString -> IO CString
newCStringFromLazyBS (JSONByteString -> IO CString) -> IO JSONByteString -> IO CString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ChatController
-> Maybe Int64 -> ByteString -> Int -> IO JSONByteString
chatSendRemoteCmdRetry ChatController
c Maybe Int64
forall a. Maybe a
Nothing ByteString
cmd (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
cRetryNum)
{-# INLINE cChatSendCmdRetry #-}

-- | send remote command to chat
cChatSendRemoteCmd :: StablePtr ChatController -> CInt -> CString -> IO CJSONString
cChatSendRemoteCmd :: StablePtr ChatController -> CInt -> CString -> IO CString
cChatSendRemoteCmd StablePtr ChatController
cPtr CInt
cRhId CString
cCmd = StablePtr ChatController -> CInt -> CString -> CInt -> IO CString
cChatSendRemoteCmdRetry StablePtr ChatController
cPtr CInt
cRhId CString
cCmd CInt
0

-- | send remote command to chat with retry count
cChatSendRemoteCmdRetry :: StablePtr ChatController -> CInt -> CString -> CInt -> IO CJSONString
cChatSendRemoteCmdRetry :: StablePtr ChatController -> CInt -> CString -> CInt -> IO CString
cChatSendRemoteCmdRetry StablePtr ChatController
cPtr CInt
cRemoteHostId CString
cCmd CInt
cRetryNum = do
  ChatController
c <- StablePtr ChatController -> IO ChatController
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr ChatController
cPtr
  ByteString
cmd <- CString -> IO ByteString
B.packCString CString
cCmd
  let rhId :: Maybe Int64
rhId = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Int64 -> Maybe Int64) -> Int64 -> Maybe Int64
forall a b. (a -> b) -> a -> b
$ CInt -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
cRemoteHostId
  JSONByteString -> IO CString
newCStringFromLazyBS (JSONByteString -> IO CString) -> IO JSONByteString -> IO CString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ChatController
-> Maybe Int64 -> ByteString -> Int -> IO JSONByteString
chatSendRemoteCmdRetry ChatController
c Maybe Int64
rhId ByteString
cmd (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
cRetryNum)
{-# INLINE cChatSendRemoteCmdRetry #-}

-- | receive message from chat (blocking)
cChatRecvMsg :: StablePtr ChatController -> IO CJSONString
cChatRecvMsg :: StablePtr ChatController -> IO CString
cChatRecvMsg StablePtr ChatController
cc = StablePtr ChatController -> IO ChatController
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr ChatController
cc IO ChatController
-> (ChatController -> IO JSONByteString) -> IO JSONByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ChatController -> IO JSONByteString
chatRecvMsg IO JSONByteString -> (JSONByteString -> IO CString) -> IO CString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JSONByteString -> IO CString
newCStringFromLazyBS

-- |  receive message from chat (blocking up to `t` microseconds (1/10^6 sec), returns empty string if times out)
cChatRecvMsgWait :: StablePtr ChatController -> CInt -> IO CJSONString
cChatRecvMsgWait :: StablePtr ChatController -> CInt -> IO CString
cChatRecvMsgWait StablePtr ChatController
cc CInt
t = StablePtr ChatController -> IO ChatController
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr ChatController
cc IO ChatController
-> (ChatController -> IO JSONByteString) -> IO JSONByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ChatController -> Int -> IO JSONByteString
`chatRecvMsgWait` CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
t) IO JSONByteString -> (JSONByteString -> IO CString) -> IO CString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JSONByteString -> IO CString
newCStringFromLazyBS

-- | parse markdown - returns ParsedMarkdown type JSON
cChatParseMarkdown :: CString -> IO CJSONString
cChatParseMarkdown :: CString -> IO CString
cChatParseMarkdown CString
s = JSONByteString -> IO CString
newCStringFromLazyBS (JSONByteString -> IO CString)
-> (ByteString -> JSONByteString) -> ByteString -> IO CString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> JSONByteString
chatParseMarkdown (ByteString -> IO CString) -> IO ByteString -> IO CString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CString -> IO ByteString
B.packCString CString
s

-- | parse server address - returns ParsedServerAddress JSON
cChatParseServer :: CString -> IO CJSONString
cChatParseServer :: CString -> IO CString
cChatParseServer CString
s = JSONByteString -> IO CString
newCStringFromLazyBS (JSONByteString -> IO CString)
-> (ByteString -> JSONByteString) -> ByteString -> IO CString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> JSONByteString
chatParseServer (ByteString -> IO CString) -> IO ByteString -> IO CString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CString -> IO ByteString
B.packCString CString
s

-- | parse web URI - returns ParsedUri JSON
cChatParseUri :: CString -> CInt -> IO CJSONString
cChatParseUri :: CString -> CInt -> IO CString
cChatParseUri CString
s CInt
safe = JSONByteString -> IO CString
newCStringFromLazyBS (JSONByteString -> IO CString)
-> (ByteString -> JSONByteString) -> ByteString -> IO CString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ByteString -> JSONByteString
chatParseUri (CInt
safe CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (ByteString -> IO CString) -> IO ByteString -> IO CString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CString -> IO ByteString
B.packCString CString
s

cChatPasswordHash :: CString -> CString -> IO CString
cChatPasswordHash :: CString -> CString -> IO CString
cChatPasswordHash CString
cPwd CString
cSalt = do
  ByteString
pwd <- CString -> IO ByteString
B.packCString CString
cPwd
  ByteString
salt <- CString -> IO ByteString
B.packCString CString
cSalt
  ByteString -> IO CString
newCStringFromBS (ByteString -> IO CString) -> ByteString -> IO CString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
chatPasswordHash ByteString
pwd ByteString
salt

-- This function supports utf8 strings
cChatValidName :: CString -> IO CString
cChatValidName :: CString -> IO CString
cChatValidName CString
cName = String -> IO CString
newCString (String -> IO CString) -> ShowS -> String -> IO CString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
mkValidName (String -> IO CString) -> IO String -> IO CString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CString -> IO String
peekCString CString
cName

-- | returns length of JSON encoded string
cChatJsonLength :: CString -> IO CInt
cChatJsonLength :: CString -> IO CInt
cChatJsonLength CString
s = Int64 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> CInt) -> (ByteString -> Int64) -> ByteString -> CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
subtract Int64
2 (Int64 -> Int64) -> (ByteString -> Int64) -> ByteString -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONByteString -> Int64
LB.length (JSONByteString -> Int64)
-> (ByteString -> JSONByteString) -> ByteString -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> JSONByteString
forall a. ToJSON a => a -> JSONByteString
J.encode (Text -> JSONByteString)
-> (ByteString -> Text) -> ByteString -> JSONByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
safeDecodeUtf8 (ByteString -> CInt) -> IO ByteString -> IO CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO ByteString
B.packCString CString
s

mobileChatOpts :: ChatDbOpts -> ChatOpts
mobileChatOpts :: ChatDbOpts -> ChatOpts
mobileChatOpts ChatDbOpts
dbOptions =
  ChatOpts
    { coreOptions :: CoreChatOpts
coreOptions =
        CoreChatOpts
          { ChatDbOpts
dbOptions :: ChatDbOpts
dbOptions :: ChatDbOpts
dbOptions,
            smpServers :: [SMPServerWithAuth]
smpServers = [],
            xftpServers :: [XFTPServerWithAuth]
xftpServers = [],
            simpleNetCfg :: SimpleNetCfg
simpleNetCfg = SimpleNetCfg
defaultSimpleNetCfg,
            logLevel :: ChatLogLevel
logLevel = ChatLogLevel
CLLImportant,
            logConnections :: Bool
logConnections = Bool
False,
            logServerHosts :: Bool
logServerHosts = Bool
True,
            logAgent :: Maybe LogLevel
logAgent = Maybe LogLevel
forall a. Maybe a
Nothing,
            logFile :: Maybe String
logFile = Maybe String
forall a. Maybe a
Nothing,
            tbqSize :: Natural
tbqSize = Natural
4096,
            deviceName :: Maybe Text
deviceName = Maybe Text
forall a. Maybe a
Nothing,
            highlyAvailable :: Bool
highlyAvailable = Bool
False,
            yesToUpMigrations :: Bool
yesToUpMigrations = Bool
False,
            migrationBackupPath :: Maybe String
migrationBackupPath = String -> Maybe String
forall a. a -> Maybe a
Just String
""
          },
      chatCmd :: String
chatCmd = String
"",
      chatCmdDelay :: Int
chatCmdDelay = Int
3,
      chatCmdLog :: ChatCmdLog
chatCmdLog = ChatCmdLog
CCLNone,
      chatServerPort :: Maybe String
chatServerPort = Maybe String
forall a. Maybe a
Nothing,
      optFilesFolder :: Maybe String
optFilesFolder = Maybe String
forall a. Maybe a
Nothing,
      optTempDirectory :: Maybe String
optTempDirectory = Maybe String
forall a. Maybe a
Nothing,
      showReactions :: Bool
showReactions = Bool
False,
      allowInstantFiles :: Bool
allowInstantFiles = Bool
True,
      autoAcceptFileSize :: Integer
autoAcceptFileSize = Integer
0,
      muteNotifications :: Bool
muteNotifications = Bool
True,
      markRead :: Bool
markRead = Bool
False,
      createBot :: Maybe CreateBotOpts
createBot = Maybe CreateBotOpts
forall a. Maybe a
Nothing,
      maintenance :: Bool
maintenance = Bool
True
    }

defaultMobileConfig :: ChatConfig
defaultMobileConfig :: ChatConfig
defaultMobileConfig =
  ChatConfig
defaultChatConfig
    { confirmMigrations = MCYesUp,
      logLevel = CLLError,
      deviceNameForRemote = "Mobile"
    }

getActiveUser_ :: DBStore -> IO (Maybe User)
getActiveUser_ :: DBStore -> IO (Maybe User)
getActiveUser_ DBStore
st = (User -> Bool) -> [User] -> Maybe User
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find User -> Bool
activeUser ([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 -> IO [User]
getUsers

#if !defined(dbPostgres)
-- only used in tests
chatMigrateInit :: String -> ScrubbedBytes -> String -> IO (Either DBMigrationResult ChatController)
chatMigrateInit :: String
-> ScrubbedBytes
-> String
-> IO (Either DBMigrationResult ChatController)
chatMigrateInit String
dbFilePrefix ScrubbedBytes
dbKey String
confirm = do
  let chatDBOpts :: ChatDbOpts
chatDBOpts = ChatDbOpts {String
dbFilePrefix :: String
dbFilePrefix :: String
dbFilePrefix, ScrubbedBytes
dbKey :: ScrubbedBytes
dbKey :: ScrubbedBytes
dbKey, trackQueries :: TrackQueries
trackQueries = Int64 -> TrackQueries
DB.TQSlow Int64
5000, vacuumOnMigration :: Bool
vacuumOnMigration = Bool
True}
  ChatDbOpts
-> Bool
-> String
-> Bool
-> IO (Either DBMigrationResult ChatController)
chatMigrateInitKey ChatDbOpts
chatDBOpts Bool
False String
confirm Bool
False
#endif

chatMigrateInitKey :: ChatDbOpts -> Bool -> String -> Bool -> IO (Either DBMigrationResult ChatController)
chatMigrateInitKey :: ChatDbOpts
-> Bool
-> String
-> Bool
-> IO (Either DBMigrationResult ChatController)
chatMigrateInitKey ChatDbOpts
chatDbOpts Bool
keepKey String
confirm Bool
backgroundMode = ExceptT DBMigrationResult IO ChatController
-> IO (Either DBMigrationResult ChatController)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DBMigrationResult IO ChatController
 -> IO (Either DBMigrationResult ChatController))
-> ExceptT DBMigrationResult IO ChatController
-> IO (Either DBMigrationResult ChatController)
forall a b. (a -> b) -> a -> b
$ do
  MigrationConfirmation
confirmMigrations <- (String -> DBMigrationResult)
-> Either String MigrationConfirmation
-> ExceptT DBMigrationResult IO MigrationConfirmation
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (DBMigrationResult -> String -> DBMigrationResult
forall a b. a -> b -> a
const DBMigrationResult
DBMInvalidConfirmation) (Either String MigrationConfirmation
 -> ExceptT DBMigrationResult IO MigrationConfirmation)
-> Either String MigrationConfirmation
-> ExceptT DBMigrationResult IO MigrationConfirmation
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String MigrationConfirmation
forall a. StrEncoding a => ByteString -> Either String a
strDecode (ByteString -> Either String MigrationConfirmation)
-> ByteString -> Either String MigrationConfirmation
forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack String
confirm
  let migrationConfig :: MigrationConfig
migrationConfig = MigrationConfirmation -> Maybe String -> MigrationConfig
MigrationConfig MigrationConfirmation
confirmMigrations (String -> Maybe String
forall a. a -> Maybe a
Just String
"")
  DBStore
chatStore <- (DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore))
-> DBOpts
-> MigrationConfig
-> ExceptT DBMigrationResult IO DBStore
forall {t}.
(DBOpts -> t -> IO (Either MigrationError DBStore))
-> DBOpts -> t -> ExceptT DBMigrationResult IO DBStore
migrate DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
createChatStore (ChatDbOpts -> String -> Bool -> [SQLiteFuncDef] -> DBOpts
toDBOpts ChatDbOpts
chatDbOpts String
chatSuffix Bool
keepKey [SQLiteFuncDef]
chatDBFunctions) MigrationConfig
migrationConfig
  DBStore
agentStore <- (DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore))
-> DBOpts
-> MigrationConfig
-> ExceptT DBMigrationResult IO DBStore
forall {t}.
(DBOpts -> t -> IO (Either MigrationError DBStore))
-> DBOpts -> t -> ExceptT DBMigrationResult IO DBStore
migrate DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
createAgentStore (ChatDbOpts -> String -> Bool -> [SQLiteFuncDef] -> DBOpts
toDBOpts ChatDbOpts
chatDbOpts String
agentSuffix Bool
keepKey []) MigrationConfig
migrationConfig
  IO ChatController -> ExceptT DBMigrationResult IO ChatController
forall a. IO a -> ExceptT DBMigrationResult IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ChatController -> ExceptT DBMigrationResult IO ChatController)
-> IO ChatController -> ExceptT DBMigrationResult IO ChatController
forall a b. (a -> b) -> a -> b
$ DBStore -> ChatDatabase -> IO ChatController
initialize DBStore
chatStore ChatDatabase {DBStore
chatStore :: DBStore
chatStore :: DBStore
chatStore, DBStore
agentStore :: DBStore
agentStore :: DBStore
agentStore}
  where
    opts :: ChatOpts
opts = ChatDbOpts -> ChatOpts
mobileChatOpts (ChatDbOpts -> ChatOpts) -> ChatDbOpts -> ChatOpts
forall a b. (a -> b) -> a -> b
$ ChatDbOpts -> ChatDbOpts
removeDbKey ChatDbOpts
chatDbOpts
    initialize :: DBStore -> ChatDatabase -> IO ChatController
initialize DBStore
st ChatDatabase
db = do
      Maybe User
user_ <- DBStore -> IO (Maybe User)
getActiveUser_ DBStore
st
      ChatDatabase
-> Maybe User
-> ChatConfig
-> ChatOpts
-> Bool
-> IO ChatController
newChatController ChatDatabase
db Maybe User
user_ ChatConfig
defaultMobileConfig ChatOpts
opts Bool
backgroundMode
    migrate :: (DBOpts -> t -> IO (Either MigrationError DBStore))
-> DBOpts -> t -> ExceptT DBMigrationResult IO DBStore
migrate DBOpts -> t -> IO (Either MigrationError DBStore)
createStore DBOpts
dbOpts t
confirmMigrations =
      IO (Either DBMigrationResult DBStore)
-> ExceptT DBMigrationResult IO DBStore
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either DBMigrationResult DBStore)
 -> ExceptT DBMigrationResult IO DBStore)
-> IO (Either DBMigrationResult DBStore)
-> ExceptT DBMigrationResult IO DBStore
forall a b. (a -> b) -> a -> b
$
        ((MigrationError -> DBMigrationResult)
-> Either MigrationError DBStore
-> Either DBMigrationResult DBStore
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> MigrationError -> DBMigrationResult
DBMErrorMigration String
errDbStr) (Either MigrationError DBStore -> Either DBMigrationResult DBStore)
-> IO (Either MigrationError DBStore)
-> IO (Either DBMigrationResult DBStore)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DBOpts -> t -> IO (Either MigrationError DBStore)
createStore DBOpts
dbOpts t
confirmMigrations)
#if !defined(dbPostgres)
          IO (Either DBMigrationResult DBStore)
-> (SQLError -> IO (Either DBMigrationResult DBStore))
-> IO (Either DBMigrationResult DBStore)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (Either DBMigrationResult DBStore
-> IO (Either DBMigrationResult DBStore)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DBMigrationResult DBStore
 -> IO (Either DBMigrationResult DBStore))
-> (SQLError -> Either DBMigrationResult DBStore)
-> SQLError
-> IO (Either DBMigrationResult DBStore)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQLError -> Either DBMigrationResult DBStore
checkDBError)
#endif
          IO (Either DBMigrationResult DBStore)
-> (SomeException -> IO (Either DBMigrationResult DBStore))
-> IO (Either DBMigrationResult DBStore)
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchAll` (Either DBMigrationResult DBStore
-> IO (Either DBMigrationResult DBStore)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DBMigrationResult DBStore
 -> IO (Either DBMigrationResult DBStore))
-> (SomeException -> Either DBMigrationResult DBStore)
-> SomeException
-> IO (Either DBMigrationResult DBStore)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either DBMigrationResult DBStore
forall e. Show e => e -> Either DBMigrationResult DBStore
dbError)
      where
        errDbStr :: String
errDbStr = DBOpts -> String
errorDbStr DBOpts
dbOpts
#if !defined(dbPostgres)
        checkDBError :: SQLError -> Either DBMigrationResult DBStore
checkDBError SQLError
e = case SQLError -> Error
sqlError SQLError
e of
          Error
DB.ErrorNotADatabase -> DBMigrationResult -> Either DBMigrationResult DBStore
forall a b. a -> Either a b
Left (DBMigrationResult -> Either DBMigrationResult DBStore)
-> DBMigrationResult -> Either DBMigrationResult DBStore
forall a b. (a -> b) -> a -> b
$ String -> DBMigrationResult
DBMErrorNotADatabase String
errDbStr
          Error
_ -> SQLError -> Either DBMigrationResult DBStore
forall e. Show e => e -> Either DBMigrationResult DBStore
dbError SQLError
e
#endif
        dbError :: Show e => e -> Either DBMigrationResult DBStore
        dbError :: forall e. Show e => e -> Either DBMigrationResult DBStore
dbError e
e = DBMigrationResult -> Either DBMigrationResult DBStore
forall a b. a -> Either a b
Left (DBMigrationResult -> Either DBMigrationResult DBStore)
-> (String -> DBMigrationResult)
-> String
-> Either DBMigrationResult DBStore
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> DBMigrationResult
DBMErrorSQL String
errDbStr (String -> Either DBMigrationResult DBStore)
-> String -> Either DBMigrationResult DBStore
forall a b. (a -> b) -> a -> b
$ e -> String
forall a. Show a => a -> String
show e
e

chatCloseStore :: ChatController -> IO String
chatCloseStore :: ChatController -> IO String
chatCloseStore ChatController {DBStore
chatStore :: DBStore
chatStore :: ChatController -> DBStore
chatStore, AgentClient
smpAgent :: AgentClient
smpAgent :: ChatController -> AgentClient
smpAgent} = IO () -> IO String
handleErr (IO () -> IO String) -> IO () -> IO String
forall a b. (a -> b) -> a -> b
$ do
  DBStore -> IO ()
closeDBStore DBStore
chatStore
  DBStore -> IO ()
closeDBStore (DBStore -> IO ()) -> DBStore -> IO ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> DBStore
agentClientStore AgentClient
smpAgent

chatReopenStore :: ChatController -> IO String
chatReopenStore :: ChatController -> IO String
chatReopenStore ChatController {DBStore
chatStore :: ChatController -> DBStore
chatStore :: DBStore
chatStore, AgentClient
smpAgent :: ChatController -> AgentClient
smpAgent :: AgentClient
smpAgent} = IO () -> IO String
handleErr (IO () -> IO String) -> IO () -> IO String
forall a b. (a -> b) -> a -> b
$ do
  DBStore -> IO ()
reopenDBStore DBStore
chatStore
  DBStore -> IO ()
reopenDBStore (AgentClient -> DBStore
agentClientStore AgentClient
smpAgent)

handleErr :: IO () -> IO String
handleErr :: IO () -> IO String
handleErr IO ()
a = (IO ()
a IO () -> String -> IO String
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String
"") IO String -> (SomeException -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String)
-> (SomeException -> String) -> SomeException -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show @SomeException)

chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString
chatSendCmd :: ChatController -> ByteString -> IO JSONByteString
chatSendCmd ChatController
cc ByteString
cmd = ChatController
-> Maybe Int64 -> ByteString -> Int -> IO JSONByteString
chatSendRemoteCmdRetry ChatController
cc Maybe Int64
forall a. Maybe a
Nothing ByteString
cmd Int
0
{-# INLINE chatSendCmd #-}

chatSendRemoteCmdRetry :: ChatController -> Maybe RemoteHostId -> B.ByteString -> Int -> IO JSONByteString
chatSendRemoteCmdRetry :: ChatController
-> Maybe Int64 -> ByteString -> Int -> IO JSONByteString
chatSendRemoteCmdRetry ChatController
cc Maybe Int64
rh ByteString
s Int
retryNum = APIResult ChatResponse -> JSONByteString
forall a. ToJSON a => a -> JSONByteString
J.encode (APIResult ChatResponse -> JSONByteString)
-> (Either ChatError ChatResponse -> APIResult ChatResponse)
-> Either ChatError ChatResponse
-> JSONByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int64
-> Either ChatError ChatResponse -> APIResult ChatResponse
forall r. Maybe Int64 -> Either ChatError r -> APIResult r
eitherToResult Maybe Int64
rh (Either ChatError ChatResponse -> JSONByteString)
-> IO (Either ChatError ChatResponse) -> IO JSONByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT ChatController IO (Either ChatError ChatResponse)
-> ChatController -> IO (Either ChatError ChatResponse)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Maybe Int64
-> ByteString
-> Int
-> ReaderT ChatController IO (Either ChatError ChatResponse)
execChatCommand Maybe Int64
rh ByteString
s Int
retryNum) ChatController
cc

chatRecvMsg :: ChatController -> IO JSONByteString
chatRecvMsg :: ChatController -> IO JSONByteString
chatRecvMsg ChatController {TBQueue (Maybe Int64, Either ChatError ChatEvent)
outputQ :: TBQueue (Maybe Int64, Either ChatError ChatEvent)
outputQ :: ChatController -> TBQueue (Maybe Int64, Either ChatError ChatEvent)
outputQ} = APIResult ChatEvent -> JSONByteString
forall a. ToJSON a => a -> JSONByteString
J.encode (APIResult ChatEvent -> JSONByteString)
-> ((Maybe Int64, Either ChatError ChatEvent)
    -> APIResult ChatEvent)
-> (Maybe Int64, Either ChatError ChatEvent)
-> JSONByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Int64 -> Either ChatError ChatEvent -> APIResult ChatEvent)
-> (Maybe Int64, Either ChatError ChatEvent) -> APIResult ChatEvent
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe Int64 -> Either ChatError ChatEvent -> APIResult ChatEvent
forall r. Maybe Int64 -> Either ChatError r -> APIResult r
eitherToResult ((Maybe Int64, Either ChatError ChatEvent) -> JSONByteString)
-> IO (Maybe Int64, Either ChatError ChatEvent)
-> IO JSONByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe Int64, Either ChatError ChatEvent)
readChatResponse
  where
    readChatResponse :: IO (Maybe Int64, Either ChatError ChatEvent)
readChatResponse =
      STM (Maybe Int64, Either ChatError ChatEvent)
-> IO (Maybe Int64, Either ChatError ChatEvent)
forall a. STM a -> IO a
atomically (TBQueue (Maybe Int64, Either ChatError ChatEvent)
-> STM (Maybe Int64, Either ChatError ChatEvent)
forall a. TBQueue a -> STM a
readTBQueue TBQueue (Maybe Int64, Either ChatError ChatEvent)
outputQ) IO (Maybe Int64, Either ChatError ChatEvent)
-> ((Maybe Int64, Either ChatError ChatEvent)
    -> IO (Maybe Int64, Either ChatError ChatEvent))
-> IO (Maybe Int64, Either ChatError ChatEvent)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Maybe Int64
_, Right CEvtTerminalEvent {}) -> IO (Maybe Int64, Either ChatError ChatEvent)
readChatResponse
        (Maybe Int64, Either ChatError ChatEvent)
out -> (Maybe Int64, Either ChatError ChatEvent)
-> IO (Maybe Int64, Either ChatError ChatEvent)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int64, Either ChatError ChatEvent)
out

chatRecvMsgWait :: ChatController -> Int -> IO JSONByteString
chatRecvMsgWait :: ChatController -> Int -> IO JSONByteString
chatRecvMsgWait ChatController
cc Int
time = JSONByteString -> Maybe JSONByteString -> JSONByteString
forall a. a -> Maybe a -> a
fromMaybe JSONByteString
"" (Maybe JSONByteString -> JSONByteString)
-> IO (Maybe JSONByteString) -> IO JSONByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO JSONByteString -> IO (Maybe JSONByteString)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
time (ChatController -> IO JSONByteString
chatRecvMsg ChatController
cc)

chatParseMarkdown :: ByteString -> JSONByteString
chatParseMarkdown :: ByteString -> JSONByteString
chatParseMarkdown = ParsedMarkdown -> JSONByteString
forall a. ToJSON a => a -> JSONByteString
J.encode (ParsedMarkdown -> JSONByteString)
-> (ByteString -> ParsedMarkdown) -> ByteString -> JSONByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe MarkdownList -> ParsedMarkdown
ParsedMarkdown (Maybe MarkdownList -> ParsedMarkdown)
-> (ByteString -> Maybe MarkdownList)
-> ByteString
-> ParsedMarkdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe MarkdownList
parseMaybeMarkdownList (Text -> Maybe MarkdownList)
-> (ByteString -> Text) -> ByteString -> Maybe MarkdownList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
safeDecodeUtf8
{-# INLINE chatParseMarkdown #-}

chatParseServer :: ByteString -> JSONByteString
chatParseServer :: ByteString -> JSONByteString
chatParseServer = ParsedServerAddress -> JSONByteString
forall a. ToJSON a => a -> JSONByteString
J.encode (ParsedServerAddress -> JSONByteString)
-> (ByteString -> ParsedServerAddress)
-> ByteString
-> JSONByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String AProtoServerWithAuth -> ParsedServerAddress
toServerAddress (Either String AProtoServerWithAuth -> ParsedServerAddress)
-> (ByteString -> Either String AProtoServerWithAuth)
-> ByteString
-> ParsedServerAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String AProtoServerWithAuth
forall a. StrEncoding a => ByteString -> Either String a
strDecode
  where
    toServerAddress :: Either String AProtoServerWithAuth -> ParsedServerAddress
    toServerAddress :: Either String AProtoServerWithAuth -> ParsedServerAddress
toServerAddress = \case
      Right (AProtoServerWithAuth SProtocolType p
protocol (ProtoServerWithAuth ProtocolServer {NonEmpty TransportHost
host :: NonEmpty TransportHost
host :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host, String
port :: String
port :: forall (p :: ProtocolType). ProtocolServer p -> String
port, keyHash :: forall (p :: ProtocolType). ProtocolServer p -> KeyHash
keyHash = C.KeyHash ByteString
kh} Maybe BasicAuth
auth)) ->
        let basicAuth :: String
basicAuth = String -> (BasicAuth -> String) -> Maybe BasicAuth -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\(BasicAuth ByteString
a) -> ByteString -> String
forall a. StrEncoding a => a -> String
enc ByteString
a) Maybe BasicAuth
auth
         in Maybe ServerAddress -> String -> ParsedServerAddress
ParsedServerAddress (ServerAddress -> Maybe ServerAddress
forall a. a -> Maybe a
Just ServerAddress {serverProtocol :: AProtocolType
serverProtocol = SProtocolType p -> AProtocolType
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p -> AProtocolType
AProtocolType SProtocolType p
protocol, hostnames :: NonEmpty String
hostnames = (TransportHost -> String)
-> NonEmpty TransportHost -> NonEmpty String
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map TransportHost -> String
forall a. StrEncoding a => a -> String
enc NonEmpty TransportHost
host, String
port :: String
port :: String
port, keyHash :: String
keyHash = ByteString -> String
forall a. StrEncoding a => a -> String
enc ByteString
kh, String
basicAuth :: String
basicAuth :: String
basicAuth}) String
""
      Left String
e -> Maybe ServerAddress -> String -> ParsedServerAddress
ParsedServerAddress Maybe ServerAddress
forall a. Maybe a
Nothing String
e
    enc :: StrEncoding a => a -> String
    enc :: forall a. StrEncoding a => a -> String
enc = ByteString -> String
B.unpack (ByteString -> String) -> (a -> ByteString) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode

chatParseUri :: Bool -> ByteString -> JSONByteString
chatParseUri :: Bool -> ByteString -> JSONByteString
chatParseUri Bool
safe ByteString
s = ParsedUri -> JSONByteString
forall a. ToJSON a => a -> JSONByteString
J.encode (ParsedUri -> JSONByteString) -> ParsedUri -> JSONByteString
forall a b. (a -> b) -> a -> b
$ case ByteString -> Either Text URI
parseUri ByteString
s of
  Left Text
e -> Maybe UriInfo -> Text -> ParsedUri
ParsedUri Maybe UriInfo
forall a. Maybe a
Nothing Text
e
  Right uri :: URI
uri@U.URI {uriScheme :: URI -> Scheme
uriScheme = U.Scheme ByteString
sch} ->
    let sanitized :: Maybe Text
sanitized = ByteString -> Text
safeDecodeUtf8 (ByteString -> Text) -> (URI -> ByteString) -> URI -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> ByteString
forall a. URIRef a -> ByteString
U.serializeURIRef' (URI -> Text) -> Maybe URI -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> URI -> Maybe URI
sanitizeUri Bool
safe URI
uri
        uriInfo :: UriInfo
uriInfo = UriInfo {scheme :: Text
scheme = ByteString -> Text
safeDecodeUtf8 ByteString
sch, Maybe Text
sanitized :: Maybe Text
sanitized :: Maybe Text
sanitized}
     in Maybe UriInfo -> Text -> ParsedUri
ParsedUri (UriInfo -> Maybe UriInfo
forall a. a -> Maybe a
Just UriInfo
uriInfo) Text
""

chatPasswordHash :: ByteString -> ByteString -> ByteString
chatPasswordHash :: ByteString -> ByteString -> ByteString
chatPasswordHash ByteString
pwd ByteString
salt = (String -> ByteString)
-> (ByteString -> ByteString)
-> Either String ByteString
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> String -> ByteString
forall a b. a -> b -> a
const ByteString
"") ByteString -> ByteString
passwordHash Either String ByteString
salt'
  where
    salt' :: Either String ByteString
salt' = ByteString -> Either String ByteString
U.decode ByteString
salt
    passwordHash :: ByteString -> ByteString
passwordHash = ByteString -> ByteString
U.encode (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
C.sha512Hash (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
pwd ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>)