{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

module Simplex.Chat.Store.Shared where

import Control.Exception (Exception)
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson.TH as J
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
import Data.Maybe (fromMaybe, isJust, listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Data.Type.Equality
import Simplex.Chat.Messages
import Simplex.Chat.Remote.Types
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.UITheme
import Simplex.Messaging.Agent.Protocol (AConnShortLink (..), AConnectionRequestUri (..), ACreatedConnLink (..), ConnId, ConnShortLink, ConnectionRequestUri, CreatedConnLink (..), UserId, connMode)
import Simplex.Messaging.Agent.Store (AnyStoreError (..))
import Simplex.Messaging.Agent.Store.AgentStore (firstRow, maybeFirstRow)
import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
import qualified Simplex.Messaging.Agent.Store.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..))
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
import Simplex.Messaging.Protocol (SubscriptionMode (..))
import Simplex.Messaging.Util (AnyError (..))
import Simplex.Messaging.Version
import UnliftIO.STM
#if defined(dbPostgres)
import Database.PostgreSQL.Simple (Only (..), Query, SqlError, (:.) (..))
import Database.PostgreSQL.Simple.Errors (constraintViolation)
import Database.PostgreSQL.Simple.SqlQQ (sql)
#else
import Database.SQLite.Simple (Only (..), Query, SQLError, (:.) (..))
import qualified Database.SQLite.Simple as SQL
import Database.SQLite.Simple.QQ (sql)
#endif

data ChatLockEntity
  = CLInvitation ByteString
  | CLConnection Int64
  | CLContact ContactId
  | CLGroup GroupId
  | CLUserContact Int64
  | CLContactRequest Int64
  | CLFile Int64
  deriving (ChatLockEntity -> ChatLockEntity -> Bool
(ChatLockEntity -> ChatLockEntity -> Bool)
-> (ChatLockEntity -> ChatLockEntity -> Bool) -> Eq ChatLockEntity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChatLockEntity -> ChatLockEntity -> Bool
== :: ChatLockEntity -> ChatLockEntity -> Bool
$c/= :: ChatLockEntity -> ChatLockEntity -> Bool
/= :: ChatLockEntity -> ChatLockEntity -> Bool
Eq, Eq ChatLockEntity
Eq ChatLockEntity =>
(ChatLockEntity -> ChatLockEntity -> Ordering)
-> (ChatLockEntity -> ChatLockEntity -> Bool)
-> (ChatLockEntity -> ChatLockEntity -> Bool)
-> (ChatLockEntity -> ChatLockEntity -> Bool)
-> (ChatLockEntity -> ChatLockEntity -> Bool)
-> (ChatLockEntity -> ChatLockEntity -> ChatLockEntity)
-> (ChatLockEntity -> ChatLockEntity -> ChatLockEntity)
-> Ord ChatLockEntity
ChatLockEntity -> ChatLockEntity -> Bool
ChatLockEntity -> ChatLockEntity -> Ordering
ChatLockEntity -> ChatLockEntity -> ChatLockEntity
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ChatLockEntity -> ChatLockEntity -> Ordering
compare :: ChatLockEntity -> ChatLockEntity -> Ordering
$c< :: ChatLockEntity -> ChatLockEntity -> Bool
< :: ChatLockEntity -> ChatLockEntity -> Bool
$c<= :: ChatLockEntity -> ChatLockEntity -> Bool
<= :: ChatLockEntity -> ChatLockEntity -> Bool
$c> :: ChatLockEntity -> ChatLockEntity -> Bool
> :: ChatLockEntity -> ChatLockEntity -> Bool
$c>= :: ChatLockEntity -> ChatLockEntity -> Bool
>= :: ChatLockEntity -> ChatLockEntity -> Bool
$cmax :: ChatLockEntity -> ChatLockEntity -> ChatLockEntity
max :: ChatLockEntity -> ChatLockEntity -> ChatLockEntity
$cmin :: ChatLockEntity -> ChatLockEntity -> ChatLockEntity
min :: ChatLockEntity -> ChatLockEntity -> ChatLockEntity
Ord)

-- These error type constructors must be added to mobile apps
data StoreError
  = SEDuplicateName
  | SEUserNotFound {StoreError -> UserId
userId :: UserId}
  | SEUserNotFoundByName {StoreError -> Text
contactName :: ContactName}
  | SEUserNotFoundByContactId {StoreError -> UserId
contactId :: ContactId}
  | SEUserNotFoundByGroupId {StoreError -> UserId
groupId :: GroupId}
  | SEUserNotFoundByFileId {StoreError -> UserId
fileId :: FileTransferId}
  | SEUserNotFoundByContactRequestId {StoreError -> UserId
contactRequestId :: Int64}
  | SEContactNotFound {contactId :: ContactId}
  | SEContactNotFoundByName {contactName :: ContactName}
  | SEContactNotFoundByMemberId {StoreError -> UserId
groupMemberId :: GroupMemberId}
  | SEContactNotReady {contactName :: ContactName}
  | SEDuplicateContactLink
  | SEUserContactLinkNotFound
  | SEContactRequestNotFound {contactRequestId :: Int64}
  | SEContactRequestNotFoundByName {contactName :: ContactName}
  | SEInvalidContactRequestEntity {contactRequestId :: Int64}
  | SEInvalidBusinessChatContactRequest
  | SEGroupNotFound {groupId :: GroupId}
  | SEGroupNotFoundByName {StoreError -> Text
groupName :: GroupName}
  | SEGroupMemberNameNotFound {groupId :: GroupId, StoreError -> Text
groupMemberName :: ContactName}
  | SEGroupMemberNotFound {groupMemberId :: GroupMemberId}
  | SEGroupMemberNotFoundByIndex {StoreError -> UserId
groupMemberIndex :: Int64}
  | SEMemberRelationsVectorNotFound {groupMemberId :: GroupMemberId}
  | SEGroupHostMemberNotFound {groupId :: GroupId}
  | SEGroupMemberNotFoundByMemberId {StoreError -> MemberId
memberId :: MemberId}
  | SEMemberContactGroupMemberNotFound {contactId :: ContactId}
  | SEInvalidMemberRelationUpdate
  | SEGroupWithoutUser
  | SEDuplicateGroupMember
  | SEGroupAlreadyJoined
  | SEGroupInvitationNotFound
  | SENoteFolderAlreadyExists {StoreError -> UserId
noteFolderId :: NoteFolderId}
  | SENoteFolderNotFound {noteFolderId :: NoteFolderId}
  | SEUserNoteFolderNotFound
  | SESndFileNotFound {fileId :: FileTransferId}
  | SESndFileInvalid {fileId :: FileTransferId}
  | SERcvFileNotFound {fileId :: FileTransferId}
  | SERcvFileDescrNotFound {fileId :: FileTransferId}
  | SEFileNotFound {fileId :: FileTransferId}
  | SERcvFileInvalid {fileId :: FileTransferId}
  | SERcvFileInvalidDescrPart
  | SELocalFileNoTransfer {fileId :: FileTransferId}
  | SESharedMsgIdNotFoundByFileId {fileId :: FileTransferId}
  | SEFileIdNotFoundBySharedMsgId {StoreError -> SharedMsgId
sharedMsgId :: SharedMsgId}
  | SESndFileNotFoundXFTP {StoreError -> AgentSndFileId
agentSndFileId :: AgentSndFileId}
  | SERcvFileNotFoundXFTP {StoreError -> AgentRcvFileId
agentRcvFileId :: AgentRcvFileId}
  | SEConnectionNotFound {StoreError -> AgentConnId
agentConnId :: AgentConnId}
  | SEConnectionNotFoundById {StoreError -> UserId
connId :: Int64}
  | SEConnectionNotFoundByMemberId {groupMemberId :: GroupMemberId}
  | SEPendingConnectionNotFound {connId :: Int64}
  | SEUniqueID
  | SELargeMsg
  | SEInternalError {StoreError -> String
message :: String}
  | SEDBException {message :: String}
  | SEDBBusyError {message :: String}
  | SEBadChatItem {StoreError -> UserId
itemId :: ChatItemId, StoreError -> Maybe UTCTime
itemTs :: Maybe ChatItemTs}
  | SEChatItemNotFound {itemId :: ChatItemId}
  | SEChatItemNotFoundByText {StoreError -> Text
text :: Text}
  | SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId}
  | SEChatItemNotFoundByFileId {fileId :: FileTransferId}
  | SEChatItemNotFoundByContactId {contactId :: ContactId}
  | SEChatItemNotFoundByGroupId {groupId :: GroupId}
  | SEProfileNotFound {StoreError -> UserId
profileId :: Int64}
  | SEDuplicateGroupLink {StoreError -> GroupInfo
groupInfo :: GroupInfo}
  | SEGroupLinkNotFound {groupInfo :: GroupInfo}
  | SEHostMemberIdNotFound {groupId :: Int64}
  | SEContactNotFoundByFileId {fileId :: FileTransferId}
  | SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId}
  | SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, StoreError -> Maybe UserId
authorGroupMemberId :: Maybe GroupMemberId, StoreError -> Maybe UserId
forwardedByGroupMemberId :: Maybe GroupMemberId}
  | SERemoteHostNotFound {StoreError -> UserId
remoteHostId :: RemoteHostId}
  | SERemoteHostUnknown -- attempting to store KnownHost without a known fingerprint
  | SERemoteHostDuplicateCA
  | SERemoteCtrlNotFound {StoreError -> UserId
remoteCtrlId :: RemoteCtrlId}
  | SERemoteCtrlDuplicateCA
  | SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId}
  | SEOperatorNotFound {StoreError -> UserId
serverOperatorId :: Int64}
  | SEUsageConditionsNotFound
  | SEInvalidQuote
  | SEInvalidMention
  | SEInvalidDeliveryTask {StoreError -> UserId
taskId :: Int64}
  | SEDeliveryTaskNotFound {taskId :: Int64}
  | SEInvalidDeliveryJob {StoreError -> UserId
jobId :: Int64}
  | SEDeliveryJobNotFound {jobId :: Int64}
  | -- | Error when reading work item that suspends worker - do not use!
    SEWorkItemError {StoreError -> String
errContext :: String}
  deriving (Int -> StoreError -> ShowS
[StoreError] -> ShowS
StoreError -> String
(Int -> StoreError -> ShowS)
-> (StoreError -> String)
-> ([StoreError] -> ShowS)
-> Show StoreError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StoreError -> ShowS
showsPrec :: Int -> StoreError -> ShowS
$cshow :: StoreError -> String
show :: StoreError -> String
$cshowList :: [StoreError] -> ShowS
showList :: [StoreError] -> ShowS
Show, Show StoreError
Typeable StoreError
(Typeable StoreError, Show StoreError) =>
(StoreError -> SomeException)
-> (SomeException -> Maybe StoreError)
-> (StoreError -> String)
-> Exception StoreError
SomeException -> Maybe StoreError
StoreError -> String
StoreError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: StoreError -> SomeException
toException :: StoreError -> SomeException
$cfromException :: SomeException -> Maybe StoreError
fromException :: SomeException -> Maybe StoreError
$cdisplayException :: StoreError -> String
displayException :: StoreError -> String
Exception)

instance AnyError StoreError where
  fromSomeException :: SomeException -> StoreError
fromSomeException = String -> StoreError
SEInternalError (String -> StoreError)
-> (SomeException -> String) -> SomeException -> StoreError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show
  {-# INLINE fromSomeException #-}

instance AnyStoreError StoreError where
  isWorkItemError :: StoreError -> Bool
isWorkItemError = \case
    SEWorkItemError {} -> Bool
True
    StoreError
_ -> Bool
False
  mkWorkItemError :: String -> StoreError
mkWorkItemError String
errContext = SEWorkItemError {String
errContext :: String
errContext :: String
errContext}

$(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError)

insertedRowId :: DB.Connection -> IO Int64
insertedRowId :: Connection -> IO UserId
insertedRowId Connection
db = Only UserId -> UserId
forall a. Only a -> a
fromOnly (Only UserId -> UserId)
-> ([Only UserId] -> Only UserId) -> [Only UserId] -> UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Only UserId] -> Only UserId
forall a. HasCallStack => [a] -> a
head ([Only UserId] -> UserId) -> IO [Only UserId] -> IO UserId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> IO [Only UserId]
forall r. FromRow r => Connection -> Query -> IO [r]
DB.query_ Connection
db Query
q
  where
#if defined(dbPostgres)
    q = "SELECT lastval()"
#else
    q :: Query
q = Query
"SELECT last_insert_rowid()"
#endif

