{-# 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.Types (User)
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
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
"7471fd2af5838dc0467aebc570b5ea75e5df3209"

previousConditionsCommit :: Text
previousConditionsCommit :: Text
previousConditionsCommit = Text
"a5061f3147165a05979d6ace33960aced2d6ac03"

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
createdAt :: UsageConditions -> UTCTime
createdAt :: UTCTime
createdAt, Maybe UTCTime
notifiedAt :: 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
enabled :: 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
conditionsAcceptance :: 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]
  }
  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]
  }
  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
  operator' :: u -> Maybe ServerOperator
  aUserServer' :: AServer u p -> AUserServer p
  servers' :: UserProtocol p => SProtocolType p -> u -> [AServer u p]

instance UserServersClass UserOperatorServers where
  type AServer UserOperatorServers = UserServer' 'DBStored
  operator' :: UserOperatorServers -> Maybe ServerOperator
operator' UserOperatorServers {Maybe ServerOperator
operator :: 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]
smpServers :: UserOperatorServers -> [UserServer 'PSMP]
smpServers :: [UserServer 'PSMP]
smpServers, [UserServer 'PXFTP]
xftpServers :: 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

instance UserServersClass UpdatedUserOperatorServers where
  type AServer UpdatedUserOperatorServers = AUserServer
  operator' :: UpdatedUserOperatorServers -> Maybe ServerOperator
operator' UpdatedUserOperatorServers {Maybe ServerOperator
operator :: 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]
smpServers :: UpdatedUserOperatorServers -> [AUserServer 'PSMP]
smpServers :: [AUserServer 'PSMP]
smpServers, [AUserServer 'PXFTP]
xftpServers :: 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

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 {server :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> ProtoServerWithAuth p
server = ProtoServerWithAuth ProtocolServer p
srv Maybe BasicAuth
_} = ProtocolServer p
srv
{-# INLINE presetServerAddress #-}

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
  }
  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
operator :: 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]
smp :: PresetOperator -> [NewUserServer 'PSMP]
smp :: [NewUserServer 'PSMP]
smp, [NewUserServer 'PXFTP]
xftp :: 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
useSMP :: PresetOperator -> Int
useSMP :: Int
useSMP, Int
useXFTP :: 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)

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

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

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 {serverId :: DBEntityId' 'DBNew
serverId = DBEntityId' 'DBNew
DBNewEntity, ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server, Bool
preset :: Bool
preset :: Bool
preset, tested :: Maybe Bool
tested = Maybe Bool
forall a. Maybe a
Nothing, Bool
enabled :: Bool
enabled :: Bool
enabled, deleted :: 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 {conditionsId :: Int64
conditionsId = Int64
cId, conditionsCommit :: Text
conditionsCommit = Text
commit, notifiedAt :: Maybe UTCTime
notifiedAt = Maybe UTCTime
forall a. Maybe a
Nothing, UTCTime
createdAt :: 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]
smp :: PresetOperator -> [NewUserServer 'PSMP]
smp :: [NewUserServer 'PSMP]
smp, [NewUserServer 'PXFTP]
xftp :: PresetOperator -> [NewUserServer 'PXFTP]
xftp :: [NewUserServer 'PXFTP]
xftp} =
      Maybe ServerOperator
-> [AUserServer 'PSMP]
-> [AUserServer 'PXFTP]
-> 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)

-- 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
operatorId :: forall (s :: DBStored). ServerOperator' s -> DBEntityId' s
operatorId :: DBEntityId' 'DBStored
operatorId, ConditionsAcceptance
conditionsAcceptance :: forall (s :: DBStored). ServerOperator' s -> ConditionsAcceptance
conditionsAcceptance :: ConditionsAcceptance
conditionsAcceptance, Bool
enabled :: forall (s :: DBStored). ServerOperator' s -> Bool
enabled :: Bool
enabled, ServerRoles
smpRoles :: forall (s :: DBStored). ServerOperator' s -> ServerRoles
smpRoles :: ServerRoles
smpRoles, ServerRoles
xftpRoles :: forall (s :: DBStored). ServerOperator' s -> ServerRoles
xftpRoles :: ServerRoles
xftpRoles} ->
            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
operator :: UserOperatorServers -> Maybe ServerOperator
operator :: Maybe ServerOperator
operator, [UserServer 'PSMP]
smpServers :: UserOperatorServers -> [UserServer 'PSMP]
smpServers :: [UserServer 'PSMP]
smpServers, [UserServer 'PXFTP]
xftpServers :: UserOperatorServers -> [UserServer 'PXFTP]
xftpServers :: [UserServer 'PXFTP]
xftpServers}) =
  UpdatedUserOperatorServers {Maybe ServerOperator
operator :: Maybe ServerOperator
operator :: Maybe ServerOperator
operator, smpServers :: [AUserServer 'PSMP]
smpServers = [AUserServer 'PSMP]
smp', xftpServers :: [AUserServer 'PXFTP]
xftpServers = [AUserServer 'PXFTP]
xftp'}
  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)
    ([AUserServer 'PSMP]
smp', [AUserServer 'PXFTP]
xftp') = 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)
      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)
        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
server :: 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 UserServer p
srv = Bool -> Bool
not (UserServer p -> Bool
forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
preset UserServer p
srv) 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
server :: 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)

srvHost :: UserServer' s p -> NonEmpty TransportHost
srvHost :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> NonEmpty TransportHost
srvHost UserServer {server :: 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

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
server :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server, Bool
enabled :: 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 {operatorId :: forall (s :: DBStored). ServerOperator' s -> DBEntityId' s
operatorId = DBEntityId Int64
opId, enabled :: 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
server :: ProtoServerWithAuth p
server, Bool
enabled :: Bool
enabled :: Bool
enabled, operator :: Maybe Int64
operator = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
opId, roles :: 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
server :: ProtoServerWithAuth p
server, Bool
enabled :: Bool
enabled :: Bool
enabled, operator :: Maybe Int64
operator = Maybe Int64
forall a. Maybe a
Nothing, roles :: 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]) -> IO [UserOperatorServers]
groupByOperator :: ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP])
-> IO [UserOperatorServers]
groupByOperator ([Maybe ServerOperator]
ops, [UserServer 'PSMP]
smpSrvs, [UserServer 'PXFTP]
xftpSrvs) = (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])
-> IO [Identity UserOperatorServers]
forall (f :: * -> *).
(Box f, Traversable f) =>
([f (Maybe ServerOperator)], [UserServer 'PSMP],
 [UserServer 'PXFTP])
-> 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)

-- 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]) -> IO [(Maybe PresetOperator, UserOperatorServers)]
groupByOperator' :: ([(Maybe PresetOperator, Maybe ServerOperator)],
 [UserServer 'PSMP], [UserServer 'PXFTP])
-> IO [(Maybe PresetOperator, UserOperatorServers)]
groupByOperator' = ([(Maybe PresetOperator, Maybe ServerOperator)],
 [UserServer 'PSMP], [UserServer 'PXFTP])
-> IO [(Maybe PresetOperator, UserOperatorServers)]
forall (f :: * -> *).
(Box f, Traversable f) =>
([f (Maybe ServerOperator)], [UserServer 'PSMP],
 [UserServer 'PXFTP])
-> IO [f UserOperatorServers]
groupByOperator_
{-# INLINE groupByOperator' #-}

groupByOperator_ :: forall f. (Box f, Traversable f) => ([f (Maybe ServerOperator)], [UserServer 'PSMP], [UserServer 'PXFTP]) -> IO [f UserOperatorServers]
groupByOperator_ :: forall (f :: * -> *).
(Box f, Traversable f) =>
([f (Maybe ServerOperator)], [UserServer 'PSMP],
 [UserServer 'PXFTP])
-> IO [f UserOperatorServers]
groupByOperator_ ([f (Maybe ServerOperator)]
ops, [UserServer 'PSMP]
smpSrvs, [UserServer 'PXFTP]
xftpSrvs) = 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)
  [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] -> 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]
smpServers :: 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]
xftpServers :: UserOperatorServers -> [UserServer 'PXFTP]
xftpServers :: [UserServer 'PXFTP]
xftpServers} = (UserOperatorServers
s :: UserOperatorServers) {xftpServers = srv : xftpServers}

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}
  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)

validateUserServers :: UserServersClass u' => [u'] -> [(User, [UserOperatorServers])] -> [UserServersError]
validateUserServers :: forall u'.
UserServersClass u' =>
[u'] -> [(User, [UserOperatorServers])] -> [UserServersError]
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
  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
    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
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
        opEnabled :: u -> Bool
opEnabled = Bool -> (ServerOperator -> Bool) -> Maybe ServerOperator -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\ServerOperator {Bool
enabled :: 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'
        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
enabled :: 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
deleted :: forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
deleted :: Bool
deleted, Bool
enabled :: 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
deleted :: 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
server :: 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)
addHost (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
        addHost :: (Set a, Set a) -> a -> (Set a, Set a)
addHost (Set a
hs, Set a
dups) a
h
          | a
h a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
hs = (Set a
hs, a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
h Set a
dups)
          | Bool
otherwise = (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
h Set a
hs, Set a
dups)
    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)

$(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)

$(JQ.deriveJSON defaultJSON ''UserOperatorServers)

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

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