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

module Simplex.Chat.Store.Profiles
  ( AutoAccept (..),
    AddressSettings (..),
    UserMsgReceiptSettings (..),
    UserContactLink (..),
    GroupLinkInfo (..),
    createUserRecord,
    createUserRecordAt,
    getUsersInfo,
    getUsers,
    setActiveUser,
    getUser,
    getUserIdByName,
    getUserByAConnId,
    getUserByASndFileId,
    getUserByARcvFileId,
    getUserByContactId,
    getUserByGroupId,
    getUserByNoteFolderId,
    getUserByFileId,
    getUserFileInfo,
    deleteUserRecord,
    updateUserPrivacy,
    updateAllContactReceipts,
    updateUserContactReceipts,
    updateUserGroupReceipts,
    updateUserAutoAcceptMemberContacts,
    updateUserProfile,
    setUserProfileContactLink,
    getUserContactProfiles,
    createUserContactLink,
    getUserAddressConnection,
    deleteUserAddress,
    getUserAddress,
    getUserContactLinkById,
    getGroupLinkInfo,
    getUserContactLinkByConnReq,
    getUserContactLinkViaShortLink,
    setUserContactLinkShortLink,
    getContactWithoutConnViaAddress,
    getContactWithoutConnViaShortAddress,
    updateUserAddressSettings,
    getProtocolServers,
    insertProtocolServer,
    getUpdateServerOperators,
    getServerOperators,
    getUserServers,
    setServerOperators,
    getCurrentUsageConditions,
    getLatestAcceptedConditions,
    setConditionsNotified,
    acceptConditions,
    setUserServers,
    setUserServers',
    createCall,
    deleteCalls,
    getCalls,
    createCommand,
    setCommandConnId,
    deleteCommand,
    updateCommandStatus,
    getCommandDataByCorrId,
    setUserUIThemes,
    profileContactLink,
  )
where

import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import qualified Data.Aeson.TH as J
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (catMaybes, fromMaybe, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Simplex.Chat.Call
import Simplex.Chat.Messages
import Simplex.Chat.Operators
import Simplex.Chat.Protocol
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.UITheme
import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..))
import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, ConnectionLink (..), CreatedConnLink (..), UserId)
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 qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON)
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode)
import Simplex.Messaging.Agent.Store.Entity
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
#if defined(dbPostgres)
import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..))
import Database.PostgreSQL.Simple.SqlQQ (sql)
#else
import Database.SQLite.Simple (Only (..), Query, (:.) (..))
import Database.SQLite.Simple.QQ (sql)
#endif

createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User
createUserRecord :: Connection
-> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User
createUserRecord Connection
db AgentUserId
auId Profile
p Bool
activeUser = Connection
-> AgentUserId
-> Profile
-> Bool
-> UTCTime
-> ExceptT StoreError IO User
createUserRecordAt Connection
db AgentUserId
auId Profile
p Bool
activeUser (UTCTime -> ExceptT StoreError IO User)
-> ExceptT StoreError IO UTCTime -> ExceptT StoreError IO User
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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

createUserRecordAt :: DB.Connection -> AgentUserId -> Profile -> Bool -> UTCTime -> ExceptT StoreError IO User
createUserRecordAt :: Connection
-> AgentUserId
-> Profile
-> Bool
-> UTCTime
-> ExceptT StoreError IO User
createUserRecordAt Connection
db (AgentUserId UserId
auId) Profile {ContactName
displayName :: ContactName
displayName :: Profile -> ContactName
displayName, ContactName
fullName :: ContactName
fullName :: Profile -> ContactName
fullName, Maybe ContactName
shortDescr :: Maybe ContactName
shortDescr :: Profile -> Maybe ContactName
shortDescr, Maybe ImageData
image :: Maybe ImageData
image :: Profile -> Maybe ImageData
image, Maybe ChatPeerType
peerType :: Maybe ChatPeerType
peerType :: Profile -> Maybe ChatPeerType
peerType, preferences :: Profile -> Maybe Preferences
preferences = Maybe Preferences
userPreferences} Bool
activeUser UTCTime
currentTs =
  StoreError
-> ExceptT StoreError IO User -> ExceptT StoreError IO User
forall a.
StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a
checkConstraint StoreError
SEDuplicateName (ExceptT StoreError IO User -> ExceptT StoreError IO User)
-> (IO User -> ExceptT StoreError IO User)
-> IO User
-> ExceptT StoreError IO User
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO User -> ExceptT StoreError IO User
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO User -> ExceptT StoreError IO User)
-> IO User -> ExceptT StoreError IO User
forall a b. (a -> b) -> a -> b
$ do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
activeUser (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO ()
DB.execute_ Connection
db Query
"UPDATE users SET active_user = 0"
    let showNtfs :: Bool
showNtfs = Bool
True
        sendRcptsContacts :: Bool
sendRcptsContacts = Bool
True
        sendRcptsSmallGroups :: Bool
sendRcptsSmallGroups = Bool
True
        autoAcceptMemberContacts :: Bool
autoAcceptMemberContacts = Bool
False
    UserId
order <- Connection -> IO UserId
getNextActiveOrder Connection
db
    Connection
-> Query
-> (UserId, ContactName, BoolInt, UserId, BoolInt, BoolInt,
    BoolInt, BoolInt, UTCTime, UTCTime)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
      Connection
db
      Query
"INSERT INTO users (agent_user_id, local_display_name, active_user, active_order, contact_id, show_ntfs, send_rcpts_contacts, send_rcpts_small_groups, auto_accept_member_contacts, created_at, updated_at) VALUES (?,?,?,?,0,?,?,?,?,?,?)"
      (UserId
auId, ContactName
displayName, Bool -> BoolInt
BI Bool
activeUser, UserId
order, Bool -> BoolInt
BI Bool
showNtfs, Bool -> BoolInt
BI Bool
sendRcptsContacts, Bool -> BoolInt
BI Bool
sendRcptsSmallGroups, Bool -> BoolInt
BI Bool
autoAcceptMemberContacts, UTCTime
currentTs, UTCTime
currentTs)
    UserId
userId <- Connection -> IO UserId
insertedRowId Connection
db
    Connection
-> Query
-> (ContactName, ContactName, UserId, UTCTime, UTCTime)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
      Connection
db
      Query
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
      (ContactName
displayName, ContactName
displayName, UserId
userId, UTCTime
currentTs, UTCTime
currentTs)
    Connection
-> Query
-> (ContactName, ContactName, Maybe ContactName, Maybe ImageData,
    Maybe ChatPeerType, UserId, 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, chat_peer_type, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
      (ContactName
displayName, ContactName
fullName, Maybe ContactName
shortDescr, Maybe ImageData
image, Maybe ChatPeerType
peerType, UserId
userId, Maybe Preferences
userPreferences, UTCTime
currentTs, UTCTime
currentTs)
    UserId
profileId <- Connection -> IO UserId
insertedRowId Connection
db
    Connection
-> Query
-> (UserId, ContactName, UserId, BoolInt, UTCTime, UTCTime,
    UTCTime)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
      Connection
db
      Query
"INSERT INTO contacts (contact_profile_id, local_display_name, user_id, is_user, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?)"
      (UserId
profileId, ContactName
displayName, UserId
userId, Bool -> BoolInt
BI Bool
True, UTCTime
currentTs, UTCTime
currentTs, UTCTime
currentTs)
    UserId
contactId <- Connection -> IO UserId
insertedRowId Connection
db
    Connection -> Query -> (UserId, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"UPDATE users SET contact_id = ? WHERE user_id = ?" (UserId
contactId, UserId
userId)
    User -> IO User
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (User -> IO User) -> User -> IO User
forall a b. (a -> b) -> a -> b
$ ((UserId, UserId, UserId, UserId, BoolInt, UserId)
 :. ((ContactName, ContactName, Maybe ContactName, 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)
  :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
       Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
      :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
          Maybe B64UrlByteString, Maybe UTCTime,
          Maybe UIThemeEntityOverrides)))
 -> User)
-> ((UserId, UserId, UserId, UserId, BoolInt, UserId)
    :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
         Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
        :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
            Maybe B64UrlByteString, Maybe UTCTime,
            Maybe UIThemeEntityOverrides)))
-> User
forall a b. (a -> b) -> a -> b
$ (UserId
userId, UserId
auId, UserId
contactId, UserId
profileId, Bool -> BoolInt
BI Bool
activeUser, UserId
order) (UserId, UserId, UserId, UserId, BoolInt, UserId)
-> ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
     Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
    :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
        Maybe B64UrlByteString, Maybe UTCTime,
        Maybe UIThemeEntityOverrides))
-> (UserId, UserId, UserId, UserId, BoolInt, UserId)
   :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
        Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
       :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
           Maybe B64UrlByteString, Maybe UTCTime,
           Maybe UIThemeEntityOverrides))
forall h t. h -> t -> h :. t
:. (ContactName
displayName, ContactName
fullName, Maybe ContactName
shortDescr, Maybe ImageData
image, Maybe ConnLinkContact
forall a. Maybe a
Nothing, Maybe ChatPeerType
peerType, Maybe Preferences
userPreferences) (ContactName, ContactName, Maybe ContactName, Maybe ImageData,
 Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
-> (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
    Maybe B64UrlByteString, Maybe UTCTime,
    Maybe UIThemeEntityOverrides)
-> (ContactName, ContactName, Maybe ContactName, Maybe ImageData,
    Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
   :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
       Maybe B64UrlByteString, Maybe UTCTime,
       Maybe UIThemeEntityOverrides)
forall h t. h -> t -> h :. t
:. (Bool -> BoolInt
BI Bool
showNtfs, Bool -> BoolInt
BI Bool
sendRcptsContacts, Bool -> BoolInt
BI Bool
sendRcptsSmallGroups, Bool -> BoolInt
BI Bool
autoAcceptMemberContacts, Maybe B64UrlByteString
forall a. Maybe a
Nothing, Maybe B64UrlByteString
forall a. Maybe a
Nothing, Maybe UTCTime
forall a. Maybe a
Nothing, Maybe UIThemeEntityOverrides
forall a. Maybe a
Nothing)

-- TODO [mentions]
getUsersInfo :: DB.Connection -> IO [UserInfo]
getUsersInfo :: Connection -> IO [UserInfo]
getUsersInfo Connection
db = Connection -> IO [User]
getUsers Connection
db IO [User] -> ([User] -> IO [UserInfo]) -> IO [UserInfo]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (User -> IO UserInfo) -> [User] -> IO [UserInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM User -> IO UserInfo
getUserInfo
  where
    getUserInfo :: User -> IO UserInfo
    getUserInfo :: User -> IO UserInfo
getUserInfo user :: User
user@User {UserId
userId :: UserId
userId :: User -> UserId
userId} = do
      Maybe Int
ctCount <-
        (Only Int -> Int) -> IO [Only Int] -> IO (Maybe Int)
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow Only Int -> Int
forall a. Only a -> a
fromOnly (IO [Only Int] -> IO (Maybe Int))
-> IO [Only Int] -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$
          Connection -> Query -> (UserId, CIStatus 'MDRcv) -> IO [Only Int]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
            Connection
db
            [sql|
              SELECT COUNT(1)
              FROM chat_items i
              JOIN contacts ct USING (contact_id)
              WHERE i.user_id = ? AND i.item_status = ? AND (ct.enable_ntfs = 1 OR ct.enable_ntfs IS NULL) AND ct.deleted = 0
            |]
            (UserId
userId, CIStatus 'MDRcv
CISRcvNew)
      Maybe Int
gCount <-
        (Only Int -> Int) -> IO [Only Int] -> IO (Maybe Int)
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow Only Int -> Int
forall a. Only a -> a
fromOnly (IO [Only Int] -> IO (Maybe Int))
-> IO [Only Int] -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$
          Connection -> Query -> (UserId, CIStatus 'MDRcv) -> IO [Only Int]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
            Connection
db
            [sql|
              SELECT COUNT(1)
              FROM chat_items i
              JOIN groups g USING (group_id)
              WHERE i.user_id = ? AND i.item_status = ?
                AND (g.enable_ntfs = 1 OR g.enable_ntfs IS NULL OR (g.enable_ntfs = 2 AND i.user_mention = 1))
            |]
            (UserId
userId, CIStatus 'MDRcv
CISRcvNew)
      UserInfo -> IO UserInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserInfo {User
user :: User
user :: User
user, unreadCount :: Int
unreadCount = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
ctCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
gCount}

getUsers :: DB.Connection -> IO [User]
getUsers :: Connection -> IO [User]
getUsers Connection
db =
  (((UserId, UserId, UserId, UserId, BoolInt, UserId)
  :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
       Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
      :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
          Maybe B64UrlByteString, Maybe UTCTime,
          Maybe UIThemeEntityOverrides)))
 -> User)
-> [(UserId, UserId, UserId, UserId, BoolInt, UserId)
    :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
         Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
        :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
            Maybe B64UrlByteString, Maybe UTCTime,
            Maybe UIThemeEntityOverrides))]
-> [User]
forall a b. (a -> b) -> [a] -> [b]
map ((UserId, UserId, UserId, UserId, BoolInt, UserId)
 :. ((ContactName, ContactName, Maybe ContactName, 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)
  :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
       Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
      :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
          Maybe B64UrlByteString, Maybe UTCTime,
          Maybe UIThemeEntityOverrides))]
 -> [User])
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> IO [User]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> Query
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
forall r. FromRow r => Connection -> Query -> IO [r]
DB.query_ Connection
db Query
userQuery

setActiveUser :: DB.Connection -> User -> IO User
setActiveUser :: Connection -> User -> IO User
setActiveUser Connection
db user :: User
user@User {UserId
userId :: User -> UserId
userId :: UserId
userId} = do
  Connection -> Query -> IO ()
DB.execute_ Connection
db Query
"UPDATE users SET active_user = 0"
  UserId
activeOrder <- Connection -> IO UserId
getNextActiveOrder Connection
db
  Connection -> Query -> (UserId, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"UPDATE users SET active_user = 1, active_order = ? WHERE user_id = ?" (UserId
activeOrder, UserId
userId)
  User -> IO User
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure User
user {activeUser = True, activeOrder}

getNextActiveOrder :: DB.Connection -> IO Int64
getNextActiveOrder :: Connection -> IO UserId
getNextActiveOrder Connection
db = do
  UserId
order <- UserId -> Maybe UserId -> UserId
forall a. a -> Maybe a -> a
fromMaybe UserId
0 (Maybe UserId -> UserId)
-> (Maybe (Maybe UserId) -> Maybe UserId)
-> Maybe (Maybe UserId)
-> UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Maybe UserId) -> Maybe UserId
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe UserId) -> UserId)
-> IO (Maybe (Maybe UserId)) -> IO UserId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Only (Maybe UserId) -> Maybe UserId)
-> IO [Only (Maybe UserId)] -> IO (Maybe (Maybe UserId))
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow Only (Maybe UserId) -> Maybe UserId
forall a. Only a -> a
fromOnly (Connection -> Query -> IO [Only (Maybe UserId)]
forall r. FromRow r => Connection -> Query -> IO [r]
DB.query_ Connection
db Query
"SELECT max(active_order) FROM users")
  if UserId
order UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
== UserId
forall a. Bounded a => a
maxBound
    then UserId
0 UserId -> IO () -> IO UserId
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Connection -> Query -> Only UserId -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"UPDATE users SET active_order = active_order - ?" (UserId -> Only UserId
forall a. a -> Only a
Only (UserId
forall a. Bounded a => a
maxBound :: Int64))
    else UserId -> IO UserId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserId -> IO UserId) -> UserId -> IO UserId
forall a b. (a -> b) -> a -> b
$ UserId
order UserId -> UserId -> UserId
forall a. Num a => a -> a -> a
+ UserId
1

getUser :: DB.Connection -> UserId -> ExceptT StoreError IO User
getUser :: Connection -> UserId -> ExceptT StoreError IO User
getUser Connection
db UserId
userId =
  IO (Either StoreError User) -> ExceptT StoreError IO User
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError User) -> ExceptT StoreError IO User)
-> (IO
      [(UserId, UserId, UserId, UserId, BoolInt, UserId)
       :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
            Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
           :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
               Maybe B64UrlByteString, Maybe UTCTime,
               Maybe UIThemeEntityOverrides))]
    -> IO (Either StoreError User))
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> ExceptT StoreError IO User
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((UserId, UserId, UserId, UserId, BoolInt, UserId)
  :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
       Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
      :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
          Maybe B64UrlByteString, Maybe UTCTime,
          Maybe UIThemeEntityOverrides)))
 -> User)
-> StoreError
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> IO (Either StoreError User)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow ((UserId, UserId, UserId, UserId, BoolInt, UserId)
 :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
      Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
     :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
         Maybe B64UrlByteString, Maybe UTCTime,
         Maybe UIThemeEntityOverrides)))
-> User
toUser (UserId -> StoreError
SEUserNotFound UserId
userId) (IO
   [(UserId, UserId, UserId, UserId, BoolInt, UserId)
    :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
         Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
        :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
            Maybe B64UrlByteString, Maybe UTCTime,
            Maybe UIThemeEntityOverrides))]
 -> ExceptT StoreError IO User)
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> ExceptT StoreError IO User
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only UserId
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
userQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" WHERE u.user_id = ?") (UserId -> Only UserId
forall a. a -> Only a
Only UserId
userId)

getUserIdByName :: DB.Connection -> UserName -> ExceptT StoreError IO Int64
getUserIdByName :: Connection -> ContactName -> ExceptT StoreError IO UserId
getUserIdByName Connection
db ContactName
uName =
  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)
-> (IO [Only UserId] -> IO (Either StoreError UserId))
-> IO [Only UserId]
-> ExceptT StoreError IO UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Only UserId -> UserId)
-> StoreError -> IO [Only UserId] -> IO (Either StoreError UserId)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow Only UserId -> UserId
forall a. Only a -> a
fromOnly (ContactName -> StoreError
SEUserNotFoundByName ContactName
uName) (IO [Only UserId] -> ExceptT StoreError IO UserId)
-> IO [Only UserId] -> ExceptT StoreError IO UserId
forall a b. (a -> b) -> a -> b
$
    Connection -> Query -> Only ContactName -> IO [Only UserId]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db Query
