From a5d07bead5906c73c0cec85c6abd2fb1399e44b8 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 3 Jun 2020 12:44:10 +0200 Subject: [PATCH 01/11] Consolidate team features (#1122) Co-authored-by: Matthias Fischmann --- libs/brig-types/src/Brig/Types/Instances.hs | 13 -- .../src/Brig/Types/Team/LegalHold.hs | 5 - libs/galley-types/galley-types.cabal | 3 +- libs/galley-types/src/Galley/Types/Teams.hs | 78 ++++---- .../src/Galley/Types/Teams/SSO.hs | 27 --- .../Galley/Types/Teams/SearchVisibility.hs | 2 - .../test/unit/Test/Galley/Types.hs | 8 + libs/wire-api/src/Wire/API/Swagger.hs | 4 +- libs/wire-api/src/Wire/API/Team/Feature.hs | 140 ++++++--------- .../src/Wire/API/Team/SearchVisibility.hs | 53 ------ .../test/unit/Test/Wire/API/Roundtrip.hs | 7 +- services/brig/brig.cabal | 3 +- services/brig/package.yaml | 1 + services/brig/src/Brig/IO/Intra.hs | 8 +- services/brig/src/Brig/User/Auth.hs | 8 +- services/brig/test/integration/API/Search.hs | 3 +- .../brig/test/integration/API/Team/Util.hs | 10 +- .../brig/test/integration/API/User/Auth.hs | 10 +- .../brig/test/integration/API/User/Handles.hs | 3 +- services/galley/src/Galley/API/Internal.hs | 29 +-- services/galley/src/Galley/API/LegalHold.hs | 9 +- services/galley/src/Galley/API/Public.hs | 35 +--- services/galley/src/Galley/API/Swagger.hs | 43 ++--- services/galley/src/Galley/API/Teams.hs | 167 +++++++----------- services/galley/src/Galley/Data/Instances.hs | 28 +-- services/galley/src/Galley/Data/LegalHold.hs | 12 +- services/galley/src/Galley/Data/Queries.hs | 15 +- services/galley/src/Galley/Data/SSO.hs | 15 +- .../src/Galley/Data/SearchVisibility.hs | 5 +- services/galley/test/integration/API/Teams.hs | 131 +++++++------- .../test/integration/API/Teams/LegalHold.hs | 41 ++--- services/spar/package.yaml | 2 + services/spar/spar.cabal | 7 +- services/spar/src/Spar/Intra/Galley.hs | 6 +- services/spar/test-integration/Util/Core.hs | 8 +- .../migrate-sso-feature-flag.cabal | 3 +- .../db/migrate-sso-feature-flag/package.yaml | 1 + tools/db/migrate-sso-feature-flag/src/Work.hs | 10 +- tools/stern/src/Stern/Intra.hs | 33 ++-- 39 files changed, 382 insertions(+), 604 deletions(-) delete mode 100644 libs/galley-types/src/Galley/Types/Teams/SSO.hs diff --git a/libs/brig-types/src/Brig/Types/Instances.hs b/libs/brig-types/src/Brig/Types/Instances.hs index 1da6d7f5cdc..f4422aac93a 100644 --- a/libs/brig-types/src/Brig/Types/Instances.hs +++ b/libs/brig-types/src/Brig/Types/Instances.hs @@ -25,23 +25,10 @@ where import Brig.Types.Client.Prekey import Brig.Types.Provider import Brig.Types.Provider.Tag -import Brig.Types.Team.LegalHold import Cassandra.CQL import Data.ByteString.Conversion import Imports -instance Cql LegalHoldStatus where - ctype = Tagged IntColumn - - fromCql (CqlInt n) = case n of - 0 -> pure $ LegalHoldDisabled - 1 -> pure $ LegalHoldEnabled - _ -> fail "fromCql: Invalid LegalHoldStatus" - fromCql _ = fail "fromCql: LegalHoldStatus: CqlInt expected" - - toCql LegalHoldDisabled = CqlInt 0 - toCql LegalHoldEnabled = CqlInt 1 - instance Cql PrekeyId where ctype = Tagged IntColumn toCql = CqlInt . fromIntegral . keyId diff --git a/libs/brig-types/src/Brig/Types/Team/LegalHold.hs b/libs/brig-types/src/Brig/Types/Team/LegalHold.hs index 28bd238d8d9..4adedab0866 100644 --- a/libs/brig-types/src/Brig/Types/Team/LegalHold.hs +++ b/libs/brig-types/src/Brig/Types/Team/LegalHold.hs @@ -24,10 +24,6 @@ module Brig.Types.Team.LegalHold viewLegalHoldService, LegalHoldClientRequest (..), - -- * LegalHoldTeamConfig (re-export) - LegalHoldTeamConfig (..), - LegalHoldStatus (..), - -- * Other (re-export) NewLegalHoldService (..), ViewLegalHoldService (..), @@ -52,7 +48,6 @@ import Data.Id import Data.Json.Util import Data.Misc import Imports -import Wire.API.Team.Feature (LegalHoldStatus (..), LegalHoldTeamConfig (..)) import Wire.API.Team.LegalHold import Wire.API.Team.LegalHold.External (LegalHoldServiceConfirm (..), LegalHoldServiceRemove (..), NewLegalHoldClient (..), RequestNewLegalHoldClient (..)) diff --git a/libs/galley-types/galley-types.cabal b/libs/galley-types/galley-types.cabal index 50be69cd8f3..2216ed181bc 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: a4fd5aaea6208236dd337f30411f58ec7fd5fefa2bf239419f28f9a732f4b288 +-- hash: ce281a8d6976cf975316d418abdfbf336e1faecbf8c30d8fc7743d8fa216ddbf name: galley-types version: 0.81.0 @@ -26,7 +26,6 @@ library Galley.Types.Teams Galley.Types.Teams.Intra Galley.Types.Teams.SearchVisibility - Galley.Types.Teams.SSO other-modules: Paths_galley_types hs-source-dirs: diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index fac23624145..ba075a2fc15 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -37,9 +37,10 @@ module Galley.Types.Teams isTeamOwner, canSeePermsOf, rolePermissions, + roleHiddenPermissions, permissionsRole, HiddenPerm (..), - IsPerm, + IsPerm (..), -- * re-exports Team, @@ -80,8 +81,6 @@ module Galley.Types.Teams fullPermissions, noPermissions, serviceWhitelistPermissions, - hasPermission, - mayGrantPermission, self, copy, Perm (..), @@ -127,7 +126,7 @@ module Galley.Types.Teams where import Control.Exception (ErrorCall (ErrorCall)) -import Control.Lens ((^.), makeLenses, to, view) +import Control.Lens ((^.), makeLenses, view) import Control.Monad.Catch import Data.Aeson import Data.Id (UserId) @@ -141,6 +140,7 @@ import Wire.API.Event.Team import Wire.API.Team (NewTeam (..), Team (..), TeamBinding (..)) import Wire.API.Team import Wire.API.Team.Conversation +import Wire.API.Team.Feature import Wire.API.Team.Member import Wire.API.Team.Permission import Wire.API.Team.Role @@ -297,15 +297,13 @@ makeLenses ''FeatureFlags -- | See Note [hidden team roles] data HiddenPerm = ChangeLegalHoldTeamSettings - | ViewLegalHoldTeamSettings | ChangeLegalHoldUserSettings | ViewLegalHoldUserSettings - | ViewSSOTeamSettings -- (change is only allowed via customer support backoffice) - | ViewTeamSearchVisibilityAvailable + | ViewTeamFeature TeamFeatureName | ChangeTeamSearchVisibility | ViewTeamSearchVisibility | ViewSameTeamEmails - deriving (Eq, Ord, Show, Enum, Bounded) + deriving (Eq, Ord, Show) -- | See Note [hidden team roles] data HiddenPermissions = HiddenPermissions @@ -316,51 +314,49 @@ data HiddenPermissions = HiddenPermissions makeLenses ''HiddenPermissions --- | Compute 'Role' from 'Permissions', and 'HiddenPermissions' from the 'Role'. If --- 'Permissions' matches no 'Role', return no hidden permission bits. -hiddenPermissionsFromPermissions :: Permissions -> HiddenPermissions -hiddenPermissionsFromPermissions = - maybe (HiddenPermissions mempty mempty) roleHiddenPermissions . permissionsRole +roleHiddenPermissions :: Role -> HiddenPermissions +roleHiddenPermissions role = HiddenPermissions p p where - roleHiddenPermissions :: Role -> HiddenPermissions - roleHiddenPermissions role = HiddenPermissions p p - where - p = roleHiddenPerms role - roleHiddenPerms :: Role -> Set HiddenPerm - roleHiddenPerms RoleOwner = roleHiddenPerms RoleAdmin - roleHiddenPerms RoleAdmin = - (roleHiddenPerms RoleMember <>) $ - Set.fromList - [ ChangeLegalHoldTeamSettings, - ChangeLegalHoldUserSettings, - ChangeTeamSearchVisibility - ] - roleHiddenPerms RoleMember = - (roleHiddenPerms RoleExternalPartner <>) $ - Set.fromList [ViewSameTeamEmails] - roleHiddenPerms RoleExternalPartner = - Set.fromList - [ ViewLegalHoldTeamSettings, - ViewLegalHoldUserSettings, - ViewSSOTeamSettings, - ViewTeamSearchVisibilityAvailable, - ViewTeamSearchVisibility - ] + p = roleHiddenPerms role + roleHiddenPerms :: Role -> Set HiddenPerm + roleHiddenPerms RoleOwner = roleHiddenPerms RoleAdmin + roleHiddenPerms RoleAdmin = + (roleHiddenPerms RoleMember <>) $ + Set.fromList + [ ChangeLegalHoldTeamSettings, + ChangeLegalHoldUserSettings, + ChangeTeamSearchVisibility + ] + roleHiddenPerms RoleMember = + (roleHiddenPerms RoleExternalPartner <>) $ + Set.fromList [ViewSameTeamEmails] + roleHiddenPerms RoleExternalPartner = + Set.fromList + [ ViewTeamFeature TeamFeatureLegalHold, + ViewTeamFeature TeamFeatureSSO, + ViewTeamFeature TeamFeatureSearchVisibility, + ViewLegalHoldUserSettings, + ViewTeamSearchVisibility + ] -- | See Note [hidden team roles] class IsPerm perm where + roleHasPerm :: Role -> perm -> Bool + roleGrantsPerm :: Role -> perm -> Bool hasPermission :: TeamMember -> perm -> Bool + hasPermission tm perm = maybe False (`roleHasPerm` perm) . permissionsRole $ tm ^. permissions mayGrantPermission :: TeamMember -> perm -> Bool + mayGrantPermission tm perm = maybe False (`roleGrantsPerm` perm) . permissionsRole $ tm ^. permissions instance IsPerm Perm where + roleHasPerm r p = p `Set.member` (rolePermissions r ^. self) + roleGrantsPerm r p = p `Set.member` (rolePermissions r ^. copy) hasPermission tm p = p `Set.member` (tm ^. permissions . self) mayGrantPermission tm p = p `Set.member` (tm ^. permissions . copy) instance IsPerm HiddenPerm where - hasPermission tm p = - p `Set.member` (tm ^. permissions . to hiddenPermissionsFromPermissions . hself) - mayGrantPermission tm p = - p `Set.member` (tm ^. permissions . to hiddenPermissionsFromPermissions . hcopy) + roleHasPerm r p = p `Set.member` (roleHiddenPermissions r ^. hself) + roleGrantsPerm r p = p `Set.member` (roleHiddenPermissions r ^. hcopy) notTeamMember :: [UserId] -> [TeamMember] -> [UserId] notTeamMember uids tmms = diff --git a/libs/galley-types/src/Galley/Types/Teams/SSO.hs b/libs/galley-types/src/Galley/Types/Teams/SSO.hs deleted file mode 100644 index 095e81c82e5..00000000000 --- a/libs/galley-types/src/Galley/Types/Teams/SSO.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.Types.Teams.SSO - ( SSOStatus (..), - SSOTeamConfig (..), - ) -where - -import Wire.API.Team.Feature diff --git a/libs/galley-types/src/Galley/Types/Teams/SearchVisibility.hs b/libs/galley-types/src/Galley/Types/Teams/SearchVisibility.hs index 986524a429d..12e2f63a32f 100644 --- a/libs/galley-types/src/Galley/Types/Teams/SearchVisibility.hs +++ b/libs/galley-types/src/Galley/Types/Teams/SearchVisibility.hs @@ -19,8 +19,6 @@ module Galley.Types.Teams.SearchVisibility ( -- re-exports TeamSearchVisibility (..), TeamSearchVisibilityView (..), - TeamSearchVisibilityAvailable (..), - TeamSearchVisibilityAvailableView (..), ) where diff --git a/libs/galley-types/test/unit/Test/Galley/Types.hs b/libs/galley-types/test/unit/Test/Galley/Types.hs index d97b874a77d..8a233bf7875 100644 --- a/libs/galley-types/test/unit/Test/Galley/Types.hs +++ b/libs/galley-types/test/unit/Test/Galley/Types.hs @@ -46,6 +46,14 @@ tests = $ \(r1, r2) -> do assertBool "owner.self" ((rolePermissions r2 ^. self) `isSubsetOf` (rolePermissions r1 ^. self)) assertBool "owner.copy" ((rolePermissions r2 ^. copy) `isSubsetOf` (rolePermissions r1 ^. copy)), + testCase "permissions for viewing feature flags" $ + -- We currently (at the time of writing this test) grant view permissions for all + -- 'TeamFeatureName's to all roles. If we add more features in the future and forget to + -- add them, this test will fail, and remind us that there we should consider adding. + -- If you want to handle view permissions for future features differntly, adopt the test + -- accordingly. Just maintain the property that adding a new feature name will break + -- this test, and force future develpers to consider what permissions they want to set. + assertBool "all covered" (all (roleHasPerm RoleExternalPartner) (ViewTeamFeature <$> [minBound ..])), testRoundTrip @FeatureFlags ] diff --git a/libs/wire-api/src/Wire/API/Swagger.hs b/libs/wire-api/src/Wire/API/Swagger.hs index 5c6ed53b047..2cd234fe869 100644 --- a/libs/wire-api/src/Wire/API/Swagger.hs +++ b/libs/wire-api/src/Wire/API/Swagger.hs @@ -105,8 +105,7 @@ models = Team.modelTeamDelete, Team.Conversation.modelTeamConversation, Team.Conversation.modelTeamConversationList, - Team.Feature.modelLegalHoldTeamConfig, - Team.Feature.modelSsoTeamConfig, + Team.Feature.modelTeamFeatureStatus, Team.Invitation.modelTeamInvitation, Team.Invitation.modelTeamInvitationList, Team.Invitation.modelTeamInvitationRequest, @@ -116,7 +115,6 @@ models = Team.Member.modelNewTeamMember, Team.Permission.modelPermissions, Team.SearchVisibility.modelTeamSearchVisibility, - Team.SearchVisibility.modelTeamSearchVisibilityAvailable, User.modelUserIdList, User.modelSelf, User.modelUser, diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index f3eef589ad9..f781a42a170 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -1,7 +1,5 @@ {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -- This file is part of the Wire Server implementation. -- @@ -21,56 +19,62 @@ -- with this program. If not, see . module Wire.API.Team.Feature - ( -- * LegalHoldTeamConfig - LegalHoldTeamConfig (..), - LegalHoldStatus (..), - - -- * SSOTeamConfig - SSOTeamConfig (..), - SSOStatus (..), - - -- * Swagger - modelLegalHoldTeamConfig, - modelSsoTeamConfig, + ( TeamFeatureName (..), + typeFeatureName, + TeamFeatureStatus (..), + modelTeamFeatureStatus, typeFeatureStatus, ) where import Data.Aeson -import Data.Json.Util ((#)) +import qualified Data.Attoparsec.ByteString as Parser +import Data.ByteString.Conversion (FromByteString (..), ToByteString (..)) import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Imports import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) --------------------------------------------------------------------------------- --- LegalHoldTeamConfig +data TeamFeatureName + = TeamFeatureLegalHold + | TeamFeatureSSO + | TeamFeatureSearchVisibility + deriving stock (Eq, Show, Ord, Generic, Enum, Bounded) + deriving (Arbitrary) via (GenericUniform TeamFeatureName) + +instance FromByteString TeamFeatureName where + parser = Parser.takeByteString >>= \b -> + case T.decodeUtf8' b of + Left e -> fail $ "Invalid TeamFeatureName: " <> show e + Right "legalhold" -> pure TeamFeatureLegalHold + Right "sso" -> pure TeamFeatureSSO + Right "search-visibility" -> pure TeamFeatureSearchVisibility + Right t -> fail $ "Invalid TeamFeatureName: " <> T.unpack t + +instance ToByteString TeamFeatureName where + builder TeamFeatureLegalHold = "legalhold" + builder TeamFeatureSSO = "sso" + builder TeamFeatureSearchVisibility = "search-visibility" + +typeFeatureName :: Doc.DataType +typeFeatureName = + Doc.string $ + Doc.enum + [ "legalhold", + "sso", + "search-visibility" + ] -data LegalHoldTeamConfig = LegalHoldTeamConfig - { legalHoldTeamConfigStatus :: LegalHoldStatus - } +data TeamFeatureStatus = TeamFeatureEnabled | TeamFeatureDisabled deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform LegalHoldTeamConfig) + deriving (Arbitrary) via (GenericUniform TeamFeatureStatus) -modelLegalHoldTeamConfig :: Doc.Model -modelLegalHoldTeamConfig = Doc.defineModel "LegalHoldTeamConfig" $ do - Doc.description "Configuration of LegalHold feature for team" +modelTeamFeatureStatus :: Doc.Model +modelTeamFeatureStatus = Doc.defineModel "TeamFeatureStatus" $ do + Doc.description "Configuration of a feature for a team" Doc.property "status" typeFeatureStatus $ Doc.description "status" -instance ToJSON LegalHoldTeamConfig where - toJSON s = - object $ - "status" .= legalHoldTeamConfigStatus s - # [] - -instance FromJSON LegalHoldTeamConfig where - parseJSON = withObject "LegalHoldTeamConfig" $ \o -> - LegalHoldTeamConfig <$> o .: "status" - -data LegalHoldStatus = LegalHoldDisabled | LegalHoldEnabled - deriving stock (Eq, Show, Ord, Enum, Bounded, Generic) - deriving (Arbitrary) via (GenericUniform LegalHoldStatus) - typeFeatureStatus :: Doc.DataType typeFeatureStatus = Doc.string $ @@ -79,52 +83,18 @@ typeFeatureStatus = "disabled" ] -instance ToJSON LegalHoldStatus where - toJSON LegalHoldEnabled = "enabled" - toJSON LegalHoldDisabled = "disabled" - -instance FromJSON LegalHoldStatus where - parseJSON = withText "LegalHoldStatus" $ \case - "enabled" -> pure LegalHoldEnabled - "disabled" -> pure LegalHoldDisabled - x -> fail $ "unexpected status type: " <> T.unpack x - --------------------------------------------------------------------------------- --- SSOTeamConfig - -data SSOTeamConfig = SSOTeamConfig - { ssoTeamConfigStatus :: SSOStatus - } - deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform SSOTeamConfig) - -modelSsoTeamConfig :: Doc.Model -modelSsoTeamConfig = Doc.defineModel "SSOTeamConfig" $ do - Doc.description "Configuration of SSO feature for team" - Doc.property "status" typeFeatureStatus $ Doc.description "status" - -instance ToJSON SSOTeamConfig where - toJSON s = - object $ - "status" .= ssoTeamConfigStatus s - # [] - -instance FromJSON SSOTeamConfig where - parseJSON = withObject "SSOTeamConfig" $ \o -> - SSOTeamConfig <$> o .: "status" - -data SSOStatus = SSODisabled | SSOEnabled - deriving stock (Eq, Show, Ord, Enum, Bounded, Generic) - deriving (Arbitrary) via (GenericUniform SSOStatus) - --- also uses the modelFeatureStatus Swagger doc - -instance ToJSON SSOStatus where - toJSON SSOEnabled = "enabled" - toJSON SSODisabled = "disabled" +instance ToJSON TeamFeatureStatus where + toJSON status = + object + [ "status" .= case status of + TeamFeatureEnabled -> String "enabled" + TeamFeatureDisabled -> String "disabled" + ] -instance FromJSON SSOStatus where - parseJSON = withText "SSOStatus" $ \case - "enabled" -> pure SSOEnabled - "disabled" -> pure SSODisabled - x -> fail $ "unexpected status type: " <> T.unpack x +instance FromJSON TeamFeatureStatus where + parseJSON = withObject "TeamFeatureStatus" $ \o -> + o .: "status" + >>= \case + "enabled" -> pure TeamFeatureEnabled + "disabled" -> pure TeamFeatureDisabled + x -> fail $ "unexpected status type: " <> T.unpack x diff --git a/libs/wire-api/src/Wire/API/Team/SearchVisibility.hs b/libs/wire-api/src/Wire/API/Team/SearchVisibility.hs index b73f3c1f3b4..9b5195a69d9 100644 --- a/libs/wire-api/src/Wire/API/Team/SearchVisibility.hs +++ b/libs/wire-api/src/Wire/API/Team/SearchVisibility.hs @@ -21,14 +21,10 @@ module Wire.API.Team.SearchVisibility ( TeamSearchVisibility (..), TeamSearchVisibilityView (..), - TeamSearchVisibilityAvailable (..), - TeamSearchVisibilityAvailableView (..), -- * Swagger modelTeamSearchVisibility, - modelTeamSearchVisibilityAvailable, typeSearchVisibility, - typeSearchVisibilityAvailable, ) where @@ -103,52 +99,3 @@ instance ToJSON TeamSearchVisibilityView where instance FromJSON TeamSearchVisibilityView where parseJSON = withObject "TeamSearchVisibilityView" $ \o -> TeamSearchVisibilityView <$> o .: "search_visibility" - --------------------------------------------------------------------------------- --- TeamSearchVisibilityAvailable - --- | Is the feature enabled for a given team? See also 'FeatureTeamSearchVisibility', --- 'TeamSearchVisibility'. -data TeamSearchVisibilityAvailable - = TeamSearchVisibilityDisabled - | TeamSearchVisibilityEnabled - deriving stock (Eq, Show, Ord, Enum, Bounded, Generic) - deriving (Arbitrary) via (GenericUniform TeamSearchVisibilityAvailable) - -typeSearchVisibilityAvailable :: Doc.DataType -typeSearchVisibilityAvailable = - Doc.string $ - Doc.enum - [ "enabled", - "disabled" - ] - -instance ToJSON TeamSearchVisibilityAvailable where - toJSON TeamSearchVisibilityEnabled = "enabled" - toJSON TeamSearchVisibilityDisabled = "disabled" - -instance FromJSON TeamSearchVisibilityAvailable where - parseJSON = withText "TeamSearchVisibilityEnabled" $ \case - "enabled" -> pure TeamSearchVisibilityEnabled - "disabled" -> pure TeamSearchVisibilityDisabled - x -> fail $ "unexpected status type: " <> T.unpack x - --------------------------------------------------------------------------------- --- TeamSearchVisibilityAvailableView - -newtype TeamSearchVisibilityAvailableView = TeamSearchVisibilityAvailableView TeamSearchVisibilityAvailable - deriving stock (Eq, Show, Generic) - deriving newtype (Arbitrary) - -modelTeamSearchVisibilityAvailable :: Doc.Model -modelTeamSearchVisibilityAvailable = Doc.defineModel "TeamSearchVisibilityAvailable" $ do - Doc.description "Configuration of Search Visibility feature for team" - Doc.property "status" typeSearchVisibilityAvailable $ do - Doc.description "status" - -instance ToJSON TeamSearchVisibilityAvailableView where - toJSON (TeamSearchVisibilityAvailableView s) = object ["status" .= s] - -instance FromJSON TeamSearchVisibilityAvailableView where - parseJSON = withObject "TeamSearchVisibilityAvailableView" $ \o -> - TeamSearchVisibilityAvailableView <$> o .: "status" diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip.hs index bd8bcf9a758..83eb21106a5 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip.hs @@ -193,10 +193,7 @@ tests = testRoundTrip @Team.TeamDeleteData, testRoundTrip @Team.Conversation.TeamConversation, testRoundTrip @Team.Conversation.TeamConversationList, - testRoundTrip @Team.Feature.LegalHoldStatus, - testRoundTrip @Team.Feature.LegalHoldTeamConfig, - testRoundTrip @Team.Feature.SSOStatus, - testRoundTrip @Team.Feature.SSOTeamConfig, + testRoundTrip @Team.Feature.TeamFeatureStatus, testRoundTrip @Team.Invitation.InvitationRequest, testRoundTrip @Team.Invitation.Invitation, testRoundTrip @Team.Invitation.InvitationList, @@ -221,8 +218,6 @@ tests = testRoundTrip @Team.Role.Role, testRoundTrip @Team.SearchVisibility.TeamSearchVisibility, testRoundTrip @Team.SearchVisibility.TeamSearchVisibilityView, - testRoundTrip @Team.SearchVisibility.TeamSearchVisibilityAvailable, - testRoundTrip @Team.SearchVisibility.TeamSearchVisibilityAvailableView, testRoundTrip @User.NewUser, testRoundTrip @User.NewUserPublic, testRoundTrip @User.UserIdList, diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 19817ca5b00..977971dd397 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -4,7 +4,7 @@ cabal-version: 2.0 -- -- see: https://github.com/sol/hpack -- --- hash: 8ed6b489b5ddf4652861e87ad845b5c06d587795b38d02c0550d0b761582da45 +-- hash: dcf98702ec8a0c8e7492ffa8ae6df1a373cba27a6c4d46cf36f575ced7818c44 name: brig version: 1.35.0 @@ -380,6 +380,7 @@ executable brig-integration , wai-utilities >=0.9 , warp , warp-tls >=3.2 + , wire-api , yaml , zauth default-language: Haskell2010 diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 9d33689193a..6a873572b14 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -252,6 +252,7 @@ executables: - wai-utilities >=0.9 - warp - warp-tls >=3.2 + - wire-api - yaml - zauth brig-index: diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 3747466c6e1..17caa5111a9 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -68,7 +68,6 @@ import qualified Brig.IO.Journal as Journal import Brig.RPC import Brig.Types import Brig.Types.Intra -import Brig.Types.Team.LegalHold (LegalHoldTeamConfig) import Brig.User.Event import qualified Brig.User.Event.Log as Log import qualified Brig.User.Search.Index as Search @@ -98,6 +97,7 @@ import Network.HTTP.Types.Method import Network.HTTP.Types.Status import qualified Network.Wai.Utilities.Error as Wai import System.Logger.Class as Log hiding ((.=), name) +import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus) ----------------------------------------------------------------------------- -- Event Handlers @@ -819,14 +819,14 @@ getTeamName tid = do paths ["i", "teams", toByteString' tid, "name"] . expect2xx --- | Calls 'Galley.API.getLegalholdStatusInternalH'. -getTeamLegalHoldStatus :: TeamId -> AppIO LegalHoldTeamConfig +-- | Calls 'Galley.API.getTeamFeatureStatusH'. +getTeamLegalHoldStatus :: TeamId -> AppIO TeamFeatureStatus getTeamLegalHoldStatus tid = do debug $ remote "galley" . msg (val "Get legalhold settings") galleyRequest GET req >>= decodeBody "galley" where req = - paths ["i", "teams", toByteString' tid, "features", "legalhold"] + paths ["i", "teams", toByteString' tid, "features", toByteString' TeamFeatureLegalHold] . expect2xx -- | Calls 'Galley.API.getSearchVisibilityInternalH'. diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index f3e5544b4d1..845839e7db5 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -49,7 +49,6 @@ import qualified Brig.Options as Opt import Brig.Phone import Brig.Types.Common import Brig.Types.Intra -import Brig.Types.Team.LegalHold (LegalHoldStatus (..), LegalHoldTeamConfig (..)) import Brig.Types.User import Brig.Types.User.Auth hiding (user) import Brig.User.Auth.Cookie @@ -68,6 +67,7 @@ import Imports import Network.Wai.Utilities.Error ((!>>)) import System.Logger (field, msg, val, (~~)) import qualified System.Logger.Class as Log +import Wire.API.Team.Feature (TeamFeatureStatus (..)) data Access u = Access { accessToken :: !AccessToken, @@ -296,7 +296,7 @@ legalHoldLogin (LegalHoldLogin uid plainTextPassword label) typ = do assertLegalHoldEnabled :: TeamId -> ExceptT LegalHoldLoginError AppIO () assertLegalHoldEnabled tid = do - LegalHoldTeamConfig stat <- lift $ Intra.getTeamLegalHoldStatus tid + stat <- lift $ Intra.getTeamLegalHoldStatus tid case stat of - LegalHoldDisabled -> throwE LegalHoldLoginLegalHoldNotEnabled - LegalHoldEnabled -> pure () + TeamFeatureDisabled -> throwE LegalHoldLoginLegalHoldNotEnabled + TeamFeatureEnabled -> pure () diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index 7547b894e39..76edf206bfb 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -46,6 +46,7 @@ import Test.Tasty import Test.Tasty.HUnit import UnliftIO (Concurrently (..), runConcurrently) import Util +import Wire.API.Team.Feature (TeamFeatureStatus (..)) tests :: Opt.Opts -> Manager -> Galley -> Brig -> IO TestTree tests opts mgr galley brig = do @@ -89,7 +90,7 @@ tests opts mgr galley brig = do prepareUsersForSearchVisibilityNoNameOutsideTeamTests :: Http ((TeamId, User, User), (TeamId, User, User), User) prepareUsersForSearchVisibilityNoNameOutsideTeamTests = do (tidA, ownerA, (memberA : _)) <- createPopulatedBindingTeamWithNamesAndHandles brig 1 - setTeamTeamSearchVisibilityAvailable galley tidA Team.TeamSearchVisibilityEnabled + setTeamTeamSearchVisibilityAvailable galley tidA TeamFeatureEnabled setTeamSearchVisibility galley tidA Team.SearchVisibilityNoNameOutsideTeam (tidB, ownerB, (memberB : _)) <- createPopulatedBindingTeamWithNamesAndHandles brig 1 regularUser <- randomUserWithHandle brig diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index f9b601b4c0b..c616a6b868c 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -23,7 +23,6 @@ import Bilge.Assert import Brig.Types.Activation import Brig.Types.Connection import Brig.Types.Team.Invitation -import Brig.Types.Team.LegalHold (LegalHoldStatus, LegalHoldTeamConfig (..)) import Brig.Types.User import Control.Lens ((^?)) import Control.Monad.Catch (MonadCatch, MonadThrow) @@ -46,6 +45,7 @@ import qualified Network.Wai.Utilities.Error as Error import Test.Tasty.HUnit import Util import Web.Cookie (parseSetCookie, setCookieName) +import Wire.API.Team.Feature (TeamFeatureStatus (..)) -- | FUTUREWORK: Remove 'createPopulatedBindingTeam', 'createPopulatedBindingTeamWithNames', -- and rename 'createPopulatedBindingTeamWithNamesAndHandles' to 'createPopulatedBindingTeam'. @@ -282,13 +282,13 @@ getTeams u galley = newTeam :: Team.BindingNewTeam newTeam = Team.BindingNewTeam $ Team.newNewTeam (unsafeRange "teamName") (unsafeRange "defaultIcon") -putLegalHoldEnabled :: HasCallStack => TeamId -> LegalHoldStatus -> Galley -> Http () +putLegalHoldEnabled :: HasCallStack => TeamId -> TeamFeatureStatus -> Galley -> Http () putLegalHoldEnabled tid enabled g = do void . put $ g . paths ["i", "teams", toByteString' tid, "features", "legalhold"] . contentJson - . lbytes (encode (LegalHoldTeamConfig enabled)) + . lbytes (encode enabled) . expect2xx accept :: Email -> InvitationCode -> RequestBody @@ -439,13 +439,13 @@ stdInvitationRequest :: Email -> Name -> Maybe Locale -> Maybe Team.Role -> Invi stdInvitationRequest e inviterName loc role = InvitationRequest e inviterName loc role Nothing Nothing -setTeamTeamSearchVisibilityAvailable :: HasCallStack => Galley -> TeamId -> Team.TeamSearchVisibilityAvailable -> Http () +setTeamTeamSearchVisibilityAvailable :: HasCallStack => Galley -> TeamId -> TeamFeatureStatus -> Http () setTeamTeamSearchVisibilityAvailable galley tid status = put ( galley . paths ["i/teams", toByteString' tid, "features/search-visibility"] . contentJson - . body (RequestBodyLBS . encode $ Team.TeamSearchVisibilityAvailableView status) + . body (RequestBodyLBS . encode $ status) ) !!! do const 204 === statusCode diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index 588b83abe9d..26704200e73 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -30,7 +30,6 @@ import Bilge.Assert hiding (assert) import qualified Brig.Options as Opts import qualified Brig.Types.Code as Code import Brig.Types.Intra -import Brig.Types.Team.LegalHold (LegalHoldStatus (..)) import Brig.Types.User import Brig.Types.User.Auth import qualified Brig.Types.User.Auth as Auth @@ -60,6 +59,7 @@ import Test.Tasty.HUnit import qualified Test.Tasty.HUnit as HUnit import UnliftIO.Async hiding (wait) import Util +import Wire.API.Team.Feature (TeamFeatureStatus (..)) tests :: Opts.Opts -> Manager -> ZAuth.Env -> Brig -> Galley -> Nginz -> TestTree tests conf m z b g n = @@ -165,7 +165,7 @@ testNginzLegalHold :: Brig -> Galley -> Nginz -> Http () testNginzLegalHold b g n = do -- create team user Alice (alice, tid) <- createUserWithTeam b - putLegalHoldEnabled tid LegalHoldEnabled g -- enable it for this team + putLegalHoldEnabled tid TeamFeatureEnabled g -- enable it for this team rs <- legalHoldLogin b (LegalHoldLogin alice (Just defPassword) Nothing) PersistentCookie runZAuth z (randomAccessToken @ZAuth.User @ZAuth.Access) @@ -840,7 +840,7 @@ prepareLegalHoldUser :: Brig -> Galley -> Http (UserId) prepareLegalHoldUser brig galley = do (uid, tid) <- createUserWithTeam brig -- enable it for this team - without that, legalhold login will fail. - putLegalHoldEnabled tid LegalHoldEnabled galley + putLegalHoldEnabled tid TeamFeatureEnabled galley return uid decodeCookie :: HasCallStack => Response a -> Http.Cookie diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index dc4bf17e0f3..69595a06ac4 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -46,6 +46,7 @@ import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently) import Util +import Wire.API.Team.Feature (TeamFeatureStatus (..)) tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree tests _cl _at conf p b c g = @@ -201,7 +202,7 @@ testHandleQuerySearchVisibilityNoNameOutsideTeam _opts brig galley = do (tid1, owner1, [member1]) <- createPopulatedBindingTeamWithNamesAndHandles brig 1 (_, owner2, [member2]) <- createPopulatedBindingTeamWithNamesAndHandles brig 1 extern <- randomUserWithHandle brig - setTeamTeamSearchVisibilityAvailable galley tid1 Team.TeamSearchVisibilityEnabled + setTeamTeamSearchVisibilityAvailable galley tid1 TeamFeatureEnabled setTeamSearchVisibility galley tid1 Team.SearchVisibilityNoNameOutsideTeam -- this is the same as in 'testHandleQuerySearchVisibilityStandard' above, because we search -- for handles, not names. diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index a5abc3b6cfe..da0cc876d7f 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -22,7 +22,6 @@ module Galley.API.Internal ) where -import Brig.Types.Team.LegalHold import qualified Cassandra as Cql import Control.Exception.Safe (catchAny) import Control.Lens hiding ((.=)) @@ -51,7 +50,6 @@ import Galley.Types.Bot (AddBot, RemoveBot) import Galley.Types.Bot.Service import Galley.Types.Teams import Galley.Types.Teams.Intra -import Galley.Types.Teams.SSO import Galley.Types.Teams.SearchVisibility import Imports hiding (head) import Network.Wai @@ -61,6 +59,7 @@ import Network.Wai.Routing hiding (route) import Network.Wai.Utilities import Network.Wai.Utilities.ZAuth import System.Logger.Class hiding (Path) +import qualified Wire.API.Team.Feature as Public sitemap :: Routes a Galley () sitemap = do @@ -170,31 +169,15 @@ sitemap = do -- Enabling this should only be possible internally. -- Viewing the status should be allowed for any admin. - get "/i/teams/:tid/features/legalhold" (continue Teams.getLegalholdStatusInternalH) $ + get "/i/teams/:tid/features/:feature" (continue Teams.getFeatureStatusInternalH) $ capture "tid" + .&. capture "feature" .&. accept "application" "json" - put "/i/teams/:tid/features/legalhold" (continue Teams.setLegalholdStatusInternalH) $ + put "/i/teams/:tid/features/:feature" (continue Teams.setFeatureStatusInternalH) $ capture "tid" - .&. jsonRequest @LegalHoldTeamConfig - .&. accept "application" "json" - - get "/i/teams/:tid/features/sso" (continue Teams.getSSOStatusInternalH) $ - capture "tid" - .&. accept "application" "json" - - put "/i/teams/:tid/features/sso" (continue Teams.setSSOStatusInternalH) $ - capture "tid" - .&. jsonRequest @SSOTeamConfig - .&. accept "application" "json" - - get "/i/teams/:tid/features/search-visibility" (continue Teams.getTeamSearchVisibilityAvailableInternalH) $ - capture "tid" - .&. accept "application" "json" - - put "/i/teams/:tid/features/search-visibility" (continue Teams.setTeamSearchVisibilityAvailableInternalH) $ - capture "tid" - .&. jsonRequest @TeamSearchVisibilityAvailableView + .&. capture "feature" + .&. jsonRequest @Public.TeamFeatureStatus .&. accept "application" "json" -- Misc API (internal) ------------------------------------------------ diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 296fafb2604..6ecf802f509 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -52,6 +52,7 @@ import Network.Wai.Predicate hiding (or, result, setStatus) import Network.Wai.Utilities as Wai import qualified System.Logger.Class as Log import UnliftIO.Async (pooledMapConcurrentlyN_) +import qualified Wire.API.Team.Feature as Public import qualified Wire.API.Team.LegalHold as Public assertLegalHoldEnabled :: TeamId -> Galley () @@ -60,9 +61,9 @@ assertLegalHoldEnabled tid = unlessM (isLegalHoldEnabled tid) $ throwM legalHold isLegalHoldEnabled :: TeamId -> Galley Bool isLegalHoldEnabled tid = do lhConfig <- LegalHoldData.getLegalHoldTeamConfig tid - return $ case legalHoldTeamConfigStatus <$> lhConfig of - Just LegalHoldEnabled -> True - Just LegalHoldDisabled -> False + return $ case lhConfig of + Just Public.TeamFeatureEnabled -> True + Just Public.TeamFeatureDisabled -> False Nothing -> False createSettingsH :: UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley Response @@ -94,7 +95,7 @@ getSettingsH (zusr ::: tid ::: _) = do getSettings :: UserId -> TeamId -> Galley Public.ViewLegalHoldService getSettings zusr tid = do zusrMembership <- Data.teamMember tid zusr - void $ permissionCheck ViewLegalHoldTeamSettings zusrMembership + void $ permissionCheck (ViewTeamFeature Public.TeamFeatureLegalHold) zusrMembership isenabled <- isLegalHoldEnabled tid mresult <- LegalHoldData.getSettings tid pure $ case (isenabled, mresult) of diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 12c18f1ed93..85ac9788b1c 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -452,27 +452,19 @@ sitemap = do -- Team Feature Flag API ---------------------------------------------- - get "/teams/:tid/features/legalhold" (continue Teams.getLegalholdStatusH) $ + get "/teams/:tid/features/:feature" (continue Teams.getFeatureStatusH) $ zauthUserId .&. capture "tid" + .&. capture "feature" .&. accept "application" "json" - document "GET" "getLegalholdStatus" $ do - summary "Shows whether the LegalHold feature is enabled for team" + document "GET" "getTeamFeature" $ do + summary "Shows whether a feature is enabled for a team" parameter Path "tid" bytes' $ description "Team ID" - returns (ref Public.modelLegalHoldTeamConfig) - response 200 "LegalHold status" end - - get "/teams/:tid/features/sso" (continue Teams.getSSOStatusH) $ - zauthUserId - .&. capture "tid" - .&. accept "application" "json" - document "GET" "getSSOStatus" $ do - summary "Shows whether SSO feature is enabled for team" - parameter Path "tid" bytes' $ - description "Team ID" - returns (ref Public.modelSsoTeamConfig) - response 200 "SSO status" end + parameter Path "feature" Public.typeFeatureName $ + description "Feature name" + returns (ref Public.modelTeamFeatureStatus) + response 200 "Team feature status" end -- Custom Backend API ------------------------------------------------- @@ -486,17 +478,6 @@ sitemap = do returns (ref Public.modelCustomBackend) response 200 "Custom backend" end - get "/teams/:tid/features/search-visibility" (continue Teams.getTeamSearchVisibilityAvailableH) $ - zauthUserId - .&. capture "tid" - .&. accept "application" "json" - document "GET" "getTeamSearchVisibilityAvailable" $ do - summary "Shows whether Custom Search Visibility feature is enabled for team" - parameter Path "tid" bytes' $ - description "Team ID" - returns (ref Public.modelTeamSearchVisibilityAvailable) - response 200 "Search Visibility status" end - -- Bot API ------------------------------------------------------------ get "/bot/conversation" (continue Query.getBotConversationH) $ diff --git a/services/galley/src/Galley/API/Swagger.hs b/services/galley/src/Galley/API/Swagger.hs index 77dd803ccf0..5bbb8d4b094 100644 --- a/services/galley/src/Galley/API/Swagger.hs +++ b/services/galley/src/Galley/API/Swagger.hs @@ -48,6 +48,7 @@ import Imports import Servant.API hiding (Header) import Servant.Swagger import URI.ByteString.QQ (uri) +import Wire.API.Team.Feature {- import Data.String.Conversions @@ -97,9 +98,9 @@ type GalleyRoutesPublic = type GalleyRoutesInternal = "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" - :> Get '[JSON] LegalHoldTeamConfig + :> Get '[JSON] TeamFeatureStatus :<|> "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" - :> ReqBody '[JSON] LegalHoldTeamConfig + :> ReqBody '[JSON] TeamFeatureStatus :> Put '[] NoContent -- FUTUREWORK: move Swagger instances next to the types they describe @@ -202,14 +203,12 @@ instance ToSchema MockViewLegalHoldServiceStatus where opts = defaultSchemaOptions {constructorTagModifier = camelToUnderscore} instance ToSchema ViewLegalHoldServiceInfo where - {- - + {- please don't put empty lines here: https://github.com/tweag/ormolu/issues/603 -- FUTUREWORK: The generic instance uses a reference to the UUID type in TeamId. This -- leads to perfectly valid swagger output, but 'validateEveryToJSON' chokes on it -- (unknown schema "UUID"). In order to be able to run those tests, we construct the -- 'ToSchema' instance manually. -- See also: https://github.com/haskell-servant/servant-swagger/pull/104 - declareNamedSchema = genericDeclareNamedSchema opts where opts = defaultSchemaOptions @@ -219,7 +218,6 @@ instance ToSchema ViewLegalHoldServiceInfo where "viewLegalHoldServiceTeam" -> "team_id" "viewLegalHoldServiceAuthToken" -> "auth_token" "viewLegalHoldServiceKey" -> "public_key" - } -} declareNamedSchema _ = @@ -261,29 +259,18 @@ instance ToSchema ViewLegalHoldServiceInfo where Right lhuri = mkHttpsUrl [uri|https://example.com/|] fpr = Fingerprint "\138\140\183\EM\226#\129\EOTl\161\183\246\DLE\161\142\220\239&\171\241h|\\GF\172\180O\129\DC1!\159" -instance ToSchema LegalHoldTeamConfig where - declareNamedSchema = genericDeclareNamedSchema opts - where - opts = - defaultSchemaOptions - { fieldLabelModifier = \case - "legalHoldTeamConfigStatus" -> "status" - } - -instance ToSchema LegalHoldStatus where - declareNamedSchema = tweak . genericDeclareNamedSchema opts +instance ToSchema TeamFeatureStatus where + declareNamedSchema _ = + pure $ NamedSchema (Just "TeamFeatureStatus") $ + mempty + & properties .~ (fromList [("status", Inline status)]) + & required .~ ["status"] + & type_ ?~ SwaggerObject + & description ?~ "whether a given team feature is enabled" where - opts = - defaultSchemaOptions - { constructorTagModifier = \case - "LegalHoldDisabled" -> "disabled" - "LegalHoldEnabled" -> "enabled" - } - tweak = fmap $ schema . description ?~ descr - where - descr = - "determines whether admins of a team " - <> "are allowed to enable LH for their users." + status = + mempty + & enum_ ?~ [String "enabled", String "disabled"] instance ToSchema RequestNewLegalHoldClient where declareNamedSchema = genericDeclareNamedSchema opts diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 4aa029fbb08..0a221f4cb60 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -39,15 +39,9 @@ module Galley.API.Teams getTeamConversationH, getTeamConversationRolesH, deleteTeamConversationH, - getSSOStatusH, - getSSOStatusInternalH, - setSSOStatusInternalH, - getLegalholdStatusH, - getLegalholdStatusInternalH, - setLegalholdStatusInternalH, - getTeamSearchVisibilityAvailableH, - setTeamSearchVisibilityAvailableInternalH, - getTeamSearchVisibilityAvailableInternalH, + getFeatureStatusH, + getFeatureStatusInternalH, + setFeatureStatusInternalH, getSearchVisibilityH, setSearchVisibilityH, getSearchVisibilityInternalH, @@ -65,7 +59,6 @@ module Galley.API.Teams where import Brig.Types.Team (TeamSize (..)) -import Brig.Types.Team.LegalHold (LegalHoldStatus (..), LegalHoldTeamConfig (..)) import Control.Lens import Control.Monad.Catch import Data.ByteString.Conversion hiding (fromList) @@ -102,7 +95,6 @@ import qualified Galley.Types as Conv import Galley.Types.Conversations.Roles as Roles import Galley.Types.Teams hiding (newTeam) import Galley.Types.Teams.Intra -import Galley.Types.Teams.SSO import Galley.Types.Teams.SearchVisibility import Imports import Network.HTTP.Types @@ -858,94 +850,70 @@ canUserJoinTeam tid = do -- Public endpoints for feature checks -getSSOStatusH :: UserId ::: TeamId ::: JSON -> Galley Response -getSSOStatusH (uid ::: tid ::: _) = do - json <$> getSSOStatus uid tid +getFeatureStatusH :: UserId ::: TeamId ::: Public.TeamFeatureName ::: JSON -> Galley Response +getFeatureStatusH (uid ::: tid ::: featureName ::: _) = + json <$> getFeatureStatus uid tid featureName -getSSOStatus :: UserId -> TeamId -> Galley Public.SSOTeamConfig -getSSOStatus uid tid = do +getFeatureStatus :: UserId -> TeamId -> Public.TeamFeatureName -> Galley Public.TeamFeatureStatus +getFeatureStatus uid tid featureName = do zusrMembership <- Data.teamMember tid uid - void $ permissionCheck ViewSSOTeamSettings zusrMembership - getSSOStatusInternal tid - -getLegalholdStatusH :: UserId ::: TeamId ::: JSON -> Galley Response -getLegalholdStatusH (uid ::: tid ::: _) = do - json <$> getLegalholdStatus uid tid - -getLegalholdStatus :: UserId -> TeamId -> Galley Public.LegalHoldTeamConfig -getLegalholdStatus uid tid = do - zusrMembership <- Data.teamMember tid uid - void $ permissionCheck ViewLegalHoldTeamSettings zusrMembership - getLegalholdStatusInternal tid - -getTeamSearchVisibilityAvailableH :: UserId ::: TeamId ::: JSON -> Galley Response -getTeamSearchVisibilityAvailableH (uid ::: tid ::: _) = - json <$> getTeamSearchVisibilityAvailable uid tid - -getTeamSearchVisibilityAvailable :: UserId -> TeamId -> Galley Public.TeamSearchVisibilityAvailableView -getTeamSearchVisibilityAvailable uid tid = do - zusrMembership <- Data.teamMember tid uid - void $ permissionCheck ViewTeamSearchVisibilityAvailable zusrMembership - getTeamSearchVisibilityAvailableInternal tid - --- Enable / Disable team features --- These endpoints are internal only and meant to be called --- only from authorized personnel (e.g., from a backoffice tool) - --- | Get SSO status for a team. -getSSOStatusInternalH :: TeamId ::: JSON -> Galley Response -getSSOStatusInternalH (tid ::: _) = do - json <$> getSSOStatusInternal tid - -getSSOStatusInternal :: TeamId -> Galley SSOTeamConfig + void $ permissionCheck (ViewTeamFeature featureName) zusrMembership + getFeatureStatusInternal tid featureName + +-- | Get feature flag status for a team. To be called only from authorized personnel (e.g., +-- from a backoffice tool) +getFeatureStatusInternalH :: TeamId ::: Public.TeamFeatureName ::: JSON -> Galley Response +getFeatureStatusInternalH (tid ::: featureName ::: _) = do + json <$> getFeatureStatusInternal tid featureName + +getFeatureStatusInternal :: TeamId -> Public.TeamFeatureName -> Galley Public.TeamFeatureStatus +getFeatureStatusInternal tid featureName = do + case featureName of + Public.TeamFeatureLegalHold -> getLegalholdStatusInternal tid + Public.TeamFeatureSSO -> getSSOStatusInternal tid + Public.TeamFeatureSearchVisibility -> getTeamSearchVisibilityAvailableInternal tid + +-- | Enable or disable feature flag for a team. To be called only from authorized personnel +-- (e.g., from a backoffice tool) +setFeatureStatusInternalH :: TeamId ::: Public.TeamFeatureName ::: JsonRequest Public.TeamFeatureStatus ::: JSON -> Galley Response +setFeatureStatusInternalH (tid ::: featureName ::: req ::: _) = + (empty & setStatus status204) <$ (setFeatureStatusInternal tid featureName =<< fromJsonBody req) + +setFeatureStatusInternal :: TeamId -> Public.TeamFeatureName -> Public.TeamFeatureStatus -> Galley () +setFeatureStatusInternal tid featureName status = do + case featureName of + Public.TeamFeatureLegalHold -> setLegalholdStatusInternal tid status + Public.TeamFeatureSSO -> setSSOStatusInternal tid status + Public.TeamFeatureSearchVisibility -> setTeamSearchVisibilityAvailableInternal tid status + +getSSOStatusInternal :: TeamId -> Galley Public.TeamFeatureStatus getSSOStatusInternal tid = do defConfig <- do featureSSO <- view (options . optSettings . setFeatureFlags . flagSSO) - pure . SSOTeamConfig $ case featureSSO of - FeatureSSOEnabledByDefault -> SSOEnabled - FeatureSSODisabledByDefault -> SSODisabled + pure $ case featureSSO of + FeatureSSOEnabledByDefault -> Public.TeamFeatureEnabled + FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled ssoTeamConfig <- SSOData.getSSOTeamConfig tid pure . fromMaybe defConfig $ ssoTeamConfig --- | Enable or disable SSO for a team. -setSSOStatusInternalH :: TeamId ::: JsonRequest SSOTeamConfig ::: JSON -> Galley Response -setSSOStatusInternalH (tid ::: req ::: _) = do - ssoTeamConfig <- fromJsonBody req - setSSOStatusInternal tid ssoTeamConfig - pure noContent - -setSSOStatusInternal :: TeamId -> SSOTeamConfig -> Galley () +setSSOStatusInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () setSSOStatusInternal tid ssoTeamConfig = do - case ssoTeamConfigStatus ssoTeamConfig of - SSODisabled -> throwM disableSsoNotImplemented - SSOEnabled -> pure () -- this one is easy to implement :) + case ssoTeamConfig of + Public.TeamFeatureDisabled -> throwM disableSsoNotImplemented + Public.TeamFeatureEnabled -> pure () -- this one is easy to implement :) SSOData.setSSOTeamConfig tid ssoTeamConfig --- | Get legal hold status for a team. -getLegalholdStatusInternalH :: TeamId ::: JSON -> Galley Response -getLegalholdStatusInternalH (tid ::: _) = do - json <$> getLegalholdStatusInternal tid - -getLegalholdStatusInternal :: TeamId -> Galley LegalHoldTeamConfig +getLegalholdStatusInternal :: TeamId -> Galley Public.TeamFeatureStatus getLegalholdStatusInternal tid = do featureLegalHold <- view (options . optSettings . setFeatureFlags . flagLegalHold) case featureLegalHold of FeatureLegalHoldDisabledByDefault -> do legalHoldTeamConfig <- LegalHoldData.getLegalHoldTeamConfig tid - pure (fromMaybe disabledConfig legalHoldTeamConfig) + pure (fromMaybe Public.TeamFeatureDisabled legalHoldTeamConfig) FeatureLegalHoldDisabledPermanently -> do - pure disabledConfig - where - disabledConfig = LegalHoldTeamConfig LegalHoldDisabled + pure Public.TeamFeatureDisabled --- | Enable or disable legal hold for a team. -setLegalholdStatusInternalH :: TeamId ::: JsonRequest LegalHoldTeamConfig ::: JSON -> Galley Response -setLegalholdStatusInternalH (tid ::: req ::: _) = do - legalHoldTeamConfig <- fromJsonBody req - setLegalholdStatusInternal tid legalHoldTeamConfig - pure noContent - -setLegalholdStatusInternal :: TeamId -> LegalHoldTeamConfig -> Galley () +setLegalholdStatusInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () setLegalholdStatusInternal tid legalHoldTeamConfig = do do featureLegalHold <- view (options . optSettings . setFeatureFlags . flagLegalHold) @@ -954,10 +922,10 @@ setLegalholdStatusInternal tid legalHoldTeamConfig = do pure () FeatureLegalHoldDisabledPermanently -> do throwM legalHoldFeatureFlagNotEnabled - case legalHoldTeamConfigStatus legalHoldTeamConfig of - LegalHoldDisabled -> removeSettings' tid + case legalHoldTeamConfig of + Public.TeamFeatureDisabled -> removeSettings' tid -- FUTUREWORK: We cannot enable legalhold on large teams right now - LegalHoldEnabled -> checkTeamSize + Public.TeamFeatureEnabled -> checkTeamSize LegalHoldData.setLegalHoldTeamConfig tid legalHoldTeamConfig where checkTeamSize = do @@ -966,32 +934,21 @@ setLegalholdStatusInternal tid legalHoldTeamConfig = do when (size > limit) $ do throwM cannotEnableLegalHoldServiceLargeTeam --- | Get Search visibility status for a team. -getTeamSearchVisibilityAvailableInternalH :: TeamId ::: JSON -> Galley Response -getTeamSearchVisibilityAvailableInternalH (tid ::: _) = do - json <$> getTeamSearchVisibilityAvailableInternal tid - -getTeamSearchVisibilityAvailableInternal :: TeamId -> Galley TeamSearchVisibilityAvailableView -getTeamSearchVisibilityAvailableInternal tid = TeamSearchVisibilityAvailableView <$> do +getTeamSearchVisibilityAvailableInternal :: TeamId -> Galley Public.TeamFeatureStatus +getTeamSearchVisibilityAvailableInternal tid = do -- TODO: This is just redundant given there is a decent default defConfig <- do featureTeamSearchVisibility <- view (options . optSettings . setFeatureFlags . flagTeamSearchVisibility) pure $ case featureTeamSearchVisibility of - FeatureTeamSearchVisibilityEnabledByDefault -> TeamSearchVisibilityEnabled - FeatureTeamSearchVisibilityDisabledByDefault -> TeamSearchVisibilityDisabled + FeatureTeamSearchVisibilityEnabledByDefault -> Public.TeamFeatureEnabled + FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled fromMaybe defConfig <$> SearchVisibilityData.getTeamSearchVisibilityAvailable tid --- | Enable or disable custom search visibility for a team. -setTeamSearchVisibilityAvailableInternalH :: TeamId ::: JsonRequest TeamSearchVisibilityAvailableView ::: JSON -> Galley Response -setTeamSearchVisibilityAvailableInternalH (tid ::: req ::: _) = do - setTeamSearchVisibilityAvailableInternal tid =<< fromJsonBody req - pure noContent - -setTeamSearchVisibilityAvailableInternal :: TeamId -> TeamSearchVisibilityAvailableView -> Galley () -setTeamSearchVisibilityAvailableInternal tid (TeamSearchVisibilityAvailableView isenabled) = do +setTeamSearchVisibilityAvailableInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () +setTeamSearchVisibilityAvailableInternal tid isenabled = do case isenabled of - TeamSearchVisibilityDisabled -> SearchVisibilityData.resetSearchVisibility tid - TeamSearchVisibilityEnabled -> pure () -- This allows the option to be set at the team level + Public.TeamFeatureDisabled -> SearchVisibilityData.resetSearchVisibility tid + Public.TeamFeatureEnabled -> pure () -- This allows the option to be set at the team level SearchVisibilityData.setTeamSearchVisibilityAvailable tid isenabled -- | Modify and get visibility type for a team (internal, no user permission checks) @@ -1009,8 +966,8 @@ setSearchVisibilityInternalH (tid ::: req ::: _) = do setSearchVisibilityInternal :: TeamId -> TeamSearchVisibilityView -> Galley () setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do - TeamSearchVisibilityAvailableView status <- getTeamSearchVisibilityAvailableInternal tid - unless (status == TeamSearchVisibilityEnabled) $ + status <- getTeamSearchVisibilityAvailableInternal tid + unless (status == Public.TeamFeatureEnabled) $ throwM teamSearchVisibilityNotEnabled SearchVisibilityData.setSearchVisibility tid searchVisibility diff --git a/services/galley/src/Galley/Data/Instances.hs b/services/galley/src/Galley/Data/Instances.hs index 9b9ee3df714..cdd5e9a4660 100644 --- a/services/galley/src/Galley/Data/Instances.hs +++ b/services/galley/src/Galley/Data/Instances.hs @@ -30,9 +30,9 @@ import Galley.Types import Galley.Types.Bot () import Galley.Types.Teams import Galley.Types.Teams.Intra -import Galley.Types.Teams.SSO import Galley.Types.Teams.SearchVisibility import Imports +import qualified Wire.API.Team.Feature as Public deriving instance Cql MutedStatus @@ -125,29 +125,17 @@ instance Cql TeamStatus where n -> fail $ "unexpected team-status: " ++ show n fromCql _ = fail "team-status: int expected" -instance Cql SSOStatus where +instance Cql Public.TeamFeatureStatus where ctype = Tagged IntColumn fromCql (CqlInt n) = case n of - 0 -> pure $ SSODisabled - 1 -> pure $ SSOEnabled - _ -> fail "fromCql: Invalid SSOStatus" - fromCql _ = fail "fromCql: SSOStatus: CqlInt expected" + 0 -> pure $ Public.TeamFeatureDisabled + 1 -> pure $ Public.TeamFeatureEnabled + _ -> fail "fromCql: Invalid TeamFeatureStatus" + fromCql _ = fail "fromCql: TeamFeatureStatus: CqlInt expected" - toCql SSODisabled = CqlInt 0 - toCql SSOEnabled = CqlInt 1 - -instance Cql TeamSearchVisibilityAvailable where - ctype = Tagged IntColumn - - fromCql (CqlInt n) = case n of - 0 -> pure $ TeamSearchVisibilityDisabled - 1 -> pure $ TeamSearchVisibilityEnabled - _ -> fail "fromCql: Invalid TeamSearchVisibilityAvailable" - fromCql _ = fail "fromCql: TeamSearchVisibilityAvailable: CqlInt expected" - - toCql TeamSearchVisibilityDisabled = CqlInt 0 - toCql TeamSearchVisibilityEnabled = CqlInt 1 + toCql Public.TeamFeatureDisabled = CqlInt 0 + toCql Public.TeamFeatureEnabled = CqlInt 1 instance Cql TeamSearchVisibility where ctype = Tagged IntColumn diff --git a/services/galley/src/Galley/Data/LegalHold.hs b/services/galley/src/Galley/Data/LegalHold.hs index 078e2c32aa4..6036faaa327 100644 --- a/services/galley/src/Galley/Data/LegalHold.hs +++ b/services/galley/src/Galley/Data/LegalHold.hs @@ -40,18 +40,20 @@ import Data.LegalHold import Galley.Data.Instances () import Galley.Data.Queries as Q import Imports +import Wire.API.Team.Feature (TeamFeatureStatus (..)) -- | Return whether a given team is allowed to enable/disable legalhold -getLegalHoldTeamConfig :: MonadClient m => TeamId -> m (Maybe LegalHoldTeamConfig) +-- Defaults to 'TeamFeatureDisabled'. +getLegalHoldTeamConfig :: MonadClient m => TeamId -> m (Maybe TeamFeatureStatus) getLegalHoldTeamConfig tid = fmap toLegalHoldTeamConfig <$> do retry x1 $ query1 selectLegalHoldTeamConfig (params Quorum (Identity tid)) where - toLegalHoldTeamConfig (Identity Nothing) = LegalHoldTeamConfig LegalHoldDisabled - toLegalHoldTeamConfig (Identity (Just status)) = LegalHoldTeamConfig status + toLegalHoldTeamConfig (Identity Nothing) = TeamFeatureDisabled + toLegalHoldTeamConfig (Identity (Just status)) = status -- | Determines whether a given team is allowed to enable/disable legalhold -setLegalHoldTeamConfig :: MonadClient m => TeamId -> LegalHoldTeamConfig -> m () -setLegalHoldTeamConfig tid LegalHoldTeamConfig {legalHoldTeamConfigStatus} = do +setLegalHoldTeamConfig :: MonadClient m => TeamId -> TeamFeatureStatus -> m () +setLegalHoldTeamConfig tid legalHoldTeamConfigStatus = do retry x5 $ write updateLegalHoldTeamConfig (params Quorum (legalHoldTeamConfigStatus, tid)) -- | Returns 'False' if legal hold is not enabled for this team diff --git a/services/galley/src/Galley/Data/Queries.hs b/services/galley/src/Galley/Data/Queries.hs index db97bab0936..530f5dd8293 100644 --- a/services/galley/src/Galley/Data/Queries.hs +++ b/services/galley/src/Galley/Data/Queries.hs @@ -20,7 +20,6 @@ module Galley.Data.Queries where import Brig.Types.Client.Prekey import Brig.Types.Code import Brig.Types.Provider -import Brig.Types.Team.LegalHold (LegalHoldStatus) import Cassandra as C hiding (Value) import Cassandra.Util (Writetime) import Data.Domain (Domain) @@ -34,10 +33,10 @@ import Galley.Types hiding (Conversation) import Galley.Types.Conversations.Roles import Galley.Types.Teams import Galley.Types.Teams.Intra -import Galley.Types.Teams.SSO import Galley.Types.Teams.SearchVisibility import Imports import Text.RawString.QQ +import Wire.API.Team.Feature (TeamFeatureStatus) -- Teams -------------------------------------------------------------------- @@ -322,10 +321,10 @@ insertBot = "insert into member (conv, user, service, provider, status) values ( -- LegalHold ---------------------------------------------------------------- -selectLegalHoldTeamConfig :: PrepQuery R (Identity TeamId) (Identity (Maybe LegalHoldStatus)) +selectLegalHoldTeamConfig :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatus)) selectLegalHoldTeamConfig = "select legalhold_status from team_features where team_id = ?" -updateLegalHoldTeamConfig :: PrepQuery W (LegalHoldStatus, TeamId) () +updateLegalHoldTeamConfig :: PrepQuery W (TeamFeatureStatus, TeamId) () updateLegalHoldTeamConfig = "update team_features set legalhold_status = ? where team_id = ?" insertLegalHoldSettings :: PrepQuery W (HttpsUrl, Fingerprint Rsa, ServiceToken, ServiceKey, TeamId) () @@ -380,19 +379,19 @@ updateUserLegalHoldStatus = where team = ? and user = ? |] -selectSSOTeamConfig :: PrepQuery R (Identity TeamId) (Identity (Maybe SSOStatus)) +selectSSOTeamConfig :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatus)) selectSSOTeamConfig = "select sso_status from team_features where team_id = ?" -updateSSOTeamConfig :: PrepQuery W (SSOStatus, TeamId) () +updateSSOTeamConfig :: PrepQuery W (TeamFeatureStatus, TeamId) () updateSSOTeamConfig = "update team_features set sso_status = ? where team_id = ?" -selectTeamSearchVisibilityAvailable :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamSearchVisibilityAvailable)) +selectTeamSearchVisibilityAvailable :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatus)) selectTeamSearchVisibilityAvailable = "select search_visibility_status from team_features where team_id = ?" -updateTeamSearchVisibilityAvailable :: PrepQuery W (TeamSearchVisibilityAvailable, TeamId) () +updateTeamSearchVisibilityAvailable :: PrepQuery W (TeamFeatureStatus, TeamId) () updateTeamSearchVisibilityAvailable = "update team_features set search_visibility_status = ? where team_id = ?" diff --git a/services/galley/src/Galley/Data/SSO.hs b/services/galley/src/Galley/Data/SSO.hs index 5c00331fc1b..fd5d484be15 100644 --- a/services/galley/src/Galley/Data/SSO.hs +++ b/services/galley/src/Galley/Data/SSO.hs @@ -27,18 +27,19 @@ import Cassandra import Data.Id import Galley.Data.Instances () import Galley.Data.Queries -import Galley.Types.Teams.SSO import Imports +import Wire.API.Team.Feature (TeamFeatureStatus (..)) --- | Return whether a given team is allowed to enable/disable sso -getSSOTeamConfig :: MonadClient m => TeamId -> m (Maybe SSOTeamConfig) +-- | Return whether a given team is allowed to enable/disable sso. +-- Defaults to 'TeamFeatureDisabled' if null in the DB +getSSOTeamConfig :: MonadClient m => TeamId -> m (Maybe TeamFeatureStatus) getSSOTeamConfig tid = fmap toSSOTeamConfig <$> do retry x1 $ query1 selectSSOTeamConfig (params Quorum (Identity tid)) where - toSSOTeamConfig (Identity Nothing) = SSOTeamConfig SSODisabled - toSSOTeamConfig (Identity (Just status)) = SSOTeamConfig status + toSSOTeamConfig (Identity Nothing) = TeamFeatureDisabled + toSSOTeamConfig (Identity (Just status)) = status -- | Determines whether a given team is allowed to enable/disable sso -setSSOTeamConfig :: MonadClient m => TeamId -> SSOTeamConfig -> m () -setSSOTeamConfig tid SSOTeamConfig {ssoTeamConfigStatus} = do +setSSOTeamConfig :: MonadClient m => TeamId -> TeamFeatureStatus -> m () +setSSOTeamConfig tid ssoTeamConfigStatus = do retry x5 $ write updateSSOTeamConfig (params Quorum (ssoTeamConfigStatus, tid)) diff --git a/services/galley/src/Galley/Data/SearchVisibility.hs b/services/galley/src/Galley/Data/SearchVisibility.hs index b685c49f526..20e2ae7e164 100644 --- a/services/galley/src/Galley/Data/SearchVisibility.hs +++ b/services/galley/src/Galley/Data/SearchVisibility.hs @@ -32,14 +32,15 @@ import Galley.Data.Instances () import Galley.Data.Queries import Galley.Types.Teams.SearchVisibility import Imports +import Wire.API.Team.Feature (TeamFeatureStatus) -- | Return whether a given team is allowed to enable/disable sso -getTeamSearchVisibilityAvailable :: MonadClient m => TeamId -> m (Maybe TeamSearchVisibilityAvailable) +getTeamSearchVisibilityAvailable :: MonadClient m => TeamId -> m (Maybe TeamFeatureStatus) getTeamSearchVisibilityAvailable tid = join . fmap runIdentity <$> do retry x1 $ query1 selectTeamSearchVisibilityAvailable (params Quorum (Identity tid)) -- | Determines whether a given team is allowed to enable/disable sso -setTeamSearchVisibilityAvailable :: MonadClient m => TeamId -> TeamSearchVisibilityAvailable -> m () +setTeamSearchVisibilityAvailable :: MonadClient m => TeamId -> TeamFeatureStatus -> m () setTeamSearchVisibilityAvailable tid isenabled = do retry x5 $ write updateTeamSearchVisibilityAvailable (params Quorum (isenabled, tid)) diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 1830268dbb9..4267fca0bdd 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -26,7 +26,6 @@ import qualified API.Util as Util import Bilge hiding (timeout) import Bilge.Assert import qualified Brig.Types as Brig -import Brig.Types.Team.LegalHold (LegalHoldStatus (..), LegalHoldTeamConfig (..)) import Control.Lens hiding ((#), (.=)) import Control.Monad.Catch import Control.Retry @@ -52,7 +51,6 @@ import qualified Galley.Types as Conv import Galley.Types.Conversations.Roles import Galley.Types.Teams import Galley.Types.Teams.Intra -import Galley.Types.Teams.SSO import Galley.Types.Teams.SearchVisibility import Gundeck.Types.Notification hiding (target) import Imports @@ -69,6 +67,7 @@ import Test.Tasty.HUnit import TestHelpers (test) import TestSetup (TestM, TestSetup, tsBrig, tsCannon, tsGConf, tsGalley) import UnliftIO (mapConcurrently, mapConcurrently_) +import qualified Wire.API.Team.Feature as Public tests :: IO TestSetup -> TestTree tests s = @@ -286,9 +285,9 @@ testEnableSSOPerTeam = do owner <- Util.randomUser tid <- Util.createBindingTeamInternal "foo" owner assertQueue "create team" tActivate - let check :: HasCallStack => String -> SSOStatus -> TestM () + let check :: HasCallStack => String -> Public.TeamFeatureStatus -> TestM () check msg enabledness = do - SSOTeamConfig status <- responseJsonUnsafe <$> (getSSOEnabledInternal tid (getSSOEnabledInternal tid TestM () putSSOEnabledInternalCheckNotImplemented = do @@ -298,26 +297,26 @@ testEnableSSOPerTeam = do <$> put ( g . paths ["i", "teams", toByteString' tid, "features", "sso"] - . json (SSOTeamConfig SSODisabled) + . json Public.TeamFeatureDisabled ) liftIO $ do assertEqual "bad status" status403 status assertEqual "bad label" "not-implemented" label featureSSO <- view (tsGConf . optSettings . setFeatureFlags . flagSSO) case featureSSO of - FeatureSSOEnabledByDefault -> check "Teams should start with SSO enabled" SSOEnabled - FeatureSSODisabledByDefault -> check "Teams should start with SSO disabled" SSODisabled - putSSOEnabledInternal tid SSOEnabled - check "Calling 'putEnabled True' should enable SSO" SSOEnabled + FeatureSSOEnabledByDefault -> check "Teams should start with SSO enabled" Public.TeamFeatureEnabled + FeatureSSODisabledByDefault -> check "Teams should start with SSO disabled" Public.TeamFeatureDisabled + putSSOEnabledInternal tid Public.TeamFeatureEnabled + check "Calling 'putEnabled True' should enable SSO" Public.TeamFeatureEnabled putSSOEnabledInternalCheckNotImplemented testEnableTeamSearchVisibilityPerTeam :: TestM () testEnableTeamSearchVisibilityPerTeam = do g <- view tsGalley (tid, owner, (member : _)) <- Util.createBindingTeamWithMembers 2 - let check :: (HasCallStack, MonadCatch m, MonadIO m, Monad m, MonadHttp m) => String -> TeamSearchVisibilityAvailable -> m () + let check :: (HasCallStack, MonadCatch m, MonadIO m, Monad m, MonadHttp m) => String -> Public.TeamFeatureStatus -> m () check msg enabledness = do - TeamSearchVisibilityAvailableView status <- responseJsonUnsafe <$> (getTeamSearchVisibilityAvailableInternal g tid (getTeamSearchVisibilityAvailableInternal g tid m () putSearchVisibilityCheckNotAllowed = do @@ -331,14 +330,14 @@ testEnableTeamSearchVisibilityPerTeam = do const (Just (TeamSearchVisibilityView vis)) === responseJsonUnsafe withCustomSearchFeature FeatureTeamSearchVisibilityEnabledByDefault $ do - check "Teams should start with Custom Search Visibility enabled" TeamSearchVisibilityEnabled + check "Teams should start with Custom Search Visibility enabled" Public.TeamFeatureEnabled putSearchVisibility g owner tid SearchVisibilityNoNameOutsideTeam !!! const 204 === statusCode putSearchVisibility g owner tid SearchVisibilityStandard !!! const 204 === statusCode withCustomSearchFeature FeatureTeamSearchVisibilityDisabledByDefault $ do - check "Teams should start with Custom Search Visibility disabled" TeamSearchVisibilityDisabled + check "Teams should start with Custom Search Visibility disabled" Public.TeamFeatureDisabled putSearchVisibilityCheckNotAllowed - putTeamSearchVisibilityAvailableInternal g tid TeamSearchVisibilityEnabled + putTeamSearchVisibilityAvailableInternal g tid Public.TeamFeatureEnabled -- Nothing was set, default value getSearchVisibilityCheck SearchVisibilityStandard putSearchVisibility g owner tid SearchVisibilityNoNameOutsideTeam !!! testResponse 204 Nothing @@ -349,7 +348,7 @@ testEnableTeamSearchVisibilityPerTeam = do -- Members can also see it? getSearchVisibility g member tid !!! testResponse 200 Nothing -- Once we disable the feature, team setting is back to the default value - putTeamSearchVisibilityAvailableInternal g tid TeamSearchVisibilityDisabled + putTeamSearchVisibilityAvailableInternal g tid Public.TeamFeatureDisabled getSearchVisibilityCheck SearchVisibilityStandard testCreateOne2OneFailNonBindingTeamMembers :: TestM () @@ -1894,13 +1893,13 @@ getSSOEnabledInternal tid = do g . paths ["i", "teams", toByteString' tid, "features", "sso"] -putSSOEnabledInternal :: HasCallStack => TeamId -> SSOStatus -> TestM () +putSSOEnabledInternal :: HasCallStack => TeamId -> Public.TeamFeatureStatus -> TestM () putSSOEnabledInternal tid enabled = do g <- view tsGalley void . put $ g . paths ["i", "teams", toByteString' tid, "features", "sso"] - . json (SSOTeamConfig enabled) + . json enabled . expect2xx getSearchVisibility :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS @@ -1931,12 +1930,12 @@ getTeamSearchVisibilityAvailableInternal g tid = do g . paths ["i", "teams", toByteString' tid, "features", "search-visibility"] -putTeamSearchVisibilityAvailableInternal :: HasCallStack => (Request -> Request) -> TeamId -> TeamSearchVisibilityAvailable -> (MonadIO m, MonadHttp m) => m () +putTeamSearchVisibilityAvailableInternal :: HasCallStack => (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> (MonadIO m, MonadHttp m) => m () putTeamSearchVisibilityAvailableInternal g tid status = do void . put $ g . paths ["i", "teams", toByteString' tid, "features", "search-visibility"] - . json (TeamSearchVisibilityAvailableView status) + . json status . expect2xx getLegalHoldEnabled :: HasCallStack => UserId -> TeamId -> TestM ResponseLBS @@ -1954,16 +1953,16 @@ getLegalHoldEnabledInternal tid = do g . paths ["i", "teams", toByteString' tid, "features", "legalhold"] -putLegalHoldEnabledInternal :: HasCallStack => TeamId -> LegalHoldStatus -> TestM () +putLegalHoldEnabledInternal :: HasCallStack => TeamId -> Public.TeamFeatureStatus -> TestM () putLegalHoldEnabledInternal = putLegalHoldEnabledInternal' expect2xx -putLegalHoldEnabledInternal' :: HasCallStack => (Request -> Request) -> TeamId -> LegalHoldStatus -> TestM () +putLegalHoldEnabledInternal' :: HasCallStack => (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> TestM () putLegalHoldEnabledInternal' reqmod tid enabled = do g <- view tsGalley void . put $ g . paths ["i", "teams", toByteString' tid, "features", "legalhold"] - . json (LegalHoldTeamConfig enabled) + . json enabled . reqmod testFeatureFlags :: TestM () @@ -1973,54 +1972,54 @@ testFeatureFlags = do -- sso - let getSSO :: HasCallStack => SSOStatus -> TestM () + let getSSO :: HasCallStack => Public.TeamFeatureStatus -> TestM () getSSO expected = getSSOEnabled owner tid !!! do statusCode === const 200 - responseJsonEither === const (Right (SSOTeamConfig expected)) - getSSOInternal :: HasCallStack => SSOStatus -> TestM () + responseJsonEither === const (Right expected) + getSSOInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () getSSOInternal expected = getSSOEnabledInternal tid !!! do statusCode === const 200 - responseJsonEither === const (Right (SSOTeamConfig expected)) - setSSOInternal :: HasCallStack => SSOStatus -> TestM () + responseJsonEither === const (Right expected) + setSSOInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () setSSOInternal = putSSOEnabledInternal tid featureSSO <- view (tsGConf . optSettings . setFeatureFlags . flagSSO) case featureSSO of FeatureSSODisabledByDefault -> do - getSSO SSODisabled - getSSOInternal SSODisabled - setSSOInternal SSOEnabled - getSSO SSOEnabled - getSSOInternal SSOEnabled + getSSO Public.TeamFeatureDisabled + getSSOInternal Public.TeamFeatureDisabled + setSSOInternal Public.TeamFeatureEnabled + getSSO Public.TeamFeatureEnabled + getSSOInternal Public.TeamFeatureEnabled FeatureSSOEnabledByDefault -> do -- since we don't allow to disable (see 'disableSsoNotImplemented'), we can't test -- much here. (disable failure is covered in "enable/disable SSO" above.) - getSSO SSOEnabled - getSSOInternal SSOEnabled + getSSO Public.TeamFeatureEnabled + getSSOInternal Public.TeamFeatureEnabled -- legalhold - let getLegalHold :: HasCallStack => LegalHoldStatus -> TestM () + let getLegalHold :: HasCallStack => Public.TeamFeatureStatus -> TestM () getLegalHold expected = getLegalHoldEnabled owner tid !!! do statusCode === const 200 - responseJsonEither === const (Right (LegalHoldTeamConfig expected)) - getLegalHoldInternal :: HasCallStack => LegalHoldStatus -> TestM () + responseJsonEither === const (Right expected) + getLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () getLegalHoldInternal expected = getLegalHoldEnabledInternal tid !!! do statusCode === const 200 - responseJsonEither === const (Right (LegalHoldTeamConfig expected)) - setLegalHoldInternal :: HasCallStack => LegalHoldStatus -> TestM () + responseJsonEither === const (Right expected) + setLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () setLegalHoldInternal = putLegalHoldEnabledInternal tid - getLegalHold LegalHoldDisabled - getLegalHoldInternal LegalHoldDisabled + getLegalHold Public.TeamFeatureDisabled + getLegalHoldInternal Public.TeamFeatureDisabled -- FUTUREWORK: run two galleys, like below for custom search visibility. featureLegalHold <- view (tsGConf . optSettings . setFeatureFlags . flagLegalHold) case featureLegalHold of FeatureLegalHoldDisabledByDefault -> do - setLegalHoldInternal LegalHoldEnabled - getLegalHold LegalHoldEnabled - getLegalHoldInternal LegalHoldEnabled + setLegalHoldInternal Public.TeamFeatureEnabled + getLegalHold Public.TeamFeatureEnabled + getLegalHoldInternal Public.TeamFeatureEnabled FeatureLegalHoldDisabledPermanently -> do - putLegalHoldEnabledInternal' expect4xx tid LegalHoldEnabled + putLegalHoldEnabledInternal' expect4xx tid Public.TeamFeatureEnabled -- custom search visibility @@ -2028,48 +2027,48 @@ testFeatureFlags = do let getTeamSearchVisibility :: (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => TeamId -> - TeamSearchVisibilityAvailable -> + Public.TeamFeatureStatus -> m () getTeamSearchVisibility teamid expected = getTeamSearchVisibilityAvailable g owner teamid !!! do statusCode === const 200 - responseJsonEither === const (Right (TeamSearchVisibilityAvailableView expected)) + responseJsonEither === const (Right expected) let getTeamSearchVisibilityInternal :: (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => TeamId -> - TeamSearchVisibilityAvailable -> + Public.TeamFeatureStatus -> m () getTeamSearchVisibilityInternal teamid expected = getTeamSearchVisibilityAvailableInternal g teamid !!! do statusCode === const 200 - responseJsonEither === const (Right (TeamSearchVisibilityAvailableView expected)) + responseJsonEither === const (Right expected) let setTeamSearchVisibilityInternal :: (Monad m, MonadHttp m, MonadIO m, HasCallStack) => TeamId -> - TeamSearchVisibilityAvailable -> + Public.TeamFeatureStatus -> m () setTeamSearchVisibilityInternal = putTeamSearchVisibilityAvailableInternal g tid2 <- Util.createNonBindingTeam "foo" owner [] withCustomSearchFeature FeatureTeamSearchVisibilityDisabledByDefault $ do - getTeamSearchVisibility tid2 TeamSearchVisibilityDisabled - getTeamSearchVisibilityInternal tid2 TeamSearchVisibilityDisabled - setTeamSearchVisibilityInternal tid2 TeamSearchVisibilityEnabled - getTeamSearchVisibility tid2 TeamSearchVisibilityEnabled - getTeamSearchVisibilityInternal tid2 TeamSearchVisibilityEnabled - setTeamSearchVisibilityInternal tid2 TeamSearchVisibilityDisabled - getTeamSearchVisibility tid2 TeamSearchVisibilityDisabled - getTeamSearchVisibilityInternal tid2 TeamSearchVisibilityDisabled + getTeamSearchVisibility tid2 Public.TeamFeatureDisabled + getTeamSearchVisibilityInternal tid2 Public.TeamFeatureDisabled + setTeamSearchVisibilityInternal tid2 Public.TeamFeatureEnabled + getTeamSearchVisibility tid2 Public.TeamFeatureEnabled + getTeamSearchVisibilityInternal tid2 Public.TeamFeatureEnabled + setTeamSearchVisibilityInternal tid2 Public.TeamFeatureDisabled + getTeamSearchVisibility tid2 Public.TeamFeatureDisabled + getTeamSearchVisibilityInternal tid2 Public.TeamFeatureDisabled tid3 <- Util.createNonBindingTeam "foo" owner [] withCustomSearchFeature FeatureTeamSearchVisibilityEnabledByDefault $ do - getTeamSearchVisibility tid3 TeamSearchVisibilityEnabled - getTeamSearchVisibilityInternal tid3 TeamSearchVisibilityEnabled - setTeamSearchVisibilityInternal tid3 TeamSearchVisibilityDisabled - getTeamSearchVisibility tid3 TeamSearchVisibilityDisabled - getTeamSearchVisibilityInternal tid3 TeamSearchVisibilityDisabled - setTeamSearchVisibilityInternal tid3 TeamSearchVisibilityEnabled - getTeamSearchVisibility tid3 TeamSearchVisibilityEnabled - getTeamSearchVisibilityInternal tid3 TeamSearchVisibilityEnabled + getTeamSearchVisibility tid3 Public.TeamFeatureEnabled + getTeamSearchVisibilityInternal tid3 Public.TeamFeatureEnabled + setTeamSearchVisibilityInternal tid3 Public.TeamFeatureDisabled + getTeamSearchVisibility tid3 Public.TeamFeatureDisabled + getTeamSearchVisibilityInternal tid3 Public.TeamFeatureDisabled + setTeamSearchVisibilityInternal tid3 Public.TeamFeatureEnabled + getTeamSearchVisibility tid3 Public.TeamFeatureEnabled + getTeamSearchVisibilityInternal tid3 Public.TeamFeatureEnabled checkJoinEvent :: (MonadIO m, MonadCatch m) => TeamId -> UserId -> WS.WebSocket -> m () checkJoinEvent tid usr w = WS.assertMatch_ timeout w $ \notif -> do diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index ff4f96bcd82..081547dd04e 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -85,6 +85,7 @@ import Test.Tasty.HUnit import Test.Tasty.HUnit (assertBool) import TestHelpers import TestSetup +import qualified Wire.API.Team.Feature as Public onlyIfLhEnabled :: TestM () -> TestM () onlyIfLhEnabled action = do @@ -346,7 +347,7 @@ testCreateLegalHoldTeamSettings = do newService <- newLegalHoldService -- not allowed to create if team setting is disabled postSettings owner tid newService !!! testResponse 403 (Just "legalhold-not-enabled") - putEnabled tid LegalHoldEnabled -- enable it for this team + putEnabled tid Public.TeamFeatureEnabled -- enable it for this team -- not allowed for users with corresp. permission bit missing postSettings member tid newService !!! testResponse 403 (Just "operation-denied") @@ -414,7 +415,7 @@ testGetLegalHoldTeamSettings = do assertEqual "bad body" ViewLegalHoldServiceDisabled (responseJsonUnsafe resp) getSettings owner tid >>= respOk getSettings member tid >>= respOk - putEnabled tid LegalHoldEnabled -- enable it for this team + putEnabled tid Public.TeamFeatureEnabled -- enable it for this team -- returns 200 with corresp. status if legalhold for team is enabled, but not configured do @@ -495,12 +496,12 @@ testEnablePerTeam = do addTeamMemberInternal tid $ newTeamMember member (rolePermissions RoleMember) Nothing ensureQueueEmpty do - LegalHoldTeamConfig status <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid do requestLegalHoldDevice owner member tid !!! const 201 === statusCode approveLegalHoldDevice (Just defPassword) member member tid !!! testResponse 200 Nothing @@ -508,9 +509,9 @@ testEnablePerTeam = do UserLegalHoldStatusResponse status _ _ <- getUserStatusTyped member tid liftIO $ assertEqual "User legal hold status should be enabled" UserLegalHoldEnabled status do - putEnabled tid LegalHoldDisabled -- disable again - LegalHoldTeamConfig status <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid TeamId -> LegalHoldStatus -> TestM () +putEnabled :: HasCallStack => TeamId -> Public.TeamFeatureStatus -> TestM () putEnabled tid enabled = void $ putEnabled' expect2xx tid enabled -putEnabled' :: HasCallStack => (Bilge.Request -> Bilge.Request) -> TeamId -> LegalHoldStatus -> TestM ResponseLBS +putEnabled' :: HasCallStack => (Bilge.Request -> Bilge.Request) -> TeamId -> Public.TeamFeatureStatus -> TestM ResponseLBS putEnabled' extra tid enabled = do g <- view tsGalley put $ g . paths ["i", "teams", toByteString' tid, "features", "legalhold"] - . json (LegalHoldTeamConfig enabled) + . json enabled . extra postSettings :: HasCallStack => UserId -> TeamId -> NewLegalHoldService -> TestM ResponseLBS @@ -793,7 +794,7 @@ withDummyTestServiceForTeam owner tid go = do runTest :: Chan (Wai.Request, LBS) -> TestM a runTest chan = do newService <- newLegalHoldService - putEnabled tid LegalHoldEnabled -- enable it for this team + putEnabled tid Public.TeamFeatureEnabled -- enable it for this team postSettings owner tid newService !!! testResponse 201 Nothing go chan dummyService :: Chan (Wai.Request, LBS) -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived diff --git a/services/spar/package.yaml b/services/spar/package.yaml index 44fcb4f4ebc..9c0730333e5 100644 --- a/services/spar/package.yaml +++ b/services/spar/package.yaml @@ -80,6 +80,7 @@ dependencies: - wai-middleware-prometheus - wai-utilities - warp + - wire-api - x509 - xml-conduit - yaml @@ -145,6 +146,7 @@ executables: - wai - wai-extra - warp-tls + - wire-api - xml-conduit - xml-hamlet - xml-lens diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index cde15c80b30..63c085843a6 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: c123bc75185ca36b175ec72d113c7114ea81282dc0e3ae0906764c5b19c0a3bf +-- hash: e6e868da454f0bfa37e1a2dc1bd7710aafda8976e37a198e0f4ea77e6a90d8fd name: spar version: 0.1 @@ -109,6 +109,7 @@ library , wai-middleware-prometheus , wai-utilities , warp + , wire-api , x509 , xml-conduit , yaml @@ -187,6 +188,7 @@ executable spar , wai-middleware-prometheus , wai-utilities , warp + , wire-api , x509 , xml-conduit , yaml @@ -289,6 +291,7 @@ executable spar-integration , wai-utilities , warp , warp-tls + , wire-api , x509 , xml-conduit , xml-hamlet @@ -379,6 +382,7 @@ executable spar-schema , wai-middleware-prometheus , wai-utilities , warp + , wire-api , x509 , xml-conduit , yaml @@ -468,6 +472,7 @@ test-suite spec , wai-middleware-prometheus , wai-utilities , warp + , wire-api , x509 , xml-conduit , yaml diff --git a/services/spar/src/Spar/Intra/Galley.hs b/services/spar/src/Spar/Intra/Galley.hs index 5db6fd6d9e7..cf21fe42b44 100644 --- a/services/spar/src/Spar/Intra/Galley.hs +++ b/services/spar/src/Spar/Intra/Galley.hs @@ -28,11 +28,11 @@ import Data.ByteString.Conversion import Data.Id (TeamId, UserId) import Data.String.Conversions import Galley.Types.Teams -import Galley.Types.Teams.SSO import Imports import Network.HTTP.Types (status403) import Network.HTTP.Types.Method import Spar.Error +import Wire.API.Team.Feature (TeamFeatureStatus (..)) ---------------------------------------------------------------------- @@ -84,6 +84,6 @@ assertSSOEnabled tid = do . paths ["i", "teams", toByteString' tid, "features", "sso"] unless (statusCode resp == 200) $ throwSpar (SparGalleyError "Could not retrieve SSO config") - SSOTeamConfig status <- parseResponse resp - unless (status == SSOEnabled) $ + status <- parseResponse resp + unless (status == TeamFeatureEnabled) $ throwSpar SparSSODisabled diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 4db18573b68..3a942c17fa5 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -152,7 +152,6 @@ import Data.UUID.V4 as UUID (nextRandom) import qualified Data.Yaml as Yaml import GHC.TypeLits import qualified Galley.Types.Teams as Galley -import qualified Galley.Types.Teams.SSO as Galley import Imports hiding (head) import Network.HTTP.Client.MultipartFormData import qualified Network.Wai.Handler.Warp as Warp @@ -185,6 +184,7 @@ import Util.Options import Util.Types import qualified Web.Cookie as Web import qualified Web.Scim.Class.User as ScimC.User +import Wire.API.Team.Feature (TeamFeatureStatus (..)) -- | Call 'mkEnv' with options from config files. mkEnvFromOptions :: IO TestEnv @@ -304,7 +304,7 @@ getUserBrig uid = do createUserWithTeam :: (HasCallStack, MonadHttp m, MonadIO m, MonadFail m) => BrigReq -> GalleyReq -> m (UserId, TeamId) createUserWithTeam brg gly = do (uid, tid) <- createUserWithTeamDisableSSO brg gly - putSSOEnabledInternal gly tid Galley.SSOEnabled + putSSOEnabledInternal gly tid TeamFeatureEnabled pure (uid, tid) createUserWithTeamDisableSSO :: (HasCallStack, MonadHttp m, MonadIO m, MonadFail m) => BrigReq -> GalleyReq -> m (UserId, TeamId) @@ -337,12 +337,12 @@ getSSOEnabledInternal gly tid = do gly . paths ["i", "teams", toByteString' tid, "features", "sso"] -putSSOEnabledInternal :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyReq -> TeamId -> Galley.SSOStatus -> m () +putSSOEnabledInternal :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyReq -> TeamId -> TeamFeatureStatus -> m () putSSOEnabledInternal gly tid enabled = do void . put $ gly . paths ["i", "teams", toByteString' tid, "features", "sso"] - . json (Galley.SSOTeamConfig enabled) + . json enabled . expect2xx -- | NB: this does create an SSO UserRef on brig, but not on spar. this is inconsistent, but the diff --git a/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal b/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal index 65e044d9a86..b4724aa502b 100644 --- a/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal +++ b/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: b23ff3a5117d9703a8b229f72618083015c92bf83b6a79de67c339b275def085 +-- hash: 36ac5bc85d9aa68e450fc0d522c4e6431d4f950e2b2f4c8176ee896a1997962a name: migrate-sso-feature-flag version: 1.0.0 @@ -47,4 +47,5 @@ executable migrate-sso-feature-flag , types-common , unliftio , uuid + , wire-api default-language: Haskell2010 diff --git a/tools/db/migrate-sso-feature-flag/package.yaml b/tools/db/migrate-sso-feature-flag/package.yaml index 309940fa73a..509b4289e73 100644 --- a/tools/db/migrate-sso-feature-flag/package.yaml +++ b/tools/db/migrate-sso-feature-flag/package.yaml @@ -36,6 +36,7 @@ dependencies: - types-common - unliftio - uuid +- wire-api executables: migrate-sso-feature-flag: main: Main.hs diff --git a/tools/db/migrate-sso-feature-flag/src/Work.hs b/tools/db/migrate-sso-feature-flag/src/Work.hs index 054bd60bc74..82351fa8b42 100644 --- a/tools/db/migrate-sso-feature-flag/src/Work.hs +++ b/tools/db/migrate-sso-feature-flag/src/Work.hs @@ -32,11 +32,11 @@ import qualified Data.Conduit.List as C import Data.Id import Data.Misc import Galley.Data.Instances () -import Galley.Types.Teams.SSO import Imports import System.Logger (Logger) import qualified System.Logger as Log import UnliftIO.Async (pooledMapConcurrentlyN) +import Wire.API.Team.Feature deriving instance Cql Name @@ -63,10 +63,10 @@ getSsoTeams = paginateC cql (paramsP Quorum () pageSize) x5 cql = "select team from idp" writeSsoFlags :: [TeamId] -> Client () -writeSsoFlags = mapM_ (`setSSOTeamConfig` (SSOTeamConfig SSOEnabled)) +writeSsoFlags = mapM_ (`setSSOTeamConfig` TeamFeatureEnabled) where - setSSOTeamConfig :: MonadClient m => TeamId -> SSOTeamConfig -> m () - setSSOTeamConfig tid SSOTeamConfig {ssoTeamConfigStatus} = do + setSSOTeamConfig :: MonadClient m => TeamId -> TeamFeatureStatus -> m () + setSSOTeamConfig tid ssoTeamConfigStatus = do retry x5 $ write updateSSOTeamConfig (params Quorum (ssoTeamConfigStatus, tid)) - updateSSOTeamConfig :: PrepQuery W (SSOStatus, TeamId) () + updateSSOTeamConfig :: PrepQuery W (TeamFeatureStatus, TeamId) () updateSSOTeamConfig = "update team_features set sso_status = ? where team_id = ?" diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 9408ed44d9a..9063ee55cac 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -65,7 +65,6 @@ import Bilge hiding (head, options, requestId) import Bilge.RPC import Brig.Types import Brig.Types.Intra -import Brig.Types.Team.LegalHold hiding (teamId) import Brig.Types.User.Auth import Control.Error import Control.Lens ((^.), view) @@ -86,7 +85,6 @@ import Data.Text.Lazy (pack) import Galley.Types import Galley.Types.Teams import Galley.Types.Teams.Intra -import Galley.Types.Teams.SSO import Galley.Types.Teams.SearchVisibility import Gundeck.Types import Imports @@ -98,6 +96,7 @@ import Stern.Types import System.Logger.Class hiding ((.=), Error, name) import qualified System.Logger.Class as Log import UnliftIO.Exception hiding (Handler) +import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus (..)) ------------------------------------------------------------------------------- @@ -437,14 +436,14 @@ getLegalholdStatus tid = do "galley" gly ( method GET - . paths ["/i/teams", toByteString' tid, "features", "legalhold"] + . paths ["/i/teams", toByteString' tid, "features", toByteString' TeamFeatureLegalHold] . expect2xx ) where fromResponseBody :: Response (Maybe LByteString) -> Handler SetLegalHoldStatus fromResponseBody resp = case responseJsonEither resp of - Right (LegalHoldTeamConfig LegalHoldDisabled) -> pure SetLegalHoldDisabled - Right (LegalHoldTeamConfig LegalHoldEnabled) -> pure SetLegalHoldEnabled + Right TeamFeatureDisabled -> pure SetLegalHoldDisabled + Right TeamFeatureEnabled -> pure SetLegalHoldEnabled Left errmsg -> throwE (Error status502 "bad-upstream" ("bad response; error message: " <> pack errmsg)) setLegalholdStatus :: TeamId -> SetLegalHoldStatus -> Handler () @@ -465,8 +464,8 @@ setLegalholdStatus tid status = do 204 -> pure () _ -> throwE $ responseJsonUnsafe resp where - toRequestBody SetLegalHoldDisabled = LegalHoldTeamConfig LegalHoldDisabled - toRequestBody SetLegalHoldEnabled = LegalHoldTeamConfig LegalHoldEnabled + toRequestBody SetLegalHoldDisabled = TeamFeatureDisabled + toRequestBody SetLegalHoldEnabled = TeamFeatureEnabled getSSOStatus :: TeamId -> Handler SetSSOStatus getSSOStatus tid = do @@ -477,14 +476,14 @@ getSSOStatus tid = do "galley" gly ( method GET - . paths ["/i/teams", toByteString' tid, "features", "sso"] + . paths ["/i/teams", toByteString' tid, "features", toByteString' TeamFeatureSSO] . expect2xx ) where fromResponseBody :: Response (Maybe LByteString) -> Handler SetSSOStatus fromResponseBody resp = case responseJsonEither resp of - Right (SSOTeamConfig SSOEnabled) -> pure SetSSOEnabled - Right (SSOTeamConfig SSODisabled) -> pure SetSSODisabled + Right TeamFeatureEnabled -> pure SetSSOEnabled + Right TeamFeatureDisabled -> pure SetSSODisabled Left errmsg -> throwE (Error status502 "bad-upstream" ("bad response; error message: " <> pack errmsg)) setSSOStatus :: TeamId -> SetSSOStatus -> Handler () @@ -505,8 +504,8 @@ setSSOStatus tid status = do 204 -> pure () _ -> throwE $ responseJsonUnsafe resp where - toRequestBody SetSSODisabled = SSOTeamConfig SSODisabled - toRequestBody SetSSOEnabled = SSOTeamConfig SSOEnabled + toRequestBody SetSSODisabled = TeamFeatureDisabled + toRequestBody SetSSOEnabled = TeamFeatureEnabled getTeamSearchVisibilityAvailable :: TeamId -> Handler SetTeamSearchVisibilityAvailable getTeamSearchVisibilityAvailable tid = do @@ -517,14 +516,14 @@ getTeamSearchVisibilityAvailable tid = do "galley" gly ( method GET - . paths ["/i/teams", toByteString' tid, "features", "search-visibility"] + . paths ["/i/teams", toByteString' tid, "features", toByteString' TeamFeatureSearchVisibility] . expect2xx ) where fromResponseBody :: Response (Maybe LByteString) -> Handler SetTeamSearchVisibilityAvailable fromResponseBody resp = case responseJsonEither resp of - Right (TeamSearchVisibilityAvailableView TeamSearchVisibilityEnabled) -> pure SetTeamSearchVisibilityEnabled - Right (TeamSearchVisibilityAvailableView TeamSearchVisibilityDisabled) -> pure SetTeamSearchVisibilityDisabled + Right TeamFeatureEnabled -> pure SetTeamSearchVisibilityEnabled + Right TeamFeatureDisabled -> pure SetTeamSearchVisibilityDisabled Left errmsg -> throwE (Error status502 "bad-upstream" ("bad response; error message: " <> pack errmsg)) setTeamSearchVisibilityAvailable :: TeamId -> SetTeamSearchVisibilityAvailable -> Handler () @@ -545,8 +544,8 @@ setTeamSearchVisibilityAvailable tid status = do 204 -> pure () _ -> throwE $ responseJsonUnsafe resp where - toRequestBody SetTeamSearchVisibilityDisabled = TeamSearchVisibilityAvailableView TeamSearchVisibilityDisabled - toRequestBody SetTeamSearchVisibilityEnabled = TeamSearchVisibilityAvailableView TeamSearchVisibilityEnabled + toRequestBody SetTeamSearchVisibilityDisabled = TeamFeatureDisabled + toRequestBody SetTeamSearchVisibilityEnabled = TeamFeatureEnabled getSearchVisibility :: TeamId -> Handler TeamSearchVisibilityView getSearchVisibility tid = do From b5da0e231972440f51eae9da1924ba22d8eb686e Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Wed, 3 Jun 2020 13:56:43 +0200 Subject: [PATCH 02/11] Update cassandra-schema.cql (#1127) We don't have an automated check for this yet, so it was forgotten. --- docs/reference/cassandra-schema.cql | 61 +++++++++++++++++++++++++---- 1 file changed, 53 insertions(+), 8 deletions(-) diff --git a/docs/reference/cassandra-schema.cql b/docs/reference/cassandra-schema.cql index bf8cb76b956..5bbcdd886c5 100644 --- a/docs/reference/cassandra-schema.cql +++ b/docs/reference/cassandra-schema.cql @@ -13,6 +13,48 @@ CREATE TYPE galley_test.pubkey ( pem blob ); +CREATE TABLE galley_test.team_notifications ( + team uuid, + id timeuuid, + payload blob, + PRIMARY KEY (team, id) +) WITH CLUSTERING ORDER BY (id ASC) + AND bloom_filter_fp_chance = 0.1 + AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} + AND comment = '' + AND compaction = {'class': 'org.apache.cassandra.db.compaction.LeveledCompactionStrategy'} + AND compression = {'chunk_length_in_kb': '64', 'class': 'org.apache.cassandra.io.compress.LZ4Compressor'} + AND crc_check_chance = 1.0 + AND dclocal_read_repair_chance = 0.1 + AND default_time_to_live = 0 + AND gc_grace_seconds = 864000 + AND max_index_interval = 2048 + AND memtable_flush_period_in_ms = 0 + AND min_index_interval = 128 + AND read_repair_chance = 0.0 + AND speculative_retry = '99PERCENTILE'; + +CREATE TABLE galley_test.team_conv ( + team uuid, + conv uuid, + managed boolean, + PRIMARY KEY (team, conv) +) WITH CLUSTERING ORDER BY (conv ASC) + AND bloom_filter_fp_chance = 0.1 + AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} + AND comment = '' + AND compaction = {'class': 'org.apache.cassandra.db.compaction.LeveledCompactionStrategy'} + AND compression = {'chunk_length_in_kb': '64', 'class': 'org.apache.cassandra.io.compress.LZ4Compressor'} + AND crc_check_chance = 1.0 + AND dclocal_read_repair_chance = 0.1 + AND default_time_to_live = 0 + AND gc_grace_seconds = 864000 + AND max_index_interval = 2048 + AND memtable_flush_period_in_ms = 0 + AND min_index_interval = 128 + AND read_repair_chance = 0.0 + AND speculative_retry = '99PERCENTILE'; + CREATE TABLE galley_test.service ( provider uuid, id uuid, @@ -37,16 +79,17 @@ CREATE TABLE galley_test.service ( AND read_repair_chance = 0.0 AND speculative_retry = '99PERCENTILE'; -CREATE TABLE galley_test.team_conv ( - team uuid, - conv uuid, - managed boolean, - PRIMARY KEY (team, conv) -) WITH CLUSTERING ORDER BY (conv ASC) - AND bloom_filter_fp_chance = 0.1 +CREATE TABLE galley_test.data_migration ( + id int, + version int, + date timestamp, + descr text, + PRIMARY KEY (id, version) +) WITH CLUSTERING ORDER BY (version ASC) + AND bloom_filter_fp_chance = 0.01 AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} AND comment = '' - AND compaction = {'class': 'org.apache.cassandra.db.compaction.LeveledCompactionStrategy'} + AND compaction = {'class': 'org.apache.cassandra.db.compaction.SizeTieredCompactionStrategy', 'max_threshold': '32', 'min_threshold': '4'} AND compression = {'chunk_length_in_kb': '64', 'class': 'org.apache.cassandra.io.compress.LZ4Compressor'} AND crc_check_chance = 1.0 AND dclocal_read_repair_chance = 0.1 @@ -61,6 +104,7 @@ CREATE TABLE galley_test.team_conv ( CREATE TABLE galley_test.team_features ( team_id uuid PRIMARY KEY, legalhold_status int, + search_visibility_status int, sso_status int ) WITH bloom_filter_fp_chance = 0.1 AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} @@ -242,6 +286,7 @@ CREATE TABLE galley_test.team ( icon text, icon_key text, name text, + search_visibility int, status int ) WITH bloom_filter_fp_chance = 0.1 AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} From ee303cc6ca5185990fb8fddae1aff01726f9bcff Mon Sep 17 00:00:00 2001 From: fisx Date: Wed, 3 Jun 2020 15:32:41 +0200 Subject: [PATCH 03/11] Cleanup export list; swagger names. (#1126) --- libs/wire-api/src/Wire/API/Team/Feature.hs | 16 +++++++++------- services/galley/src/Galley/API/Public.hs | 2 +- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index f781a42a170..36999e35bc9 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -20,10 +20,12 @@ module Wire.API.Team.Feature ( TeamFeatureName (..), - typeFeatureName, TeamFeatureStatus (..), + + -- * Swagger modelTeamFeatureStatus, - typeFeatureStatus, + typeTeamFeatureName, + typeTeamFeatureStatus, ) where @@ -57,8 +59,8 @@ instance ToByteString TeamFeatureName where builder TeamFeatureSSO = "sso" builder TeamFeatureSearchVisibility = "search-visibility" -typeFeatureName :: Doc.DataType -typeFeatureName = +typeTeamFeatureName :: Doc.DataType +typeTeamFeatureName = Doc.string $ Doc.enum [ "legalhold", @@ -73,10 +75,10 @@ data TeamFeatureStatus = TeamFeatureEnabled | TeamFeatureDisabled modelTeamFeatureStatus :: Doc.Model modelTeamFeatureStatus = Doc.defineModel "TeamFeatureStatus" $ do Doc.description "Configuration of a feature for a team" - Doc.property "status" typeFeatureStatus $ Doc.description "status" + Doc.property "status" typeTeamFeatureStatus $ Doc.description "status" -typeFeatureStatus :: Doc.DataType -typeFeatureStatus = +typeTeamFeatureStatus :: Doc.DataType +typeTeamFeatureStatus = Doc.string $ Doc.enum [ "enabled", diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 85ac9788b1c..791a5866f04 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -461,7 +461,7 @@ sitemap = do summary "Shows whether a feature is enabled for a team" parameter Path "tid" bytes' $ description "Team ID" - parameter Path "feature" Public.typeFeatureName $ + parameter Path "feature" Public.typeTeamFeatureName $ description "Feature name" returns (ref Public.modelTeamFeatureStatus) response 200 "Team feature status" end From 9a11c498df09749f6390a44602bd7e03215b6859 Mon Sep 17 00:00:00 2001 From: fisx Date: Thu, 4 Jun 2020 14:39:40 +0200 Subject: [PATCH 04/11] Validate saml emails (#1113) * Email validation for SAML auth. * Refactor; extend internal update-email end-point. * Roundtrip tests for FromByteString, ToByteString. --- libs/galley-types/src/Galley/Types/Teams.hs | 1 + libs/wire-api/package.yaml | 1 + .../src/Wire/API/Provider/Service/Tag.hs | 10 +- libs/wire-api/src/Wire/API/Team/Feature.hs | 14 ++- libs/wire-api/test/unit/Main.hs | 6 +- .../API/{Roundtrip.hs => Roundtrip/Aeson.hs} | 2 +- .../Test/Wire/API/Roundtrip/ByteString.hs | 92 ++++++++++++++++++ libs/wire-api/wire-api.cabal | 6 +- services/brig/src/Brig/API/Internal.hs | 24 +++-- services/brig/src/Brig/API/Public.hs | 23 +---- services/brig/src/Brig/API/Types.hs | 7 ++ services/brig/src/Brig/API/User.hs | 22 +++++ services/galley/galley.cabal | 4 +- services/galley/schema/src/Main.hs | 4 +- .../src/V42_TeamFeatureValidateSamlEmails.hs | 29 ++++++ services/galley/src/Galley/API/Teams.hs | 12 +++ services/galley/src/Galley/Data.hs | 2 +- services/galley/src/Galley/Data/Queries.hs | 8 ++ .../src/Galley/Data/ValidateSAMLEmails.hs | 42 ++++++++ services/spar/src/Spar/App.hs | 21 +++- services/spar/src/Spar/Error.hs | 1 + services/spar/src/Spar/Intra/Brig.hs | 29 +++++- services/spar/src/Spar/Intra/Galley.hs | 5 + services/spar/src/Spar/Scim/User.hs | 4 +- .../Test/Spar/Scim/UserSpec.hs | 95 ++++++++++++++++++- services/spar/test-integration/Util/Scim.hs | 13 +++ 26 files changed, 424 insertions(+), 53 deletions(-) rename libs/wire-api/test/unit/Test/Wire/API/{Roundtrip.hs => Roundtrip/Aeson.hs} (99%) create mode 100644 libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs create mode 100644 services/galley/schema/src/V42_TeamFeatureValidateSamlEmails.hs create mode 100644 services/galley/src/Galley/Data/ValidateSAMLEmails.hs diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index ba075a2fc15..cbd0a603b33 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -335,6 +335,7 @@ roleHiddenPermissions role = HiddenPermissions p p [ ViewTeamFeature TeamFeatureLegalHold, ViewTeamFeature TeamFeatureSSO, ViewTeamFeature TeamFeatureSearchVisibility, + ViewTeamFeature TeamFeatureValidateSAMLEmails, ViewLegalHoldUserSettings, ViewTeamSearchVisibility ] diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index d7ae54d1ae8..2ffe8e699f5 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -61,6 +61,7 @@ tests: - -with-rtsopts=-N dependencies: - base + - bytestring-conversion - wire-api - aeson-qq - lens diff --git a/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs b/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs index 951bc9b1c3a..5363d8678d0 100644 --- a/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs +++ b/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs @@ -49,9 +49,9 @@ import qualified Data.Range as Range import Data.Range (LTE, Range, fromRange) import qualified Data.Set as Set import qualified Data.Text.Encoding as Text -import GHC.TypeLits (Nat) +import GHC.TypeLits (KnownNat, Nat) import Imports -import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) +import Wire.API.Arbitrary (Arbitrary (..), GenericUniform (..)) -------------------------------------------------------------------------------- -- ServiceTag @@ -180,6 +180,9 @@ newtype QueryAnyTags (m :: Nat) (n :: Nat) = QueryAnyTags {queryAnyTagsRange :: Range m n (Set (QueryAllTags m n))} deriving stock (Eq, Show, Ord) +instance (KnownNat m, KnownNat n, LTE m n) => Arbitrary (QueryAnyTags m n) where + arbitrary = QueryAnyTags <$> arbitrary + queryAnyTags :: LTE m n => MatchAny -> Maybe (QueryAnyTags m n) queryAnyTags t = do x <- mapM queryAllTags (Set.toList (matchAnySet t)) @@ -208,6 +211,9 @@ newtype QueryAllTags (m :: Nat) (n :: Nat) = QueryAllTags {queryAllTagsRange :: Range m n (Set ServiceTag)} deriving stock (Eq, Show, Ord) +instance (KnownNat m, KnownNat n, LTE m n) => Arbitrary (QueryAllTags m n) where + arbitrary = QueryAllTags <$> arbitrary + queryAllTags :: LTE m n => MatchAll -> Maybe (QueryAllTags m n) queryAllTags = fmap QueryAllTags . Range.checked . matchAllSet diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 36999e35bc9..1f5296df863 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -31,7 +31,8 @@ where import Data.Aeson import qualified Data.Attoparsec.ByteString as Parser -import Data.ByteString.Conversion (FromByteString (..), ToByteString (..)) +import Data.ByteString.Conversion (FromByteString (..), ToByteString (..), toByteString') +import Data.String.Conversions (cs) import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -42,6 +43,7 @@ data TeamFeatureName = TeamFeatureLegalHold | TeamFeatureSSO | TeamFeatureSearchVisibility + | TeamFeatureValidateSAMLEmails deriving stock (Eq, Show, Ord, Generic, Enum, Bounded) deriving (Arbitrary) via (GenericUniform TeamFeatureName) @@ -52,21 +54,17 @@ instance FromByteString TeamFeatureName where Right "legalhold" -> pure TeamFeatureLegalHold Right "sso" -> pure TeamFeatureSSO Right "search-visibility" -> pure TeamFeatureSearchVisibility + Right "validate-saml-emails" -> pure TeamFeatureValidateSAMLEmails Right t -> fail $ "Invalid TeamFeatureName: " <> T.unpack t instance ToByteString TeamFeatureName where builder TeamFeatureLegalHold = "legalhold" builder TeamFeatureSSO = "sso" builder TeamFeatureSearchVisibility = "search-visibility" + builder TeamFeatureValidateSAMLEmails = "validate-saml-emails" typeTeamFeatureName :: Doc.DataType -typeTeamFeatureName = - Doc.string $ - Doc.enum - [ "legalhold", - "sso", - "search-visibility" - ] +typeTeamFeatureName = Doc.string . Doc.enum $ cs . toByteString' <$> [(minBound :: TeamFeatureName) ..] data TeamFeatureStatus = TeamFeatureEnabled | TeamFeatureDisabled deriving stock (Eq, Show, Generic) diff --git a/libs/wire-api/test/unit/Main.hs b/libs/wire-api/test/unit/Main.hs index 75a823c143d..53893a18af8 100644 --- a/libs/wire-api/test/unit/Main.hs +++ b/libs/wire-api/test/unit/Main.hs @@ -23,7 +23,8 @@ where import Imports import Test.Tasty import qualified Test.Wire.API.Call.TURN as Call.TURN -import qualified Test.Wire.API.Roundtrip as Roundtrip +import qualified Test.Wire.API.Roundtrip.Aeson as Roundtrip.Aeson +import qualified Test.Wire.API.Roundtrip.ByteString as Roundtrip.ByteString import qualified Test.Wire.API.Team.Member as Team.Member import qualified Test.Wire.API.User as User import qualified Test.Wire.API.User.RichInfo as User.RichInfo @@ -37,5 +38,6 @@ main = Team.Member.tests, User.tests, User.RichInfo.tests, - Roundtrip.tests + Roundtrip.Aeson.tests, + Roundtrip.ByteString.tests ] diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs similarity index 99% rename from libs/wire-api/test/unit/Test/Wire/API/Roundtrip.hs rename to libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index 83eb21106a5..84dcb832059 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Wire.API.Roundtrip (tests) where +module Test.Wire.API.Roundtrip.Aeson (tests) where import Data.Aeson (FromJSON, ToJSON, parseJSON, toJSON) import Data.Aeson.Types (parseEither) diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs new file mode 100644 index 00000000000..19e211dbc7c --- /dev/null +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs @@ -0,0 +1,92 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Roundtrip.ByteString (tests) where + +import Data.ByteString.Conversion +import Imports +import qualified Test.Tasty as T +import Test.Tasty.QuickCheck ((===), Arbitrary, counterexample, testProperty) +import Type.Reflection (typeRep) +import qualified Wire.API.Arbitrary as Arbitrary () +import qualified Wire.API.Asset.V3 as Asset.V3 +import qualified Wire.API.Asset.V3.Resumable as Asset.V3.Resumable +import qualified Wire.API.Call.TURN as Call.TURN +import qualified Wire.API.Conversation.Code as Conversation.Code +import qualified Wire.API.Conversation.Role as Conversation.Role +import qualified Wire.API.Properties as Properties +import qualified Wire.API.Provider as Provider +import qualified Wire.API.Provider.Service as Provider.Service +import qualified Wire.API.Provider.Service.Tag as Provider.Service.Tag +import qualified Wire.API.Push.V2.Token as Push.V2.Token +import qualified Wire.API.Team.Feature as Team.Feature +import qualified Wire.API.User as User +import qualified Wire.API.User.Activation as User.Activation +import qualified Wire.API.User.Auth as User.Auth +import qualified Wire.API.User.Identity as User.Identity +import qualified Wire.API.User.Password as User.Password +import qualified Wire.API.User.Profile as User.Profile + +tests :: T.TestTree +tests = + T.localOption (T.Timeout (60 * 1000000) "60s") . T.testGroup "JSON roundtrip tests" $ + [ testRoundTrip @Asset.V3.AssetKey, + testRoundTrip @Asset.V3.AssetRetention, + testRoundTrip @Asset.V3.AssetToken, + testRoundTrip @Asset.V3.Resumable.ChunkSize, + testRoundTrip @Asset.V3.Resumable.Offset, + testRoundTrip @Asset.V3.Resumable.TotalSize, + testRoundTrip @Call.TURN.Scheme, + testRoundTrip @Call.TURN.Transport, + testRoundTrip @Call.TURN.TurnHost, + testRoundTrip @Call.TURN.TurnURI, + testRoundTrip @Conversation.Code.Key, + testRoundTrip @Conversation.Code.Value, + testRoundTrip @Conversation.Role.RoleName, + testRoundTrip @Properties.PropertyKey, + testRoundTrip @Provider.HttpsUrl, + testRoundTrip @Provider.Service.ServiceKeyPEM, + testRoundTrip @Provider.Service.ServiceToken, + testRoundTrip @Provider.Service.Tag.ServiceTag, + testRoundTrip @Push.V2.Token.Token, + testRoundTrip @Team.Feature.TeamFeatureName, + testRoundTrip @User.Activation.ActivationCode, + testRoundTrip @User.Activation.ActivationKey, + testRoundTrip @User.Auth.CookieLabel, + testRoundTrip @User.Identity.Email, + testRoundTrip @User.Identity.Phone, + testRoundTrip @User.InvitationCode, + testRoundTrip @User.Password.PasswordResetCode, + testRoundTrip @User.Password.PasswordResetKey, + testRoundTrip @User.Profile.Name, + testRoundTrip @(Provider.Service.Tag.QueryAllTags 3 5), + testRoundTrip @(Provider.Service.Tag.QueryAnyTags 3 5) + -- FUTUREWORK: + -- testCase "Call.TURN.TurnUsername (doesn't have FromByteString)" ... + -- testCase "User.Activation.ActivationTarget (doesn't have FromByteString)" ... + ] + +testRoundTrip :: + forall a. + (Arbitrary a, Typeable a, ToByteString a, FromByteString a, Eq a, Show a) => + T.TestTree +testRoundTrip = testProperty msg trip + where + msg = show (typeRep @a) + trip (v :: a) = + counterexample (show $ toByteString' v) $ + Just v === (fromByteString . toByteString') v diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 239395af74c..314b0f24326 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: e86154ca496caaeb488bd2810630f53757421d25b05d746b86024ee7224c49ff +-- hash: b89d6631f18653ec03e69a4a98f3c9f791e886de9a485772e9bff78fbf8a1fc4 name: wire-api version: 0.1.0 @@ -121,7 +121,8 @@ test-suite wire-api-tests main-is: Main.hs other-modules: Test.Wire.API.Call.TURN - Test.Wire.API.Roundtrip + Test.Wire.API.Roundtrip.Aeson + Test.Wire.API.Roundtrip.ByteString Test.Wire.API.Team.Member Test.Wire.API.User Test.Wire.API.User.RichInfo @@ -134,6 +135,7 @@ test-suite wire-api-tests aeson >=0.6 , aeson-qq , base + , bytestring-conversion , containers >=0.5 , imports , lens diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 96096b58a07..6c6cab0a1a9 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -86,8 +86,14 @@ sitemap = do post "/i/users" (continue createUserNoVerifyH) $ accept "application" "json" .&. jsonRequest @NewUser - put "/i/self/email" (continue changeSelfEmailNoSendH) $ + + -- internal email activation (used in tests and in spar for validating emails obtains as + -- SAML user identifiers). if the validate query parameter is false or missing, only set + -- the activation timeout, but do not send an email, and do not do anything about activating + -- the email. + put "/i/self/email" (continue changeSelfEmailMaybeSendH) $ zauthUserId + .&. def False (query "validate") .&. jsonRequest @EmailUpdate -- This endpoint will lead to the following events being sent: @@ -288,19 +294,19 @@ deleteUserNoVerify uid = do void $ lift (API.lookupAccount uid) >>= ifNothing userNotFound lift $ API.deleteUserNoVerify uid -changeSelfEmailNoSendH :: UserId ::: JsonRequest EmailUpdate -> Handler Response -changeSelfEmailNoSendH (u ::: req) = do +changeSelfEmailMaybeSendH :: UserId ::: Bool ::: JsonRequest EmailUpdate -> Handler Response +changeSelfEmailMaybeSendH (u ::: validate ::: req) = do email <- euEmail <$> parseJsonBody req - changeSelfEmailNoSend u email >>= \case + changeSelfEmailMaybeSend u (if validate then ActuallySendEmail else DoNotSendEmail) email >>= \case ChangeEmailResponseIdempotent -> pure (setStatus status204 empty) ChangeEmailResponseNeedsActivation -> pure (setStatus status202 empty) -data ChangeEmailResponse - = ChangeEmailResponseIdempotent - | ChangeEmailResponseNeedsActivation +data MaybeSendEmail = ActuallySendEmail | DoNotSendEmail -changeSelfEmailNoSend :: UserId -> Email -> Handler ChangeEmailResponse -changeSelfEmailNoSend u email = do +changeSelfEmailMaybeSend :: UserId -> MaybeSendEmail -> Email -> Handler ChangeEmailResponse +changeSelfEmailMaybeSend u ActuallySendEmail email = do + API.changeSelfEmail u email +changeSelfEmailMaybeSend u DoNotSendEmail email = do API.changeEmail u email !>> changeEmailError >>= \case ChangeEmailIdempotent -> pure ChangeEmailResponseIdempotent ChangeEmailNeedsActivation _ -> pure ChangeEmailResponseNeedsActivation diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 5228c21c702..c70e569d4d2 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -1242,31 +1242,10 @@ customerExtensionCheckBlockedDomains email = do changeSelfEmailH :: UserId ::: ConnId ::: JsonRequest Public.EmailUpdate -> Handler Response changeSelfEmailH (u ::: _ ::: req) = do email <- Public.euEmail <$> parseJsonBody req - changeSelfEmail u email >>= \case + API.changeSelfEmail u email >>= \case ChangeEmailResponseIdempotent -> pure (setStatus status204 empty) ChangeEmailResponseNeedsActivation -> pure (setStatus status202 empty) -data ChangeEmailResponse - = ChangeEmailResponseIdempotent - | ChangeEmailResponseNeedsActivation - -changeSelfEmail :: UserId -> Public.Email -> Handler ChangeEmailResponse -changeSelfEmail u email = do - API.changeEmail u email !>> changeEmailError >>= \case - ChangeEmailIdempotent -> - pure ChangeEmailResponseIdempotent - ChangeEmailNeedsActivation (usr, adata, en) -> do - lift $ sendOutEmail usr adata en - pure ChangeEmailResponseNeedsActivation - where - sendOutEmail usr adata en = do - sendActivationMail - en - (Public.userDisplayName usr) - (activationKey adata, activationCode adata) - (Just (Public.userLocale usr)) - (Public.userIdentity usr) - createConnectionH :: JSON ::: UserId ::: ConnId ::: JsonRequest Public.ConnectionRequest -> Handler Response createConnectionH (_ ::: self ::: conn ::: req) = do cr <- parseJsonBody req diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index ef381afbebc..5bfa0301f91 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -73,12 +73,19 @@ data ActivationResult | -- | The key/code was valid but already recently activated. ActivationPass +-- | Outcome of the invariants check in 'Brig.API.User.changeEmail'. data ChangeEmailResult = -- | The request was successful, user needs to verify the new email address ChangeEmailNeedsActivation !(User, Activation, Email) | -- | The user asked to change the email address to the one already owned ChangeEmailIdempotent +-- | Typed response of the @put /self/email@ end-point (returned in +-- 'Brig.API.User.changeSelfEmail'. +data ChangeEmailResponse + = ChangeEmailResponseIdempotent + | ChangeEmailResponseNeedsActivation + ------------------------------------------------------------------------------- -- Failures diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index d28f0e0d919..98c1cf7cd1a 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -23,6 +23,7 @@ module Brig.API.User createUser, Brig.API.User.updateUser, changeLocale, + changeSelfEmail, changeEmail, changePhone, changeHandle, @@ -81,6 +82,7 @@ module Brig.API.User ) where +import qualified Brig.API.Error as Error import Brig.API.Types import Brig.App import qualified Brig.Code as Code @@ -377,6 +379,26 @@ checkHandles check num = reverse <$> collectFree [] check num ------------------------------------------------------------------------------- -- Change Email +-- | Call 'changeEmail' and process result: if email changes to itself, succeed, if not, send +-- validation email. +changeSelfEmail :: UserId -> Email -> ExceptT Error.Error AppIO ChangeEmailResponse +changeSelfEmail u email = do + changeEmail u email !>> Error.changeEmailError >>= \case + ChangeEmailIdempotent -> + pure ChangeEmailResponseIdempotent + ChangeEmailNeedsActivation (usr, adata, en) -> do + lift $ sendOutEmail usr adata en + pure ChangeEmailResponseNeedsActivation + where + sendOutEmail usr adata en = do + sendActivationMail + en + (userDisplayName usr) + (activationKey adata, activationCode adata) + (Just (userLocale usr)) + (userIdentity usr) + +-- | Prepare changing the email (checking a number of invariants). changeEmail :: UserId -> Email -> ExceptT ChangeEmailError AppIO ChangeEmailResult changeEmail u email = do em <- diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index e20318c4d21..d37aa096ee3 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 81940ddc6234314b03bc1213404219c834f06eba109f5a4678745a913d5364c0 +-- hash: ea8a2731dc5ada81ea4a4bfed991318a463ea1bdc8af1b5ae12836565ce2cb19 name: galley version: 0.83.0 @@ -51,6 +51,7 @@ library Galley.Data.SSO Galley.Data.TeamNotifications Galley.Data.Types + Galley.Data.ValidateSAMLEmails Galley.External Galley.External.LegalHoldService Galley.Intra.Client @@ -334,6 +335,7 @@ executable galley-schema V39 V40_CreateTableDataMigration V41_TeamNotificationQueue + V42_TeamFeatureValidateSamlEmails Paths_galley hs-source-dirs: schema/src diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index 7587793f2d5..a1c5e669b10 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -44,6 +44,7 @@ import qualified V38_CreateTableBillingTeamMember import qualified V39 import qualified V40_CreateTableDataMigration import qualified V41_TeamNotificationQueue +import qualified V42_TeamFeatureValidateSamlEmails main :: IO () main = do @@ -73,7 +74,8 @@ main = do V38_CreateTableBillingTeamMember.migration, V39.migration, V40_CreateTableDataMigration.migration, - V41_TeamNotificationQueue.migration + V41_TeamNotificationQueue.migration, + V42_TeamFeatureValidateSamlEmails.migration -- When adding migrations here, don't forget to update -- 'schemaVersion' in Galley.Data ] diff --git a/services/galley/schema/src/V42_TeamFeatureValidateSamlEmails.hs b/services/galley/schema/src/V42_TeamFeatureValidateSamlEmails.hs new file mode 100644 index 00000000000..76ff171d8d3 --- /dev/null +++ b/services/galley/schema/src/V42_TeamFeatureValidateSamlEmails.hs @@ -0,0 +1,29 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module V42_TeamFeatureValidateSamlEmails + ( migration, + ) +where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = Migration 42 "Add feature flag for validation of saml emails" $ do + schema' [r| ALTER TABLE team_features ADD validate_saml_emails int; |] diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 0a221f4cb60..73eae30ec23 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -82,6 +82,7 @@ import qualified Galley.Data.SSO as SSOData import qualified Galley.Data.SearchVisibility as SearchVisibilityData import Galley.Data.Services (BotMember) import qualified Galley.Data.Types as Data +import qualified Galley.Data.ValidateSAMLEmails as ValidateSAMLEmailsData import qualified Galley.External as External import qualified Galley.Intra.Journal as Journal import Galley.Intra.Push @@ -872,6 +873,7 @@ getFeatureStatusInternal tid featureName = do Public.TeamFeatureLegalHold -> getLegalholdStatusInternal tid Public.TeamFeatureSSO -> getSSOStatusInternal tid Public.TeamFeatureSearchVisibility -> getTeamSearchVisibilityAvailableInternal tid + Public.TeamFeatureValidateSAMLEmails -> getValidateSAMLEmailsInternal tid -- | Enable or disable feature flag for a team. To be called only from authorized personnel -- (e.g., from a backoffice tool) @@ -885,6 +887,7 @@ setFeatureStatusInternal tid featureName status = do Public.TeamFeatureLegalHold -> setLegalholdStatusInternal tid status Public.TeamFeatureSSO -> setSSOStatusInternal tid status Public.TeamFeatureSearchVisibility -> setTeamSearchVisibilityAvailableInternal tid status + Public.TeamFeatureValidateSAMLEmails -> setValidateSAMLEmailsInternal tid status getSSOStatusInternal :: TeamId -> Galley Public.TeamFeatureStatus getSSOStatusInternal tid = do @@ -951,6 +954,15 @@ setTeamSearchVisibilityAvailableInternal tid isenabled = do Public.TeamFeatureEnabled -> pure () -- This allows the option to be set at the team level SearchVisibilityData.setTeamSearchVisibilityAvailable tid isenabled +getValidateSAMLEmailsInternal :: TeamId -> Galley Public.TeamFeatureStatus +getValidateSAMLEmailsInternal = + ValidateSAMLEmailsData.getValidateSAMLEmails >=> \case + Nothing -> throwM teamNotFound + Just s -> pure s + +setValidateSAMLEmailsInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () +setValidateSAMLEmailsInternal = ValidateSAMLEmailsData.setValidateSAMLEmails + -- | Modify and get visibility type for a team (internal, no user permission checks) getSearchVisibilityInternalH :: TeamId ::: JSON -> Galley Response getSearchVisibilityInternalH (tid ::: _) = diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 9ab48638345..6c32b6caa0c 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -172,7 +172,7 @@ resultSetResult :: ResultSet a -> [a] resultSetResult = result . page schemaVersion :: Int32 -schemaVersion = 41 +schemaVersion = 42 -- | Insert a conversation code insertCode :: MonadClient m => Code -> m () diff --git a/services/galley/src/Galley/Data/Queries.hs b/services/galley/src/Galley/Data/Queries.hs index 530f5dd8293..dc097335efb 100644 --- a/services/galley/src/Galley/Data/Queries.hs +++ b/services/galley/src/Galley/Data/Queries.hs @@ -403,6 +403,14 @@ updateSearchVisibility :: PrepQuery W (TeamSearchVisibility, TeamId) () updateSearchVisibility = "update team set search_visibility = ? where team = ?" +selectValidateSAMLEmails :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatus)) +selectValidateSAMLEmails = + "select validate_saml_emails from team_features where team_id = ?" + +updateValidateSAMLEmails :: PrepQuery W (TeamFeatureStatus, TeamId) () +updateValidateSAMLEmails = + "update team_features set validate_saml_emails = ? where team_id = ?" + selectCustomBackend :: PrepQuery R (Identity Domain) (HttpsUrl, HttpsUrl) selectCustomBackend = "select config_json_url, webapp_welcome_url from custom_backend where domain = ?" diff --git a/services/galley/src/Galley/Data/ValidateSAMLEmails.hs b/services/galley/src/Galley/Data/ValidateSAMLEmails.hs new file mode 100644 index 00000000000..c81e0d58a8d --- /dev/null +++ b/services/galley/src/Galley/Data/ValidateSAMLEmails.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ViewPatterns #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Data.ValidateSAMLEmails + ( setValidateSAMLEmails, + getValidateSAMLEmails, + ) +where + +import Cassandra +import Data.Id +import Galley.Data.Instances () +import Galley.Data.Queries +import Imports +import Wire.API.Team.Feature (TeamFeatureStatus (..)) + +getValidateSAMLEmails :: MonadClient m => TeamId -> m (Maybe TeamFeatureStatus) +getValidateSAMLEmails tid = fmap toFeatureStatus <$> do + retry x1 $ query1 selectValidateSAMLEmails (params Quorum (Identity tid)) + where + toFeatureStatus (Identity Nothing) = TeamFeatureDisabled + toFeatureStatus (Identity (Just status)) = status + +setValidateSAMLEmails :: MonadClient m => TeamId -> TeamFeatureStatus -> m () +setValidateSAMLEmails tid featureStatus = do + retry x5 $ write updateValidateSAMLEmails (params Quorum (featureStatus, tid)) diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 4dd168aa7ba..e02789a47af 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -30,6 +30,7 @@ module Spar.App insertUser, autoprovisionSamlUser, autoprovisionSamlUserWithId, + validateEmailIfExists, errorPage, ) where @@ -67,8 +68,10 @@ import Spar.Orphans () import Spar.Types import qualified System.Logger as Log import System.Logger.Class (MonadLogger (log)) +import Text.Email.Parser (domainPart, localPart) import URI.ByteString as URI import Web.Cookie (SetCookie, renderSetCookie) +import qualified Wire.API.User.Identity as WireEmail newtype Spar a = Spar {fromSpar :: ReaderT Env (ExceptT SparError IO) a} deriving (Functor, Applicative, Monad, MonadIO, MonadReader Env, MonadError SparError) @@ -209,12 +212,28 @@ autoprovisionSamlUserWithId buid suid mbName managedBy = do let teamid = idp ^. idpExtraInfo . wiTeam scimtoks <- wrapMonadClient $ Data.getScimTokens teamid if null scimtoks - then createSamlUserWithId buid suid mbName managedBy + then do + createSamlUserWithId buid suid mbName managedBy + validateEmailIfExists buid suid else throwError . SAML.Forbidden $ "bad credentials (note that your team uses SCIM, " <> "which disables saml auto-provisioning)" +-- | If user's 'NameID' is an email address and the team has email validation for SSO enabled, +-- make brig send a validation email to the address the user registered under. If the +-- traditional validation procedure succeeds, the user will have an email address. +validateEmailIfExists :: UserId -> SAML.UserRef -> Spar () +validateEmailIfExists uid (SAML.UserRef _ nameid) = case nameid ^. SAML.nameID of + UNameIDEmail email -> do + Intra.isEmailValidationEnabledUser uid >>= \case + True -> Intra.updateEmail uid (castEmail email) + False -> pure () + _ -> pure () + where + castEmail :: Email -> WireEmail.Email + castEmail (Email adr) = WireEmail.Email (cs $ localPart adr) (cs $ domainPart adr) + -- | Check if 'UserId' is in the team that hosts the idp that owns the 'UserRef'. If so, write the -- 'UserRef' into the 'UserIdentity'. Otherwise, throw an error. bindUser :: UserId -> SAML.UserRef -> Spar UserId diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index 78a8d19399d..f5c8ea6eb79 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -34,6 +34,7 @@ module Spar.Error -- custom servant monad in the 'MakeCustomError' instances. sparToServerError, renderSparError, + waiToServant, ) where diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index a94ffc71437..14daa2d99d3 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -36,12 +36,14 @@ module Spar.Intra.Brig bindBrigUser, deleteBrigUser, createBrigUser, + updateEmail, isTeamUser, getZUsrOwnedTeam, ensureReAuthorised, ssoLogin, parseResponse, MonadSparToBrig (..), + isEmailValidationEnabledUser, ) where @@ -66,7 +68,7 @@ import Imports import Network.HTTP.Types.Method import qualified SAML2.WebSSO as SAML import Spar.Error -import Spar.Intra.Galley as Galley (MonadSparToGalley, assertIsTeamOwner) +import Spar.Intra.Galley as Galley (MonadSparToGalley, assertIsTeamOwner, isEmailValidationEnabledTeam) import Web.Cookie ---------------------------------------------------------------------- @@ -169,6 +171,22 @@ createBrigUser suid (Id buid) teamid mbName managedBy = do | otherwise -> throwSpar . SparBrigError . cs $ "create user failed with status " <> show sCode +updateEmail :: (HasCallStack, MonadSparToBrig m) => UserId -> Email -> m () +updateEmail buid email = do + resp <- + call $ + method PUT + . path "/i/self/email" + . header "Z-User" (toByteString' buid) + . query [("validate", Just "true")] + . json (EmailUpdate email) + case statusCode resp of + 204 -> pure () + 202 -> pure () + -- everything else is an error; if the response body still cannot be parsed as a + -- Wai.Error, it's ok to crash with a 500 here, so we use the unsafe parser. + _ -> throwError . SAML.CustomServant . waiToServant . responseJsonUnsafe $ resp + -- | Get a user; returns 'Nothing' if the user was not found or has been deleted. getBrigUser :: (HasCallStack, MonadSparToBrig m) => UserId -> m (Maybe User) getBrigUser buid = do @@ -437,3 +455,12 @@ ssoLogin buid = do pure Nothing | otherwise -> throwSpar . SparBrigError . cs $ "sso-login failed with status " <> show sCode + +-- | This is more of a brig thing, but we need to get the team for the user first, so it goes +-- here. Perhaps we should merge "Spar.Intra.*" into "Spar.Intra"? +isEmailValidationEnabledUser :: (HasCallStack, MonadSparToGalley m, MonadSparToBrig m) => UserId -> m Bool +isEmailValidationEnabledUser uid = do + user <- getBrigUser uid + case user >>= userTeam of + Nothing -> pure False + Just tid -> isEmailValidationEnabledTeam tid diff --git a/services/spar/src/Spar/Intra/Galley.hs b/services/spar/src/Spar/Intra/Galley.hs index cf21fe42b44..da2942999c1 100644 --- a/services/spar/src/Spar/Intra/Galley.hs +++ b/services/spar/src/Spar/Intra/Galley.hs @@ -87,3 +87,8 @@ assertSSOEnabled tid = do status <- parseResponse resp unless (status == TeamFeatureEnabled) $ throwSpar SparSSODisabled + +isEmailValidationEnabledTeam :: (HasCallStack, MonadSparToGalley m) => TeamId -> m Bool +isEmailValidationEnabledTeam tid = do + resp <- call $ method GET . paths ["i", "teams", toByteString' tid, "features", "validate-saml-emails"] + pure (statusCode resp == 200 && responseJsonMaybe resp == Just TeamFeatureEnabled) diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 6c6e6c6fcde..ebd70c06168 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -58,7 +58,7 @@ import Galley.Types.Teams as Galley import Imports import Network.URI import qualified SAML2.WebSSO as SAML -import Spar.App (Env, Spar, getUser, sparCtxOpts, wrapMonadClient, wrapMonadClient) +import Spar.App (Env, Spar, getUser, sparCtxOpts, validateEmailIfExists, wrapMonadClient, wrapMonadClient) import qualified Spar.Data as Data import Spar.Intra.Brig as Brig import qualified Spar.Intra.Brig as Intra.Brig @@ -351,6 +351,8 @@ createValidScimUser (ValidScimUser user uref idpConfig handl mbName richInfo) = -- FUTUREWORK(arianvp): these two actions we probably want to make transactional lift . wrapMonadClient $ Data.insertScimUser buid storedUser lift . wrapMonadClient $ Data.insertSAMLUser uref buid + + lift $ validateEmailIfExists buid uref pure storedUser updateValidScimUser :: diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 8d48b16f675..3599d1159f1 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -29,15 +29,19 @@ import Bilge import Bilge.Assert import Brig.Types.User as Brig import Control.Lens +import Control.Monad.Catch (MonadCatch) +import Control.Retry (exponentialBackoff, limitRetries, recovering) import qualified Data.Aeson as Aeson +import Data.Aeson.Lens (_String, key) import Data.Aeson.QQ (aesonQQ) import Data.Aeson.Types (fromJSON, toJSON) import Data.ByteString.Conversion import Data.Handle (Handle (Handle)) -import Data.Id (UserId, randomId) +import Data.Id (TeamId, UserId, randomId) import Data.Ix (inRange) import qualified Data.Map as Map import Data.String.Conversions (cs) +import qualified Data.Text.Ascii as Ascii import Imports import qualified SAML2.WebSSO.Test.MockResponse as SAML import qualified SAML2.WebSSO.Types as SAML @@ -54,6 +58,8 @@ import qualified Web.Scim.Schema.Common as Scim import qualified Web.Scim.Schema.Meta as Scim import qualified Web.Scim.Schema.PatchOp as PatchOp import qualified Web.Scim.Schema.User as Scim.User +import qualified Wire.API.Team.Feature as Feature +import qualified Wire.API.User.Activation as Activation -- | Tests for @\/scim\/v2\/Users@. spec :: SpecWith TestEnv @@ -65,6 +71,7 @@ spec = do specUpdateUser specDeleteUser specAzureQuirks + specEmailValidation describe "CRUD operations maintain invariants in mapScimToBrig, mapBrigToScim." $ do it "..." $ do pendingWith "this is a job for quickcheck-state-machine" @@ -1065,3 +1072,89 @@ specAzureQuirks = do liftIO $ users `shouldBe` [] users' <- listUsers tok (Just (filterBy "externalId" "f52dcb88-9fa1-4ec7-984f-7bc2d4046a9c")) liftIO $ users' `shouldBe` [] + +---------------------------------------------------------------------------- +-- Email validation of SAML users (depending on team flag) + +specEmailValidation :: SpecWith TestEnv +specEmailValidation = do + describe "email validation" $ do + let enableSamlEmailValidation :: HasCallStack => TeamId -> TestSpar () + enableSamlEmailValidation tid = do + galley <- asks (^. teGalley) + let req = put $ galley . paths p . json Feature.TeamFeatureEnabled + p = ["/i/teams", toByteString' tid, "features", "validate-saml-emails"] + call req !!! const 204 === statusCode + -- + assertEmail :: HasCallStack => UserId -> Maybe Email -> TestSpar () + assertEmail uid expectedEmail = do + brig <- asks (^. teBrig) + let req = get (brig . path "/self" . zUser uid) + call req !!! do + const 200 === statusCode + const expectedEmail === (userEmail <=< responseJsonMaybe) + -- + eventually :: HasCallStack => TestSpar a -> TestSpar a + eventually = recovering (limitRetries 3 <> exponentialBackoff 100000) [] . const + -- + setup :: HasCallStack => Bool -> TestSpar (UserId, Email) + setup enabled = do + (tok, (_ownerid, teamid, idp)) <- registerIdPAndScimToken + when enabled $ enableSamlEmailValidation teamid + (user, email) <- randomScimUserWithEmail + scimStoredUser <- createUser tok user + let Right uref = mkUserRef idp . Scim.User.externalId . Scim.value . Scim.thing $ scimStoredUser + uid <- getUserIdViaRef uref + brig <- asks (^. teBrig) + call $ activateEmail brig email + pure (uid, email) + -- + -- copied from brig integration tests. + activateEmail :: + HasCallStack => + BrigReq -> + Email -> + (MonadIO m, MonadCatch m, MonadHttp m) => m () + activateEmail brig email = do + act <- getActivationCode brig (Left email) + case act of + Nothing -> pure () -- missing activation key/code; this happens if the feature is + -- disabled (second test case below) + Just kc -> activate brig kc !!! do + const 200 === statusCode + const (Just False) === fmap Activation.activatedFirst . responseJsonMaybe + -- + -- copied from brig integration tests. + getActivationCode :: + HasCallStack => + BrigReq -> + Either Email Phone -> + (MonadIO m, MonadCatch m, MonadHttp m) => m (Maybe (Activation.ActivationKey, Activation.ActivationCode)) + getActivationCode brig ep = do + let qry = either (queryItem "email" . toByteString') (queryItem "phone" . toByteString') ep + r <- get $ brig . path "/i/users/activation-code" . qry + let lbs = fromMaybe "" $ responseBody r + let akey = Activation.ActivationKey . Ascii.unsafeFromText <$> (lbs ^? key "key" . _String) + let acode = Activation.ActivationCode . Ascii.unsafeFromText <$> (lbs ^? key "code" . _String) + return $ (,) <$> akey <*> acode + -- + -- copied from brig integration tests. + activate :: + HasCallStack => + BrigReq -> + (Activation.ActivationKey, Activation.ActivationCode) -> + (MonadIO m, MonadCatch m, MonadHttp m) => m ResponseLBS + activate brig (k, c) = + get $ + brig + . path "activate" + . queryItem "key" (toByteString' k) + . queryItem "code" (toByteString' c) + + context "enabled in team" . it "gives user email" $ do + (uid, email) <- setup True + eventually $ assertEmail uid (Just email) + + context "not enabled in team" . it "does not give user email" $ do + (uid, _) <- setup False + eventually $ assertEmail uid Nothing diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index 3b742bae2db..6bcf6d9cd6b 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -145,6 +145,19 @@ randomScimUserWithSubjectAndRichInfo richInfo = do subj ) +randomScimUserWithEmail :: MonadRandom m => m (Scim.User.User SparTag, Email) +randomScimUserWithEmail = do + suffix <- cs <$> replicateM 7 (getRandomR ('0', '9')) + let email = Email ("email" <> suffix) "example.com" + externalId = fromEmail email + pure + ( (Scim.User.empty userSchemas ("scimuser_" <> suffix) (ScimUserExtra (RichInfo mempty mempty))) + { Scim.User.displayName = Just ("Scim User #" <> suffix), + Scim.User.externalId = Just externalId + }, + email + ) + randomScimEmail :: MonadRandom m => m Email.Email randomScimEmail = do let typ :: Maybe Text = Nothing From ce3bb4fa284d74f0742db0d338cf33538144557e Mon Sep 17 00:00:00 2001 From: fisx Date: Fri, 5 Jun 2020 19:46:38 +0200 Subject: [PATCH 05/11] Fix incomplete pattern in code checking email domain (custom extensions) (#1130) * Do not depend on MonadFail for incomplete pattern handling. Co-authored-by: Matthias Heinzel --- services/brig/src/Brig/API/Public.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index c70e569d4d2..c1ae534e0d8 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -1232,12 +1232,13 @@ sendActivationCode Public.SendActivationCode {..} = do customerExtensionCheckBlockedDomains :: (DomainsBlockedForRegistration ~ DomainsBlockedForRegistration) => Public.Email -> Handler () customerExtensionCheckBlockedDomains email = do mBlockedDomains <- asks (fmap domainsBlockedForRegistration . setCustomerExtensions . view settings) - case mBlockedDomains of - Nothing -> pure () - Just (DomainsBlockedForRegistration blockedDomains) -> do - let Right domain = mkDomain (Public.emailDomain email) - when (domain `elem` blockedDomains) $ do - throwM $ customerExtensionBlockedDomain domain + for_ mBlockedDomains $ \(DomainsBlockedForRegistration blockedDomains) -> do + case mkDomain (Public.emailDomain email) of + Left _ -> + pure () -- if it doesn't fit the syntax of blocked domains, it is not blocked + Right domain -> + when (domain `elem` blockedDomains) $ do + throwM $ customerExtensionBlockedDomain domain changeSelfEmailH :: UserId ::: ConnId ::: JsonRequest Public.EmailUpdate -> Handler Response changeSelfEmailH (u ::: _ ::: req) = do From 869c7ac59ae62b6cee35aabe7f44ed8c031c946d Mon Sep 17 00:00:00 2001 From: fisx Date: Mon, 8 Jun 2020 16:27:00 +0200 Subject: [PATCH 06/11] Simplify team feature database interface; add validate-saml-emails feature to stern/backoffice (#1129) * Simplify team feature database interface. There was one Data.* module per column in the team_features table. That may make sense at some point in the distant future, but as long as all those columns are just booleans, having one haskell module to access any of them in a uniform way saves a lot of boilerplate. * Use new feature flag types and make a generic end-point in stern. * Add FUTUREWORKs. Co-authored-by: Akshay Mankar --- docs/reference/cassandra-schema.cql | 3 +- services/galley/galley.cabal | 5 +- services/galley/src/Galley/API/LegalHold.hs | 3 +- services/galley/src/Galley/API/Teams.hs | 27 ++-- services/galley/src/Galley/Data/LegalHold.hs | 19 +-- services/galley/src/Galley/Data/Queries.hs | 31 ---- services/galley/src/Galley/Data/SSO.hs | 45 ------ .../src/Galley/Data/SearchVisibility.hs | 15 +- .../galley/src/Galley/Data/TeamFeatures.hs | 51 +++++++ .../src/Galley/Data/ValidateSAMLEmails.hs | 42 ------ services/galley/test/integration/API/Teams.hs | 5 + tools/stern/src/Stern/API.hs | 92 ++++-------- tools/stern/src/Stern/Intra.hs | 138 +++--------------- tools/stern/src/Stern/Swagger.hs | 16 -- tools/stern/src/Stern/Types.hs | 18 --- 15 files changed, 121 insertions(+), 389 deletions(-) delete mode 100644 services/galley/src/Galley/Data/SSO.hs create mode 100644 services/galley/src/Galley/Data/TeamFeatures.hs delete mode 100644 services/galley/src/Galley/Data/ValidateSAMLEmails.hs diff --git a/docs/reference/cassandra-schema.cql b/docs/reference/cassandra-schema.cql index 5bbcdd886c5..3a62c2e5288 100644 --- a/docs/reference/cassandra-schema.cql +++ b/docs/reference/cassandra-schema.cql @@ -105,7 +105,8 @@ CREATE TABLE galley_test.team_features ( team_id uuid PRIMARY KEY, legalhold_status int, search_visibility_status int, - sso_status int + sso_status int, + validate_saml_emails int ) WITH bloom_filter_fp_chance = 0.1 AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} AND comment = '' diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index d37aa096ee3..633e053fb66 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: ea8a2731dc5ada81ea4a4bfed991318a463ea1bdc8af1b5ae12836565ce2cb19 +-- hash: 92456c44f0413d6ce65ee41f0b151adcc8a84a465cd9b05e3be17b1917c8f551 name: galley version: 0.83.0 @@ -48,10 +48,9 @@ library Galley.Data.Queries Galley.Data.SearchVisibility Galley.Data.Services - Galley.Data.SSO + Galley.Data.TeamFeatures Galley.Data.TeamNotifications Galley.Data.Types - Galley.Data.ValidateSAMLEmails Galley.External Galley.External.LegalHoldService Galley.Intra.Client diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 6ecf802f509..1c32218de16 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -42,6 +42,7 @@ import Galley.API.Util import Galley.App import qualified Galley.Data as Data import qualified Galley.Data.LegalHold as LegalHoldData +import qualified Galley.Data.TeamFeatures as TeamFeatures import qualified Galley.External.LegalHoldService as LHService import qualified Galley.Intra.Client as Client import Galley.Types.Teams as Team @@ -60,7 +61,7 @@ assertLegalHoldEnabled tid = unlessM (isLegalHoldEnabled tid) $ throwM legalHold isLegalHoldEnabled :: TeamId -> Galley Bool isLegalHoldEnabled tid = do - lhConfig <- LegalHoldData.getLegalHoldTeamConfig tid + lhConfig <- TeamFeatures.getFlag tid Public.TeamFeatureLegalHold return $ case lhConfig of Just Public.TeamFeatureEnabled -> True Just Public.TeamFeatureDisabled -> False diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 73eae30ec23..c8ba67affa8 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -77,12 +77,10 @@ import qualified Galley.API.TeamNotifications as APITeamQueue import Galley.API.Util import Galley.App import qualified Galley.Data as Data -import qualified Galley.Data.LegalHold as LegalHoldData -import qualified Galley.Data.SSO as SSOData import qualified Galley.Data.SearchVisibility as SearchVisibilityData import Galley.Data.Services (BotMember) +import qualified Galley.Data.TeamFeatures as TeamFeatures import qualified Galley.Data.Types as Data -import qualified Galley.Data.ValidateSAMLEmails as ValidateSAMLEmailsData import qualified Galley.External as External import qualified Galley.Intra.Journal as Journal import Galley.Intra.Push @@ -896,7 +894,7 @@ getSSOStatusInternal tid = do pure $ case featureSSO of FeatureSSOEnabledByDefault -> Public.TeamFeatureEnabled FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled - ssoTeamConfig <- SSOData.getSSOTeamConfig tid + ssoTeamConfig <- TeamFeatures.getFlag tid Public.TeamFeatureSSO pure . fromMaybe defConfig $ ssoTeamConfig setSSOStatusInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () @@ -904,14 +902,14 @@ setSSOStatusInternal tid ssoTeamConfig = do case ssoTeamConfig of Public.TeamFeatureDisabled -> throwM disableSsoNotImplemented Public.TeamFeatureEnabled -> pure () -- this one is easy to implement :) - SSOData.setSSOTeamConfig tid ssoTeamConfig + TeamFeatures.setFlag tid Public.TeamFeatureSSO ssoTeamConfig getLegalholdStatusInternal :: TeamId -> Galley Public.TeamFeatureStatus getLegalholdStatusInternal tid = do featureLegalHold <- view (options . optSettings . setFeatureFlags . flagLegalHold) case featureLegalHold of FeatureLegalHoldDisabledByDefault -> do - legalHoldTeamConfig <- LegalHoldData.getLegalHoldTeamConfig tid + legalHoldTeamConfig <- TeamFeatures.getFlag tid Public.TeamFeatureLegalHold pure (fromMaybe Public.TeamFeatureDisabled legalHoldTeamConfig) FeatureLegalHoldDisabledPermanently -> do pure Public.TeamFeatureDisabled @@ -929,7 +927,7 @@ setLegalholdStatusInternal tid legalHoldTeamConfig = do Public.TeamFeatureDisabled -> removeSettings' tid -- FUTUREWORK: We cannot enable legalhold on large teams right now Public.TeamFeatureEnabled -> checkTeamSize - LegalHoldData.setLegalHoldTeamConfig tid legalHoldTeamConfig + TeamFeatures.setFlag tid Public.TeamFeatureLegalHold legalHoldTeamConfig where checkTeamSize = do (TeamSize size) <- BrigTeam.getSize tid @@ -945,23 +943,24 @@ getTeamSearchVisibilityAvailableInternal tid = do pure $ case featureTeamSearchVisibility of FeatureTeamSearchVisibilityEnabledByDefault -> Public.TeamFeatureEnabled FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled - fromMaybe defConfig <$> SearchVisibilityData.getTeamSearchVisibilityAvailable tid + fromMaybe defConfig <$> TeamFeatures.getFlag tid Public.TeamFeatureSearchVisibility setTeamSearchVisibilityAvailableInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () setTeamSearchVisibilityAvailableInternal tid isenabled = do case isenabled of Public.TeamFeatureDisabled -> SearchVisibilityData.resetSearchVisibility tid Public.TeamFeatureEnabled -> pure () -- This allows the option to be set at the team level - SearchVisibilityData.setTeamSearchVisibilityAvailable tid isenabled + TeamFeatures.setFlag tid Public.TeamFeatureSearchVisibility isenabled getValidateSAMLEmailsInternal :: TeamId -> Galley Public.TeamFeatureStatus -getValidateSAMLEmailsInternal = - ValidateSAMLEmailsData.getValidateSAMLEmails >=> \case - Nothing -> throwM teamNotFound - Just s -> pure s +getValidateSAMLEmailsInternal tid = + -- FUTUREWORK: we may also want to get a default from the server config file here, like for + -- sso, and team search visibility. + fromMaybe Public.TeamFeatureDisabled + <$> TeamFeatures.getFlag tid Public.TeamFeatureValidateSAMLEmails setValidateSAMLEmailsInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () -setValidateSAMLEmailsInternal = ValidateSAMLEmailsData.setValidateSAMLEmails +setValidateSAMLEmailsInternal tid = TeamFeatures.setFlag tid Public.TeamFeatureValidateSAMLEmails -- | Modify and get visibility type for a team (internal, no user permission checks) getSearchVisibilityInternalH :: TeamId ::: JSON -> Galley Response diff --git a/services/galley/src/Galley/Data/LegalHold.hs b/services/galley/src/Galley/Data/LegalHold.hs index 6036faaa327..857fa9aa499 100644 --- a/services/galley/src/Galley/Data/LegalHold.hs +++ b/services/galley/src/Galley/Data/LegalHold.hs @@ -18,9 +18,7 @@ -- with this program. If not, see . module Galley.Data.LegalHold - ( setLegalHoldTeamConfig, - getLegalHoldTeamConfig, - createSettings, + ( createSettings, getSettings, removeSettings, Galley.Data.LegalHold.insertPendingPrekeys, @@ -40,21 +38,6 @@ import Data.LegalHold import Galley.Data.Instances () import Galley.Data.Queries as Q import Imports -import Wire.API.Team.Feature (TeamFeatureStatus (..)) - --- | Return whether a given team is allowed to enable/disable legalhold --- Defaults to 'TeamFeatureDisabled'. -getLegalHoldTeamConfig :: MonadClient m => TeamId -> m (Maybe TeamFeatureStatus) -getLegalHoldTeamConfig tid = fmap toLegalHoldTeamConfig <$> do - retry x1 $ query1 selectLegalHoldTeamConfig (params Quorum (Identity tid)) - where - toLegalHoldTeamConfig (Identity Nothing) = TeamFeatureDisabled - toLegalHoldTeamConfig (Identity (Just status)) = status - --- | Determines whether a given team is allowed to enable/disable legalhold -setLegalHoldTeamConfig :: MonadClient m => TeamId -> TeamFeatureStatus -> m () -setLegalHoldTeamConfig tid legalHoldTeamConfigStatus = do - retry x5 $ write updateLegalHoldTeamConfig (params Quorum (legalHoldTeamConfigStatus, tid)) -- | Returns 'False' if legal hold is not enabled for this team -- The Caller is responsible for checking whether legal hold is enabled for this team diff --git a/services/galley/src/Galley/Data/Queries.hs b/services/galley/src/Galley/Data/Queries.hs index dc097335efb..35193844c2a 100644 --- a/services/galley/src/Galley/Data/Queries.hs +++ b/services/galley/src/Galley/Data/Queries.hs @@ -36,7 +36,6 @@ import Galley.Types.Teams.Intra import Galley.Types.Teams.SearchVisibility import Imports import Text.RawString.QQ -import Wire.API.Team.Feature (TeamFeatureStatus) -- Teams -------------------------------------------------------------------- @@ -321,12 +320,6 @@ insertBot = "insert into member (conv, user, service, provider, status) values ( -- LegalHold ---------------------------------------------------------------- -selectLegalHoldTeamConfig :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatus)) -selectLegalHoldTeamConfig = "select legalhold_status from team_features where team_id = ?" - -updateLegalHoldTeamConfig :: PrepQuery W (TeamFeatureStatus, TeamId) () -updateLegalHoldTeamConfig = "update team_features set legalhold_status = ? where team_id = ?" - insertLegalHoldSettings :: PrepQuery W (HttpsUrl, Fingerprint Rsa, ServiceToken, ServiceKey, TeamId) () insertLegalHoldSettings = [r| @@ -379,22 +372,6 @@ updateUserLegalHoldStatus = where team = ? and user = ? |] -selectSSOTeamConfig :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatus)) -selectSSOTeamConfig = - "select sso_status from team_features where team_id = ?" - -updateSSOTeamConfig :: PrepQuery W (TeamFeatureStatus, TeamId) () -updateSSOTeamConfig = - "update team_features set sso_status = ? where team_id = ?" - -selectTeamSearchVisibilityAvailable :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatus)) -selectTeamSearchVisibilityAvailable = - "select search_visibility_status from team_features where team_id = ?" - -updateTeamSearchVisibilityAvailable :: PrepQuery W (TeamFeatureStatus, TeamId) () -updateTeamSearchVisibilityAvailable = - "update team_features set search_visibility_status = ? where team_id = ?" - selectSearchVisibility :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamSearchVisibility)) selectSearchVisibility = "select search_visibility from team where team = ?" @@ -403,14 +380,6 @@ updateSearchVisibility :: PrepQuery W (TeamSearchVisibility, TeamId) () updateSearchVisibility = "update team set search_visibility = ? where team = ?" -selectValidateSAMLEmails :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatus)) -selectValidateSAMLEmails = - "select validate_saml_emails from team_features where team_id = ?" - -updateValidateSAMLEmails :: PrepQuery W (TeamFeatureStatus, TeamId) () -updateValidateSAMLEmails = - "update team_features set validate_saml_emails = ? where team_id = ?" - selectCustomBackend :: PrepQuery R (Identity Domain) (HttpsUrl, HttpsUrl) selectCustomBackend = "select config_json_url, webapp_welcome_url from custom_backend where domain = ?" diff --git a/services/galley/src/Galley/Data/SSO.hs b/services/galley/src/Galley/Data/SSO.hs deleted file mode 100644 index fd5d484be15..00000000000 --- a/services/galley/src/Galley/Data/SSO.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.Data.SSO - ( setSSOTeamConfig, - getSSOTeamConfig, - ) -where - -import Cassandra -import Data.Id -import Galley.Data.Instances () -import Galley.Data.Queries -import Imports -import Wire.API.Team.Feature (TeamFeatureStatus (..)) - --- | Return whether a given team is allowed to enable/disable sso. --- Defaults to 'TeamFeatureDisabled' if null in the DB -getSSOTeamConfig :: MonadClient m => TeamId -> m (Maybe TeamFeatureStatus) -getSSOTeamConfig tid = fmap toSSOTeamConfig <$> do - retry x1 $ query1 selectSSOTeamConfig (params Quorum (Identity tid)) - where - toSSOTeamConfig (Identity Nothing) = TeamFeatureDisabled - toSSOTeamConfig (Identity (Just status)) = status - --- | Determines whether a given team is allowed to enable/disable sso -setSSOTeamConfig :: MonadClient m => TeamId -> TeamFeatureStatus -> m () -setSSOTeamConfig tid ssoTeamConfigStatus = do - retry x5 $ write updateSSOTeamConfig (params Quorum (ssoTeamConfigStatus, tid)) diff --git a/services/galley/src/Galley/Data/SearchVisibility.hs b/services/galley/src/Galley/Data/SearchVisibility.hs index 20e2ae7e164..72b3085ec34 100644 --- a/services/galley/src/Galley/Data/SearchVisibility.hs +++ b/services/galley/src/Galley/Data/SearchVisibility.hs @@ -18,9 +18,7 @@ -- with this program. If not, see . module Galley.Data.SearchVisibility - ( setTeamSearchVisibilityAvailable, - getTeamSearchVisibilityAvailable, - setSearchVisibility, + ( setSearchVisibility, getSearchVisibility, resetSearchVisibility, ) @@ -32,17 +30,6 @@ import Galley.Data.Instances () import Galley.Data.Queries import Galley.Types.Teams.SearchVisibility import Imports -import Wire.API.Team.Feature (TeamFeatureStatus) - --- | Return whether a given team is allowed to enable/disable sso -getTeamSearchVisibilityAvailable :: MonadClient m => TeamId -> m (Maybe TeamFeatureStatus) -getTeamSearchVisibilityAvailable tid = join . fmap runIdentity <$> do - retry x1 $ query1 selectTeamSearchVisibilityAvailable (params Quorum (Identity tid)) - --- | Determines whether a given team is allowed to enable/disable sso -setTeamSearchVisibilityAvailable :: MonadClient m => TeamId -> TeamFeatureStatus -> m () -setTeamSearchVisibilityAvailable tid isenabled = do - retry x5 $ write updateTeamSearchVisibilityAvailable (params Quorum (isenabled, tid)) -- | Return whether a given team is allowed to enable/disable sso getSearchVisibility :: MonadClient m => TeamId -> m TeamSearchVisibility diff --git a/services/galley/src/Galley/Data/TeamFeatures.hs b/services/galley/src/Galley/Data/TeamFeatures.hs new file mode 100644 index 00000000000..49072334ee8 --- /dev/null +++ b/services/galley/src/Galley/Data/TeamFeatures.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE ViewPatterns #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Data.TeamFeatures + ( setFlag, + getFlag, + ) +where + +import Cassandra +import Data.Id +import Galley.Data.Instances () +import Imports +import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus (..)) + +-- | Is a given feature enabled or disabled? Returns 'Nothing' if team does not exist or the +-- feature flag in Cassandra is null. +getFlag :: MonadClient m => TeamId -> TeamFeatureName -> m (Maybe TeamFeatureStatus) +getFlag tid feature = (>>= runIdentity) <$> retry x1 (query1 (select feature) (params Quorum (Identity tid))) + +-- | Enable or disable feature flag. +setFlag :: MonadClient m => TeamId -> TeamFeatureName -> TeamFeatureStatus -> m () +setFlag tid feature flag = do retry x5 $ write (update feature) (params Quorum (flag, tid)) + +select :: TeamFeatureName -> PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatus)) +select feature = fromString $ "select " <> toCol feature <> " from team_features where team_id = ?" + +update :: TeamFeatureName -> PrepQuery W (TeamFeatureStatus, TeamId) () +update feature = fromString $ "update team_features set " <> toCol feature <> " = ? where team_id = ?" + +toCol :: TeamFeatureName -> String +toCol TeamFeatureLegalHold = "legalhold_status" +toCol TeamFeatureSSO = "sso_status" +toCol TeamFeatureSearchVisibility = "search_visibility_status" +toCol TeamFeatureValidateSAMLEmails = "validate_saml_emails" diff --git a/services/galley/src/Galley/Data/ValidateSAMLEmails.hs b/services/galley/src/Galley/Data/ValidateSAMLEmails.hs deleted file mode 100644 index c81e0d58a8d..00000000000 --- a/services/galley/src/Galley/Data/ValidateSAMLEmails.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.Data.ValidateSAMLEmails - ( setValidateSAMLEmails, - getValidateSAMLEmails, - ) -where - -import Cassandra -import Data.Id -import Galley.Data.Instances () -import Galley.Data.Queries -import Imports -import Wire.API.Team.Feature (TeamFeatureStatus (..)) - -getValidateSAMLEmails :: MonadClient m => TeamId -> m (Maybe TeamFeatureStatus) -getValidateSAMLEmails tid = fmap toFeatureStatus <$> do - retry x1 $ query1 selectValidateSAMLEmails (params Quorum (Identity tid)) - where - toFeatureStatus (Identity Nothing) = TeamFeatureDisabled - toFeatureStatus (Identity (Just status)) = status - -setValidateSAMLEmails :: MonadClient m => TeamId -> TeamFeatureStatus -> m () -setValidateSAMLEmails tid featureStatus = do - retry x5 $ write updateValidateSAMLEmails (params Quorum (featureStatus, tid)) diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 4267fca0bdd..82cb1f86335 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -1878,6 +1878,11 @@ postCryptoBroadcastMessage100OrMaxConns = do newTeamMember' :: Permissions -> UserId -> TeamMember newTeamMember' perms uid = newTeamMember uid perms Nothing +-- NOTE: all client functions calling @{/i,}/teams/*/features/*@ can be replaced by +-- hypothetical functions 'getTeamFeatureFlag', 'getTeamFeatureFlagInternal', +-- 'putTeamFeatureFlagInternal'. Since these functions all work in slightly different monads +-- and with different kinds of internal checks, it's quite tedious to do so. + getSSOEnabled :: HasCallStack => UserId -> TeamId -> TestM ResponseLBS getSSOEnabled uid tid = do g <- view tsGalley diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 6c7caa598d2..b7d41fa1898 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -66,6 +66,7 @@ import qualified Stern.Swagger as Doc import Stern.Types import System.Logger.Class hiding ((.=), Error, name, trace) import Util.Options +import qualified Wire.API.Team.Feature as Public import qualified Wire.API.Team.SearchVisibility as Public import qualified Wire.Swagger as Doc @@ -326,68 +327,32 @@ routes = do -- feature flags - get "/teams/:tid/features/legalhold" (continue (liftM json . Intra.getLegalholdStatus)) $ + get "/teams/:tid/features/:feature" (continue getTeamFeatureFlagH) $ capture "tid" - document "GET" "getLegalholdStatus" $ do - summary "Shows whether legalhold feature is enabled for team" + .&. capture "feature" + document "GET" "getTeamFeatureFlag" $ do + summary "Shows whether a feature flag is enabled or not for a given team." Doc.parameter Doc.Path "tid" Doc.bytes' $ description "Team ID" - Doc.returns Doc.docSetLegalHoldStatus - Doc.response 200 "Legalhold status" Doc.end - Doc.returns Doc.bool' + Doc.parameter Doc.Path "feature" Public.typeTeamFeatureName $ + description "Feature name" + Doc.returns Public.typeTeamFeatureStatus + Doc.response 200 "Team feature flag status" Doc.end - put "/teams/:tid/features/legalhold" (continue setLegalholdStatus) $ - contentType "application" "json" - .&. capture "tid" - .&. jsonRequest @SetLegalHoldStatus - document "PUT" "setLegalholdStatus" $ do - summary "Disable / enable legalhold feature for team" - Doc.parameter Doc.Path "tid" Doc.bytes' $ - description "Team ID" - Doc.body Doc.docSetLegalHoldStatus $ - Doc.description "JSON body" - Doc.response 200 "Legalhold status" Doc.end - - get "/teams/:tid/features/sso" (continue (liftM json . Intra.getSSOStatus)) $ + put "/teams/:tid/features/:feature" (continue setTeamFeatureFlagH) $ capture "tid" - document "GET" "getSSOStatus" $ do - summary "Shows whether SSO feature is enabled for team" - Doc.parameter Doc.Path "tid" Doc.bytes' $ - description "Team ID" - Doc.returns Doc.docSetSSOStatus - Doc.response 200 "SSO status" Doc.end - - put "/teams/:tid/features/sso" (continue setSSOStatus) $ - contentType "application" "json" - .&. capture "tid" - .&. jsonRequest @SetSSOStatus - document "PUT" "setSSOStatus" $ do - summary "Disable / enable SSO feature for team" + .&. capture "feature" + .&. contentType "application" "json" + .&. jsonRequest @Public.TeamFeatureStatus + document "PUT" "setTeamFeatureFlag" $ do + summary "Disable / enable feature flag for a given team" Doc.parameter Doc.Path "tid" Doc.bytes' $ description "Team ID" - Doc.body Doc.docSetSSOStatus $ + Doc.parameter Doc.Path "feature" Public.typeTeamFeatureName $ + description "Feature name" + Doc.body Public.typeTeamFeatureStatus $ Doc.description "JSON body" - Doc.response 200 "SSO status" Doc.end - - get "/teams/:tid/features/search-visibility" (continue (liftM json . Intra.getTeamSearchVisibilityAvailable)) $ - capture "tid" - document "GET" "getTeamSearchVisibilityAvailable" $ do - summary "Shows whether TeamSearchVisibility feature is enabled for team" - Doc.parameter Doc.Path "tid" Doc.bytes' $ - description "Team ID" - Doc.returns Doc.docSetTeamSearchVisibilityAvailable - Doc.response 200 "TeamSearchVisibility status" Doc.end - put "/teams/:tid/features/search-visibility" (continue setTeamSearchVisibilityAvailable) $ - contentType "application" "json" - .&. capture "tid" - .&. jsonRequest @SetTeamSearchVisibilityAvailable - document "PUT" "setTeamSearchVisibilityAvailable" $ do - summary "Disable / enable TeamSearchVisibility feature for team" - Doc.parameter Doc.Path "tid" Doc.bytes' $ - description "Team ID" - Doc.body Doc.docSetTeamSearchVisibilityAvailable $ - Doc.description "JSON body" - Doc.response 200 "TeamSearchVisibility status" Doc.end + Doc.response 200 "Team feature flag status" Doc.end -- These endpoints should be part of team settings. Until then, we access them from here -- for authorized personnel to enable/disable this on the team's behalf @@ -614,20 +579,13 @@ getTeamInfo = liftM json . Intra.getTeamInfo getTeamAdminInfo :: TeamId -> Handler Response getTeamAdminInfo = liftM (json . toAdminInfo) . Intra.getTeamInfo -setLegalholdStatus :: JSON ::: TeamId ::: JsonRequest SetLegalHoldStatus -> Handler Response -setLegalholdStatus (_ ::: tid ::: req) = do - status <- parseBody req !>> Error status400 "client-error" - liftM json $ Intra.setLegalholdStatus tid status - -setSSOStatus :: JSON ::: TeamId ::: JsonRequest SetSSOStatus -> Handler Response -setSSOStatus (_ ::: tid ::: req) = do - status :: SetSSOStatus <- parseBody req !>> Error status400 "client-error" - liftM json $ Intra.setSSOStatus tid status +getTeamFeatureFlagH :: TeamId ::: Public.TeamFeatureName -> Handler Response +getTeamFeatureFlagH (tid ::: feature) = + json <$> Intra.getTeamFeatureFlag tid feature -setTeamSearchVisibilityAvailable :: JSON ::: TeamId ::: JsonRequest SetTeamSearchVisibilityAvailable -> Handler Response -setTeamSearchVisibilityAvailable (_ ::: tid ::: req) = do - status :: SetTeamSearchVisibilityAvailable <- parseBody req !>> Error status400 "client-error" - liftM json $ Intra.setTeamSearchVisibilityAvailable tid status +setTeamFeatureFlagH :: TeamId ::: Public.TeamFeatureName ::: JSON ::: JsonRequest Public.TeamFeatureStatus -> Handler Response +setTeamFeatureFlagH (tid ::: feature ::: _ ::: req) = + empty <$ (Intra.setTeamFeatureFlag tid feature =<< (parseBody req !>> Error status400 "client-error")) setSearchVisibility :: JSON ::: TeamId ::: JsonRequest Team.TeamSearchVisibility -> Handler Response setSearchVisibility (_ ::: tid ::: req) = do diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 9063ee55cac..95f8e32e7fc 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -40,12 +40,8 @@ module Stern.Intra getUserBindingTeam, isBlacklisted, setBlacklistStatus, - getLegalholdStatus, - setLegalholdStatus, - getSSOStatus, - setSSOStatus, - getTeamSearchVisibilityAvailable, - setTeamSearchVisibilityAvailable, + getTeamFeatureFlag, + setTeamFeatureFlag, getSearchVisibility, setSearchVisibility, getTeamBillingInfo, @@ -96,7 +92,7 @@ import Stern.Types import System.Logger.Class hiding ((.=), Error, name) import qualified System.Logger.Class as Log import UnliftIO.Exception hiding (Handler) -import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus (..)) +import qualified Wire.API.Team.Feature as Public ------------------------------------------------------------------------------- @@ -427,125 +423,29 @@ setBlacklistStatus status emailOrPhone = do statusToMethod False = DELETE statusToMethod True = POST -getLegalholdStatus :: TeamId -> Handler SetLegalHoldStatus -getLegalholdStatus tid = do - info $ msg "Getting legalhold status" +getTeamFeatureFlag :: TeamId -> Public.TeamFeatureName -> Handler Public.TeamFeatureStatus +getTeamFeatureFlag tid feature = do + info $ msg "Getting team feature status" gly <- view galley - (>>= fromResponseBody) . catchRpcErrors $ - rpc' - "galley" - gly - ( method GET - . paths ["/i/teams", toByteString' tid, "features", toByteString' TeamFeatureLegalHold] + let req = + method GET + . paths ["/i/teams", toByteString' tid, "features", toByteString' feature] . expect2xx - ) - where - fromResponseBody :: Response (Maybe LByteString) -> Handler SetLegalHoldStatus - fromResponseBody resp = case responseJsonEither resp of - Right TeamFeatureDisabled -> pure SetLegalHoldDisabled - Right TeamFeatureEnabled -> pure SetLegalHoldEnabled - Left errmsg -> throwE (Error status502 "bad-upstream" ("bad response; error message: " <> pack errmsg)) - -setLegalholdStatus :: TeamId -> SetLegalHoldStatus -> Handler () -setLegalholdStatus tid status = do - info $ msg "Setting legalhold status" - gly <- view galley - resp <- - catchRpcErrors $ - rpc' - "galley" - gly - ( method PUT - . paths ["/i/teams", toByteString' tid, "features", "legalhold"] - . lbytes (encode $ toRequestBody status) - . contentJson - ) - case statusCode resp of - 204 -> pure () - _ -> throwE $ responseJsonUnsafe resp - where - toRequestBody SetLegalHoldDisabled = TeamFeatureDisabled - toRequestBody SetLegalHoldEnabled = TeamFeatureEnabled - -getSSOStatus :: TeamId -> Handler SetSSOStatus -getSSOStatus tid = do - info $ msg "Getting SSO status" - gly <- view galley - (>>= fromResponseBody) . catchRpcErrors $ - rpc' - "galley" - gly - ( method GET - . paths ["/i/teams", toByteString' tid, "features", toByteString' TeamFeatureSSO] - . expect2xx - ) - where - fromResponseBody :: Response (Maybe LByteString) -> Handler SetSSOStatus - fromResponseBody resp = case responseJsonEither resp of - Right TeamFeatureEnabled -> pure SetSSOEnabled - Right TeamFeatureDisabled -> pure SetSSODisabled - Left errmsg -> throwE (Error status502 "bad-upstream" ("bad response; error message: " <> pack errmsg)) - -setSSOStatus :: TeamId -> SetSSOStatus -> Handler () -setSSOStatus tid status = do - info $ msg "Setting SSO status" - gly <- view galley - resp <- - catchRpcErrors $ - rpc' - "galley" - gly - ( method PUT - . paths ["/i/teams", toByteString' tid, "features", "sso"] - . lbytes (encode $ toRequestBody status) - . contentJson - ) - case statusCode resp of - 204 -> pure () - _ -> throwE $ responseJsonUnsafe resp - where - toRequestBody SetSSODisabled = TeamFeatureDisabled - toRequestBody SetSSOEnabled = TeamFeatureEnabled + responseJsonUnsafe <$> catchRpcErrors (rpc' "galley" gly req) -getTeamSearchVisibilityAvailable :: TeamId -> Handler SetTeamSearchVisibilityAvailable -getTeamSearchVisibilityAvailable tid = do - info $ msg "Getting TeamSearchVisibility status" +setTeamFeatureFlag :: TeamId -> Public.TeamFeatureName -> Public.TeamFeatureStatus -> Handler () +setTeamFeatureFlag tid feature status = do + info $ msg "Setting team feature status" gly <- view galley - (>>= fromResponseBody) . catchRpcErrors $ - rpc' - "galley" - gly - ( method GET - . paths ["/i/teams", toByteString' tid, "features", toByteString' TeamFeatureSearchVisibility] - . expect2xx - ) - where - fromResponseBody :: Response (Maybe LByteString) -> Handler SetTeamSearchVisibilityAvailable - fromResponseBody resp = case responseJsonEither resp of - Right TeamFeatureEnabled -> pure SetTeamSearchVisibilityEnabled - Right TeamFeatureDisabled -> pure SetTeamSearchVisibilityDisabled - Left errmsg -> throwE (Error status502 "bad-upstream" ("bad response; error message: " <> pack errmsg)) - -setTeamSearchVisibilityAvailable :: TeamId -> SetTeamSearchVisibilityAvailable -> Handler () -setTeamSearchVisibilityAvailable tid status = do - info $ msg "Setting TeamSearchVisibility status" - gly <- view galley - resp <- - catchRpcErrors $ - rpc' - "galley" - gly - ( method PUT - . paths ["/i/teams", toByteString' tid, "features", "search-visibility"] - . lbytes (encode $ toRequestBody status) - . contentJson - ) + let req = + method PUT + . paths ["/i/teams", toByteString' tid, "features", toByteString' feature] + . Bilge.json status + . contentJson + resp <- catchRpcErrors $ rpc' "galley" gly req case statusCode resp of 204 -> pure () _ -> throwE $ responseJsonUnsafe resp - where - toRequestBody SetTeamSearchVisibilityDisabled = TeamFeatureDisabled - toRequestBody SetTeamSearchVisibilityEnabled = TeamFeatureEnabled getSearchVisibility :: TeamId -> Handler TeamSearchVisibilityView getSearchVisibility tid = do diff --git a/tools/stern/src/Stern/Swagger.hs b/tools/stern/src/Stern/Swagger.hs index 452d3a81915..8d1efe8960b 100644 --- a/tools/stern/src/Stern/Swagger.hs +++ b/tools/stern/src/Stern/Swagger.hs @@ -21,7 +21,6 @@ module Stern.Swagger where import Data.Swagger.Build.Api import Imports -import Stern.Types sternModels :: [Model] sternModels = @@ -90,18 +89,3 @@ teamBillingInfoUpdate = defineModel "teamBillingInfoUpdate" $ do property "state" string' $ do description "State of the company address (1 - 256 characters)" optional - -docSetSSOStatus :: DataType -docSetSSOStatus = docBoundedEnum @SetSSOStatus - -docSetLegalHoldStatus :: DataType -docSetLegalHoldStatus = docBoundedEnum @SetLegalHoldStatus - -docSetTeamSearchVisibilityAvailable :: DataType -docSetTeamSearchVisibilityAvailable = docBoundedEnum @SetTeamSearchVisibilityAvailable - --- (the double-call to show is to add extra double-quotes to the string. this is important --- because the json instances also render this into a json string, and json string are wrapped --- in double-quotes.) -docBoundedEnum :: forall a. (Bounded a, Enum a, Show a) => DataType -docBoundedEnum = string . enum $ show . show <$> [(minBound :: a) ..] diff --git a/tools/stern/src/Stern/Types.hs b/tools/stern/src/Stern/Types.hs index 24ceccc6f93..c91bcbd39fa 100644 --- a/tools/stern/src/Stern/Types.hs +++ b/tools/stern/src/Stern/Types.hs @@ -150,21 +150,3 @@ data TeamBillingInfoUpdate = TeamBillingInfoUpdate deriving (Eq, Show) deriveJSON toJSONFieldName ''TeamBillingInfoUpdate - -data SetLegalHoldStatus = SetLegalHoldDisabled | SetLegalHoldEnabled - deriving (Eq, Show, Ord, Enum, Bounded, Generic) - -deriveJSON toJSONFieldName ''SetLegalHoldStatus - -data SetSSOStatus = SetSSODisabled | SetSSOEnabled - deriving (Eq, Show, Ord, Enum, Bounded, Generic) - -deriveJSON toJSONFieldName ''SetSSOStatus - --- | FUTUREWORK: we should probably use --- 'Galley.Types.Teams.SearchVisibility.TeamSearchVisibilityEnabled'. (same for --- 'SetSSOStatus', 'SetLegalHoldStatus'. -data SetTeamSearchVisibilityAvailable = SetTeamSearchVisibilityDisabled | SetTeamSearchVisibilityEnabled - deriving (Eq, Show, Ord, Enum, Bounded, Generic) - -deriveJSON toJSONFieldName ''SetTeamSearchVisibilityAvailable From a89b9cd818997e7837e5d0938ecfd90cf8dd9e52 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Tue, 9 Jun 2020 09:21:36 +0200 Subject: [PATCH 07/11] Enable additional GHC warnings (#1131) These are not enable by -Wall. More specifically: -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields In tests, I just disabled the warnings per file, but in production code, I tried resolving the issues instead. The only other warning I would consider adding is -Wredundant-contraints, but it doesn't usually prevent bugs, so it's probably not worth the time to add right now. It also flags usage of `HasCallStack`, which can be annoying. Co-authored-by: Matthias Fischmann --- libs/api-bot/api-bot.cabal | 4 +- libs/api-client/api-client.cabal | 4 +- libs/bilge/bilge.cabal | 4 +- libs/brig-types/brig-types.cabal | 6 +- libs/brig-types/src/Brig/Types/Intra.hs | 7 +- libs/cargohold-types/cargohold-types.cabal | 4 +- libs/cassandra-util/cassandra-util.cabal | 4 +- libs/cassandra-util/src/Cassandra/Schema.hs | 2 + libs/extended/extended.cabal | 4 +- libs/federation-util/federation-util.cabal | 6 +- .../src/Network/Federation/Util/Internal.hs | 5 +- libs/galley-types/galley-types.cabal | 6 +- libs/gundeck-types/gundeck-types.cabal | 4 +- libs/imports/imports.cabal | 4 +- libs/metrics-core/metrics-core.cabal | 4 +- libs/metrics-wai/metrics-wai.cabal | 4 +- libs/ropes/ropes.cabal | 8 +- .../sodium-crypto-sign.cabal | 4 +- libs/ssl-util/ssl-util.cabal | 4 +- libs/tasty-cannon/tasty-cannon.cabal | 4 +- libs/types-common-aws/types-common-aws.cabal | 4 +- .../types-common-journal.cabal | 4 +- libs/types-common/src/Data/List1.hs | 4 + libs/types-common/types-common.cabal | 6 +- .../src/Network/Wai/Utilities/Server.hs | 4 +- libs/wai-utilities/wai-utilities.cabal | 4 +- .../wire-api/src/Wire/API/Provider/Service.hs | 28 +++--- libs/wire-api/src/Wire/API/Team.hs | 1 + libs/wire-api/src/Wire/API/User.hs | 11 +-- libs/wire-api/wire-api.cabal | 6 +- libs/zauth/zauth.cabal | 8 +- package-defaults.yaml | 3 + services/brig/brig.cabal | 16 +-- services/brig/src/Brig/IO/Intra.hs | 31 +++--- services/brig/src/Brig/Provider/API.hs | 7 +- services/brig/src/Brig/TURN/API.hs | 4 +- services/brig/src/Brig/User/Event.hs | 98 +++++++++++-------- .../brig/test/integration/API/Provider.hs | 1 + services/brig/test/integration/API/Search.hs | 2 + services/brig/test/integration/API/Team.hs | 2 + .../brig/test/integration/API/Team/Util.hs | 2 + .../brig/test/integration/API/User/Account.hs | 2 + .../brig/test/integration/API/User/Auth.hs | 1 + .../brig/test/integration/API/User/Client.hs | 2 + .../test/integration/API/User/Connection.hs | 2 + .../integration/API/User/PasswordReset.hs | 2 + .../brig/test/integration/API/User/Util.hs | 2 + services/cannon/cannon.cabal | 8 +- services/cargohold/cargohold.cabal | 8 +- services/cargohold/test/integration/API/V3.hs | 2 + services/federator/federator.cabal | 6 +- services/galley/galley.cabal | 15 +-- services/galley/package.yaml | 1 + services/galley/src/Galley/API/Internal.hs | 4 +- services/galley/src/Galley/API/Swagger.hs | 62 +++--------- services/galley/test/integration/API.hs | 2 + services/galley/test/integration/API/Teams.hs | 2 + .../test/integration/API/Teams/LegalHold.hs | 1 + services/galley/test/integration/API/Util.hs | 2 + services/gundeck/gundeck.cabal | 14 +-- services/gundeck/test/unit/ThreadBudget.hs | 23 +++-- services/proxy/proxy.cabal | 6 +- services/spar/spar.cabal | 12 +-- .../test-integration/Test/Spar/APISpec.hs | 2 + .../test-integration/Test/Spar/AppSpec.hs | 1 + .../test-integration/Test/Spar/DataSpec.hs | 1 + .../Test/Spar/Scim/UserSpec.hs | 1 + services/spar/test-integration/Util/Core.hs | 1 + services/spar/test/Test/Spar/ScimSpec.hs | 7 +- tools/api-simulations/api-simulations.cabal | 8 +- tools/bonanza/bonanza.cabal | 12 +-- tools/db/auto-whitelist/auto-whitelist.cabal | 4 +- .../billing-team-member-backfill.cabal | 6 +- .../migrate-sso-feature-flag.cabal | 4 +- .../service-backfill/service-backfill.cabal | 4 +- tools/makedeb/makedeb.cabal | 6 +- tools/stern/src/Stern/API.hs | 3 +- tools/stern/src/Stern/Intra.hs | 2 +- tools/stern/src/Stern/Types.hs | 8 +- tools/stern/stern.cabal | 6 +- 80 files changed, 321 insertions(+), 272 deletions(-) diff --git a/libs/api-bot/api-bot.cabal b/libs/api-bot/api-bot.cabal index 49dbec8003e..68977a612d3 100644 --- a/libs/api-bot/api-bot.cabal +++ b/libs/api-bot/api-bot.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: ff48dbfe677cdd01dafb24662f6ef4d5e0dd7f04251cf92a8c7ed61a4787e1c0 +-- hash: e2b0b4378fe9c912993ce1a6b0ebd11f8bf68309d63f2dc15a3a1b61c6454461 name: api-bot version: 0.4.2 @@ -37,7 +37,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: HaskellNet >=0.5 , HaskellNet-SSL >=0.3 diff --git a/libs/api-client/api-client.cabal b/libs/api-client/api-client.cabal index e2fc0e8727e..900afb00350 100644 --- a/libs/api-client/api-client.cabal +++ b/libs/api-client/api-client.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: c8e4c2db3a7d0e48459ccf411e98bd1cb10b885582f6e005eebe301f3f5390ef +-- hash: 5c9e5b6c9888256963d49396679f85a9923baac2eb58250704bf8223cde92b73 name: api-client version: 0.4.2 @@ -36,7 +36,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: aeson >=0.11 , async >=2.0 diff --git a/libs/bilge/bilge.cabal b/libs/bilge/bilge.cabal index 0fa33418395..44ef91b6e1b 100644 --- a/libs/bilge/bilge.cabal +++ b/libs/bilge/bilge.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 3935614b306254149b1649f7970804c8b164d0edfee1b42192edd81220011379 +-- hash: 2f6095f5830d420a83db86b6daf3980643bccce908e1ae0439209c41b23708f9 name: bilge version: 0.22.0 @@ -35,7 +35,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: aeson >=0.6 , ansi-terminal >=0.6 diff --git a/libs/brig-types/brig-types.cabal b/libs/brig-types/brig-types.cabal index 44d51911f60..53bcdd0e1fd 100644 --- a/libs/brig-types/brig-types.cabal +++ b/libs/brig-types/brig-types.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: b7c27bea3301594e838d9d0d39612ad751a4e1e9f52276d6d2fae0c6c3f6ae4a +-- hash: 7497d04521f12339e2a8f5537dacf242839dea9034f69e67f0a254b1548cadd9 name: brig-types version: 1.35.0 @@ -45,7 +45,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields build-depends: QuickCheck >=2.9 , aeson >=0.11 @@ -98,7 +98,7 @@ test-suite brig-types-tests hs-source-dirs: test/unit default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N build-depends: QuickCheck , aeson diff --git a/libs/brig-types/src/Brig/Types/Intra.hs b/libs/brig-types/src/Brig/Types/Intra.hs index 4054470b52c..3d46458b2ba 100644 --- a/libs/brig-types/src/Brig/Types/Intra.hs +++ b/libs/brig-types/src/Brig/Types/Intra.hs @@ -119,8 +119,11 @@ instance FromJSON UserAccount where instance ToJSON UserAccount where toJSON (UserAccount u s) = - let Object o = toJSON u - in Object $ M.insert "status" (toJSON s) o + case toJSON u of + Object o -> + Object $ M.insert "status" (toJSON s) o + other -> + error $ "toJSON UserAccount: not an object: " <> show (encode other) ------------------------------------------------------------------------------- -- UserList diff --git a/libs/cargohold-types/cargohold-types.cabal b/libs/cargohold-types/cargohold-types.cabal index 69486476e5f..aa544f942c5 100644 --- a/libs/cargohold-types/cargohold-types.cabal +++ b/libs/cargohold-types/cargohold-types.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 83ee67ac57c0c2a532f6faa4eae38b3fcc19303fc6d68955ffe4bd98d248e753 +-- hash: eff079abe22cc21d655da449bb1d051e145050171695dc58b0333f9d488e3acd name: cargohold-types version: 1.5.0 @@ -27,7 +27,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: aeson >=0.6 , attoparsec >=0.10 diff --git a/libs/cassandra-util/cassandra-util.cabal b/libs/cassandra-util/cassandra-util.cabal index 6130782efeb..e07089ec5d3 100644 --- a/libs/cassandra-util/cassandra-util.cabal +++ b/libs/cassandra-util/cassandra-util.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 4b6e1302b2f3f0c59820223b656b21aeb8634a3697b272f2546dc957818a3310 +-- hash: 9d0b2c673a95e6e12bd1785bc39e04a76d7a961ae31bc856cba5021e8fae9dd2 name: cassandra-util version: 0.16.5 @@ -30,7 +30,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: aeson >=0.7 , base >=4.6 && <5.0 diff --git a/libs/cassandra-util/src/Cassandra/Schema.hs b/libs/cassandra-util/src/Cassandra/Schema.hs index 4ae67ee94d7..64243832540 100644 --- a/libs/cassandra-util/src/Cassandra/Schema.hs +++ b/libs/cassandra-util/src/Cassandra/Schema.hs @@ -2,6 +2,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +-- for ReplicationStrategy +{-# OPTIONS_GHC -Wno-partial-fields #-} -- This file is part of the Wire Server implementation. -- diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal index a332a2fe4f6..8d3377220fa 100644 --- a/libs/extended/extended.cabal +++ b/libs/extended/extended.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 6d1c11d003f9c50397c8bc6ff6b07138dc00200844cb86411aa895fa49ca81f6 +-- hash: e55322d0117b6bdd9e66d2fb1768e8c42514125904626540a436a728563609f1 name: extended version: 0.1.0 @@ -31,7 +31,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: aeson , base diff --git a/libs/federation-util/federation-util.cabal b/libs/federation-util/federation-util.cabal index 8f8a57aef2f..8f9d28983e7 100644 --- a/libs/federation-util/federation-util.cabal +++ b/libs/federation-util/federation-util.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 312f8e843a350a0a87c70b3b868a3e29f0ec6d30aaa8913ec0a40e33ba30e6bd +-- hash: d327ef72460d5f79332d80fa4a70516b7351472f50c17a8c491d28c65ec0f024 name: federation-util version: 0.1.0 @@ -28,7 +28,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: async >=2.0 , base >=4.6 && <5.0 @@ -58,7 +58,7 @@ test-suite spec hs-source-dirs: test default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck , async >=2.0 diff --git a/libs/federation-util/src/Network/Federation/Util/Internal.hs b/libs/federation-util/src/Network/Federation/Util/Internal.hs index 68a3ddf72f8..99aa578781d 100644 --- a/libs/federation-util/src/Network/Federation/Util/Internal.hs +++ b/libs/federation-util/src/Network/Federation/Util/Internal.hs @@ -122,7 +122,10 @@ orderSrvResult srvResult = do randomNumber <- randomRIO (0, total) -- Select the first record with its running sum greater -- than or equal to the random number. - let (beginning, ((priority, weight, port, domain, _) : end)) = break (\(_, _, _, _, running) -> randomNumber <= running) sublist' + let (beginning, (priority, weight, port, domain, _), end) = + case break (\(_, _, _, _, running) -> randomNumber <= running) sublist' of + (b, (c : e)) -> (b, c, e) + _ -> error "orderSrvResult: no record with running sum greater than random number" -- Remove the running total number from the remaining -- elements. let sublist'' = map (\(priority', weight', port', domain', _) -> (priority', weight', port', domain')) (concat [beginning, end]) diff --git a/libs/galley-types/galley-types.cabal b/libs/galley-types/galley-types.cabal index 2216ed181bc..099894d2ddf 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: ce281a8d6976cf975316d418abdfbf336e1faecbf8c30d8fc7743d8fa216ddbf +-- hash: fb74da023d3b1f2a3ad91fca661ee239b7010e42ec219bec603378749aafabea name: galley-types version: 0.81.0 @@ -31,7 +31,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: aeson >=0.6 , attoparsec >=0.10 @@ -71,7 +71,7 @@ test-suite galley-types-tests hs-source-dirs: test/unit default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N build-depends: QuickCheck , aeson diff --git a/libs/gundeck-types/gundeck-types.cabal b/libs/gundeck-types/gundeck-types.cabal index b8f4fa3bb5e..f743290e963 100644 --- a/libs/gundeck-types/gundeck-types.cabal +++ b/libs/gundeck-types/gundeck-types.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 3f63d2fadb0c32703d787154dd830787a80ef50e6fa8b5d3480eb2a3a6706eb5 +-- hash: 40ff305d7e94103674d24523ec4f236ceea6415b63b2bc8fbd01c8983cbe8133 name: gundeck-types version: 1.45.0 @@ -32,7 +32,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: aeson >=0.6 , attoparsec >=0.10 diff --git a/libs/imports/imports.cabal b/libs/imports/imports.cabal index fd671b53a90..ab5e1698f89 100644 --- a/libs/imports/imports.cabal +++ b/libs/imports/imports.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 46140b9b362cced4d847a47014015a2517bfaaa4203a1d359d61963e7be044cd +-- hash: 48cc1af1cc65ab98646e6a73ea655f21c8e66a15a31fd4a612c0c82173805f62 name: imports version: 0.1.0 @@ -30,7 +30,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: base , bytestring diff --git a/libs/metrics-core/metrics-core.cabal b/libs/metrics-core/metrics-core.cabal index 88911bd50b0..df6e02797bd 100644 --- a/libs/metrics-core/metrics-core.cabal +++ b/libs/metrics-core/metrics-core.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 41d05423bb5ecff238b37dda906f942b8e5688f1627637853be687ada4e61693 +-- hash: f75e1ad46dd369c71f89d022436bd5cdc3b67a36a42f8dd4068fe2d7ae4f7a43 name: metrics-core version: 0.3.2 @@ -26,7 +26,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: atomic-primops >=0.8 , base >=4.9 diff --git a/libs/metrics-wai/metrics-wai.cabal b/libs/metrics-wai/metrics-wai.cabal index e8eaca8d80c..f98c57b3154 100644 --- a/libs/metrics-wai/metrics-wai.cabal +++ b/libs/metrics-wai/metrics-wai.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 5ae11aea0f562def1900e89b7cec0809fbd3e10edc7eef00cfbfe752b06a147f +-- hash: 07d2c4f1144943967e6acfe4d6b5f0d1911443bafe33048152b872584c52db24 name: metrics-wai version: 0.5.7 @@ -30,7 +30,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path ghc-prof-options: -fprof-auto build-depends: base ==4.* diff --git a/libs/ropes/ropes.cabal b/libs/ropes/ropes.cabal index 28ecb8e1596..88c710bd2e3 100644 --- a/libs/ropes/ropes.cabal +++ b/libs/ropes/ropes.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 3f789e5caaf99371aeab04b920b5b7a1a3ea71687eeb7b49cbaeec83c6b8ed3d +-- hash: 8e1fc11eb8dfecf6b35bf33c8cd612ed3e50f371781a549f8728286a79acb547 name: ropes version: 0.4.20 @@ -28,7 +28,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: aeson >=0.6 , aws >=0.10.2 @@ -58,7 +58,7 @@ executable ropes-aws-auth-test hs-source-dirs: test/integration-aws-auth default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded build-depends: aws , base >=4 && <5 @@ -81,7 +81,7 @@ executable ropes-aws-test hs-source-dirs: test/integration-aws default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded build-depends: aws , base >=4 && <5 diff --git a/libs/sodium-crypto-sign/sodium-crypto-sign.cabal b/libs/sodium-crypto-sign/sodium-crypto-sign.cabal index 54a74ae8964..42b7f9e6e85 100644 --- a/libs/sodium-crypto-sign/sodium-crypto-sign.cabal +++ b/libs/sodium-crypto-sign/sodium-crypto-sign.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: e269c6982089a3f0f5b7e20f9c88218fed99a2344c98c4c5c75ba382789d9a90 +-- hash: 4e1ecfe06369fae6c5bc0b3616348f6dfbe2139e9fa0cdb0b91d7a415c39a6bd name: sodium-crypto-sign version: 0.1.2 @@ -26,7 +26,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path pkgconfig-depends: libsodium >= 0.4.5 build-depends: diff --git a/libs/ssl-util/ssl-util.cabal b/libs/ssl-util/ssl-util.cabal index 69cabe82e44..e58652f1c1b 100644 --- a/libs/ssl-util/ssl-util.cabal +++ b/libs/ssl-util/ssl-util.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: c47b5a68a5c4c6497c1fdf7420e4c787f72d884eda70231731a57a0d7b02bc52 +-- hash: a53a7554117a25d8613c61055b2201940de2cf03500632351755e19434bde9b5 name: ssl-util version: 0.1.0 @@ -26,7 +26,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: HsOpenSSL >=0.11 , base >=4.7 && <5 diff --git a/libs/tasty-cannon/tasty-cannon.cabal b/libs/tasty-cannon/tasty-cannon.cabal index c2c8ae2cd51..106f17e6d54 100644 --- a/libs/tasty-cannon/tasty-cannon.cabal +++ b/libs/tasty-cannon/tasty-cannon.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 245a691959757e03022c98c946bc4fe2c2bb6b1882a481d8cf576c0fdfd80064 +-- hash: 559c0395770dd830b3bf57b35148faafaee5b2bc9b40ebba6a7a12822ad39e25 name: tasty-cannon version: 0.4.0 @@ -25,7 +25,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: aeson , async diff --git a/libs/types-common-aws/types-common-aws.cabal b/libs/types-common-aws/types-common-aws.cabal index 499090de2f4..6e1b2332b8f 100644 --- a/libs/types-common-aws/types-common-aws.cabal +++ b/libs/types-common-aws/types-common-aws.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 1d709501a762db52880e7e0ab3c268832b6bee36371162d6caf4bd91536fba3b +-- hash: ae1a97df05fea5d88fcc77729a353096632bef917cdf9d363c7d79ee1bb663de name: types-common-aws version: 0.16.0 @@ -36,7 +36,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path ghc-prof-options: -fprof-auto-exported build-depends: amazonka diff --git a/libs/types-common-journal/types-common-journal.cabal b/libs/types-common-journal/types-common-journal.cabal index 48c6acc1840..6a4078f85b7 100644 --- a/libs/types-common-journal/types-common-journal.cabal +++ b/libs/types-common-journal/types-common-journal.cabal @@ -4,7 +4,7 @@ cabal-version: 1.24 -- -- see: https://github.com/sol/hpack -- --- hash: c0fe3ead4cd149cf0424226e6d130441dc44ea8538517927150a017c1a983cd6 +-- hash: 5e8377800318f44ef1a9021df8560a8fe8ea292cc6678faa740bfc7e142f7fec name: types-common-journal version: 0.1.0 @@ -40,7 +40,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -fno-warn-redundant-constraints + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -fno-warn-redundant-constraints ghc-prof-options: -fprof-auto-exported build-depends: base ==4.* diff --git a/libs/types-common/src/Data/List1.hs b/libs/types-common/src/Data/List1.hs index f1b4ba8991e..9426491fb00 100644 --- a/libs/types-common/src/Data/List1.hs +++ b/libs/types-common/src/Data/List1.hs @@ -46,6 +46,10 @@ list1 :: a -> [a] -> List1 a list1 a = List1 . (N.:|) a {-# INLINE list1 #-} +maybeList1 :: [a] -> Maybe (List1 a) +maybeList1 = fmap List1 . N.nonEmpty +{-# INLINE maybeList1 #-} + (<|) :: a -> List1 a -> List1 a (<|) a = List1 . (N.<|) a . toNonEmpty {-# INLINE (<|) #-} diff --git a/libs/types-common/types-common.cabal b/libs/types-common/types-common.cabal index d8d5b62c969..5be26464cf9 100644 --- a/libs/types-common/types-common.cabal +++ b/libs/types-common/types-common.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 507a0d8a20b432280023bd2361517ea5c10b65217930737993333a3c9910b945 +-- hash: c17e83566b787517579fe409778cca9f88b3c23e9819dfc11b8ae84572aa1c6d name: types-common version: 0.16.0 @@ -45,7 +45,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path ghc-prof-options: -fprof-auto-exported build-depends: QuickCheck >=2.9 @@ -110,7 +110,7 @@ test-suite tests hs-source-dirs: test default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded build-depends: QuickCheck , aeson diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index ff3965477f2..901da290a5a 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -202,7 +202,9 @@ errorHandlers = [ Handler $ \(x :: Wai.Error) -> pure x, Handler $ \(_ :: InvalidRequest) -> pure $ Wai.Error status400 "client-error" "Invalid Request", Handler $ \(_ :: TimeoutThread) -> pure $ Wai.Error status408 "client-error" "Request Timeout", - Handler $ \(ZlibException (-3)) -> pure $ Wai.Error status400 "client-error" "Invalid request body compression", + Handler $ \case + ZlibException (-3) -> pure $ Wai.Error status400 "client-error" "Invalid request body compression" + ZlibException _ -> pure $ Wai.Error status500 "server-error" "Server Error", Handler $ \(_ :: SomeException) -> pure $ Wai.Error status500 "server-error" "Server Error" ] {-# INLINE errorHandlers #-} diff --git a/libs/wai-utilities/wai-utilities.cabal b/libs/wai-utilities/wai-utilities.cabal index 93c35f188f8..2028f2a1e2c 100644 --- a/libs/wai-utilities/wai-utilities.cabal +++ b/libs/wai-utilities/wai-utilities.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: f808f36e1c2521e5e53b24e784dcc177e7079eab0ab2856fa8e7358f92369cdf +-- hash: 03b270072cba482a38b85bce9aa85fba04e5bd4a10561c7e636d64b797c9989a name: wai-utilities version: 0.16.1 @@ -32,7 +32,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: aeson >=0.6 , async >=2.0 diff --git a/libs/wire-api/src/Wire/API/Provider/Service.hs b/libs/wire-api/src/Wire/API/Provider/Service.hs index df541fd35fa..5cfbe7e3d63 100644 --- a/libs/wire-api/src/Wire/API/Provider/Service.hs +++ b/libs/wire-api/src/Wire/API/Provider/Service.hs @@ -175,20 +175,22 @@ instance FromJSON ServiceKeyPEM where either fail pure . runParser parser . Text.encodeUtf8 instance Arbitrary ServiceKeyPEM where - arbitrary = pure $ ServiceKeyPEM k + arbitrary = + case pemParseBS (BS.unlines key) of + Right [k] -> pure $ ServiceKeyPEM k + other -> error $ "arbitrary ServiceKeyPEM: unexpected error: " <> show other where - Right [k] = - pemParseBS . BS.unlines $ - [ "-----BEGIN PUBLIC KEY-----", - "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAu+Kg/PHHU3atXrUbKnw0", - "G06FliXcNt3lMwl2os5twEDcPPFw/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPH", - "WvUBdiLfGrZqJO223DB6D8K2Su/odmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKV", - "VPOaOzgtAB21XKRiQ4ermqgi3/njr03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiS", - "bUKr/BeArYRcjzr/h5m1In6fG/if9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg8", - "7X883H+LA/d6X5CTiPv1VMxXdBUiGPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7la", - "nQIDAQAB", - "-----END PUBLIC KEY-----" - ] + key = + [ "-----BEGIN PUBLIC KEY-----", + "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAu+Kg/PHHU3atXrUbKnw0", + "G06FliXcNt3lMwl2os5twEDcPPFw/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPH", + "WvUBdiLfGrZqJO223DB6D8K2Su/odmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKV", + "VPOaOzgtAB21XKRiQ4ermqgi3/njr03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiS", + "bUKr/BeArYRcjzr/h5m1In6fG/if9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg8", + "7X883H+LA/d6X5CTiPv1VMxXdBUiGPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7la", + "nQIDAQAB", + "-----END PUBLIC KEY-----" + ] -------------------------------------------------------------------------------- -- Service diff --git a/libs/wire-api/src/Wire/API/Team.hs b/libs/wire-api/src/Wire/API/Team.hs index e424f261f8f..0e8aa37e3e0 100644 --- a/libs/wire-api/src/Wire/API/Team.hs +++ b/libs/wire-api/src/Wire/API/Team.hs @@ -47,6 +47,7 @@ module Wire.API.Team newTeamIcon, newTeamIconKey, newTeamMembers, + newTeamJson, -- * TeamUpdateData TeamUpdateData (..), diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index ee3bfd9f392..e0f6a886ddb 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -106,7 +106,7 @@ import Imports import qualified Test.QuickCheck as QC import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) import Wire.API.Provider.Service (ServiceRef, modelServiceRef) -import Wire.API.Team (BindingNewTeam, modelNewBindingTeam) +import Wire.API.Team (BindingNewTeam (BindingNewTeam), modelNewBindingTeam, newTeamJson) import Wire.API.User.Activation (ActivationCode) import Wire.API.User.Auth (CookieLabel) import Wire.API.User.Identity @@ -701,11 +701,10 @@ data BindingNewTeamUser = BindingNewTeamUser deriving (Arbitrary) via (GenericUniform BindingNewTeamUser) instance ToJSON BindingNewTeamUser where - toJSON (BindingNewTeamUser t c) = - let (Object t') = toJSON t - in object $ - "currency" .= c - # HashMap.toList t' + toJSON (BindingNewTeamUser (BindingNewTeam t) c) = + object $ + "currency" .= c + # newTeamJson t instance FromJSON BindingNewTeamUser where parseJSON j@(Object o) = do diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 314b0f24326..cc30f4b145e 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: b89d6631f18653ec03e69a4a98f3c9f791e886de9a485772e9bff78fbf8a1fc4 +-- hash: 0b7804e84887d0d642757ae3d7c847a618e620969c1980684e728683b4be5d3e name: wire-api version: 0.1.0 @@ -72,7 +72,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: QuickCheck >=2.14 , aeson >=0.6 @@ -130,7 +130,7 @@ test-suite wire-api-tests hs-source-dirs: test/unit default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N build-depends: aeson >=0.6 , aeson-qq diff --git a/libs/zauth/zauth.cabal b/libs/zauth/zauth.cabal index 658aabb3e56..6d9a1ef5235 100644 --- a/libs/zauth/zauth.cabal +++ b/libs/zauth/zauth.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 81125daf636e3a223f61c427a999cc9dad34256ac9c1fea63e8863e0c0acaf27 +-- hash: 951765034b4ec8f2fde4635ce261a77b085fef580d65226414206f053c86bec4 name: zauth version: 0.10.3 @@ -31,7 +31,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields build-depends: attoparsec >=0.11 , base >=4.6 && <5 @@ -58,7 +58,7 @@ executable zauth hs-source-dirs: main default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: base , base64-bytestring @@ -84,7 +84,7 @@ test-suite zauth-unit hs-source-dirs: test default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: base , bytestring diff --git a/package-defaults.yaml b/package-defaults.yaml index 73952a67d7f..07dfcbac0c0 100644 --- a/package-defaults.yaml +++ b/package-defaults.yaml @@ -1,6 +1,9 @@ ghc-options: - -O2 - -Wall +- -Wincomplete-uni-patterns +- -Wincomplete-record-updates +- -Wpartial-fields - -fwarn-tabs # These errors pop up from time to time but haven't caused any serious trouble yet - -optP-Wno-nonportable-include-path diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 977971dd397..bfce591b023 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -4,7 +4,7 @@ cabal-version: 2.0 -- -- see: https://github.com/sol/hpack -- --- hash: dcf98702ec8a0c8e7492ffa8ae6df1a373cba27a6c4d46cf36f575ced7818c44 +-- hash: b6a944d4d084f81687d2b816c99a5fe95cdd1d7c6aa866bf3f709981c28fe442 name: brig version: 1.35.0 @@ -100,7 +100,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields build-depends: HaskellNet >=0.3 , HaskellNet-SSL >=0.3 @@ -234,7 +234,7 @@ library brig-index-lib hs-source-dirs: index/src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields build-depends: aeson , base @@ -261,7 +261,7 @@ executable brig other-modules: Paths_brig default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N1 -with-rtsopts=-T -rtsopts + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N1 -with-rtsopts=-T -rtsopts build-depends: HsOpenSSL , base @@ -277,7 +277,7 @@ executable brig-index other-modules: Paths_brig default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N build-depends: base , brig-index-lib @@ -315,7 +315,7 @@ executable brig-integration hs-source-dirs: test/integration default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields build-depends: HsOpenSSL , aeson @@ -441,7 +441,7 @@ executable brig-schema hs-source-dirs: schema/src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields build-depends: base , cassandra-util >=0.12 @@ -464,7 +464,7 @@ test-suite brig-tests hs-source-dirs: test/unit default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N build-depends: aeson , base diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 17caa5111a9..c1eaf44e849 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -169,7 +169,7 @@ updateSearchIndex orig e = case e of UserResumed {} -> Search.reindex orig UserActivated {} -> Search.reindex orig UserDeleted {} -> Search.reindex orig - UserUpdated {..} -> do + UserUpdated UserUpdatedData {..} -> do let interesting = or [ isJust eupName, @@ -180,13 +180,20 @@ updateSearchIndex orig e = case e of journalEvent :: UserId -> UserEvent -> AppIO () journalEvent orig e = case e of - UserActivated acc -> Journal.userActivate (accountUser acc) - UserUpdated {eupName = Just name} -> Journal.userUpdate orig Nothing Nothing (Just name) - UserUpdated {eupLocale = Just loc} -> Journal.userUpdate orig Nothing (Just loc) Nothing - UserIdentityUpdated _ (Just em) _ -> Journal.userUpdate orig (Just em) Nothing Nothing - UserIdentityRemoved _ (Just em) _ -> Journal.userEmailRemove orig em - UserDeleted {} -> Journal.userDelete orig - _ -> return () + UserActivated acc -> + Journal.userActivate (accountUser acc) + UserUpdated UserUpdatedData {eupName = Just name} -> + Journal.userUpdate orig Nothing Nothing (Just name) + UserUpdated UserUpdatedData {eupLocale = Just loc} -> + Journal.userUpdate orig Nothing (Just loc) Nothing + UserIdentityUpdated (UserIdentityUpdatedData _ (Just em) _) -> + Journal.userUpdate orig (Just em) Nothing Nothing + UserIdentityRemoved (UserIdentityRemovedData _ (Just em) _) -> + Journal.userEmailRemove orig em + UserDeleted {} -> + Journal.userDelete orig + _ -> + return () ------------------------------------------------------------------------------- -- Low-Level Event Notification @@ -202,7 +209,7 @@ dispatchNotifications orig conn e = case e of LegalHoldClientRequested {} -> notifyContacts event orig Push.RouteAny conn UserLegalHoldDisabled {} -> notifyContacts event orig Push.RouteAny conn UserLegalHoldEnabled {} -> notifyContacts event orig Push.RouteAny conn - UserUpdated {..} + UserUpdated UserUpdatedData {..} -- This relies on the fact that we never change the locale AND something else. | isJust eupLocale -> notifySelf event orig Push.RouteDirect conn | otherwise -> notifyContacts event orig Push.RouteDirect conn @@ -355,7 +362,7 @@ toPushFormat (UserEvent (UserActivated (UserAccount u _))) = [ "type" .= ("user.activate" :: Text), "user" .= SelfProfile u ] -toPushFormat (UserEvent (UserUpdated i n pic acc ass hdl loc mb)) = +toPushFormat (UserEvent (UserUpdated (UserUpdatedData i n pic acc ass hdl loc mb))) = Just $ M.fromList [ "type" .= ("user.update" :: Text), @@ -372,7 +379,7 @@ toPushFormat (UserEvent (UserUpdated i n pic acc ass hdl loc mb)) = # [] ) ] -toPushFormat (UserEvent UserIdentityUpdated {..}) = +toPushFormat (UserEvent (UserIdentityUpdated UserIdentityUpdatedData {..})) = Just $ M.fromList [ "type" .= ("user.update" :: Text), @@ -384,7 +391,7 @@ toPushFormat (UserEvent UserIdentityUpdated {..}) = # [] ) ] -toPushFormat (UserEvent (UserIdentityRemoved i e p)) = +toPushFormat (UserEvent (UserIdentityRemoved (UserIdentityRemovedData i e p))) = Just $ M.fromList [ "type" .= ("user.identity-remove" :: Text), diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 0c1f100a8b5..ce8f6c393b9 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -65,8 +65,7 @@ import qualified Data.Conduit.List as C import Data.Hashable (hash) import Data.Id import qualified Data.List as List -import Data.List.NonEmpty (nonEmpty) -import Data.List1 (List1 (..)) +import Data.List1 (maybeList1) import qualified Data.Map.Strict as Map import Data.Misc ((<$$>), Fingerprint (..), Rsa) import Data.Predicate @@ -591,11 +590,11 @@ updateServiceConn pid sid upd = do scon <- DB.lookupServiceConn pid sid >>= maybeServiceNotFound svc <- DB.lookupServiceProfile pid sid >>= maybeServiceNotFound let newBaseUrl = updateServiceConnUrl upd - let newTokens = List1 <$> (nonEmpty . fromRange =<< updateServiceConnTokens upd) + let newTokens = maybeList1 . fromRange =<< updateServiceConnTokens upd let newEnabled = updateServiceConnEnabled upd let newKeyPems = fromRange <$> updateServiceConnKeys upd keys <- forM newKeyPems (mapM (validateServiceKey >=> maybeInvalidServiceKey)) - let newKeys = List1 <$> (keys >>= nonEmpty) + let newKeys = keys >>= maybeList1 let newFps = fmap snd <$> newKeys DB.updateServiceConn pid sid newBaseUrl newTokens newKeys newEnabled let scon' = diff --git a/services/brig/src/Brig/TURN/API.hs b/services/brig/src/Brig/TURN/API.hs index a353b31ed7c..ec0785cc0bd 100644 --- a/services/brig/src/Brig/TURN/API.hs +++ b/services/brig/src/Brig/TURN/API.hs @@ -130,8 +130,8 @@ newConfig env limit = do -- (see property tests in brig-types) -- since the input is List1 and limit is in Range 1 10 -- it should also be safe to assume the returning list has length >= 1 - let (x : xs) = Public.limitServers (toList uris) (fromRange lim) - List1.list1 x xs + List1.maybeList1 (Public.limitServers (toList uris) (fromRange lim)) + & fromMaybe (error "newConfig:limitedList: empty list of servers") genUsername :: Word32 -> MWC.GenIO -> IO Public.TurnUsername genUsername ttl prng = do rnd <- view (packedBytes . utf8) <$> replicateM 16 (MWC.uniformR (97, 122) prng) diff --git a/services/brig/src/Brig/User/Event.hs b/services/brig/src/Brig/User/Event.hs index 2941f57d279..50569d494ea 100644 --- a/services/brig/src/Brig/User/Event.hs +++ b/services/brig/src/Brig/User/Event.hs @@ -43,27 +43,9 @@ data UserEvent UserResumed !UserId | -- | The user account has been deleted. UserDeleted !UserId - | UserUpdated - { eupId :: !UserId, - eupName :: !(Maybe Name), - -- | DEPRECATED - eupPict :: !(Maybe Pict), - eupAccentId :: !(Maybe ColourId), - eupAssets :: !(Maybe [Asset]), - eupHandle :: !(Maybe Handle), - eupLocale :: !(Maybe Locale), - eupManagedBy :: !(Maybe ManagedBy) - } - | UserIdentityUpdated - { eiuId :: !UserId, - eiuEmail :: !(Maybe Email), - eiuPhone :: !(Maybe Phone) - } - | UserIdentityRemoved - { eirId :: !UserId, - eirEmail :: !(Maybe Email), - eirPhone :: !(Maybe Phone) - } + | UserUpdated !UserUpdatedData + | UserIdentityUpdated !UserIdentityUpdatedData + | UserIdentityRemoved !UserIdentityRemovedData | UserLegalHoldDisabled !UserId | UserLegalHoldEnabled !UserId | LegalHoldClientRequested LegalHoldClientRequestedData @@ -83,6 +65,33 @@ data ClientEvent = ClientAdded !UserId !Client | ClientRemoved !UserId !Client +data UserUpdatedData = UserUpdatedData + { eupId :: !UserId, + eupName :: !(Maybe Name), + -- | DEPRECATED + eupPict :: !(Maybe Pict), + eupAccentId :: !(Maybe ColourId), + eupAssets :: !(Maybe [Asset]), + eupHandle :: !(Maybe Handle), + eupLocale :: !(Maybe Locale), + eupManagedBy :: !(Maybe ManagedBy) + } + deriving stock (Show) + +data UserIdentityUpdatedData = UserIdentityUpdatedData + { eiuId :: !UserId, + eiuEmail :: !(Maybe Email), + eiuPhone :: !(Maybe Phone) + } + deriving stock (Show) + +data UserIdentityRemovedData = UserIdentityRemovedData + { eirId :: !UserId, + eirEmail :: !(Maybe Email), + eirPhone :: !(Maybe Phone) + } + deriving stock (Show) + data LegalHoldClientRequestedData = LegalHoldClientRequestedData { lhcTargetUser :: !UserId, lhcLastPrekey :: !LastPrekey, @@ -91,38 +100,49 @@ data LegalHoldClientRequestedData = LegalHoldClientRequestedData deriving stock (Show) emailRemoved :: UserId -> Email -> UserEvent -emailRemoved u e = UserIdentityRemoved u (Just e) Nothing +emailRemoved u e = + UserIdentityRemoved $ UserIdentityRemovedData u (Just e) Nothing phoneRemoved :: UserId -> Phone -> UserEvent -phoneRemoved u p = UserIdentityRemoved u Nothing (Just p) +phoneRemoved u p = + UserIdentityRemoved $ UserIdentityRemovedData u Nothing (Just p) emailUpdated :: UserId -> Email -> UserEvent -emailUpdated u e = UserIdentityUpdated u (Just e) Nothing +emailUpdated u e = + UserIdentityUpdated $ UserIdentityUpdatedData u (Just e) Nothing phoneUpdated :: UserId -> Phone -> UserEvent -phoneUpdated u p = UserIdentityUpdated u Nothing (Just p) +phoneUpdated u p = + UserIdentityUpdated $ UserIdentityUpdatedData u Nothing (Just p) handleUpdated :: UserId -> Handle -> UserEvent -handleUpdated u h = (emptyUpdate u) {eupHandle = Just h} +handleUpdated u h = + UserUpdated $ (emptyUserUpdatedData u) {eupHandle = Just h} localeUpdate :: UserId -> Locale -> UserEvent -localeUpdate u loc = (emptyUpdate u) {eupLocale = Just loc} +localeUpdate u loc = + UserUpdated $ (emptyUserUpdatedData u) {eupLocale = Just loc} managedByUpdate :: UserId -> ManagedBy -> UserEvent -managedByUpdate u mb = (emptyUpdate u) {eupManagedBy = Just mb} +managedByUpdate u mb = + UserUpdated $ (emptyUserUpdatedData u) {eupManagedBy = Just mb} profileUpdated :: UserId -> UserUpdate -> UserEvent profileUpdated u UserUpdate {..} = - (emptyUpdate u) - { eupName = uupName, - eupPict = uupPict, - eupAccentId = uupAccentId, - eupAssets = uupAssets - } + UserUpdated $ + (emptyUserUpdatedData u) + { eupName = uupName, + eupPict = uupPict, + eupAccentId = uupAccentId, + eupAssets = uupAssets + } emptyUpdate :: UserId -> UserEvent -emptyUpdate u = - UserUpdated +emptyUpdate = UserUpdated . emptyUserUpdatedData + +emptyUserUpdatedData :: UserId -> UserUpdatedData +emptyUserUpdatedData u = + UserUpdatedData { eupId = u, eupName = Nothing, eupPict = Nothing, @@ -142,9 +162,9 @@ userEventUserId (UserActivated u) = userId (accountUser u) userEventUserId (UserSuspended u) = u userEventUserId (UserResumed u) = u userEventUserId (UserDeleted u) = u -userEventUserId UserUpdated {..} = eupId -userEventUserId UserIdentityUpdated {..} = eiuId -userEventUserId UserIdentityRemoved {..} = eirId +userEventUserId (UserUpdated u) = eupId u +userEventUserId (UserIdentityUpdated u) = eiuId u +userEventUserId (UserIdentityRemoved u) = eirId u userEventUserId (UserLegalHoldDisabled uid) = uid userEventUserId (UserLegalHoldEnabled uid) = uid userEventUserId (LegalHoldClientRequested dat) = lhcTargetUser dat diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 7199b6b8078..fe2722981c2 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. -- diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index 76edf206bfb..de32d2c5297 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 3870f47777e..393c64a2769 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index c616a6b868c..9dfc34a07f7 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 29f3f0e9637..81940b583b0 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index 26704200e73..64b18985646 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. -- diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index 9c16a052f00..2295ad6207c 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index eaf5af64527..1799f762b45 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH diff --git a/services/brig/test/integration/API/User/PasswordReset.hs b/services/brig/test/integration/API/User/PasswordReset.hs index 41459719c07..fa5351856ed 100644 --- a/services/brig/test/integration/API/User/PasswordReset.hs +++ b/services/brig/test/integration/API/User/PasswordReset.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index b8d217522d7..433842a5c06 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH diff --git a/services/cannon/cannon.cabal b/services/cannon/cannon.cabal index b5a5bd7bde1..3bc38ecb9b4 100644 --- a/services/cannon/cannon.cabal +++ b/services/cannon/cannon.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 6a10bea5010160e4364ac754dd26e5cb5f2d4dd49f19522ce444542839a7df37 +-- hash: a8aa45b1a83a1c40bf95cfc76314b18583ed21a857eeca5e6598a89e4d164313 name: cannon version: 0.31.0 @@ -40,7 +40,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: aeson >=0.11 , api-field-json-th >=0.1.0.2 @@ -92,7 +92,7 @@ executable cannon other-modules: Paths_cannon default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T -with-rtsopts=-M1g -with-rtsopts=-ki4k + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T -with-rtsopts=-M1g -with-rtsopts=-ki4k build-depends: base , cannon @@ -113,7 +113,7 @@ test-suite cannon-tests hs-source-dirs: test default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N build-depends: QuickCheck >=2.7 , async diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index ef29cf433f2..c31d64b1ca2 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 28ef528284092ba80ae2598560748d825507f73b503853dd8c3031f12cd49dc5 +-- hash: 7a319e64df8c4523bb37b4ce4f2249a99ac0db1b935aa093e8d781b726fab68a name: cargohold version: 1.5.0 @@ -45,7 +45,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: HsOpenSSL >=0.11 , HsOpenSSL-x509-system >=0.1 @@ -115,7 +115,7 @@ executable cargohold other-modules: Paths_cargohold default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-T + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-T build-depends: HsOpenSSL >=0.11 , aeson >=0.11 @@ -156,7 +156,7 @@ executable cargohold-integration hs-source-dirs: test/integration default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: HsOpenSSL >=0.11 , aeson >=0.11 diff --git a/services/cargohold/test/integration/API/V3.hs b/services/cargohold/test/integration/API/V3.hs index 114ededb432..cc8161de81a 100644 --- a/services/cargohold/test/integration/API/V3.hs +++ b/services/cargohold/test/integration/API/V3.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index 3d6de6042b6..0b26b11d71a 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 03ec0f9a11f05b34c7cf2216747ff7a75c79d30a243ea9b589393ce04e89fc89 +-- hash: 05e45399becaef2bbecfa958ec4d5633900e2e1d8e1c1a2e7ecd2afbdbc2404f name: federator version: 1.0.0 @@ -29,7 +29,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: QuickCheck , aeson @@ -69,7 +69,7 @@ executable federator hs-source-dirs: exec default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N1 -with-rtsopts=-T -rtsopts + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N1 -with-rtsopts=-T -rtsopts build-depends: QuickCheck , aeson diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 633e053fb66..68621a09ea1 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 92456c44f0413d6ce65ee41f0b151adcc8a84a465cd9b05e3be17b1917c8f551 +-- hash: 79de6e0df943f81b06a385534f150c05146658d23c9b577b6e67d66cb9c67625 name: galley version: 0.83.0 @@ -71,10 +71,11 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: HsOpenSSL >=0.11 , HsOpenSSL-x509-system >=0.1 + , QuickCheck >=2.14 , aeson >=0.11 , amazonka >=1.4.5 , amazonka-sqs >=1.4.5 @@ -163,7 +164,7 @@ executable galley other-modules: Paths_galley default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-T -rtsopts + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-T -rtsopts build-depends: HsOpenSSL , base @@ -197,7 +198,7 @@ executable galley-integration hs-source-dirs: test/integration default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded build-depends: HsOpenSSL , HsOpenSSL-x509-system @@ -284,7 +285,7 @@ executable galley-migrate-data hs-source-dirs: migrate-data/src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: base , cassandra-util @@ -339,7 +340,7 @@ executable galley-schema hs-source-dirs: schema/src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: base , cassandra-util @@ -365,7 +366,7 @@ test-suite galley-types-tests hs-source-dirs: test/unit default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N build-depends: base , containers diff --git a/services/galley/package.yaml b/services/galley/package.yaml index 16fbc6b7ffc..de589aedf05 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -61,6 +61,7 @@ library: - prometheus-client - protobuf >=0.2 - proto-lens >=0.2 + - QuickCheck >=2.14 - resourcet >=1.1 - retry >=0.5 - safe-exceptions >=0.1 diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index da0cc876d7f..4764e27e3db 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -29,7 +29,7 @@ import Control.Monad.Catch (MonadCatch, throwM) import Data.Id import Data.IdMapping (MappedOrLocalId (Local), partitionMappedOrLocalIds) import Data.List.NonEmpty (nonEmpty) -import Data.List1 (List1 (List1), list1) +import Data.List1 (List1, list1, maybeList1) import Data.Range import Data.String.Conversions (cs) import qualified Galley.API.Clients as Clients @@ -282,7 +282,7 @@ rmUser user conn = do . set Intra.pushRoute Intra.RouteDirect | otherwise -> return Nothing for_ - (List1 <$> nonEmpty (catMaybes pp)) + (maybeList1 (catMaybes pp)) Intra.push unless (null $ Cql.result ids) $ leaveConversations u =<< Cql.liftClient (Cql.nextPage ids) diff --git a/services/galley/src/Galley/API/Swagger.hs b/services/galley/src/Galley/API/Swagger.hs index 5bbb8d4b094..ab4ec1a8e86 100644 --- a/services/galley/src/Galley/API/Swagger.hs +++ b/services/galley/src/Galley/API/Swagger.hs @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -Wno-orphans -Wno-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- This file is part of the Wire Server implementation. -- @@ -34,7 +35,6 @@ import Brig.Types.Team.LegalHold import Control.Lens import Data.Aeson (toJSON) import Data.Aeson (Value (..)) -import Data.ByteString.Conversion (fromByteString) import Data.HashMap.Strict.InsOrd import Data.Id import Data.LegalHold @@ -42,12 +42,13 @@ import Data.Misc import Data.Proxy import Data.Swagger hiding (Header (..)) import Data.Text as Text (unlines) -import Data.Text.Encoding (encodeUtf8) -import Data.UUID (UUID, fromText) +import Data.UUID (UUID) import Imports import Servant.API hiding (Header) import Servant.Swagger -import URI.ByteString.QQ (uri) +import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck.Gen as QC +import qualified Test.QuickCheck.Random as QC import Wire.API.Team.Feature {- @@ -159,7 +160,7 @@ instance ToSchema ViewLegalHoldService where pure $ NamedSchema (Just "ViewLegalHoldService") $ mempty & properties .~ properties_ - & example .~ example_ + & example .~ Just (toJSON example_) & required .~ ["status"] & minProperties .~ Just 1 & maxProperties .~ Just 2 @@ -171,27 +172,9 @@ instance ToSchema ViewLegalHoldService where [ ("status", Inline (toSchema (Proxy @MockViewLegalHoldServiceStatus))), ("settings", Inline (toSchema (Proxy @ViewLegalHoldServiceInfo))) ] - example_ :: Maybe Value example_ = - Just . toJSON $ - ViewLegalHoldService (ViewLegalHoldServiceInfo (Id tid) lhuri fpr tok key) - where - tok = ServiceToken "sometoken" - Just key = - fromByteString . encodeUtf8 $ Text.unlines $ - [ "-----BEGIN PUBLIC KEY-----", - "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAu+Kg/PHHU3atXrUbKnw0", - "G06FliXcNt3lMwl2os5twEDcPPFw/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPH", - "WvUBdiLfGrZqJO223DB6D8K2Su/odmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKV", - "VPOaOzgtAB21XKRiQ4ermqgi3/njr03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiS", - "bUKr/BeArYRcjzr/h5m1In6fG/if9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg8", - "7X883H+LA/d6X5CTiPv1VMxXdBUiGPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7la", - "nQIDAQAB", - "-----END PUBLIC KEY-----" - ] - Just tid = fromText "7fff70c6-7b9c-11e9-9fbd-f3cc32e6bbec" - Right lhuri = mkHttpsUrl [uri|https://example.com/|] - fpr = Fingerprint "\138\140\183\EM\226#\129\EOTl\161\183\246\DLE\161\142\220\239&\171\241h|\\GF\172\180O\129\DC1!\159" + ViewLegalHoldService + (ViewLegalHoldServiceInfo arbitraryExample arbitraryExample arbitraryExample (ServiceToken "sometoken") arbitraryExample) -- | this type is only introduce locally here to generate the schema for 'ViewLegalHoldService'. data MockViewLegalHoldServiceStatus = Configured | NotConfigured | Disabled @@ -224,7 +207,7 @@ instance ToSchema ViewLegalHoldServiceInfo where pure $ NamedSchema (Just "ViewLegalHoldServiceInfo") $ mempty & properties .~ properties_ - & example .~ example_ + & example .~ Just (toJSON example_) & required .~ ["team_id", "base_url", "fingerprint", "auth_token", "public_key"] & type_ .~ Just SwaggerObject where @@ -237,27 +220,9 @@ instance ToSchema ViewLegalHoldServiceInfo where ("auth_token", Inline (toSchema (Proxy @(ServiceToken)))), ("public_key", Inline (toSchema (Proxy @(ServiceKeyPEM)))) ] - example_ :: Maybe Value example_ = - Just . toJSON $ - ViewLegalHoldServiceInfo (Id tid) lhuri fpr tok key - where - tok = ServiceToken "sometoken" - Just key = - fromByteString . encodeUtf8 $ Text.unlines $ - [ "-----BEGIN PUBLIC KEY-----", - "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAu+Kg/PHHU3atXrUbKnw0", - "G06FliXcNt3lMwl2os5twEDcPPFw/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPH", - "WvUBdiLfGrZqJO223DB6D8K2Su/odmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKV", - "VPOaOzgtAB21XKRiQ4ermqgi3/njr03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiS", - "bUKr/BeArYRcjzr/h5m1In6fG/if9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg8", - "7X883H+LA/d6X5CTiPv1VMxXdBUiGPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7la", - "nQIDAQAB", - "-----END PUBLIC KEY-----" - ] - Just tid = fromText "7fff70c6-7b9c-11e9-9fbd-f3cc32e6bbec" - Right lhuri = mkHttpsUrl [uri|https://example.com/|] - fpr = Fingerprint "\138\140\183\EM\226#\129\EOTl\161\183\246\DLE\161\142\220\239&\171\241h|\\GF\172\180O\129\DC1!\159" + ViewLegalHoldService + (ViewLegalHoldServiceInfo arbitraryExample arbitraryExample arbitraryExample (ServiceToken "sometoken") arbitraryExample) instance ToSchema TeamFeatureStatus where declareNamedSchema _ = @@ -372,6 +337,9 @@ instance ToSchema LastPrekey where ---------------------------------------------------------------------- -- helpers +arbitraryExample :: QC.Arbitrary a => a +arbitraryExample = QC.unGen QC.arbitrary (QC.mkQCGen 0) 30 + camelToUnderscore :: String -> String camelToUnderscore = concatMap go . (ix 0 %~ toLower) where diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index b4300f775ad..135829d5d05 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 82cb1f86335..97ceec2b938 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 081547dd04e..783dd1dcf47 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -- This file is part of the Wire Server implementation. diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 0d4993df4f5..e2cdaa04de7 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index afcf51c792b..0152d2726be 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: f23e304cc1c753624feaa613a5e9d449d67fa4604f92a9a11895c310877bdaf3 +-- hash: 1af4e3338a6ac8d494ebb8f9b4adfc3f786c87b1919e63c73841e9d4be6c7811 name: gundeck version: 1.45.0 @@ -59,7 +59,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -fwarn-incomplete-uni-patterns + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -fwarn-incomplete-uni-patterns build-depends: HsOpenSSL >=0.11 , aeson >=0.11 @@ -138,7 +138,7 @@ executable gundeck other-modules: Paths_gundeck default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-T + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-T build-depends: HsOpenSSL , base @@ -165,7 +165,7 @@ executable gundeck-integration hs-source-dirs: test/integration default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded build-depends: HUnit , HsOpenSSL @@ -226,7 +226,7 @@ executable gundeck-schema hs-source-dirs: schema/src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded build-depends: base , cassandra-util @@ -255,7 +255,7 @@ test-suite gundeck-tests hs-source-dirs: test/unit default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded build-depends: HsOpenSSL , MonadRandom @@ -307,7 +307,7 @@ benchmark gundeck-bench hs-source-dirs: test/bench default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: HsOpenSSL , aeson diff --git a/services/gundeck/test/unit/ThreadBudget.hs b/services/gundeck/test/unit/ThreadBudget.hs index d28e4de5bf9..7bd07c4c3b8 100644 --- a/services/gundeck/test/unit/ThreadBudget.hs +++ b/services/gundeck/test/unit/ThreadBudget.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -- This file is part of the Wire Server implementation. @@ -205,7 +206,7 @@ data Response r = InitResponse (State r) | RunResponse | WaitResponse - | MeasureResponse {rspConcreteRunning :: Int} + | MeasureResponse Int -- concrete running threads deriving (Show, Generic, Generic1, Rank2.Functor, Rank2.Foldable, Rank2.Traversable) generator :: HasCallStack => Model Symbolic -> Maybe (Gen (Command Symbolic)) @@ -248,14 +249,14 @@ semantics (Wait _ howlong) = -- 'Measure' looks at the concrete state and records it into the model. semantics (Measure (opaque -> (tbs, _, _))) = do - rspConcreteRunning <- budgetSpent tbs - pure MeasureResponse {..} + concreteRunning <- budgetSpent tbs + pure (MeasureResponse concreteRunning) transition :: HasCallStack => Model r -> Command r -> Response r -> Model r transition (Model Nothing) (Init _) (InitResponse st) = Model (Just st) transition (Model (Just st)) Run {} RunResponse = Model (Just st) transition (Model (Just st)) Wait {} WaitResponse = Model (Just st) -transition (Model (Just st)) Measure {} MeasureResponse {..} = Model (Just st) +transition (Model (Just st)) Measure {} MeasureResponse {} = Model (Just st) transition _ _ _ = error "impossible." precondition :: HasCallStack => Model Symbolic -> Command Symbolic -> Logic @@ -265,19 +266,19 @@ postcondition :: HasCallStack => Model Concrete -> Command Concrete -> Response postcondition (Model Nothing) Init {} InitResponse {} = Top postcondition (Model (Just _)) Run {} RunResponse {} = Top postcondition (Model (Just _)) Wait {} WaitResponse {} = Top -postcondition model@(Model (Just _)) cmd@Measure {} resp@MeasureResponse {..} = +postcondition model@(Model (Just _)) cmd@Measure {} resp@(MeasureResponse concreteRunning) = threadLimitExceeded where Model (Just state) = transition model cmd resp - rspThreadLimit :: Int - rspThreadLimit = case opaque state of + threadLimit :: Int + threadLimit = case opaque state of (tbs, _, _) -> tbs ^?! Control.Lens.to threadBudgetLimits . limitHard . _Just -- number of running threads is never above the limit. - threadLimitExceeded = Annotate "thread limit exceeded" $ rspConcreteRunning .<= rspThreadLimit + threadLimitExceeded = Annotate "thread limit exceeded" $ concreteRunning .<= threadLimit -- FUTUREWORK: check that the number of running threads matches the model exactly. looks -- plausible, but when i tried to make the model rich enough to express this test i didn't -- manage to sort out the timing. --- syncNumRunning = Annotate "out of sync" $ rspConcreteRunning .== rspModelRunning +-- syncNumRunning = Annotate "out of sync" $ concreteRunning .== modelRunning postcondition m c r = error $ "impossible: " <> show (m, c, r) @@ -286,9 +287,7 @@ mock (Model Nothing) (Init _) = InitResponse <$> genSym mock (Model (Just _)) Run {} = pure RunResponse mock (Model (Just _)) Wait {} = pure WaitResponse -mock (Model (Just _)) Measure {} = pure MeasureResponse {..} - where - rspConcreteRunning = undefined +mock (Model (Just _)) Measure {} = pure (MeasureResponse undefined) -- FUTUREWORK: mock is cool because if we do this right, it gives us a quickcheck- -- validated mock component that we can use in other tests. it appears it's not needed in -- the tests in this module, though, and we will need to keep track of more of the diff --git a/services/proxy/proxy.cabal b/services/proxy/proxy.cabal index aaa9aef1b21..5608502a692 100644 --- a/services/proxy/proxy.cabal +++ b/services/proxy/proxy.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 637d4e18d3cfc3d03b97e5f8d06121277c14d95cb66c5754b14a3db160ac9bfd +-- hash: c7d7601ddb7cd8d1b3e04df779230b3d23b949ee6b9905eab1496a2a9b872214 name: proxy version: 0.9.0 @@ -36,7 +36,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields build-depends: aeson >=1.0 , base >=4.6 && <5 @@ -78,7 +78,7 @@ executable proxy other-modules: Paths_proxy default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-T + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-T build-depends: base , extended diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 63c085843a6..70816d58644 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: e6e868da454f0bfa37e1a2dc1bd7710aafda8976e37a198e0f4ea77e6a90d8fd +-- hash: 84ff7e7ee95f7419098b8029990a04ec98e64a1ed2ea41c534bea60d87be1a33 name: spar version: 0.1 @@ -44,7 +44,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -j -Wno-redundant-constraints -Werror + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -j -Wno-redundant-constraints -Werror build-depends: HsOpenSSL , aeson @@ -122,7 +122,7 @@ executable spar hs-source-dirs: exec default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -j -Wno-redundant-constraints -Werror -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -j -Wno-redundant-constraints -Werror -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T build-depends: HsOpenSSL , aeson @@ -213,7 +213,7 @@ executable spar-integration hs-source-dirs: test-integration default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -j -Wno-redundant-constraints -Werror -threaded -rtsopts -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -j -Wno-redundant-constraints -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: HsOpenSSL , MonadRandom @@ -316,7 +316,7 @@ executable spar-schema hs-source-dirs: schema/src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -j -Wno-redundant-constraints -Werror -threaded -rtsopts -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -j -Wno-redundant-constraints -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: HsOpenSSL , aeson @@ -402,7 +402,7 @@ test-suite spec hs-source-dirs: test default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -j -Wno-redundant-constraints -Werror -threaded -rtsopts -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -j -Wno-redundant-constraints -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: HsOpenSSL , QuickCheck diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 5a32c7a4955..10ad6ab4513 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH diff --git a/services/spar/test-integration/Test/Spar/AppSpec.hs b/services/spar/test-integration/Test/Spar/AppSpec.hs index 39c91533661..d49246c7b8e 100644 --- a/services/spar/test-integration/Test/Spar/AppSpec.hs +++ b/services/spar/test-integration/Test/Spar/AppSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. -- diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index 309e4d86994..d451fd8252d 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. -- diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 3599d1159f1..5fd52217759 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. -- diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 3a942c17fa5..3f005c1843a 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. -- diff --git a/services/spar/test/Test/Spar/ScimSpec.hs b/services/spar/test/Test/Spar/ScimSpec.hs index 6388a768b8f..d7a6605550c 100644 --- a/services/spar/test/Test/Spar/ScimSpec.hs +++ b/services/spar/test/Test/Spar/ScimSpec.hs @@ -8,7 +8,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- This file is part of the Wire Server implementation. -- @@ -34,10 +35,8 @@ import Brig.Types.User (RichField (..), RichInfo (..)) import Data.Aeson (eitherDecode', encode, parseJSON) import Data.Aeson.QQ (aesonQQ) import qualified Data.Aeson.Types as Aeson -import qualified Data.HashMap.Strict as HM import Data.Id import qualified Data.Map as Map -import qualified Data.Text as T import qualified Data.UUID as UUID import Imports import Network.URI (parseURI) @@ -46,13 +45,11 @@ import Spar.Scim import Test.Hspec import Test.QuickCheck import URI.ByteString -import Web.Scim.AttrName (AttrName (..)) import qualified Web.Scim.Class.User as ScimC import Web.Scim.Filter (AttrPath (..)) import qualified Web.Scim.Schema.Common as Scim import qualified Web.Scim.Schema.Meta as Scim import Web.Scim.Schema.PatchOp (Op (Remove), Operation (..), PatchOp (..), Path (NormalPath), applyOperation) -import qualified Web.Scim.Schema.PatchOp as PatchOp import qualified Web.Scim.Schema.ResourceType as ScimR import Web.Scim.Schema.Schema (Schema (CustomSchema)) import qualified Web.Scim.Schema.Schema as Scim diff --git a/tools/api-simulations/api-simulations.cabal b/tools/api-simulations/api-simulations.cabal index c26ed4985c5..6326d4b7990 100644 --- a/tools/api-simulations/api-simulations.cabal +++ b/tools/api-simulations/api-simulations.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 0f90b8315b92f70857d0582203f6af1eb7c2b1df87dea8c01d950183fe0e9fe3 +-- hash: 270e2dd55d92063bef42a5ba167b1d5c36d685bc790fa4a3161e569d458e1e3e name: api-simulations version: 0.4.2 @@ -26,7 +26,7 @@ library hs-source-dirs: lib/src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: aeson >=0.7 , api-bot @@ -53,7 +53,7 @@ executable api-loadtest hs-source-dirs: loadtest/src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N -with-rtsopts=-T + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N -with-rtsopts=-T build-depends: api-bot , api-client @@ -91,7 +91,7 @@ executable api-smoketest hs-source-dirs: smoketest/src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N -with-rtsopts=-T + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N -with-rtsopts=-T build-depends: api-bot , api-client diff --git a/tools/bonanza/bonanza.cabal b/tools/bonanza/bonanza.cabal index b79648e0cdd..c49b73b1b88 100644 --- a/tools/bonanza/bonanza.cabal +++ b/tools/bonanza/bonanza.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 08cc6d357674ea09cd3e2563aa63d778f4dbac1c4f1d722d7edae22148750c79 +-- hash: 8d08766e828f1eb6b5314808808037082ec748509c5640b48410a0691beeaa1a name: bonanza version: 3.6.0 @@ -45,7 +45,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-small-strict-fields -fno-warn-unused-do-bind + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-small-strict-fields -fno-warn-unused-do-bind build-depends: aeson >=1.0 , attoparsec >=0.10 @@ -89,7 +89,7 @@ executable bonanza other-modules: Paths_bonanza default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-small-strict-fields -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-T -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-small-strict-fields -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-T -with-rtsopts=-N build-depends: base ==4.* , bonanza @@ -105,7 +105,7 @@ executable kibana-raw other-modules: Paths_bonanza default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-small-strict-fields -rtsopts + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-small-strict-fields -rtsopts build-depends: aeson >=1.0 , base @@ -125,7 +125,7 @@ executable kibanana other-modules: Paths_bonanza default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-small-strict-fields -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-T -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-small-strict-fields -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-T -with-rtsopts=-N build-depends: async , base @@ -154,7 +154,7 @@ test-suite bonanza-tests hs-source-dirs: test/unit default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -with-rtsopts=-N build-depends: QuickCheck , aeson diff --git a/tools/db/auto-whitelist/auto-whitelist.cabal b/tools/db/auto-whitelist/auto-whitelist.cabal index 5c3e926f337..af45cd956a0 100644 --- a/tools/db/auto-whitelist/auto-whitelist.cabal +++ b/tools/db/auto-whitelist/auto-whitelist.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 85c7cbfdf08baf6437e3da2f82fe7862311336420ea8f4825dec40ec753daa23 +-- hash: 30359e01c94cc9990d5d145390d84474d6565cfd0bfda04efa704c365bb99092 name: auto-whitelist version: 1.0.0 @@ -25,7 +25,7 @@ executable auto-whitelist hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts build-depends: attoparsec , base diff --git a/tools/db/billing-team-member-backfill/billing-team-member-backfill.cabal b/tools/db/billing-team-member-backfill/billing-team-member-backfill.cabal index b073957eff9..b2ae6e9d9ff 100644 --- a/tools/db/billing-team-member-backfill/billing-team-member-backfill.cabal +++ b/tools/db/billing-team-member-backfill/billing-team-member-backfill.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: 8f831d80b2384fadeff0c8cbd7088e217f588678b6fe9363981757bef3041375 +-- hash: 0f2b80d40183f6878dcd22bd199c9be915e6b3f7b5f99c609634185e33b2dde9 name: billing-team-member-backfill version: 1.0.0 @@ -25,7 +25,7 @@ executable billing-team-member-backfill hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts build-depends: base , cassandra-util diff --git a/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal b/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal index b4724aa502b..fcd984adb53 100644 --- a/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal +++ b/tools/db/migrate-sso-feature-flag/migrate-sso-feature-flag.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 36ac5bc85d9aa68e450fc0d522c4e6431d4f950e2b2f4c8176ee896a1997962a +-- hash: c38a1187cbb7096dc02f7fbd4452136026c14d8b937aa8e44266ba3cb39bc0ad name: migrate-sso-feature-flag version: 1.0.0 @@ -25,7 +25,7 @@ executable migrate-sso-feature-flag hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts build-depends: attoparsec , base diff --git a/tools/db/service-backfill/service-backfill.cabal b/tools/db/service-backfill/service-backfill.cabal index eb3fab1ef6d..9913fc8aee9 100644 --- a/tools/db/service-backfill/service-backfill.cabal +++ b/tools/db/service-backfill/service-backfill.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 0b53449632293250f29c5b217594390fe59e99c14f4a315c0e59edb64800ff82 +-- hash: 18087f601fd9a68756d98531cd5bfce79cd4f9fd2e6492393527097d1613fdb0 name: service-backfill version: 1.0.0 @@ -25,7 +25,7 @@ executable service-backfill hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N -with-rtsopts=-T -rtsopts build-depends: attoparsec , base diff --git a/tools/makedeb/makedeb.cabal b/tools/makedeb/makedeb.cabal index 302797f154f..a9f7bb18020 100644 --- a/tools/makedeb/makedeb.cabal +++ b/tools/makedeb/makedeb.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 0a381ff1274cd5edda2c1334539611b360548e9baf5bc719f5e9058e5d844319 +-- hash: 2c4e332eb92ae29580646df9f72387c09f892ba0d72f42a89a974b1655ec5bcd name: makedeb version: 0.3.0 @@ -28,7 +28,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: base >=4.6 && <5.0 , directory >=1.2 @@ -46,7 +46,7 @@ executable makedeb other-modules: Paths_makedeb default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded build-depends: base , imports diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index b7d41fa1898..4862765a7c6 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -39,6 +39,7 @@ import Data.ByteString (ByteString) import Data.ByteString.Conversion import Data.ByteString.Lazy (fromStrict) import Data.Handle (Handle) +import qualified Data.HashMap.Strict as M import Data.Id import Data.Predicate import Data.Range @@ -687,7 +688,7 @@ getUserData uid = do "properties" .= properties ] where - noEmail = let Object o = object ["results" .= emptyArray] in MarketoResult o + noEmail = MarketoResult $ M.singleton "results" emptyArray -- Utilities diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 95f8e32e7fc..66bc5acf71f 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -592,7 +592,7 @@ getMarketoResult email = do 404 -> return noEmail _ -> throwE (Error status502 "bad-upstream" "") where - noEmail = let Object o = object ["results" .= emptyArray] in MarketoResult o + noEmail = MarketoResult $ M.singleton "results" emptyArray getUserConsentLog :: UserId -> Handler ConsentLog getUserConsentLog uid = do diff --git a/tools/stern/src/Stern/Types.hs b/tools/stern/src/Stern/Types.hs index c91bcbd39fa..3ea26464e57 100644 --- a/tools/stern/src/Stern/Types.hs +++ b/tools/stern/src/Stern/Types.hs @@ -40,10 +40,14 @@ newtype TeamMemberInfo = TeamMemberInfo {tm :: TeamMember} instance ToJSON TeamMemberInfo where toJSON (TeamMemberInfo m) = - let Object o = teamMemberJson (const True) m - in Object $ M.insert "can_update_billing" (Bool (hasPermission m SetBilling)) + case teamMemberJson (const True) m of + Object o -> + Object + $ M.insert "can_update_billing" (Bool (hasPermission m SetBilling)) $ M.insert "can_view_billing" (Bool (hasPermission m GetBilling)) $ o + other -> + error $ "toJSON TeamMemberInfo: not an object: " <> show (encode other) data TeamInfo = TeamInfo { tiData :: TeamData, diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index 40430b8d562..9e8ed217a32 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: cfe4b05d6b1712183f3e0bb34480bccf7a4b9ecd6e32fd328731ac65df2453aa +-- hash: 359297a5d2e072c399e6e27b49065ef7ca860f07e1fb84b106df4f3eca12d21a name: stern version: 1.7.2 @@ -36,7 +36,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields build-depends: aeson >=0.11 , attoparsec >=0.12 @@ -88,7 +88,7 @@ executable stern other-modules: Paths_stern default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-T + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-T build-depends: base , extended From bca31ffe6b675888022dfa5bdc80fab42b425d93 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Tue, 9 Jun 2020 20:11:03 +0200 Subject: [PATCH 08/11] Add a note about unused registration flow (#1119) --- docs/reference/user/registration.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/docs/reference/user/registration.md b/docs/reference/user/registration.md index 87f56cda9b1..8a9c289b56b 100644 --- a/docs/reference/user/registration.md +++ b/docs/reference/user/registration.md @@ -70,6 +70,8 @@ If the code is incorrect or if an incorrect code has been tried enough times, th ## Registration without pre-verification {#RefRegistrationNoPreverification} +_NOTE: This flow is currently not used by any clients. At least this was the state on 2020-05-28_ + It is also possible to call `POST /register` without verifying the email address or phone number, in which case the account will have to be activated later by calling [`POST /activate`](activation.md#RefActivationSubmit). Sample API request and response: ``` From d8aa9f03417704b8dc373ca00a85be9f0b44664c Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 10 Jun 2020 10:38:54 +0200 Subject: [PATCH 09/11] Changelog. --- CHANGELOG.md | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 3bbc0f00507..a8ee409c304 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,24 @@ +# 2020-06-10 + +## Release Notes + +No extra steps needed during upgrade. + +## New Features + +* Validate saml emails (#1113, #1122, #1129) + +## Documentation + +* Add a note about unused registration flow in docs (#1119) +* Update cassandra-schema.cql (#1127) + +## Internal changes + +* Fix incomplete pattern in code checking email domain (custom extensions) (#1130) +* Enable additional GHC warnings (#1131) +* Cleanup export list; swagger names. (#1126) + # 2020-06-03 ## Release Notes From f3eb1315998b928412c7a1f64b37657c1a019e0c Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 10 Jun 2020 10:39:02 +0200 Subject: [PATCH 10/11] Trailing whitespace. --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a8ee409c304..bc63f49713b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -55,7 +55,7 @@ No extra steps needed during upgrade. ## New Features * Add tool to migrate data for galley (#1096) - This can be used in a more automated way than the backfill-billing-team-member. + This can be used in a more automated way than the backfill-billing-team-member. It should be done as a step after deployment. ## Internal Changes From bf50f9ae52b17c3a1f79012e9ee79e047ed2f247 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 10 Jun 2020 11:44:00 +0200 Subject: [PATCH 11/11] Changelog: actually, there are extra steps. --- CHANGELOG.md | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index bc63f49713b..6aacc9214eb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,7 +2,10 @@ ## Release Notes -No extra steps needed during upgrade. +- schema migration for cassandra_galley +- promote stern *after* galley +- promote spar *after* brig +- no need to upgrade nginz ## New Features