core, ui: per-server roles for self-hosted servers (#7254)

* core, ui: plan per-server roles for self-hosted servers * core: add per-server roles field to UserServer * core: add nullable role columns to protocol_servers * core: persist per-server roles * core: validate server coverage using per-server roles * test: cover per-server roles resolution and coverage * multiplatform: per-server role toggles for self-hosted servers * ios: per-server role toggles for self-hosted servers * core: per-server role overrides with per-role defaults * test: cover three-state per-server role resolution * fix: derive Eq for ServerRolesOverride * multiplatform: three-state role dropdowns on saved servers * ios: three-state role pickers on saved servers * test: per-server roles independent across two servers * test: enable names role in name-resolution tests * style: trim comments in per-server roles code * chore: rename server_roles migration to 20260716 (last) * core: per-server roles override operator roles, inherit when unset * multiplatform: per-server role default inherits from operator * ios: per-server role default inherits from operator * refactor(servers): tidy per-server roles per review - dedup no-operator default into ServerRoles.noOperatorDefault (Kotlin/Swift) - iOS: move roles-section control flow to the call site via a named gate, and parse the server address once instead of up to three times - Kotlin: collapse redundant derivedState; revert defaultOn->default rename for cross-platform parity - drop unused Hashable conformance on Swift ServerRoles - add agentServerCfgs test for names inheritance from an operator - remove no-op enableNamesRole calls from dormant DirectoryTests - fix ChatClient import ordering * chore(migration): date server_roles migration 20260720 * only show roles when server is enabled, move section above QR code --------- Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
2026-07-28 12:09:41 +00:00 · 2026-07-20 16:35:13 +01:00
parent 966c9f7947
commit 2ea5940e81
19 changed files with 834 additions and 54 deletions
@@ -49,7 +49,7 @@ import Simplex.Chat.Operators.Conditions
 import Simplex.Chat.Protocol (RelayCapabilities (..), 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.Env.SQLite (ServerCfg (..), ServerRoles (..))
 import Simplex.Messaging.Agent.Protocol (sameShortLinkContact)
 import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
 import Simplex.Messaging.Agent.Store.Entity
@@ -176,6 +176,22 @@ operatorRoles p op = case p of
  SPSMP -> smpRoles op
  SPXFTP -> xftpRoles op

+data ServerRolesOverride = ServerRolesOverride
+  { storage :: Maybe Bool,
+    proxy :: Maybe Bool,
+    names :: Maybe Bool
+  }
+  deriving (Eq, Show)
+
+emptyServerRolesOverride :: ServerRolesOverride
+emptyServerRolesOverride = ServerRolesOverride {storage = Nothing, proxy = Nothing, names = Nothing}
+
+-- each role: override if set, else the operator's role (if any), else default (receive on, proxy on, names off)
+resolveServerRoles :: UserProtocol p => SProtocolType p -> Maybe ServerOperator -> ServerRolesOverride -> ServerRoles
+resolveServerRoles p op ServerRolesOverride {storage, proxy, names} =
+  ServerRoles {storage = fromMaybe s storage, proxy = fromMaybe pr proxy, names = fromMaybe n names}
+  where ServerRoles {storage = s, proxy = pr, names = n} = maybe (ServerRoles True True False) (operatorRoles p) op
+
 conditionsAccepted :: ServerOperator -> Bool
 conditionsAccepted ServerOperator {conditionsAcceptance} = case conditionsAcceptance of
  CAAccepted {} -> True
@@ -245,6 +261,7 @@ data UserServer' s (p :: ProtocolType) = UserServer
    preset :: Bool,
    tested :: Maybe Bool,
    enabled :: Bool,
+    roles :: ServerRolesOverride,
    deleted :: Bool
  }
  deriving (Show)
@@ -330,7 +347,7 @@ newUserServer = newUserServer_ False True

 newUserServer_ :: Bool -> Bool -> ProtoServerWithAuth p -> NewUserServer p
 newUserServer_ preset enabled server =
-  UserServer {serverId = DBNewEntity, server, preset, tested = Nothing, enabled, deleted = False}
+  UserServer {serverId = DBNewEntity, server, preset, tested = Nothing, enabled, roles = emptyServerRolesOverride, deleted = False}

 presetChatRelay :: Bool -> RelayProfile -> [Text] -> ShortLinkContact -> NewUserChatRelay
 presetChatRelay = newChatRelay_ True
@@ -439,13 +456,13 @@ agentServerCfgs :: UserProtocol p => SProtocolType p -> [(Text, ServerOperator)]
 agentServerCfgs p opDomains = mapMaybe agentServer
  where
    agentServer :: UserServer' s p -> Maybe (ServerCfg p)
-    agentServer srv@UserServer {server, enabled} =
+    agentServer srv@UserServer {server, enabled, roles = srvRoles} =
      case find (\(d, _) -> any (matchingHost d) (srvHost srv)) opDomains of
        Just (_, op@ServerOperator {operatorId = DBEntityId opId, enabled = opEnabled})
-          | opEnabled -> Just ServerCfg {server, enabled, operator = Just opId, roles = operatorRoles p op}
+          | opEnabled -> Just ServerCfg {server, enabled, operator = Just opId, roles = resolveServerRoles p (Just op) srvRoles}
          | otherwise -> Nothing
        Nothing ->
-          Just ServerCfg {server, enabled, operator = Nothing, roles = allRoles}
+          Just ServerCfg {server, enabled, operator = Nothing, roles = resolveServerRoles p Nothing srvRoles}

 matchingHost :: Text -> TransportHost -> Bool
 matchingHost d = \case
@@ -524,11 +541,10 @@ validateUserServers curr others = (currUserErrs <> concatMap otherUserErrs other
    noServersErrs :: (UserServersClass u, ProtocolTypeI p, UserProtocol p) => SProtocolType p -> Maybe User -> [u] -> [UserServersError]
    noServersErrs p user uss
      | noServers opEnabled = [USENoServers p' user]
-      | otherwise = [USEStorageMissing p' user | noServers (hasRole storage)] <> [USEProxyMissing p' user | noServers (hasRole proxy)]
+      | otherwise = [USEStorageMissing p' user | not (any (hasRole p (\ServerRoles {storage} -> storage)) uss)] <> [USEProxyMissing p' user | not (any (hasRole p (\ServerRoles {proxy} -> proxy)) uss)]
      where
        p' = AProtocolType p
        noServers cond = not $ any srvEnabled $ userServers p $ filter cond uss
-        hasRole roleSel = maybe True (\op@ServerOperator {enabled} -> enabled && roleSel (operatorRoles p op)) . operator'
        srvEnabled (AUS _ UserServer {deleted, enabled}) = enabled && not deleted
    serverErrs :: (UserServersClass u, ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [u] -> [UserServersError]
    serverErrs p uss = mapMaybe duplicateErr_ srvs
@@ -542,6 +558,10 @@ validateUserServers curr others = (currUserErrs <> concatMap otherUserErrs other
        allHosts = concatMap (\(AUS _ srv) -> L.toList $ srvHost srv) srvs
    userServers :: (UserServersClass u, UserProtocol p) => SProtocolType p -> [u] -> [AUserServer p]
    userServers p = map aUserServer' . concatMap (servers' p)
+    -- a group covers a role if its operator is enabled and some enabled server resolves it on
+    hasRole :: (UserServersClass u, UserProtocol p) => SProtocolType p -> (ServerRoles -> Bool) -> u -> Bool
+    hasRole p roleSel u =
+      opEnabled u && any (\(AUS _ UserServer {enabled, deleted, roles}) -> enabled && not deleted && roleSel (resolveServerRoles p (operator' u) roles)) (map aUserServer' (servers' p u))
    chatRelayErrs :: UserServersClass u => [u] -> [UserServersError]
    chatRelayErrs uss = concatMap duplicateErrs_ cRelays
      where
@@ -562,11 +582,7 @@ validateUserServers curr others = (currUserErrs <> concatMap otherUserErrs other
        noChatRelays cond = not $ any relayEnabled $ userChatRelays $ filter cond uss
        relayEnabled (AUCR _ UserChatRelay {deleted, enabled}) = enabled && not deleted
    noNamesServersWarns :: UserServersClass u => Maybe User -> [u] -> [UserServersWarning]
-    noNamesServersWarns user uss = [USWNoNamesServers user | noNamesServers]
-      where
-        noNamesServers = not $ any srvEnabled $ userServers SPSMP $ filter namesEnabled uss
-        srvEnabled (AUS _ UserServer {deleted, enabled}) = enabled && not deleted
-        namesEnabled = maybe True (\op@ServerOperator {enabled} -> enabled && names (operatorRoles SPSMP op)) . operator'
+    noNamesServersWarns user uss = [USWNoNamesServers user | not (any (hasRole SPSMP (\ServerRoles {names} -> names)) uss)]
    userChatRelays :: UserServersClass u => [u] -> [AUserChatRelay]
    userChatRelays = map aUserChatRelay' . concatMap chatRelays'
    opEnabled :: UserServersClass u => u -> Bool
@@ -591,6 +607,8 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction)

 $(JQ.deriveJSON defaultJSON ''ServerOperatorConditions)

+$(JQ.deriveJSON defaultJSON ''ServerRolesOverride)
+
 instance ProtocolTypeI p => ToJSON (UserServer' s p) where
  toEncoding = $(JQ.mkToEncoding defaultJSON ''UserServer')
  toJSON = $(JQ.mkToJSON defaultJSON ''UserServer')
@@ -44,6 +44,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260707_file_digest
 import Simplex.Chat.Store.Postgres.Migrations.M20260714_member_security_code
 import Simplex.Chat.Store.Postgres.Migrations.M20260715_profile_description
 import Simplex.Chat.Store.Postgres.Migrations.M20260716_signed_history
+import Simplex.Chat.Store.Postgres.Migrations.M20260720_server_roles
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))

 schemaMigrations :: [(String, Text, Maybe Text)]
@@ -87,7 +88,8 @@ schemaMigrations =
    ("20260707_file_digest", m20260707_file_digest, Just down_m20260707_file_digest),
    ("20260714_member_security_code", m20260714_member_security_code, Just down_m20260714_member_security_code),
    ("20260715_profile_description", m20260715_profile_description, Just down_m20260715_profile_description),
-    ("20260716_signed_history", m20260716_signed_history, Just down_m20260716_signed_history)
+    ("20260716_signed_history", m20260716_signed_history, Just down_m20260716_signed_history),
+    ("20260720_server_roles", m20260720_server_roles, Just down_m20260720_server_roles)
  ]

 -- | The list of migrations in ascending order by date
@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Store.Postgres.Migrations.M20260720_server_roles where
+
+import Data.Text (Text)
+import Text.RawString.QQ (r)
+
+m20260720_server_roles :: Text
+m20260720_server_roles =
+  [r|
+ALTER TABLE protocol_servers ADD COLUMN role_storage SMALLINT;
+ALTER TABLE protocol_servers ADD COLUMN role_proxy SMALLINT;
+ALTER TABLE protocol_servers ADD COLUMN role_names SMALLINT;
+|]
+
+down_m20260720_server_roles :: Text
+down_m20260720_server_roles =
+  [r|
+ALTER TABLE protocol_servers DROP COLUMN role_storage;
+ALTER TABLE protocol_servers DROP COLUMN role_proxy;
+ALTER TABLE protocol_servers DROP COLUMN role_names;
+|]
@@ -1187,7 +1187,10 @@ CREATE TABLE test_chat_schema.protocol_servers (
    user_id bigint NOT NULL,
    created_at timestamp with time zone DEFAULT now() NOT NULL,
    updated_at timestamp with time zone DEFAULT now() NOT NULL,
-    protocol text DEFAULT 'smp'::text NOT NULL
+    protocol text DEFAULT 'smp'::text NOT NULL,
+    role_storage smallint,
+    role_proxy smallint,
+    role_names smallint
 );


@@ -642,41 +642,45 @@ getProtocolServers db p User {userId} =
    <$> DB.query
      db
      [sql|
-        SELECT smp_server_id, host, port, key_hash, basic_auth, preset, tested, enabled
+        SELECT smp_server_id, host, port, key_hash, basic_auth, preset, tested, enabled,
+               role_storage, role_proxy, role_names
        FROM protocol_servers
        WHERE user_id = ? AND protocol = ?
      |]
      (userId, decodeLatin1 $ strEncode p)
  where
-    toUserServer :: (DBEntityId, NonEmpty TransportHost, String, C.KeyHash, Maybe Text, BoolInt, Maybe BoolInt, BoolInt) -> UserServer p
-    toUserServer (serverId, host, port, keyHash, auth_, BI preset, tested, BI enabled) =
+    toUserServer :: ((DBEntityId, NonEmpty TransportHost, String, C.KeyHash, Maybe Text, BoolInt, Maybe BoolInt, BoolInt) :. (Maybe BoolInt, Maybe BoolInt, Maybe BoolInt)) -> UserServer p
+    toUserServer ((serverId, host, port, keyHash, auth_, BI preset, tested, BI enabled) :. (rStorage, rProxy, rNames)) =
      let server = ProtoServerWithAuth (ProtocolServer p host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
-       in UserServer {serverId, server, preset, tested = unBI <$> tested, enabled, deleted = False}
+          roles = ServerRolesOverride (unBI <$> rStorage) (unBI <$> rProxy) (unBI <$> rNames)
+       in UserServer {serverId, server, preset, tested = unBI <$> tested, enabled, roles, deleted = False}

 insertProtocolServer :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> UTCTime -> NewUserServer p -> IO (UserServer p)
-insertProtocolServer db p User {userId} ts srv@UserServer {server, preset, tested, enabled} = do
+insertProtocolServer db p User {userId} ts srv@UserServer {server, preset, tested, enabled, roles} = do
  DB.execute
    db
    [sql|
      INSERT INTO protocol_servers
-        (protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
-      VALUES (?,?,?,?,?,?,?,?,?,?,?)
+        (protocol, host, port, key_hash, basic_auth, preset, tested, enabled,
+         role_storage, role_proxy, role_names, user_id, created_at, updated_at)
+      VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
    |]
-    (serverColumns p server :. (BI preset, BI <$> tested, BI enabled, userId, ts, ts))
+    (serverColumns p server :. (BI preset, BI <$> tested, BI enabled) :. roleColumns roles :. (userId, ts, ts))
  sId <- insertedRowId db
  pure (srv :: NewUserServer p) {serverId = DBEntityId sId}

 updateProtocolServer :: ProtocolTypeI p => DB.Connection -> SProtocolType p -> UTCTime -> UserServer p -> IO ()
-updateProtocolServer db p ts UserServer {serverId, server, preset, tested, enabled} =
+updateProtocolServer db p ts UserServer {serverId, server, preset, tested, enabled, roles} =
  DB.execute
    db
    [sql|
      UPDATE protocol_servers
      SET protocol = ?, host = ?, port = ?, key_hash = ?, basic_auth = ?,
-          preset = ?, tested = ?, enabled = ?, updated_at = ?
+          preset = ?, tested = ?, enabled = ?,
+          role_storage = ?, role_proxy = ?, role_names = ?, updated_at = ?
      WHERE smp_server_id = ?
    |]
-    (serverColumns p server :. (BI preset, BI <$> tested, BI enabled, ts, serverId))
+    (serverColumns p server :. (BI preset, BI <$> tested, BI enabled) :. roleColumns roles :. (ts, serverId))

 serverColumns :: ProtocolTypeI p => SProtocolType p -> ProtoServerWithAuth p -> (Text, NonEmpty TransportHost, String, C.KeyHash, Maybe Text)
 serverColumns p (ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_) =
@@ -684,6 +688,9 @@ serverColumns p (ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_)
      auth = safeDecodeUtf8 . unBasicAuth <$> auth_
   in (protocol, host, port, keyHash, auth)

+roleColumns :: ServerRolesOverride -> (Maybe BoolInt, Maybe BoolInt, Maybe BoolInt)
+roleColumns ServerRolesOverride {storage, proxy, names} = (BI <$> storage, BI <$> proxy, BI <$> names)
+
 getChatRelays :: DB.Connection -> User -> IO [UserChatRelay]
 getChatRelays db User {userId} =
  map toChatRelay
@@ -772,7 +779,10 @@ updateServerOperator db currentTs ServerOperator {operatorId, enabled, smpRoles,
      SET enabled = ?, smp_role_storage = ?, smp_role_proxy = ?, smp_role_names = ?, xftp_role_storage = ?, xftp_role_proxy = ?, updated_at = ?
      WHERE server_operator_id = ?
    |]
-    (BI enabled, BI (storage smpRoles), BI (proxy smpRoles), BI (names smpRoles), BI (storage xftpRoles), BI (proxy xftpRoles), currentTs, operatorId)
+    (BI enabled, BI smpStorage, BI smpProxy, BI smpNames, BI xftpStorage, BI xftpProxy, currentTs, operatorId)
+  where
+    ServerRoles {storage = smpStorage, proxy = smpProxy, names = smpNames} = smpRoles
+    ServerRoles {storage = xftpStorage, proxy = xftpProxy} = xftpRoles

 getUpdateServerOperators :: DB.Connection -> NonEmpty PresetOperator -> Bool -> IO [(Maybe PresetOperator, Maybe ServerOperator)]
 getUpdateServerOperators db presetOps newUser = do
@@ -810,7 +820,10 @@ getUpdateServerOperators db presetOps newUser = do
          SET trade_name = ?, legal_name = ?, server_domains = ?, enabled = ?, smp_role_storage = ?, smp_role_proxy = ?, smp_role_names = ?, xftp_role_storage = ?, xftp_role_proxy = ?
          WHERE server_operator_id = ?
        |]
-        (tradeName, legalName, T.intercalate "," serverDomains, BI enabled, BI (storage smpRoles), BI (proxy smpRoles), BI (names smpRoles), BI (storage xftpRoles), BI (proxy xftpRoles), operatorId)
+        (tradeName, legalName, T.intercalate "," serverDomains, BI enabled, BI smpStorage, BI smpProxy, BI smpNames, BI xftpStorage, BI xftpProxy, operatorId)
+      where
+        ServerRoles {storage = smpStorage, proxy = smpProxy, names = smpNames} = smpRoles
+        ServerRoles {storage = xftpStorage, proxy = xftpProxy} = xftpRoles
    insertOperator :: NewServerOperator -> IO ServerOperator
    insertOperator op@ServerOperator {operatorTag, tradeName, legalName, serverDomains, enabled, smpRoles, xftpRoles} = do
      DB.execute
@@ -820,9 +833,12 @@ getUpdateServerOperators db presetOps newUser = do
            (server_operator_tag, trade_name, legal_name, server_domains, enabled, smp_role_storage, smp_role_proxy, smp_role_names, xftp_role_storage, xftp_role_proxy)
          VALUES (?,?,?,?,?,?,?,?,?,?)
        |]
-        (operatorTag, tradeName, legalName, T.intercalate "," serverDomains, BI enabled, BI (storage smpRoles), BI (proxy smpRoles), BI (names smpRoles), BI (storage xftpRoles), BI (proxy xftpRoles))
+        (operatorTag, tradeName, legalName, T.intercalate "," serverDomains, BI enabled, BI smpStorage, BI smpProxy, BI smpNames, BI xftpStorage, BI xftpProxy)
      opId <- insertedRowId db
      pure op {operatorId = DBEntityId opId}
+      where
+        ServerRoles {storage = smpStorage, proxy = smpProxy, names = smpNames} = smpRoles
+        ServerRoles {storage = xftpStorage, proxy = xftpProxy} = xftpRoles
    autoAcceptConditions op UsageConditions {conditionsCommit} now =
      acceptConditions_ db op conditionsCommit now True
        $> op {conditionsAcceptance = CAAccepted (Just now) True}
@@ -167,6 +167,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260707_file_digest
 import Simplex.Chat.Store.SQLite.Migrations.M20260714_member_security_code
 import Simplex.Chat.Store.SQLite.Migrations.M20260715_profile_description
 import Simplex.Chat.Store.SQLite.Migrations.M20260716_signed_history
+import Simplex.Chat.Store.SQLite.Migrations.M20260720_server_roles
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))

 schemaMigrations :: [(String, Query, Maybe Query)]
@@ -333,7 +334,8 @@ schemaMigrations =
    ("20260707_file_digest", m20260707_file_digest, Just down_m20260707_file_digest),
    ("20260714_member_security_code", m20260714_member_security_code, Just down_m20260714_member_security_code),
    ("20260715_profile_description", m20260715_profile_description, Just down_m20260715_profile_description),
-    ("20260716_signed_history", m20260716_signed_history, Just down_m20260716_signed_history)
+    ("20260716_signed_history", m20260716_signed_history, Just down_m20260716_signed_history),
+    ("20260720_server_roles", m20260720_server_roles, Just down_m20260720_server_roles)
  ]

 -- | The list of migrations in ascending order by date
@@ -0,0 +1,22 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Store.SQLite.Migrations.M20260720_server_roles where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20260720_server_roles :: Query
+m20260720_server_roles =
+  [sql|
+ALTER TABLE protocol_servers ADD COLUMN role_storage INTEGER;
+ALTER TABLE protocol_servers ADD COLUMN role_proxy INTEGER;
+ALTER TABLE protocol_servers ADD COLUMN role_names INTEGER;
+|]
+
+down_m20260720_server_roles :: Query
+down_m20260720_server_roles =
+  [sql|
+ALTER TABLE protocol_servers DROP COLUMN role_storage;
+ALTER TABLE protocol_servers DROP COLUMN role_proxy;
+ALTER TABLE protocol_servers DROP COLUMN role_names;
+|]
@@ -565,6 +565,9 @@ CREATE TABLE IF NOT EXISTS "protocol_servers"(
  created_at TEXT NOT NULL DEFAULT(datetime('now')),
  updated_at TEXT NOT NULL DEFAULT(datetime('now')),
  protocol TEXT NOT NULL DEFAULT 'smp',
+  role_storage INTEGER,
+  role_proxy INTEGER,
+  role_names INTEGER,
  UNIQUE(user_id, host, port)
 ) STRICT;
 CREATE TABLE xftp_file_descriptions(
@@ -1659,12 +1659,12 @@ viewUserServers UserOperatorServers {operator, smpServers, xftpServers, chatRela
            testedInfo = maybe [] (\t -> ["test: " <> if t then "passed" else "failed"]) tested
        viewRoles op@ServerOperator {enabled}
          | not enabled = "disabled"
-          | storage rs && proxy rs = "enabled"
-          | storage rs = "enabled storage"
-          | proxy rs = "enabled proxy"
+          | rStorage && rProxy = "enabled"
+          | rStorage = "enabled storage"
+          | rProxy = "enabled proxy"
          | otherwise = "disabled (servers known)"
          where
-            rs = operatorRoles p op
+            ServerRoles {storage = rStorage, proxy = rProxy} = operatorRoles p op
    viewChatRelays :: [UserChatRelay] -> [StyledString]
    viewChatRelays [] = []
    viewChatRelays cRelays
@@ -1752,12 +1752,12 @@ viewOpEnabled ServerOperator {enabled, smpRoles, xftpRoles}
  | both smpRoles && both xftpRoles = "enabled"
  | otherwise = "SMP " <> viewRoles smpRoles <> ", XFTP " <> viewRoles xftpRoles
  where
-    no rs = not $ storage rs || proxy rs
-    both rs = storage rs && proxy rs
-    viewRoles rs
+    no ServerRoles {storage, proxy} = not $ storage || proxy
+    both ServerRoles {storage, proxy} = storage && proxy
+    viewRoles rs@ServerRoles {storage, proxy}
      | both rs = "enabled"
-      | storage rs = "enabled storage"
-      | proxy rs = "enabled proxy"
+      | storage = "enabled storage"
+      | proxy = "enabled proxy"
      | otherwise = "disabled (servers known)"

 viewConditionsAction :: UsageConditionsAction -> [StyledString]