"SELECT user_id FROM users WHERE local_display_name = ?" (ContactName -> Only ContactName
forall a. a -> Only a
Only ContactName
uName)

getUserByAConnId :: DB.Connection -> AgentConnId -> IO (Maybe User)
getUserByAConnId :: Connection -> AgentConnId -> IO (Maybe User)
getUserByAConnId Connection
db AgentConnId
agentConnId =
  (((UserId, UserId, UserId, UserId, BoolInt, UserId)
  :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
       Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
      :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
          Maybe B64UrlByteString, Maybe UTCTime,
          Maybe UIThemeEntityOverrides)))
 -> User)
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> IO (Maybe User)
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow ((UserId, UserId, UserId, UserId, BoolInt, UserId)
 :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
      Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
     :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
         Maybe B64UrlByteString, Maybe UTCTime,
         Maybe UIThemeEntityOverrides)))
-> User
toUser (IO
   [(UserId, UserId, UserId, UserId, BoolInt, UserId)
    :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
         Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
        :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
            Maybe B64UrlByteString, Maybe UTCTime,
            Maybe UIThemeEntityOverrides))]
 -> IO (Maybe User))
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> IO (Maybe User)
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only AgentConnId
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
userQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" JOIN connections c ON c.user_id = u.user_id WHERE c.agent_conn_id = ?") (AgentConnId -> Only AgentConnId
forall a. a -> Only a
Only AgentConnId
agentConnId)

getUserByASndFileId :: DB.Connection -> AgentSndFileId -> IO (Maybe User)
getUserByASndFileId :: Connection -> AgentSndFileId -> IO (Maybe User)
getUserByASndFileId Connection
db AgentSndFileId
aSndFileId =
  (((UserId, UserId, UserId, UserId, BoolInt, UserId)
  :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
       Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
      :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
          Maybe B64UrlByteString, Maybe UTCTime,
          Maybe UIThemeEntityOverrides)))
 -> User)
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> IO (Maybe User)
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow ((UserId, UserId, UserId, UserId, BoolInt, UserId)
 :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
      Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
     :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
         Maybe B64UrlByteString, Maybe UTCTime,
         Maybe UIThemeEntityOverrides)))
-> User
toUser (IO
   [(UserId, UserId, UserId, UserId, BoolInt, UserId)
    :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
         Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
        :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
            Maybe B64UrlByteString, Maybe UTCTime,
            Maybe UIThemeEntityOverrides))]
 -> IO (Maybe User))
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> IO (Maybe User)
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only AgentSndFileId
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
userQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" JOIN files f ON f.user_id = u.user_id WHERE f.agent_snd_file_id = ?") (AgentSndFileId -> Only AgentSndFileId
forall a. a -> Only a
Only AgentSndFileId
aSndFileId)

getUserByARcvFileId :: DB.Connection -> AgentRcvFileId -> IO (Maybe User)
getUserByARcvFileId :: Connection -> AgentRcvFileId -> IO (Maybe User)
getUserByARcvFileId Connection
db AgentRcvFileId
aRcvFileId =
  (((UserId, UserId, UserId, UserId, BoolInt, UserId)
  :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
       Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
      :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
          Maybe B64UrlByteString, Maybe UTCTime,
          Maybe UIThemeEntityOverrides)))
 -> User)
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> IO (Maybe User)
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow ((UserId, UserId, UserId, UserId, BoolInt, UserId)
 :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
      Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
     :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
         Maybe B64UrlByteString, Maybe UTCTime,
         Maybe UIThemeEntityOverrides)))
-> User
toUser (IO
   [(UserId, UserId, UserId, UserId, BoolInt, UserId)
    :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
         Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
        :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
            Maybe B64UrlByteString, Maybe UTCTime,
            Maybe UIThemeEntityOverrides))]
 -> IO (Maybe User))
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> IO (Maybe User)
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only AgentRcvFileId
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
userQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" JOIN files f ON f.user_id = u.user_id JOIN rcv_files r ON r.file_id = f.file_id WHERE r.agent_rcv_file_id = ?") (AgentRcvFileId -> Only AgentRcvFileId
forall a. a -> Only a
Only AgentRcvFileId
aRcvFileId)

getUserByContactId :: DB.Connection -> ContactId -> ExceptT StoreError IO User
getUserByContactId :: Connection -> UserId -> ExceptT StoreError IO User
getUserByContactId Connection
db UserId
contactId =
  IO (Either StoreError User) -> ExceptT StoreError IO User
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError User) -> ExceptT StoreError IO User)
-> (IO
      [(UserId, UserId, UserId, UserId, BoolInt, UserId)
       :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
            Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
           :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
               Maybe B64UrlByteString, Maybe UTCTime,
               Maybe UIThemeEntityOverrides))]
    -> IO (Either StoreError User))
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> ExceptT StoreError IO User
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((UserId, UserId, UserId, UserId, BoolInt, UserId)
  :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
       Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
      :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
          Maybe B64UrlByteString, Maybe UTCTime,
          Maybe UIThemeEntityOverrides)))
 -> User)
-> StoreError
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> IO (Either StoreError User)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow ((UserId, UserId, UserId, UserId, BoolInt, UserId)
 :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
      Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
     :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
         Maybe B64UrlByteString, Maybe UTCTime,
         Maybe UIThemeEntityOverrides)))
-> User
toUser (UserId -> StoreError
SEUserNotFoundByContactId UserId
contactId) (IO
   [(UserId, UserId, UserId, UserId, BoolInt, UserId)
    :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
         Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
        :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
            Maybe B64UrlByteString, Maybe UTCTime,
            Maybe UIThemeEntityOverrides))]
 -> ExceptT StoreError IO User)
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> ExceptT StoreError IO User
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only UserId
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
userQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" JOIN contacts ct ON ct.user_id = u.user_id WHERE ct.contact_id = ? AND ct.deleted = 0") (UserId -> Only UserId
forall a. a -> Only a
Only UserId
contactId)

getUserByGroupId :: DB.Connection -> GroupId -> ExceptT StoreError IO User
getUserByGroupId :: Connection -> UserId -> ExceptT StoreError IO User
getUserByGroupId Connection
db UserId
groupId =
  IO (Either StoreError User) -> ExceptT StoreError IO User
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError User) -> ExceptT StoreError IO User)
-> (IO
      [(UserId, UserId, UserId, UserId, BoolInt, UserId)
       :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
            Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
           :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
               Maybe B64UrlByteString, Maybe UTCTime,
               Maybe UIThemeEntityOverrides))]
    -> IO (Either StoreError User))
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> ExceptT StoreError IO User
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((UserId, UserId, UserId, UserId, BoolInt, UserId)
  :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
       Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
      :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
          Maybe B64UrlByteString, Maybe UTCTime,
          Maybe UIThemeEntityOverrides)))
 -> User)
-> StoreError
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> IO (Either StoreError User)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow ((UserId, UserId, UserId, UserId, BoolInt, UserId)
 :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
      Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
     :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
         Maybe B64UrlByteString, Maybe UTCTime,
         Maybe UIThemeEntityOverrides)))
-> User
toUser (UserId -> StoreError
SEUserNotFoundByGroupId UserId
groupId) (IO
   [(UserId, UserId, UserId, UserId, BoolInt, UserId)
    :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
         Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
        :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
            Maybe B64UrlByteString, Maybe UTCTime,
            Maybe UIThemeEntityOverrides))]
 -> ExceptT StoreError IO User)
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> ExceptT StoreError IO User
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only UserId
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
userQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" JOIN groups g ON g.user_id = u.user_id WHERE g.group_id = ?") (UserId -> Only UserId
forall a. a -> Only a
Only UserId
groupId)

getUserByNoteFolderId :: DB.Connection -> NoteFolderId -> ExceptT StoreError IO User
getUserByNoteFolderId :: Connection -> UserId -> ExceptT StoreError IO User
getUserByNoteFolderId Connection
db UserId
contactId =
  IO (Either StoreError User) -> ExceptT StoreError IO User
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError User) -> ExceptT StoreError IO User)
-> (IO
      [(UserId, UserId, UserId, UserId, BoolInt, UserId)
       :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
            Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
           :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
               Maybe B64UrlByteString, Maybe UTCTime,
               Maybe UIThemeEntityOverrides))]
    -> IO (Either StoreError User))
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> ExceptT StoreError IO User
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((UserId, UserId, UserId, UserId, BoolInt, UserId)
  :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
       Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
      :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
          Maybe B64UrlByteString, Maybe UTCTime,
          Maybe UIThemeEntityOverrides)))
 -> User)
-> StoreError
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> IO (Either StoreError User)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow ((UserId, UserId, UserId, UserId, BoolInt, UserId)
 :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
      Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
     :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
         Maybe B64UrlByteString, Maybe UTCTime,
         Maybe UIThemeEntityOverrides)))
-> User
toUser (UserId -> StoreError
SEUserNotFoundByContactId UserId
contactId) (IO
   [(UserId, UserId, UserId, UserId, BoolInt, UserId)
    :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
         Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
        :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
            Maybe B64UrlByteString, Maybe UTCTime,
            Maybe UIThemeEntityOverrides))]
 -> ExceptT StoreError IO User)
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> ExceptT StoreError IO User
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only UserId
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
userQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" JOIN note_folders nf ON nf.user_id = u.user_id WHERE nf.note_folder_id = ?") (UserId -> Only UserId
forall a. a -> Only a
Only UserId
contactId)

getUserByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO User
getUserByFileId :: Connection -> UserId -> ExceptT StoreError IO User
getUserByFileId Connection
db UserId
fileId =
  IO (Either StoreError User) -> ExceptT StoreError IO User
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError User) -> ExceptT StoreError IO User)
-> (IO
      [(UserId, UserId, UserId, UserId, BoolInt, UserId)
       :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
            Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
           :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
               Maybe B64UrlByteString, Maybe UTCTime,
               Maybe UIThemeEntityOverrides))]
    -> IO (Either StoreError User))
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> ExceptT StoreError IO User
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((UserId, UserId, UserId, UserId, BoolInt, UserId)
  :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
       Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
      :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
          Maybe B64UrlByteString, Maybe UTCTime,
          Maybe UIThemeEntityOverrides)))
 -> User)
-> StoreError
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> IO (Either StoreError User)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow ((UserId, UserId, UserId, UserId, BoolInt, UserId)
 :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
      Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
     :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
         Maybe B64UrlByteString, Maybe UTCTime,
         Maybe UIThemeEntityOverrides)))
-> User
toUser (UserId -> StoreError
SEUserNotFoundByFileId UserId
fileId) (IO
   [(UserId, UserId, UserId, UserId, BoolInt, UserId)
    :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
         Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
        :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
            Maybe B64UrlByteString, Maybe UTCTime,
            Maybe UIThemeEntityOverrides))]
 -> ExceptT StoreError IO User)
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
-> ExceptT StoreError IO User
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only UserId
-> IO
     [(UserId, UserId, UserId, UserId, BoolInt, UserId)
      :. ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
           Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
          :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString,
              Maybe B64UrlByteString, Maybe UTCTime,
              Maybe UIThemeEntityOverrides))]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
userQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" JOIN files f ON f.user_id = u.user_id WHERE f.file_id = ?") (UserId -> Only UserId
forall a. a -> Only a
Only UserId
fileId)

getUserFileInfo :: DB.Connection -> User -> IO [CIFileInfo]
getUserFileInfo :: Connection -> User -> IO [CIFileInfo]
getUserFileInfo Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} =
  ((UserId, Maybe ACIFileStatus, Maybe FilePath) -> CIFileInfo)
-> [(UserId, Maybe ACIFileStatus, Maybe FilePath)] -> [CIFileInfo]
forall a b. (a -> b) -> [a] -> [b]
map (UserId, Maybe ACIFileStatus, Maybe FilePath) -> CIFileInfo
toFileInfo
    ([(UserId, Maybe ACIFileStatus, Maybe FilePath)] -> [CIFileInfo])
-> IO [(UserId, Maybe ACIFileStatus, Maybe FilePath)]
-> IO [CIFileInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> Query
-> Only UserId
-> IO [(UserId, Maybe ACIFileStatus, Maybe FilePath)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
fileInfoQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" WHERE i.user_id = ?") (UserId -> Only UserId
forall a. a -> Only a
Only UserId
userId)

deleteUserRecord :: DB.Connection -> User -> IO ()
deleteUserRecord :: Connection -> User -> IO ()
deleteUserRecord Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} =
  Connection -> Query -> Only UserId -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"DELETE FROM users WHERE user_id = ?" (UserId -> Only UserId
forall a. a -> Only a
Only UserId
userId)

updateUserPrivacy :: DB.Connection -> User -> IO ()
updateUserPrivacy :: Connection -> User -> IO ()
updateUserPrivacy Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId, Bool
showNtfs :: Bool
showNtfs :: User -> Bool
showNtfs, Maybe UserPwdHash
viewPwdHash :: Maybe UserPwdHash
viewPwdHash :: User -> Maybe UserPwdHash
viewPwdHash} =
  Connection
-> Query
-> ((Maybe B64UrlByteString, Maybe B64UrlByteString)
    :. (BoolInt, UserId))
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE users
      SET view_pwd_hash = ?, view_pwd_salt = ?, show_ntfs = ?
      WHERE user_id = ?
    |]
    (Maybe UserPwdHash
-> (Maybe B64UrlByteString, Maybe B64UrlByteString)
hashSalt Maybe UserPwdHash
viewPwdHash (Maybe B64UrlByteString, Maybe B64UrlByteString)
-> (BoolInt, UserId)
-> (Maybe B64UrlByteString, Maybe B64UrlByteString)
   :. (BoolInt, UserId)
forall h t. h -> t -> h :. t
:. (Bool -> BoolInt
BI Bool
showNtfs, UserId
userId))
  where
    hashSalt :: Maybe UserPwdHash
-> (Maybe B64UrlByteString, Maybe B64UrlByteString)
hashSalt = Maybe (B64UrlByteString, B64UrlByteString)
-> (Maybe B64UrlByteString, Maybe B64UrlByteString)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
L.unzip (Maybe (B64UrlByteString, B64UrlByteString)
 -> (Maybe B64UrlByteString, Maybe B64UrlByteString))
-> (Maybe UserPwdHash
    -> Maybe (B64UrlByteString, B64UrlByteString))
-> Maybe UserPwdHash
-> (Maybe B64UrlByteString, Maybe B64UrlByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserPwdHash -> (B64UrlByteString, B64UrlByteString))
-> Maybe UserPwdHash -> Maybe (B64UrlByteString, B64UrlByteString)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\UserPwdHash {B64UrlByteString
hash :: B64UrlByteString
hash :: UserPwdHash -> B64UrlByteString
hash, B64UrlByteString
salt :: B64UrlByteString
salt :: UserPwdHash -> B64UrlByteString
salt} -> (B64UrlByteString
hash, B64UrlByteString
salt))

updateAllContactReceipts :: DB.Connection -> Bool -> IO ()
updateAllContactReceipts :: Connection -> Bool -> IO ()
updateAllContactReceipts Connection
db Bool
onOff =
  Connection -> Query -> (BoolInt, BoolInt) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    Query
"UPDATE users SET send_rcpts_contacts = ?, send_rcpts_small_groups = ? WHERE view_pwd_hash IS NULL"
    (Bool -> BoolInt
BI Bool
onOff, Bool -> BoolInt
BI Bool
onOff)