checkConstraint :: StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a
checkConstraint :: forall a.
StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a
checkConstraint StoreError
err ExceptT StoreError IO a
action = IO (Either StoreError a) -> ExceptT StoreError IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError a) -> ExceptT StoreError IO a)
-> IO (Either StoreError a) -> ExceptT StoreError IO a
forall a b. (a -> b) -> a -> b
$ ExceptT StoreError IO a -> IO (Either StoreError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT StoreError IO a
action IO (Either StoreError a)
-> (SQLError -> IO (Either StoreError a))
-> IO (Either StoreError a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (Either StoreError a -> IO (Either StoreError a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StoreError a -> IO (Either StoreError a))
-> (SQLError -> Either StoreError a)
-> SQLError
-> IO (Either StoreError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreError -> Either StoreError a
forall a b. a -> Either a b
Left (StoreError -> Either StoreError a)
-> (SQLError -> StoreError) -> SQLError -> Either StoreError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreError -> SQLError -> StoreError
handleSQLError StoreError
err)

#if defined(dbPostgres)
type SQLError = SqlError
#endif

constraintError :: SQLError -> Bool
#if defined(dbPostgres)
constraintError = isJust . constraintViolation
#else
constraintError :: SQLError -> Bool
constraintError SQLError
e = SQLError -> Error
SQL.sqlError SQLError
e Error -> Error -> Bool
forall a. Eq a => a -> a -> Bool
== Error
SQL.ErrorConstraint
#endif
{-# INLINE constraintError #-}

handleSQLError :: StoreError -> SQLError -> StoreError
handleSQLError :: StoreError -> SQLError -> StoreError
handleSQLError StoreError
err SQLError
e
  | SQLError -> Bool
constraintError SQLError
e = StoreError
err
  | Bool
otherwise = String -> StoreError
SEInternalError (String -> StoreError) -> String -> StoreError
forall a b. (a -> b) -> a -> b
$ SQLError -> String
forall a. Show a => a -> String
show SQLError
e

mkStoreError :: E.SomeException -> StoreError
mkStoreError :: SomeException -> StoreError
mkStoreError = String -> StoreError
SEInternalError (String -> StoreError)
-> (SomeException -> String) -> SomeException -> StoreError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show
{-# INLINE mkStoreError #-}

fileInfoQuery :: Query
fileInfoQuery :: Query
fileInfoQuery =
  [sql|
    SELECT f.file_id, f.ci_file_status, f.file_path
    FROM chat_items i
    JOIN files f ON f.chat_item_id = i.chat_item_id
  |]

toFileInfo :: (Int64, Maybe ACIFileStatus, Maybe FilePath) -> CIFileInfo
toFileInfo :: (UserId, Maybe ACIFileStatus, Maybe String) -> CIFileInfo
toFileInfo (UserId
fileId, Maybe ACIFileStatus
fileStatus, Maybe String
filePath) = CIFileInfo {UserId
fileId :: UserId
fileId :: UserId
fileId, Maybe ACIFileStatus
fileStatus :: Maybe ACIFileStatus
fileStatus :: Maybe ACIFileStatus
fileStatus, Maybe String
filePath :: Maybe String
filePath :: Maybe String
filePath}

type EntityIdsRow = (Maybe Int64, Maybe Int64, Maybe Int64)

type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, BoolInt, Maybe GroupLinkId, Maybe XContactId) :. (Maybe Int64, ConnStatus, ConnType, BoolInt, LocalAlias) :. EntityIdsRow :. (UTCTime, Maybe Text, Maybe UTCTime, PQSupport, PQEncryption, Maybe PQEncryption, Maybe PQEncryption, Int, Int, Maybe VersionChat, VersionChat, VersionChat)

type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe BoolInt, Maybe GroupLinkId, Maybe XContactId) :. (Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe BoolInt, Maybe LocalAlias) :. EntityIdsRow :. (Maybe UTCTime, Maybe Text, Maybe UTCTime, Maybe PQSupport, Maybe PQEncryption, Maybe PQEncryption, Maybe PQEncryption, Maybe Int, Maybe Int, Maybe VersionChat, Maybe VersionChat, Maybe VersionChat)

toConnection :: VersionRangeChat -> ConnectionRow -> Connection
toConnection :: VersionRangeChat -> ConnectionRow -> Connection
toConnection VersionRangeChat
vr ((UserId
connId, ConnId
acId, Int
connLevel, Maybe UserId
viaContact, Maybe UserId
viaUserContactLink, BI Bool
viaGroupLink, Maybe GroupLinkId
groupLinkId, Maybe XContactId
xContactId) :. (Maybe UserId
customUserProfileId, ConnStatus
connStatus, ConnType
connType, BI Bool
contactConnInitiated, Text
localAlias) :. (Maybe UserId
contactId, Maybe UserId
groupMemberId, Maybe UserId
userContactLinkId) :. (UTCTime
createdAt, Maybe Text
code_, Maybe UTCTime
verifiedAt_, PQSupport
pqSupport, PQEncryption
pqEncryption, Maybe PQEncryption
pqSndEnabled, Maybe PQEncryption
pqRcvEnabled, Int
authErrCounter, Int
quotaErrCounter, Maybe (Version ChatVersion)
chatV, Version ChatVersion
minVer, Version ChatVersion
maxVer)) =
  Connection
    { UserId
connId :: UserId
connId :: UserId
connId,
      agentConnId :: AgentConnId
agentConnId = ConnId -> AgentConnId
AgentConnId ConnId
acId,
      connChatVersion :: Version ChatVersion
connChatVersion = Version ChatVersion
-> Maybe (Version ChatVersion) -> Version ChatVersion
forall a. a -> Maybe a -> a
fromMaybe (VersionRangeChat
vr VersionRangeChat -> VersionRangeChat -> Version ChatVersion
`peerConnChatVersion` VersionRangeChat
peerChatVRange) Maybe (Version ChatVersion)
chatV,
      peerChatVRange :: VersionRangeChat
peerChatVRange = VersionRangeChat
peerChatVRange,
      Int
connLevel :: Int
connLevel :: Int
connLevel,
      Maybe UserId
viaContact :: Maybe UserId
viaContact :: Maybe UserId
viaContact,
      Maybe UserId
viaUserContactLink :: Maybe UserId
viaUserContactLink :: Maybe UserId
viaUserContactLink,
      Bool
viaGroupLink :: Bool
viaGroupLink :: Bool
viaGroupLink,
      Maybe GroupLinkId
groupLinkId :: Maybe GroupLinkId
groupLinkId :: Maybe GroupLinkId
groupLinkId,
      Maybe XContactId
xContactId :: Maybe XContactId
xContactId :: Maybe XContactId
xContactId,
      Maybe UserId
customUserProfileId :: Maybe UserId
customUserProfileId :: Maybe UserId
customUserProfileId,
      ConnStatus
connStatus :: ConnStatus
connStatus :: ConnStatus
connStatus,
      ConnType
connType :: ConnType
connType :: ConnType
connType,
      Bool
contactConnInitiated :: Bool
contactConnInitiated :: Bool
contactConnInitiated,
      Text
localAlias :: Text
localAlias :: Text
localAlias,
      entityId :: Maybe UserId
entityId = ConnType -> Maybe UserId
entityId_ ConnType
connType,
      connectionCode :: Maybe SecurityCode
connectionCode = Text -> UTCTime -> SecurityCode
SecurityCode (Text -> UTCTime -> SecurityCode)
-> Maybe Text -> Maybe (UTCTime -> SecurityCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
code_ Maybe (UTCTime -> SecurityCode)
-> Maybe UTCTime -> Maybe SecurityCode
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe UTCTime
verifiedAt_,
      PQSupport
pqSupport :: PQSupport
pqSupport :: PQSupport
pqSupport,
      PQEncryption
pqEncryption :: PQEncryption
pqEncryption :: PQEncryption
pqEncryption,
      Maybe PQEncryption
pqSndEnabled :: Maybe PQEncryption
pqSndEnabled :: Maybe PQEncryption
pqSndEnabled,
      Maybe PQEncryption
pqRcvEnabled :: Maybe PQEncryption
pqRcvEnabled :: Maybe PQEncryption
pqRcvEnabled,
      Int
authErrCounter :: Int
authErrCounter :: Int
authErrCounter,
      Int
quotaErrCounter :: Int
quotaErrCounter :: Int
quotaErrCounter,
      UTCTime
createdAt :: UTCTime
createdAt :: UTCTime
createdAt
    }
  where
    peerChatVRange :: VersionRangeChat
peerChatVRange = VersionRangeChat -> Maybe VersionRangeChat -> VersionRangeChat
forall a. a -> Maybe a -> a
fromMaybe (Version ChatVersion -> VersionRangeChat
forall v. Version v -> VersionRange v
versionToRange Version ChatVersion
maxVer) (Maybe VersionRangeChat -> VersionRangeChat)
-> Maybe VersionRangeChat -> VersionRangeChat
forall a b. (a -> b) -> a -> b
$ Version ChatVersion
-> Version ChatVersion -> Maybe VersionRangeChat
forall v. Version v -> Version v -> Maybe (VersionRange v)
safeVersionRange Version ChatVersion
minVer Version ChatVersion
maxVer
    entityId_ :: ConnType -> Maybe Int64
    entityId_ :: ConnType -> Maybe UserId
entityId_ ConnType
ConnContact = Maybe UserId
contactId
    entityId_ ConnType
ConnMember = Maybe UserId
groupMemberId
    entityId_ ConnType
ConnUserContact = Maybe UserId
userContactLinkId

toMaybeConnection :: VersionRangeChat -> MaybeConnectionRow -> Maybe Connection
toMaybeConnection :: VersionRangeChat -> MaybeConnectionRow -> Maybe Connection
toMaybeConnection VersionRangeChat
vr ((Just UserId
connId, Just ConnId
agentConnId, Just Int
connLevel, Maybe UserId
viaContact, Maybe UserId
viaUserContactLink, Just BoolInt
viaGroupLink, Maybe GroupLinkId
groupLinkId, Maybe XContactId
xContactId) :. (Maybe UserId
customUserProfileId, Just ConnStatus
connStatus, Just ConnType
connType, Just BoolInt
contactConnInitiated, Just Text
localAlias) :. (Maybe UserId
contactId, Maybe UserId
groupMemberId, Maybe UserId
userContactLinkId) :. (Just UTCTime
createdAt, Maybe Text
code_, Maybe UTCTime
verifiedAt_, Just PQSupport
pqSupport, Just PQEncryption
pqEncryption, Maybe PQEncryption
pqSndEnabled_, Maybe PQEncryption
pqRcvEnabled_, Just Int
authErrCounter, Just Int
quotaErrCounter, Maybe (Version ChatVersion)
connChatVersion, Just Version ChatVersion
minVer, Just Version ChatVersion
maxVer)) =
  Connection -> Maybe Connection
forall a. a -> Maybe a
Just (Connection -> Maybe Connection) -> Connection -> Maybe Connection
forall a b. (a -> b) -> a -> b
$ VersionRangeChat -> ConnectionRow -> Connection
toConnection VersionRangeChat
vr ((UserId
connId, ConnId
agentConnId, Int
connLevel, Maybe UserId
viaContact, Maybe UserId
viaUserContactLink, BoolInt
viaGroupLink, Maybe GroupLinkId
groupLinkId, Maybe XContactId
xContactId) (UserId, ConnId, Int, Maybe UserId, Maybe UserId, BoolInt,
 Maybe GroupLinkId, Maybe XContactId)
-> ((Maybe UserId, ConnStatus, ConnType, BoolInt, Text)
    :. (EntityIdsRow
        :. (UTCTime, Maybe Text, Maybe UTCTime, PQSupport, PQEncryption,
            Maybe PQEncryption, Maybe PQEncryption, Int, Int,
            Maybe (Version ChatVersion), Version ChatVersion,
            Version ChatVersion)))
-> ConnectionRow
forall h t. h -> t -> h :. t
:. (Maybe UserId
customUserProfileId, ConnStatus
connStatus, ConnType
connType, BoolInt
contactConnInitiated, Text
localAlias) (Maybe UserId, ConnStatus, ConnType, BoolInt, Text)
-> (EntityIdsRow
    :. (UTCTime, Maybe Text, Maybe UTCTime, PQSupport, PQEncryption,
        Maybe PQEncryption, Maybe PQEncryption, Int, Int,
        Maybe (Version ChatVersion), Version ChatVersion,
        Version ChatVersion))
-> (Maybe UserId, ConnStatus, ConnType, BoolInt, Text)
   :. (EntityIdsRow
       :. (UTCTime, Maybe Text, Maybe UTCTime, PQSupport, PQEncryption,
           Maybe PQEncryption, Maybe PQEncryption, Int, Int,
           Maybe (Version ChatVersion), Version ChatVersion,
           Version ChatVersion))
forall h t. h -> t -> h :. t
:. (Maybe UserId
contactId, Maybe UserId
groupMemberId, Maybe UserId
userContactLinkId) EntityIdsRow
-> (UTCTime, Maybe Text, Maybe UTCTime, PQSupport, PQEncryption,
    Maybe PQEncryption, Maybe PQEncryption, Int, Int,
    Maybe (Version ChatVersion), Version ChatVersion,
    Version ChatVersion)
-> EntityIdsRow
   :. (UTCTime, Maybe Text, Maybe UTCTime, PQSupport, PQEncryption,
       Maybe PQEncryption, Maybe PQEncryption, Int, Int,
       Maybe (Version ChatVersion), Version ChatVersion,
       Version ChatVersion)
forall h t. h -> t -> h :. t
:. (UTCTime
createdAt, Maybe Text
code_, Maybe UTCTime
verifiedAt_, PQSupport
pqSupport, PQEncryption
pqEncryption, Maybe PQEncryption
pqSndEnabled_, Maybe PQEncryption
pqRcvEnabled_, Int
authErrCounter, Int
quotaErrCounter, Maybe (Version ChatVersion)
connChatVersion, Version ChatVersion
minVer, Version ChatVersion
maxVer))
toMaybeConnection VersionRangeChat
_ MaybeConnectionRow
_ = Maybe Connection
forall a. Maybe a
Nothing

createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> ConnStatus -> VersionChat -> VersionRangeChat -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> SubscriptionMode -> PQSupport -> IO Connection
createConnection_ :: Connection
-> UserId
-> ConnType
-> Maybe UserId
-> ConnId
-> ConnStatus
-> Version ChatVersion
-> VersionRangeChat
-> Maybe UserId
-> Maybe UserId
-> Maybe UserId
-> Int
-> UTCTime
-> SubscriptionMode
-> PQSupport
-> IO Connection
createConnection_ Connection
db UserId
userId ConnType
connType Maybe UserId
entityId ConnId
acId ConnStatus
connStatus Version ChatVersion
connChatVersion peerChatVRange :: VersionRangeChat
peerChatVRange@(VersionRange Version ChatVersion
minV Version ChatVersion
maxV) Maybe UserId
viaContact Maybe UserId
viaUserContactLink Maybe UserId
customUserProfileId Int
connLevel UTCTime
currentTs SubscriptionMode
subMode PQSupport
pqSup = do
  Maybe UserId
viaLinkGroupId :: Maybe Int64 <- (Maybe (Maybe UserId) -> Maybe UserId)
-> IO (Maybe (Maybe UserId)) -> IO (Maybe UserId)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe UserId) -> Maybe UserId
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (Maybe (Maybe UserId)) -> IO (Maybe UserId))
-> ((UserId -> IO (Maybe UserId)) -> IO (Maybe (Maybe UserId)))
-> (UserId -> IO (Maybe UserId))
-> IO (Maybe UserId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe UserId
-> (UserId -> IO (Maybe UserId)) -> IO (Maybe (Maybe UserId))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe UserId
viaUserContactLink ((UserId -> IO (Maybe UserId)) -> IO (Maybe UserId))
-> (UserId -> IO (Maybe UserId)) -> IO (Maybe UserId)
forall a b. (a -> b) -> a -> b
$ \UserId
ucLinkId ->
    (Only UserId -> UserId) -> IO [Only UserId] -> IO (Maybe UserId)
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow Only UserId -> UserId
forall a. Only a -> a
fromOnly (IO [Only UserId] -> IO (Maybe UserId))
-> IO [Only UserId] -> IO (Maybe UserId)
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> (UserId, UserId) -> IO [Only UserId]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db Query
"SELECT group_id FROM user_contact_links WHERE user_id = ? AND user_contact_link_id = ? AND group_id IS NOT NULL" (UserId
userId, UserId
ucLinkId)
  let viaGroupLink :: Bool
viaGroupLink = Maybe UserId -> Bool
forall a. Maybe a -> Bool
isJust Maybe UserId
viaLinkGroupId
  Connection
-> Query
-> ((UserId, ConnId, Int, Maybe UserId, Maybe UserId, BoolInt,
     Maybe UserId, ConnStatus, ConnType)
    :. ((Maybe UserId, Maybe UserId, Maybe UserId, UTCTime, UTCTime)
        :. (Version ChatVersion, Version ChatVersion, Version ChatVersion,
            BoolInt, PQSupport, PQSupport)))
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      INSERT INTO connections (
        user_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, custom_user_profile_id, conn_status, conn_type,
        contact_id, group_member_id, user_contact_link_id, created_at, updated_at,
        conn_chat_version, peer_chat_min_version, peer_chat_max_version, to_subscribe, pq_support, pq_encryption
      ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
    |]
    ( (UserId
userId, ConnId
acId, Int
connLevel, Maybe UserId
viaContact, Maybe UserId
viaUserContactLink, Bool -> BoolInt
BI Bool
viaGroupLink, Maybe UserId
customUserProfileId, ConnStatus
connStatus, ConnType
connType)
        (UserId, ConnId, Int, Maybe UserId, Maybe UserId, BoolInt,
 Maybe UserId, ConnStatus, ConnType)
-> ((Maybe UserId, Maybe UserId, Maybe UserId, UTCTime, UTCTime)
    :. (Version ChatVersion, Version ChatVersion, Version ChatVersion,
        BoolInt, PQSupport, PQSupport))
-> (UserId, ConnId, Int, Maybe UserId, Maybe UserId, BoolInt,
    Maybe UserId, ConnStatus, ConnType)
   :. ((Maybe UserId, Maybe UserId, Maybe UserId, UTCTime, UTCTime)
       :. (Version ChatVersion, Version ChatVersion, Version ChatVersion,
           BoolInt, PQSupport, PQSupport))
forall h t. h -> t -> h :. t
:. (ConnType -> Maybe UserId
ent ConnType
ConnContact, ConnType -> Maybe UserId
ent ConnType
ConnMember, ConnType -> Maybe UserId
ent ConnType
ConnUserContact, UTCTime
currentTs, UTCTime
currentTs)
        (Maybe UserId, Maybe UserId, Maybe UserId, UTCTime, UTCTime)
-> (Version ChatVersion, Version ChatVersion, Version ChatVersion,
    BoolInt, PQSupport, PQSupport)
-> (Maybe UserId, Maybe UserId, Maybe UserId, UTCTime, UTCTime)
   :. (Version ChatVersion, Version ChatVersion, Version ChatVersion,
       BoolInt, PQSupport, PQSupport)
forall h t. h -> t -> h :. t
:. (Version ChatVersion
connChatVersion, Version ChatVersion
minV, Version ChatVersion
maxV, Bool -> BoolInt
BI (SubscriptionMode
subMode SubscriptionMode -> SubscriptionMode -> Bool
forall a. Eq a => a -> a -> Bool
== SubscriptionMode
SMOnlyCreate), PQSupport
pqSup, PQSupport
pqSup)
    )
  UserId
connId <- Connection -> IO UserId
insertedRowId Connection
db
  Connection -> IO Connection
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Connection
      { UserId
connId :: UserId
connId :: UserId
connId,
        agentConnId :: AgentConnId
agentConnId = ConnId -> AgentConnId
AgentConnId ConnId
acId,
        Version ChatVersion
connChatVersion :: Version ChatVersion
connChatVersion :: Version ChatVersion
connChatVersion,
        VersionRangeChat
peerChatVRange :: VersionRangeChat
peerChatVRange :: VersionRangeChat
peerChatVRange,
        ConnType
connType :: ConnType
connType :: ConnType
connType,
        contactConnInitiated :: Bool
contactConnInitiated = Bool
False,
        Maybe UserId
entityId :: Maybe UserId
entityId :: Maybe UserId
entityId,
        Maybe UserId
viaContact :: Maybe UserId
viaContact :: Maybe UserId
viaContact,
        Maybe UserId
viaUserContactLink :: Maybe UserId
viaUserContactLink :: Maybe UserId
viaUserContactLink,
        Bool
viaGroupLink :: Bool
viaGroupLink :: Bool
viaGroupLink,
        groupLinkId :: Maybe GroupLinkId
groupLinkId = Maybe GroupLinkId
forall a. Maybe a
Nothing, -- should it be set to viaLinkGroupId
        xContactId :: Maybe XContactId
xContactId = Maybe XContactId
forall a. Maybe a
Nothing,
        Maybe UserId
customUserProfileId :: Maybe UserId
customUserProfileId :: Maybe UserId
customUserProfileId,
        Int
connLevel :: Int
connLevel :: Int
connLevel,
        ConnStatus
connStatus :: ConnStatus
connStatus :: ConnStatus
connStatus,
        localAlias :: Text
localAlias = Text
"",
        createdAt :: UTCTime
createdAt = UTCTime
currentTs,
        connectionCode :: Maybe SecurityCode
connectionCode = Maybe SecurityCode
forall a. Maybe a
Nothing,
        pqSupport :: PQSupport
pqSupport = PQSupport
pqSup,
        pqEncryption :: PQEncryption
pqEncryption = PQSupport -> PQEncryption
CR.pqSupportToEnc PQSupport
pqSup,
        pqSndEnabled :: Maybe PQEncryption
pqSndEnabled = Maybe PQEncryption
forall a. Maybe a
Nothing,
        pqRcvEnabled :: Maybe PQEncryption
pqRcvEnabled = Maybe PQEncryption
forall a. Maybe a
Nothing,
        authErrCounter :: Int
authErrCounter = Int
0,
        quotaErrCounter :: Int
quotaErrCounter = Int
0
      }
  where
    ent :: ConnType -> Maybe UserId
ent ConnType
ct = if ConnType
connType ConnType -> ConnType -> Bool
forall a. Eq a => a -> a -> Bool
== ConnType
ct then Maybe UserId
entityId else Maybe UserId
forall a. Maybe a
Nothing

createIncognitoProfile_ :: DB.Connection -> UserId -> UTCTime -> Profile -> IO Int64
createIncognitoProfile_ :: Connection -> UserId -> UTCTime -> Profile -> IO UserId
createIncognitoProfile_ Connection
db UserId
userId UTCTime
createdAt Profile {Text
displayName :: Text
displayName :: Profile -> Text
displayName, Text
fullName :: Text
fullName :: Profile -> Text
fullName, Maybe Text
shortDescr :: Maybe Text
shortDescr :: Profile -> Maybe Text
shortDescr, Maybe ImageData
image :: Maybe ImageData
image :: Profile -> Maybe ImageData
image} = do
  Connection
-> Query
-> (Text, Text, Maybe Text, Maybe ImageData, UserId, Maybe BoolInt,
    UTCTime, UTCTime)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      INSERT INTO contact_profiles (display_name, full_name, short_descr, image, user_id, incognito, created_at, updated_at)
      VALUES (?,?,?,?,?,?,?,?)
    |]
    (Text
displayName, Text
fullName, Maybe Text
shortDescr, Maybe ImageData
image, UserId
userId, BoolInt -> Maybe BoolInt
forall a. a -> Maybe a
Just (Bool -> BoolInt
BI Bool
True), UTCTime
createdAt, UTCTime
createdAt)
  Connection -> IO UserId
insertedRowId Connection
db

updateConnSupportPQ :: DB.Connection -> Int64 -> PQSupport -> PQEncryption -> IO ()
updateConnSupportPQ :: Connection -> UserId -> PQSupport -> PQEncryption -> IO ()
updateConnSupportPQ Connection
db UserId
connId PQSupport
pqSup PQEncryption
pqEnc =
  Connection -> Query -> (PQSupport, PQEncryption, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE connections
      SET pq_support = ?, pq_encryption = ?
      WHERE connection_id = ?
    |]
    (PQSupport
pqSup, PQEncryption
pqEnc, UserId
connId)

updateConnPQSndEnabled :: DB.Connection -> Int64 -> PQEncryption -> IO ()
updateConnPQSndEnabled :: Connection -> UserId -> PQEncryption -> IO ()
updateConnPQSndEnabled Connection
db UserId
connId PQEncryption
pqSndEnabled =
  Connection -> Query -> (PQEncryption, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE connections
      SET pq_snd_enabled = ?
      WHERE connection_id = ?
    |]
    (PQEncryption
pqSndEnabled, UserId
connId)

updateConnPQRcvEnabled :: DB.Connection -> Int64 -> PQEncryption -> IO ()
updateConnPQRcvEnabled :: Connection -> UserId -> PQEncryption -> IO ()
updateConnPQRcvEnabled Connection
db UserId
connId PQEncryption
pqRcvEnabled =
  Connection -> Query -> (PQEncryption, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE connections
      SET pq_rcv_enabled = ?
      WHERE connection_id = ?
    |]
    (PQEncryption
pqRcvEnabled, UserId
connId)

updateConnPQEnabledCON :: DB.Connection -> Int64 -> PQEncryption -> IO ()
updateConnPQEnabledCON :: Connection -> UserId -> PQEncryption -> IO ()
updateConnPQEnabledCON Connection
db UserId
connId PQEncryption
pqEnabled =
  Connection
-> Query -> (PQEncryption, PQEncryption, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE connections
      SET pq_snd_enabled = ?, pq_rcv_enabled = ?
      WHERE connection_id = ?
    |]
    (PQEncryption
pqEnabled, PQEncryption
pqEnabled, UserId
connId)

setPeerChatVRange :: DB.Connection -> Int64 -> VersionChat -> VersionRangeChat -> IO ()
setPeerChatVRange :: Connection
-> UserId -> Version ChatVersion -> VersionRangeChat -> IO ()
setPeerChatVRange Connection
db UserId
connId Version ChatVersion
chatV (VersionRange Version ChatVersion
minVer Version ChatVersion
maxVer) =
  Connection
-> Query
-> (Version ChatVersion, Version ChatVersion, Version ChatVersion,
    UserId)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE connections
      SET conn_chat_version = ?, peer_chat_min_version = ?, peer_chat_max_version = ?
      WHERE connection_id = ?
    |]
    (Version ChatVersion
chatV, Version ChatVersion
minVer, Version ChatVersion
maxVer, UserId
connId)

setMemberChatVRange :: DB.Connection -> GroupMemberId -> VersionRangeChat -> IO ()
setMemberChatVRange :: Connection -> UserId -> VersionRangeChat -> IO ()
setMemberChatVRange Connection
db UserId
mId (VersionRange Version ChatVersion
minVer Version ChatVersion
maxVer) =
  Connection
-> Query
-> (Version ChatVersion, Version ChatVersion, UserId)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE group_members
      SET peer_chat_min_version = ?, peer_chat_max_version = ?
      WHERE group_member_id = ?
    |]
    (Version ChatVersion
minVer, Version ChatVersion
maxVer, UserId
mId)

