{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

module Simplex.Chat.Operators where

import Control.Applicative ((<|>))
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import qualified Data.Aeson.TH as JQ
import Data.FileEmbed
import Data.Foldable (foldMap')
import Data.Functor.Identity
import Data.IORef
import Data.Int (Int64)
import Data.Kind
import Data.List (find, foldl')
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (addUTCTime)
import Data.Time.Clock (UTCTime, nominalDay)
import Language.Haskell.TH.Syntax (lift)
import Simplex.Chat.Operators.Conditions
import Simplex.Chat.Protocol (RelayProfile (..))
import Simplex.Chat.Types (ShortLinkContact, User)
import Simplex.Chat.Types.Shared (RelayStatus)
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
import Simplex.Messaging.Agent.Protocol (sameShortLinkContact)
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
import Simplex.Messaging.Agent.Store.Entity
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
import Simplex.Messaging.Protocol (AProtocolType (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, SProtocolType (..), UserProtocol)
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Util (atomicModifyIORef'_, safeDecodeUtf8)

usageConditionsCommit :: Text
usageConditionsCommit :: Text
usageConditionsCommit = Text
"05f99634c470f8bddac20046947a0606938b22ad"

previousConditionsCommit :: Text
previousConditionsCommit :: Text
previousConditionsCommit = Text
"7471fd2af5838dc0467aebc570b5ea75e5df3209"

usageConditionsText :: Text
usageConditionsText :: Text
usageConditionsText =
  $( let s = $(embedFile "PRIVACY.md")
      in [|stripFrontMatter $(lift (safeDecodeUtf8 s))|]
   )

data OperatorTag = OTSimplex | OTFlux
  deriving (OperatorTag -> OperatorTag -> Bool
(OperatorTag -> OperatorTag -> Bool)
-> (OperatorTag -> OperatorTag -> Bool) -> Eq OperatorTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OperatorTag -> OperatorTag -> Bool
== :: OperatorTag -> OperatorTag -> Bool
$c/= :: OperatorTag -> OperatorTag -> Bool
/= :: OperatorTag -> OperatorTag -> Bool
Eq, Eq OperatorTag
Eq OperatorTag =>
(OperatorTag -> OperatorTag -> Ordering)
-> (OperatorTag -> OperatorTag -> Bool)
-> (OperatorTag -> OperatorTag -> Bool)
-> (OperatorTag -> OperatorTag -> Bool)
-> (OperatorTag -> OperatorTag -> Bool)
-> (OperatorTag -> OperatorTag -> OperatorTag)
-> (OperatorTag -> OperatorTag -> OperatorTag)
-> Ord OperatorTag
OperatorTag -> OperatorTag -> Bool
OperatorTag -> OperatorTag -> Ordering
OperatorTag -> OperatorTag -> OperatorTag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: OperatorTag -> OperatorTag -> Ordering
compare :: OperatorTag -> OperatorTag -> Ordering
$c< :: OperatorTag -> OperatorTag -> Bool
< :: OperatorTag -> OperatorTag -> Bool
$c<= :: OperatorTag -> OperatorTag -> Bool
<= :: OperatorTag -> OperatorTag -> Bool
$c> :: OperatorTag -> OperatorTag -> Bool
> :: OperatorTag -> OperatorTag -> Bool
$c>= :: OperatorTag -> OperatorTag -> Bool
>= :: OperatorTag -> OperatorTag -> Bool
$cmax :: OperatorTag -> OperatorTag -> OperatorTag
max :: OperatorTag -> OperatorTag -> OperatorTag
$cmin :: OperatorTag -> OperatorTag -> OperatorTag
min :: OperatorTag -> OperatorTag -> OperatorTag
Ord, Int -> OperatorTag -> ShowS
[OperatorTag] -> ShowS
OperatorTag -> String
(Int -> OperatorTag -> ShowS)
-> (OperatorTag -> String)
-> ([OperatorTag] -> ShowS)
-> Show OperatorTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OperatorTag -> ShowS
showsPrec :: Int -> OperatorTag -> ShowS
$cshow :: OperatorTag -> String
show :: OperatorTag -> String
$cshowList :: [OperatorTag] -> ShowS
showList :: [OperatorTag] -> ShowS
Show)

instance FromField OperatorTag where fromField :: FieldParser OperatorTag
fromField = (Text -> Maybe OperatorTag) -> FieldParser OperatorTag
forall a. Typeable a => (Text -> Maybe a) -> Field -> Ok a
fromTextField_ Text -> Maybe OperatorTag
forall a. TextEncoding a => Text -> Maybe a
textDecode

instance ToField OperatorTag where toField :: OperatorTag -> SQLData
toField = Text -> SQLData
forall a. ToField a => a -> SQLData
toField (Text -> SQLData)
-> (OperatorTag -> Text) -> OperatorTag -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OperatorTag -> Text
forall a. TextEncoding a => a -> Text
textEncode

instance FromJSON OperatorTag where
  parseJSON :: Value -> Parser OperatorTag
parseJSON = String -> Value -> Parser OperatorTag
forall a. TextEncoding a => String -> Value -> Parser a
textParseJSON String
"OperatorTag"

instance ToJSON OperatorTag where
  toJSON :: OperatorTag -> Value
toJSON = Text -> Value
J.String (Text -> Value) -> (OperatorTag -> Text) -> OperatorTag -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OperatorTag -> Text
forall a. TextEncoding a => a -> Text
textEncode
  toEncoding :: OperatorTag -> Encoding
toEncoding = Text -> Encoding
forall a. Text -> Encoding' a
JE.text (Text -> Encoding)
-> (OperatorTag -> Text) -> OperatorTag -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OperatorTag -> Text
forall a. TextEncoding a => a -> Text
textEncode

instance TextEncoding OperatorTag where
  textDecode :: Text -> Maybe OperatorTag
textDecode = \case
    Text
"simplex" -> OperatorTag -> Maybe OperatorTag
forall a. a -> Maybe a
Just OperatorTag
OTSimplex
    Text
"flux" -> OperatorTag -> Maybe OperatorTag
forall a. a -> Maybe a
Just OperatorTag
OTFlux
    Text
_ -> Maybe OperatorTag
forall a. Maybe a
Nothing
  textEncode :: OperatorTag -> Text
textEncode = \case
    OperatorTag
OTSimplex -> Text
"simplex"
    OperatorTag
OTFlux -> Text
"flux"

data UsageConditions = UsageConditions
  { UsageConditions -> Int64
conditionsId :: Int64,
    UsageConditions -> Text
conditionsCommit :: Text,
    UsageConditions -> Maybe UTCTime
notifiedAt :: Maybe UTCTime,
    UsageConditions -> UTCTime
createdAt :: UTCTime
  }
  deriving (Int -> UsageConditions -> ShowS
[UsageConditions] -> ShowS
UsageConditions -> String
(Int -> UsageConditions -> ShowS)
-> (UsageConditions -> String)
-> ([UsageConditions] -> ShowS)
-> Show UsageConditions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UsageConditions -> ShowS
showsPrec :: Int -> UsageConditions -> ShowS
$cshow :: UsageConditions -> String
show :: UsageConditions -> String
$cshowList :: [UsageConditions] -> ShowS
showList :: [UsageConditions] -> ShowS
Show)

data UsageConditionsAction
  = UCAReview {UsageConditionsAction -> [ServerOperator]
operators :: [ServerOperator], UsageConditionsAction -> Maybe UTCTime
deadline :: Maybe UTCTime, UsageConditionsAction -> Bool
showNotice :: Bool}
  | UCAAccepted {operators :: [ServerOperator]}
  deriving (Int -> UsageConditionsAction -> ShowS
[UsageConditionsAction] -> ShowS
UsageConditionsAction -> String
(Int -> UsageConditionsAction -> ShowS)
-> (UsageConditionsAction -> String)
-> ([UsageConditionsAction] -> ShowS)
-> Show UsageConditionsAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UsageConditionsAction -> ShowS
showsPrec :: Int -> UsageConditionsAction -> ShowS
$cshow :: UsageConditionsAction -> String
show :: UsageConditionsAction -> String
$cshowList :: [UsageConditionsAction] -> ShowS
showList :: [UsageConditionsAction] -> ShowS
Show)

data ServerOperatorConditions = ServerOperatorConditions
  { ServerOperatorConditions -> [ServerOperator]
serverOperators :: [ServerOperator],
    ServerOperatorConditions -> UsageConditions
currentConditions :: UsageConditions,
    ServerOperatorConditions -> Maybe UsageConditionsAction
conditionsAction :: Maybe UsageConditionsAction
  }
  deriving (Int -> ServerOperatorConditions -> ShowS
[ServerOperatorConditions] -> ShowS
ServerOperatorConditions -> String
(Int -> ServerOperatorConditions -> ShowS)
-> (ServerOperatorConditions -> String)
-> ([ServerOperatorConditions] -> ShowS)
-> Show ServerOperatorConditions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerOperatorConditions -> ShowS
showsPrec :: Int -> ServerOperatorConditions -> ShowS
$cshow :: ServerOperatorConditions -> String
show :: ServerOperatorConditions -> String
$cshowList :: [ServerOperatorConditions] -> ShowS
showList :: [ServerOperatorConditions] -> ShowS
Show)

usageConditionsAction :: [ServerOperator] -> UsageConditions -> UTCTime -> Maybe UsageConditionsAction
usageConditionsAction :: [ServerOperator]
-> UsageConditions -> UTCTime -> Maybe UsageConditionsAction
usageConditionsAction [ServerOperator]
operators UsageConditions {UTCTime
$sel:createdAt:UsageConditions :: UsageConditions -> UTCTime
createdAt :: UTCTime
createdAt, Maybe UTCTime
$sel:notifiedAt:UsageConditions :: UsageConditions -> Maybe UTCTime
notifiedAt :: Maybe UTCTime
notifiedAt} UTCTime
now = do
  let enabledOperators :: [ServerOperator]
enabledOperators = (ServerOperator -> Bool) -> [ServerOperator] -> [ServerOperator]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ServerOperator {Bool
enabled :: Bool
$sel:enabled:ServerOperator :: forall (s :: DBStored). ServerOperator' s -> Bool
enabled} -> Bool
enabled) [ServerOperator]
operators
  if
    | [ServerOperator] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ServerOperator]
enabledOperators -> Maybe UsageConditionsAction
forall a. Maybe a
Nothing
    | (ServerOperator -> Bool) -> [ServerOperator] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ServerOperator -> Bool
conditionsAccepted [ServerOperator]
enabledOperators ->
        let acceptedForOperators :: [ServerOperator]
acceptedForOperators = (ServerOperator -> Bool) -> [ServerOperator] -> [ServerOperator]
forall a. (a -> Bool) -> [a] -> [a]
filter ServerOperator -> Bool
conditionsAccepted [ServerOperator]
operators
         in UsageConditionsAction -> Maybe UsageConditionsAction
forall a. a -> Maybe a
Just (UsageConditionsAction -> Maybe UsageConditionsAction)
-> UsageConditionsAction -> Maybe UsageConditionsAction
forall a b. (a -> b) -> a -> b
$ [ServerOperator] -> UsageConditionsAction
UCAAccepted [ServerOperator]
acceptedForOperators
    | Bool
otherwise ->
        let acceptForOperators :: [ServerOperator]
acceptForOperators = (ServerOperator -> Bool) -> [ServerOperator] -> [ServerOperator]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (ServerOperator -> Bool) -> ServerOperator -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerOperator -> Bool
conditionsAccepted) [ServerOperator]
enabledOperators
            deadline :: Maybe UTCTime
deadline = UTCTime -> UTCTime -> Maybe UTCTime
conditionsRequiredOrDeadline UTCTime
createdAt (UTCTime -> Maybe UTCTime -> UTCTime
forall a. a -> Maybe a -> a
fromMaybe UTCTime
now Maybe UTCTime
notifiedAt)
            showNotice :: Bool
showNotice = Maybe UTCTime -> Bool
forall a. Maybe a -> Bool
isNothing Maybe UTCTime
notifiedAt
         in UsageConditionsAction -> Maybe UsageConditionsAction
forall a. a -> Maybe a
Just (UsageConditionsAction -> Maybe UsageConditionsAction)
-> UsageConditionsAction -> Maybe UsageConditionsAction
forall a b. (a -> b) -> a -> b
$ [ServerOperator] -> Maybe UTCTime -> Bool -> UsageConditionsAction
UCAReview [ServerOperator]
acceptForOperators Maybe UTCTime
deadline Bool
showNotice

conditionsRequiredOrDeadline :: UTCTime -> UTCTime -> Maybe UTCTime
conditionsRequiredOrDeadline :: UTCTime -> UTCTime -> Maybe UTCTime
conditionsRequiredOrDeadline UTCTime
createdAt UTCTime
notifiedAtOrNow =
  if UTCTime
notifiedAtOrNow UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
14 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay) UTCTime
createdAt
    then UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime
conditionsDeadline UTCTime
notifiedAtOrNow
    else Maybe UTCTime
forall a. Maybe a
Nothing -- required
  where
    conditionsDeadline :: UTCTime -> UTCTime
    conditionsDeadline :: UTCTime -> UTCTime
conditionsDeadline = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
31 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay)

data ConditionsAcceptance
  = CAAccepted {ConditionsAcceptance -> Maybe UTCTime
acceptedAt :: Maybe UTCTime, ConditionsAcceptance -> Bool
autoAccepted :: Bool}
  | CARequired {ConditionsAcceptance -> Maybe UTCTime
deadline :: Maybe UTCTime}
  deriving (Int -> ConditionsAcceptance -> ShowS
[ConditionsAcceptance] -> ShowS
ConditionsAcceptance -> String
(Int -> ConditionsAcceptance -> ShowS)
-> (ConditionsAcceptance -> String)
-> ([ConditionsAcceptance] -> ShowS)
-> Show ConditionsAcceptance
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConditionsAcceptance -> ShowS
showsPrec :: Int -> ConditionsAcceptance -> ShowS
$cshow :: ConditionsAcceptance -> String
show :: ConditionsAcceptance -> String
$cshowList :: [ConditionsAcceptance] -> ShowS
showList :: [ConditionsAcceptance] -> ShowS
Show)

type ServerOperator = ServerOperator' 'DBStored

type NewServerOperator = ServerOperator' 'DBNew