updateUserContactReceipts :: DB.Connection -> User -> UserMsgReceiptSettings -> IO ()
updateUserContactReceipts :: Connection -> User -> UserMsgReceiptSettings -> IO ()
updateUserContactReceipts Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} UserMsgReceiptSettings {Bool
enable :: Bool
enable :: UserMsgReceiptSettings -> Bool
enable, Bool
clearOverrides :: Bool
clearOverrides :: UserMsgReceiptSettings -> Bool
clearOverrides} = do
  Connection -> Query -> (BoolInt, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"UPDATE users SET send_rcpts_contacts = ? WHERE user_id = ?" (Bool -> BoolInt
BI Bool
enable, UserId
userId)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
clearOverrides (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO ()
DB.execute_ Connection
db Query
"UPDATE contacts SET send_rcpts = NULL"

updateUserGroupReceipts :: DB.Connection -> User -> UserMsgReceiptSettings -> IO ()
updateUserGroupReceipts :: Connection -> User -> UserMsgReceiptSettings -> IO ()
updateUserGroupReceipts Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} UserMsgReceiptSettings {Bool
enable :: UserMsgReceiptSettings -> Bool
enable :: Bool
enable, Bool
clearOverrides :: UserMsgReceiptSettings -> Bool
clearOverrides :: Bool
clearOverrides} = do
  Connection -> Query -> (BoolInt, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"UPDATE users SET send_rcpts_small_groups = ? WHERE user_id = ?" (Bool -> BoolInt
BI Bool
enable, UserId
userId)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
clearOverrides (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO ()
DB.execute_ Connection
db Query
"UPDATE groups SET send_rcpts = NULL"

updateUserAutoAcceptMemberContacts :: DB.Connection -> User -> Bool -> IO ()
updateUserAutoAcceptMemberContacts :: Connection -> User -> Bool -> IO ()
updateUserAutoAcceptMemberContacts Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} Bool
autoAccept =
  Connection -> Query -> (BoolInt, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"UPDATE users SET auto_accept_member_contacts = ? WHERE user_id = ?" (Bool -> BoolInt
BI Bool
autoAccept, UserId
userId)

updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User
updateUserProfile :: Connection -> User -> Profile -> ExceptT StoreError IO User
updateUserProfile Connection
db User
user Profile
p'
  | ContactName
displayName ContactName -> ContactName -> Bool
forall a. Eq a => a -> a -> Bool
== ContactName
newName = IO User -> ExceptT StoreError IO User
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO User -> ExceptT StoreError IO User)
-> IO User -> ExceptT StoreError IO User
forall a b. (a -> b) -> a -> b
$ do
      Connection -> UserId -> UserId -> Profile -> IO ()
updateContactProfile_ Connection
db UserId
userId UserId
profileId Profile
p'
      UTCTime
currentTs <- IO UTCTime
getCurrentTime
      Maybe UTCTime
userMemberProfileUpdatedAt' <- UTCTime -> IO (Maybe UTCTime)
updateUserMemberProfileUpdatedAt_ UTCTime
currentTs
      User -> IO User
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure User
user {profile, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
  | Bool
otherwise =
      StoreError
-> ExceptT StoreError IO User -> ExceptT StoreError IO User
forall a.
StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a
checkConstraint StoreError
SEDuplicateName (ExceptT StoreError IO User -> ExceptT StoreError IO User)
-> (IO User -> ExceptT StoreError IO User)
-> IO User
-> ExceptT StoreError IO User
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO User -> ExceptT StoreError IO User
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO User -> ExceptT StoreError IO User)
-> IO User -> ExceptT StoreError IO User
forall a b. (a -> b) -> a -> b
$ do
        UTCTime
currentTs <- IO UTCTime
getCurrentTime
        Connection -> Query -> (ContactName, UTCTime, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (ContactName
newName, UTCTime
currentTs, UserId
userId)
        Maybe UTCTime
userMemberProfileUpdatedAt' <- UTCTime -> IO (Maybe UTCTime)
updateUserMemberProfileUpdatedAt_ UTCTime
currentTs
        Connection
-> Query
-> (ContactName, ContactName, UserId, UTCTime, UTCTime)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
          Connection
db
          Query
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
          (ContactName
newName, ContactName
newName, UserId
userId, UTCTime
currentTs, UTCTime
currentTs)
        Connection -> UserId -> UserId -> Profile -> UTCTime -> IO ()
updateContactProfile_' Connection
db UserId
userId UserId
profileId Profile
p' UTCTime
currentTs
        Connection
-> User -> UserId -> ContactName -> ContactName -> UTCTime -> IO ()
updateContactLDN_ Connection
db User
user UserId
userContactId ContactName
localDisplayName ContactName
newName UTCTime
currentTs
        User -> IO User
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure User
user {localDisplayName = newName, profile, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
  where
    updateUserMemberProfileUpdatedAt_ :: UTCTime -> IO (Maybe UTCTime)
updateUserMemberProfileUpdatedAt_ UTCTime
currentTs
      | Bool
userMemberProfileChanged = do
          Connection -> Query -> (UTCTime, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"UPDATE users SET user_member_profile_updated_at = ? WHERE user_id = ?" (UTCTime
currentTs, UserId
userId)
          Maybe UTCTime -> IO (Maybe UTCTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UTCTime -> IO (Maybe UTCTime))
-> Maybe UTCTime -> IO (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
currentTs
      | Bool
otherwise = Maybe UTCTime -> IO (Maybe UTCTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UTCTime
userMemberProfileUpdatedAt
    userMemberProfileChanged :: Bool
userMemberProfileChanged = ContactName
newName ContactName -> ContactName -> Bool
forall a. Eq a => a -> a -> Bool
/= ContactName
displayName Bool -> Bool -> Bool
|| ContactName
fn' ContactName -> ContactName -> Bool
forall a. Eq a => a -> a -> Bool
/= ContactName
fullName Bool -> Bool -> Bool
|| Maybe ContactName
d' Maybe ContactName -> Maybe ContactName -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ContactName
shortDescr Bool -> Bool -> Bool
|| Maybe ImageData
img' Maybe ImageData -> Maybe ImageData -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ImageData
image
    User {UserId
userId :: User -> UserId
userId :: UserId
userId, UserId
userContactId :: UserId
userContactId :: User -> UserId
userContactId, ContactName
localDisplayName :: ContactName
localDisplayName :: User -> ContactName
localDisplayName, profile :: User -> LocalProfile
profile = LocalProfile {UserId
profileId :: UserId
profileId :: LocalProfile -> UserId
profileId, ContactName
displayName :: ContactName
displayName :: LocalProfile -> ContactName
displayName, ContactName
fullName :: ContactName
fullName :: LocalProfile -> ContactName
fullName, Maybe ContactName
shortDescr :: Maybe ContactName
shortDescr :: LocalProfile -> Maybe ContactName
shortDescr, Maybe ImageData
image :: Maybe ImageData
image :: LocalProfile -> Maybe ImageData
image, ContactName
localAlias :: ContactName
localAlias :: LocalProfile -> ContactName
localAlias}, Maybe UTCTime
userMemberProfileUpdatedAt :: User -> Maybe UTCTime
userMemberProfileUpdatedAt :: Maybe UTCTime
userMemberProfileUpdatedAt} = User
user
    Profile {displayName :: Profile -> ContactName
displayName = ContactName
newName, fullName :: Profile -> ContactName
fullName = ContactName
fn', shortDescr :: Profile -> Maybe ContactName
shortDescr = Maybe ContactName
d', image :: Profile -> Maybe ImageData
image = Maybe ImageData
img', Maybe Preferences
preferences :: Profile -> Maybe Preferences
preferences :: Maybe Preferences
preferences} = Profile
p'
    profile :: LocalProfile
profile = UserId -> Profile -> ContactName -> LocalProfile
toLocalProfile UserId
profileId Profile
p' ContactName
localAlias
    fullPreferences :: FullPreferences
fullPreferences = Maybe Preferences -> FullPreferences
fullPreferences' Maybe Preferences
preferences

setUserProfileContactLink :: DB.Connection -> User -> Maybe UserContactLink -> IO User
setUserProfileContactLink :: Connection -> User -> Maybe UserContactLink -> IO User
setUserProfileContactLink Connection
db user :: User
user@User {UserId
userId :: User -> UserId
userId :: UserId
userId, profile :: User -> LocalProfile
profile = p :: LocalProfile
p@LocalProfile {UserId
profileId :: LocalProfile -> UserId
profileId :: UserId
profileId}} Maybe UserContactLink
ucl_ = do
  UTCTime
ts <- IO UTCTime
getCurrentTime
  Connection
-> Query
-> (Maybe ConnLinkContact, UTCTime, UserId, UserId)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE contact_profiles
      SET contact_link = ?, updated_at = ?
      WHERE user_id = ? AND contact_profile_id = ?
    |]
    (Maybe ConnLinkContact
contactLink, UTCTime
ts, UserId
userId, UserId
profileId)
  User -> IO User
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (User
user :: User) {profile = p {contactLink}}
  where
    contactLink :: Maybe ConnLinkContact
contactLink = UserContactLink -> ConnLinkContact
profileContactLink (UserContactLink -> ConnLinkContact)
-> Maybe UserContactLink -> Maybe ConnLinkContact
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UserContactLink
ucl_

-- only used in tests
getUserContactProfiles :: DB.Connection -> User -> IO [Profile]
getUserContactProfiles :: Connection -> User -> IO [Profile]
getUserContactProfiles Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} =
  ((ContactName, ContactName, Maybe ContactName, Maybe ImageData,
  Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
 -> Profile)
-> [(ContactName, ContactName, Maybe ContactName, Maybe ImageData,
     Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)]
-> [Profile]
forall a b. (a -> b) -> [a] -> [b]
map (ContactName, ContactName, Maybe ContactName, Maybe ImageData,
 Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
-> Profile
toContactProfile
    ([(ContactName, ContactName, Maybe ContactName, Maybe ImageData,
   Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)]
 -> [Profile])
-> IO
     [(ContactName, ContactName, Maybe ContactName, Maybe ImageData,
       Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)]
-> IO [Profile]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> Query
-> Only UserId
-> IO
     [(ContactName, ContactName, Maybe ContactName, Maybe ImageData,
       Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
      Connection
db
      [sql|
        SELECT display_name, full_name, short_descr, image, contact_link, chat_peer_type, preferences
        FROM contact_profiles
        WHERE user_id = ?
      |]
      (UserId -> Only UserId
forall a. a -> Only a
Only UserId
userId)
  where
    toContactProfile :: (ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences) -> Profile
    toContactProfile :: (ContactName, ContactName, Maybe ContactName, Maybe ImageData,
 Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences)
-> Profile
toContactProfile (ContactName
displayName, ContactName
fullName, Maybe ContactName
shortDescr, Maybe ImageData
image, Maybe ConnLinkContact
contactLink, Maybe ChatPeerType
peerType, Maybe Preferences
preferences) = Profile {ContactName
displayName :: ContactName
displayName :: ContactName
displayName, ContactName
fullName :: ContactName
fullName :: ContactName
fullName, Maybe ContactName
shortDescr :: Maybe ContactName
shortDescr :: Maybe ContactName
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}

createUserContactLink :: DB.Connection -> User -> ConnId -> CreatedLinkContact -> SubscriptionMode -> ExceptT StoreError IO ()
createUserContactLink :: Connection
-> User
-> ConnId
-> CreatedLinkContact
-> SubscriptionMode
-> ExceptT StoreError IO ()
createUserContactLink Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} ConnId
agentConnId (CCLink ConnectionRequestUri 'CMContact
cReq Maybe (ConnShortLink 'CMContact)
shortLink) SubscriptionMode
subMode =
  StoreError -> ExceptT StoreError IO () -> ExceptT StoreError IO ()
forall a.
StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a
checkConstraint StoreError
SEDuplicateContactLink (ExceptT StoreError IO () -> ExceptT StoreError IO ())
-> (IO () -> ExceptT StoreError IO ())
-> IO ()
-> ExceptT StoreError IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
currentTs <- IO UTCTime
getCurrentTime
    let slDataSet :: BoolInt
slDataSet = Bool -> BoolInt
BI (Maybe (ConnShortLink 'CMContact) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (ConnShortLink 'CMContact)
shortLink)
    Connection
-> Query
-> (UserId, ConnectionRequestUri 'CMContact,
    Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, UTCTime,
    UTCTime)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
      Connection
db
      Query
"INSERT INTO user_contact_links (user_id, conn_req_contact, short_link_contact, short_link_data_set, short_link_large_data_set, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
      (UserId
userId, ConnectionRequestUri 'CMContact
cReq, Maybe (ConnShortLink 'CMContact)
shortLink, BoolInt
slDataSet, BoolInt
slDataSet, UTCTime
currentTs, UTCTime
currentTs)
    UserId
userContactLinkId <- Connection -> IO UserId
insertedRowId Connection
db
    IO Connection -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Connection -> IO ()) -> IO Connection -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection
-> UserId
-> ConnType
-> Maybe UserId
-> ConnId
-> ConnStatus
-> VersionChat
-> VersionRangeChat
-> Maybe UserId
-> Maybe UserId
-> Maybe UserId
-> Int
-> UTCTime
-> SubscriptionMode
-> PQSupport
-> IO Connection
createConnection_ Connection
db UserId
userId ConnType
ConnUserContact (UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
userContactLinkId) ConnId
agentConnId ConnStatus
ConnNew VersionChat
initialChatVersion VersionRangeChat
chatInitialVRange Maybe UserId
forall a. Maybe a
Nothing Maybe UserId
forall a. Maybe a
Nothing Maybe UserId
forall a. Maybe a
Nothing Int
0 UTCTime
currentTs SubscriptionMode
subMode PQSupport
CR.PQSupportOff

getUserAddressConnection :: DB.Connection -> VersionRangeChat -> User -> ExceptT StoreError IO Connection
getUserAddressConnection :: Connection
-> VersionRangeChat -> User -> ExceptT StoreError IO Connection
getUserAddressConnection Connection
db VersionRangeChat
vr User {UserId
userId :: User -> UserId
userId :: UserId
userId} = do
  IO (Either StoreError Connection)
-> ExceptT StoreError IO Connection
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError Connection)
 -> ExceptT StoreError IO Connection)
-> (IO [ConnectionRow] -> IO (Either StoreError Connection))
-> IO [ConnectionRow]
-> ExceptT StoreError IO Connection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConnectionRow -> Connection)
-> StoreError
-> IO [ConnectionRow]
-> IO (Either StoreError Connection)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow (VersionRangeChat -> ConnectionRow -> Connection
toConnection VersionRangeChat
vr) StoreError
SEUserContactLinkNotFound (IO [ConnectionRow] -> ExceptT StoreError IO Connection)
-> IO [ConnectionRow] -> ExceptT StoreError IO Connection
forall a b. (a -> b) -> a -> b
$
    Connection -> Query -> (UserId, UserId) -> IO [ConnectionRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
      Connection
db
      [sql|
        SELECT 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 connections c
        JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id
        WHERE c.user_id = ? AND uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL
      |]
      (UserId
userId, UserId
userId)

deleteUserAddress :: DB.Connection -> User -> IO ()
deleteUserAddress :: Connection -> User -> IO ()
deleteUserAddress Connection
db user :: User
user@User {UserId
userId :: User -> UserId
userId :: UserId
userId} = do
  Connection -> Query -> Only UserId -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      DELETE FROM connections WHERE connection_id IN (
        SELECT connection_id
        FROM connections c
        JOIN user_contact_links uc USING (user_contact_link_id)
        WHERE uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL
      )
    |]
    (UserId -> Only UserId
forall a. a -> Only a
Only UserId
userId)
  IO User -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO User -> IO ()) -> IO User -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> User -> Maybe UserContactLink -> IO User
setUserProfileContactLink Connection
db User
user Maybe UserContactLink
forall a. Maybe a
Nothing
  Connection -> Query -> Only UserId -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL" (UserId -> Only UserId
forall a. a -> Only a
Only UserId
userId)

data UserMsgReceiptSettings = UserMsgReceiptSettings
  { UserMsgReceiptSettings -> Bool
enable :: Bool,
    UserMsgReceiptSettings -> Bool
clearOverrides :: Bool
  }
  deriving (Int -> UserMsgReceiptSettings -> ShowS
[UserMsgReceiptSettings] -> ShowS
UserMsgReceiptSettings -> FilePath
(Int -> UserMsgReceiptSettings -> ShowS)
-> (UserMsgReceiptSettings -> FilePath)
-> ([UserMsgReceiptSettings] -> ShowS)
-> Show UserMsgReceiptSettings
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserMsgReceiptSettings -> ShowS
showsPrec :: Int -> UserMsgReceiptSettings -> ShowS
$cshow :: UserMsgReceiptSettings -> FilePath
show :: UserMsgReceiptSettings -> FilePath
$cshowList :: [UserMsgReceiptSettings] -> ShowS
showList :: [UserMsgReceiptSettings] -> ShowS
Show)

data UserContactLink = UserContactLink
  { UserContactLink -> UserId
userContactLinkId :: Int64,
    UserContactLink -> CreatedLinkContact
connLinkContact :: CreatedLinkContact,
    UserContactLink -> Bool
shortLinkDataSet :: Bool,
    UserContactLink -> BoolDef
shortLinkLargeDataSet :: BoolDef,
    UserContactLink -> AddressSettings
addressSettings :: AddressSettings
  }
  deriving (Int -> UserContactLink -> ShowS
[UserContactLink] -> ShowS
UserContactLink -> FilePath
(Int -> UserContactLink -> ShowS)
-> (UserContactLink -> FilePath)
-> ([UserContactLink] -> ShowS)
-> Show UserContactLink
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserContactLink -> ShowS
showsPrec :: Int -> UserContactLink -> ShowS
$cshow :: UserContactLink -> FilePath
show :: UserContactLink -> FilePath
$cshowList :: [UserContactLink] -> ShowS
showList :: [UserContactLink] -> ShowS
Show)

profileContactLink :: UserContactLink -> ConnLinkContact
profileContactLink :: UserContactLink -> ConnLinkContact
profileContactLink UserContactLink {connLinkContact :: UserContactLink -> CreatedLinkContact
connLinkContact = CCLink ConnectionRequestUri 'CMContact
cReq Maybe (ConnShortLink 'CMContact)
sLink} = ConnLinkContact
-> (ConnShortLink 'CMContact -> ConnLinkContact)
-> Maybe (ConnShortLink 'CMContact)
-> ConnLinkContact
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ConnectionRequestUri 'CMContact -> ConnLinkContact
forall (m :: ConnectionMode).
ConnectionRequestUri m -> ConnectionLink m
CLFull ConnectionRequestUri 'CMContact
cReq) ConnShortLink 'CMContact -> ConnLinkContact
forall (m :: ConnectionMode). ConnShortLink m -> ConnectionLink m
CLShort Maybe (ConnShortLink 'CMContact)
sLink

data GroupLinkInfo = GroupLinkInfo
  { GroupLinkInfo -> UserId
groupId :: GroupId,
    GroupLinkInfo -> GroupMemberRole
memberRole :: GroupMemberRole
  }
  deriving (Int -> GroupLinkInfo -> ShowS
[GroupLinkInfo] -> ShowS
GroupLinkInfo -> FilePath
(Int -> GroupLinkInfo -> ShowS)
-> (GroupLinkInfo -> FilePath)
-> ([GroupLinkInfo] -> ShowS)
-> Show GroupLinkInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GroupLinkInfo -> ShowS
showsPrec :: Int -> GroupLinkInfo -> ShowS
$cshow :: GroupLinkInfo -> FilePath
show :: GroupLinkInfo -> FilePath
$cshowList :: [GroupLinkInfo] -> ShowS
showList :: [GroupLinkInfo] -> ShowS
Show)

data AddressSettings = AddressSettings
  { AddressSettings -> Bool
businessAddress :: Bool, -- possibly, it can be wrapped together with acceptIncognito, or AutoAccept made sum type
    AddressSettings -> Maybe AutoAccept
autoAccept :: Maybe AutoAccept, -- accept automatically
    AddressSettings -> Maybe MsgContent
autoReply :: Maybe MsgContent -- included in short link information, sent on acceptance in case wasn't shown during connection
  }
  deriving (AddressSettings -> AddressSettings -> Bool
(AddressSettings -> AddressSettings -> Bool)
-> (AddressSettings -> AddressSettings -> Bool)
-> Eq AddressSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AddressSettings -> AddressSettings -> Bool
== :: AddressSettings -> AddressSettings -> Bool
$c/= :: AddressSettings -> AddressSettings -> Bool
/= :: AddressSettings -> AddressSettings -> Bool
Eq, Int -> AddressSettings -> ShowS
[AddressSettings] -> ShowS
AddressSettings -> FilePath
(Int -> AddressSettings -> ShowS)
-> (AddressSettings -> FilePath)
-> ([AddressSettings] -> ShowS)
-> Show AddressSettings
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AddressSettings -> ShowS
showsPrec :: Int -> AddressSettings -> ShowS
$cshow :: AddressSettings -> FilePath
show :: AddressSettings -> FilePath
$cshowList :: [AddressSettings] -> ShowS
showList :: [AddressSettings] -> ShowS
Show)

data AutoAccept = AutoAccept
  { AutoAccept -> Bool
acceptIncognito :: IncognitoEnabled -- "incognito" is allowed onle for old addresses without short link data
  }
  deriving (AutoAccept -> AutoAccept -> Bool
(AutoAccept -> AutoAccept -> Bool)
-> (AutoAccept -> AutoAccept -> Bool) -> Eq AutoAccept
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AutoAccept -> AutoAccept -> Bool
== :: AutoAccept -> AutoAccept -> Bool
$c/= :: AutoAccept -> AutoAccept -> Bool
/= :: AutoAccept -> AutoAccept -> Bool
Eq, Int -> AutoAccept -> ShowS
[AutoAccept] -> ShowS
AutoAccept -> FilePath
(Int -> AutoAccept -> ShowS)
-> (AutoAccept -> FilePath)
-> ([AutoAccept] -> ShowS)
-> Show AutoAccept
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AutoAccept -> ShowS
showsPrec :: Int -> AutoAccept -> ShowS
$cshow :: AutoAccept -> FilePath
show :: AutoAccept -> FilePath
$cshowList :: [AutoAccept] -> ShowS
showList :: [AutoAccept] -> ShowS
Show)

$(J.deriveJSON defaultJSON ''AutoAccept)

$(J.deriveJSON defaultJSON ''AddressSettings)

$(J.deriveJSON defaultJSON ''UserContactLink)

toUserContactLink :: (Int64, ConnReqContact, Maybe ShortLinkContact, BoolInt, BoolInt, BoolInt, BoolInt, BoolInt, Maybe MsgContent) -> UserContactLink
toUserContactLink :: (UserId, ConnectionRequestUri 'CMContact,
 Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
 BoolInt, BoolInt, Maybe MsgContent)
-> UserContactLink
toUserContactLink (UserId
userContactLinkId, ConnectionRequestUri 'CMContact
connReq, Maybe (ConnShortLink 'CMContact)
shortLink, BI Bool
shortLinkDataSet, BI Bool
slLargeDataSet, BI Bool
businessAddress, BI Bool
autoAccept', BI Bool
acceptIncognito, Maybe MsgContent
autoReply) =
  UserId
-> CreatedLinkContact
-> Bool
-> BoolDef
-> AddressSettings
-> UserContactLink
UserContactLink UserId
userContactLinkId (ConnectionRequestUri 'CMContact
-> Maybe (ConnShortLink 'CMContact) -> CreatedLinkContact
forall (m :: ConnectionMode).
ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
CCLink ConnectionRequestUri 'CMContact
connReq Maybe (ConnShortLink 'CMContact)
shortLink) Bool
shortLinkDataSet (Bool -> BoolDef
BoolDef Bool
slLargeDataSet) (AddressSettings -> UserContactLink)
-> AddressSettings -> UserContactLink
forall a b. (a -> b) -> a -> b
$
    let autoAccept :: Maybe AutoAccept
autoAccept = if Bool
autoAccept' then AutoAccept -> Maybe AutoAccept
forall a. a -> Maybe a
Just AutoAccept {Bool
acceptIncognito :: Bool
acceptIncognito :: Bool
acceptIncognito} else Maybe AutoAccept
forall a. Maybe a
Nothing
     in AddressSettings {Bool
businessAddress :: Bool
businessAddress :: Bool
businessAddress, Maybe AutoAccept
autoAccept :: Maybe AutoAccept
autoAccept :: Maybe AutoAccept
autoAccept, Maybe MsgContent
autoReply :: Maybe MsgContent
autoReply :: Maybe MsgContent
autoReply}

getUserAddress :: DB.Connection -> User -> ExceptT StoreError IO UserContactLink
getUserAddress :: Connection -> User -> ExceptT StoreError IO UserContactLink
getUserAddress Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} =
  IO (Either StoreError UserContactLink)
-> ExceptT StoreError IO UserContactLink
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError UserContactLink)
 -> ExceptT StoreError IO UserContactLink)
-> (IO
      [(UserId, ConnectionRequestUri 'CMContact,
        Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
        BoolInt, BoolInt, Maybe MsgContent)]
    -> IO (Either StoreError UserContactLink))
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)]
-> ExceptT StoreError IO UserContactLink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UserId, ConnectionRequestUri 'CMContact,
  Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
  BoolInt, BoolInt, Maybe MsgContent)
 -> UserContactLink)
-> StoreError
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)]
-> IO (Either StoreError UserContactLink)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow (UserId, ConnectionRequestUri 'CMContact,
 Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
 BoolInt, BoolInt, Maybe MsgContent)
-> UserContactLink
toUserContactLink StoreError
SEUserContactLinkNotFound (IO
   [(UserId, ConnectionRequestUri 'CMContact,
     Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
     BoolInt, BoolInt, Maybe MsgContent)]
 -> ExceptT StoreError IO UserContactLink)
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)]
-> ExceptT StoreError IO UserContactLink
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only UserId
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
userContactLinkQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL") (UserId -> Only UserId
forall a. a -> Only a
Only UserId
userId)

getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo)
getUserContactLinkById :: Connection
-> UserId
-> UserId
-> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo)
getUserContactLinkById Connection
db UserId
userId UserId
userContactLinkId =
  IO (Either StoreError (UserContactLink, Maybe GroupLinkInfo))
-> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError (UserContactLink, Maybe GroupLinkInfo))
 -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo))
-> (IO
      [(UserId, ConnectionRequestUri 'CMContact,
        Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
        BoolInt, BoolInt, Maybe MsgContent)
       :. (Maybe UserId, Maybe GroupMemberRole)]
    -> IO (Either StoreError (UserContactLink, Maybe GroupLinkInfo)))
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)
      :. (Maybe UserId, Maybe GroupMemberRole)]
-> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((UserId, ConnectionRequestUri 'CMContact,
   Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
   BoolInt, BoolInt, Maybe MsgContent)
  :. (Maybe UserId, Maybe GroupMemberRole))
 -> (UserContactLink, Maybe GroupLinkInfo))
-> StoreError
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)
      :. (Maybe UserId, Maybe GroupMemberRole)]
-> IO (Either StoreError (UserContactLink, Maybe GroupLinkInfo))
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow (\((UserId, ConnectionRequestUri 'CMContact,
 Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
 BoolInt, BoolInt, Maybe MsgContent)
ucl :. (Maybe UserId, Maybe GroupMemberRole)
gli) -> ((UserId, ConnectionRequestUri 'CMContact,
 Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
 BoolInt, BoolInt, Maybe MsgContent)
-> UserContactLink
toUserContactLink (UserId, ConnectionRequestUri 'CMContact,
 Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
 BoolInt, BoolInt, Maybe MsgContent)
ucl, (Maybe UserId, Maybe GroupMemberRole) -> Maybe GroupLinkInfo
toGroupLinkInfo (Maybe UserId, Maybe GroupMemberRole)
gli)) StoreError
SEUserContactLinkNotFound (IO
   [(UserId, ConnectionRequestUri 'CMContact,
     Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
     BoolInt, BoolInt, Maybe MsgContent)
    :. (Maybe UserId, Maybe GroupMemberRole)]
 -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo))
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)
      :. (Maybe UserId, Maybe GroupMemberRole)]
-> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo)
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> (UserId, UserId)
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)
      :. (Maybe UserId, Maybe GroupMemberRole)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
      Connection
db
      [sql|
        SELECT user_contact_link_id, conn_req_contact, short_link_contact, short_link_data_set, short_link_large_data_set, business_address, auto_accept, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role
        FROM user_contact_links
        WHERE user_id = ? AND user_contact_link_id = ?
      |]
      (UserId
userId, UserId
userContactLinkId)

toGroupLinkInfo :: (Maybe GroupId, Maybe GroupMemberRole) -> Maybe GroupLinkInfo
toGroupLinkInfo :: (Maybe UserId, Maybe GroupMemberRole) -> Maybe GroupLinkInfo
toGroupLinkInfo (Maybe UserId
groupId_, Maybe GroupMemberRole
mRole_) =
  (\UserId
groupId -> GroupLinkInfo {UserId
groupId :: UserId
groupId :: UserId
groupId, memberRole :: GroupMemberRole
memberRole = GroupMemberRole -> Maybe GroupMemberRole -> GroupMemberRole
forall a. a -> Maybe a -> a
fromMaybe GroupMemberRole
GRMember Maybe GroupMemberRole
mRole_})
    (UserId -> GroupLinkInfo) -> Maybe UserId -> Maybe GroupLinkInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UserId
groupId_

getGroupLinkInfo :: DB.Connection -> UserId -> GroupId -> IO (Maybe GroupLinkInfo)
getGroupLinkInfo :: Connection -> UserId -> UserId -> IO (Maybe GroupLinkInfo)
getGroupLinkInfo Connection
db UserId
userId UserId
groupId =
  (Maybe (Maybe GroupLinkInfo) -> Maybe GroupLinkInfo)
-> IO (Maybe (Maybe GroupLinkInfo)) -> IO (Maybe GroupLinkInfo)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe GroupLinkInfo) -> Maybe GroupLinkInfo
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (Maybe (Maybe GroupLinkInfo)) -> IO (Maybe GroupLinkInfo))
-> IO (Maybe (Maybe GroupLinkInfo)) -> IO (Maybe GroupLinkInfo)
forall a b. (a -> b) -> a -> b
$ ((Maybe UserId, Maybe GroupMemberRole) -> Maybe GroupLinkInfo)
-> IO [(Maybe UserId, Maybe GroupMemberRole)]
-> IO (Maybe (Maybe GroupLinkInfo))
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow (Maybe UserId, Maybe GroupMemberRole) -> Maybe GroupLinkInfo
toGroupLinkInfo (IO [(Maybe UserId, Maybe GroupMemberRole)]
 -> IO (Maybe (Maybe GroupLinkInfo)))
-> IO [(Maybe UserId, Maybe GroupMemberRole)]
-> IO (Maybe (Maybe GroupLinkInfo))
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> (UserId, UserId)
-> IO [(Maybe UserId, Maybe GroupMemberRole)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
      Connection
db
      [sql|
        SELECT group_id, group_link_member_role
        FROM user_contact_links
        WHERE user_id = ? AND group_id = ?
      |]
      (UserId
userId, UserId
groupId)

getUserContactLinkByConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe UserContactLink)
getUserContactLinkByConnReq :: Connection
-> User
-> (ConnectionRequestUri 'CMContact,
    ConnectionRequestUri 'CMContact)
-> IO (Maybe UserContactLink)
getUserContactLinkByConnReq Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} (ConnectionRequestUri 'CMContact
cReqSchema1, ConnectionRequestUri 'CMContact
cReqSchema2) =
  ((UserId, ConnectionRequestUri 'CMContact,
  Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
  BoolInt, BoolInt, Maybe MsgContent)
 -> UserContactLink)
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)]
-> IO (Maybe UserContactLink)
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow (UserId, ConnectionRequestUri 'CMContact,
 Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
 BoolInt, BoolInt, Maybe MsgContent)
-> UserContactLink
toUserContactLink (IO
   [(UserId, ConnectionRequestUri 'CMContact,
     Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
     BoolInt, BoolInt, Maybe MsgContent)]
 -> IO (Maybe UserContactLink))
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)]
-> IO (Maybe UserContactLink)
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> (UserId, ConnectionRequestUri 'CMContact,
    ConnectionRequestUri 'CMContact)
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
userContactLinkQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" WHERE user_id = ? AND conn_req_contact IN (?,?)") (UserId
userId, ConnectionRequestUri 'CMContact
cReqSchema1, ConnectionRequestUri 'CMContact
cReqSchema2)

getUserContactLinkViaShortLink :: DB.Connection -> User -> ShortLinkContact -> IO (Maybe UserContactLink)
getUserContactLinkViaShortLink :: Connection
-> User -> ConnShortLink 'CMContact -> IO (Maybe UserContactLink)
getUserContactLinkViaShortLink Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} ConnShortLink 'CMContact
shortLink =
  ((UserId, ConnectionRequestUri 'CMContact,
  Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
  BoolInt, BoolInt, Maybe MsgContent)
 -> UserContactLink)
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)]
-> IO (Maybe UserContactLink)
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow (UserId, ConnectionRequestUri 'CMContact,
 Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
 BoolInt, BoolInt, Maybe MsgContent)
-> UserContactLink
toUserContactLink (IO
   [(UserId, ConnectionRequestUri 'CMContact,
     Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
     BoolInt, BoolInt, Maybe MsgContent)]
 -> IO (Maybe UserContactLink))
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)]
-> IO (Maybe UserContactLink)
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> (UserId, ConnShortLink 'CMContact)
-> IO
     [(UserId, ConnectionRequestUri 'CMContact,
       Maybe (ConnShortLink 'CMContact), BoolInt, BoolInt, BoolInt,
       BoolInt, BoolInt, Maybe MsgContent)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
userContactLinkQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" WHERE user_id = ? AND short_link_contact = ?") (UserId
userId, ConnShortLink 'CMContact
shortLink)

userContactLinkQuery :: Query
userContactLinkQuery :: Query
userContactLinkQuery =
  [sql|
    SELECT user_contact_link_id, conn_req_contact, short_link_contact, short_link_data_set, short_link_large_data_set, business_address, auto_accept, auto_accept_incognito, auto_reply_msg_content
    FROM user_contact_links
  |]

setUserContactLinkShortLink :: DB.Connection -> Int64 -> ShortLinkContact -> IO ()
setUserContactLinkShortLink :: Connection -> UserId -> ConnShortLink 'CMContact -> IO ()
setUserContactLinkShortLink Connection
db UserId
userContactLinkId ConnShortLink 'CMContact
shortLink =
  Connection
-> Query
-> (ConnShortLink 'CMContact, BoolInt, BoolInt, BoolInt, UserId)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE user_contact_links
      SET short_link_contact = ?,
          short_link_data_set = ?,
          short_link_large_data_set = ?,
          auto_accept_incognito = ?
      WHERE user_contact_link_id = ?
    |]
    (ConnShortLink 'CMContact
shortLink, Bool -> BoolInt
BI Bool
True, Bool -> BoolInt
BI Bool
True, Bool -> BoolInt
BI Bool
False, UserId
userContactLinkId)

getContactWithoutConnViaAddress :: DB.Connection -> VersionRangeChat -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact)
getContactWithoutConnViaAddress :: Connection
-> VersionRangeChat
-> User
-> (ConnectionRequestUri 'CMContact,
    ConnectionRequestUri 'CMContact)
-> IO (Maybe Contact)
getContactWithoutConnViaAddress Connection
db VersionRangeChat
vr user :: User
user@User {UserId
userId :: User -> UserId
userId :: UserId
userId} (ConnectionRequestUri 'CMContact
cReqSchema1, ConnectionRequestUri 'CMContact
cReqSchema2) = do
  Maybe UserId
ctId_ <-
    (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, ConnectionRequestUri 'CMContact,
    ConnectionRequestUri 'CMContact)
-> IO [Only UserId]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
        Connection
db
        [sql|
          SELECT ct.contact_id
          FROM contacts ct
          JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
          LEFT JOIN connections c ON c.contact_id = ct.contact_id
          WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL
        |]
        (UserId
userId, ConnectionRequestUri 'CMContact
cReqSchema1, ConnectionRequestUri 'CMContact
cReqSchema2)
  IO (Maybe Contact)
-> (UserId -> IO (Maybe Contact))
-> Maybe UserId
-> IO (Maybe Contact)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Contact -> IO (Maybe Contact)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Contact
forall a. Maybe a
Nothing) ((Either StoreError Contact -> Maybe Contact)
-> IO (Either StoreError Contact) -> IO (Maybe Contact)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either StoreError Contact -> Maybe Contact
forall a b. Either a b -> Maybe b
eitherToMaybe (IO (Either StoreError Contact) -> IO (Maybe Contact))
-> (UserId -> IO (Either StoreError Contact))
-> UserId
-> IO (Maybe Contact)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT StoreError IO Contact -> IO (Either StoreError Contact)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO Contact -> IO (Either StoreError Contact))
-> (UserId -> ExceptT StoreError IO Contact)
-> UserId
-> IO (Either StoreError Contact)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection
-> VersionRangeChat
-> User
-> UserId
-> ExceptT StoreError IO Contact
getContact Connection
db VersionRangeChat
vr User
user) Maybe UserId
ctId_

getContactWithoutConnViaShortAddress :: DB.Connection -> VersionRangeChat -> User -> ShortLinkContact -> IO (Maybe Contact)
getContactWithoutConnViaShortAddress :: Connection
-> VersionRangeChat
-> User
-> ConnShortLink 'CMContact
-> IO (Maybe Contact)
getContactWithoutConnViaShortAddress Connection
db VersionRangeChat
vr user :: User
user@User {UserId
userId :: User -> UserId
userId :: UserId
userId} ConnShortLink 'CMContact
shortLink = do
  Maybe UserId
ctId_ <-
    (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, ConnShortLink 'CMContact) -> IO [Only UserId]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
        Connection
db
        [sql|
          SELECT ct.contact_id
          FROM contacts ct
          JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
          LEFT JOIN connections c ON c.contact_id = ct.contact_id
          WHERE cp.user_id = ? AND cp.contact_link = ? AND c.connection_id IS NULL
        |]
        (UserId
userId, ConnShortLink 'CMContact
shortLink)
  IO (Maybe Contact)
-> (UserId -> IO (Maybe Contact))
-> Maybe UserId
-> IO (Maybe Contact)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Contact -> IO (Maybe Contact)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Contact
forall a. Maybe a
Nothing) ((Either StoreError Contact -> Maybe Contact)
-> IO (Either StoreError Contact) -> IO (Maybe Contact)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either StoreError Contact -> Maybe Contact
forall a b. Either a b -> Maybe b
eitherToMaybe (IO (Either StoreError Contact) -> IO (Maybe Contact))
-> (UserId -> IO (Either StoreError Contact))
-> UserId
-> IO (Maybe Contact)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT StoreError IO Contact -> IO (Either StoreError Contact)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO Contact -> IO (Either StoreError Contact))
-> (UserId -> ExceptT StoreError IO Contact)
-> UserId
-> IO (Either StoreError Contact)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection
-> VersionRangeChat
-> User
-> UserId
-> ExceptT StoreError IO Contact
getContact Connection
db VersionRangeChat
vr User
user) Maybe UserId
ctId_