setCommandConnId :: DB.Connection -> User -> CommandId -> Int64 -> IO ()
setCommandConnId :: Connection -> User -> UserId -> UserId -> IO ()
setCommandConnId Connection
db User {UserId
userId :: UserId
userId :: User -> UserId
userId} UserId
cmdId UserId
connId = do
  UTCTime
updatedAt <- IO UTCTime
getCurrentTime
  Connection -> Query -> (UserId, UTCTime, UserId, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE commands
      SET connection_id = ?, updated_at = ?
      WHERE user_id = ? AND command_id = ?
    |]
    (UserId
connId, UTCTime
updatedAt, UserId
userId, UserId
cmdId)

createContact :: DB.Connection -> User -> Profile -> ExceptT StoreError IO ()
createContact :: Connection -> User -> Profile -> ExceptT StoreError IO ()
createContact Connection
db User
user Profile
profile = do
  UTCTime
currentTs <- IO UTCTime -> ExceptT StoreError IO UTCTime
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  ExceptT StoreError IO UserId -> ExceptT StoreError IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT StoreError IO UserId -> ExceptT StoreError IO ())
-> ExceptT StoreError IO UserId -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection
-> User
-> Profile
-> Preferences
-> Maybe (ACreatedConnLink, Maybe SharedMsgId)
-> Text
-> UTCTime
-> ExceptT StoreError IO UserId
createContact_ Connection
db User
user Profile
profile Preferences
emptyChatPrefs Maybe (ACreatedConnLink, Maybe SharedMsgId)
forall a. Maybe a
Nothing Text
"" UTCTime
currentTs

createContact_ :: DB.Connection -> User -> Profile -> Preferences -> Maybe (ACreatedConnLink, Maybe SharedMsgId) -> LocalAlias -> UTCTime -> ExceptT StoreError IO ContactId
createContact_ :: Connection
-> User
-> Profile
-> Preferences
-> Maybe (ACreatedConnLink, Maybe SharedMsgId)
-> Text
-> UTCTime
-> ExceptT StoreError IO UserId
createContact_ Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} Profile {Text
displayName :: Profile -> Text
displayName :: Text
displayName, Text
fullName :: Profile -> Text
fullName :: Text
fullName, Maybe Text
shortDescr :: Profile -> Maybe Text
shortDescr :: Maybe Text
shortDescr, Maybe ImageData
image :: Profile -> Maybe ImageData
image :: Maybe ImageData
image, Maybe ConnLinkContact
contactLink :: Maybe ConnLinkContact
contactLink :: Profile -> Maybe ConnLinkContact
contactLink, Maybe ChatPeerType
peerType :: Maybe ChatPeerType
peerType :: Profile -> Maybe ChatPeerType
peerType, Maybe Preferences
preferences :: Maybe Preferences
preferences :: Profile -> Maybe Preferences
preferences} Preferences
ctUserPreferences Maybe (ACreatedConnLink, Maybe SharedMsgId)
prepared Text
localAlias UTCTime
currentTs =
  IO (Either StoreError UserId) -> ExceptT StoreError IO UserId
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError UserId) -> ExceptT StoreError IO UserId)
-> ((Text -> IO (Either StoreError UserId))
    -> IO (Either StoreError UserId))
-> (Text -> IO (Either StoreError UserId))
-> ExceptT StoreError IO UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection
-> UserId
-> Text
-> (Text -> IO (Either StoreError UserId))
-> IO (Either StoreError UserId)
forall a.
Connection
-> UserId
-> Text
-> (Text -> IO (Either StoreError a))
-> IO (Either StoreError a)
withLocalDisplayName Connection
db UserId
userId Text
displayName ((Text -> IO (Either StoreError UserId))
 -> ExceptT StoreError IO UserId)
-> (Text -> IO (Either StoreError UserId))
-> ExceptT StoreError IO UserId
forall a b. (a -> b) -> a -> b
$ \Text
ldn -> do
    Connection
-> Query
-> ((Text, Text, Maybe Text, Maybe ImageData,
     Maybe ConnLinkContact, Maybe ChatPeerType)
    :. (UserId, Text, Maybe Preferences, UTCTime, UTCTime))
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
      Connection
db
      Query
"INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, chat_peer_type, user_id, local_alias, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)"
      ((Text
displayName, Text
fullName, Maybe Text
shortDescr, Maybe ImageData
image, Maybe ConnLinkContact
contactLink, Maybe ChatPeerType
peerType) (Text, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact,
 Maybe ChatPeerType)
-> (UserId, Text, Maybe Preferences, UTCTime, UTCTime)
-> (Text, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact,
    Maybe ChatPeerType)
   :. (UserId, Text, Maybe Preferences, UTCTime, UTCTime)
forall h t. h -> t -> h :. t
:. (UserId
userId, Text
localAlias, Maybe Preferences
preferences, UTCTime
currentTs, UTCTime
currentTs))
    UserId
profileId <- Connection -> IO UserId
insertedRowId Connection
db
    Connection
-> Query
-> ((UserId, Preferences, Text, UserId, UTCTime, UTCTime, UTCTime,
     BoolInt)
    :. NewPreparedContactRow)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
      Connection
db
      Query