data AServerOperator = forall s. ASO (SDBStored s) (ServerOperator' s)

deriving instance Show AServerOperator

data ServerOperator' s = ServerOperator
  { forall (s :: DBStored). ServerOperator' s -> DBEntityId' s
operatorId :: DBEntityId' s,
    forall (s :: DBStored). ServerOperator' s -> Maybe OperatorTag
operatorTag :: Maybe OperatorTag,
    forall (s :: DBStored). ServerOperator' s -> Text
tradeName :: Text,
    forall (s :: DBStored). ServerOperator' s -> Maybe Text
legalName :: Maybe Text,
    forall (s :: DBStored). ServerOperator' s -> [Text]
serverDomains :: [Text],
    forall (s :: DBStored). ServerOperator' s -> ConditionsAcceptance
conditionsAcceptance :: ConditionsAcceptance,
    forall (s :: DBStored). ServerOperator' s -> Bool
enabled :: Bool,
    forall (s :: DBStored). ServerOperator' s -> ServerRoles
smpRoles :: ServerRoles,
    forall (s :: DBStored). ServerOperator' s -> ServerRoles
xftpRoles :: ServerRoles
  }
  deriving (Int -> ServerOperator' s -> ShowS
[ServerOperator' s] -> ShowS
ServerOperator' s -> String
(Int -> ServerOperator' s -> ShowS)
-> (ServerOperator' s -> String)
-> ([ServerOperator' s] -> ShowS)
-> Show (ServerOperator' s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: DBStored). Int -> ServerOperator' s -> ShowS
forall (s :: DBStored). [ServerOperator' s] -> ShowS
forall (s :: DBStored). ServerOperator' s -> String
$cshowsPrec :: forall (s :: DBStored). Int -> ServerOperator' s -> ShowS
showsPrec :: Int -> ServerOperator' s -> ShowS
$cshow :: forall (s :: DBStored). ServerOperator' s -> String
show :: ServerOperator' s -> String
$cshowList :: forall (s :: DBStored). [ServerOperator' s] -> ShowS
showList :: [ServerOperator' s] -> ShowS
Show)

data ServerOperatorRoles = ServerOperatorRoles
  { ServerOperatorRoles -> Int64
operatorId' :: Int64,
    ServerOperatorRoles -> Bool
enabled' :: Bool,
    ServerOperatorRoles -> ServerRoles
smpRoles' :: ServerRoles,
    ServerOperatorRoles -> ServerRoles
xftpRoles' :: ServerRoles
  }
  deriving (Int -> ServerOperatorRoles -> ShowS
[ServerOperatorRoles] -> ShowS
ServerOperatorRoles -> String
(Int -> ServerOperatorRoles -> ShowS)
-> (ServerOperatorRoles -> String)
-> ([ServerOperatorRoles] -> ShowS)
-> Show ServerOperatorRoles
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerOperatorRoles -> ShowS
showsPrec :: Int -> ServerOperatorRoles -> ShowS
$cshow :: ServerOperatorRoles -> String
show :: ServerOperatorRoles -> String
$cshowList :: [ServerOperatorRoles] -> ShowS
showList :: [ServerOperatorRoles] -> ShowS
Show)

operatorRoles :: UserProtocol p => SProtocolType p -> ServerOperator -> ServerRoles
operatorRoles :: forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> ServerOperator -> ServerRoles
operatorRoles SProtocolType p
p ServerOperator
op = case SProtocolType p
p of
  SProtocolType p
SPSMP -> ServerOperator -> ServerRoles
forall (s :: DBStored). ServerOperator' s -> ServerRoles
smpRoles ServerOperator
op
  SProtocolType p
SPXFTP -> ServerOperator -> ServerRoles
forall (s :: DBStored). ServerOperator' s -> ServerRoles
xftpRoles ServerOperator
op

conditionsAccepted :: ServerOperator -> Bool
conditionsAccepted :: ServerOperator -> Bool
conditionsAccepted ServerOperator {ConditionsAcceptance
$sel:conditionsAcceptance:ServerOperator :: forall (s :: DBStored). ServerOperator' s -> ConditionsAcceptance
conditionsAcceptance :: ConditionsAcceptance
conditionsAcceptance} = case ConditionsAcceptance
conditionsAcceptance of
  CAAccepted {} -> Bool
True
  ConditionsAcceptance
_ -> Bool
False

data UserOperatorServers = UserOperatorServers
  { UserOperatorServers -> Maybe ServerOperator
operator :: Maybe ServerOperator,
    UserOperatorServers -> [UserServer 'PSMP]
smpServers :: [UserServer 'PSMP],
    UserOperatorServers -> [UserServer 'PXFTP]
xftpServers :: [UserServer 'PXFTP],
    UserOperatorServers -> [UserChatRelay]
chatRelays :: [UserChatRelay]
  }
  deriving (Int -> UserOperatorServers -> ShowS
[UserOperatorServers] -> ShowS
UserOperatorServers -> String
(Int -> UserOperatorServers -> ShowS)
-> (UserOperatorServers -> String)
-> ([UserOperatorServers] -> ShowS)
-> Show UserOperatorServers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserOperatorServers -> ShowS
showsPrec :: Int -> UserOperatorServers -> ShowS
$cshow :: UserOperatorServers -> String
show :: UserOperatorServers -> String
$cshowList :: [UserOperatorServers] -> ShowS
showList :: [UserOperatorServers] -> ShowS
Show)

data UpdatedUserOperatorServers = UpdatedUserOperatorServers
  { UpdatedUserOperatorServers -> Maybe ServerOperator
operator :: Maybe ServerOperator,
    UpdatedUserOperatorServers -> [AUserServer 'PSMP]
smpServers :: [AUserServer 'PSMP],
    UpdatedUserOperatorServers -> [AUserServer 'PXFTP]
xftpServers :: [AUserServer 'PXFTP],
    UpdatedUserOperatorServers -> [AUserChatRelay]
chatRelays :: [AUserChatRelay]
  }
  deriving (Int -> UpdatedUserOperatorServers -> ShowS
[UpdatedUserOperatorServers] -> ShowS
UpdatedUserOperatorServers -> String
(Int -> UpdatedUserOperatorServers -> ShowS)
-> (UpdatedUserOperatorServers -> String)
-> ([UpdatedUserOperatorServers] -> ShowS)
-> Show UpdatedUserOperatorServers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UpdatedUserOperatorServers -> ShowS
showsPrec :: Int -> UpdatedUserOperatorServers -> ShowS
$cshow :: UpdatedUserOperatorServers -> String
show :: UpdatedUserOperatorServers -> String
$cshowList :: [UpdatedUserOperatorServers] -> ShowS
showList :: [UpdatedUserOperatorServers] -> ShowS
Show)

data ValidatedProtoServer p = ValidatedProtoServer {forall (p :: ProtocolType).
ValidatedProtoServer p -> Either Text (ProtoServerWithAuth p)
unVPS :: Either Text (ProtoServerWithAuth p)}
  deriving (Int -> ValidatedProtoServer p -> ShowS
[ValidatedProtoServer p] -> ShowS
ValidatedProtoServer p -> String
(Int -> ValidatedProtoServer p -> ShowS)
-> (ValidatedProtoServer p -> String)
-> ([ValidatedProtoServer p] -> ShowS)
-> Show (ValidatedProtoServer p)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (p :: ProtocolType). Int -> ValidatedProtoServer p -> ShowS
forall (p :: ProtocolType). [ValidatedProtoServer p] -> ShowS
forall (p :: ProtocolType). ValidatedProtoServer p -> String
$cshowsPrec :: forall (p :: ProtocolType). Int -> ValidatedProtoServer p -> ShowS
showsPrec :: Int -> ValidatedProtoServer p -> ShowS
$cshow :: forall (p :: ProtocolType). ValidatedProtoServer p -> String
show :: ValidatedProtoServer p -> String
$cshowList :: forall (p :: ProtocolType). [ValidatedProtoServer p] -> ShowS
showList :: [ValidatedProtoServer p] -> ShowS
Show)

class UserServersClass u where
  type AServer u = (s :: ProtocolType -> Type) | s -> u
  type AChatRelay u = (s :: Type) | s -> u
  operator' :: u -> Maybe ServerOperator
  aUserServer' :: AServer u p -> AUserServer p
  servers' :: UserProtocol p => SProtocolType p -> u -> [AServer u p]
  chatRelays' :: u -> [AChatRelay u]
  aUserChatRelay' :: AChatRelay u -> AUserChatRelay

instance UserServersClass UserOperatorServers where
  type AServer UserOperatorServers = UserServer' 'DBStored
  type AChatRelay UserOperatorServers = UserChatRelay' 'DBStored
  operator' :: UserOperatorServers -> Maybe ServerOperator
operator' UserOperatorServers {Maybe ServerOperator
$sel:operator:UserOperatorServers :: UserOperatorServers -> Maybe ServerOperator
operator :: Maybe ServerOperator
operator} = Maybe ServerOperator
operator
  aUserServer' :: forall (p :: ProtocolType).
AServer UserOperatorServers p -> AUserServer p
aUserServer' = SDBStored 'DBStored -> UserServer' 'DBStored p -> AUserServer p
forall (p :: ProtocolType) (s :: DBStored).
SDBStored s -> UserServer' s p -> AUserServer p
AUS SDBStored 'DBStored
SDBStored
  servers' :: forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p
-> UserOperatorServers -> [AServer UserOperatorServers p]
servers' SProtocolType p
p UserOperatorServers {[UserServer 'PSMP]
$sel:smpServers:UserOperatorServers :: UserOperatorServers -> [UserServer 'PSMP]
smpServers :: [UserServer 'PSMP]
smpServers, [UserServer 'PXFTP]
$sel:xftpServers:UserOperatorServers :: UserOperatorServers -> [UserServer 'PXFTP]
xftpServers :: [UserServer 'PXFTP]
xftpServers} = case SProtocolType p
p of
    SProtocolType p
SPSMP -> [UserServer 'PSMP]
[AServer UserOperatorServers p]
smpServers
    SProtocolType p
SPXFTP -> [UserServer 'PXFTP]
[AServer UserOperatorServers p]
xftpServers
  chatRelays' :: UserOperatorServers -> [AChatRelay UserOperatorServers]
chatRelays' UserOperatorServers {[UserChatRelay]
$sel:chatRelays:UserOperatorServers :: UserOperatorServers -> [UserChatRelay]
chatRelays :: [UserChatRelay]
chatRelays} = [UserChatRelay]
[AChatRelay UserOperatorServers]
chatRelays
  aUserChatRelay' :: AChatRelay UserOperatorServers -> AUserChatRelay
aUserChatRelay' = SDBStored 'DBStored -> UserChatRelay -> AUserChatRelay
forall (s :: DBStored).
SDBStored s -> UserChatRelay' s -> AUserChatRelay
AUCR SDBStored 'DBStored
SDBStored

instance UserServersClass UpdatedUserOperatorServers where
  type AServer UpdatedUserOperatorServers = AUserServer
  type AChatRelay UpdatedUserOperatorServers = AUserChatRelay
  operator' :: UpdatedUserOperatorServers -> Maybe ServerOperator
operator' UpdatedUserOperatorServers {Maybe ServerOperator
$sel:operator:UpdatedUserOperatorServers :: UpdatedUserOperatorServers -> Maybe ServerOperator
operator :: Maybe ServerOperator
operator} = Maybe ServerOperator
operator
  aUserServer' :: forall (p :: ProtocolType).
AServer UpdatedUserOperatorServers p -> AUserServer p
aUserServer' = AUserServer p -> AUserServer p
AServer UpdatedUserOperatorServers p -> AUserServer p
forall a. a -> a
id
  servers' :: forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p
-> UpdatedUserOperatorServers
-> [AServer UpdatedUserOperatorServers p]
servers' SProtocolType p
p UpdatedUserOperatorServers {[AUserServer 'PSMP]
$sel:smpServers:UpdatedUserOperatorServers :: UpdatedUserOperatorServers -> [AUserServer 'PSMP]
smpServers :: [AUserServer 'PSMP]
smpServers, [AUserServer 'PXFTP]
$sel:xftpServers:UpdatedUserOperatorServers :: UpdatedUserOperatorServers -> [AUserServer 'PXFTP]
xftpServers :: [AUserServer 'PXFTP]
xftpServers} = case SProtocolType p
p of
    SProtocolType p
SPSMP -> [AUserServer 'PSMP]
[AServer UpdatedUserOperatorServers p]
smpServers
    SProtocolType p
SPXFTP -> [AUserServer 'PXFTP]
[AServer UpdatedUserOperatorServers p]
xftpServers
  chatRelays' :: UpdatedUserOperatorServers
-> [AChatRelay UpdatedUserOperatorServers]
chatRelays' UpdatedUserOperatorServers {[AUserChatRelay]
$sel:chatRelays:UpdatedUserOperatorServers :: UpdatedUserOperatorServers -> [AUserChatRelay]
chatRelays :: [AUserChatRelay]
chatRelays} = [AUserChatRelay]
[AChatRelay UpdatedUserOperatorServers]
chatRelays
  aUserChatRelay' :: AChatRelay UpdatedUserOperatorServers -> AUserChatRelay
aUserChatRelay' = AUserChatRelay -> AUserChatRelay
AChatRelay UpdatedUserOperatorServers -> AUserChatRelay
forall a. a -> a
id

type UserServer p = UserServer' 'DBStored p

type NewUserServer p = UserServer' 'DBNew p

data AUserServer p = forall s. AUS (SDBStored s) (UserServer' s p)

deriving instance Show (AUserServer p)

data UserServer' s (p :: ProtocolType) = UserServer
  { forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> DBEntityId' s
serverId :: DBEntityId' s,
    forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> ProtoServerWithAuth p
server :: ProtoServerWithAuth p,
    forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
preset :: Bool,
    forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> Maybe Bool
tested :: Maybe Bool,
    forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
enabled :: Bool,
    forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
deleted :: Bool
  }
  deriving (Int -> UserServer' s p -> ShowS
[UserServer' s p] -> ShowS
UserServer' s p -> String
(Int -> UserServer' s p -> ShowS)
-> (UserServer' s p -> String)
-> ([UserServer' s p] -> ShowS)
-> Show (UserServer' s p)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: DBStored) (p :: ProtocolType).
Int -> UserServer' s p -> ShowS
forall (s :: DBStored) (p :: ProtocolType).
[UserServer' s p] -> ShowS
forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> String
$cshowsPrec :: forall (s :: DBStored) (p :: ProtocolType).
Int -> UserServer' s p -> ShowS
showsPrec :: Int -> UserServer' s p -> ShowS
$cshow :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> String
show :: UserServer' s p -> String
$cshowList :: forall (s :: DBStored) (p :: ProtocolType).
[UserServer' s p] -> ShowS
showList :: [UserServer' s p] -> ShowS
Show)

presetServerAddress :: UserServer' s p -> ProtocolServer p
presetServerAddress :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> ProtocolServer p
presetServerAddress UserServer {$sel:server:UserServer :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> ProtoServerWithAuth p
server = ProtoServerWithAuth ProtocolServer p
srv Maybe BasicAuth
_} = ProtocolServer p
srv
{-# INLINE presetServerAddress #-}

type UserChatRelay = UserChatRelay' 'DBStored

type NewUserChatRelay = UserChatRelay' 'DBNew

data AUserChatRelay = forall s. AUCR (SDBStored s) (UserChatRelay' s)

deriving instance Show AUserChatRelay

data UserChatRelay' s = UserChatRelay
  { forall (s :: DBStored). UserChatRelay' s -> DBEntityId' s
chatRelayId :: DBEntityId' s,
    forall (s :: DBStored). UserChatRelay' s -> ShortLinkContact
address :: ShortLinkContact,
    forall (s :: DBStored). UserChatRelay' s -> RelayProfile
relayProfile :: RelayProfile,
    forall (s :: DBStored). UserChatRelay' s -> [Text]
domains :: [Text],
    forall (s :: DBStored). UserChatRelay' s -> Bool
preset :: Bool,
    forall (s :: DBStored). UserChatRelay' s -> Maybe Bool
tested :: Maybe Bool,
    forall (s :: DBStored). UserChatRelay' s -> Bool
enabled :: Bool,
    forall (s :: DBStored). UserChatRelay' s -> Bool
deleted :: Bool
  }
  deriving (Int -> UserChatRelay' s -> ShowS
[UserChatRelay' s] -> ShowS
UserChatRelay' s -> String
(Int -> UserChatRelay' s -> ShowS)
-> (UserChatRelay' s -> String)
-> ([UserChatRelay' s] -> ShowS)
-> Show (UserChatRelay' s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: DBStored). Int -> UserChatRelay' s -> ShowS
forall (s :: DBStored). [UserChatRelay' s] -> ShowS
forall (s :: DBStored). UserChatRelay' s -> String
$cshowsPrec :: forall (s :: DBStored). Int -> UserChatRelay' s -> ShowS
showsPrec :: Int -> UserChatRelay' s -> ShowS
$cshow :: forall (s :: DBStored). UserChatRelay' s -> String
show :: UserChatRelay' s -> String
$cshowList :: forall (s :: DBStored). [UserChatRelay' s] -> ShowS
showList :: [UserChatRelay' s] -> ShowS
Show)

deriving instance Eq UserChatRelay

data GroupRelay = GroupRelay
  { GroupRelay -> Int64
groupRelayId :: Int64,
    GroupRelay -> Int64
groupMemberId :: Int64,
    GroupRelay -> UserChatRelay
userChatRelay :: UserChatRelay,
    GroupRelay -> RelayStatus
relayStatus :: RelayStatus,
    GroupRelay -> Maybe ShortLinkContact
relayLink :: Maybe ShortLinkContact
  }
  deriving (GroupRelay -> GroupRelay -> Bool
(GroupRelay -> GroupRelay -> Bool)
-> (GroupRelay -> GroupRelay -> Bool) -> Eq GroupRelay
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GroupRelay -> GroupRelay -> Bool
== :: GroupRelay -> GroupRelay -> Bool
$c/= :: GroupRelay -> GroupRelay -> Bool
/= :: GroupRelay -> GroupRelay -> Bool
Eq, Int -> GroupRelay -> ShowS
[GroupRelay] -> ShowS
GroupRelay -> String
(Int -> GroupRelay -> ShowS)
-> (GroupRelay -> String)
-> ([GroupRelay] -> ShowS)
-> Show GroupRelay
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GroupRelay -> ShowS
showsPrec :: Int -> GroupRelay -> ShowS
$cshow :: GroupRelay -> String
show :: GroupRelay -> String
$cshowList :: [GroupRelay] -> ShowS
showList :: [GroupRelay] -> ShowS
Show)

-- for setting chat relays via CLI API
data CLINewRelay = CLINewRelay
  { CLINewRelay -> ShortLinkContact
address :: ShortLinkContact,
    CLINewRelay -> Text
name :: Text
  }
  deriving (Int -> CLINewRelay -> ShowS
[CLINewRelay] -> ShowS
CLINewRelay -> String
(Int -> CLINewRelay -> ShowS)
-> (CLINewRelay -> String)
-> ([CLINewRelay] -> ShowS)
-> Show CLINewRelay
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CLINewRelay -> ShowS
showsPrec :: Int -> CLINewRelay -> ShowS
$cshow :: CLINewRelay -> String
show :: CLINewRelay -> String
$cshowList :: [CLINewRelay] -> ShowS
showList :: [CLINewRelay] -> ShowS
Show)

data PresetOperator = PresetOperator
  { PresetOperator -> Maybe NewServerOperator
operator :: Maybe NewServerOperator,
    PresetOperator -> [NewUserServer 'PSMP]
smp :: [NewUserServer 'PSMP],
    PresetOperator -> Int
useSMP :: Int,
    PresetOperator -> [NewUserServer 'PXFTP]
xftp :: [NewUserServer 'PXFTP],
    PresetOperator -> Int
useXFTP :: Int,
    PresetOperator -> [NewUserChatRelay]
chatRelays :: [NewUserChatRelay],
    PresetOperator -> Int
useChatRelays :: Int
  }
  deriving (Int -> PresetOperator -> ShowS
[PresetOperator] -> ShowS
PresetOperator -> String
(Int -> PresetOperator -> ShowS)
-> (PresetOperator -> String)
-> ([PresetOperator] -> ShowS)
-> Show PresetOperator
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PresetOperator -> ShowS
showsPrec :: Int -> PresetOperator -> ShowS
$cshow :: PresetOperator -> String
show :: PresetOperator -> String
$cshowList :: [PresetOperator] -> ShowS
showList :: [PresetOperator] -> ShowS
Show)

pOperator :: PresetOperator -> Maybe NewServerOperator
pOperator :: PresetOperator -> Maybe NewServerOperator
pOperator PresetOperator {Maybe NewServerOperator
$sel:operator:PresetOperator :: PresetOperator -> Maybe NewServerOperator
operator :: Maybe NewServerOperator
operator} = Maybe NewServerOperator
operator

pServers :: UserProtocol p => SProtocolType p -> PresetOperator -> [NewUserServer p]
pServers :: forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> PresetOperator -> [NewUserServer p]
pServers SProtocolType p
p PresetOperator {[NewUserServer 'PSMP]
$sel:smp:PresetOperator :: PresetOperator -> [NewUserServer 'PSMP]
smp :: [NewUserServer 'PSMP]
smp, [NewUserServer 'PXFTP]
$sel:xftp:PresetOperator :: PresetOperator -> [NewUserServer 'PXFTP]
xftp :: [NewUserServer 'PXFTP]
xftp} = case SProtocolType p
p of
  SProtocolType p
SPSMP -> [NewUserServer p]
[NewUserServer 'PSMP]
smp
  SProtocolType p
SPXFTP -> [NewUserServer p]
[NewUserServer 'PXFTP]
xftp

operatorServersToUse :: UserProtocol p => SProtocolType p -> PresetOperator -> Int
operatorServersToUse :: forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> PresetOperator -> Int
operatorServersToUse SProtocolType p
p PresetOperator {Int
$sel:useSMP:PresetOperator :: PresetOperator -> Int
useSMP :: Int
useSMP, Int
$sel:useXFTP:PresetOperator :: PresetOperator -> Int
useXFTP :: Int
useXFTP} = case SProtocolType p
p of
  SProtocolType p
SPSMP -> Int
useSMP
  SProtocolType p
SPXFTP -> Int
useXFTP

presetServer' :: Bool -> ProtocolServer p -> NewUserServer p
presetServer' :: forall (p :: ProtocolType).
Bool -> ProtocolServer p -> NewUserServer p
presetServer' Bool
enabled = Bool -> ProtoServerWithAuth p -> NewUserServer p
forall (p :: ProtocolType).
Bool -> ProtoServerWithAuth p -> NewUserServer p
presetServer Bool
enabled (ProtoServerWithAuth p -> NewUserServer p)
-> (ProtocolServer p -> ProtoServerWithAuth p)
-> ProtocolServer p
-> NewUserServer p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtocolServer p -> Maybe BasicAuth -> ProtoServerWithAuth p
forall (p :: ProtocolType).
ProtocolServer p -> Maybe BasicAuth -> ProtoServerWithAuth p
`ProtoServerWithAuth` Maybe BasicAuth
forall a. Maybe a
Nothing)
{-# INLINE presetServer' #-}

presetServer :: Bool -> ProtoServerWithAuth p -> NewUserServer p
presetServer :: forall (p :: ProtocolType).
Bool -> ProtoServerWithAuth p -> NewUserServer p
presetServer = Bool -> Bool -> ProtoServerWithAuth p -> NewUserServer p
forall (p :: ProtocolType).
Bool -> Bool -> ProtoServerWithAuth p -> NewUserServer p
newUserServer_ Bool
True
{-# INLINE presetServer #-}

newUserServer :: ProtoServerWithAuth p -> NewUserServer p
newUserServer :: forall (p :: ProtocolType).
ProtoServerWithAuth p -> NewUserServer p
newUserServer = Bool -> Bool -> ProtoServerWithAuth p -> NewUserServer p
forall (p :: ProtocolType).
Bool -> Bool -> ProtoServerWithAuth p -> NewUserServer p
newUserServer_ Bool
False Bool
True
{-# INLINE newUserServer #-}

newUserServer_ :: Bool -> Bool -> ProtoServerWithAuth p -> NewUserServer p
newUserServer_ :: forall (p :: ProtocolType).
Bool -> Bool -> ProtoServerWithAuth p -> NewUserServer p
newUserServer_ Bool
preset Bool
enabled ProtoServerWithAuth p
server =
  UserServer {$sel:serverId:UserServer :: DBEntityId' 'DBNew
serverId = DBEntityId' 'DBNew
DBNewEntity, ProtoServerWithAuth p
$sel:server:UserServer :: ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server, Bool
$sel:preset:UserServer :: Bool
preset :: Bool
preset, $sel:tested:UserServer :: Maybe Bool
tested = Maybe Bool
forall a. Maybe a
Nothing, Bool
$sel:enabled:UserServer :: Bool
enabled :: Bool
enabled, $sel:deleted:UserServer :: Bool
deleted = Bool
False}

presetChatRelay :: Bool -> RelayProfile -> [Text] -> ShortLinkContact -> NewUserChatRelay
presetChatRelay :: Bool
-> RelayProfile -> [Text] -> ShortLinkContact -> NewUserChatRelay
presetChatRelay = Bool
-> Bool
-> RelayProfile
-> [Text]
-> ShortLinkContact
-> NewUserChatRelay
newChatRelay_ Bool
True
{-# INLINE presetChatRelay #-}

newChatRelay :: RelayProfile -> [Text] -> ShortLinkContact -> NewUserChatRelay
newChatRelay :: RelayProfile -> [Text] -> ShortLinkContact -> NewUserChatRelay
newChatRelay = Bool
-> Bool
-> RelayProfile
-> [Text]
-> ShortLinkContact
-> NewUserChatRelay
newChatRelay_ Bool
False Bool
True
{-# INLINE newChatRelay #-}

newChatRelay_ :: Bool -> Bool -> RelayProfile -> [Text] -> ShortLinkContact -> NewUserChatRelay
newChatRelay_ :: Bool
-> Bool
-> RelayProfile
-> [Text]
-> ShortLinkContact
-> NewUserChatRelay
newChatRelay_ Bool
preset Bool
enabled RelayProfile
relayProfile [Text]
domains !ShortLinkContact
address =
  UserChatRelay {$sel:chatRelayId:UserChatRelay :: DBEntityId' 'DBNew
chatRelayId = DBEntityId' 'DBNew
DBNewEntity, ShortLinkContact
$sel:address:UserChatRelay :: ShortLinkContact
address :: ShortLinkContact
address, RelayProfile
$sel:relayProfile:UserChatRelay :: RelayProfile
relayProfile :: RelayProfile
relayProfile, [Text]
$sel:domains:UserChatRelay :: [Text]
domains :: [Text]
domains, Bool
$sel:preset:UserChatRelay :: Bool
preset :: Bool
preset, $sel:tested:UserChatRelay :: Maybe Bool
tested = Maybe Bool
forall a. Maybe a
Nothing, Bool
$sel:enabled:UserChatRelay :: Bool
enabled :: Bool
enabled, $sel:deleted:UserChatRelay :: Bool
deleted = Bool
False}

-- This function should be used inside DB transaction to update conditions in the database
-- it evaluates to (current conditions, and conditions to add)
usageConditionsToAdd :: Bool -> UTCTime -> [UsageConditions] -> (UsageConditions, [UsageConditions])
usageConditionsToAdd :: Bool
-> UTCTime
-> [UsageConditions]
-> (UsageConditions, [UsageConditions])
usageConditionsToAdd = Text
-> Text
-> Bool
-> UTCTime
-> [UsageConditions]
-> (UsageConditions, [UsageConditions])
usageConditionsToAdd' Text
previousConditionsCommit Text
usageConditionsCommit

-- This function is used in unit tests
usageConditionsToAdd' :: Text -> Text -> Bool -> UTCTime -> [UsageConditions] -> (UsageConditions, [UsageConditions])
usageConditionsToAdd' :: Text
-> Text
-> Bool
-> UTCTime
-> [UsageConditions]
-> (UsageConditions, [UsageConditions])
usageConditionsToAdd' Text
prevCommit Text
sourceCommit Bool
newUser UTCTime
createdAt = \case
  []
    | Bool
newUser -> (UsageConditions
sourceCond, [Item [UsageConditions]
UsageConditions
sourceCond])
    | Bool
otherwise -> (UsageConditions
sourceCond, [Item [UsageConditions]
UsageConditions
prevCond, Item [UsageConditions]
UsageConditions
sourceCond])
    where
      prevCond :: UsageConditions
prevCond = Int64 -> Text -> UsageConditions
conditions Int64
1 Text
prevCommit
      sourceCond :: UsageConditions
sourceCond = Int64 -> Text -> UsageConditions
conditions Int64
2 Text
sourceCommit
  [UsageConditions]
conds
    | Bool
hasSourceCond -> ([UsageConditions] -> UsageConditions
forall a. HasCallStack => [a] -> a
last [UsageConditions]
conds, [])
    | Bool
otherwise -> (UsageConditions
sourceCond, [Item [UsageConditions]
UsageConditions
sourceCond])
    where
      hasSourceCond :: Bool
hasSourceCond = (UsageConditions -> Bool) -> [UsageConditions] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Text
sourceCommit Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==) (Text -> Bool)
-> (UsageConditions -> Text) -> UsageConditions -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UsageConditions -> Text
conditionsCommit) [UsageConditions]
conds
      sourceCond :: UsageConditions
sourceCond = Int64 -> Text -> UsageConditions
conditions Int64
cId Text
sourceCommit
      cId :: Int64
cId = [Int64] -> Int64
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((UsageConditions -> Int64) -> [UsageConditions] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map UsageConditions -> Int64
conditionsId [UsageConditions]
conds) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1
  where
    conditions :: Int64 -> Text -> UsageConditions
conditions Int64
cId Text
commit = UsageConditions {$sel:conditionsId:UsageConditions :: Int64
conditionsId = Int64
cId, $sel:conditionsCommit:UsageConditions :: Text
conditionsCommit = Text
commit, $sel:notifiedAt:UsageConditions :: Maybe UTCTime
notifiedAt = Maybe UTCTime
forall a. Maybe a
Nothing, UTCTime
$sel:createdAt:UsageConditions :: UTCTime
createdAt :: UTCTime
createdAt}

presetUserServers :: [(Maybe PresetOperator, Maybe ServerOperator)] -> [UpdatedUserOperatorServers]
presetUserServers :: [(Maybe PresetOperator, Maybe ServerOperator)]
-> [UpdatedUserOperatorServers]
presetUserServers = ((Maybe PresetOperator, Maybe ServerOperator)
 -> Maybe UpdatedUserOperatorServers)
-> [(Maybe PresetOperator, Maybe ServerOperator)]
-> [UpdatedUserOperatorServers]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (((Maybe PresetOperator, Maybe ServerOperator)
  -> Maybe UpdatedUserOperatorServers)
 -> [(Maybe PresetOperator, Maybe ServerOperator)]
 -> [UpdatedUserOperatorServers])
-> ((Maybe PresetOperator, Maybe ServerOperator)
    -> Maybe UpdatedUserOperatorServers)
-> [(Maybe PresetOperator, Maybe ServerOperator)]
-> [UpdatedUserOperatorServers]
forall a b. (a -> b) -> a -> b
$ \(Maybe PresetOperator
presetOp_, Maybe ServerOperator
op) -> Maybe ServerOperator
-> PresetOperator -> UpdatedUserOperatorServers
mkUS Maybe ServerOperator
op (PresetOperator -> UpdatedUserOperatorServers)
-> Maybe PresetOperator -> Maybe UpdatedUserOperatorServers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PresetOperator
presetOp_
  where
    mkUS :: Maybe ServerOperator
-> PresetOperator -> UpdatedUserOperatorServers
mkUS Maybe ServerOperator
op PresetOperator {[NewUserServer 'PSMP]
$sel:smp:PresetOperator :: PresetOperator -> [NewUserServer 'PSMP]
smp :: [NewUserServer 'PSMP]
smp, [NewUserServer 'PXFTP]
$sel:xftp:PresetOperator :: PresetOperator -> [NewUserServer 'PXFTP]
xftp :: [NewUserServer 'PXFTP]
xftp, [NewUserChatRelay]
$sel:chatRelays:PresetOperator :: PresetOperator -> [NewUserChatRelay]
chatRelays :: [NewUserChatRelay]
chatRelays} =
      Maybe ServerOperator
-> [AUserServer 'PSMP]
-> [AUserServer 'PXFTP]
-> [AUserChatRelay]
-> UpdatedUserOperatorServers
UpdatedUserOperatorServers Maybe ServerOperator
op ((NewUserServer 'PSMP -> AUserServer 'PSMP)
-> [NewUserServer 'PSMP] -> [AUserServer 'PSMP]
forall a b. (a -> b) -> [a] -> [b]
map (SDBStored 'DBNew -> NewUserServer 'PSMP -> AUserServer 'PSMP
forall (p :: ProtocolType) (s :: DBStored).
SDBStored s -> UserServer' s p -> AUserServer p
AUS SDBStored 'DBNew
SDBNew) [NewUserServer 'PSMP]
smp) ((NewUserServer 'PXFTP -> AUserServer 'PXFTP)
-> [NewUserServer 'PXFTP] -> [AUserServer 'PXFTP]
forall a b. (a -> b) -> [a] -> [b]
map (SDBStored 'DBNew -> NewUserServer 'PXFTP -> AUserServer 'PXFTP
forall (p :: ProtocolType) (s :: DBStored).
SDBStored s -> UserServer' s p -> AUserServer p
AUS SDBStored 'DBNew
SDBNew) [NewUserServer 'PXFTP]
xftp) ((NewUserChatRelay -> AUserChatRelay)
-> [NewUserChatRelay] -> [AUserChatRelay]
forall a b. (a -> b) -> [a] -> [b]
map (SDBStored 'DBNew -> NewUserChatRelay -> AUserChatRelay
forall (s :: DBStored).
SDBStored s -> UserChatRelay' s -> AUserChatRelay
AUCR SDBStored 'DBNew
SDBNew) [NewUserChatRelay]
chatRelays)

-- This function should be used inside DB transaction to update operators.
-- It allows to add/remove/update preset operators in the database preserving enabled and roles settings,
-- and preserves custom operators without tags for forward compatibility.
updatedServerOperators :: NonEmpty PresetOperator -> [ServerOperator] -> [(Maybe PresetOperator, Maybe AServerOperator)]
updatedServerOperators :: NonEmpty PresetOperator
-> [ServerOperator]
-> [(Maybe PresetOperator, Maybe AServerOperator)]
updatedServerOperators NonEmpty PresetOperator
presetOps [ServerOperator]
storedOps =
  (PresetOperator
 -> [(Maybe PresetOperator, Maybe AServerOperator)]
 -> [(Maybe PresetOperator, Maybe AServerOperator)])
-> [(Maybe PresetOperator, Maybe AServerOperator)]
-> NonEmpty PresetOperator
-> [(Maybe PresetOperator, Maybe AServerOperator)]
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PresetOperator
-> [(Maybe PresetOperator, Maybe AServerOperator)]
-> [(Maybe PresetOperator, Maybe AServerOperator)]
addPreset [] NonEmpty PresetOperator
presetOps
    [(Maybe PresetOperator, Maybe AServerOperator)]
-> [(Maybe PresetOperator, Maybe AServerOperator)]
-> [(Maybe PresetOperator, Maybe AServerOperator)]
forall a. Semigroup a => a -> a -> a
<> (ServerOperator -> (Maybe PresetOperator, Maybe AServerOperator))
-> [ServerOperator]
-> [(Maybe PresetOperator, Maybe AServerOperator)]
forall a b. (a -> b) -> [a] -> [b]
map (\ServerOperator
op -> (Maybe PresetOperator
forall a. Maybe a
Nothing, AServerOperator -> Maybe AServerOperator
forall a. a -> Maybe a
Just (AServerOperator -> Maybe AServerOperator)
-> AServerOperator -> Maybe AServerOperator
forall a b. (a -> b) -> a -> b
$ SDBStored 'DBStored -> ServerOperator -> AServerOperator
forall (s :: DBStored).
SDBStored s -> ServerOperator' s -> AServerOperator
ASO SDBStored 'DBStored
SDBStored ServerOperator
op)) ((ServerOperator -> Bool) -> [ServerOperator] -> [ServerOperator]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe OperatorTag -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe OperatorTag -> Bool)
-> (ServerOperator -> Maybe OperatorTag) -> ServerOperator -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerOperator -> Maybe OperatorTag
forall (s :: DBStored). ServerOperator' s -> Maybe OperatorTag
operatorTag) [ServerOperator]
storedOps)
  where
    -- TODO remove domains of preset operators from custom
    addPreset :: PresetOperator
-> [(Maybe PresetOperator, Maybe AServerOperator)]
-> [(Maybe PresetOperator, Maybe AServerOperator)]
addPreset PresetOperator
op = ((PresetOperator -> Maybe PresetOperator
forall a. a -> Maybe a
Just PresetOperator
op, NewServerOperator -> AServerOperator
storedOp' (NewServerOperator -> AServerOperator)
-> Maybe NewServerOperator -> Maybe AServerOperator
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PresetOperator -> Maybe NewServerOperator
pOperator PresetOperator
op) (Maybe PresetOperator, Maybe AServerOperator)
-> [(Maybe PresetOperator, Maybe AServerOperator)]
-> [(Maybe PresetOperator, Maybe AServerOperator)]
forall a. a -> [a] -> [a]
:)
      where
        storedOp' :: NewServerOperator -> AServerOperator
storedOp' NewServerOperator
presetOp = case (ServerOperator -> Bool)
-> [ServerOperator] -> Maybe ServerOperator
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((NewServerOperator -> Maybe OperatorTag
forall (s :: DBStored). ServerOperator' s -> Maybe OperatorTag
operatorTag NewServerOperator
presetOp Maybe OperatorTag -> Maybe OperatorTag -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe OperatorTag -> Bool)
-> (ServerOperator -> Maybe OperatorTag) -> ServerOperator -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerOperator -> Maybe OperatorTag
forall (s :: DBStored). ServerOperator' s -> Maybe OperatorTag
operatorTag) [ServerOperator]
storedOps of
          Just ServerOperator {DBEntityId' 'DBStored
$sel:operatorId:ServerOperator :: forall (s :: DBStored). ServerOperator' s -> DBEntityId' s
operatorId :: DBEntityId' 'DBStored
operatorId, ConditionsAcceptance
$sel:conditionsAcceptance:ServerOperator :: forall (s :: DBStored). ServerOperator' s -> ConditionsAcceptance
conditionsAcceptance :: ConditionsAcceptance
conditionsAcceptance, Bool
$sel:enabled:ServerOperator :: forall (s :: DBStored). ServerOperator' s -> Bool
enabled :: Bool
enabled, ServerRoles
$sel:smpRoles:ServerOperator :: forall (s :: DBStored). ServerOperator' s -> ServerRoles
smpRoles :: ServerRoles
smpRoles, ServerRoles
$sel:xftpRoles:ServerOperator :: forall (s :: DBStored). ServerOperator' s -> ServerRoles
xftpRoles :: ServerRoles
xftpRoles} ->
            SDBStored 'DBStored -> ServerOperator -> AServerOperator
forall (s :: DBStored).
SDBStored s -> ServerOperator' s -> AServerOperator
ASO SDBStored 'DBStored
SDBStored NewServerOperator
presetOp {operatorId, conditionsAcceptance, enabled, smpRoles, xftpRoles}
          Maybe ServerOperator
Nothing -> SDBStored 'DBNew -> NewServerOperator -> AServerOperator
forall (s :: DBStored).
SDBStored s -> ServerOperator' s -> AServerOperator
ASO SDBStored 'DBNew
SDBNew NewServerOperator
presetOp

-- This function should be used inside DB transaction to update servers.
updatedUserServers :: (Maybe PresetOperator, UserOperatorServers) -> UpdatedUserOperatorServers
updatedUserServers :: (Maybe PresetOperator, UserOperatorServers)
-> UpdatedUserOperatorServers
updatedUserServers (Maybe PresetOperator
presetOp_, UserOperatorServers {Maybe ServerOperator
$sel:operator:UserOperatorServers :: UserOperatorServers -> Maybe ServerOperator
operator :: Maybe ServerOperator
operator, [UserServer 'PSMP]
$sel:smpServers:UserOperatorServers :: UserOperatorServers -> [UserServer 'PSMP]
smpServers :: [UserServer 'PSMP]
smpServers, [UserServer 'PXFTP]
$sel:xftpServers:UserOperatorServers :: UserOperatorServers -> [UserServer 'PXFTP]
xftpServers :: [UserServer 'PXFTP]
xftpServers, [UserChatRelay]
$sel:chatRelays:UserOperatorServers :: UserOperatorServers -> [UserChatRelay]
chatRelays :: [UserChatRelay]
chatRelays}) =
  UpdatedUserOperatorServers {Maybe ServerOperator
$sel:operator:UpdatedUserOperatorServers :: Maybe ServerOperator
operator :: Maybe ServerOperator
operator, $sel:smpServers:UpdatedUserOperatorServers :: [AUserServer 'PSMP]
smpServers = [AUserServer 'PSMP]
smp', $sel:xftpServers:UpdatedUserOperatorServers :: [AUserServer 'PXFTP]
xftpServers = [AUserServer 'PXFTP]
xftp', $sel:chatRelays:UpdatedUserOperatorServers :: [AUserChatRelay]
chatRelays = [AUserChatRelay]
cRelays'}
  where
    stored :: [UserServer' 'DBStored p] -> [AUserServer p]
stored = (UserServer' 'DBStored p -> AUserServer p)
-> [UserServer' 'DBStored p] -> [AUserServer p]
forall a b. (a -> b) -> [a] -> [b]
map (SDBStored 'DBStored -> UserServer' 'DBStored p -> AUserServer p
forall (p :: ProtocolType) (s :: DBStored).
SDBStored s -> UserServer' s p -> AUserServer p
AUS SDBStored 'DBStored
SDBStored)
    storedRelays :: [UserChatRelay] -> [AUserChatRelay]
storedRelays = (UserChatRelay -> AUserChatRelay)
-> [UserChatRelay] -> [AUserChatRelay]
forall a b. (a -> b) -> [a] -> [b]
map (SDBStored 'DBStored -> UserChatRelay -> AUserChatRelay
forall (s :: DBStored).
SDBStored s -> UserChatRelay' s -> AUserChatRelay
AUCR SDBStored 'DBStored
SDBStored)
    ([AUserServer 'PSMP]
smp', [AUserServer 'PXFTP]
xftp', [AUserChatRelay]
cRelays') = case Maybe PresetOperator
presetOp_ of
      Maybe PresetOperator
Nothing -> ([UserServer 'PSMP] -> [AUserServer 'PSMP]
forall {p :: ProtocolType}.
[UserServer' 'DBStored p] -> [AUserServer p]
stored [UserServer 'PSMP]
smpServers, [UserServer 'PXFTP] -> [AUserServer 'PXFTP]
forall {p :: ProtocolType}.
[UserServer' 'DBStored p] -> [AUserServer p]
stored [UserServer 'PXFTP]
xftpServers, [UserChatRelay] -> [AUserChatRelay]
storedRelays [UserChatRelay]
chatRelays)
      Just PresetOperator
presetOp -> (SProtocolType 'PSMP -> [UserServer 'PSMP] -> [AUserServer 'PSMP]
forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> [UserServer p] -> [AUserServer p]
updated SProtocolType 'PSMP
SPSMP [UserServer 'PSMP]
smpServers, SProtocolType 'PXFTP -> [UserServer 'PXFTP] -> [AUserServer 'PXFTP]
forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> [UserServer p] -> [AUserServer p]
updated SProtocolType 'PXFTP
SPXFTP [UserServer 'PXFTP]
xftpServers, [UserChatRelay] -> [AUserChatRelay]
updatedRelays [UserChatRelay]
chatRelays)
        where
          updated :: forall p. UserProtocol p => SProtocolType p -> [UserServer p] -> [AUserServer p]
          updated :: forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> [UserServer p] -> [AUserServer p]
updated SProtocolType p
p [UserServer p]
srvs = (NewUserServer p -> AUserServer p)
-> [NewUserServer p] -> [AUserServer p]
forall a b. (a -> b) -> [a] -> [b]
map NewUserServer p -> AUserServer p
userServer [NewUserServer p]
presetSrvs [AUserServer p] -> [AUserServer p] -> [AUserServer p]
forall a. Semigroup a => a -> a -> a
<> [UserServer p] -> [AUserServer p]
forall {p :: ProtocolType}.
[UserServer' 'DBStored p] -> [AUserServer p]
stored ((UserServer p -> Bool) -> [UserServer p] -> [UserServer p]
forall a. (a -> Bool) -> [a] -> [a]
filter UserServer p -> Bool
customServer [UserServer p]
srvs)
            where
              storedSrvs :: Map (ProtoServerWithAuth p) (UserServer p)
              storedSrvs :: Map (ProtoServerWithAuth p) (UserServer p)
storedSrvs = (Map (ProtoServerWithAuth p) (UserServer p)
 -> UserServer p -> Map (ProtoServerWithAuth p) (UserServer p))
-> Map (ProtoServerWithAuth p) (UserServer p)
-> [UserServer p]
-> Map (ProtoServerWithAuth p) (UserServer p)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map (ProtoServerWithAuth p) (UserServer p)
ss srv :: UserServer p
srv@UserServer {ProtoServerWithAuth p
$sel:server:UserServer :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server} -> ProtoServerWithAuth p
-> UserServer p
-> Map (ProtoServerWithAuth p) (UserServer p)
-> Map (ProtoServerWithAuth p) (UserServer p)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ProtoServerWithAuth p
server UserServer p
srv Map (ProtoServerWithAuth p) (UserServer p)
ss) Map (ProtoServerWithAuth p) (UserServer p)
forall k a. Map k a
M.empty [UserServer p]
srvs
              customServer :: UserServer p -> Bool
              customServer :: UserServer p -> Bool
customServer srv :: UserServer p
srv@UserServer {Bool
$sel:preset:UserServer :: forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
preset :: Bool
preset} = Bool -> Bool
not Bool
preset Bool -> Bool -> Bool
&& (TransportHost -> Bool) -> NonEmpty TransportHost -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TransportHost -> Set TransportHost -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set TransportHost
presetHosts) (UserServer p -> NonEmpty TransportHost
forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> NonEmpty TransportHost
srvHost UserServer p
srv)
              presetSrvs :: [NewUserServer p]
              presetSrvs :: [NewUserServer p]
presetSrvs = SProtocolType p -> PresetOperator -> [NewUserServer p]
forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> PresetOperator -> [NewUserServer p]
pServers SProtocolType p
p PresetOperator
presetOp
              presetHosts :: Set TransportHost
              presetHosts :: Set TransportHost
presetHosts = (NewUserServer p -> Set TransportHost)
-> [NewUserServer p] -> Set TransportHost
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' ([TransportHost] -> Set TransportHost
forall a. Ord a => [a] -> Set a
S.fromList ([TransportHost] -> Set TransportHost)
-> (NewUserServer p -> [TransportHost])
-> NewUserServer p
-> Set TransportHost
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty TransportHost -> [TransportHost]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty TransportHost -> [TransportHost])
-> (NewUserServer p -> NonEmpty TransportHost)
-> NewUserServer p
-> [TransportHost]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewUserServer p -> NonEmpty TransportHost
forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> NonEmpty TransportHost
srvHost) [NewUserServer p]
presetSrvs
              userServer :: NewUserServer p -> AUserServer p
              userServer :: NewUserServer p -> AUserServer p
userServer srv :: NewUserServer p
srv@UserServer {ProtoServerWithAuth p
$sel:server:UserServer :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server} = AUserServer p
-> (UserServer p -> AUserServer p)
-> Maybe (UserServer p)
-> AUserServer p
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SDBStored 'DBNew -> NewUserServer p -> AUserServer p
forall (p :: ProtocolType) (s :: DBStored).
SDBStored s -> UserServer' s p -> AUserServer p
AUS SDBStored 'DBNew
SDBNew NewUserServer p
srv) (SDBStored 'DBStored -> UserServer p -> AUserServer p
forall (p :: ProtocolType) (s :: DBStored).
SDBStored s -> UserServer' s p -> AUserServer p
AUS SDBStored 'DBStored
SDBStored) (ProtoServerWithAuth p
-> Map (ProtoServerWithAuth p) (UserServer p)
-> Maybe (UserServer p)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ProtoServerWithAuth p
server Map (ProtoServerWithAuth p) (UserServer p)
storedSrvs)
          updatedRelays :: [UserChatRelay] -> [AUserChatRelay]
          updatedRelays :: [UserChatRelay] -> [AUserChatRelay]
updatedRelays [UserChatRelay]
relays = (NewUserChatRelay -> AUserChatRelay)
-> [NewUserChatRelay] -> [AUserChatRelay]
forall a b. (a -> b) -> [a] -> [b]
map NewUserChatRelay -> AUserChatRelay
userRelay [NewUserChatRelay]
presetRelays [AUserChatRelay] -> [AUserChatRelay] -> [AUserChatRelay]
forall a. Semigroup a => a -> a -> a
<> [UserChatRelay] -> [AUserChatRelay]
storedRelays ((UserChatRelay -> Bool) -> [UserChatRelay] -> [UserChatRelay]
forall a. (a -> Bool) -> [a] -> [a]
filter UserChatRelay -> Bool
customRelay [UserChatRelay]
relays)
            where
              customRelay :: UserChatRelay -> Bool
              customRelay :: UserChatRelay -> Bool
customRelay UserChatRelay {Bool
$sel:preset:UserChatRelay :: forall (s :: DBStored). UserChatRelay' s -> Bool
preset :: Bool
preset, ShortLinkContact
$sel:address:UserChatRelay :: forall (s :: DBStored). UserChatRelay' s -> ShortLinkContact
address :: ShortLinkContact
address} =
                Bool -> Bool
not Bool
preset Bool -> Bool -> Bool
&& Bool -> Bool
not ((NewUserChatRelay -> Bool) -> [NewUserChatRelay] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ShortLinkContact -> ShortLinkContact -> Bool
sameShortLinkContact ShortLinkContact
address (ShortLinkContact -> Bool)
-> (NewUserChatRelay -> ShortLinkContact)
-> NewUserChatRelay
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewUserChatRelay -> ShortLinkContact
forall (s :: DBStored). UserChatRelay' s -> ShortLinkContact
chatRelayAddress) [NewUserChatRelay]
presetRelays)
              presetRelays :: [NewUserChatRelay]
              presetRelays :: [NewUserChatRelay]
presetRelays =
                let PresetOperator {$sel:chatRelays:PresetOperator :: PresetOperator -> [NewUserChatRelay]
chatRelays = [NewUserChatRelay]
crs} = PresetOperator
presetOp
                 in [NewUserChatRelay]
crs
              userRelay :: NewUserChatRelay -> AUserChatRelay
              userRelay :: NewUserChatRelay -> AUserChatRelay
userRelay relay :: NewUserChatRelay
relay@UserChatRelay {ShortLinkContact
$sel:address:UserChatRelay :: forall (s :: DBStored). UserChatRelay' s -> ShortLinkContact
address :: ShortLinkContact
address} =
                AUserChatRelay
-> (UserChatRelay -> AUserChatRelay)
-> Maybe UserChatRelay
-> AUserChatRelay
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SDBStored 'DBNew -> NewUserChatRelay -> AUserChatRelay
forall (s :: DBStored).
SDBStored s -> UserChatRelay' s -> AUserChatRelay
AUCR SDBStored 'DBNew
SDBNew NewUserChatRelay
relay) (SDBStored 'DBStored -> UserChatRelay -> AUserChatRelay
forall (s :: DBStored).
SDBStored s -> UserChatRelay' s -> AUserChatRelay
AUCR SDBStored 'DBStored
SDBStored) (Maybe UserChatRelay -> AUserChatRelay)
-> Maybe UserChatRelay -> AUserChatRelay
forall a b. (a -> b) -> a -> b
$
                  (UserChatRelay -> Bool) -> [UserChatRelay] -> Maybe UserChatRelay
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (ShortLinkContact -> ShortLinkContact -> Bool
sameShortLinkContact ShortLinkContact
address (ShortLinkContact -> Bool)
-> (UserChatRelay -> ShortLinkContact) -> UserChatRelay -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserChatRelay -> ShortLinkContact
forall (s :: DBStored). UserChatRelay' s -> ShortLinkContact
chatRelayAddress) [UserChatRelay]
relays

srvHost :: UserServer' s p -> NonEmpty TransportHost
srvHost :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> NonEmpty TransportHost
srvHost UserServer {$sel:server:UserServer :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> ProtoServerWithAuth p
server = ProtoServerWithAuth ProtocolServer p
srv Maybe BasicAuth
_} = ProtocolServer p -> NonEmpty TransportHost
forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host ProtocolServer p
srv

chatRelayAddress :: UserChatRelay' s -> ShortLinkContact
chatRelayAddress :: forall (s :: DBStored). UserChatRelay' s -> ShortLinkContact
chatRelayAddress UserChatRelay {ShortLinkContact
$sel:address:UserChatRelay :: forall (s :: DBStored). UserChatRelay' s -> ShortLinkContact
address :: ShortLinkContact
address} = ShortLinkContact
address

agentServerCfgs :: UserProtocol p => SProtocolType p -> [(Text, ServerOperator)] -> [UserServer' s p] -> [ServerCfg p]
agentServerCfgs :: forall (p :: ProtocolType) (s :: DBStored).
UserProtocol p =>
SProtocolType p
-> [(Text, ServerOperator)] -> [UserServer' s p] -> [ServerCfg p]
agentServerCfgs SProtocolType p
p [(Text, ServerOperator)]
opDomains = (UserServer' s p -> Maybe (ServerCfg p))
-> [UserServer' s p] -> [ServerCfg p]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe UserServer' s p -> Maybe (ServerCfg p)
forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> Maybe (ServerCfg p)
agentServer
  where
    agentServer :: UserServer' s p -> Maybe (ServerCfg p)
    agentServer :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> Maybe (ServerCfg p)
agentServer srv :: UserServer' s p
srv@UserServer {ProtoServerWithAuth p
$sel:server:UserServer :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server, Bool
$sel:enabled:UserServer :: forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
enabled :: Bool
enabled} =
      case ((Text, ServerOperator) -> Bool)
-> [(Text, ServerOperator)] -> Maybe (Text, ServerOperator)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Text
d, ServerOperator
_) -> (TransportHost -> Bool) -> NonEmpty TransportHost -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> TransportHost -> Bool
matchingHost Text
d) (UserServer' s p -> NonEmpty TransportHost
forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> NonEmpty TransportHost
srvHost UserServer' s p
srv)) [(Text, ServerOperator)]
opDomains of
        Just (Text
_, op :: ServerOperator
op@ServerOperator {$sel:operatorId:ServerOperator :: forall (s :: DBStored). ServerOperator' s -> DBEntityId' s
operatorId = DBEntityId Int64
opId, $sel:enabled:ServerOperator :: forall (s :: DBStored). ServerOperator' s -> Bool
enabled = Bool
opEnabled})
          | Bool
opEnabled -> ServerCfg p -> Maybe (ServerCfg p)
forall a. a -> Maybe a
Just ServerCfg {ProtoServerWithAuth p
server :: ProtoServerWithAuth p
$sel:server:ServerCfg :: ProtoServerWithAuth p
server, Bool
enabled :: Bool
$sel:enabled:ServerCfg :: Bool
enabled, $sel:operator:ServerCfg :: Maybe Int64
operator = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
opId, $sel:roles:ServerCfg :: ServerRoles
roles = SProtocolType p -> ServerOperator -> ServerRoles
forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> ServerOperator -> ServerRoles
operatorRoles SProtocolType p
p ServerOperator
op}
          | Bool
otherwise -> Maybe (ServerCfg p)
forall a. Maybe a
Nothing
        Maybe (Text, ServerOperator)
Nothing ->
          ServerCfg p -> Maybe (ServerCfg p)
forall a. a -> Maybe a
Just ServerCfg {ProtoServerWithAuth p
server :: ProtoServerWithAuth p
$sel:server:ServerCfg :: ProtoServerWithAuth p
server, Bool
enabled :: Bool
$sel:enabled:ServerCfg :: Bool
enabled, $sel:operator:ServerCfg :: Maybe Int64
operator = Maybe Int64
forall a. Maybe a
Nothing, $sel:roles:ServerCfg :: ServerRoles
roles = ServerRoles
allRoles}

matchingHost :: Text -> TransportHost -> Bool
matchingHost :: Text -> TransportHost -> Bool
matchingHost Text
d = \case
  THDomainName String
h -> Text
d Text -> Text -> Bool
`T.isSuffixOf` String -> Text
T.pack String
h
  TransportHost
_ -> Bool
False

operatorDomains :: [ServerOperator' s] -> [(Text, ServerOperator' s)]
operatorDomains :: forall (s :: DBStored).
[ServerOperator' s] -> [(Text, ServerOperator' s)]
operatorDomains = (ServerOperator' s
 -> [(Text, ServerOperator' s)] -> [(Text, ServerOperator' s)])
-> [(Text, ServerOperator' s)]
-> [ServerOperator' s]
-> [(Text, ServerOperator' s)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ServerOperator' s
op [(Text, ServerOperator' s)]
ds -> (Text
 -> [(Text, ServerOperator' s)] -> [(Text, ServerOperator' s)])
-> [(Text, ServerOperator' s)]
-> [Text]
-> [(Text, ServerOperator' s)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Text
d -> ((Text
d, ServerOperator' s
op) (Text, ServerOperator' s)
-> [(Text, ServerOperator' s)] -> [(Text, ServerOperator' s)]
forall a. a -> [a] -> [a]
:)) [(Text, ServerOperator' s)]
ds (ServerOperator' s -> [Text]
forall (s :: DBStored). ServerOperator' s -> [Text]
serverDomains ServerOperator' s
op)) []

class Box b where
  box :: a -> b a
  unbox :: b a -> a

instance Box Identity where
  box :: forall a. a -> Identity a
box = a -> Identity a
forall a. a -> Identity a
Identity
  unbox :: forall a. Identity a -> a
unbox = Identity a -> a
forall a. Identity a -> a
runIdentity

instance Box ((,) (Maybe a)) where
  box :: forall a. a -> (Maybe a, a)
box = (Maybe a
forall a. Maybe a
Nothing,)
  unbox :: forall a. (Maybe a, a) -> a
unbox = (Maybe a, a) -> a
forall a b. (a, b) -> b
snd

groupByOperator :: ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP], [UserChatRelay]) -> IO [UserOperatorServers]
groupByOperator :: ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP],
 [UserChatRelay])
-> IO [UserOperatorServers]
groupByOperator ([Maybe ServerOperator]
ops, [UserServer 'PSMP]
smpSrvs, [UserServer 'PXFTP]
xftpSrvs, [UserChatRelay]
chatRelays) = (Identity UserOperatorServers -> UserOperatorServers)
-> [Identity UserOperatorServers] -> [UserOperatorServers]
forall a b. (a -> b) -> [a] -> [b]
map Identity UserOperatorServers -> UserOperatorServers
forall a. Identity a -> a
runIdentity ([Identity UserOperatorServers] -> [UserOperatorServers])
-> IO [Identity UserOperatorServers] -> IO [UserOperatorServers]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Identity (Maybe ServerOperator)], [UserServer 'PSMP],
 [UserServer 'PXFTP], [UserChatRelay])
-> IO [Identity UserOperatorServers]
forall (f :: * -> *).
(Box f, Traversable f) =>
([f (Maybe ServerOperator)], [UserServer 'PSMP],
 [UserServer 'PXFTP], [UserChatRelay])
-> IO [f UserOperatorServers]
groupByOperator_ ((Maybe ServerOperator -> Identity (Maybe ServerOperator))
-> [Maybe ServerOperator] -> [Identity (Maybe ServerOperator)]
forall a b. (a -> b) -> [a] -> [b]
map Maybe ServerOperator -> Identity (Maybe ServerOperator)
forall a. a -> Identity a
Identity [Maybe ServerOperator]
ops, [UserServer 'PSMP]
smpSrvs, [UserServer 'PXFTP]
xftpSrvs, [UserChatRelay]
chatRelays)

-- For the initial app start this function relies on tuple being Functor/Box
-- to preserve the information about operator being DBNew or DBStored
groupByOperator' :: ([(Maybe PresetOperator, Maybe ServerOperator)], [UserServer 'PSMP], [UserServer 'PXFTP], [UserChatRelay]) -> IO [(Maybe PresetOperator, UserOperatorServers)]
groupByOperator' :: ([(Maybe PresetOperator, Maybe ServerOperator)],
 [UserServer 'PSMP], [UserServer 'PXFTP], [UserChatRelay])
-> IO [(Maybe PresetOperator, UserOperatorServers)]
groupByOperator' = ([(Maybe PresetOperator, Maybe ServerOperator)],
 [UserServer 'PSMP], [UserServer 'PXFTP], [UserChatRelay])
-> IO [(Maybe PresetOperator, UserOperatorServers)]
forall (f :: * -> *).
(Box f, Traversable f) =>
([f (Maybe ServerOperator)], [UserServer 'PSMP],
 [UserServer 'PXFTP], [UserChatRelay])
-> IO [f UserOperatorServers]
groupByOperator_
{-# INLINE groupByOperator' #-}

groupByOperator_ :: forall f. (Box f, Traversable f) => ([f (Maybe ServerOperator)], [UserServer 'PSMP], [UserServer 'PXFTP], [UserChatRelay]) -> IO [f UserOperatorServers]
groupByOperator_ :: forall (f :: * -> *).
(Box f, Traversable f) =>
([f (Maybe ServerOperator)], [UserServer 'PSMP],
 [UserServer 'PXFTP], [UserChatRelay])
-> IO [f UserOperatorServers]
groupByOperator_ ([f (Maybe ServerOperator)]
ops, [UserServer 'PSMP]
smpSrvs, [UserServer 'PXFTP]
xftpSrvs, [UserChatRelay]
cRelays) = do
  let ops' :: [f ServerOperator]
ops' = (f (Maybe ServerOperator) -> Maybe (f ServerOperator))
-> [f (Maybe ServerOperator)] -> [f ServerOperator]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe f (Maybe ServerOperator) -> Maybe (f ServerOperator)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => f (m a) -> m (f a)
sequence [f (Maybe ServerOperator)]
ops
      customOp_ :: Maybe (f (Maybe ServerOperator))
customOp_ = (f (Maybe ServerOperator) -> Bool)
-> [f (Maybe ServerOperator)] -> Maybe (f (Maybe ServerOperator))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Maybe ServerOperator -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe ServerOperator -> Bool)
-> (f (Maybe ServerOperator) -> Maybe ServerOperator)
-> f (Maybe ServerOperator)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Maybe ServerOperator) -> Maybe ServerOperator
forall a. f a -> a
forall (b :: * -> *) a. Box b => b a -> a
unbox) [f (Maybe ServerOperator)]
ops
  [([Text], IORef (f UserOperatorServers))]
ss <- (f ServerOperator -> IO ([Text], IORef (f UserOperatorServers)))
-> [f ServerOperator]
-> IO [([Text], IORef (f UserOperatorServers))]
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 ((\f ServerOperator
op -> (ServerOperator -> [Text]
forall (s :: DBStored). ServerOperator' s -> [Text]
serverDomains (f ServerOperator -> ServerOperator
forall a. f a -> a
forall (b :: * -> *) a. Box b => b a -> a
unbox f ServerOperator
op),) (IORef (f UserOperatorServers)
 -> ([Text], IORef (f UserOperatorServers)))
-> IO (IORef (f UserOperatorServers))
-> IO ([Text], IORef (f UserOperatorServers))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f UserOperatorServers -> IO (IORef (f UserOperatorServers))
forall a. a -> IO (IORef a)
newIORef (Maybe ServerOperator -> UserOperatorServers
mkUS (Maybe ServerOperator -> UserOperatorServers)
-> (ServerOperator -> Maybe ServerOperator)
-> ServerOperator
-> UserOperatorServers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerOperator -> Maybe ServerOperator
forall a. a -> Maybe a
Just (ServerOperator -> UserOperatorServers)
-> f ServerOperator -> f UserOperatorServers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f ServerOperator
op))) [f ServerOperator]
ops'
  IORef (f UserOperatorServers)
custom <- f UserOperatorServers -> IO (IORef (f UserOperatorServers))
forall a. a -> IO (IORef a)
newIORef (f UserOperatorServers -> IO (IORef (f UserOperatorServers)))
-> f UserOperatorServers -> IO (IORef (f UserOperatorServers))
forall a b. (a -> b) -> a -> b
$ f UserOperatorServers
-> (f (Maybe ServerOperator) -> f UserOperatorServers)
-> Maybe (f (Maybe ServerOperator))
-> f UserOperatorServers
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UserOperatorServers -> f UserOperatorServers
forall a. a -> f a
forall (b :: * -> *) a. Box b => a -> b a
box (UserOperatorServers -> f UserOperatorServers)
-> UserOperatorServers -> f UserOperatorServers
forall a b. (a -> b) -> a -> b
$ Maybe ServerOperator -> UserOperatorServers
mkUS Maybe ServerOperator
forall a. Maybe a
Nothing) (Maybe ServerOperator -> UserOperatorServers
mkUS (Maybe ServerOperator -> UserOperatorServers)
-> f (Maybe ServerOperator) -> f UserOperatorServers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) Maybe (f (Maybe ServerOperator))
customOp_
  (UserServer 'PSMP -> IO ()) -> [UserServer 'PSMP] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([([Text], IORef (f UserOperatorServers))]
-> IORef (f UserOperatorServers)
-> (UserServer 'PSMP -> UserOperatorServers -> UserOperatorServers)
-> UserServer 'PSMP
-> IO ()
forall (p :: ProtocolType).
[([Text], IORef (f UserOperatorServers))]
-> IORef (f UserOperatorServers)
-> (UserServer p -> UserOperatorServers -> UserOperatorServers)
-> UserServer p
-> IO ()
addServer [([Text], IORef (f UserOperatorServers))]
ss IORef (f UserOperatorServers)
custom UserServer 'PSMP -> UserOperatorServers -> UserOperatorServers
addSMP) ([UserServer 'PSMP] -> [UserServer 'PSMP]
forall a. [a] -> [a]
reverse [UserServer 'PSMP]
smpSrvs)
  (UserServer 'PXFTP -> IO ()) -> [UserServer 'PXFTP] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([([Text], IORef (f UserOperatorServers))]
-> IORef (f UserOperatorServers)
-> (UserServer 'PXFTP
    -> UserOperatorServers -> UserOperatorServers)
-> UserServer 'PXFTP
-> IO ()
forall (p :: ProtocolType).
[([Text], IORef (f UserOperatorServers))]
-> IORef (f UserOperatorServers)
-> (UserServer p -> UserOperatorServers -> UserOperatorServers)
-> UserServer p
-> IO ()
addServer [([Text], IORef (f UserOperatorServers))]
ss IORef (f UserOperatorServers)
custom UserServer 'PXFTP -> UserOperatorServers -> UserOperatorServers
addXFTP) ([UserServer 'PXFTP] -> [UserServer 'PXFTP]
forall a. [a] -> [a]
reverse [UserServer 'PXFTP]
xftpSrvs)
  (UserChatRelay -> IO ()) -> [UserChatRelay] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([([Text], IORef (f UserOperatorServers))]
-> IORef (f UserOperatorServers) -> UserChatRelay -> IO ()
addChatRelay [([Text], IORef (f UserOperatorServers))]
ss IORef (f UserOperatorServers)
custom) [UserChatRelay]
cRelays
  [f UserOperatorServers]
opSrvs <- (([Text], IORef (f UserOperatorServers))
 -> IO (f UserOperatorServers))
-> [([Text], IORef (f UserOperatorServers))]
-> IO [f UserOperatorServers]
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 (IORef (f UserOperatorServers) -> IO (f UserOperatorServers)
forall a. IORef a -> IO a
readIORef (IORef (f UserOperatorServers) -> IO (f UserOperatorServers))
-> (([Text], IORef (f UserOperatorServers))
    -> IORef (f UserOperatorServers))
-> ([Text], IORef (f UserOperatorServers))
-> IO (f UserOperatorServers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text], IORef (f UserOperatorServers))
-> IORef (f UserOperatorServers)
forall a b. (a, b) -> b
snd) [([Text], IORef (f UserOperatorServers))]
ss
  f UserOperatorServers
customSrvs <- IORef (f UserOperatorServers) -> IO (f UserOperatorServers)
forall a. IORef a -> IO a
readIORef IORef (f UserOperatorServers)
custom
  [f UserOperatorServers] -> IO [f UserOperatorServers]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([f UserOperatorServers] -> IO [f UserOperatorServers])
-> [f UserOperatorServers] -> IO [f UserOperatorServers]
forall a b. (a -> b) -> a -> b
$ [f UserOperatorServers]
opSrvs [f UserOperatorServers]
-> [f UserOperatorServers] -> [f UserOperatorServers]
forall a. Semigroup a => a -> a -> a
<> [f UserOperatorServers
Item [f UserOperatorServers]
customSrvs]
  where
    mkUS :: Maybe ServerOperator -> UserOperatorServers
mkUS Maybe ServerOperator
op = Maybe ServerOperator
-> [UserServer 'PSMP]
-> [UserServer 'PXFTP]
-> [UserChatRelay]
-> UserOperatorServers
UserOperatorServers Maybe ServerOperator
op [] [] []
    addServer :: [([Text], IORef (f UserOperatorServers))] -> IORef (f UserOperatorServers) -> (UserServer p -> UserOperatorServers -> UserOperatorServers) -> UserServer p -> IO ()
    addServer :: forall (p :: ProtocolType).
[([Text], IORef (f UserOperatorServers))]
-> IORef (f UserOperatorServers)
-> (UserServer p -> UserOperatorServers -> UserOperatorServers)
-> UserServer p
-> IO ()
addServer [([Text], IORef (f UserOperatorServers))]
ss IORef (f UserOperatorServers)
custom UserServer p -> UserOperatorServers -> UserOperatorServers
add UserServer p
srv =
      let v :: IORef (f UserOperatorServers)
v = IORef (f UserOperatorServers)
-> (([Text], IORef (f UserOperatorServers))
    -> IORef (f UserOperatorServers))
-> Maybe ([Text], IORef (f UserOperatorServers))
-> IORef (f UserOperatorServers)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IORef (f UserOperatorServers)
custom ([Text], IORef (f UserOperatorServers))
-> IORef (f UserOperatorServers)
forall a b. (a, b) -> b
snd (Maybe ([Text], IORef (f UserOperatorServers))
 -> IORef (f UserOperatorServers))
-> Maybe ([Text], IORef (f UserOperatorServers))
-> IORef (f UserOperatorServers)
forall a b. (a -> b) -> a -> b
$ (([Text], IORef (f UserOperatorServers)) -> Bool)
-> [([Text], IORef (f UserOperatorServers))]
-> Maybe ([Text], IORef (f UserOperatorServers))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\([Text]
ds, IORef (f UserOperatorServers)
_) -> (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Text
d -> (TransportHost -> Bool) -> NonEmpty TransportHost -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> TransportHost -> Bool
matchingHost Text
d) (UserServer p -> NonEmpty TransportHost
forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> NonEmpty TransportHost
srvHost UserServer p
srv)) [Text]
ds) [([Text], IORef (f UserOperatorServers))]
ss
       in IORef (f UserOperatorServers)
-> (f UserOperatorServers -> f UserOperatorServers) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ IORef (f UserOperatorServers)
v (UserServer p -> UserOperatorServers -> UserOperatorServers
add UserServer p
srv (UserOperatorServers -> UserOperatorServers)
-> f UserOperatorServers -> f UserOperatorServers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
    addSMP :: UserServer 'PSMP -> UserOperatorServers -> UserOperatorServers
addSMP UserServer 'PSMP
srv s :: UserOperatorServers
s@UserOperatorServers {[UserServer 'PSMP]
$sel:smpServers:UserOperatorServers :: UserOperatorServers -> [UserServer 'PSMP]
smpServers :: [UserServer 'PSMP]
smpServers} = (UserOperatorServers
s :: UserOperatorServers) {smpServers = srv : smpServers}
    addXFTP :: UserServer 'PXFTP -> UserOperatorServers -> UserOperatorServers
addXFTP UserServer 'PXFTP
srv s :: UserOperatorServers
s@UserOperatorServers {[UserServer 'PXFTP]
$sel:xftpServers:UserOperatorServers :: UserOperatorServers -> [UserServer 'PXFTP]
xftpServers :: [UserServer 'PXFTP]
xftpServers} = (UserOperatorServers
s :: UserOperatorServers) {xftpServers = srv : xftpServers}
    addChatRelay :: [([Text], IORef (f UserOperatorServers))] -> IORef (f UserOperatorServers) -> UserChatRelay -> IO ()
    addChatRelay :: [([Text], IORef (f UserOperatorServers))]
-> IORef (f UserOperatorServers) -> UserChatRelay -> IO ()
addChatRelay [([Text], IORef (f UserOperatorServers))]
ss IORef (f UserOperatorServers)
custom UserChatRelay
chatRelay =
      let v :: IORef (f UserOperatorServers)
v = IORef (f UserOperatorServers)
-> (([Text], IORef (f UserOperatorServers))
    -> IORef (f UserOperatorServers))
-> Maybe ([Text], IORef (f UserOperatorServers))
-> IORef (f UserOperatorServers)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IORef (f UserOperatorServers)
custom ([Text], IORef (f UserOperatorServers))
-> IORef (f UserOperatorServers)
forall a b. (a, b) -> b
snd (Maybe ([Text], IORef (f UserOperatorServers))
 -> IORef (f UserOperatorServers))
-> Maybe ([Text], IORef (f UserOperatorServers))
-> IORef (f UserOperatorServers)
forall a b. (a -> b) -> a -> b
$ (([Text], IORef (f UserOperatorServers)) -> Bool)
-> [([Text], IORef (f UserOperatorServers))]
-> Maybe ([Text], IORef (f UserOperatorServers))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\([Text]
ds, IORef (f UserOperatorServers)
_) -> (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` UserChatRelay -> [Text]
forall (s :: DBStored). UserChatRelay' s -> [Text]
domains UserChatRelay
chatRelay) [Text]
ds) [([Text], IORef (f UserOperatorServers))]
ss
       in IORef (f UserOperatorServers)
-> (f UserOperatorServers -> f UserOperatorServers) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ IORef (f UserOperatorServers)
v (UserOperatorServers -> UserOperatorServers
addCRelay (UserOperatorServers -> UserOperatorServers)
-> f UserOperatorServers -> f UserOperatorServers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
      where
        addCRelay :: UserOperatorServers -> UserOperatorServers
addCRelay s :: UserOperatorServers
s@UserOperatorServers {[UserChatRelay]
$sel:chatRelays:UserOperatorServers :: UserOperatorServers -> [UserChatRelay]
chatRelays :: [UserChatRelay]
chatRelays} = (UserOperatorServers
s :: UserOperatorServers) {chatRelays = chatRelay : chatRelays}

data UserServersError
  = USENoServers {UserServersError -> AProtocolType
protocol :: AProtocolType, UserServersError -> Maybe User
user :: Maybe User}
  | USEStorageMissing {protocol :: AProtocolType, user :: Maybe User}
  | USEProxyMissing {protocol :: AProtocolType, user :: Maybe User}
  | USEDuplicateServer {protocol :: AProtocolType, UserServersError -> Text
duplicateServer :: Text, UserServersError -> TransportHost
duplicateHost :: TransportHost}
  | USEDuplicateChatRelayAddress {UserServersError -> Text
duplicateChatRelay :: Text, UserServersError -> ShortLinkContact
duplicateAddress :: ShortLinkContact}
  deriving (Int -> UserServersError -> ShowS
[UserServersError] -> ShowS
UserServersError -> String
(Int -> UserServersError -> ShowS)
-> (UserServersError -> String)
-> ([UserServersError] -> ShowS)
-> Show UserServersError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserServersError -> ShowS
showsPrec :: Int -> UserServersError -> ShowS
$cshow :: UserServersError -> String
show :: UserServersError -> String
$cshowList :: [UserServersError] -> ShowS
showList :: [UserServersError] -> ShowS
Show)

data UserServersWarning = USWNoChatRelays {UserServersWarning -> Maybe User
user :: Maybe User}
  deriving (Int -> UserServersWarning -> ShowS
[UserServersWarning] -> ShowS
UserServersWarning -> String
(Int -> UserServersWarning -> ShowS)
-> (UserServersWarning -> String)
-> ([UserServersWarning] -> ShowS)
-> Show UserServersWarning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserServersWarning -> ShowS
showsPrec :: Int -> UserServersWarning -> ShowS
$cshow :: UserServersWarning -> String
show :: UserServersWarning -> String
$cshowList :: [UserServersWarning] -> ShowS
showList :: [UserServersWarning] -> ShowS
Show)

validateUserServers :: UserServersClass u' => [u'] -> [(User, [UserOperatorServers])] -> ([UserServersError], [UserServersWarning])
validateUserServers :: forall u'.
UserServersClass u' =>
[u']
-> [(User, [UserOperatorServers])]
-> ([UserServersError], [UserServersWarning])
validateUserServers [u']
curr [(User, [UserOperatorServers])]
others = ([UserServersError]
currUserErrs [UserServersError] -> [UserServersError] -> [UserServersError]
forall a. Semigroup a => a -> a -> a
<> ((User, [UserOperatorServers]) -> [UserServersError])
-> [(User, [UserOperatorServers])] -> [UserServersError]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (User, [UserOperatorServers]) -> [UserServersError]
forall {u}. UserServersClass u => (User, [u]) -> [UserServersError]
otherUserErrs [(User, [UserOperatorServers])]
others, [UserServersWarning]
currUserWarns [UserServersWarning]
-> [UserServersWarning] -> [UserServersWarning]
forall a. Semigroup a => a -> a -> a
<> ((User, [UserOperatorServers]) -> [UserServersWarning])
-> [(User, [UserOperatorServers])] -> [UserServersWarning]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (User, [UserOperatorServers]) -> [UserServersWarning]
forall {u}.
UserServersClass u =>
(User, [u]) -> [UserServersWarning]
otherUserWarns [(User, [UserOperatorServers])]
others)
  where
    currUserErrs :: [UserServersError]
currUserErrs = SProtocolType 'PSMP -> Maybe User -> [u'] -> [UserServersError]
forall u (p :: ProtocolType).
(UserServersClass u, ProtocolTypeI p, UserProtocol p) =>
SProtocolType p -> Maybe User -> [u] -> [UserServersError]
noServersErrs SProtocolType 'PSMP
SPSMP Maybe User
forall a. Maybe a
Nothing [u']
curr [UserServersError] -> [UserServersError] -> [UserServersError]
forall a. Semigroup a => a -> a -> a
<> SProtocolType 'PXFTP -> Maybe User -> [u'] -> [UserServersError]
forall u (p :: ProtocolType).
(UserServersClass u, ProtocolTypeI p, UserProtocol p) =>
SProtocolType p -> Maybe User -> [u] -> [UserServersError]
noServersErrs SProtocolType 'PXFTP
SPXFTP Maybe User
forall a. Maybe a
Nothing [u']
curr [UserServersError] -> [UserServersError] -> [UserServersError]
forall a. Semigroup a => a -> a -> a
<> SProtocolType 'PSMP -> [u'] -> [UserServersError]
forall u (p :: ProtocolType).
(UserServersClass u, ProtocolTypeI p, UserProtocol p) =>
SProtocolType p -> [u] -> [UserServersError]
serverErrs SProtocolType 'PSMP
SPSMP [u']
curr [UserServersError] -> [UserServersError] -> [UserServersError]
forall a. Semigroup a => a -> a -> a
<> SProtocolType 'PXFTP -> [u'] -> [UserServersError]
forall u (p :: ProtocolType).
(UserServersClass u, ProtocolTypeI p, UserProtocol p) =>
SProtocolType p -> [u] -> [UserServersError]
serverErrs SProtocolType 'PXFTP
SPXFTP [u']
curr [UserServersError] -> [UserServersError] -> [UserServersError]
forall a. Semigroup a => a -> a -> a
<> [u'] -> [UserServersError]
forall u. UserServersClass u => [u] -> [UserServersError]
chatRelayErrs [u']
curr
    otherUserErrs :: (User, [u]) -> [UserServersError]
otherUserErrs (User
user, [u]
uss) = SProtocolType 'PSMP -> Maybe User -> [u] -> [UserServersError]
forall u (p :: ProtocolType).
(UserServersClass u, ProtocolTypeI p, UserProtocol p) =>
SProtocolType p -> Maybe User -> [u] -> [UserServersError]
noServersErrs SProtocolType 'PSMP
SPSMP (User -> Maybe User
forall a. a -> Maybe a
Just User
user) [u]
uss [UserServersError] -> [UserServersError] -> [UserServersError]
forall a. Semigroup a => a -> a -> a
<> SProtocolType 'PXFTP -> Maybe User -> [u] -> [UserServersError]
forall u (p :: ProtocolType).
(UserServersClass u, ProtocolTypeI p, UserProtocol p) =>
SProtocolType p -> Maybe User -> [u] -> [UserServersError]
noServersErrs SProtocolType 'PXFTP
SPXFTP (User -> Maybe User
forall a. a -> Maybe a
Just User
user) [u]
uss
    noServersErrs :: (UserServersClass u, ProtocolTypeI p, UserProtocol p) => SProtocolType p -> Maybe User -> [u] -> [UserServersError]
    noServersErrs :: forall u (p :: ProtocolType).
(UserServersClass u, ProtocolTypeI p, UserProtocol p) =>
SProtocolType p -> Maybe User -> [u] -> [UserServersError]
noServersErrs SProtocolType p
p Maybe User
user [u]
uss
      | (u -> Bool) -> Bool
noServers u -> Bool
forall u. UserServersClass u => u -> Bool
opEnabled = [AProtocolType -> Maybe User -> UserServersError
USENoServers AProtocolType
p' Maybe User
user]
      | Bool
otherwise = [AProtocolType -> Maybe User -> UserServersError
USEStorageMissing AProtocolType
p' Maybe User
user | (u -> Bool) -> Bool
noServers ((ServerRoles -> Bool) -> u -> Bool
hasRole ServerRoles -> Bool
storage)] [UserServersError] -> [UserServersError] -> [UserServersError]
forall a. Semigroup a => a -> a -> a
<> [AProtocolType -> Maybe User -> UserServersError
USEProxyMissing AProtocolType
p' Maybe User
user | (u -> Bool) -> Bool
noServers ((ServerRoles -> Bool) -> u -> Bool
hasRole ServerRoles -> Bool
proxy)]
      where
        p' :: AProtocolType
p' = SProtocolType p -> AProtocolType
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p -> AProtocolType
AProtocolType SProtocolType p
p
        noServers :: (u -> Bool) -> Bool
noServers u -> Bool
cond = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (AUserServer p -> Bool) -> [AUserServer p] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any AUserServer p -> Bool
forall {p :: ProtocolType}. AUserServer p -> Bool
srvEnabled ([AUserServer p] -> Bool) -> [AUserServer p] -> Bool
forall a b. (a -> b) -> a -> b
$ SProtocolType p -> [u] -> [AUserServer p]
forall u (p :: ProtocolType).
(UserServersClass u, UserProtocol p) =>
SProtocolType p -> [u] -> [AUserServer p]
userServers SProtocolType p
p ([u] -> [AUserServer p]) -> [u] -> [AUserServer p]
forall a b. (a -> b) -> a -> b
$ (u -> Bool) -> [u] -> [u]
forall a. (a -> Bool) -> [a] -> [a]
filter u -> Bool
cond [u]
uss
        hasRole :: (ServerRoles -> Bool) -> u -> Bool
hasRole ServerRoles -> Bool
roleSel = Bool -> (ServerOperator -> Bool) -> Maybe ServerOperator -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\op :: ServerOperator
op@ServerOperator {Bool
$sel:enabled:ServerOperator :: forall (s :: DBStored). ServerOperator' s -> Bool
enabled :: Bool
enabled} -> Bool
enabled Bool -> Bool -> Bool
&& ServerRoles -> Bool
roleSel (SProtocolType p -> ServerOperator -> ServerRoles
forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> ServerOperator -> ServerRoles
operatorRoles SProtocolType p
p ServerOperator
op)) (Maybe ServerOperator -> Bool)
-> (u -> Maybe ServerOperator) -> u -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. u -> Maybe ServerOperator
forall u. UserServersClass u => u -> Maybe ServerOperator
operator'
        srvEnabled :: AUserServer p -> Bool
srvEnabled (AUS SDBStored s
_ UserServer {Bool
$sel:deleted:UserServer :: forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
deleted :: Bool
deleted, Bool
$sel:enabled:UserServer :: forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
enabled :: Bool
enabled}) = Bool
enabled Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
deleted
    serverErrs :: (UserServersClass u, ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [u] -> [UserServersError]
    serverErrs :: forall u (p :: ProtocolType).
(UserServersClass u, ProtocolTypeI p, UserProtocol p) =>
SProtocolType p -> [u] -> [UserServersError]
serverErrs SProtocolType p
p [u]
uss = (AUserServer p -> Maybe UserServersError)
-> [AUserServer p] -> [UserServersError]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe AUserServer p -> Maybe UserServersError
duplicateErr_ [AUserServer p]
srvs
      where
        p' :: AProtocolType
p' = SProtocolType p -> AProtocolType
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p -> AProtocolType
AProtocolType SProtocolType p
p
        srvs :: [AUserServer p]
srvs = (AUserServer p -> Bool) -> [AUserServer p] -> [AUserServer p]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(AUS SDBStored s
_ UserServer {Bool
$sel:deleted:UserServer :: forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
deleted :: Bool
deleted}) -> Bool -> Bool
not Bool
deleted) ([AUserServer p] -> [AUserServer p])
-> [AUserServer p] -> [AUserServer p]
forall a b. (a -> b) -> a -> b
$ SProtocolType p -> [u] -> [AUserServer p]
forall u (p :: ProtocolType).
(UserServersClass u, UserProtocol p) =>
SProtocolType p -> [u] -> [AUserServer p]
userServers SProtocolType p
p [u]
uss
        duplicateErr_ :: AUserServer p -> Maybe UserServersError
duplicateErr_ (AUS SDBStored s
_ srv :: UserServer' s p
srv@UserServer {ProtoServerWithAuth p
$sel:server:UserServer :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server}) =
          AProtocolType -> Text -> TransportHost -> UserServersError
USEDuplicateServer AProtocolType
p' (ByteString -> Text
safeDecodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ProtoServerWithAuth p -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ProtoServerWithAuth p
server)
            (TransportHost -> UserServersError)
-> Maybe TransportHost -> Maybe UserServersError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TransportHost -> Bool)
-> NonEmpty TransportHost -> Maybe TransportHost
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TransportHost -> Set TransportHost -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set TransportHost
duplicateHosts) (UserServer' s p -> NonEmpty TransportHost
forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> NonEmpty TransportHost
srvHost UserServer' s p
srv)
        duplicateHosts :: Set TransportHost
duplicateHosts = (Set TransportHost, Set TransportHost) -> Set TransportHost
forall a b. (a, b) -> b
snd ((Set TransportHost, Set TransportHost) -> Set TransportHost)
-> (Set TransportHost, Set TransportHost) -> Set TransportHost
forall a b. (a -> b) -> a -> b
$ ((Set TransportHost, Set TransportHost)
 -> TransportHost -> (Set TransportHost, Set TransportHost))
-> (Set TransportHost, Set TransportHost)
-> [TransportHost]
-> (Set TransportHost, Set TransportHost)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Set TransportHost, Set TransportHost)
-> TransportHost -> (Set TransportHost, Set TransportHost)
forall a. Ord a => (Set a, Set a) -> a -> (Set a, Set a)
addDuplicate (Set TransportHost
forall a. Set a
S.empty, Set TransportHost
forall a. Set a
S.empty) [TransportHost]
allHosts
        allHosts :: [TransportHost]
allHosts = (AUserServer p -> [TransportHost])
-> [AUserServer p] -> [TransportHost]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(AUS SDBStored s
_ UserServer' s p
srv) -> NonEmpty TransportHost -> [TransportHost]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty TransportHost -> [TransportHost])
-> NonEmpty TransportHost -> [TransportHost]
forall a b. (a -> b) -> a -> b
$ UserServer' s p -> NonEmpty TransportHost
forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> NonEmpty TransportHost
srvHost UserServer' s p
srv) [AUserServer p]
srvs
    userServers :: (UserServersClass u, UserProtocol p) => SProtocolType p -> [u] -> [AUserServer p]
    userServers :: forall u (p :: ProtocolType).
(UserServersClass u, UserProtocol p) =>
SProtocolType p -> [u] -> [AUserServer p]
userServers SProtocolType p
p = (AServer u p -> AUserServer p) -> [AServer u p] -> [AUserServer p]
forall a b. (a -> b) -> [a] -> [b]
map AServer u p -> AUserServer p
forall u (p :: ProtocolType).
UserServersClass u =>
AServer u p -> AUserServer p
forall (p :: ProtocolType). AServer u p -> AUserServer p
aUserServer' ([AServer u p] -> [AUserServer p])
-> ([u] -> [AServer u p]) -> [u] -> [AUserServer p]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (u -> [AServer u p]) -> [u] -> [AServer u p]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SProtocolType p -> u -> [AServer u p]
forall u (p :: ProtocolType).
(UserServersClass u, UserProtocol p) =>
SProtocolType p -> u -> [AServer u p]
forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> u -> [AServer u p]
servers' SProtocolType p
p)
    chatRelayErrs :: UserServersClass u => [u] -> [UserServersError]
    chatRelayErrs :: forall u. UserServersClass u => [u] -> [UserServersError]
chatRelayErrs [u]
uss = (AUserChatRelay -> [UserServersError])
-> [AUserChatRelay] -> [UserServersError]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AUserChatRelay -> [UserServersError]
duplicateErrs_ [AUserChatRelay]
cRelays
      where
        cRelays :: [AUserChatRelay]
cRelays = (AUserChatRelay -> Bool) -> [AUserChatRelay] -> [AUserChatRelay]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(AUCR SDBStored s
_ UserChatRelay {Bool
$sel:deleted:UserChatRelay :: forall (s :: DBStored). UserChatRelay' s -> Bool
deleted :: Bool
deleted}) -> Bool -> Bool
not Bool
deleted) ([AUserChatRelay] -> [AUserChatRelay])
-> [AUserChatRelay] -> [AUserChatRelay]
forall a b. (a -> b) -> a -> b
$ [u] -> [AUserChatRelay]
forall u. UserServersClass u => [u] -> [AUserChatRelay]
userChatRelays [u]
uss
        duplicateErrs_ :: AUserChatRelay -> [UserServersError]
duplicateErrs_ (AUCR SDBStored s
_ UserChatRelay {$sel:relayProfile:UserChatRelay :: forall (s :: DBStored). UserChatRelay' s -> RelayProfile
relayProfile = RelayProfile {Text
displayName :: Text
$sel:displayName:RelayProfile :: RelayProfile -> Text
displayName}, ShortLinkContact
$sel:address:UserChatRelay :: forall (s :: DBStored). UserChatRelay' s -> ShortLinkContact
address :: ShortLinkContact
address}) =
          [Text -> ShortLinkContact -> UserServersError
USEDuplicateChatRelayAddress Text
displayName ShortLinkContact
address | ShortLinkContact
address ShortLinkContact -> [ShortLinkContact] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ShortLinkContact]
duplicateAddresses]
        duplicateAddresses :: [ShortLinkContact]
duplicateAddresses = ([ShortLinkContact], [ShortLinkContact]) -> [ShortLinkContact]
forall a b. (a, b) -> b
snd (([ShortLinkContact], [ShortLinkContact]) -> [ShortLinkContact])
-> ([ShortLinkContact], [ShortLinkContact]) -> [ShortLinkContact]
forall a b. (a -> b) -> a -> b
$ (([ShortLinkContact], [ShortLinkContact])
 -> ShortLinkContact -> ([ShortLinkContact], [ShortLinkContact]))
-> ([ShortLinkContact], [ShortLinkContact])
-> [ShortLinkContact]
-> ([ShortLinkContact], [ShortLinkContact])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([ShortLinkContact], [ShortLinkContact])
-> ShortLinkContact -> ([ShortLinkContact], [ShortLinkContact])
addAddress ([], []) [ShortLinkContact]
allAddresses
        allAddresses :: [ShortLinkContact]
allAddresses = (AUserChatRelay -> ShortLinkContact)
-> [AUserChatRelay] -> [ShortLinkContact]
forall a b. (a -> b) -> [a] -> [b]
map (\(AUCR SDBStored s
_ UserChatRelay {ShortLinkContact
$sel:address:UserChatRelay :: forall (s :: DBStored). UserChatRelay' s -> ShortLinkContact
address :: ShortLinkContact
address}) -> ShortLinkContact
address) [AUserChatRelay]
cRelays
        addAddress :: ([ShortLinkContact], [ShortLinkContact]) -> ShortLinkContact -> ([ShortLinkContact], [ShortLinkContact])
        addAddress :: ([ShortLinkContact], [ShortLinkContact])
-> ShortLinkContact -> ([ShortLinkContact], [ShortLinkContact])
addAddress ([ShortLinkContact]
xs, [ShortLinkContact]
dups) ShortLinkContact
x
          | (ShortLinkContact -> Bool) -> [ShortLinkContact] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ShortLinkContact -> ShortLinkContact -> Bool
sameShortLinkContact ShortLinkContact
x) [ShortLinkContact]
xs = ([ShortLinkContact]
xs, ShortLinkContact
x ShortLinkContact -> [ShortLinkContact] -> [ShortLinkContact]
forall a. a -> [a] -> [a]
: [ShortLinkContact]
dups)
          | Bool
otherwise = (ShortLinkContact
x ShortLinkContact -> [ShortLinkContact] -> [ShortLinkContact]
forall a. a -> [a] -> [a]
: [ShortLinkContact]
xs, [ShortLinkContact]
dups)
    currUserWarns :: [UserServersWarning]
currUserWarns = Maybe User -> [u'] -> [UserServersWarning]
forall u.
UserServersClass u =>
Maybe User -> [u] -> [UserServersWarning]
noChatRelaysWarns Maybe User
forall a. Maybe a
Nothing [u']
curr
    otherUserWarns :: (User, [u]) -> [UserServersWarning]
otherUserWarns (User
user, [u]
uss) = Maybe User -> [u] -> [UserServersWarning]
forall u.
UserServersClass u =>
Maybe User -> [u] -> [UserServersWarning]
noChatRelaysWarns (User -> Maybe User
forall a. a -> Maybe a
Just User
user) [u]
uss
    noChatRelaysWarns :: UserServersClass u => Maybe User -> [u] -> [UserServersWarning]
    noChatRelaysWarns :: forall u.
UserServersClass u =>
Maybe User -> [u] -> [UserServersWarning]
noChatRelaysWarns Maybe User
user [u]
uss
      | (u -> Bool) -> Bool
noChatRelays u -> Bool
forall u. UserServersClass u => u -> Bool
opEnabled = [Maybe User -> UserServersWarning
USWNoChatRelays Maybe User
user]
      | Bool
otherwise = []
      where
        noChatRelays :: (u -> Bool) -> Bool
noChatRelays u -> Bool
cond = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (AUserChatRelay -> Bool) -> [AUserChatRelay] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any AUserChatRelay -> Bool
relayEnabled ([AUserChatRelay] -> Bool) -> [AUserChatRelay] -> Bool
forall a b. (a -> b) -> a -> b
$ [u] -> [AUserChatRelay]
forall u. UserServersClass u => [u] -> [AUserChatRelay]
userChatRelays ([u] -> [AUserChatRelay]) -> [u] -> [AUserChatRelay]
forall a b. (a -> b) -> a -> b
$ (u -> Bool) -> [u] -> [u]
forall a. (a -> Bool) -> [a] -> [a]
filter u -> Bool
cond [u]
uss
        relayEnabled :: AUserChatRelay -> Bool
relayEnabled (AUCR SDBStored s
_ UserChatRelay {Bool
$sel:deleted:UserChatRelay :: forall (s :: DBStored). UserChatRelay' s -> Bool
deleted :: Bool
deleted, Bool
$sel:enabled:UserChatRelay :: forall (s :: DBStored). UserChatRelay' s -> Bool
enabled :: Bool
enabled}) = Bool
enabled Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
deleted
    userChatRelays :: UserServersClass u => [u] -> [AUserChatRelay]
    userChatRelays :: forall u. UserServersClass u => [u] -> [AUserChatRelay]
userChatRelays = (AChatRelay u -> AUserChatRelay)
-> [AChatRelay u] -> [AUserChatRelay]
forall a b. (a -> b) -> [a] -> [b]
map AChatRelay u -> AUserChatRelay
forall u. UserServersClass u => AChatRelay u -> AUserChatRelay
aUserChatRelay' ([AChatRelay u] -> [AUserChatRelay])
-> ([u] -> [AChatRelay u]) -> [u] -> [AUserChatRelay]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (u -> [AChatRelay u]) -> [u] -> [AChatRelay u]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap u -> [AChatRelay u]
forall u. UserServersClass u => u -> [AChatRelay u]
chatRelays'
    opEnabled :: UserServersClass u => u -> Bool
    opEnabled :: forall u. UserServersClass u => u -> Bool
opEnabled = Bool -> (ServerOperator -> Bool) -> Maybe ServerOperator -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\ServerOperator {Bool
$sel:enabled:ServerOperator :: forall (s :: DBStored). ServerOperator' s -> Bool
enabled :: Bool
enabled} -> Bool
enabled) (Maybe ServerOperator -> Bool)
-> (u -> Maybe ServerOperator) -> u -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. u -> Maybe ServerOperator
forall u. UserServersClass u => u -> Maybe ServerOperator
operator'
    addDuplicate :: Ord a => (Set a, Set a) -> a -> (Set a, Set a)
    addDuplicate :: forall a. Ord a => (Set a, Set a) -> a -> (Set a, Set a)
addDuplicate (Set a
xs, Set a
dups) a
x
      | a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
xs = (Set a
xs, a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
x Set a
dups)
      | Bool
otherwise = (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
x Set a
xs, Set a
dups)

$(JQ.deriveJSON defaultJSON ''UsageConditions)

$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CA") ''ConditionsAcceptance)

instance ToJSON (ServerOperator' s) where
  toEncoding :: ServerOperator' s -> Encoding
toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerOperator')
  toJSON :: ServerOperator' s -> Value
toJSON = $(JQ.mkToJSON defaultJSON ''ServerOperator')

instance DBStoredI s => FromJSON (ServerOperator' s) where
  parseJSON :: Value -> Parser (ServerOperator' s)
parseJSON = $(JQ.mkParseJSON defaultJSON ''ServerOperator')

$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction)

$(JQ.deriveJSON defaultJSON ''ServerOperatorConditions)

instance ProtocolTypeI p => ToJSON (UserServer' s p) where
  toEncoding :: UserServer' s p -> Encoding
toEncoding = $(JQ.mkToEncoding defaultJSON ''UserServer')
  toJSON :: UserServer' s p -> Value
toJSON = $(JQ.mkToJSON defaultJSON ''UserServer')

instance (DBStoredI s, ProtocolTypeI p) => FromJSON (UserServer' s p) where
  parseJSON :: Value -> Parser (UserServer' s p)
parseJSON = $(JQ.mkParseJSON defaultJSON ''UserServer')

instance ProtocolTypeI p => FromJSON (AUserServer p) where
  parseJSON :: Value -> Parser (AUserServer p)
parseJSON Value
v = (SDBStored 'DBStored -> UserServer' 'DBStored p -> AUserServer p
forall (p :: ProtocolType) (s :: DBStored).
SDBStored s -> UserServer' s p -> AUserServer p
AUS SDBStored 'DBStored
SDBStored (UserServer' 'DBStored p -> AUserServer p)
-> Parser (UserServer' 'DBStored p) -> Parser (AUserServer p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (UserServer' 'DBStored p)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v) Parser (AUserServer p)
-> Parser (AUserServer p) -> Parser (AUserServer p)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (SDBStored 'DBNew -> UserServer' 'DBNew p -> AUserServer p
forall (p :: ProtocolType) (s :: DBStored).
SDBStored s -> UserServer' s p -> AUserServer p
AUS SDBStored 'DBNew
SDBNew (UserServer' 'DBNew p -> AUserServer p)
-> Parser (UserServer' 'DBNew p) -> Parser (AUserServer p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (UserServer' 'DBNew p)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)

instance ToJSON (UserChatRelay' s) where
  toEncoding :: UserChatRelay' s -> Encoding
toEncoding = $(JQ.mkToEncoding defaultJSON ''UserChatRelay')
  toJSON :: UserChatRelay' s -> Value
toJSON = $(JQ.mkToJSON defaultJSON ''UserChatRelay')

instance DBStoredI s => FromJSON (UserChatRelay' s) where
  parseJSON :: Value -> Parser (UserChatRelay' s)
parseJSON = $(JQ.mkParseJSON defaultJSON ''UserChatRelay')

instance FromJSON AUserChatRelay where
  parseJSON :: Value -> Parser AUserChatRelay
parseJSON Value
v = (SDBStored 'DBStored -> UserChatRelay -> AUserChatRelay
forall (s :: DBStored).
SDBStored s -> UserChatRelay' s -> AUserChatRelay
AUCR SDBStored 'DBStored
SDBStored (UserChatRelay -> AUserChatRelay)
-> Parser UserChatRelay -> Parser AUserChatRelay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser UserChatRelay
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v) Parser AUserChatRelay
-> Parser AUserChatRelay -> Parser AUserChatRelay
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (SDBStored 'DBNew -> NewUserChatRelay -> AUserChatRelay
forall (s :: DBStored).
SDBStored s -> UserChatRelay' s -> AUserChatRelay
AUCR SDBStored 'DBNew
SDBNew (NewUserChatRelay -> AUserChatRelay)
-> Parser NewUserChatRelay -> Parser AUserChatRelay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser NewUserChatRelay
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)

$(JQ.deriveJSON defaultJSON ''UserOperatorServers)

instance FromJSON UpdatedUserOperatorServers where
  parseJSON :: Value -> Parser UpdatedUserOperatorServers
parseJSON = $(JQ.mkParseJSON defaultJSON ''UpdatedUserOperatorServers)

$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "USE") ''UserServersError)

$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "USW") ''UserServersWarning)

$(JQ.deriveJSON defaultJSON ''GroupRelay)