updateUserAddressSettings :: DB.Connection -> Int64 -> AddressSettings -> IO ()
updateUserAddressSettings :: Connection -> UserId -> AddressSettings -> IO ()
updateUserAddressSettings Connection
db UserId
userContactLinkId AddressSettings {Bool
businessAddress :: AddressSettings -> Bool
businessAddress :: Bool
businessAddress, Maybe AutoAccept
autoAccept :: AddressSettings -> Maybe AutoAccept
autoAccept :: Maybe AutoAccept
autoAccept, Maybe MsgContent
autoReply :: AddressSettings -> Maybe MsgContent
autoReply :: Maybe MsgContent
autoReply} =
  Connection
-> Query
-> ((BoolInt, BoolInt) :. (BoolInt, Maybe MsgContent, UserId))
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE user_contact_links
      SET auto_accept = ?, auto_accept_incognito = ?, business_address = ?, auto_reply_msg_content = ?
      WHERE user_contact_link_id = ?
    |]
    ((BoolInt, BoolInt)
autoAcceptValues (BoolInt, BoolInt)
-> (BoolInt, Maybe MsgContent, UserId)
-> (BoolInt, BoolInt) :. (BoolInt, Maybe MsgContent, UserId)
forall h t. h -> t -> h :. t
:. (Bool -> BoolInt
BI Bool
businessAddress, Maybe MsgContent
autoReply, UserId
userContactLinkId))
  where
    autoAcceptValues :: (BoolInt, BoolInt)
autoAcceptValues = case Maybe AutoAccept
autoAccept of
      Just AutoAccept {Bool
acceptIncognito :: AutoAccept -> Bool
acceptIncognito :: Bool
acceptIncognito} -> (Bool -> BoolInt
BI Bool
True, Bool -> BoolInt
BI Bool
acceptIncognito)
      Maybe AutoAccept
Nothing -> (Bool -> BoolInt
BI Bool
False, Bool -> BoolInt
BI Bool
False)

getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> IO [UserServer p]
getProtocolServers :: forall (p :: ProtocolType).
ProtocolTypeI p =>
Connection -> SProtocolType p -> User -> IO [UserServer p]
getProtocolServers Connection
db SProtocolType p
p User {UserId
userId :: User -> UserId
userId :: UserId
userId} =
  ((DBEntityId' 'DBStored, NonEmpty TransportHost, FilePath, KeyHash,
  Maybe ContactName, BoolInt, Maybe BoolInt, BoolInt)
 -> UserServer p)
-> [(DBEntityId' 'DBStored, NonEmpty TransportHost, FilePath,
     KeyHash, Maybe ContactName, BoolInt, Maybe BoolInt, BoolInt)]
-> [UserServer p]
forall a b. (a -> b) -> [a] -> [b]
map (DBEntityId' 'DBStored, NonEmpty TransportHost, FilePath, KeyHash,
 Maybe ContactName, BoolInt, Maybe BoolInt, BoolInt)
-> UserServer p
toUserServer
    ([(DBEntityId' 'DBStored, NonEmpty TransportHost, FilePath,
   KeyHash, Maybe ContactName, BoolInt, Maybe BoolInt, BoolInt)]
 -> [UserServer p])
-> IO
     [(DBEntityId' 'DBStored, NonEmpty TransportHost, FilePath, KeyHash,
       Maybe ContactName, BoolInt, Maybe BoolInt, BoolInt)]
-> IO [UserServer p]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> Query
-> (UserId, ContactName)
-> IO
     [(DBEntityId' 'DBStored, NonEmpty TransportHost, FilePath, KeyHash,
       Maybe ContactName, BoolInt, Maybe BoolInt, BoolInt)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
      Connection
db
      [sql|
        SELECT smp_server_id, host, port, key_hash, basic_auth, preset, tested, enabled
        FROM protocol_servers
        WHERE user_id = ? AND protocol = ?
      |]
      (UserId
userId, ConnId -> ContactName
decodeLatin1 (ConnId -> ContactName) -> ConnId -> ContactName
forall a b. (a -> b) -> a -> b
$ SProtocolType p -> ConnId
forall a. StrEncoding a => a -> ConnId
strEncode SProtocolType p
p)
  where
    toUserServer :: (DBEntityId, NonEmpty TransportHost, String, C.KeyHash, Maybe Text, BoolInt, Maybe BoolInt, BoolInt) -> UserServer p
    toUserServer :: (DBEntityId' 'DBStored, NonEmpty TransportHost, FilePath, KeyHash,
 Maybe ContactName, BoolInt, Maybe BoolInt, BoolInt)
-> UserServer p
toUserServer (DBEntityId' 'DBStored
serverId, NonEmpty TransportHost
host, FilePath
port, KeyHash
keyHash, Maybe ContactName
auth_, BI Bool
preset, Maybe BoolInt
tested, BI Bool
enabled) =
      let server :: ProtoServerWithAuth p
server = ProtocolServer p -> Maybe BasicAuth -> ProtoServerWithAuth p
forall (p :: ProtocolType).
ProtocolServer p -> Maybe BasicAuth -> ProtoServerWithAuth p
ProtoServerWithAuth (SProtocolType p
-> NonEmpty TransportHost
-> FilePath
-> KeyHash
-> ProtocolServer p
forall (p :: ProtocolType).
SProtocolType p
-> NonEmpty TransportHost
-> FilePath
-> KeyHash
-> ProtocolServer p
ProtocolServer SProtocolType p
p NonEmpty TransportHost
host FilePath
port KeyHash
keyHash) (ConnId -> BasicAuth
BasicAuth (ConnId -> BasicAuth)
-> (ContactName -> ConnId) -> ContactName -> BasicAuth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContactName -> ConnId
encodeUtf8 (ContactName -> BasicAuth) -> Maybe ContactName -> Maybe BasicAuth
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ContactName
auth_)
       in UserServer {DBEntityId' 'DBStored
serverId :: DBEntityId' 'DBStored
serverId :: DBEntityId' 'DBStored
serverId, ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server, Bool
preset :: Bool
preset :: Bool
preset, tested :: Maybe Bool
tested = BoolInt -> Bool
unBI (BoolInt -> Bool) -> Maybe BoolInt -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe BoolInt
tested, Bool
enabled :: Bool
enabled :: Bool
enabled, deleted :: Bool
deleted = Bool
False}

insertProtocolServer :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> UTCTime -> NewUserServer p -> IO (UserServer p)
insertProtocolServer :: forall (p :: ProtocolType).
ProtocolTypeI p =>
Connection
-> SProtocolType p
-> User
-> UTCTime
-> NewUserServer p
-> IO (UserServer p)
insertProtocolServer Connection
db SProtocolType p
p User {UserId
userId :: User -> UserId
userId :: UserId
userId} UTCTime
ts srv :: NewUserServer p
srv@UserServer {ProtoServerWithAuth p
server :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server, Bool
preset :: forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
preset :: Bool
preset, Maybe Bool
tested :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> Maybe Bool
tested :: Maybe Bool
tested, Bool
enabled :: forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
enabled :: Bool
enabled} = do
  Connection
-> Query
-> ((ContactName, NonEmpty TransportHost, FilePath, KeyHash,
     Maybe ContactName)
    :. (BoolInt, Maybe BoolInt, BoolInt, UserId, UTCTime, UTCTime))
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      INSERT INTO protocol_servers
        (protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
      VALUES (?,?,?,?,?,?,?,?,?,?,?)
    |]
    (SProtocolType p
-> ProtoServerWithAuth p
-> (ContactName, NonEmpty TransportHost, FilePath, KeyHash,
    Maybe ContactName)
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p
-> ProtoServerWithAuth p
-> (ContactName, NonEmpty TransportHost, FilePath, KeyHash,
    Maybe ContactName)
serverColumns SProtocolType p
p ProtoServerWithAuth p
server (ContactName, NonEmpty TransportHost, FilePath, KeyHash,
 Maybe ContactName)
-> (BoolInt, Maybe BoolInt, BoolInt, UserId, UTCTime, UTCTime)
-> (ContactName, NonEmpty TransportHost, FilePath, KeyHash,
    Maybe ContactName)
   :. (BoolInt, Maybe BoolInt, BoolInt, UserId, UTCTime, UTCTime)
forall h t. h -> t -> h :. t
:. (Bool -> BoolInt
BI Bool
preset, Bool -> BoolInt
BI (Bool -> BoolInt) -> Maybe Bool -> Maybe BoolInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Bool
tested, Bool -> BoolInt
BI Bool
enabled, UserId
userId, UTCTime
ts, UTCTime
ts))
  UserId
sId <- Connection -> IO UserId
insertedRowId Connection
db
  UserServer p -> IO (UserServer p)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewUserServer p
srv :: NewUserServer p) {serverId = DBEntityId sId}

updateProtocolServer :: ProtocolTypeI p => DB.Connection -> SProtocolType p -> UTCTime -> UserServer p -> IO ()
updateProtocolServer :: forall (p :: ProtocolType).
ProtocolTypeI p =>
Connection -> SProtocolType p -> UTCTime -> UserServer p -> IO ()
updateProtocolServer Connection
db SProtocolType p
p UTCTime
ts UserServer {DBEntityId' 'DBStored
serverId :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> DBEntityId' s
serverId :: DBEntityId' 'DBStored
serverId, ProtoServerWithAuth p
server :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server, Bool
preset :: forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
preset :: Bool
preset, Maybe Bool
tested :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> Maybe Bool
tested :: Maybe Bool
tested, Bool
enabled :: forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
enabled :: Bool
enabled} =
  Connection
-> Query
-> ((ContactName, NonEmpty TransportHost, FilePath, KeyHash,
     Maybe ContactName)
    :. (BoolInt, Maybe BoolInt, BoolInt, UTCTime,
        DBEntityId' 'DBStored))
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE protocol_servers
      SET protocol = ?, host = ?, port = ?, key_hash = ?, basic_auth = ?,
          preset = ?, tested = ?, enabled = ?, updated_at = ?
      WHERE smp_server_id = ?
    |]
    (SProtocolType p
-> ProtoServerWithAuth p
-> (ContactName, NonEmpty TransportHost, FilePath, KeyHash,
    Maybe ContactName)
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p
-> ProtoServerWithAuth p
-> (ContactName, NonEmpty TransportHost, FilePath, KeyHash,
    Maybe ContactName)
serverColumns SProtocolType p
p ProtoServerWithAuth p
server (ContactName, NonEmpty TransportHost, FilePath, KeyHash,
 Maybe ContactName)
-> (BoolInt, Maybe BoolInt, BoolInt, UTCTime,
    DBEntityId' 'DBStored)
-> (ContactName, NonEmpty TransportHost, FilePath, KeyHash,
    Maybe ContactName)
   :. (BoolInt, Maybe BoolInt, BoolInt, UTCTime,
       DBEntityId' 'DBStored)
forall h t. h -> t -> h :. t
:. (Bool -> BoolInt
BI Bool
preset, Bool -> BoolInt
BI (Bool -> BoolInt) -> Maybe Bool -> Maybe BoolInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Bool
tested, Bool -> BoolInt
BI Bool
enabled, UTCTime
ts, DBEntityId' 'DBStored
serverId))

serverColumns :: ProtocolTypeI p => SProtocolType p -> ProtoServerWithAuth p -> (Text, NonEmpty TransportHost, String, C.KeyHash, Maybe Text)
serverColumns :: forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p
-> ProtoServerWithAuth p
-> (ContactName, NonEmpty TransportHost, FilePath, KeyHash,
    Maybe ContactName)
serverColumns SProtocolType p
p (ProtoServerWithAuth ProtocolServer {NonEmpty TransportHost
host :: NonEmpty TransportHost
host :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host, FilePath
port :: FilePath
port :: forall (p :: ProtocolType). ProtocolServer p -> FilePath
port, KeyHash
keyHash :: KeyHash
keyHash :: forall (p :: ProtocolType). ProtocolServer p -> KeyHash
keyHash} Maybe BasicAuth
auth_) =
  let protocol :: ContactName
protocol = ConnId -> ContactName
decodeLatin1 (ConnId -> ContactName) -> ConnId -> ContactName
forall a b. (a -> b) -> a -> b
$ SProtocolType p -> ConnId
forall a. StrEncoding a => a -> ConnId
strEncode SProtocolType p
p
      auth :: Maybe ContactName
auth = ConnId -> ContactName
safeDecodeUtf8 (ConnId -> ContactName)
-> (BasicAuth -> ConnId) -> BasicAuth -> ContactName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BasicAuth -> ConnId
unBasicAuth (BasicAuth -> ContactName) -> Maybe BasicAuth -> Maybe ContactName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe BasicAuth
auth_
   in (ContactName
protocol, NonEmpty TransportHost
host, FilePath
port, KeyHash
keyHash, Maybe ContactName
auth)

getServerOperators :: DB.Connection -> ExceptT StoreError IO ServerOperatorConditions
getServerOperators :: Connection -> ExceptT StoreError IO ServerOperatorConditions
getServerOperators Connection
db = do
  UsageConditions
currentConditions <- Connection -> ExceptT StoreError IO UsageConditions
getCurrentUsageConditions Connection
db
  IO ServerOperatorConditions
-> ExceptT StoreError IO ServerOperatorConditions
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ServerOperatorConditions
 -> ExceptT StoreError IO ServerOperatorConditions)
-> IO ServerOperatorConditions
-> ExceptT StoreError IO ServerOperatorConditions
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
now <- IO UTCTime
getCurrentTime
    Maybe UsageConditions
latestAcceptedConds_ <- Connection -> IO (Maybe UsageConditions)
getLatestAcceptedConditions Connection
db
    let getConds :: ServerOperator' 'DBStored -> IO (ServerOperator' 'DBStored)
getConds ServerOperator' 'DBStored
op = (\ConditionsAcceptance
ca -> ServerOperator' 'DBStored
op {conditionsAcceptance = ca}) (ConditionsAcceptance -> ServerOperator' 'DBStored)
-> IO ConditionsAcceptance -> IO (ServerOperator' 'DBStored)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> ServerOperator' 'DBStored
-> UsageConditions
-> Maybe UsageConditions
-> UTCTime
-> IO ConditionsAcceptance
getOperatorConditions_ Connection
db ServerOperator' 'DBStored
op UsageConditions
currentConditions Maybe UsageConditions
latestAcceptedConds_ UTCTime
now
    [ServerOperator' 'DBStored]
ops <- (ServerOperator' 'DBStored -> IO (ServerOperator' 'DBStored))
-> [ServerOperator' 'DBStored] -> IO [ServerOperator' 'DBStored]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ServerOperator' 'DBStored -> IO (ServerOperator' 'DBStored)
getConds ([ServerOperator' 'DBStored] -> IO [ServerOperator' 'DBStored])
-> IO [ServerOperator' 'DBStored] -> IO [ServerOperator' 'DBStored]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Connection -> IO [ServerOperator' 'DBStored]
getServerOperators_ Connection
db
    let conditionsAction :: Maybe UsageConditionsAction
conditionsAction = [ServerOperator' 'DBStored]
-> UsageConditions -> UTCTime -> Maybe UsageConditionsAction
usageConditionsAction [ServerOperator' 'DBStored]
ops UsageConditions
currentConditions UTCTime
now
    ServerOperatorConditions -> IO ServerOperatorConditions
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerOperatorConditions {serverOperators :: [ServerOperator' 'DBStored]
serverOperators = [ServerOperator' 'DBStored]
ops, UsageConditions
currentConditions :: UsageConditions
currentConditions :: UsageConditions
currentConditions, Maybe UsageConditionsAction
conditionsAction :: Maybe UsageConditionsAction
conditionsAction :: Maybe UsageConditionsAction
conditionsAction}