"INSERT INTO contacts (contact_profile_id, user_preferences, local_display_name, user_id, created_at, updated_at, chat_ts, contact_used, conn_full_link_to_connect, conn_short_link_to_connect, welcome_shared_msg_id) VALUES (?,?,?,?,?,?,?,?,?,?,?)"
      ((UserId
profileId, Preferences
ctUserPreferences, Text
ldn, UserId
userId, UTCTime
currentTs, UTCTime
currentTs, UTCTime
currentTs, Bool -> BoolInt
BI Bool
True) (UserId, Preferences, Text, UserId, UTCTime, UTCTime, UTCTime,
 BoolInt)
-> NewPreparedContactRow
-> (UserId, Preferences, Text, UserId, UTCTime, UTCTime, UTCTime,
    BoolInt)
   :. NewPreparedContactRow
forall h t. h -> t -> h :. t
:. Maybe (ACreatedConnLink, Maybe SharedMsgId)
-> NewPreparedContactRow
toPreparedContactRow Maybe (ACreatedConnLink, Maybe SharedMsgId)
prepared)
    UserId
contactId <- Connection -> IO UserId
insertedRowId Connection
db
    Either StoreError UserId -> IO (Either StoreError UserId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StoreError UserId -> IO (Either StoreError UserId))
-> Either StoreError UserId -> IO (Either StoreError UserId)
forall a b. (a -> b) -> a -> b
$ UserId -> Either StoreError UserId
forall a b. b -> Either a b
Right UserId
contactId

newContactUserPrefs :: User -> Profile -> Preferences
newContactUserPrefs :: User -> Profile -> Preferences
newContactUserPrefs User {fullPreferences :: User -> FullPreferences
fullPreferences = FullPreferences {timedMessages :: FullPreferences -> TimedMessagesPreference
timedMessages = TimedMessagesPreference
userTM}} Profile {Maybe Preferences
preferences :: Profile -> Maybe Preferences
preferences :: Maybe Preferences
preferences} =
  let ctTM_ :: Maybe TimedMessagesPreference
ctTM_ = SChatFeature 'CFTimedMessages
-> Preferences -> Maybe (FeaturePreference 'CFTimedMessages)
forall (f :: ChatFeature).
SChatFeature f -> Preferences -> Maybe (FeaturePreference f)
chatPrefSel SChatFeature 'CFTimedMessages
SCFTimedMessages (Preferences -> Maybe TimedMessagesPreference)
-> Maybe Preferences -> Maybe TimedMessagesPreference
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Preferences
preferences
      ctUserTM' :: Maybe TimedMessagesPreference
ctUserTM' = TimedMessagesPreference
-> Maybe TimedMessagesPreference -> Maybe TimedMessagesPreference
newContactUserTMPref TimedMessagesPreference
userTM Maybe TimedMessagesPreference
ctTM_
   in Preferences
emptyChatPrefs {timedMessages = ctUserTM'}
  where
    newContactUserTMPref :: TimedMessagesPreference -> Maybe TimedMessagesPreference -> Maybe TimedMessagesPreference
    newContactUserTMPref :: TimedMessagesPreference
-> Maybe TimedMessagesPreference -> Maybe TimedMessagesPreference
newContactUserTMPref TimedMessagesPreference
userTMPref Maybe TimedMessagesPreference
ctTMPref_ =
      case (TimedMessagesPreference
userTMPref, Maybe TimedMessagesPreference
ctTMPref_) of
        (TimedMessagesPreference {allow :: TimedMessagesPreference -> FeatureAllowed
allow = FeatureAllowed
FANo}, Maybe TimedMessagesPreference
_) -> Maybe TimedMessagesPreference
forall a. Maybe a
Nothing
        (TimedMessagesPreference
_, Maybe TimedMessagesPreference
Nothing) -> Maybe TimedMessagesPreference
forall a. Maybe a
Nothing
        (TimedMessagesPreference
_, Just TimedMessagesPreference {allow :: TimedMessagesPreference -> FeatureAllowed
allow = FeatureAllowed
FANo}) -> Maybe TimedMessagesPreference
forall a. Maybe a
Nothing
        (TimedMessagesPreference {allow :: TimedMessagesPreference -> FeatureAllowed
allow = FeatureAllowed
userAllow, ttl :: TimedMessagesPreference -> Maybe Int
ttl = Maybe Int
userTTL_}, Just TimedMessagesPreference {ttl :: TimedMessagesPreference -> Maybe Int
ttl = Maybe Int
ctTTL_}) ->
          case (Maybe Int
userTTL_, Maybe Int
ctTTL_) of
            (Just Int
userTTL, Just Int
ctTTL) -> TimedMessagesPreference -> Maybe TimedMessagesPreference
forall a. a -> Maybe a
Just (TimedMessagesPreference -> Maybe TimedMessagesPreference)
-> TimedMessagesPreference -> Maybe TimedMessagesPreference
forall a b. (a -> b) -> a -> b
$ Int -> TimedMessagesPreference
override (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
userTTL Int
ctTTL)
            (Just Int
userTTL, Maybe Int
Nothing) -> TimedMessagesPreference -> Maybe TimedMessagesPreference
forall a. a -> Maybe a
Just (TimedMessagesPreference -> Maybe TimedMessagesPreference)
-> TimedMessagesPreference -> Maybe TimedMessagesPreference
forall a b. (a -> b) -> a -> b
$ Int -> TimedMessagesPreference
override Int
userTTL
            (Maybe Int
Nothing, Just Int
ctTTL) -> TimedMessagesPreference -> Maybe TimedMessagesPreference
forall a. a -> Maybe a
Just (TimedMessagesPreference -> Maybe TimedMessagesPreference)
-> TimedMessagesPreference -> Maybe TimedMessagesPreference
forall a b. (a -> b) -> a -> b
$ Int -> TimedMessagesPreference
override Int
ctTTL
            (Maybe Int
Nothing, Maybe Int
Nothing) -> Maybe TimedMessagesPreference
forall a. Maybe a
Nothing
          where
            override :: Int -> TimedMessagesPreference
override Int
overrideTTL = TimedMessagesPreference {allow :: FeatureAllowed
allow = FeatureAllowed
userAllow, ttl :: Maybe Int
ttl = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
overrideTTL}

type NewPreparedContactRow = (Maybe AConnectionRequestUri, Maybe AConnShortLink, Maybe SharedMsgId)

toPreparedContactRow :: Maybe (ACreatedConnLink, Maybe SharedMsgId) -> NewPreparedContactRow
toPreparedContactRow :: Maybe (ACreatedConnLink, Maybe SharedMsgId)
-> NewPreparedContactRow
toPreparedContactRow = \case
  Just (ACCL SConnectionMode m
m (CCLink ConnectionRequestUri m
fullLink Maybe (ConnShortLink m)
shortLink), Maybe SharedMsgId
welcomeSharedMsgId) -> (AConnectionRequestUri -> Maybe AConnectionRequestUri
forall a. a -> Maybe a
Just (SConnectionMode m
-> ConnectionRequestUri m -> AConnectionRequestUri
forall (m :: ConnectionMode).
ConnectionModeI m =>
SConnectionMode m
-> ConnectionRequestUri m -> AConnectionRequestUri
ACR SConnectionMode m
m ConnectionRequestUri m
fullLink), SConnectionMode m -> ConnShortLink m -> AConnShortLink
forall (m :: ConnectionMode).
ConnectionModeI m =>
SConnectionMode m -> ConnShortLink m -> AConnShortLink
ACSL SConnectionMode m
m (ConnShortLink m -> AConnShortLink)
-> Maybe (ConnShortLink m) -> Maybe AConnShortLink
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ConnShortLink m)
shortLink, Maybe SharedMsgId
welcomeSharedMsgId)
  Maybe (ACreatedConnLink, Maybe SharedMsgId)
Nothing -> (Maybe AConnectionRequestUri
forall a. Maybe a
Nothing, Maybe AConnShortLink
forall a. Maybe a
Nothing, Maybe SharedMsgId
forall a. Maybe a
Nothing)

type NewPreparedGroupRow m = (Maybe (ConnectionRequestUri m), Maybe (ConnShortLink m), Maybe SharedMsgId)

toPreparedGroupRow :: Maybe (CreatedConnLink m, Maybe SharedMsgId) -> NewPreparedGroupRow m
toPreparedGroupRow :: forall (m :: ConnectionMode).
Maybe (CreatedConnLink m, Maybe SharedMsgId)
-> NewPreparedGroupRow m
toPreparedGroupRow = \case
  Just (CCLink ConnectionRequestUri m
fullLink Maybe (ConnShortLink m)
shortLink, Maybe SharedMsgId
welcomeSharedMsgId) -> (ConnectionRequestUri m -> Maybe (ConnectionRequestUri m)
forall a. a -> Maybe a
Just ConnectionRequestUri m
fullLink, Maybe (ConnShortLink m)
shortLink, Maybe SharedMsgId
welcomeSharedMsgId)
  Maybe (CreatedConnLink m, Maybe SharedMsgId)
Nothing -> (Maybe (ConnectionRequestUri m)
forall a. Maybe a
Nothing, Maybe (ConnShortLink m)
forall a. Maybe a
Nothing, Maybe SharedMsgId
forall a. Maybe a
Nothing)
{-# INLINE toPreparedGroupRow #-}

deleteUnusedIncognitoProfileById_ :: DB.Connection -> User -> ProfileId -> IO ()
deleteUnusedIncognitoProfileById_ :: Connection -> User -> UserId -> IO ()
deleteUnusedIncognitoProfileById_ Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} UserId
profileId =
  Connection
-> Query
-> (UserId, UserId, UserId, UserId, UserId, UserId)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      DELETE FROM contact_profiles
      WHERE user_id = ? AND contact_profile_id = ? AND incognito = 1
        AND 1 NOT IN (
          SELECT 1 FROM connections
          WHERE user_id = ? AND custom_user_profile_id = ? LIMIT 1
        )
        AND 1 NOT IN (
          SELECT 1 FROM group_members
          WHERE user_id = ? AND member_profile_id = ? LIMIT 1
        )
    |]
    (UserId
userId, UserId
profileId, UserId
userId, UserId
profileId, UserId
userId, UserId
profileId)

type PreparedContactRow = (Maybe AConnectionRequestUri, Maybe AConnShortLink, Maybe SharedMsgId, Maybe SharedMsgId)

type GroupDirectInvitationRow = (Maybe ConnReqInvitation, Maybe GroupId, Maybe GroupMemberId, Maybe Int64, BoolInt)

type ContactRow' = (ProfileId, ContactName, ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, BoolInt, ContactStatus) :. (Maybe MsgFilter, Maybe BoolInt, BoolInt, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime) :. PreparedContactRow :. (Maybe Int64, Maybe GroupMemberId, BoolInt) :. GroupDirectInvitationRow :. (Maybe UIThemeEntityOverrides, BoolInt, Maybe CustomData, Maybe Int64)

type ContactRow = Only ContactId :. ContactRow'

toContact :: VersionRangeChat -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact
toContact :: VersionRangeChat
-> User
-> [UserId]
-> (ContactRow :. MaybeConnectionRow)
-> Contact
toContact VersionRangeChat
vr User
user [UserId]
chatTags ((Only UserId
contactId :. (UserId
profileId, Text
localDisplayName, Text
displayName, Text
fullName, Maybe Text
shortDescr, Maybe ImageData
image, Maybe ConnLinkContact
contactLink, Maybe ChatPeerType
peerType, Text
localAlias, BI Bool
contactUsed, ContactStatus
contactStatus) :. (Maybe MsgFilter
enableNtfs_, Maybe BoolInt
sendRcpts, BI Bool
favorite, Maybe Preferences
preferences, Preferences
userPreferences, UTCTime
createdAt, UTCTime
updatedAt, Maybe UTCTime
chatTs) :. PreparedContactRow
preparedContactRow :. (Maybe UserId
contactRequestId, Maybe UserId
contactGroupMemberId, BI Bool
contactGrpInvSent) :. GroupDirectInvitationRow
groupDirectInvRow :. (Maybe UIThemeEntityOverrides
uiThemes, BI Bool
chatDeleted, Maybe CustomData
customData, Maybe UserId
chatItemTTL)) :. MaybeConnectionRow
connRow) =
  let profile :: LocalProfile
profile = LocalProfile {UserId
profileId :: UserId
profileId :: UserId
profileId, Text
displayName :: Text
displayName :: Text
displayName, Text
fullName :: Text
fullName :: Text
fullName, Maybe Text
shortDescr :: Maybe Text
shortDescr :: Maybe Text
shortDescr, Maybe ImageData
image :: Maybe ImageData
image :: Maybe ImageData
image, Maybe ConnLinkContact
contactLink :: Maybe ConnLinkContact
contactLink :: Maybe ConnLinkContact
contactLink, Maybe ChatPeerType
peerType :: Maybe ChatPeerType
peerType :: Maybe ChatPeerType
peerType, Maybe Preferences
preferences :: Maybe Preferences
preferences :: Maybe Preferences
preferences, Text
localAlias :: Text
localAlias :: Text
localAlias}
      activeConn :: Maybe Connection
activeConn = VersionRangeChat -> MaybeConnectionRow -> Maybe Connection
toMaybeConnection VersionRangeChat
vr MaybeConnectionRow
connRow
      chatSettings :: ChatSettings
chatSettings = ChatSettings {enableNtfs :: MsgFilter
enableNtfs = MsgFilter -> Maybe MsgFilter -> MsgFilter
forall a. a -> Maybe a -> a
fromMaybe MsgFilter
MFAll Maybe MsgFilter
enableNtfs_, sendRcpts :: Maybe Bool
sendRcpts = BoolInt -> Bool
unBI (BoolInt -> Bool) -> Maybe BoolInt -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe BoolInt
sendRcpts, Bool
favorite :: Bool
favorite :: Bool
favorite}
      incognito :: Bool
incognito = Bool -> (Connection -> Bool) -> Maybe Connection -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Connection -> Bool
connIncognito Maybe Connection
activeConn
      mergedPreferences :: ContactUserPreferences
mergedPreferences = User
-> Preferences
-> Maybe Preferences
-> Bool
-> ContactUserPreferences
contactUserPreferences User
user Preferences
userPreferences Maybe Preferences
preferences Bool
incognito
      preparedContact :: Maybe PreparedContact
preparedContact = PreparedContactRow -> Maybe PreparedContact
toPreparedContact PreparedContactRow
preparedContactRow
      groupDirectInv :: Maybe GroupDirectInvitation
groupDirectInv = GroupDirectInvitationRow -> Maybe GroupDirectInvitation
toGroupDirectInvitation GroupDirectInvitationRow
groupDirectInvRow
   in Contact {UserId
contactId :: UserId
contactId :: UserId
contactId, Text
localDisplayName :: Text
localDisplayName :: Text
localDisplayName, LocalProfile
profile :: LocalProfile
profile :: LocalProfile
profile, Maybe Connection
activeConn :: Maybe Connection
activeConn :: Maybe Connection
activeConn, Bool
contactUsed :: Bool
contactUsed :: Bool
contactUsed, ContactStatus
contactStatus :: ContactStatus
contactStatus :: ContactStatus
contactStatus, ChatSettings
chatSettings :: ChatSettings
chatSettings :: ChatSettings
chatSettings, Preferences
userPreferences :: Preferences
userPreferences :: Preferences
userPreferences, ContactUserPreferences
mergedPreferences :: ContactUserPreferences
mergedPreferences :: ContactUserPreferences
mergedPreferences, UTCTime
createdAt :: UTCTime
createdAt :: UTCTime
createdAt, UTCTime
updatedAt :: UTCTime
updatedAt :: UTCTime
updatedAt, Maybe UTCTime
chatTs :: Maybe UTCTime
chatTs :: Maybe UTCTime
chatTs, Maybe PreparedContact
preparedContact :: Maybe PreparedContact
preparedContact :: Maybe PreparedContact
preparedContact, Maybe UserId
contactRequestId :: Maybe UserId
contactRequestId :: Maybe UserId
contactRequestId, Maybe UserId
contactGroupMemberId :: Maybe UserId
contactGroupMemberId :: Maybe UserId
contactGroupMemberId, Bool
contactGrpInvSent :: Bool
contactGrpInvSent :: Bool
contactGrpInvSent, Maybe GroupDirectInvitation
groupDirectInv :: Maybe GroupDirectInvitation
groupDirectInv :: Maybe GroupDirectInvitation
groupDirectInv, [UserId]
chatTags :: [UserId]
chatTags :: [UserId]
chatTags, Maybe UserId
chatItemTTL :: Maybe UserId
chatItemTTL :: Maybe UserId
chatItemTTL, Maybe UIThemeEntityOverrides
uiThemes :: Maybe UIThemeEntityOverrides
uiThemes :: Maybe UIThemeEntityOverrides
uiThemes, Bool
chatDeleted :: Bool
chatDeleted :: Bool
chatDeleted, Maybe CustomData
customData :: Maybe CustomData
customData :: Maybe CustomData
customData}

toPreparedContact :: PreparedContactRow -> Maybe PreparedContact
toPreparedContact :: PreparedContactRow -> Maybe PreparedContact
toPreparedContact (Maybe AConnectionRequestUri
connFullLink, Maybe AConnShortLink
connShortLink, Maybe SharedMsgId
welcomeSharedMsgId, Maybe SharedMsgId
requestSharedMsgId) =
  (\cl :: ACreatedConnLink
cl@(ACCL SConnectionMode m
m CreatedConnLink m
_) -> PreparedContact {connLinkToConnect :: ACreatedConnLink
connLinkToConnect = ACreatedConnLink
cl, uiConnLinkType :: ConnectionMode
uiConnLinkType = SConnectionMode m -> ConnectionMode
forall (m :: ConnectionMode). SConnectionMode m -> ConnectionMode
connMode SConnectionMode m
m, Maybe SharedMsgId
welcomeSharedMsgId :: Maybe SharedMsgId
welcomeSharedMsgId :: Maybe SharedMsgId
welcomeSharedMsgId, Maybe SharedMsgId
requestSharedMsgId :: Maybe SharedMsgId
requestSharedMsgId :: Maybe SharedMsgId
requestSharedMsgId})
    (ACreatedConnLink -> PreparedContact)
-> Maybe ACreatedConnLink -> Maybe PreparedContact
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AConnectionRequestUri
-> Maybe AConnShortLink -> Maybe ACreatedConnLink
toACreatedConnLink_ Maybe AConnectionRequestUri
connFullLink Maybe AConnShortLink
connShortLink

toACreatedConnLink_ :: Maybe AConnectionRequestUri -> Maybe AConnShortLink -> Maybe ACreatedConnLink
toACreatedConnLink_ :: Maybe AConnectionRequestUri
-> Maybe AConnShortLink -> Maybe ACreatedConnLink
toACreatedConnLink_ Maybe AConnectionRequestUri
Nothing Maybe AConnShortLink
_ = Maybe ACreatedConnLink
forall a. Maybe a
Nothing
toACreatedConnLink_ (Just (ACR SConnectionMode m
m ConnectionRequestUri m
cr)) Maybe AConnShortLink
csl = case Maybe AConnShortLink
csl of
  Maybe AConnShortLink
Nothing -> ACreatedConnLink -> Maybe ACreatedConnLink
forall a. a -> Maybe a
Just (ACreatedConnLink -> Maybe ACreatedConnLink)
-> ACreatedConnLink -> Maybe ACreatedConnLink
forall a b. (a -> b) -> a -> b
$ SConnectionMode m -> CreatedConnLink m -> ACreatedConnLink
forall (m :: ConnectionMode).
ConnectionModeI m =>
SConnectionMode m -> CreatedConnLink m -> ACreatedConnLink
ACCL SConnectionMode m
m (CreatedConnLink m -> ACreatedConnLink)
-> CreatedConnLink m -> ACreatedConnLink
forall a b. (a -> b) -> a -> b
$ ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
forall (m :: ConnectionMode).
ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
CCLink ConnectionRequestUri m
cr Maybe (ConnShortLink m)
forall a. Maybe a
Nothing
  Just (ACSL SConnectionMode m
m' ConnShortLink m
l) -> (\m :~: m
Refl -> SConnectionMode m -> CreatedConnLink m -> ACreatedConnLink
forall (m :: ConnectionMode).
ConnectionModeI m =>
SConnectionMode m -> CreatedConnLink m -> ACreatedConnLink
ACCL SConnectionMode m
m (CreatedConnLink m -> ACreatedConnLink)
-> CreatedConnLink m -> ACreatedConnLink
forall a b. (a -> b) -> a -> b
$ ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
forall (m :: ConnectionMode).
ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
CCLink ConnectionRequestUri m
cr (ConnShortLink m -> Maybe (ConnShortLink m)
forall a. a -> Maybe a
Just ConnShortLink m
ConnShortLink m
l)) ((m :~: m) -> ACreatedConnLink)
-> Maybe (m :~: m) -> Maybe ACreatedConnLink
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SConnectionMode m -> SConnectionMode m -> Maybe (m :~: m)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: ConnectionMode) (b :: ConnectionMode).
SConnectionMode a -> SConnectionMode b -> Maybe (a :~: b)
testEquality SConnectionMode m
m SConnectionMode m
m'

toGroupDirectInvitation :: GroupDirectInvitationRow -> Maybe GroupDirectInvitation
toGroupDirectInvitation :: GroupDirectInvitationRow -> Maybe GroupDirectInvitation
toGroupDirectInvitation (Maybe ConnReqInvitation
Nothing, Maybe UserId
_, Maybe UserId
_, Maybe UserId
_, BoolInt
_) = Maybe GroupDirectInvitation
forall a. Maybe a
Nothing
toGroupDirectInvitation (Just ConnReqInvitation
groupDirectInvLink, Maybe UserId
fromGroupId_, Maybe UserId
fromGroupMemberId_, Maybe UserId
fromGroupMemberConnId_, BI Bool
groupDirectInvStartedConnection) =
  GroupDirectInvitation -> Maybe GroupDirectInvitation
forall a. a -> Maybe a
Just (GroupDirectInvitation -> Maybe GroupDirectInvitation)
-> GroupDirectInvitation -> Maybe GroupDirectInvitation
forall a b. (a -> b) -> a -> b
$ GroupDirectInvitation {ConnReqInvitation
groupDirectInvLink :: ConnReqInvitation
groupDirectInvLink :: ConnReqInvitation
groupDirectInvLink, Maybe UserId
fromGroupId_ :: Maybe UserId
fromGroupId_ :: Maybe UserId
fromGroupId_, Maybe UserId
fromGroupMemberId_ :: Maybe UserId
fromGroupMemberId_ :: Maybe UserId
fromGroupMemberId_, Maybe UserId
fromGroupMemberConnId_ :: Maybe UserId
fromGroupMemberConnId_ :: Maybe UserId
fromGroupMemberConnId_, Bool
groupDirectInvStartedConnection :: Bool
groupDirectInvStartedConnection :: Bool
groupDirectInvStartedConnection}

getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile
getProfileById :: Connection
-> UserId -> UserId -> ExceptT StoreError IO LocalProfile
getProfileById Connection
db UserId
userId UserId
profileId =
  IO (Either StoreError LocalProfile)
-> ExceptT StoreError IO LocalProfile
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError LocalProfile)
 -> ExceptT StoreError IO LocalProfile)
-> (IO [ProfileRow] -> IO (Either StoreError LocalProfile))
-> IO [ProfileRow]
-> ExceptT StoreError IO LocalProfile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProfileRow -> LocalProfile)
-> StoreError
-> IO [ProfileRow]
-> IO (Either StoreError LocalProfile)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow ProfileRow -> LocalProfile
rowToLocalProfile (UserId -> StoreError
SEProfileNotFound UserId
profileId) (IO [ProfileRow] -> ExceptT StoreError IO LocalProfile)
-> IO [ProfileRow] -> ExceptT StoreError IO LocalProfile
forall a b. (a -> b) -> a -> b
$
    Connection -> Query -> (UserId, UserId) -> IO [ProfileRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
      Connection
db
      [sql|
        SELECT cp.contact_profile_id, cp.display_name, cp.full_name, cp.short_descr, cp.image, cp.contact_link, cp.chat_peer_type, cp.local_alias, cp.preferences -- , ct.user_preferences
        FROM contact_profiles cp
        WHERE cp.user_id = ? AND cp.contact_profile_id = ?
      |]
      (UserId
userId, UserId
profileId)

type ContactRequestRow = (Int64, ContactName, AgentInvId, Maybe ContactId, Maybe GroupId, Maybe Int64) :. (Int64, ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType) :. (Maybe XContactId, PQSupport, Maybe SharedMsgId, Maybe SharedMsgId, Maybe Preferences, UTCTime, UTCTime, VersionChat, VersionChat)

toContactRequest :: ContactRequestRow -> UserContactRequest
toContactRequest :: ContactRequestRow -> UserContactRequest
toContactRequest ((UserId
contactRequestId, Text
localDisplayName, AgentInvId
agentInvitationId, Maybe UserId
contactId_, Maybe UserId
businessGroupId_, Maybe UserId
userContactLinkId_) :. (UserId
profileId, Text
displayName, Text
fullName, Maybe Text
shortDescr, Maybe ImageData
image, Maybe ConnLinkContact
contactLink, Maybe ChatPeerType
peerType) :. (Maybe XContactId
xContactId, PQSupport
pqSupport, Maybe SharedMsgId
welcomeSharedMsgId, Maybe SharedMsgId
requestSharedMsgId, Maybe Preferences
preferences, UTCTime
createdAt, UTCTime
updatedAt, Version ChatVersion
minVer, Version ChatVersion
maxVer)) = do
  let profile :: Profile
profile = Profile {Text
displayName :: Text
displayName :: Text
displayName, Text
fullName :: Text
fullName :: Text
fullName, Maybe Text
shortDescr :: Maybe Text
shortDescr :: Maybe Text
shortDescr, Maybe ImageData
image :: Maybe ImageData
image :: Maybe ImageData
image, Maybe ConnLinkContact
contactLink :: Maybe ConnLinkContact
contactLink :: Maybe ConnLinkContact
contactLink, Maybe ChatPeerType
peerType :: Maybe ChatPeerType
peerType :: Maybe ChatPeerType
peerType, Maybe Preferences
preferences :: Maybe Preferences
preferences :: Maybe Preferences
preferences}
      cReqChatVRange :: VersionRangeChat
cReqChatVRange = VersionRangeChat -> Maybe VersionRangeChat -> VersionRangeChat
forall a. a -> Maybe a -> a
fromMaybe (Version ChatVersion -> VersionRangeChat
forall v. Version v -> VersionRange v
versionToRange Version ChatVersion
maxVer) (Maybe VersionRangeChat -> VersionRangeChat)
-> Maybe VersionRangeChat -> VersionRangeChat
forall a b. (a -> b) -> a -> b
$ Version ChatVersion
-> Version ChatVersion -> Maybe VersionRangeChat
forall v. Version v -> Version v -> Maybe (VersionRange v)
safeVersionRange Version ChatVersion
minVer Version ChatVersion
maxVer
   in UserContactRequest {UserId
contactRequestId :: UserId
contactRequestId :: UserId
contactRequestId, AgentInvId
agentInvitationId :: AgentInvId
agentInvitationId :: AgentInvId
agentInvitationId, Maybe UserId
contactId_ :: Maybe UserId
contactId_ :: Maybe UserId
contactId_, Maybe UserId
businessGroupId_ :: Maybe UserId
businessGroupId_ :: Maybe UserId
businessGroupId_, Maybe UserId
userContactLinkId_ :: Maybe UserId
userContactLinkId_ :: Maybe UserId
userContactLinkId_, VersionRangeChat
cReqChatVRange :: VersionRangeChat
cReqChatVRange :: VersionRangeChat
cReqChatVRange, Text
localDisplayName :: Text
localDisplayName :: Text
localDisplayName, UserId
profileId :: UserId
profileId :: UserId
profileId, Profile
profile :: Profile
profile :: Profile
profile, Maybe XContactId
xContactId :: Maybe XContactId
xContactId :: Maybe XContactId
xContactId, PQSupport
pqSupport :: PQSupport
pqSupport :: PQSupport
pqSupport, Maybe SharedMsgId
welcomeSharedMsgId :: Maybe SharedMsgId
welcomeSharedMsgId :: Maybe SharedMsgId
welcomeSharedMsgId, Maybe SharedMsgId
requestSharedMsgId :: Maybe SharedMsgId
requestSharedMsgId :: Maybe SharedMsgId
requestSharedMsgId, UTCTime
createdAt :: UTCTime
createdAt :: UTCTime
createdAt, UTCTime
updatedAt :: UTCTime
updatedAt :: UTCTime
updatedAt}

userQuery :: Query
userQuery :: Query
userQuery =
  [sql|
    SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences,
      u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes
    FROM users u
    JOIN contacts uct ON uct.contact_id = u.contact_id
    JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id
  |]

toUser :: (UserId, UserId, ContactId, ProfileId, BoolInt, Int64) :. (ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences) :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString, Maybe B64UrlByteString, Maybe UTCTime, Maybe UIThemeEntityOverrides) -> User
toUser :: ((UserId, UserId, UserId, UserId, BoolInt, UserId)
 :. ((Text, Text, Maybe Text, Maybe ImageData,
      Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
     :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
         Maybe B64UrlByteString, Maybe UTCTime,
         Maybe UIThemeEntityOverrides)))