getUserServers :: DB.Connection -> User -> ExceptT StoreError IO ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP])
getUserServers :: Connection
-> User
-> ExceptT
     StoreError
     IO
     ([Maybe (ServerOperator' 'DBStored)], [UserServer 'PSMP],
      [UserServer 'PXFTP])
getUserServers Connection
db User
user =
  (,,)
    ([Maybe (ServerOperator' 'DBStored)]
 -> [UserServer 'PSMP]
 -> [UserServer 'PXFTP]
 -> ([Maybe (ServerOperator' 'DBStored)], [UserServer 'PSMP],
     [UserServer 'PXFTP]))
-> ExceptT StoreError IO [Maybe (ServerOperator' 'DBStored)]
-> ExceptT
     StoreError
     IO
     ([UserServer 'PSMP]
      -> [UserServer 'PXFTP]
      -> ([Maybe (ServerOperator' 'DBStored)], [UserServer 'PSMP],
          [UserServer 'PXFTP]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ServerOperator' 'DBStored -> Maybe (ServerOperator' 'DBStored))
-> [ServerOperator' 'DBStored]
-> [Maybe (ServerOperator' 'DBStored)]
forall a b. (a -> b) -> [a] -> [b]
map ServerOperator' 'DBStored -> Maybe (ServerOperator' 'DBStored)
forall a. a -> Maybe a
Just ([ServerOperator' 'DBStored]
 -> [Maybe (ServerOperator' 'DBStored)])
-> (ServerOperatorConditions -> [ServerOperator' 'DBStored])
-> ServerOperatorConditions
-> [Maybe (ServerOperator' 'DBStored)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerOperatorConditions -> [ServerOperator' 'DBStored]
serverOperators (ServerOperatorConditions -> [Maybe (ServerOperator' 'DBStored)])
-> ExceptT StoreError IO ServerOperatorConditions
-> ExceptT StoreError IO [Maybe (ServerOperator' 'DBStored)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> ExceptT StoreError IO ServerOperatorConditions
getServerOperators Connection
db)
    ExceptT
  StoreError
  IO
  ([UserServer 'PSMP]
   -> [UserServer 'PXFTP]
   -> ([Maybe (ServerOperator' 'DBStored)], [UserServer 'PSMP],
       [UserServer 'PXFTP]))
-> ExceptT StoreError IO [UserServer 'PSMP]
-> ExceptT
     StoreError
     IO
     ([UserServer 'PXFTP]
      -> ([Maybe (ServerOperator' 'DBStored)], [UserServer 'PSMP],
          [UserServer 'PXFTP]))
forall a b.
ExceptT StoreError IO (a -> b)
-> ExceptT StoreError IO a -> ExceptT StoreError IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO [UserServer 'PSMP] -> ExceptT StoreError IO [UserServer 'PSMP]
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Connection -> SProtocolType 'PSMP -> User -> IO [UserServer 'PSMP]
forall (p :: ProtocolType).
ProtocolTypeI p =>
Connection -> SProtocolType p -> User -> IO [UserServer p]
getProtocolServers Connection
db SProtocolType 'PSMP
SPSMP User
user)
    ExceptT
  StoreError
  IO
  ([UserServer 'PXFTP]
   -> ([Maybe (ServerOperator' 'DBStored)], [UserServer 'PSMP],
       [UserServer 'PXFTP]))
-> ExceptT StoreError IO [UserServer 'PXFTP]
-> ExceptT
     StoreError
     IO
     ([Maybe (ServerOperator' 'DBStored)], [UserServer 'PSMP],
      [UserServer 'PXFTP])
forall a b.
ExceptT StoreError IO (a -> b)
-> ExceptT StoreError IO a -> ExceptT StoreError IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO [UserServer 'PXFTP] -> ExceptT StoreError IO [UserServer 'PXFTP]
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Connection
-> SProtocolType 'PXFTP -> User -> IO [UserServer 'PXFTP]
forall (p :: ProtocolType).
ProtocolTypeI p =>
Connection -> SProtocolType p -> User -> IO [UserServer p]
getProtocolServers Connection
db SProtocolType 'PXFTP
SPXFTP User
user)

setServerOperators :: DB.Connection -> NonEmpty ServerOperator -> IO ()
setServerOperators :: Connection -> NonEmpty (ServerOperator' 'DBStored) -> IO ()
setServerOperators Connection
db NonEmpty (ServerOperator' 'DBStored)
ops = do
  UTCTime
currentTs <- IO UTCTime
getCurrentTime
  (ServerOperator' 'DBStored -> IO ())
-> NonEmpty (ServerOperator' 'DBStored) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Connection -> UTCTime -> ServerOperator' 'DBStored -> IO ()
updateServerOperator Connection
db UTCTime
currentTs) NonEmpty (ServerOperator' 'DBStored)
ops

updateServerOperator :: DB.Connection -> UTCTime -> ServerOperator -> IO ()
updateServerOperator :: Connection -> UTCTime -> ServerOperator' 'DBStored -> IO ()
updateServerOperator Connection
db UTCTime
currentTs ServerOperator {DBEntityId' 'DBStored
operatorId :: DBEntityId' 'DBStored
operatorId :: forall (s :: DBStored). ServerOperator' s -> DBEntityId' s
operatorId, Bool
enabled :: Bool
enabled :: forall (s :: DBStored). ServerOperator' s -> Bool
enabled, ServerRoles
smpRoles :: ServerRoles
smpRoles :: forall (s :: DBStored). ServerOperator' s -> ServerRoles
smpRoles, ServerRoles
xftpRoles :: ServerRoles
xftpRoles :: forall (s :: DBStored). ServerOperator' s -> ServerRoles
xftpRoles} =
  Connection
-> Query
-> (BoolInt, BoolInt, BoolInt, BoolInt, BoolInt, UTCTime,
    DBEntityId' 'DBStored)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE server_operators
      SET enabled = ?, smp_role_storage = ?, smp_role_proxy = ?, xftp_role_storage = ?, xftp_role_proxy = ?, updated_at = ?
      WHERE server_operator_id = ?
    |]
    (Bool -> BoolInt
BI Bool
enabled, Bool -> BoolInt
BI (ServerRoles -> Bool
storage ServerRoles
smpRoles), Bool -> BoolInt
BI (ServerRoles -> Bool
proxy ServerRoles
smpRoles), Bool -> BoolInt
BI (ServerRoles -> Bool
storage ServerRoles
xftpRoles), Bool -> BoolInt
BI (ServerRoles -> Bool
proxy ServerRoles
xftpRoles), UTCTime
currentTs, DBEntityId' 'DBStored
operatorId)

getUpdateServerOperators :: DB.Connection -> NonEmpty PresetOperator -> Bool -> IO [(Maybe PresetOperator, Maybe ServerOperator)]
getUpdateServerOperators :: Connection
-> NonEmpty PresetOperator
-> Bool
-> IO [(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))]
getUpdateServerOperators Connection
db NonEmpty PresetOperator
presetOps Bool
newUser = do
  [UsageConditions]
conds <- ((UserId, ContactName, Maybe UTCTime, UTCTime) -> UsageConditions)
-> [(UserId, ContactName, Maybe UTCTime, UTCTime)]
-> [UsageConditions]
forall a b. (a -> b) -> [a] -> [b]
map (UserId, ContactName, Maybe UTCTime, UTCTime) -> UsageConditions
toUsageConditions ([(UserId, ContactName, Maybe UTCTime, UTCTime)]
 -> [UsageConditions])
-> IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
-> IO [UsageConditions]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> Query -> IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
forall r. FromRow r => Connection -> Query -> IO [r]
DB.query_ Connection
db Query
usageCondsQuery
  UTCTime
now <- IO UTCTime
getCurrentTime
  let (UsageConditions
currentConds, [UsageConditions]
condsToAdd) = Bool
-> UTCTime
-> [UsageConditions]
-> (UsageConditions, [UsageConditions])
usageConditionsToAdd Bool
newUser UTCTime
now [UsageConditions]
conds
  (UsageConditions -> IO ()) -> [UsageConditions] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ UsageConditions -> IO ()
insertConditions [UsageConditions]
condsToAdd
  Maybe UsageConditions
latestAcceptedConds_ <- Connection -> IO (Maybe UsageConditions)
getLatestAcceptedConditions Connection
db
  [(Maybe PresetOperator, Maybe AServerOperator)]
ops <- NonEmpty PresetOperator
-> [ServerOperator' 'DBStored]
-> [(Maybe PresetOperator, Maybe AServerOperator)]
updatedServerOperators NonEmpty PresetOperator
presetOps ([ServerOperator' 'DBStored]
 -> [(Maybe PresetOperator, Maybe AServerOperator)])
-> IO [ServerOperator' 'DBStored]
-> IO [(Maybe PresetOperator, Maybe AServerOperator)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO [ServerOperator' 'DBStored]
getServerOperators_ Connection
db
  [(Maybe PresetOperator, Maybe AServerOperator)]
-> ((Maybe PresetOperator, Maybe AServerOperator)
    -> IO (Maybe PresetOperator, Maybe (ServerOperator' 'DBStored)))
-> IO [(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Maybe PresetOperator, Maybe AServerOperator)]
ops (((Maybe PresetOperator, Maybe AServerOperator)
  -> IO (Maybe PresetOperator, Maybe (ServerOperator' 'DBStored)))
 -> IO [(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))])
-> ((Maybe PresetOperator, Maybe AServerOperator)
    -> IO (Maybe PresetOperator, Maybe (ServerOperator' 'DBStored)))
-> IO [(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))]
forall a b. (a -> b) -> a -> b
$ (Maybe AServerOperator -> IO (Maybe (ServerOperator' 'DBStored)))
-> (Maybe PresetOperator, Maybe AServerOperator)
-> IO (Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> (Maybe PresetOperator, a) -> f (Maybe PresetOperator, b)
traverse ((Maybe AServerOperator -> IO (Maybe (ServerOperator' 'DBStored)))
 -> (Maybe PresetOperator, Maybe AServerOperator)
 -> IO (Maybe PresetOperator, Maybe (ServerOperator' 'DBStored)))
-> (Maybe AServerOperator
    -> IO (Maybe (ServerOperator' 'DBStored)))
-> (Maybe PresetOperator, Maybe AServerOperator)
-> IO (Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))
forall a b. (a -> b) -> a -> b
$ (AServerOperator -> IO (ServerOperator' 'DBStored))
-> Maybe AServerOperator -> IO (Maybe (ServerOperator' 'DBStored))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM ((AServerOperator -> IO (ServerOperator' 'DBStored))
 -> Maybe AServerOperator -> IO (Maybe (ServerOperator' 'DBStored)))
-> (AServerOperator -> IO (ServerOperator' 'DBStored))
-> Maybe AServerOperator
-> IO (Maybe (ServerOperator' 'DBStored))
forall a b. (a -> b) -> a -> b
$ \(ASO SDBStored s
_ ServerOperator' s
op) ->
    -- traverse for tuple, mapM for Maybe
    case ServerOperator' s -> DBEntityId' s
forall (s :: DBStored). ServerOperator' s -> DBEntityId' s
operatorId ServerOperator' s
op of
      DBEntityId' s
DBNewEntity -> NewServerOperator -> IO (ServerOperator' 'DBStored)
insertOperator ServerOperator' s
NewServerOperator
op
      DBEntityId UserId
_ -> do
        ServerOperator' 'DBStored -> IO ()
updateOperator ServerOperator' s
ServerOperator' 'DBStored
op
        Connection
-> ServerOperator' 'DBStored
-> UsageConditions
-> Maybe UsageConditions
-> UTCTime
-> IO ConditionsAcceptance
getOperatorConditions_ Connection
db ServerOperator' s
ServerOperator' 'DBStored
op UsageConditions
currentConds Maybe UsageConditions
latestAcceptedConds_ UTCTime
now IO ConditionsAcceptance
-> (ConditionsAcceptance -> IO (ServerOperator' 'DBStored))
-> IO (ServerOperator' 'DBStored)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          CARequired (Just UTCTime
ts) | UTCTime
ts UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
now -> ServerOperator' 'DBStored
-> UsageConditions -> UTCTime -> IO (ServerOperator' 'DBStored)
autoAcceptConditions ServerOperator' s
ServerOperator' 'DBStored
op UsageConditions
currentConds UTCTime
now
          ConditionsAcceptance
ca -> ServerOperator' 'DBStored -> IO (ServerOperator' 'DBStored)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerOperator' s
op {conditionsAcceptance = ca}
  where
    insertConditions :: UsageConditions -> IO ()
insertConditions UsageConditions {UserId
conditionsId :: UserId
conditionsId :: UsageConditions -> UserId
conditionsId, ContactName
conditionsCommit :: ContactName
conditionsCommit :: UsageConditions -> ContactName
conditionsCommit, Maybe UTCTime
notifiedAt :: Maybe UTCTime
notifiedAt :: UsageConditions -> Maybe UTCTime
notifiedAt, UTCTime
createdAt :: UTCTime
createdAt :: UsageConditions -> UTCTime
createdAt} =
      Connection
-> Query -> (UserId, ContactName, Maybe UTCTime, UTCTime) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
        Connection
db
        [sql|
          INSERT INTO usage_conditions
            (usage_conditions_id, conditions_commit, notified_at, created_at)
          VALUES (?,?,?,?)
        |]
        (UserId
conditionsId, ContactName
conditionsCommit, Maybe UTCTime
notifiedAt, UTCTime
createdAt)
    updateOperator :: ServerOperator -> IO ()
    updateOperator :: ServerOperator' 'DBStored -> IO ()
updateOperator ServerOperator {DBEntityId' 'DBStored
operatorId :: forall (s :: DBStored). ServerOperator' s -> DBEntityId' s
operatorId :: DBEntityId' 'DBStored
operatorId, ContactName
tradeName :: ContactName
tradeName :: forall (s :: DBStored). ServerOperator' s -> ContactName
tradeName, Maybe ContactName
legalName :: Maybe ContactName
legalName :: forall (s :: DBStored). ServerOperator' s -> Maybe ContactName
legalName, [ContactName]
serverDomains :: [ContactName]
serverDomains :: forall (s :: DBStored). ServerOperator' s -> [ContactName]
serverDomains, Bool
enabled :: forall (s :: DBStored). ServerOperator' s -> Bool
enabled :: Bool
enabled, ServerRoles
smpRoles :: forall (s :: DBStored). ServerOperator' s -> ServerRoles
smpRoles :: ServerRoles
smpRoles, ServerRoles
xftpRoles :: forall (s :: DBStored). ServerOperator' s -> ServerRoles
xftpRoles :: ServerRoles
xftpRoles} =
      Connection
-> Query
-> (ContactName, Maybe ContactName, ContactName, BoolInt, BoolInt,
    BoolInt, BoolInt, BoolInt, DBEntityId' 'DBStored)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
        Connection
db
        [sql|
          UPDATE server_operators
          SET trade_name = ?, legal_name = ?, server_domains = ?, enabled = ?, smp_role_storage = ?, smp_role_proxy = ?, xftp_role_storage = ?, xftp_role_proxy = ?
          WHERE server_operator_id = ?
        |]
        (ContactName
tradeName, Maybe ContactName
legalName, ContactName -> [ContactName] -> ContactName
T.intercalate ContactName
"," [ContactName]
serverDomains, Bool -> BoolInt
BI Bool
enabled, Bool -> BoolInt
BI (ServerRoles -> Bool
storage ServerRoles
smpRoles), Bool -> BoolInt
BI (ServerRoles -> Bool
proxy ServerRoles
smpRoles), Bool -> BoolInt
BI (ServerRoles -> Bool
storage ServerRoles
xftpRoles), Bool -> BoolInt
BI (ServerRoles -> Bool
proxy ServerRoles
xftpRoles), DBEntityId' 'DBStored
operatorId)
    insertOperator :: NewServerOperator -> IO ServerOperator
    insertOperator :: NewServerOperator -> IO (ServerOperator' 'DBStored)
insertOperator op :: NewServerOperator
op@ServerOperator {Maybe OperatorTag
operatorTag :: Maybe OperatorTag
operatorTag :: forall (s :: DBStored). ServerOperator' s -> Maybe OperatorTag
operatorTag, ContactName
tradeName :: forall (s :: DBStored). ServerOperator' s -> ContactName
tradeName :: ContactName
tradeName, Maybe ContactName
legalName :: forall (s :: DBStored). ServerOperator' s -> Maybe ContactName
legalName :: Maybe ContactName
legalName, [ContactName]
serverDomains :: forall (s :: DBStored). ServerOperator' s -> [ContactName]
serverDomains :: [ContactName]
serverDomains, Bool
enabled :: forall (s :: DBStored). ServerOperator' s -> Bool
enabled :: Bool
enabled, ServerRoles
smpRoles :: forall (s :: DBStored). ServerOperator' s -> ServerRoles
smpRoles :: ServerRoles
smpRoles, ServerRoles
xftpRoles :: forall (s :: DBStored). ServerOperator' s -> ServerRoles
xftpRoles :: ServerRoles
xftpRoles} = do
      Connection
-> Query
-> (Maybe OperatorTag, ContactName, Maybe ContactName, ContactName,
    BoolInt, BoolInt, BoolInt, BoolInt, BoolInt)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
        Connection
db
        [sql|
          INSERT INTO server_operators
            (server_operator_tag, trade_name, legal_name, server_domains, enabled, smp_role_storage, smp_role_proxy, xftp_role_storage, xftp_role_proxy)
          VALUES (?,?,?,?,?,?,?,?,?)
        |]
        (Maybe OperatorTag
operatorTag, ContactName
tradeName, Maybe ContactName
legalName, ContactName -> [ContactName] -> ContactName
T.intercalate ContactName
"," [ContactName]
serverDomains, Bool -> BoolInt
BI Bool
enabled, Bool -> BoolInt
BI (ServerRoles -> Bool
storage ServerRoles
smpRoles), Bool -> BoolInt
BI (ServerRoles -> Bool
proxy ServerRoles
smpRoles), Bool -> BoolInt
BI (ServerRoles -> Bool
storage ServerRoles
xftpRoles), Bool -> BoolInt
BI (ServerRoles -> Bool
proxy ServerRoles
xftpRoles))
      UserId
opId <- Connection -> IO UserId
insertedRowId Connection
db
      ServerOperator' 'DBStored -> IO (ServerOperator' 'DBStored)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NewServerOperator
op {operatorId = DBEntityId opId}
    autoAcceptConditions :: ServerOperator' 'DBStored
-> UsageConditions -> UTCTime -> IO (ServerOperator' 'DBStored)
autoAcceptConditions ServerOperator' 'DBStored
op UsageConditions {ContactName
conditionsCommit :: UsageConditions -> ContactName
conditionsCommit :: ContactName
conditionsCommit} UTCTime
now =
      Connection
-> ServerOperator' 'DBStored
-> ContactName
-> UTCTime
-> Bool
-> IO ()
acceptConditions_ Connection
db ServerOperator' 'DBStored
op ContactName
conditionsCommit UTCTime
now Bool
True
        IO ()
-> ServerOperator' 'DBStored -> IO (ServerOperator' 'DBStored)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ServerOperator' 'DBStored
op {conditionsAcceptance = CAAccepted (Just now) True}

serverOperatorQuery :: Query
serverOperatorQuery :: Query
serverOperatorQuery =
  [sql|
    SELECT server_operator_id, server_operator_tag, trade_name, legal_name,
      server_domains, enabled, smp_role_storage, smp_role_proxy, xftp_role_storage, xftp_role_proxy
    FROM server_operators
  |]

getServerOperators_ :: DB.Connection -> IO [ServerOperator]
getServerOperators_ :: Connection -> IO [ServerOperator' 'DBStored]
getServerOperators_ Connection
db = (((DBEntityId' 'DBStored, Maybe OperatorTag, ContactName,
   Maybe ContactName, ContactName, BoolInt)
  :. ((BoolInt, BoolInt) :. (BoolInt, BoolInt)))
 -> ServerOperator' 'DBStored)
-> [(DBEntityId' 'DBStored, Maybe OperatorTag, ContactName,
     Maybe ContactName, ContactName, BoolInt)
    :. ((BoolInt, BoolInt) :. (BoolInt, BoolInt))]
-> [ServerOperator' 'DBStored]
forall a b. (a -> b) -> [a] -> [b]
map ((DBEntityId' 'DBStored, Maybe OperatorTag, ContactName,
  Maybe ContactName, ContactName, BoolInt)
 :. ((BoolInt, BoolInt) :. (BoolInt, BoolInt)))
-> ServerOperator' 'DBStored
toServerOperator ([(DBEntityId' 'DBStored, Maybe OperatorTag, ContactName,
   Maybe ContactName, ContactName, BoolInt)
  :. ((BoolInt, BoolInt) :. (BoolInt, BoolInt))]
 -> [ServerOperator' 'DBStored])
-> IO
     [(DBEntityId' 'DBStored, Maybe OperatorTag, ContactName,
       Maybe ContactName, ContactName, BoolInt)
      :. ((BoolInt, BoolInt) :. (BoolInt, BoolInt))]
-> IO [ServerOperator' 'DBStored]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> Query
-> IO
     [(DBEntityId' 'DBStored, Maybe OperatorTag, ContactName,
       Maybe ContactName, ContactName, BoolInt)
      :. ((BoolInt, BoolInt) :. (BoolInt, BoolInt))]
forall r. FromRow r => Connection -> Query -> IO [r]
DB.query_ Connection
db Query
serverOperatorQuery

toServerOperator :: (DBEntityId, Maybe OperatorTag, Text, Maybe Text, Text, BoolInt) :. (BoolInt, BoolInt) :. (BoolInt, BoolInt) -> ServerOperator
toServerOperator :: ((DBEntityId' 'DBStored, Maybe OperatorTag, ContactName,
  Maybe ContactName, ContactName, BoolInt)
 :. ((BoolInt, BoolInt) :. (BoolInt, BoolInt)))
-> ServerOperator' 'DBStored
toServerOperator ((DBEntityId' 'DBStored
operatorId, Maybe OperatorTag
operatorTag, ContactName
tradeName, Maybe ContactName
legalName, ContactName
domains, BI Bool
enabled) :. (BoolInt, BoolInt)
smpRoles' :. (BoolInt, BoolInt)
xftpRoles') =
  ServerOperator
    { DBEntityId' 'DBStored
operatorId :: DBEntityId' 'DBStored
operatorId :: DBEntityId' 'DBStored
operatorId,
      Maybe OperatorTag
operatorTag :: Maybe OperatorTag
operatorTag :: Maybe OperatorTag
operatorTag,
      ContactName
tradeName :: ContactName
tradeName :: ContactName
tradeName,
      Maybe ContactName
legalName :: Maybe ContactName
legalName :: Maybe ContactName
legalName,
      serverDomains :: [ContactName]
serverDomains = HasCallStack => ContactName -> ContactName -> [ContactName]
ContactName -> ContactName -> [ContactName]
T.splitOn ContactName
"," ContactName
domains,
      conditionsAcceptance :: ConditionsAcceptance
conditionsAcceptance = Maybe UTCTime -> ConditionsAcceptance
CARequired Maybe UTCTime
forall a. Maybe a
Nothing,
      Bool
enabled :: Bool
enabled :: Bool
enabled,
      smpRoles :: ServerRoles
smpRoles = (BoolInt, BoolInt) -> ServerRoles
serverRoles (BoolInt, BoolInt)
smpRoles',
      xftpRoles :: ServerRoles
xftpRoles = (BoolInt, BoolInt) -> ServerRoles
serverRoles (BoolInt, BoolInt)
xftpRoles'
    }
  where
    serverRoles :: (BoolInt, BoolInt) -> ServerRoles
serverRoles (BI Bool
storage, BI Bool
proxy) = ServerRoles {Bool
storage :: Bool
storage :: Bool
storage, Bool
proxy :: Bool
proxy :: Bool
proxy}

getOperatorConditions_ :: DB.Connection -> ServerOperator -> UsageConditions -> Maybe UsageConditions -> UTCTime -> IO ConditionsAcceptance
getOperatorConditions_ :: Connection
-> ServerOperator' 'DBStored
-> UsageConditions
-> Maybe UsageConditions
-> UTCTime
-> IO ConditionsAcceptance
getOperatorConditions_ Connection
db ServerOperator {DBEntityId' 'DBStored
operatorId :: forall (s :: DBStored). ServerOperator' s -> DBEntityId' s
operatorId :: DBEntityId' 'DBStored
operatorId} UsageConditions {conditionsCommit :: UsageConditions -> ContactName
conditionsCommit = ContactName
currentCommit, UTCTime
createdAt :: UsageConditions -> UTCTime
createdAt :: UTCTime
createdAt, Maybe UTCTime
notifiedAt :: UsageConditions -> Maybe UTCTime
notifiedAt :: Maybe UTCTime
notifiedAt} Maybe UsageConditions
latestAcceptedConds_ UTCTime
now = do
  case Maybe UsageConditions
latestAcceptedConds_ of
    Maybe UsageConditions
Nothing -> ConditionsAcceptance -> IO ConditionsAcceptance
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConditionsAcceptance -> IO ConditionsAcceptance)
-> ConditionsAcceptance -> IO ConditionsAcceptance
forall a b. (a -> b) -> a -> b
$ Maybe UTCTime -> ConditionsAcceptance
CARequired Maybe UTCTime
forall a. Maybe a
Nothing -- no conditions accepted by any operator
    Just UsageConditions {conditionsCommit :: UsageConditions -> ContactName
conditionsCommit = ContactName
latestAcceptedCommit} -> do
      Maybe (ContactName, Maybe UTCTime, BoolInt)
operatorAcceptedConds_ <-
        ((ContactName, Maybe UTCTime, BoolInt)
 -> (ContactName, Maybe UTCTime, BoolInt))
-> IO [(ContactName, Maybe UTCTime, BoolInt)]
-> IO (Maybe (ContactName, Maybe UTCTime, BoolInt))
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow (ContactName, Maybe UTCTime, BoolInt)
-> (ContactName, Maybe UTCTime, BoolInt)
forall a. a -> a
id (IO [(ContactName, Maybe UTCTime, BoolInt)]
 -> IO (Maybe (ContactName, Maybe UTCTime, BoolInt)))
-> IO [(ContactName, Maybe UTCTime, BoolInt)]
-> IO (Maybe (ContactName, Maybe UTCTime, BoolInt))
forall a b. (a -> b) -> a -> b
$
          Connection
-> Query
-> Only (DBEntityId' 'DBStored)
-> IO [(ContactName, Maybe UTCTime, BoolInt)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
            Connection
db
            [sql|
              SELECT conditions_commit, accepted_at, auto_accepted
              FROM operator_usage_conditions
              WHERE server_operator_id = ?
              ORDER BY operator_usage_conditions_id DESC
              LIMIT 1
            |]
            (DBEntityId' 'DBStored -> Only (DBEntityId' 'DBStored)
forall a. a -> Only a
Only DBEntityId' 'DBStored
operatorId)
      ConditionsAcceptance -> IO ConditionsAcceptance
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConditionsAcceptance -> IO ConditionsAcceptance)
-> ConditionsAcceptance -> IO ConditionsAcceptance
forall a b. (a -> b) -> a -> b
$ case Maybe (ContactName, Maybe UTCTime, BoolInt)
operatorAcceptedConds_ of
        Just (ContactName
operatorCommit, Maybe UTCTime
acceptedAt_, BI Bool
autoAccept)
          | ContactName
operatorCommit ContactName -> ContactName -> Bool
forall a. Eq a => a -> a -> Bool
/= ContactName
latestAcceptedCommit -> Maybe UTCTime -> ConditionsAcceptance
CARequired Maybe UTCTime
forall a. Maybe a
Nothing -- TODO should we consider this operator disabled?
          | ContactName
currentCommit ContactName -> ContactName -> Bool
forall a. Eq a => a -> a -> Bool
/= ContactName
latestAcceptedCommit -> Maybe UTCTime -> ConditionsAcceptance
CARequired (Maybe UTCTime -> ConditionsAcceptance)
-> Maybe UTCTime -> ConditionsAcceptance
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> Maybe UTCTime
conditionsRequiredOrDeadline UTCTime
createdAt (UTCTime -> Maybe UTCTime -> UTCTime
forall a. a -> Maybe a -> a
fromMaybe UTCTime
now Maybe UTCTime
notifiedAt)
          | Bool
otherwise -> Maybe UTCTime -> Bool -> ConditionsAcceptance
CAAccepted Maybe UTCTime
acceptedAt_ Bool
autoAccept
        Maybe (ContactName, Maybe UTCTime, BoolInt)
_ -> Maybe UTCTime -> ConditionsAcceptance
CARequired Maybe UTCTime
forall a. Maybe a
Nothing -- no conditions were accepted for this operator

getCurrentUsageConditions :: DB.Connection -> ExceptT StoreError IO UsageConditions
getCurrentUsageConditions :: Connection -> ExceptT StoreError IO UsageConditions
getCurrentUsageConditions Connection
db =
  IO (Either StoreError UsageConditions)
-> ExceptT StoreError IO UsageConditions
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError UsageConditions)
 -> ExceptT StoreError IO UsageConditions)
-> (IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
    -> IO (Either StoreError UsageConditions))
-> IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
-> ExceptT StoreError IO UsageConditions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UserId, ContactName, Maybe UTCTime, UTCTime) -> UsageConditions)
-> StoreError
-> IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
-> IO (Either StoreError UsageConditions)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow (UserId, ContactName, Maybe UTCTime, UTCTime) -> UsageConditions
toUsageConditions StoreError
SEUsageConditionsNotFound (IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
 -> ExceptT StoreError IO UsageConditions)
-> IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
-> ExceptT StoreError IO UsageConditions
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query -> IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
forall r. FromRow r => Connection -> Query -> IO [r]
DB.query_ Connection
db (Query
usageCondsQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" DESC LIMIT 1")

usageCondsQuery :: Query
usageCondsQuery :: Query
usageCondsQuery =
  [sql|
    SELECT usage_conditions_id, conditions_commit, notified_at, created_at
    FROM usage_conditions
    ORDER BY usage_conditions_id
  |]

toUsageConditions :: (Int64, Text, Maybe UTCTime, UTCTime) -> UsageConditions
toUsageConditions :: (UserId, ContactName, Maybe UTCTime, UTCTime) -> UsageConditions
toUsageConditions (UserId
conditionsId, ContactName
conditionsCommit, Maybe UTCTime
notifiedAt, UTCTime
createdAt) =
  UsageConditions {UserId
conditionsId :: UserId
conditionsId :: UserId
conditionsId, ContactName
conditionsCommit :: ContactName
conditionsCommit :: ContactName
conditionsCommit, Maybe UTCTime
notifiedAt :: Maybe UTCTime
notifiedAt :: Maybe UTCTime
notifiedAt, UTCTime
createdAt :: UTCTime
createdAt :: UTCTime
createdAt}

getLatestAcceptedConditions :: DB.Connection -> IO (Maybe UsageConditions)
getLatestAcceptedConditions :: Connection -> IO (Maybe UsageConditions)
getLatestAcceptedConditions Connection
db =
  ((UserId, ContactName, Maybe UTCTime, UTCTime) -> UsageConditions)
-> IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
-> IO (Maybe UsageConditions)
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow (UserId, ContactName, Maybe UTCTime, UTCTime) -> UsageConditions
toUsageConditions (IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
 -> IO (Maybe UsageConditions))
-> IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
-> IO (Maybe UsageConditions)
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query -> IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
forall r. FromRow r => Connection -> Query -> IO [r]
DB.query_
      Connection
db
      [sql|
        SELECT usage_conditions_id, conditions_commit, notified_at, created_at
        FROM usage_conditions
        WHERE conditions_commit = (
          SELECT conditions_commit
          FROM operator_usage_conditions
          ORDER BY accepted_at DESC
          LIMIT 1
        )
      |]

setConditionsNotified :: DB.Connection -> Int64 -> UTCTime -> IO ()
setConditionsNotified :: Connection -> UserId -> UTCTime -> IO ()
setConditionsNotified Connection
db UserId
condId UTCTime
notifiedAt =
  Connection -> Query -> (UTCTime, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"UPDATE usage_conditions SET notified_at = ? WHERE usage_conditions_id = ?" (UTCTime
notifiedAt, UserId
condId)

acceptConditions :: DB.Connection -> Int64 -> NonEmpty Int64 -> UTCTime -> ExceptT StoreError IO ()
acceptConditions :: Connection
-> UserId -> NonEmpty UserId -> UTCTime -> ExceptT StoreError IO ()
acceptConditions Connection
db UserId
condId NonEmpty UserId
opIds UTCTime
acceptedAt = do
  UsageConditions {ContactName
conditionsCommit :: UsageConditions -> ContactName
conditionsCommit :: ContactName
conditionsCommit} <- Connection -> UserId -> ExceptT StoreError IO UsageConditions
getUsageConditionsById_ Connection
db UserId
condId
  NonEmpty (ServerOperator' 'DBStored)
operators <- (UserId -> ExceptT StoreError IO (ServerOperator' 'DBStored))
-> NonEmpty UserId
-> ExceptT StoreError IO (NonEmpty (ServerOperator' 'DBStored))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM UserId -> ExceptT StoreError IO (ServerOperator' 'DBStored)
getServerOperator_ NonEmpty UserId
opIds
  IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ NonEmpty (ServerOperator' 'DBStored)
-> (ServerOperator' 'DBStored -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (ServerOperator' 'DBStored)
operators ((ServerOperator' 'DBStored -> IO ()) -> IO ())
-> (ServerOperator' 'DBStored -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ServerOperator' 'DBStored
op -> Connection
-> ServerOperator' 'DBStored
-> ContactName
-> UTCTime
-> Bool
-> IO ()
acceptConditions_ Connection
db ServerOperator' 'DBStored
op ContactName
conditionsCommit UTCTime
acceptedAt Bool
False
  where
    getServerOperator_ :: UserId -> ExceptT StoreError IO (ServerOperator' 'DBStored)
getServerOperator_ UserId
opId =
      IO (Either StoreError (ServerOperator' 'DBStored))
-> ExceptT StoreError IO (ServerOperator' 'DBStored)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError (ServerOperator' 'DBStored))
 -> ExceptT StoreError IO (ServerOperator' 'DBStored))
-> IO (Either StoreError (ServerOperator' 'DBStored))
-> ExceptT StoreError IO (ServerOperator' 'DBStored)
forall a b. (a -> b) -> a -> b
$
        (((DBEntityId' 'DBStored, Maybe OperatorTag, ContactName,
   Maybe ContactName, ContactName, BoolInt)
  :. ((BoolInt, BoolInt) :. (BoolInt, BoolInt)))
 -> ServerOperator' 'DBStored)
-> StoreError
-> IO
     [(DBEntityId' 'DBStored, Maybe OperatorTag, ContactName,
       Maybe ContactName, ContactName, BoolInt)
      :. ((BoolInt, BoolInt) :. (BoolInt, BoolInt))]
-> IO (Either StoreError (ServerOperator' 'DBStored))
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow ((DBEntityId' 'DBStored, Maybe OperatorTag, ContactName,
  Maybe ContactName, ContactName, BoolInt)
 :. ((BoolInt, BoolInt) :. (BoolInt, BoolInt)))
-> ServerOperator' 'DBStored
toServerOperator (UserId -> StoreError
SEOperatorNotFound UserId
opId) (IO
   [(DBEntityId' 'DBStored, Maybe OperatorTag, ContactName,
     Maybe ContactName, ContactName, BoolInt)
    :. ((BoolInt, BoolInt) :. (BoolInt, BoolInt))]
 -> IO (Either StoreError (ServerOperator' 'DBStored)))
-> IO
     [(DBEntityId' 'DBStored, Maybe OperatorTag, ContactName,
       Maybe ContactName, ContactName, BoolInt)
      :. ((BoolInt, BoolInt) :. (BoolInt, BoolInt))]
-> IO (Either StoreError (ServerOperator' 'DBStored))
forall a b. (a -> b) -> a -> b
$
          Connection
-> Query
-> Only UserId
-> IO
     [(DBEntityId' 'DBStored, Maybe OperatorTag, ContactName,
       Maybe ContactName, ContactName, BoolInt)
      :. ((BoolInt, BoolInt) :. (BoolInt, BoolInt))]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
serverOperatorQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" WHERE server_operator_id = ?") (UserId -> Only UserId
forall a. a -> Only a
Only UserId
opId)

acceptConditions_ :: DB.Connection -> ServerOperator -> Text -> UTCTime -> Bool -> IO ()
acceptConditions_ :: Connection
-> ServerOperator' 'DBStored
-> ContactName
-> UTCTime
-> Bool
-> IO ()
acceptConditions_ Connection
db ServerOperator {DBEntityId' 'DBStored
operatorId :: forall (s :: DBStored). ServerOperator' s -> DBEntityId' s
operatorId :: DBEntityId' 'DBStored
operatorId, Maybe OperatorTag
operatorTag :: forall (s :: DBStored). ServerOperator' s -> Maybe OperatorTag
operatorTag :: Maybe OperatorTag
operatorTag} ContactName
conditionsCommit UTCTime
acceptedAt Bool
autoAccepted = do
  Maybe (Maybe UTCTime)
acceptedAt_ :: Maybe (Maybe UTCTime) <- (Only (Maybe UTCTime) -> Maybe UTCTime)
-> IO [Only (Maybe UTCTime)] -> IO (Maybe (Maybe UTCTime))
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow Only (Maybe UTCTime) -> Maybe UTCTime
forall a. Only a -> a
fromOnly (IO [Only (Maybe UTCTime)] -> IO (Maybe (Maybe UTCTime)))
-> IO [Only (Maybe UTCTime)] -> IO (Maybe (Maybe UTCTime))
forall a b. (a -> b) -> a -> b
$ Connection
-> Query
-> (DBEntityId' 'DBStored, ContactName)
-> IO [Only (Maybe UTCTime)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db Query
"SELECT accepted_at FROM operator_usage_conditions WHERE server_operator_id = ? AND conditions_commit = ?" (DBEntityId' 'DBStored
operatorId, ContactName
conditionsCommit)
  case Maybe (Maybe UTCTime)
acceptedAt_ of
    Just Maybe UTCTime
Nothing ->
      Connection
-> Query
-> (DBEntityId' 'DBStored, Maybe OperatorTag, ContactName, UTCTime,
    BoolInt, UTCTime, BoolInt)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
        Connection
db
        (Query
q Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
"ON CONFLICT (server_operator_id, conditions_commit) DO UPDATE SET accepted_at = ?, auto_accepted = ?")
        (DBEntityId' 'DBStored
operatorId, Maybe OperatorTag
operatorTag, ContactName
conditionsCommit, UTCTime
acceptedAt, Bool -> BoolInt
BI Bool
autoAccepted, UTCTime
acceptedAt, Bool -> BoolInt
BI Bool
autoAccepted)
    Just (Just UTCTime
_) ->
      Connection
-> Query
-> (DBEntityId' 'DBStored, Maybe OperatorTag, ContactName, UTCTime,
    BoolInt)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
        Connection
db
        (Query
q Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
"ON CONFLICT (server_operator_id, conditions_commit) DO NOTHING")
        (DBEntityId' 'DBStored
operatorId, Maybe OperatorTag
operatorTag, ContactName
conditionsCommit, UTCTime
acceptedAt, Bool -> BoolInt
BI Bool
autoAccepted)
    Maybe (Maybe UTCTime)
Nothing ->
      Connection
-> Query
-> (DBEntityId' 'DBStored, Maybe OperatorTag, ContactName, UTCTime,
    BoolInt)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
        Connection
db
        Query
q
        (DBEntityId' 'DBStored
operatorId, Maybe OperatorTag
operatorTag, ContactName
conditionsCommit, UTCTime
acceptedAt, Bool -> BoolInt
BI Bool
autoAccepted)
  where
    q :: Query
q =
      [sql|
        INSERT INTO operator_usage_conditions
          (server_operator_id, server_operator_tag, conditions_commit, accepted_at, auto_accepted)
        VALUES (?,?,?,?,?)
      |]

getUsageConditionsById_ :: DB.Connection -> Int64 -> ExceptT StoreError IO UsageConditions
getUsageConditionsById_ :: Connection -> UserId -> ExceptT StoreError IO UsageConditions
getUsageConditionsById_ Connection
db UserId
conditionsId =
  IO (Either StoreError UsageConditions)
-> ExceptT StoreError IO UsageConditions
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError UsageConditions)
 -> ExceptT StoreError IO UsageConditions)
-> (IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
    -> IO (Either StoreError UsageConditions))
-> IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
-> ExceptT StoreError IO UsageConditions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UserId, ContactName, Maybe UTCTime, UTCTime) -> UsageConditions)
-> StoreError
-> IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
-> IO (Either StoreError UsageConditions)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow (UserId, ContactName, Maybe UTCTime, UTCTime) -> UsageConditions
toUsageConditions StoreError
SEUsageConditionsNotFound (IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
 -> ExceptT StoreError IO UsageConditions)
-> IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
-> ExceptT StoreError IO UsageConditions
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only UserId
-> IO [(UserId, ContactName, Maybe UTCTime, UTCTime)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
      Connection
db
      [sql|
        SELECT usage_conditions_id, conditions_commit, notified_at, created_at
        FROM usage_conditions
        WHERE usage_conditions_id = ?
      |]
      (UserId -> Only UserId
forall a. a -> Only a
Only UserId
conditionsId)

setUserServers :: DB.Connection -> User -> UTCTime -> UpdatedUserOperatorServers -> ExceptT StoreError IO UserOperatorServers
setUserServers :: Connection
-> User
-> UTCTime
-> UpdatedUserOperatorServers
-> ExceptT StoreError IO UserOperatorServers
setUserServers Connection
db User
user UTCTime
ts = StoreError
-> ExceptT StoreError IO UserOperatorServers
-> ExceptT StoreError IO UserOperatorServers
forall a.
StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a
checkConstraint StoreError
SEUniqueID (ExceptT StoreError IO UserOperatorServers
 -> ExceptT StoreError IO UserOperatorServers)
-> (UpdatedUserOperatorServers
    -> ExceptT StoreError IO UserOperatorServers)
-> UpdatedUserOperatorServers
-> ExceptT StoreError IO UserOperatorServers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO UserOperatorServers -> ExceptT StoreError IO UserOperatorServers
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UserOperatorServers
 -> ExceptT StoreError IO UserOperatorServers)
-> (UpdatedUserOperatorServers -> IO UserOperatorServers)
-> UpdatedUserOperatorServers
-> ExceptT StoreError IO UserOperatorServers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection
-> User
-> UTCTime
-> UpdatedUserOperatorServers
-> IO UserOperatorServers
setUserServers' Connection
db User
user UTCTime
ts

setUserServers' :: DB.Connection -> User -> UTCTime -> UpdatedUserOperatorServers -> IO UserOperatorServers
setUserServers' :: Connection
-> User
-> UTCTime
-> UpdatedUserOperatorServers
-> IO UserOperatorServers
setUserServers' Connection
db user :: User
user@User {UserId
userId :: User -> UserId
userId :: UserId
userId} UTCTime
ts UpdatedUserOperatorServers {Maybe (ServerOperator' 'DBStored)
operator :: Maybe (ServerOperator' 'DBStored)
operator :: UpdatedUserOperatorServers -> Maybe (ServerOperator' 'DBStored)
operator, [AUserServer 'PSMP]
smpServers :: [AUserServer 'PSMP]
smpServers :: UpdatedUserOperatorServers -> [AUserServer 'PSMP]
smpServers, [AUserServer 'PXFTP]
xftpServers :: [AUserServer 'PXFTP]
xftpServers :: UpdatedUserOperatorServers -> [AUserServer 'PXFTP]
xftpServers} = do
  (ServerOperator' 'DBStored -> IO ())
-> Maybe (ServerOperator' 'DBStored) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Connection -> UTCTime -> ServerOperator' 'DBStored -> IO ()
updateServerOperator Connection
db UTCTime
ts) Maybe (ServerOperator' 'DBStored)
operator
  [UserServer 'PSMP]
smpSrvs' <- [Maybe (UserServer 'PSMP)] -> [UserServer 'PSMP]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (UserServer 'PSMP)] -> [UserServer 'PSMP])
-> IO [Maybe (UserServer 'PSMP)] -> IO [UserServer 'PSMP]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AUserServer 'PSMP -> IO (Maybe (UserServer 'PSMP)))
-> [AUserServer 'PSMP] -> IO [Maybe (UserServer 'PSMP)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (SProtocolType 'PSMP
-> AUserServer 'PSMP -> IO (Maybe (UserServer 'PSMP))
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p -> AUserServer p -> IO (Maybe (UserServer p))
upsertOrDelete SProtocolType 'PSMP
SPSMP) [AUserServer 'PSMP]
smpServers
  [UserServer 'PXFTP]
xftpSrvs' <- [Maybe (UserServer 'PXFTP)] -> [UserServer 'PXFTP]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (UserServer 'PXFTP)] -> [UserServer 'PXFTP])
-> IO [Maybe (UserServer 'PXFTP)] -> IO [UserServer 'PXFTP]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AUserServer 'PXFTP -> IO (Maybe (UserServer 'PXFTP)))
-> [AUserServer 'PXFTP] -> IO [Maybe (UserServer 'PXFTP)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (SProtocolType 'PXFTP
-> AUserServer 'PXFTP -> IO (Maybe (UserServer 'PXFTP))
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p -> AUserServer p -> IO (Maybe (UserServer p))
upsertOrDelete SProtocolType 'PXFTP
SPXFTP) [AUserServer 'PXFTP]
xftpServers
  UserOperatorServers -> IO UserOperatorServers
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserOperatorServers {Maybe (ServerOperator' 'DBStored)
operator :: Maybe (ServerOperator' 'DBStored)
operator :: Maybe (ServerOperator' 'DBStored)
operator, smpServers :: [UserServer 'PSMP]
smpServers = [UserServer 'PSMP]
smpSrvs', xftpServers :: [UserServer 'PXFTP]
xftpServers = [UserServer 'PXFTP]
xftpSrvs'}
  where
    upsertOrDelete :: ProtocolTypeI p => SProtocolType p -> AUserServer p -> IO (Maybe (UserServer p))
    upsertOrDelete :: forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p -> AUserServer p -> IO (Maybe (UserServer p))
upsertOrDelete SProtocolType p
p (AUS SDBStored s
_ s :: UserServer' s p
s@UserServer {DBEntityId' s
serverId :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> DBEntityId' s
serverId :: DBEntityId' s
serverId, Bool
deleted :: forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
deleted :: Bool
deleted}) = case DBEntityId' s
serverId of
      DBEntityId' s
DBNewEntity
        | Bool
deleted -> Maybe (UserServer p) -> IO (Maybe (UserServer p))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (UserServer p)
forall a. Maybe a
Nothing
        | Bool
otherwise -> UserServer p -> Maybe (UserServer p)
forall a. a -> Maybe a
Just (UserServer p -> Maybe (UserServer p))
-> IO (UserServer p) -> IO (Maybe (UserServer p))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> SProtocolType p
-> User
-> UTCTime
-> NewUserServer p
-> IO (UserServer p)
forall (p :: ProtocolType).
ProtocolTypeI p =>
Connection
-> SProtocolType p
-> User
-> UTCTime
-> NewUserServer p
-> IO (UserServer p)
insertProtocolServer Connection
db SProtocolType p
p User
user UTCTime
ts UserServer' s p
NewUserServer p
s
      DBEntityId UserId
srvId
        | Bool
deleted -> Maybe (UserServer p)
forall a. Maybe a
Nothing Maybe (UserServer p) -> IO () -> IO (Maybe (UserServer p))
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Connection -> Query -> (UserId, UserId, BoolInt) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"DELETE FROM protocol_servers WHERE user_id = ? AND smp_server_id = ? AND preset = ?" (UserId
userId, UserId
srvId, Bool -> BoolInt
BI Bool
False)
        | Bool
otherwise -> UserServer p -> Maybe (UserServer p)
forall a. a -> Maybe a
Just UserServer' s p
UserServer p
s Maybe (UserServer p) -> IO () -> IO (Maybe (UserServer p))
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Connection -> SProtocolType p -> UTCTime -> UserServer p -> IO ()
forall (p :: ProtocolType).
ProtocolTypeI p =>
Connection -> SProtocolType p -> UTCTime -> UserServer p -> IO ()
updateProtocolServer Connection
db SProtocolType p
p UTCTime
ts UserServer' s p
UserServer p
s

createCall :: DB.Connection -> User -> Call -> UTCTime -> IO ()
createCall :: Connection -> User -> Call -> UTCTime -> IO ()
createCall Connection
db user :: User
user@User {UserId
userId :: User -> UserId
userId :: UserId
userId} Call {UserId
contactId :: UserId
contactId :: Call -> UserId
contactId, CallId
callId :: CallId
callId :: Call -> CallId
callId, ContactName
callUUID :: ContactName
callUUID :: Call -> ContactName
callUUID, UserId
chatItemId :: UserId
chatItemId :: Call -> UserId
chatItemId, CallState
callState :: CallState
callState :: Call -> CallState
callState} UTCTime
callTs = do
  UTCTime
currentTs <- IO UTCTime
getCurrentTime
  Connection -> User -> UserId -> IO ()
deleteCalls Connection
db User
user UserId
contactId
  Connection
-> Query
-> (UserId, CallId, ContactName, UserId, CallState, UTCTime,
    UserId, UTCTime, UTCTime)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      INSERT INTO calls
        (contact_id, shared_call_id, call_uuid, chat_item_id, call_state, call_ts, user_id, created_at, updated_at)
      VALUES (?,?,?,?,?,?,?,?,?)
    |]
    (UserId
contactId, CallId
callId, ContactName
callUUID, UserId
chatItemId, CallState
callState, UTCTime
callTs, UserId
userId, UTCTime
currentTs, UTCTime
currentTs)

deleteCalls :: DB.Connection -> User -> ContactId -> IO ()
deleteCalls :: Connection -> User -> UserId -> IO ()
deleteCalls Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} UserId
contactId = do
  Connection -> Query -> (UserId, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"DELETE FROM calls WHERE user_id = ? AND contact_id = ?" (UserId
userId, UserId
contactId)

getCalls :: DB.Connection -> IO [Call]
getCalls :: Connection -> IO [Call]
getCalls Connection
db =
  ((UserId, CallId, ContactName, UserId, CallState, UTCTime) -> Call)
-> [(UserId, CallId, ContactName, UserId, CallState, UTCTime)]
-> [Call]
forall a b. (a -> b) -> [a] -> [b]
map (UserId, CallId, ContactName, UserId, CallState, UTCTime) -> Call
toCall
    ([(UserId, CallId, ContactName, UserId, CallState, UTCTime)]
 -> [Call])
-> IO [(UserId, CallId, ContactName, UserId, CallState, UTCTime)]
-> IO [Call]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> Query
-> IO [(UserId, CallId, ContactName, UserId, CallState, UTCTime)]
forall r. FromRow r => Connection -> Query -> IO [r]
DB.query_
      Connection
db
      [sql|
        SELECT
          contact_id, shared_call_id, call_uuid, chat_item_id, call_state, call_ts
        FROM calls
        ORDER BY call_ts ASC
      |]
  where
    toCall :: (ContactId, CallId, Text, ChatItemId, CallState, UTCTime) -> Call
    toCall :: (UserId, CallId, ContactName, UserId, CallState, UTCTime) -> Call
toCall (UserId
contactId, CallId
callId, ContactName
callUUID, UserId
chatItemId, CallState
callState, UTCTime
callTs) = Call {UserId
contactId :: UserId
contactId :: UserId
contactId, CallId
callId :: CallId
callId :: CallId
callId, ContactName
callUUID :: ContactName
callUUID :: ContactName
callUUID, UserId
chatItemId :: UserId
chatItemId :: UserId
chatItemId, CallState
callState :: CallState
callState :: CallState
callState, UTCTime
callTs :: UTCTime
callTs :: UTCTime
callTs}

createCommand :: DB.Connection -> User -> Maybe Int64 -> CommandFunction -> IO CommandId
createCommand :: Connection -> User -> Maybe UserId -> CommandFunction -> IO UserId
createCommand Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} Maybe UserId
connId CommandFunction
commandFunction = do
  UTCTime
currentTs <- IO UTCTime
getCurrentTime
  Connection
-> Query
-> (Maybe UserId, CommandFunction, CommandStatus, UserId, UTCTime,
    UTCTime)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      INSERT INTO commands (connection_id, command_function, command_status, user_id, created_at, updated_at)
      VALUES (?,?,?,?,?,?)
    |]
    (Maybe UserId
connId, CommandFunction
commandFunction, CommandStatus
CSCreated, UserId
userId, UTCTime
currentTs, UTCTime
currentTs)
  Connection -> IO UserId
insertedRowId Connection
db

deleteCommand :: DB.Connection -> User -> CommandId -> IO ()
deleteCommand :: Connection -> User -> UserId -> IO ()
deleteCommand Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} UserId
cmdId =
  Connection -> Query -> (UserId, UserId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"DELETE FROM commands WHERE user_id = ? AND command_id = ?" (UserId
userId, UserId
cmdId)

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

getCommandDataByCorrId :: DB.Connection -> User -> ACorrId -> IO (Maybe CommandData)
getCommandDataByCorrId :: Connection -> User -> ConnId -> IO (Maybe CommandData)
getCommandDataByCorrId Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} ConnId
corrId =
  ((UserId, Maybe UserId, CommandFunction, CommandStatus)
 -> CommandData)
-> IO [(UserId, Maybe UserId, CommandFunction, CommandStatus)]
-> IO (Maybe CommandData)
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow (UserId, Maybe UserId, CommandFunction, CommandStatus)
-> CommandData
toCommandData (IO [(UserId, Maybe UserId, CommandFunction, CommandStatus)]
 -> IO (Maybe CommandData))
-> IO [(UserId, Maybe UserId, CommandFunction, CommandStatus)]
-> IO (Maybe CommandData)
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> (UserId, FilePath)
-> IO [(UserId, Maybe UserId, CommandFunction, CommandStatus)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query
      Connection
db
      [sql|
        SELECT command_id, connection_id, command_function, command_status
        FROM commands
        WHERE user_id = ? AND command_id = ?
      |]
      (UserId
userId, ConnId -> FilePath
commandId ConnId
corrId)
  where
    toCommandData :: (CommandId, Maybe Int64, CommandFunction, CommandStatus) -> CommandData
    toCommandData :: (UserId, Maybe UserId, CommandFunction, CommandStatus)
-> CommandData
toCommandData (UserId
cmdId, Maybe UserId
cmdConnId, CommandFunction
cmdFunction, CommandStatus
cmdStatus) = CommandData {UserId
cmdId :: UserId
cmdId :: UserId
cmdId, Maybe UserId
cmdConnId :: Maybe UserId
cmdConnId :: Maybe UserId
cmdConnId, CommandFunction
cmdFunction :: CommandFunction
cmdFunction :: CommandFunction
cmdFunction, CommandStatus
cmdStatus :: CommandStatus
cmdStatus :: CommandStatus
cmdStatus}

setUserUIThemes :: DB.Connection -> User -> Maybe UIThemeEntityOverrides -> IO ()
setUserUIThemes :: Connection -> User -> Maybe UIThemeEntityOverrides -> IO ()
setUserUIThemes Connection
db User {UserId
userId :: User -> UserId
userId :: UserId
userId} Maybe UIThemeEntityOverrides
uiThemes = do
  UTCTime
updatedAt <- IO UTCTime
getCurrentTime
  Connection
-> Query
-> (Maybe UIThemeEntityOverrides, UTCTime, UserId)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"UPDATE users SET ui_themes = ?, updated_at = ? WHERE user_id = ?" (Maybe UIThemeEntityOverrides
uiThemes, UTCTime
updatedAt, UserId
userId)