-> User
toUser ((UserId
userId, UserId
auId, UserId
userContactId, UserId
profileId, BI Bool
activeUser, UserId
activeOrder) :. (Text
displayName, Text
fullName, Maybe Text
shortDescr, Maybe ImageData
image, Maybe ConnLinkContact
contactLink, Maybe ChatPeerType
peerType, Maybe Preferences
userPreferences) :. (BI Bool
showNtfs, BI Bool
sendRcptsContacts, BI Bool
sendRcptsSmallGroups, BI Bool
autoAcceptMemberContacts, Maybe B64UrlByteString
viewPwdHash_, Maybe B64UrlByteString
viewPwdSalt_, Maybe UTCTime
userMemberProfileUpdatedAt, Maybe UIThemeEntityOverrides
uiThemes)) =
  User {UserId
userId :: UserId
userId :: UserId
userId, agentUserId :: AgentUserId
agentUserId = UserId -> AgentUserId
AgentUserId UserId
auId, UserId
userContactId :: UserId
userContactId :: UserId
userContactId, localDisplayName :: Text
localDisplayName = Text
displayName, LocalProfile
profile :: LocalProfile
profile :: LocalProfile
profile, Bool
activeUser :: Bool
activeUser :: Bool
activeUser, UserId
activeOrder :: UserId
activeOrder :: UserId
activeOrder, FullPreferences
fullPreferences :: FullPreferences
fullPreferences :: FullPreferences
fullPreferences, Bool
showNtfs :: Bool
showNtfs :: Bool
showNtfs, Bool
sendRcptsContacts :: Bool
sendRcptsContacts :: Bool
sendRcptsContacts, Bool
sendRcptsSmallGroups :: Bool
sendRcptsSmallGroups :: Bool
sendRcptsSmallGroups, autoAcceptMemberContacts :: BoolDef
autoAcceptMemberContacts = Bool -> BoolDef
BoolDef Bool
autoAcceptMemberContacts, Maybe UserPwdHash
viewPwdHash :: Maybe UserPwdHash
viewPwdHash :: Maybe UserPwdHash
viewPwdHash, Maybe UTCTime
userMemberProfileUpdatedAt :: Maybe UTCTime
userMemberProfileUpdatedAt :: Maybe UTCTime
userMemberProfileUpdatedAt, Maybe UIThemeEntityOverrides
uiThemes :: Maybe UIThemeEntityOverrides
uiThemes :: Maybe UIThemeEntityOverrides
uiThemes}
  where
    profile :: LocalProfile
profile = LocalProfile {UserId
profileId :: UserId
profileId :: UserId
profileId, Text
displayName :: Text
displayName :: Text
displayName, Text
fullName :: Text
fullName :: Text
fullName, Maybe Text
shortDescr :: Maybe Text
shortDescr :: Maybe Text
shortDescr, Maybe ImageData
image :: Maybe ImageData
image :: Maybe ImageData
image, Maybe ConnLinkContact
contactLink :: Maybe ConnLinkContact
contactLink :: Maybe ConnLinkContact
contactLink, Maybe ChatPeerType
peerType :: Maybe ChatPeerType
peerType :: Maybe ChatPeerType
peerType, preferences :: Maybe Preferences
preferences = Maybe Preferences
userPreferences, localAlias :: Text
localAlias = Text
""}
    fullPreferences :: FullPreferences
fullPreferences = Maybe Preferences -> FullPreferences
fullPreferences' Maybe Preferences
userPreferences
    viewPwdHash :: Maybe UserPwdHash
viewPwdHash = B64UrlByteString -> B64UrlByteString -> UserPwdHash
UserPwdHash (B64UrlByteString -> B64UrlByteString -> UserPwdHash)
-> Maybe B64UrlByteString
-> Maybe (B64UrlByteString -> UserPwdHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe B64UrlByteString
viewPwdHash_ Maybe (B64UrlByteString -> UserPwdHash)
-> Maybe B64UrlByteString -> Maybe UserPwdHash
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe B64UrlByteString
viewPwdSalt_

toPendingContactConnection :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, Maybe GroupLinkId, Maybe Int64, Maybe ConnReqInvitation, Maybe ShortLinkInvitation, LocalAlias, UTCTime, UTCTime) -> PendingContactConnection
toPendingContactConnection :: (UserId, ConnId, ConnStatus, Maybe ConnId, Maybe UserId,
 Maybe GroupLinkId, Maybe UserId, Maybe ConnReqInvitation,
 Maybe ShortLinkInvitation, Text, UTCTime, UTCTime)
-> PendingContactConnection
toPendingContactConnection (UserId
pccConnId, ConnId
acId, ConnStatus
pccConnStatus, Maybe ConnId
connReqHash, Maybe UserId
viaUserContactLink, Maybe GroupLinkId
groupLinkId, Maybe UserId
customUserProfileId, Maybe ConnReqInvitation
connReqInv, Maybe ShortLinkInvitation
shortLinkInv, Text
localAlias, UTCTime
createdAt, UTCTime
updatedAt) =
  let connLinkInv :: Maybe CreatedLinkInvitation
connLinkInv = (ConnReqInvitation
-> Maybe ShortLinkInvitation -> CreatedLinkInvitation
forall (m :: ConnectionMode).
ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
`CCLink` Maybe ShortLinkInvitation
shortLinkInv) (ConnReqInvitation -> CreatedLinkInvitation)
-> Maybe ConnReqInvitation -> Maybe CreatedLinkInvitation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ConnReqInvitation
connReqInv
   in PendingContactConnection {UserId
pccConnId :: UserId
pccConnId :: UserId
pccConnId, pccAgentConnId :: AgentConnId
pccAgentConnId = ConnId -> AgentConnId
AgentConnId ConnId
acId, ConnStatus
pccConnStatus :: ConnStatus
pccConnStatus :: ConnStatus
pccConnStatus, viaContactUri :: Bool
viaContactUri = Maybe ConnId -> Bool
forall a. Maybe a -> Bool
isJust Maybe ConnId
connReqHash, Maybe UserId
viaUserContactLink :: Maybe UserId
viaUserContactLink :: Maybe UserId
viaUserContactLink, Maybe GroupLinkId
groupLinkId :: Maybe GroupLinkId
groupLinkId :: Maybe GroupLinkId
groupLinkId, Maybe UserId
customUserProfileId :: Maybe UserId
customUserProfileId :: Maybe UserId
customUserProfileId, Maybe CreatedLinkInvitation
connLinkInv :: Maybe CreatedLinkInvitation
connLinkInv :: Maybe CreatedLinkInvitation
connLinkInv, Text
localAlias :: Text
localAlias :: Text
localAlias, UTCTime
createdAt :: UTCTime
createdAt :: UTCTime
createdAt, UTCTime
updatedAt :: UTCTime
updatedAt :: UTCTime
updatedAt}

getConnReqInv :: DB.Connection -> Int64 -> ExceptT StoreError IO ConnReqInvitation
getConnReqInv :: Connection -> UserId -> ExceptT StoreError IO ConnReqInvitation
getConnReqInv Connection
db UserId
connId =
  IO (Either StoreError ConnReqInvitation)
-> ExceptT StoreError IO ConnReqInvitation
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError ConnReqInvitation)
 -> ExceptT StoreError IO ConnReqInvitation)
-> (IO [Only ConnReqInvitation]
    -> IO (Either StoreError ConnReqInvitation))
-> IO [Only ConnReqInvitation]
-> ExceptT StoreError IO ConnReqInvitation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Only ConnReqInvitation -> ConnReqInvitation)
-> StoreError
-> IO [Only ConnReqInvitation]
-> IO (Either StoreError ConnReqInvitation)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow Only ConnReqInvitation -> ConnReqInvitation
forall a. Only a -> a
fromOnly (UserId -> StoreError
SEConnectionNotFoundById UserId
connId) (IO [Only ConnReqInvitation]
 -> ExceptT StoreError IO ConnReqInvitation)
-> IO [Only ConnReqInvitation]
-> ExceptT StoreError IO ConnReqInvitation
forall a b. (a -> b) -> a -> b
$
    Connection -> Query -> Only UserId -> IO [Only ConnReqInvitation]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
      Connection
db
      Query
"SELECT conn_req_inv FROM connections WHERE connection_id = ?"
      (UserId -> Only UserId
forall a. a -> Only a
Only UserId
connId)

-- | Saves unique local display name based on passed displayName, suffixed with _N if required.
-- This function should be called inside transaction.
withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO (Either StoreError a)) -> IO (Either StoreError a)
withLocalDisplayName :: forall a.
Connection
-> UserId
-> Text
-> (Text -> IO (Either StoreError a))
-> IO (Either StoreError a)
withLocalDisplayName Connection
db UserId
userId Text
displayName Text -> IO (Either StoreError a)
action = IO Int
getLdnSuffix IO Int
-> (Int -> IO (Either StoreError a)) -> IO (Either StoreError a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int -> Int -> IO (Either StoreError a)
`tryCreateName` Int
20)
  where
    getLdnSuffix :: IO Int
    getLdnSuffix :: IO Int
getLdnSuffix =
      Int -> (Only Int -> Int) -> Maybe (Only Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 ((Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> (Only Int -> Int) -> Only Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only Int -> Int
forall a. Only a -> a
fromOnly) (Maybe (Only Int) -> Int)
-> ([Only Int] -> Maybe (Only Int)) -> [Only Int] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Only Int] -> Maybe (Only Int)
forall a. [a] -> Maybe a
listToMaybe
        ([Only Int] -> Int) -> IO [Only Int] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> (UserId, Text) -> IO [Only Int]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
          Connection
db
          [sql|
            SELECT ldn_suffix FROM display_names
            WHERE user_id = ? AND ldn_base = ?
            ORDER BY ldn_suffix DESC
            LIMIT 1
          |]
          (UserId
userId, Text
displayName)
    tryCreateName :: Int -> Int -> IO (Either StoreError a)
    tryCreateName :: Int -> Int -> IO (Either StoreError a)
tryCreateName Int
_ Int
0 = Either StoreError a -> IO (Either StoreError a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StoreError a -> IO (Either StoreError a))
-> Either StoreError a -> IO (Either StoreError a)
forall a b. (a -> b) -> a -> b
$ StoreError -> Either StoreError a
forall a b. a -> Either a b
Left StoreError
SEDuplicateName
    tryCreateName Int
ldnSuffix Int
attempts = do
      UTCTime
currentTs <- IO UTCTime
getCurrentTime
      let ldn :: Text
ldn = Text
displayName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Int
ldnSuffix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Text
"" else String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
ldnSuffix)
      IO () -> IO (Either SQLError ())
forall e a. Exception e => IO a -> IO (Either e a)
E.try (Text -> UTCTime -> IO ()
insertName Text
ldn UTCTime
currentTs) IO (Either SQLError ())
-> (Either SQLError () -> IO (Either StoreError a))
-> IO (Either StoreError a)
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 () -> Text -> IO (Either StoreError a)
action Text
ldn
        Left SQLError
e
          | SQLError -> Bool
constraintError SQLError
e -> Int -> Int -> IO (Either StoreError a)
tryCreateName (Int
ldnSuffix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
attempts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
          | Bool
otherwise -> SQLError -> IO (Either StoreError a)
forall e a. Exception e => e -> IO a
E.throwIO SQLError
e
      where
        insertName :: Text -> UTCTime -> IO ()
insertName Text
ldn UTCTime
ts =
          Connection
-> Query -> (Text, Text, Int, UserId, UTCTime, UTCTime) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
            Connection
db
            [sql|
              INSERT INTO display_names
                (local_display_name, ldn_base, ldn_suffix, user_id, created_at, updated_at)
              VALUES (?,?,?,?,?,?)
            |]
            (Text
ldn, Text
displayName, Int
ldnSuffix, UserId
userId, UTCTime
ts, UTCTime
ts)

createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
createWithRandomId :: forall a.
TVar ChaChaDRG -> (ConnId -> IO a) -> ExceptT StoreError IO a
createWithRandomId = Int
-> TVar ChaChaDRG -> (ConnId -> IO a) -> ExceptT StoreError IO a
forall a.
Int
-> TVar ChaChaDRG -> (ConnId -> IO a) -> ExceptT StoreError IO a
createWithRandomBytes Int
12

createWithRandomId' :: forall a. TVar ChaChaDRG -> (ByteString -> IO (Either StoreError a)) -> ExceptT StoreError IO a
createWithRandomId' :: forall a.
TVar ChaChaDRG
-> (ConnId -> IO (Either StoreError a)) -> ExceptT StoreError IO a
createWithRandomId' = Int
-> TVar ChaChaDRG
-> (ConnId -> IO (Either StoreError a))
-> ExceptT StoreError IO a
forall a.
Int
-> TVar ChaChaDRG
-> (ConnId -> IO (Either StoreError a))
-> ExceptT StoreError IO a
createWithRandomBytes' Int
12

createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
createWithRandomBytes :: forall a.
Int
-> TVar ChaChaDRG -> (ConnId -> IO a) -> ExceptT StoreError IO a
createWithRandomBytes Int
size TVar ChaChaDRG
gVar ConnId -> IO a
create = Int
-> TVar ChaChaDRG
-> (ConnId -> IO (Either StoreError a))
-> ExceptT StoreError IO a
forall a.
Int
-> TVar ChaChaDRG
-> (ConnId -> IO (Either StoreError a))
-> ExceptT StoreError IO a
createWithRandomBytes' Int
size TVar ChaChaDRG
gVar ((a -> Either StoreError a) -> IO a -> IO (Either StoreError a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either StoreError a
forall a b. b -> Either a b
Right (IO a -> IO (Either StoreError a))
-> (ConnId -> IO a) -> ConnId -> IO (Either StoreError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnId -> IO a
create)

createWithRandomBytes' :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO (Either StoreError a)) -> ExceptT StoreError IO a
createWithRandomBytes' :: forall a.
Int
-> TVar ChaChaDRG
-> (ConnId -> IO (Either StoreError a))
-> ExceptT StoreError IO a
createWithRandomBytes' Int
size TVar ChaChaDRG
gVar ConnId -> IO (Either StoreError a)
create = Int -> ExceptT StoreError IO a
tryCreate Int
3
  where
    tryCreate :: Int -> ExceptT StoreError IO a
    tryCreate :: Int -> ExceptT StoreError IO a
tryCreate Int
0 = StoreError -> ExceptT StoreError IO a
forall a. StoreError -> ExceptT StoreError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StoreError
SEUniqueID
    tryCreate Int
n = do
      ConnId
id' <- IO ConnId -> ExceptT StoreError IO ConnId
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ConnId -> ExceptT StoreError IO ConnId)
-> IO ConnId -> ExceptT StoreError IO ConnId
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> Int -> IO ConnId
encodedRandomBytes TVar ChaChaDRG
gVar Int
size
      IO (Either SQLError (Either StoreError a))
-> ExceptT StoreError IO (Either SQLError (Either StoreError a))
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either StoreError a)
-> IO (Either SQLError (Either StoreError a))
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO (Either StoreError a)
 -> IO (Either SQLError (Either StoreError a)))
-> IO (Either StoreError a)
-> IO (Either SQLError (Either StoreError a))
forall a b. (a -> b) -> a -> b
$ ConnId -> IO (Either StoreError a)
create ConnId
id') ExceptT StoreError IO (Either SQLError (Either StoreError a))
-> (Either SQLError (Either StoreError a)
    -> ExceptT StoreError IO a)
-> ExceptT StoreError IO a
forall a b.
ExceptT StoreError IO a
-> (a -> ExceptT StoreError IO b) -> ExceptT StoreError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right Either StoreError a
x -> Either StoreError a -> ExceptT StoreError IO a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither Either StoreError a
x
        Left SQLError
e
          | SQLError -> Bool
constraintError SQLError
e -> Int -> ExceptT StoreError IO a
tryCreate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
          | Bool
otherwise -> StoreError -> ExceptT StoreError IO a
forall a. StoreError -> ExceptT StoreError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (StoreError -> ExceptT StoreError IO a)
-> (String -> StoreError) -> String -> ExceptT StoreError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StoreError
SEInternalError (String -> ExceptT StoreError IO a)
-> String -> ExceptT StoreError IO a
forall a b. (a -> b) -> a -> b
$ SQLError -> String
forall a. Show a => a -> String
show SQLError
e

encodedRandomBytes :: TVar ChaChaDRG -> Int -> IO ByteString
encodedRandomBytes :: TVar ChaChaDRG -> Int -> IO ConnId
encodedRandomBytes TVar ChaChaDRG
gVar Int
n = STM ConnId -> IO ConnId
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM ConnId -> IO ConnId) -> STM ConnId -> IO ConnId
forall a b. (a -> b) -> a -> b
$ ConnId -> ConnId
B64.encode (ConnId -> ConnId) -> STM ConnId -> STM ConnId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> TVar ChaChaDRG -> STM ConnId
C.randomBytes Int
n TVar ChaChaDRG
gVar

assertNotUser :: DB.Connection -> User -> Contact -> ExceptT StoreError IO ()
assertNotUser :: Connection -> User -> Contact -> ExceptT StoreError IO ()
assertNotUser Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} Contact {UserId
contactId :: Contact -> UserId
contactId :: UserId
contactId, Text
localDisplayName :: Contact -> Text
localDisplayName :: Text
localDisplayName} = do
  Maybe UserId
r :: (Maybe Int64) <-
    -- This query checks that the foreign keys in the users table
    -- are not referencing the contact about to be deleted.
    -- With the current schema it would cause cascade delete of user,
    -- with mofified schema (in v5.6.0-beta.0) it would cause foreign key violation error.
    IO (Maybe UserId) -> ExceptT StoreError IO (Maybe UserId)
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe UserId) -> ExceptT StoreError IO (Maybe UserId))
-> (IO [Only UserId] -> IO (Maybe UserId))
-> IO [Only UserId]
-> ExceptT StoreError IO (Maybe UserId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Only UserId -> UserId) -> IO [Only UserId] -> IO (Maybe UserId)
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow Only UserId -> UserId
forall a. Only a -> a
fromOnly (IO [Only UserId] -> ExceptT StoreError IO (Maybe UserId))
-> IO [Only UserId] -> ExceptT StoreError IO (Maybe UserId)
forall a b. (a -> b) -> a -> b
$
      Connection -> Query -> (UserId, Text, UserId) -> IO [Only UserId]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
        Connection
db
        [sql|
          SELECT 1 FROM users
          WHERE (user_id = ? AND local_display_name = ?)
             OR contact_id = ?
          LIMIT 1
        |]
        (UserId
userId, Text
localDisplayName, UserId
contactId)
  Bool -> ExceptT StoreError IO () -> ExceptT StoreError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe UserId -> Bool
forall a. Maybe a -> Bool
isJust Maybe UserId
r) (ExceptT StoreError IO () -> ExceptT StoreError IO ())
-> ExceptT StoreError IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ StoreError -> ExceptT StoreError IO ()
forall a. StoreError -> ExceptT StoreError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (StoreError -> ExceptT StoreError IO ())
-> StoreError -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ UserId -> UserId -> StoreError
SEProhibitedDeleteUser UserId
userId UserId
contactId

safeDeleteLDN :: DB.Connection -> User -> ContactName -> IO ()
safeDeleteLDN :: Connection -> User -> Text -> IO ()
safeDeleteLDN Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} Text
localDisplayName = do
  Connection -> Query -> (UserId, Text, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      DELETE FROM display_names
      WHERE user_id = ? AND local_display_name = ?
        AND local_display_name NOT IN (SELECT local_display_name FROM users WHERE user_id = ?)
    |]
    (UserId
userId, Text
localDisplayName, UserId
userId)

type PreparedGroupRow = (Maybe ConnReqContact, Maybe ShortLinkContact, BoolInt, BoolInt, Maybe SharedMsgId, Maybe SharedMsgId)

type BusinessChatInfoRow = (Maybe BusinessChatType, Maybe MemberId, Maybe MemberId)

type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Text, Maybe Text, Maybe ImageData) :. (Maybe MsgFilter, Maybe BoolInt, BoolInt, Maybe GroupPreferences, Maybe GroupMemberAdmission) :. (UTCTime, UTCTime, Maybe UTCTime, Maybe UTCTime) :. PreparedGroupRow :. BusinessChatInfoRow :. (Maybe UIThemeEntityOverrides, Int64, Maybe CustomData, Maybe Int64, Int, Maybe ConnReqContact) :. GroupMemberRow

type GroupMemberRow = (GroupMemberId, GroupId, Int64, MemberId, VersionChat, VersionChat, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, BoolInt, Maybe MemberRestrictionStatus) :. (Maybe Int64, Maybe GroupMemberId, ContactName, Maybe ContactId, ProfileId) :. ProfileRow :. (UTCTime, UTCTime) :. (Maybe UTCTime, Int64, Int64, Int64, Maybe UTCTime)

type ProfileRow = (ProfileId, ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, Maybe Preferences)

toGroupInfo :: VersionRangeChat -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
toGroupInfo :: VersionRangeChat -> UserId -> [UserId] -> GroupInfoRow -> GroupInfo
toGroupInfo VersionRangeChat
vr UserId
userContactId [UserId]
chatTags ((UserId
groupId, Text
localDisplayName, Text
displayName, Text
fullName, Maybe Text
shortDescr, Text
localAlias, Maybe Text
description, Maybe ImageData
image) :. (Maybe MsgFilter
enableNtfs_, Maybe BoolInt
sendRcpts, BI Bool
favorite, Maybe GroupPreferences
groupPreferences, Maybe GroupMemberAdmission
memberAdmission) :. (UTCTime
createdAt, UTCTime
updatedAt, Maybe UTCTime
chatTs, Maybe UTCTime
userMemberProfileSentAt) :. PreparedGroupRow
preparedGroupRow :. BusinessChatInfoRow
businessRow :. (Maybe UIThemeEntityOverrides
uiThemes, UserId
currentMembers, Maybe CustomData
customData, Maybe UserId
chatItemTTL, Int
membersRequireAttention, Maybe ConnReqContact
viaGroupLinkUri) :. GroupMemberRow
userMemberRow) =
  let membership :: GroupMember
membership = (UserId -> GroupMemberRow -> GroupMember
toGroupMember UserId
userContactId GroupMemberRow
userMemberRow) {memberChatVRange = vr}
      chatSettings :: ChatSettings
chatSettings = ChatSettings {enableNtfs :: MsgFilter
enableNtfs = MsgFilter -> Maybe MsgFilter -> MsgFilter
forall a. a -> Maybe a -> a
fromMaybe MsgFilter
MFAll Maybe MsgFilter
enableNtfs_, sendRcpts :: Maybe Bool
sendRcpts = BoolInt -> Bool
unBI (BoolInt -> Bool) -> Maybe BoolInt -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe BoolInt
sendRcpts, Bool
favorite :: Bool
favorite :: Bool
favorite}
      fullGroupPreferences :: FullGroupPreferences
fullGroupPreferences = Maybe GroupPreferences -> FullGroupPreferences
mergeGroupPreferences Maybe GroupPreferences
groupPreferences
      groupProfile :: GroupProfile
groupProfile = GroupProfile {Text
displayName :: Text
displayName :: Text
displayName, Text
fullName :: Text
fullName :: Text
fullName, Maybe Text
shortDescr :: Maybe Text
shortDescr :: Maybe Text
shortDescr, Maybe Text
description :: Maybe Text
description :: Maybe Text
description, Maybe ImageData
image :: Maybe ImageData
image :: Maybe ImageData
image, Maybe GroupPreferences
groupPreferences :: Maybe GroupPreferences
groupPreferences :: Maybe GroupPreferences
groupPreferences, Maybe GroupMemberAdmission
memberAdmission :: Maybe GroupMemberAdmission
memberAdmission :: Maybe GroupMemberAdmission
memberAdmission}
      businessChat :: Maybe BusinessChatInfo
businessChat = BusinessChatInfoRow -> Maybe BusinessChatInfo
toBusinessChatInfo BusinessChatInfoRow
businessRow
      preparedGroup :: Maybe PreparedGroup
preparedGroup = PreparedGroupRow -> Maybe PreparedGroup
toPreparedGroup PreparedGroupRow
preparedGroupRow
      groupSummary :: GroupSummary
groupSummary = GroupSummary {UserId
currentMembers :: UserId
currentMembers :: UserId
currentMembers}
   in GroupInfo {UserId
groupId :: UserId
groupId :: UserId
groupId, useRelays :: BoolDef
useRelays = Bool -> BoolDef
BoolDef Bool
False, Text
localDisplayName :: Text
localDisplayName :: Text
localDisplayName, GroupProfile
groupProfile :: GroupProfile
groupProfile :: GroupProfile
groupProfile, Text
localAlias :: Text
localAlias :: Text
localAlias, Maybe BusinessChatInfo
businessChat :: Maybe BusinessChatInfo
businessChat :: Maybe BusinessChatInfo
businessChat, FullGroupPreferences
fullGroupPreferences :: FullGroupPreferences
fullGroupPreferences :: FullGroupPreferences
fullGroupPreferences, GroupMember
membership :: GroupMember
membership :: GroupMember
membership, ChatSettings
chatSettings :: ChatSettings
chatSettings :: ChatSettings
chatSettings, UTCTime
createdAt :: UTCTime
createdAt :: UTCTime
createdAt, UTCTime
updatedAt :: UTCTime
updatedAt :: UTCTime
updatedAt, Maybe UTCTime
chatTs :: Maybe UTCTime
chatTs :: Maybe UTCTime
chatTs, Maybe UTCTime
userMemberProfileSentAt :: Maybe UTCTime
userMemberProfileSentAt :: Maybe UTCTime
userMemberProfileSentAt, Maybe PreparedGroup
preparedGroup :: Maybe PreparedGroup
preparedGroup :: Maybe PreparedGroup
preparedGroup, [UserId]
chatTags :: [UserId]
chatTags :: [UserId]
chatTags, Maybe UserId
chatItemTTL :: Maybe UserId
chatItemTTL :: Maybe UserId
chatItemTTL, Maybe UIThemeEntityOverrides
uiThemes :: Maybe UIThemeEntityOverrides
uiThemes :: Maybe UIThemeEntityOverrides
uiThemes, GroupSummary
groupSummary :: GroupSummary
groupSummary :: GroupSummary
groupSummary, Maybe CustomData
customData :: Maybe CustomData
customData :: Maybe CustomData
customData, Int
membersRequireAttention :: Int
membersRequireAttention :: Int
membersRequireAttention, Maybe ConnReqContact
viaGroupLinkUri :: Maybe ConnReqContact
viaGroupLinkUri :: Maybe ConnReqContact
viaGroupLinkUri}

toPreparedGroup :: PreparedGroupRow -> Maybe PreparedGroup
toPreparedGroup :: PreparedGroupRow -> Maybe PreparedGroup
toPreparedGroup = \case
  (Just ConnReqContact
fullLink, Maybe ShortLinkContact
shortLink_, BI Bool
connLinkPreparedConnection, BI Bool
connLinkStartedConnection, Maybe SharedMsgId
welcomeSharedMsgId, Maybe SharedMsgId
requestSharedMsgId) ->
    PreparedGroup -> Maybe PreparedGroup
forall a. a -> Maybe a
Just PreparedGroup {connLinkToConnect :: CreatedLinkContact
connLinkToConnect = ConnReqContact -> Maybe ShortLinkContact -> CreatedLinkContact
forall (m :: ConnectionMode).
ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
CCLink ConnReqContact
fullLink Maybe ShortLinkContact
shortLink_, Bool
connLinkPreparedConnection :: Bool
connLinkPreparedConnection :: Bool
connLinkPreparedConnection, Bool
connLinkStartedConnection :: Bool
connLinkStartedConnection :: Bool
connLinkStartedConnection, Maybe SharedMsgId
welcomeSharedMsgId :: Maybe SharedMsgId
welcomeSharedMsgId :: Maybe SharedMsgId
welcomeSharedMsgId, Maybe SharedMsgId
requestSharedMsgId :: Maybe SharedMsgId
requestSharedMsgId :: Maybe SharedMsgId
requestSharedMsgId}
  PreparedGroupRow
_ -> Maybe PreparedGroup
forall a. Maybe a
Nothing

toGroupMember :: Int64 -> GroupMemberRow -> GroupMember
toGroupMember :: UserId -> GroupMemberRow -> GroupMember
toGroupMember UserId
userContactId ((UserId
groupMemberId, UserId
groupId, UserId
indexInGroup, MemberId
memberId, Version ChatVersion
minVer, Version ChatVersion
maxVer, GroupMemberRole
memberRole, GroupMemberCategory
memberCategory, GroupMemberStatus
memberStatus, BI Bool
showMessages, Maybe MemberRestrictionStatus
memberRestriction_) :. (Maybe UserId
invitedById, Maybe UserId
invitedByGroupMemberId, Text
localDisplayName, Maybe UserId
memberContactId, UserId
memberContactProfileId) :. ProfileRow
profileRow :. (UTCTime
createdAt, UTCTime
updatedAt) :. (Maybe UTCTime
supportChatTs_, UserId
supportChatUnread, UserId
supportChatMemberAttention, UserId
supportChatMentions, Maybe UTCTime
supportChatLastMsgFromMemberTs)) =
  let memberProfile :: LocalProfile
memberProfile = ProfileRow -> LocalProfile
rowToLocalProfile ProfileRow
profileRow
      memberSettings :: GroupMemberSettings
memberSettings = GroupMemberSettings {Bool
showMessages :: Bool
showMessages :: Bool
showMessages}
      blockedByAdmin :: Bool
blockedByAdmin = Bool
-> (MemberRestrictionStatus -> Bool)
-> Maybe MemberRestrictionStatus
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False MemberRestrictionStatus -> Bool
mrsBlocked Maybe MemberRestrictionStatus
memberRestriction_
      invitedBy :: InvitedBy
invitedBy = UserId -> Maybe UserId -> InvitedBy
toInvitedBy UserId
userContactId Maybe UserId
invitedById
      activeConn :: Maybe a
activeConn = Maybe a
forall a. Maybe a
Nothing
      memberChatVRange :: VersionRangeChat
memberChatVRange = VersionRangeChat -> Maybe VersionRangeChat -> VersionRangeChat
forall a. a -> Maybe a -> a
fromMaybe (Version ChatVersion -> VersionRangeChat
forall v. Version v -> VersionRange v
versionToRange Version ChatVersion
maxVer) (Maybe VersionRangeChat -> VersionRangeChat)
-> Maybe VersionRangeChat -> VersionRangeChat
forall a b. (a -> b) -> a -> b
$ Version ChatVersion
-> Version ChatVersion -> Maybe VersionRangeChat
forall v. Version v -> Version v -> Maybe (VersionRange v)
safeVersionRange Version ChatVersion
minVer Version ChatVersion
maxVer
      supportChat :: Maybe GroupSupportChat
supportChat = case Maybe UTCTime
supportChatTs_ of
        Just UTCTime
chatTs ->
          GroupSupportChat -> Maybe GroupSupportChat
forall a. a -> Maybe a
Just
            GroupSupportChat
              { UTCTime
chatTs :: UTCTime
chatTs :: UTCTime
chatTs,
                unread :: UserId
unread = UserId
supportChatUnread,
                memberAttention :: UserId
memberAttention = UserId
supportChatMemberAttention,
                mentions :: UserId
mentions = UserId
supportChatMentions,
                lastMsgFromMemberTs :: Maybe UTCTime
lastMsgFromMemberTs = Maybe UTCTime
supportChatLastMsgFromMemberTs
              }
        Maybe UTCTime
_ -> Maybe GroupSupportChat
forall a. Maybe a
Nothing
   in GroupMember {Bool
UserId
Maybe UserId
Maybe Connection
Maybe GroupSupportChat
Text
UTCTime
VersionRangeChat
GroupMemberRole
GroupMemberStatus
GroupMemberCategory
GroupMemberSettings
InvitedBy
MemberId
LocalProfile
forall a. Maybe a
memberChatVRange :: VersionRangeChat
groupMemberId :: UserId
groupId :: UserId
indexInGroup :: UserId
memberId :: MemberId
memberRole :: GroupMemberRole
memberCategory :: GroupMemberCategory
memberStatus :: GroupMemberStatus
invitedByGroupMemberId :: Maybe UserId
localDisplayName :: Text
memberContactId :: Maybe UserId
memberContactProfileId :: UserId
createdAt :: UTCTime
updatedAt :: UTCTime
memberProfile :: LocalProfile
memberSettings :: GroupMemberSettings
blockedByAdmin :: Bool
invitedBy :: InvitedBy
activeConn :: forall a. Maybe a
memberChatVRange :: VersionRangeChat
supportChat :: Maybe GroupSupportChat
supportChat :: Maybe GroupSupportChat
updatedAt :: UTCTime
createdAt :: UTCTime
activeConn :: Maybe Connection
memberContactProfileId :: UserId
memberContactId :: Maybe UserId
memberProfile :: LocalProfile
localDisplayName :: Text
invitedByGroupMemberId :: Maybe UserId
invitedBy :: InvitedBy
blockedByAdmin :: Bool
memberSettings :: GroupMemberSettings
memberStatus :: GroupMemberStatus
memberCategory :: GroupMemberCategory
memberRole :: GroupMemberRole
memberId :: MemberId
indexInGroup :: UserId
groupId :: UserId
groupMemberId :: UserId
..}

groupMemberQuery :: Query
groupMemberQuery :: Query
groupMemberQuery =
  [sql|
    SELECT
      m.group_member_id, m.group_id, m.index_in_group, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction,
      m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences,
      m.created_at, m.updated_at,
      m.support_chat_ts, m.support_chat_items_unread, m.support_chat_items_member_attention, m.support_chat_items_mentions, m.support_chat_last_msg_from_member_ts,
      c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.xcontact_id, c.custom_user_profile_id,
      c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.user_contact_link_id,
      c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter,
      c.conn_chat_version, c.peer_chat_min_version, c.peer_chat_max_version
    FROM group_members m
    JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
    LEFT JOIN connections c ON c.group_member_id = m.group_member_id
  |]

toContactMember :: VersionRangeChat -> User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
toContactMember :: VersionRangeChat
-> User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
toContactMember VersionRangeChat
vr User {UserId
userContactId :: User -> UserId
userContactId :: UserId
userContactId} (GroupMemberRow
memberRow :. MaybeConnectionRow
connRow) =
  (UserId -> GroupMemberRow -> GroupMember
toGroupMember UserId
userContactId GroupMemberRow
memberRow) {activeConn = toMaybeConnection vr connRow}

rowToLocalProfile :: ProfileRow -> LocalProfile
rowToLocalProfile :: ProfileRow -> LocalProfile
rowToLocalProfile (UserId
profileId, Text
displayName, Text
fullName, Maybe Text
shortDescr, Maybe ImageData
image, Maybe ConnLinkContact
contactLink, Maybe ChatPeerType
peerType, Text
localAlias, Maybe Preferences
preferences) =
  LocalProfile {UserId
profileId :: UserId
profileId :: UserId
profileId, Text
displayName :: Text
displayName :: Text
displayName, Text
fullName :: Text
fullName :: Text
fullName, Maybe Text
shortDescr :: Maybe Text
shortDescr :: Maybe Text
shortDescr, Maybe ImageData
image :: Maybe ImageData
image :: Maybe ImageData
image, Maybe ConnLinkContact
contactLink :: Maybe ConnLinkContact
contactLink :: Maybe ConnLinkContact
contactLink, Maybe ChatPeerType
peerType :: Maybe ChatPeerType
peerType :: Maybe ChatPeerType
peerType, Text
localAlias :: Text
localAlias :: Text
localAlias, Maybe Preferences
preferences :: Maybe Preferences
preferences :: Maybe Preferences
preferences}

toBusinessChatInfo :: BusinessChatInfoRow -> Maybe BusinessChatInfo
toBusinessChatInfo :: BusinessChatInfoRow -> Maybe BusinessChatInfo
toBusinessChatInfo (Just BusinessChatType
chatType, Just MemberId
businessId, Just MemberId
customerId) = BusinessChatInfo -> Maybe BusinessChatInfo
forall a. a -> Maybe a
Just BusinessChatInfo {BusinessChatType
chatType :: BusinessChatType
chatType :: BusinessChatType
chatType, MemberId
businessId :: MemberId
businessId :: MemberId
businessId, MemberId
customerId :: MemberId
customerId :: MemberId
customerId}
toBusinessChatInfo BusinessChatInfoRow
_ = Maybe BusinessChatInfo
forall a. Maybe a
Nothing

groupInfoQuery :: Query
groupInfoQuery :: Query
groupInfoQuery = Query
groupInfoQueryFields Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" " Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
groupInfoQueryFrom

groupInfoQueryFields :: Query
groupInfoQueryFields :: Query
groupInfoQueryFields =
  [sql|
    SELECT
      -- GroupInfo
      g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.short_descr, g.local_alias, gp.description, gp.image,
      g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, gp.member_admission,
      g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at,
      g.conn_full_link_to_connect, g.conn_short_link_to_connect, g.conn_link_prepared_connection, g.conn_link_started_connection, g.welcome_shared_msg_id, g.request_shared_msg_id,
      g.business_chat, g.business_member_id, g.customer_member_id,
      g.ui_themes, g.summary_current_members_count, g.custom_data, g.chat_item_ttl, g.members_require_attention, g.via_group_link_uri,
      -- GroupMember - membership
      mu.group_member_id, mu.group_id, mu.index_in_group, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category,
      mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
      pu.display_name, pu.full_name, pu.short_descr, pu.image, pu.contact_link, pu.chat_peer_type, pu.local_alias, pu.preferences,
      mu.created_at, mu.updated_at,
      mu.support_chat_ts, mu.support_chat_items_unread, mu.support_chat_items_member_attention, mu.support_chat_items_mentions, mu.support_chat_last_msg_from_member_ts
  |]

groupInfoQueryFrom :: Query
groupInfoQueryFrom :: Query
groupInfoQueryFrom =
  [sql|
    FROM groups g
    JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
    JOIN group_members mu ON mu.group_id = g.group_id
    JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id)
  |]

createChatTag :: DB.Connection -> User -> Maybe Text -> Text -> IO ChatTagId
createChatTag :: Connection -> User -> Maybe Text -> Text -> IO UserId
createChatTag Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} Maybe Text
emoji Text
text = do
  Connection -> Query -> (UserId, Maybe Text, Text, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      INSERT INTO chat_tags (user_id, chat_tag_emoji, chat_tag_text, tag_order)
      VALUES (?,?,?, COALESCE((SELECT MAX(tag_order) + 1 FROM chat_tags WHERE user_id = ?), 1))
    |]
    (UserId
userId, Maybe Text
emoji, Text
text, UserId
userId)
  Connection -> IO UserId
insertedRowId Connection
db

deleteChatTag :: DB.Connection -> User -> ChatTagId -> IO ()
deleteChatTag :: Connection -> User -> UserId -> IO ()
deleteChatTag Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} UserId
tId =
  Connection -> Query -> (UserId, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      DELETE FROM chat_tags
      WHERE user_id = ? AND chat_tag_id = ?
    |]
    (UserId
userId, UserId
tId)

updateChatTag :: DB.Connection -> User -> ChatTagId -> Maybe Text -> Text -> IO ()
updateChatTag :: Connection -> User -> UserId -> Maybe Text -> Text -> IO ()
updateChatTag Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} UserId
tId Maybe Text
emoji Text
text =
  Connection -> Query -> (Maybe Text, Text, UserId, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE chat_tags
      SET chat_tag_emoji = ?, chat_tag_text = ?
      WHERE user_id = ? AND chat_tag_id = ?
    |]
    (Maybe Text
emoji, Text
text, UserId
userId, UserId
tId)

updateChatTagOrder :: DB.Connection -> User -> ChatTagId -> Int -> IO ()
updateChatTagOrder :: Connection -> User -> UserId -> Int -> IO ()
updateChatTagOrder Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} UserId
tId Int
order =
  Connection -> Query -> (Int, UserId, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE chat_tags
      SET tag_order = ?
      WHERE user_id = ? AND chat_tag_id = ?
    |]
    (Int
order, UserId
userId, UserId
tId)

reorderChatTags :: DB.Connection -> User -> [ChatTagId] -> IO ()
reorderChatTags :: Connection -> User -> [UserId] -> IO ()
reorderChatTags Connection
db User
user [UserId]
tIds =
  [(Int, UserId)] -> ((Int, UserId) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [UserId] -> [(Int, UserId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [UserId]
tIds) (((Int, UserId) -> IO ()) -> IO ())
-> ((Int, UserId) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
order, UserId
tId) ->
    Connection -> User -> UserId -> Int -> IO ()
updateChatTagOrder Connection
db User
user UserId
tId Int
order

getUserChatTags :: DB.Connection -> User -> IO [ChatTag]
getUserChatTags :: Connection -> User -> IO [ChatTag]
getUserChatTags Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} =
  ((UserId, Maybe Text, Text) -> ChatTag)
-> [(UserId, Maybe Text, Text)] -> [ChatTag]
forall a b. (a -> b) -> [a] -> [b]
map (UserId, Maybe Text, Text) -> ChatTag
toChatTag
    ([(UserId, Maybe Text, Text)] -> [ChatTag])
-> IO [(UserId, Maybe Text, Text)] -> IO [ChatTag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> Query -> Only UserId -> IO [(UserId, Maybe Text, Text)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
      Connection
db
      [sql|
        SELECT chat_tag_id, chat_tag_emoji, chat_tag_text
        FROM chat_tags
        WHERE user_id = ?
        ORDER BY tag_order
      |]
      (UserId -> Only UserId
forall a. a -> Only a
Only UserId
userId)
  where
    toChatTag :: (ChatTagId, Maybe Text, Text) -> ChatTag
    toChatTag :: (UserId, Maybe Text, Text) -> ChatTag
toChatTag (UserId
chatTagId, Maybe Text
chatTagEmoji, Text
chatTagText) = ChatTag {UserId
chatTagId :: UserId
chatTagId :: UserId
chatTagId, Maybe Text
chatTagEmoji :: Maybe Text
chatTagEmoji :: Maybe Text
chatTagEmoji, Text
chatTagText :: Text
chatTagText :: Text
chatTagText}

getGroupChatTags :: DB.Connection -> GroupId -> IO [ChatTagId]
getGroupChatTags :: Connection -> UserId -> IO [UserId]
getGroupChatTags Connection
db UserId
groupId =
  (Only UserId -> UserId) -> [Only UserId] -> [UserId]
forall a b. (a -> b) -> [a] -> [b]
map Only UserId -> UserId
forall a. Only a -> a
fromOnly ([Only UserId] -> [UserId]) -> IO [Only UserId] -> IO [UserId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> Only UserId -> IO [Only UserId]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db Query
"SELECT chat_tag_id FROM chat_tags_chats WHERE group_id = ?" (UserId -> Only UserId
forall a. a -> Only a
Only UserId
groupId)

addGroupChatTags :: DB.Connection -> GroupInfo -> IO GroupInfo
addGroupChatTags :: Connection -> GroupInfo -> IO GroupInfo
addGroupChatTags Connection
db g :: GroupInfo
g@GroupInfo {UserId
groupId :: GroupInfo -> UserId
groupId :: UserId
groupId} = do
  [UserId]
chatTags <- Connection -> UserId -> IO [UserId]
getGroupChatTags Connection
db UserId
groupId
  GroupInfo -> IO GroupInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
g :: GroupInfo) {chatTags}

setViaGroupLinkUri :: DB.Connection -> GroupId -> Int64 -> IO ()
setViaGroupLinkUri :: Connection -> UserId -> UserId -> IO ()
setViaGroupLinkUri Connection
db UserId
groupId UserId
connId = do
  [(Maybe ConnReqContact, Maybe ConnReqUriHash)]
r <-
    Connection
-> Query
-> Only UserId
-> IO [(Maybe ConnReqContact, Maybe ConnReqUriHash)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
      Connection
db
      Query
"SELECT via_contact_uri, via_contact_uri_hash FROM connections WHERE connection_id = ?"
      (UserId -> Only UserId
forall a. a -> Only a
Only UserId
connId) ::
      IO [(Maybe ConnReqContact, Maybe ConnReqUriHash)]
  Maybe (Maybe ConnReqContact, Maybe ConnReqUriHash)
-> ((Maybe ConnReqContact, Maybe ConnReqUriHash) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Maybe ConnReqContact, Maybe ConnReqUriHash)]
-> Maybe (Maybe ConnReqContact, Maybe ConnReqUriHash)
forall a. [a] -> Maybe a
listToMaybe [(Maybe ConnReqContact, Maybe ConnReqUriHash)]
r) (((Maybe ConnReqContact, Maybe ConnReqUriHash) -> IO ()) -> IO ())
-> ((Maybe ConnReqContact, Maybe ConnReqUriHash) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Maybe ConnReqContact
viaContactUri, Maybe ConnReqUriHash
viaContactUriHash) ->
    Connection
-> Query
-> (Maybe ConnReqContact, Maybe ConnReqUriHash, UserId)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
      Connection
db
      [sql|
        UPDATE groups
        SET via_group_link_uri = ?, via_group_link_uri_hash = ?
        WHERE group_id = ?
      |]
      (Maybe ConnReqContact
viaContactUri, Maybe ConnReqUriHash
viaContactUriHash, UserId
groupId)

deleteConnectionRecord :: DB.Connection -> User -> Int64 -> IO ()
deleteConnectionRecord :: Connection -> User -> UserId -> IO ()
deleteConnectionRecord Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} UserId
cId = do
  Connection -> Query -> (UserId, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"DELETE FROM connections WHERE user_id = ? AND connection_id = ?" (UserId
userId, UserId
cId)