diff --git a/CHANGELOG.md b/CHANGELOG.md index 4e8b7cc7f1a..b30badcd88c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,16 +1,42 @@ +# 2019-09-03 + +## Relevant for self-hosters + +- Option for limiting login retries (#830) +- Option for suspending inactive users (#831) +- Add json logging (#828) (#836) +- Feature Flags in galley options. (#825) + +## Relevant for client developers + +- Specialize the error cases on conversation lookup. (#841) + +## Bug fixes + +- Fix is-team-owner logic (don't require email in all cases) (#833) +- Typos in swagger (#826) + +## Internal changes + +- Fix flaky integration test. (#834) +- Remove `exposed-modules` sections from all package.yaml files. (#832) +- Remove Debug.Trace from Imports. (#838) +- Cleanup integration tests (#839) + + # 2019-08-08 #822 ## Features - legalhold (#802), but block feature activation (#823) - a few shell scripts for self-hosters (#805, #801) -- release nginz_disco (#759) +- Release nginz_disco (#759) -## Client-facing internal changes +## Public API changes +- SSO is disabled by default now; but enabled for all teams that already have an IdP. - feature flags (starting with legalhold, sso) (#813, #818) - - SSO is disabled by default now; but enabled for all teams that already have an IdP. - - new public end-points: + - new public end-points (#813, #818): - get "/teams/:tid/features/legalhold" - get "/teams/:tid/features/sso" - new internal end-points: diff --git a/libs/api-bot/package.yaml b/libs/api-bot/package.yaml index 9f53ca7489f..486e9163bd1 100644 --- a/libs/api-bot/package.yaml +++ b/libs/api-bot/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: api-bot version: '0.4.2' @@ -58,15 +58,4 @@ dependencies: - vector >=0.10 library: source-dirs: src - exposed-modules: - - Network.Wire.Bot - - Network.Wire.Bot.Assert - - Network.Wire.Bot.Clients - - Network.Wire.Bot.Crypto - - Network.Wire.Bot.Email - - Network.Wire.Bot.Metrics - - Network.Wire.Bot.Monad - - Network.Wire.Bot.Report - - Network.Wire.Bot.Report.Text - - Network.Wire.Bot.Settings stability: experimental diff --git a/libs/api-client/package.yaml b/libs/api-client/package.yaml index 23c7ace025b..dc5be9c89b4 100644 --- a/libs/api-client/package.yaml +++ b/libs/api-client/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: api-client version: '0.4.2' @@ -47,16 +47,4 @@ dependencies: - websockets >=0.9 library: source-dirs: src - exposed-modules: - - Network.Wire.Client - - Network.Wire.Client.API.Auth - - Network.Wire.Client.API.Asset - - Network.Wire.Client.API.Conversation - - Network.Wire.Client.API.Push - - Network.Wire.Client.API.Search - - Network.Wire.Client.API.User - - Network.Wire.Client.API.Client - - Network.Wire.Client.HTTP - - Network.Wire.Client.Monad - - Network.Wire.Client.Session stability: experimental diff --git a/libs/bilge/package.yaml b/libs/bilge/package.yaml index a803f8a6b86..20eaaae04e6 100644 --- a/libs/bilge/package.yaml +++ b/libs/bilge/package.yaml @@ -40,12 +40,4 @@ dependencies: - wai-extra library: source-dirs: src - exposed-modules: - - Bilge - - Bilge.Assert - - Bilge.IO - - Bilge.Request - - Bilge.Response - - Bilge.Retry - - Bilge.RPC stability: experimental diff --git a/libs/bilge/src/Bilge/IO.hs b/libs/bilge/src/Bilge/IO.hs index 667b202d448..5942821e4b0 100644 --- a/libs/bilge/src/Bilge/IO.hs +++ b/libs/bilge/src/Bilge/IO.hs @@ -48,7 +48,7 @@ module Bilge.IO , HttpException (..) ) where -import Imports hiding (head, trace) +import Imports hiding (head) import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Trans.Control diff --git a/libs/brig-types/test/unit/Test/Brig/Types/Common.hs b/libs/brig-types/test/unit/Test/Brig/Types/Common.hs index 36b6bdccc26..f03cf38f5d0 100644 --- a/libs/brig-types/test/unit/Test/Brig/Types/Common.hs +++ b/libs/brig-types/test/unit/Test/Brig/Types/Common.hs @@ -16,7 +16,6 @@ import Brig.Types.Test.Arbitrary () import Control.Lens import Data.Aeson import Data.Aeson.Types -import Data.Proxy import Data.Typeable (typeOf) import Galley.Types.Teams import Galley.Types.Teams.SSO @@ -29,40 +28,41 @@ import Test.Tasty.QuickCheck tests :: TestTree tests = testGroup "Common (types vs. aeson)" - [ run @Handle Proxy - , run @Name Proxy - , run @ColourId Proxy - , run @Email Proxy - , run @Phone Proxy - , run @UserIdentity Proxy - , run @UserSSOId Proxy - , run @AssetSize Proxy - , run @Asset Proxy - , run @ExcludedPrefix Proxy - , run @ManagedBy Proxy - , run @TeamMemberDeleteData Proxy - , run @LegalHoldStatus Proxy - , run @LegalHoldTeamConfig Proxy - , run @NewLegalHoldService Proxy - , run @LegalHoldService Proxy - , run @ViewLegalHoldService Proxy - , run @NewLegalHoldClient Proxy - , run @RequestNewLegalHoldClient Proxy - , run @UserLegalHoldStatusResponse Proxy - , run @LegalHoldServiceConfirm Proxy - , run @LegalHoldClientRequest Proxy - , run @RemoveLegalHoldSettingsRequest Proxy - , run @DisableLegalHoldForUserRequest Proxy - , run @ApproveLegalHoldForUserRequest Proxy - , run @SSOStatus Proxy - , run @SSOTeamConfig Proxy + [ run @Handle + , run @Name + , run @ColourId + , run @Email + , run @Phone + , run @UserIdentity + , run @UserSSOId + , run @AssetSize + , run @Asset + , run @ExcludedPrefix + , run @ManagedBy + , run @TeamMemberDeleteData + , run @LegalHoldStatus + , run @LegalHoldTeamConfig + , run @NewLegalHoldService + , run @LegalHoldService + , run @ViewLegalHoldService + , run @NewLegalHoldClient + , run @RequestNewLegalHoldClient + , run @UserLegalHoldStatusResponse + , run @LegalHoldServiceConfirm + , run @LegalHoldClientRequest + , run @RemoveLegalHoldSettingsRequest + , run @DisableLegalHoldForUserRequest + , run @ApproveLegalHoldForUserRequest + , run @SSOStatus + , run @SSOTeamConfig + , run @FeatureFlags , testCase "{} is a valid TeamMemberDeleteData" $ do assertEqual "{}" (Right $ newTeamMemberDeleteData Nothing) (eitherDecode "{}") ] where run :: forall a. (Arbitrary a, Typeable a, ToJSON a, FromJSON a, Eq a, Show a) - => Proxy a -> TestTree - run Proxy = testProperty msg trip + => TestTree + run = testProperty msg trip where msg = show $ typeOf (undefined :: a) trip (v :: a) = counterexample (show $ toJSON v) @@ -83,3 +83,10 @@ instance Arbitrary SSOStatus where instance Arbitrary SSOTeamConfig where arbitrary = SSOTeamConfig <$> arbitrary + +instance Arbitrary FeatureFlags where + arbitrary = FeatureFlags <$> arbitrary + shrink (FeatureFlags ls) = FeatureFlags <$> shrink ls + +instance Arbitrary FeatureFlag where + arbitrary = Test.Tasty.QuickCheck.elements [minBound..] diff --git a/libs/cargohold-types/package.yaml b/libs/cargohold-types/package.yaml index 99992b7c618..45e91b52621 100644 --- a/libs/cargohold-types/package.yaml +++ b/libs/cargohold-types/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: cargohold-types version: '1.5.0' @@ -31,7 +31,3 @@ dependencies: - uuid >=1.2 library: source-dirs: src - exposed-modules: - - CargoHold.Types - - CargoHold.Types.V3 - - CargoHold.Types.V3.Resumable diff --git a/libs/cassandra-util/package.yaml b/libs/cassandra-util/package.yaml index 468218d3316..c4fba625931 100644 --- a/libs/cassandra-util/package.yaml +++ b/libs/cassandra-util/package.yaml @@ -35,10 +35,3 @@ dependencies: - retry library: source-dirs: src - exposed-modules: - - Cassandra - - Cassandra.CQL - - Cassandra.Exec - - Cassandra.Schema - - Cassandra.Settings - - Cassandra.Util diff --git a/libs/extended/package.yaml b/libs/extended/package.yaml index 13164a797f3..f6b4816d370 100644 --- a/libs/extended/package.yaml +++ b/libs/extended/package.yaml @@ -17,6 +17,7 @@ dependencies: - base - bytestring - extra +- aeson - imports - optparse-applicative - tinylog @@ -34,6 +35,7 @@ dependencies: - servant-swagger - string-conversions - transformers +- text - wai library: source-dirs: src diff --git a/libs/extended/src/System/Logger/Extended.hs b/libs/extended/src/System/Logger/Extended.hs index b9ed9144628..fb8f66ccb7b 100644 --- a/libs/extended/src/System/Logger/Extended.hs +++ b/libs/extended/src/System/Logger/Extended.hs @@ -1,29 +1,90 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DerivingStrategies #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | Tinylog convenience things. module System.Logger.Extended ( module Log + , LogFormat(..) , mkLogger , mkLogger' , LoggerT(..) , runWithLogger + , netStringsToLogFormat ) where -import Imports import Control.Monad.Catch +import Data.Aeson +import Data.Aeson.Encoding (pair, list, text) import Database.CQL.IO +import GHC.Generics +import Imports import System.Logger as Log - -import qualified Data.ByteString.Lazy.Char8 as L +import Data.String.Conversions (cs) import qualified Data.ByteString.Lazy.Builder as B +import qualified Data.ByteString.Lazy.Char8 as L import qualified System.Logger.Class as LC -mkLogger :: Log.Level -> Bool -> IO Log.Logger -mkLogger lvl netstr = Log.new + +deriving instance Generic LC.Level +instance FromJSON LC.Level +instance ToJSON LC.Level + +-- | The log formats supported +data LogFormat = JSON | Plain | Netstring + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- | We use this as an intermediate structure to ease the implementation of the +-- ToJSON instance but we could just inline everything. I think this has +-- negligible impact and makes the code a bit more readable. Let me know +data Element' = Element' Series [Builder] + +elementToEncoding :: Element' -> Encoding +elementToEncoding (Element' fields msgs) = pairs $ fields <> msgsToSeries msgs + where + msgsToSeries :: [Builder] -> Series + msgsToSeries = pair "msgs" . list (text . cs . eval) + +collect :: [Element] -> Element' +collect = foldr go (Element' mempty []) + where + go :: Element -> Element' -> Element' + go (Bytes b) (Element' f m) = + Element' f (b : m) + go (Field k v) (Element' f m) = + Element' (f <> pair (cs . eval $ k) (text . cs . eval $ v)) m + +jsonRenderer :: Renderer +jsonRenderer _sep _dateFormat _logLevel = fromEncoding . elementToEncoding . collect + +-- | Here for backwards-compatibility reasons +netStringsToLogFormat :: Bool -> LogFormat +netStringsToLogFormat True = Netstring +netStringsToLogFormat False = Plain + +-- | Creates a logger given a log format Also takes an useNetstrings argument +-- which is there because we cannot immediatelly deprecate the old interface. +-- Old configs only provide the useNetstrings argument and not the logFormat +-- argument, and in that case implement the old behaviour of either enabling +-- plain text logging or netstring logging. If both arguments are set, +-- logFormat takes presedence over useNetstrings +-- +-- FUTUREWORK: Once we get rid of the useNetstrings in our config files, we can +-- remove this function and rename 'mkLoggerNew' to 'mkLogger' +mkLogger :: Log.Level -> Maybe (Last Bool) -> Maybe (Last LogFormat) -> IO Log.Logger +mkLogger lvl useNetstrings logFormat = do + mkLoggerNew lvl $ + case (fmap netStringsToLogFormat <$> useNetstrings) <> logFormat of + Just x -> getLast x + Nothing -> Plain + +-- | Version of mkLogger that doesn't support the deprecated useNetstrings option +mkLoggerNew :: Log.Level -> LogFormat -> IO Log.Logger +mkLoggerNew lvl logFormat = Log.new . Log.setReadEnvironment False . Log.setOutput Log.StdOut . Log.setFormat Nothing - $ simpleSettings (Just lvl) (Just netstr) + $ simpleSettings lvl logFormat -- | Variant of Log.defSettings: -- @@ -33,15 +94,16 @@ mkLogger lvl netstr = Log.new -- -- * use 'canonicalizeWhitespace'. -- -simpleSettings :: Maybe Level -> Maybe Bool -> Log.Settings -simpleSettings lvl netstr - = maybe id setLogLevel lvl - . setRenderer (canonicalizeWhitespace rndr) +simpleSettings :: Log.Level -> LogFormat -> Log.Settings +simpleSettings lvl logFormat + = Log.setLogLevel lvl + . Log.setRenderer (canonicalizeWhitespace rndr) $ Log.defSettings where - rndr = case netstr of - Just True -> \_ _ _ -> renderNetstr - _ -> \s _ _ -> renderDefault s + rndr = case logFormat of + Netstring -> \_separator _dateFormat _level -> Log.renderNetstr + Plain -> \ separator _dateFormat _level -> Log.renderDefault separator + JSON -> jsonRenderer -- | Replace all whitespace characters in the output of a renderer by @' '@. -- Log output must be ASCII encoding. @@ -50,7 +112,7 @@ simpleSettings lvl netstr -- places and situations in your code and your dependencies that inject newlines -- into your log messages, you can choose to call 'canonicalizeWhitespace' on -- your renderer.) -canonicalizeWhitespace :: Renderer -> Renderer +canonicalizeWhitespace :: Log.Renderer -> Log.Renderer canonicalizeWhitespace rndrRaw delim df lvl = B.lazyByteString . nl2sp . B.toLazyByteString . rndrRaw delim df lvl where diff --git a/libs/galley-types/src/Galley/Types/Swagger.hs b/libs/galley-types/src/Galley/Types/Swagger.hs index 504c3b50451..0be062a5117 100644 --- a/libs/galley-types/src/Galley/Types/Swagger.hs +++ b/libs/galley-types/src/Galley/Types/Swagger.hs @@ -41,6 +41,8 @@ galleyModels = , clientMismatch , serviceRef , teamInfo + , legalHoldTeamConfig + , ssoTeamConfig ] event :: Model @@ -441,3 +443,20 @@ serviceRef = defineModel "ServiceRef" $ do errorObj :: Model errorObj = Swagger.errorModel + + +legalHoldTeamConfig :: Model +legalHoldTeamConfig = defineModel "LegalHoldTeamConfig" $ do + description "Configuration of LegalHold feature for team" + property "status" featureStatus $ description "status" + +ssoTeamConfig :: Model +ssoTeamConfig = defineModel "SSOTeamConfig" $ do + description "Configuration of SSO feature for team" + property "status" featureStatus $ description "status" + +featureStatus :: DataType +featureStatus = string $ enum + [ "enabled" + , "disabled" + ] diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index 5ca6a874f1b..29e93e6431d 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -21,6 +21,9 @@ module Galley.Types.Teams , TeamCreationTime (..) , tcTime + , FeatureFlags(..) + , FeatureFlag(..) + , TeamList , newTeamList , teamListTeams @@ -313,6 +316,25 @@ newtype TeamCreationTime = TeamCreationTime { _tcTime :: Int64 } +newtype FeatureFlags = FeatureFlags (Set FeatureFlag) + deriving (Eq, Show, Generic) + +data FeatureFlag = FeatureSSO | FeatureLegalHold + deriving (Eq, Ord, Show, Enum, Bounded, Generic) + +instance FromJSON FeatureFlags where + parseJSON = withObject "FeatureFlags" $ \obj -> do + sso <- fromMaybe False <$> obj .:? "sso" + legalhold <- fromMaybe False <$> obj .:? "legalhold" + pure . FeatureFlags . Set.fromList $ + [ FeatureSSO | sso ] <> + [ FeatureLegalHold | legalhold ] + +instance ToJSON FeatureFlags where + toJSON (FeatureFlags flags) = object $ + [ "sso" .= (FeatureSSO `elem` flags) ] <> + [ "legalhold" .= (FeatureLegalHold `elem` flags) ] + newTeam :: TeamId -> UserId -> Text -> Text -> TeamBinding -> Team newTeam tid uid nme ico bnd = Team tid uid nme ico Nothing bnd diff --git a/libs/gundeck-types/package.yaml b/libs/gundeck-types/package.yaml index 25e9c3e4098..d3bbbfaf21d 100644 --- a/libs/gundeck-types/package.yaml +++ b/libs/gundeck-types/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: gundeck-types version: '1.45.0' @@ -26,13 +26,3 @@ dependencies: - unordered-containers >=0.2 library: source-dirs: src - exposed-modules: - - Gundeck.Types - - Gundeck.Types.BulkPush - - Gundeck.Types.Common - - Gundeck.Types.Event - - Gundeck.Types.Notification - - Gundeck.Types.Presence - - Gundeck.Types.Push - - Gundeck.Types.Push.V2 - - Gundeck.Types.Swagger diff --git a/libs/imports/package.yaml b/libs/imports/package.yaml index 26c38b89c71..0a9c5e70352 100644 --- a/libs/imports/package.yaml +++ b/libs/imports/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: imports version: '0.1.0' @@ -16,7 +16,6 @@ copyright: (c) 2018 Wire Swiss GmbH license: AGPL-3 dependencies: - base -- aeson - extra - unliftio - unliftio-core @@ -30,6 +29,4 @@ dependencies: - tinylog library: source-dirs: src - exposed-modules: - - Imports stability: experimental diff --git a/libs/imports/src/Imports.hs b/libs/imports/src/Imports.hs index 24e08befdd5..253109d5364 100644 --- a/libs/imports/src/Imports.hs +++ b/libs/imports/src/Imports.hs @@ -24,7 +24,6 @@ module Imports , module Data.Tuple , module Data.String , module Data.List - , module Debug.Trace , Generic , Typeable , HasCallStack @@ -71,8 +70,6 @@ module Imports , unlessM ) where -import Orphans () - -- Explicitly saying what to import because some things from Prelude clash -- with e.g. UnliftIO modules import Prelude ( @@ -100,8 +97,8 @@ import Data.Void import Data.Bool import Data.Char import Data.Ord -import Data.Semigroup (Semigroup) -import Data.Monoid +import Data.Semigroup hiding (diff, Option, option) -- conflicts with Options.Applicative.Option (should we care?) +import Data.Monoid hiding (First(..), Last(..)) -- First and Last are going to be deprecated. Use Semigroup instead import Data.Maybe import Data.Either import Data.Foldable @@ -112,7 +109,6 @@ import Data.List hiding (insert, delete) -- 'insert' and 'delete' are import Data.String import Control.Monad hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) import Control.Monad.Extra (whenM, unlessM) -import Debug.Trace import GHC.Generics (Generic) import Data.Typeable (Typeable) import GHC.Stack (HasCallStack) diff --git a/libs/imports/src/Orphans.hs b/libs/imports/src/Orphans.hs deleted file mode 100644 index f46e6a08ce2..00000000000 --- a/libs/imports/src/Orphans.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveGeneric #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - --- | Orphan instances for non-Wire-specific types and classes. -module Orphans () where - -import Data.Aeson -import GHC.Generics -import System.Logger.Class as Logger - -deriving instance Generic Logger.Level -instance FromJSON Logger.Level -instance ToJSON Logger.Level diff --git a/libs/metrics-collectd/package.yaml b/libs/metrics-collectd/package.yaml index a4bb22efee0..0970c0ec817 100644 --- a/libs/metrics-collectd/package.yaml +++ b/libs/metrics-collectd/package.yaml @@ -18,12 +18,6 @@ dependencies: - transformers >=0.3 library: source-dirs: src - exposed-modules: - - System.Metrics.Collectd.Collectd - - System.Metrics.Collectd.IO - - System.Metrics.Collectd.Json - - System.Metrics.Collectd.Json.Path - - System.Metrics.Collectd.Config dependencies: - aeson >=0.8 - async >=2.0 diff --git a/libs/ropes/package.yaml b/libs/ropes/package.yaml index 1e5de164495..62f0f058d09 100644 --- a/libs/ropes/package.yaml +++ b/libs/ropes/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: ropes version: '0.4.20' @@ -16,11 +16,6 @@ dependencies: - semigroups >=0.11 library: source-dirs: src - exposed-modules: - - Ropes.Aws - - Ropes.Aws.Ses - - Ropes.Nexmo - - Ropes.Twilio dependencies: - aeson >=0.6 - aws >=0.10.2 diff --git a/libs/sodium-crypto-sign/package.yaml b/libs/sodium-crypto-sign/package.yaml index 636fc9867c7..dfc16043d21 100644 --- a/libs/sodium-crypto-sign/package.yaml +++ b/libs/sodium-crypto-sign/package.yaml @@ -21,7 +21,5 @@ dependencies: - imports library: source-dirs: src - exposed-modules: - - Sodium.Crypto.Sign pkg-config-dependencies: - libsodium >= 0.4.5 diff --git a/libs/ssl-util/package.yaml b/libs/ssl-util/package.yaml index 688201c45f9..9dfdf279a4f 100644 --- a/libs/ssl-util/package.yaml +++ b/libs/ssl-util/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: ssl-util version: '0.1.0' @@ -19,6 +19,4 @@ dependencies: - time >=1.5 library: source-dirs: src - exposed-modules: - - Ssl.Util stability: experimental diff --git a/libs/tasty-cannon/package.yaml b/libs/tasty-cannon/package.yaml index e22967c57af..74f56ad309c 100644 --- a/libs/tasty-cannon/package.yaml +++ b/libs/tasty-cannon/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: tasty-cannon version: '0.4.0' @@ -29,5 +29,3 @@ dependencies: - websockets >=0.8 library: source-dirs: src - exposed-modules: - - Test.Tasty.Cannon diff --git a/libs/types-common-aws/package.yaml b/libs/types-common-aws/package.yaml index 135b16ace5e..dd1bee768b3 100644 --- a/libs/types-common-aws/package.yaml +++ b/libs/types-common-aws/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: types-common-aws version: '0.16.0' @@ -36,8 +36,6 @@ dependencies: library: source-dirs: src ghc-prof-options: -fprof-auto-exported - exposed-modules: - - Util.Test.SQS when: - condition: impl(ghc >=8) ghc-options: -fno-warn-redundant-constraints diff --git a/libs/types-common-journal/package.yaml b/libs/types-common-journal/package.yaml index 6f1f7262790..2dae58da8df 100644 --- a/libs/types-common-journal/package.yaml +++ b/libs/types-common-journal/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: types-common-journal version: '0.1.0' @@ -26,13 +26,13 @@ library: source-dirs: src ghc-prof-options: -fprof-auto-exported exposed-modules: + # do not remove this list! stack won't be able to generate it from the protobuf source files! - Data.Proto - Data.Proto.Id - Proto.TeamEvents - Proto.TeamEvents_Fields - Proto.UserEvents - Proto.UserEvents_Fields - build-type: Custom verbatim: | custom-setup diff --git a/libs/types-common/package.yaml b/libs/types-common/package.yaml index e0643c2e822..217c0c8bab9 100644 --- a/libs/types-common/package.yaml +++ b/libs/types-common/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: types-common version: '0.16.0' @@ -14,21 +14,6 @@ dependencies: library: source-dirs: src ghc-prof-options: -fprof-auto-exported - exposed-modules: - - Data.Code - - Data.ETag - - Data.Id - - Data.Json.Util - - Data.LegalHold - - Data.List1 - - Data.Misc - - Data.Range - - Data.Swagger - - Data.Text.Ascii - - Data.UUID.Tagged - - Util.Options - - Util.Options.Common - - Util.Test dependencies: - attoparsec >=0.11 - aeson >=1.0 diff --git a/libs/wai-utilities/package.yaml b/libs/wai-utilities/package.yaml index 82251da3832..c13929887d2 100644 --- a/libs/wai-utilities/package.yaml +++ b/libs/wai-utilities/package.yaml @@ -39,11 +39,3 @@ dependencies: - warp >=3.0 library: source-dirs: src - exposed-modules: - - Network.Wai.Utilities - - Network.Wai.Utilities.Error - - Network.Wai.Utilities.Request - - Network.Wai.Utilities.Response - - Network.Wai.Utilities.Server - - Network.Wai.Utilities.Swagger - - Network.Wai.Utilities.ZAuth diff --git a/libs/zauth/package.yaml b/libs/zauth/package.yaml index c427458019f..a5eb35bbe1f 100644 --- a/libs/zauth/package.yaml +++ b/libs/zauth/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: zauth version: '0.10.3' @@ -17,10 +17,6 @@ library: source-dirs: src ghc-options: - -funbox-strict-fields - exposed-modules: - - Data.ZAuth.Token - - Data.ZAuth.Creation - - Data.ZAuth.Validation dependencies: - attoparsec >=0.11 - base >=4.6 && <5 diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index 2e0a9c42ad7..cf7316323e9 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -115,7 +115,6 @@ zauth: providerTokenTimeout: 60 turn: - # Replace this with the list of supported URIs servers: test/resources/turn/servers.txt serversV2: test/resources/turn/servers-v2.txt # This should be the same secret as used by the TURN servers @@ -137,6 +136,11 @@ optSettings: setUserCookieThrottle: stdDev: 5 retryAfter: 1 + setLimitFailedLogins: + timeout: 5 # seconds. if you reach the limit, how long do you have to wait to try again. + retryLimit: 5 # how many times can you have a failed login in that timeframe. + setSuspendInactiveUsers: # this this is omitted: never suspend inactive users. + suspendTimeout: 10 setRichInfoLimit: 5000 # should be in sync with Spar setDefaultLocale: en setMaxTeamSize: 32 diff --git a/services/brig/package.yaml b/services/brig/package.yaml index ab95e6dbb27..05efe06146f 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -39,20 +39,6 @@ dependencies: - yaml >=0.8.22 library: source-dirs: src - exposed-modules: - - Brig.App - - Brig.API - - Brig.AWS - - Brig.AWS.Types - - Brig.Code - - Brig.Data.PasswordReset - - Brig.Options - - Brig.Provider.DB - - Brig.RPC - - Brig.Run - - Brig.User.Auth.Cookie.Limit - - Brig.User.Search.Index - - Brig.ZAuth dependencies: - amazonka >=1.3.7 - amazonka-dynamodb >=1.3.7 diff --git a/services/brig/src/Brig/API.hs b/services/brig/src/Brig/API.hs index 14fd40c14ae..98bd0741dd7 100644 --- a/services/brig/src/Brig/API.hs +++ b/services/brig/src/Brig/API.hs @@ -59,7 +59,6 @@ import qualified Brig.Provider.API as Provider import qualified Brig.Team.API as Team import qualified Brig.Team.Email as Team import qualified Brig.TURN.API as TURN -import qualified System.Logger.Class as Log --------------------------------------------------------------------------- -- Sitemap @@ -1442,22 +1441,20 @@ canBeDeleted :: UserId ::: TeamId -> Handler Response canBeDeleted (uid ::: tid) = do onlyOwner <- lift (Team.teamOwnershipStatus uid tid) case onlyOwner of - Team.IsOnlyTeamOwner -> throwStd noOtherOwner - Team.IsOneOfManyTeamOwners -> pure () - Team.IsNotTeamOwner -> pure () - Team.NoTeamOwnersAreLeft -> do -- (keeping the user won't help in this case) - Log.warn $ Log.field "user" (toByteString uid) - . Log.msg (Log.val "Team.NoTeamOwnersAreLeft") + Team.IsOnlyTeamOwnerWithEmail -> throwStd noOtherOwner + Team.IsOneOfManyTeamOwnersWithEmail -> pure () + Team.IsTeamOwnerWithoutEmail -> pure () + Team.IsNotTeamOwner -> pure () return empty isTeamOwner :: UserId ::: TeamId -> Handler Response isTeamOwner (uid ::: tid) = do onlyOwner <- lift (Team.teamOwnershipStatus uid tid) case onlyOwner of - Team.IsOnlyTeamOwner -> pure () - Team.IsOneOfManyTeamOwners -> pure () - Team.IsNotTeamOwner -> throwStd insufficientTeamPermissions - Team.NoTeamOwnersAreLeft -> throwStd insufficientTeamPermissions + Team.IsOnlyTeamOwnerWithEmail -> pure () + Team.IsOneOfManyTeamOwnersWithEmail -> pure () + Team.IsTeamOwnerWithoutEmail -> pure () + Team.IsNotTeamOwner -> throwStd insufficientTeamPermissions return empty updateSSOId :: UserId ::: JSON ::: JsonRequest UserSSOId -> Handler Response diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index 69cb26a1a90..7b29cfd1f67 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -109,6 +109,8 @@ loginError LoginEphemeral = StdError accountEphemeral loginError LoginPendingActivation = StdError accountPending loginError (LoginThrottled wait) = RichError loginsTooFrequent () [("Retry-After", toByteString' (retryAfterSeconds wait))] +loginError (LoginBlocked wait) = RichError tooManyFailedLogins () + [("Retry-After", toByteString' (retryAfterSeconds wait))] authError :: AuthError -> Error authError AuthInvalidUser = StdError badCredentials @@ -377,9 +379,13 @@ tooManyTeamInvitations = Wai.Error status403 "too-many-team-invitations" "Too ma tooManyTeamMembers :: Wai.Error tooManyTeamMembers = Wai.Error status403 "too-many-team-members" "Too many members in this team." +-- | In contrast to 'tooManyFailedLogins', this is about too many *successful* logins. loginsTooFrequent :: Wai.Error loginsTooFrequent = Wai.Error status429 "client-error" "Logins too frequent" +tooManyFailedLogins :: Wai.Error +tooManyFailedLogins = Wai.Error status403 "client-error" "Too many failed logins" + tooLargeRichInfo :: Wai.Error tooLargeRichInfo = Wai.Error status413 "too-large-rich-info" "Rich info has exceeded the limit" diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index 57377a123a7..3d1017c5c2d 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -112,6 +112,7 @@ data LoginError | LoginEphemeral | LoginPendingActivation | LoginThrottled RetryAfter + | LoginBlocked RetryAfter data ChangePasswordError = InvalidCurrentPassword diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 1951455353c..b87cc38d23c 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -12,6 +12,7 @@ module Brig.API.User , lookupHandle , changeManagedBy , changeAccountStatus + , suspendAccount , Data.lookupAccounts , Data.lookupAccount , Data.lookupStatus @@ -466,6 +467,12 @@ changeAccountStatus usrs status = do Data.updateStatus u status Intra.onUserEvent u Nothing (ev u) +suspendAccount :: HasCallStack => List1 UserId -> AppIO () +suspendAccount usrs = runExceptT (changeAccountStatus usrs Suspended) >>= \case + Right _ -> pure () + Left InvalidAccountStatus -> error "impossible." + + ------------------------------------------------------------------------------- -- Activation @@ -695,13 +702,10 @@ deleteUser uid pwd = do Just tid -> do ownerSituation <- lift $ Team.teamOwnershipStatus uid tid case ownerSituation of - Team.IsOnlyTeamOwner -> throwE DeleteUserOnlyOwner - Team.IsOneOfManyTeamOwners -> pure () - Team.IsNotTeamOwner -> pure () - Team.NoTeamOwnersAreLeft -> do - Log.warn $ field "user" (toByteString uid) - . field "team" (toByteString tid) - . msg (val "Team.NoTeamOwnersAreLeft") + Team.IsOnlyTeamOwnerWithEmail -> throwE DeleteUserOnlyOwner + Team.IsOneOfManyTeamOwnersWithEmail -> pure () + Team.IsTeamOwnerWithoutEmail -> pure () + Team.IsNotTeamOwner -> pure () go a = maybe (byIdentity a) (byPassword a) pwd diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index efe703240de..b3a960e434c 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -155,7 +155,7 @@ newEnv o = do Just sha256 <- getDigestByName "SHA256" Just sha512 <- getDigestByName "SHA512" mtr <- Metrics.metrics - lgr <- Log.mkLogger (Opt.logLevel o) (Opt.logNetStrings o) + lgr <- Log.mkLogger (Opt.logLevel o) (Opt.logNetStrings o) (Opt.logFormat o) cas <- initCassandra o lgr mgr <- initHttpManager ext <- initExtGetManager diff --git a/services/brig/src/Brig/Budget.hs b/services/brig/src/Brig/Budget.hs index 2075bca0a06..656ac0252d1 100644 --- a/services/brig/src/Brig/Budget.hs +++ b/services/brig/src/Brig/Budget.hs @@ -5,6 +5,7 @@ module Brig.Budget , BudgetKey (..) , Budgeted (..) , withBudget + , checkBudget , lookupBudget , insertBudget ) where @@ -18,14 +19,26 @@ data Budget = Budget { budgetTimeout :: !NominalDiffTime , budgetValue :: !Int32 } + deriving (Eq, Show, Generic) data Budgeted a = BudgetExhausted NominalDiffTime | BudgetedValue a Int32 + deriving (Eq, Show, Generic) newtype BudgetKey = BudgetKey Text deriving (Eq, Show, Cql) +-- | @withBudget (BudgetKey "k") (Budget 30 5) action@ runs @action@ at most 5 times every 30 +-- seconds. @"k"@ is used for keeping different calls to 'withBudget' apart; use something +-- there that's unique to your context, like @"login#" <> uid@. +-- +-- FUTUREWORK: encourage caller to define their own type for budget keys (rather than using an +-- untyped text), and represent the types in a way that guarantees that if i'm using a local +-- type that i don't export, then nobody will be able to use my namespace. +-- +-- FUTUREWORK: exceptions are not handled very nicely, but it's not clear what it would mean +-- to improve this. withBudget :: MonadClient m => BudgetKey -> Budget -> m a -> m (Budgeted a) withBudget k b ma = do Budget ttl val <- fromMaybe b <$> lookupBudget k @@ -37,6 +50,15 @@ withBudget k b ma = do insertBudget k (Budget ttl remaining) return (BudgetedValue a remaining) +-- | Like 'withBudget', but does not decrease budget, only takes a look. +checkBudget :: MonadClient m => BudgetKey -> Budget -> m (Budgeted ()) +checkBudget k b = do + Budget ttl val <- fromMaybe b <$> lookupBudget k + let remaining = val - 1 + return $ if remaining < 0 + then BudgetExhausted ttl + else BudgetedValue () remaining + lookupBudget :: MonadClient m => BudgetKey -> m (Maybe Budget) lookupBudget k = fmap mk <$> query1 budgetSelect (params One (Identity k)) where diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 742f0f70e8b..8679554b897 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -619,8 +619,9 @@ getTeamContacts u = do getTeamOwners :: TeamId -> AppIO [Team.TeamMember] getTeamOwners tid = filter Team.isTeamOwner . view Team.teamMembers <$> getTeamMembers tid --- | Like 'getTeamOwners', but only returns owners with an email address. -getTeamOwnersWithEmail :: TeamId -> AppIO [Team.TeamMember] +-- | Like 'getTeamOwners', but only returns owners with an flag indicating whether they have +-- an email address. +getTeamOwnersWithEmail :: TeamId -> AppIO [(Team.TeamMember, Bool)] getTeamOwnersWithEmail tid = do mems <- getTeamOwners tid usrList :: [User] <- lookupUsers ((^. Team.userId) <$> mems) @@ -634,7 +635,7 @@ getTeamOwnersWithEmail tid = do hasEmail :: Team.TeamMember -> Bool hasEmail mem = maybe False id $ Map.lookup (mem ^. Team.userId) usrMap - pure $ filter hasEmail mems + pure $ (\mem -> (mem, hasEmail mem)) <$> mems getTeamId :: UserId -> AppIO (Maybe TeamId) getTeamId u = do diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 2dc07f5a508..523edca134f 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -14,22 +14,22 @@ import Data.Aeson.Types (typeMismatch) import Data.Aeson (withText) import Data.Id import Data.Scientific (toBoundedInteger) -import Data.Time.Clock (DiffTime, secondsToDiffTime) +import Data.Time.Clock (NominalDiffTime) import Data.Yaml (FromJSON(..), ToJSON(..)) import Util.Options -import System.Logger.Class (Level) +import System.Logger.Extended (Level, LogFormat) import qualified Brig.ZAuth as ZAuth import qualified Data.Yaml as Y newtype Timeout = Timeout - { timeoutDiff :: DiffTime + { timeoutDiff :: NominalDiffTime } deriving newtype (Eq, Enum, Ord, Num, Real, Fractional, RealFrac, Show) instance Read Timeout where readsPrec i s = case readsPrec i s of - [(x, s')] -> [(Timeout (secondsToDiffTime x), s')] + [(x :: Int, s')] -> [(Timeout (fromIntegral x), s')] _ -> [] data ElasticSearchOpts = ElasticSearchOpts @@ -164,6 +164,28 @@ data EmailSMSOpts = EmailSMSOpts instance FromJSON EmailSMSOpts +-- | Login retry limit. In contrast to 'setUserCookieThrottle', this is not about mitigating +-- DOS attacks, but about preventing dictionary attacks. This introduces the orthogonal risk +-- of an attacker blocking legitimate login attempts of a user by constantly keeping the retry +-- limit for that user exhausted with failed login attempts. +-- +-- If in doubt, do not ues retry options and worry about encouraging / enforcing a good +-- password policy. +data LimitFailedLogins = LimitFailedLogins + { timeout :: !Timeout -- ^ Time the user is blocked when retry limit is reached (in + -- seconds mostly for making it easier to write a fast-ish + -- integration test.) + , retryLimit :: !Int -- ^ Maximum number of failed login attempts for one user. + } deriving (Eq, Show, Generic) + +instance FromJSON LimitFailedLogins + +data SuspendInactiveUsers = SuspendInactiveUsers + { suspendTimeout :: !Timeout + } deriving (Eq, Show, Generic) + +instance FromJSON SuspendInactiveUsers + -- | ZAuth options data ZAuthOpts = ZAuthOpts { privateKeys :: !FilePath -- ^ Private key file @@ -241,9 +263,9 @@ data Opts = Opts -- Logging , logLevel :: !Level -- ^ Log level (Debug, Info, etc) - , logNetStrings :: !Bool -- ^ Use netstrings encoding (see + , logNetStrings :: !(Maybe (Last Bool)) -- ^ Use netstrings encoding (see -- ) - + , logFormat :: !(Maybe (Last LogFormat)) -- ^ Logformat to use -- TURN , turn :: !TurnOpts -- ^ TURN server settings @@ -267,7 +289,14 @@ data Settings = Settings , setUserCookieRenewAge :: !Integer -- ^ Minimum age of a user cookie before -- it is renewed during token refresh , setUserCookieLimit :: !Int -- ^ Max. # of cookies per user and cookie type - , setUserCookieThrottle :: !CookieThrottle -- ^ Throttling settings + , setUserCookieThrottle :: !CookieThrottle -- ^ Throttling settings (not to be confused + -- with 'LoginRetryOpts') + , setLimitFailedLogins :: !(Maybe LimitFailedLogins) -- ^ Block user from logging in + -- for m minutes after n failed + -- logins + , setSuspendInactiveUsers :: !(Maybe SuspendInactiveUsers) + -- ^ If last cookie renewal is too long ago, + -- suspend the user. , setRichInfoLimit :: !Int -- ^ Max size of rich info (number of chars in -- field names and values), should be in sync -- with Spar @@ -288,7 +317,7 @@ instance FromJSON Timeout where bounded = toBoundedInteger n :: Maybe Int64 in pure $ Timeout $ - secondsToDiffTime $ maybe defaultV fromIntegral bounded + fromIntegral @Int $ maybe defaultV fromIntegral bounded parseJSON v = typeMismatch "activationTimeout" v instance FromJSON Settings diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index 25b198c0c1e..36e9a1367ff 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -11,19 +11,33 @@ import Control.Error import qualified Brig.IO.Intra as Intra import qualified Data.Set as Set -data TeamOwnershipStatus = IsOnlyTeamOwner | IsOneOfManyTeamOwners | IsNotTeamOwner | NoTeamOwnersAreLeft +-- | Every team must have at least one owner with an email address for billing and +-- administration. 'TeamOwnershipStatus' distinguishes all the relevant cases. +data TeamOwnershipStatus + = IsOnlyTeamOwnerWithEmail + | IsOneOfManyTeamOwnersWithEmail + | IsTeamOwnerWithoutEmail + | IsNotTeamOwner deriving (Eq, Show, Bounded, Enum) --- | A team owner is a team member with full permissions *and* an email address. teamOwnershipStatus :: UserId -> TeamId -> AppIO TeamOwnershipStatus -teamOwnershipStatus uid tid = teamOwnershipStatus' uid . fmap (^. userId) <$> Intra.getTeamOwnersWithEmail tid +teamOwnershipStatus uid tid = compute <$> Intra.getTeamOwnersWithEmail tid + where + compute :: [(TeamMember, Bool)] -> TeamOwnershipStatus + compute owners = search (getuid <$> owners) (getuid <$> ownersWithEmail) + where + ownersWithEmail = filter (^. _2) owners + getuid = (^. _1 . userId) -teamOwnershipStatus' :: UserId -> [UserId] -> TeamOwnershipStatus -teamOwnershipStatus' _ [] = NoTeamOwnersAreLeft -teamOwnershipStatus' uid (Set.fromList -> owners) - | uid `Set.notMember` owners = IsNotTeamOwner - | Set.null (Set.delete uid owners) = IsOnlyTeamOwner - | otherwise = IsOneOfManyTeamOwners + search :: [UserId] -> [UserId] -> TeamOwnershipStatus + search [] [] = IsNotTeamOwner -- this shouldn't happen, but we don't handle that here. + search (Set.fromList -> owners) (Set.fromList -> ownersWithEmail) + = case (uid `Set.member` owners, uid `Set.member` ownersWithEmail) of + (False, _) -> IsNotTeamOwner + (True, False) -> IsTeamOwnerWithoutEmail + (True, True) -> if Set.null (Set.delete uid ownersWithEmail) + then IsOnlyTeamOwnerWithEmail + else IsOneOfManyTeamOwnersWithEmail ensurePermissions :: UserId -> TeamId -> [Perm] -> ExceptT Error AppIO () ensurePermissions u t perms = do diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 9432264106d..fb522821b4b 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -16,8 +16,12 @@ module Brig.User.Auth ) where import Imports + +import Control.Lens (view, to) import Brig.App import Brig.API.Types +import Brig.API.User (suspendAccount) +import Brig.Budget import Brig.Email import Brig.Data.UserKey import Brig.Phone @@ -28,15 +32,21 @@ import Brig.Types.Common import Brig.Types.Intra import Brig.Types.User import Brig.Types.User.Auth hiding (user) -import Control.Error +import Control.Error hiding (bool) import Data.Id +import Data.ByteString.Conversion (toByteString) +import Data.List1 (singleton) import Data.Misc (PlainTextPassword (..)) +import System.Logger (msg, field, (~~), val) import qualified Brig.Data.Activation as Data import qualified Brig.Data.LoginCode as Data import qualified Brig.Data.User as Data import qualified Brig.Data.UserKey as Data +import qualified Brig.Options as Opt import qualified Brig.ZAuth as ZAuth +import qualified System.Logger.Class as Log + data Access = Access { accessToken :: !AccessToken @@ -71,19 +81,46 @@ lookupLoginCode phone = Data.lookupKey (userPhoneKey phone) >>= \case login :: Login -> CookieType -> ExceptT LoginError AppIO Access login (PasswordLogin li pw label) typ = do uid <- resolveLoginId li + checkRetryLimit uid Data.authenticate uid pw `catchE` \case AuthSuspended -> throwE LoginSuspended AuthEphemeral -> throwE LoginEphemeral - AuthInvalidCredentials -> throwE LoginFailed - AuthInvalidUser -> throwE LoginFailed + AuthInvalidCredentials -> loginFailed uid + AuthInvalidUser -> loginFailed uid newAccess uid typ label login (SmsLogin phone code label) typ = do uid <- resolveLoginId (LoginByPhone phone) + checkRetryLimit uid ok <- lift $ Data.verifyLoginCode uid code unless ok $ - throwE LoginFailed + loginFailed uid newAccess uid typ label +loginFailed :: UserId -> ExceptT LoginError AppIO () +loginFailed uid = decrRetryLimit uid >> throwE LoginFailed + +decrRetryLimit :: UserId -> ExceptT LoginError AppIO () +decrRetryLimit = withRetryLimit (\k b -> withBudget k b $ pure ()) + +checkRetryLimit :: UserId -> ExceptT LoginError AppIO () +checkRetryLimit = withRetryLimit checkBudget + +withRetryLimit + :: (BudgetKey -> Budget -> ExceptT LoginError AppIO (Budgeted ())) + -> UserId + -> ExceptT LoginError AppIO () +withRetryLimit action uid = do + mLimitFailedLogins <- view (settings . to Opt.setLimitFailedLogins) + forM_ mLimitFailedLogins $ \opts -> do + let bkey = BudgetKey ("login#" <> idToText uid) + budget = Budget + (Opt.timeoutDiff $ Opt.timeout opts) + (fromIntegral $ Opt.retryLimit opts) + bresult <- action bkey budget + case bresult of + BudgetExhausted ttl -> throwE . LoginBlocked . RetryAfter . floor $ ttl + BudgetedValue () _ -> pure () + logout :: ZAuth.UserToken -> ZAuth.AccessToken -> ExceptT ZAuth.Failure AppIO () logout ut at = do (u, ck) <- validateTokens ut (Just at) @@ -94,7 +131,8 @@ renewAccess -> Maybe ZAuth.AccessToken -> ExceptT ZAuth.Failure AppIO Access renewAccess ut at = do - (_, ck) <- validateTokens ut at + (uid, ck) <- validateTokens ut at + catchSuspendInactiveUser uid ZAuth.Expired ck' <- lift $ nextCookie ck at' <- lift $ newAccessToken (fromMaybe ck ck') at return $ Access at' ck' @@ -112,8 +150,19 @@ revokeAccess u pw cc ll = do -------------------------------------------------------------------------------- -- Internal +catchSuspendInactiveUser :: UserId -> e -> ExceptT e AppIO () +catchSuspendInactiveUser uid errval = do + mustsuspend <- lift $ mustSuspendInactiveUser uid + Log.warn $ msg (val "catchSuspendInactiveUser") + ~~ field "user" (toByteString uid) + ~~ field "mustsuspend" mustsuspend + when mustsuspend $ do + lift $ suspendAccount (singleton uid) + throwE errval + newAccess :: UserId -> CookieType -> Maybe CookieLabel -> ExceptT LoginError AppIO Access newAccess u ct cl = do + catchSuspendInactiveUser u LoginSuspended r <- lift $ newCookieLimited u ct cl case r of Left delay -> throwE $ LoginThrottled delay diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index 2f2d4f7dd5c..89c763fd2d5 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -3,11 +3,11 @@ module Brig.User.Auth.Cookie newCookie , newAccessToken , nextCookie - , renewCookie , lookupCookie , revokeCookies , revokeAllCookies , listCookies + , mustSuspendInactiveUser -- * Limited Cookies , RetryAfter (..) @@ -27,7 +27,7 @@ import Brig.App import Brig.Options hiding (user) import Brig.Types.User.Auth hiding (user) import Brig.User.Auth.Cookie.Limit -import Control.Lens (view) +import Control.Lens (view, to) import Data.ByteString.Conversion import Data.Id import Data.Text.Encoding (encodeUtf8) @@ -110,6 +110,30 @@ renewCookie old = do DB.insertCookie u old' (Just (DB.TTL (fromIntegral ttl))) return new +-- | Whether a user has not renewed any of her cookies for longer than +-- 'suspendCookiesOlderThanSecs'. Call this always before 'newCookie', 'nextCookie', +-- 'newCookieLimited' if there is a chance that the user should be suspended (we don't do it +-- implicitly because of cyclical dependencies). +mustSuspendInactiveUser :: UserId -> AppIO Bool +mustSuspendInactiveUser uid = view (settings . to setSuspendInactiveUsers) >>= \case + Nothing -> pure False + Just (SuspendInactiveUsers (Timeout suspendAge)) -> do + now <- liftIO =<< view currentTime + + let suspendHere :: UTCTime + suspendHere = addUTCTime (-suspendAge) now + + youngEnough :: Cookie () -> Bool + youngEnough = (>= suspendHere) . cookieCreated + + ckies <- listCookies uid [] + let mustSuspend + | null ckies = False + | any youngEnough ckies = False + | otherwise = True + + pure mustSuspend + newAccessToken :: Cookie ZAuth.UserToken -> Maybe ZAuth.AccessToken -> AppIO AccessToken newAccessToken c mt = do t' <- case mt of diff --git a/services/brig/test/integration/API/TURN.hs b/services/brig/test/integration/API/TURN.hs index 7b7c1c399da..ee229334235 100644 --- a/services/brig/test/integration/API/TURN.hs +++ b/services/brig/test/integration/API/TURN.hs @@ -11,26 +11,24 @@ import Data.List ((\\)) import Data.List1 (List1) import Data.Misc (Port) import Network.HTTP.Client (Manager) -import System.IO.Temp (writeTempFile) +import System.FilePath (()) import Test.Tasty import Test.Tasty.HUnit +import UnliftIO.Exception (finally) import Util import qualified Data.ByteString.Lazy as LB import qualified Data.List1 as List1 - -type TurnUpdater = String -> IO () +import qualified UnliftIO.Temporary as Temp tests :: Manager -> Brig -> FilePath -> FilePath -> IO TestTree tests m b turn turnV2 = do return $ testGroup "turn" - [ test m "basic /calls/config - 200" $ resetTurn >> testCallsConfig b + [ test m "basic /calls/config - 200" $ testCallsConfig b -- FIXME: requires tests to run on same host as brig - , test m "multiple servers /calls/config - 200" $ resetTurn >> testCallsConfigMultiple b (setTurn turn) - , test m "multiple servers /calls/config/v2 - 200" $ resetTurn >> testCallsConfigMultipleV2 b (setTurn turnV2) + , test m "multiple servers /calls/config - 200" . withTurnFile turn $ testCallsConfigMultiple b + , test m "multiple servers /calls/config/v2 - 200" . withTurnFile turnV2 $ testCallsConfigMultipleV2 b ] - where - resetTurn = liftIO $ setTurn turn "turn:127.0.0.1:3478" >> setTurn turnV2 "turn:localhost:3478" testCallsConfig :: Brig -> Http () testCallsConfig b = do @@ -165,14 +163,24 @@ toTurnURI s h p t = turnURI s ip p t ip = fromMaybe (error "Failed to parse host address") $ fromByteString h -setTurn :: FilePath -> String -> IO () -setTurn cfgDest newConf = do - tmpDir <- getTemporaryDirectory - tmpPathFile <- writeTempFile tmpDir "-turn.tmp" newConf - copyFile tmpPathFile cfgDest + +type TurnUpdater = String -> IO () + +withTurnFile :: FilePath -> (TurnUpdater -> Http ()) -> Http () +withTurnFile cfgDest action = do + Temp.withSystemTempDirectory "wire.temp" $ \tempdir -> do + let backup = tempdir "backup" + copyFile cfgDest backup + action (setTurn tempdir cfgDest) + `finally` copyFile backup cfgDest + +-- This essentially writes 'newConf' to 'cfgDest', but in a portable way that makes sure +-- brig's filewatch notices that the file has changed. +setTurn :: FilePath -> FilePath -> String -> IO () +setTurn tmpDir cfgDest newConf = do + let tmpFile = tmpDir "file" + writeFile tmpFile newConf + copyFile tmpFile cfgDest -- TODO: This must be higher than the value specified -- in the watcher in Brig.App (currently, 0.5 seconds) threadDelay 1000000 - -- Note that this may leave temporary files behind in - -- case of some exceptions - removeFile tmpPathFile diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 52d6d46f4ac..4a8bac83d3c 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -590,7 +590,7 @@ testSuspendUser brig = do u <- randomUser brig let uid = userId u Just email = userEmail u - setStatus uid Suspended + setStatus brig uid Suspended -- login fails login brig (defEmailLogin email) PersistentCookie !!! do const 403 === statusCode @@ -603,17 +603,11 @@ testSuspendUser brig = do Search.assertCan'tFind brig suid uid (fromName (userName u)) -- re-activate - setStatus uid Active + setStatus brig uid Active chkStatus brig uid Active -- should appear in search again Search.refreshIndex brig Search.assertCanFind brig suid uid (fromName (userName u)) - where - setStatus u s = - let js = RequestBodyLBS . encode $ AccountStatusUpdate s - in put ( brig . paths ["i", "users", toByteString' u, "status"] - . contentJson . body js - ) !!! const 200 === statusCode testGetByIdentity :: Brig -> Http () testGetByIdentity brig = do diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index fbb0358d2f3..f423968f93a 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + module API.User.Auth (tests) where import Imports @@ -9,6 +11,7 @@ import Brig.Types.User.Auth import Brig.ZAuth (ZAuth, runZAuth) import UnliftIO.Async hiding (wait) import Control.Lens ((^?), set) +import Control.Retry import Data.Aeson import Data.Aeson.Lens import Data.ByteString.Conversion @@ -31,9 +34,10 @@ import qualified Data.Text.Lazy as Lazy import qualified Brig.ZAuth as ZAuth import qualified Data.Text as Text import qualified Data.UUID.V4 as UUID - +import qualified Test.Tasty.HUnit as HUnit import qualified Network.Wai.Utilities.Error as Error + tests :: Maybe Opts.Opts -> Manager -> ZAuth.Env -> Brig -> TestTree tests conf m z b = testGroup "auth" [ testGroup "login" @@ -44,6 +48,7 @@ tests conf m z b = testGroup "auth" , test m "send-phone-code" (testSendLoginCode b) , test m "failure" (testLoginFailure b) , test m "throttle" (testThrottleLogins conf b) + , test m "limit-retry" (testLimitRetries conf b) , testGroup "sso-login" [ test m "email" (testEmailSsoLogin b) , test m "failure-suspended" (testSuspendedSsoLogin b) @@ -57,6 +62,7 @@ tests conf m z b = testGroup "auth" , test m "unknown-cookie" (testUnknownCookie z b) , test m "new-persistent-cookie" (testNewPersistentCookie conf b) , test m "new-session-cookie" (testNewSessionCookie conf b) + , test m "suspend-inactive" (testSuspendInactiveUsers conf b) ] , testGroup "cookies" [ test m "list" (testListCookies b) @@ -227,7 +233,54 @@ testThrottleLogins conf b = do liftIO $ do assertBool "throttle delay" (n > 0) threadDelay (1000000 * (n + 1)) - void $ login b (defEmailLogin e) SessionCookie + login b (defEmailLogin e) SessionCookie !!! const 200 === statusCode + +testLimitRetries :: HasCallStack => Maybe Opts.Opts -> Brig -> Http () +testLimitRetries (Just conf) brig = do + let Just opts = Opts.setLimitFailedLogins . Opts.optSettings $ conf + unless (Opts.timeout opts <= 30) $ + error "`loginRetryTimeout` is the number of seconds this test is running. Please pick a value < 30." + + usr <- randomUser brig + let Just email = userEmail usr + + usr' <- randomUser brig + let Just email' = userEmail usr' + + -- Login 5 times with bad password. + forM_ [1..Opts.retryLimit opts] $ \_ -> + login brig (emailLogin email defWrongPassword (Just defCookieLabel)) SessionCookie + show (retryTimeout, Opts.timeout opts)) + -- (this accounts for slow CI systems that lose up to 2 secs) + (retryTimeout >= Opts.timeout opts - 2 && + retryTimeout <= Opts.timeout opts) + threadDelay (1000000 * (retryAfterSecs - 2)) -- wait almost long enough. + + -- fail again later into the block time window + rsp <- login brig (defEmailLogin email) SessionCookie show retryAfterSecs) (retryAfterSecs <= 2) + threadDelay (1000000 * (retryAfterSecs + 1)) -- wait one more second, just to be safe. + + -- wait long enough and login successfully! + liftIO $ threadDelay (1000000 * 2) + login brig (defEmailLogin email) SessionCookie !!! const 200 === statusCode + ------------------------------------------------------------------------------- -- Sso login @@ -389,6 +442,57 @@ testNewSessionCookie config b = do const 200 === statusCode const Nothing === getHeader "Set-Cookie" +testSuspendInactiveUsers :: HasCallStack => Maybe Opts.Opts -> Brig -> Http () +testSuspendInactiveUsers (Just config) brig = do + -- (context information: cookies are stored by user, not be device; so if there if the + -- cookie is old it means none of the devices of a user has used it for a request.) + + let Just suspendAge = Opts.suspendTimeout <$> Opts.setSuspendInactiveUsers (Opts.optSettings config) + unless (suspendAge <= 30) $ + error "`suspendCookiesOlderThanSecs` is the number of seconds this test is running. Please pick a value < 30." + + let check :: HasCallStack => CookieType -> String -> Http () + check cookieType endPoint = do + user <- randomUser brig + let Just email = userEmail user + rs <- login brig (emailLogin email defPassword Nothing) cookieType + do + post (brig . path "/access" . cookie cky) !!! do + const 403 === statusCode + const Nothing === getHeader "Set-Cookie" + "/login" -> do + login brig (emailLogin email defPassword Nothing) cookieType !!! do + const 403 === statusCode + const Nothing === getHeader "Set-Cookie" + + let assertStatus want = do + have <- retrying (exponentialBackoff 200000 <> limitRetries 6) + (\_ have -> pure $ have == Suspended) + (\_ -> getStatus brig (userId user)) + let errmsg = "testSuspendInactiveUsers: " <> show (want, cookieType, endPoint, waitTime, suspendAge) + liftIO $ HUnit.assertEqual errmsg want have + + assertStatus Suspended + setStatus brig (userId user) Active + assertStatus Active + + login brig (emailLogin email defPassword Nothing) cookieType + !!! const 200 === statusCode + + check SessionCookie "/access" + check SessionCookie "/login" + check PersistentCookie "/access" + check PersistentCookie "/login" + + ------------------------------------------------------------------------------- -- Cookie Management @@ -488,6 +592,9 @@ testTooManyCookies config b = do let Just n = fromByteString =<< getHeader "Retry-After" x liftIO $ threadDelay (1000000 * (n + 1)) loginWhenAllowed pwl t + 403 -> error ("forbidden; " <> + "perhaps setSuspendInactiveUsers.suspendTimeout is too small? " <> + "(try 29 seconds).") xxx -> error ("Unexpected status code when logging in: " ++ show xxx) testLogout :: Brig -> Http () @@ -582,14 +689,6 @@ assertSaneAccessToken now uid tk = do assertEqual "user" uid (ZAuth.accessTokenOf tk) assertBool "expiry" (ZAuth.tokenExpiresUTC tk > now) --- | Set user's status to something (e.g. 'Suspended'). -setStatus :: Brig -> UserId -> AccountStatus -> HttpT IO () -setStatus brig u s = - let js = RequestBodyLBS . encode $ AccountStatusUpdate s - in put ( brig . paths ["i", "users", toByteString' u, "status"] - . contentJson . Http.body js - ) !!! const 200 === statusCode - -- | Get error label from the response (for use in assertions). errorLabel :: Response (Maybe Lazy.ByteString) -> Maybe Lazy.Text errorLabel = fmap Error.label . decodeBody diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 0ba94beb451..7156a0ff981 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -163,10 +163,10 @@ testCancelConnection2 brig galley = do -- A cannot see the conversation (due to cancelling) getConversation galley uid1 cnv !!! do - const 404 === statusCode + const 403 === statusCode -- B cannot see the conversation - getConversation galley uid2 cnv !!! const 404 === statusCode + getConversation galley uid2 cnv !!! const 403 === statusCode -- B initiates a connection request himself postConnection brig uid2 uid1 !!! const 200 === statusCode @@ -182,7 +182,7 @@ testCancelConnection2 brig galley = do -- A is a past member, cannot see the conversation getConversation galley uid1 cnv !!! do - const 404 === statusCode + const 403 === statusCode -- A finally accepts putConnection brig uid1 uid2 Accepted !!! const 200 === statusCode @@ -270,7 +270,7 @@ testBlockAndResendConnection brig galley = do -- B never accepted and thus does not see the conversation let Just cnv = ucConvId =<< decodeBody rsp - getConversation galley uid2 cnv !!! const 404 === statusCode + getConversation galley uid2 cnv !!! const 403 === statusCode -- A can see the conversation and is a current member getConversation galley uid1 cnv !!! do diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index c856c231e46..13f6cfe6e0f 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -16,7 +16,7 @@ import Control.Lens ((^?), (^?!)) import Control.Monad.Catch (MonadThrow) import Control.Retry import Data.Aeson -import Data.Aeson.Lens (key, _String, _Integral) +import Data.Aeson.Lens (key, _String, _Integral, _JSON) import Data.ByteString.Char8 (pack) import Data.ByteString.Conversion import Data.Id @@ -350,16 +350,12 @@ isMember g usr cnv = do Nothing -> return False Just m -> return (usr == memId m) -getStatus :: HasCallStack => Brig -> UserId -> Http AccountStatus -getStatus brig u = do - r <- get (brig . paths ["i", "users", toByteString' u, "status"]) error $ "getStatus: failed to parse response: " ++ show r - Just j -> do - let st = maybeFromJSON =<< (j ^? key "status") - return $ fromMaybe (error $ "getStatus: failed to decode status" ++ show j) st +getStatus :: HasCallStack => Brig -> UserId -> HttpT IO AccountStatus +getStatus brig u = + either (error . show) (^?! key "status" . (_JSON @Value @AccountStatus)) . (responseJson @Value) <$> + get ( brig . paths ["i", "users", toByteString' u, "status"] + . expect2xx + ) chkStatus :: HasCallStack => Brig -> UserId -> AccountStatus -> Http () chkStatus brig u s = @@ -367,6 +363,13 @@ chkStatus brig u s = const 200 === statusCode const (Just (toJSON s)) === ((^? key "status") <=< responseBody) +setStatus :: Brig -> UserId -> AccountStatus -> Http () +setStatus brig u s = + let js = RequestBodyLBS . encode $ AccountStatusUpdate s + in put ( brig . paths ["i", "users", toByteString' u, "status"] + . contentJson . body js + ) !!! const 200 === statusCode + -------------------------------------------------------------------------------- -- Utilities @@ -515,6 +518,9 @@ someLastPrekeys = defPassword :: PlainTextPassword defPassword = PlainTextPassword "secret" +defWrongPassword :: PlainTextPassword +defWrongPassword = PlainTextPassword "not secret" + defCookieLabel :: CookieLabel defCookieLabel = CookieLabel "auth" diff --git a/services/cannon/package.yaml b/services/cannon/package.yaml index 71a4959dc29..efb9451090c 100644 --- a/services/cannon/package.yaml +++ b/services/cannon/package.yaml @@ -14,13 +14,6 @@ dependencies: - extended library: source-dirs: src - exposed-modules: - - Cannon.API - - Cannon.Dict - - Cannon.Options - - Cannon.Run - - Cannon.Types - - Cannon.WS dependencies: - base >=4.6 && <5 - aeson >=0.11 diff --git a/services/cannon/src/Cannon/App.hs b/services/cannon/src/Cannon/App.hs index 9445cae92f0..55d56affd97 100644 --- a/services/cannon/src/Cannon/App.hs +++ b/services/cannon/src/Cannon/App.hs @@ -142,7 +142,6 @@ rejectOnError p x = do _ -> pure () throwM x --- TODO ioErrors :: (MonadLogger m, MonadIO m) => Key -> [Handler m ()] ioErrors k = let f s = Logger.err $ client (key2bytes k) . msg s in [ Handler $ \(x :: HandshakeException) -> f (show x) diff --git a/services/cannon/src/Cannon/Options.hs b/services/cannon/src/Cannon/Options.hs index 0be4389ecf1..62267c9f5e1 100644 --- a/services/cannon/src/Cannon/Options.hs +++ b/services/cannon/src/Cannon/Options.hs @@ -10,6 +10,7 @@ module Cannon.Options , externalHostFile , logLevel , logNetStrings + , logFormat , Opts ) where @@ -17,7 +18,7 @@ where import Imports import Control.Lens (makeFields) import Data.Aeson.APIFieldJsonTH -import System.Logger.Class (Level) +import System.Logger.Extended (Level, LogFormat) data Cannon = Cannon @@ -42,7 +43,8 @@ data Opts = Opts { _optsCannon :: !Cannon , _optsGundeck :: !Gundeck , _optsLogLevel :: !Level - , _optsLogNetStrings :: !Bool + , _optsLogNetStrings :: !(Maybe (Last Bool)) + , _optsLogFormat :: !(Maybe (Last LogFormat)) } deriving (Eq, Show, Generic) makeFields ''Opts diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index 715a9af36d3..8cee8f35a51 100644 --- a/services/cannon/src/Cannon/Run.hs +++ b/services/cannon/src/Cannon/Run.hs @@ -28,7 +28,7 @@ run :: Opts -> IO () run o = do ext <- loadExternal m <- Middleware.metrics - g <- L.mkLogger (o ^. logLevel) (o ^. logNetStrings) + g <- L.mkLogger (o ^. logLevel) (o ^. logNetStrings) (o ^. logFormat) e <- mkEnv <$> pure m <*> pure ext <*> pure o diff --git a/services/cannon/src/Cannon/WS.hs b/services/cannon/src/Cannon/WS.hs index 66281eb61d2..9427dacd38d 100644 --- a/services/cannon/src/Cannon/WS.hs +++ b/services/cannon/src/Cannon/WS.hs @@ -30,7 +30,7 @@ module Cannon.WS ) where -import Imports hiding (threadDelay, trace) +import Imports hiding (threadDelay) import Bilge hiding (trace) import Bilge.Retry import Bilge.RPC diff --git a/services/cargohold/package.yaml b/services/cargohold/package.yaml index 3261a9a7844..3f4ffe45bda 100644 --- a/services/cargohold/package.yaml +++ b/services/cargohold/package.yaml @@ -34,10 +34,6 @@ dependencies: - imports library: source-dirs: src - exposed-modules: - - CargoHold.API - - CargoHold.Options - - CargoHold.Run dependencies: - base >=4 && <5 - attoparsec >=0.12 diff --git a/services/cargohold/src/CargoHold/App.hs b/services/cargohold/src/CargoHold/App.hs index 62859d36b07..f075b53e9c9 100644 --- a/services/cargohold/src/CargoHold/App.hs +++ b/services/cargohold/src/CargoHold/App.hs @@ -84,7 +84,7 @@ makeLenses ''Env newEnv :: Opts -> IO Env newEnv o = do met <- Metrics.metrics - lgr <- Log.mkLogger (o^.optLogLevel) (o^.optLogNetStrings) + lgr <- Log.mkLogger (o^.optLogLevel) (o^.optLogNetStrings) (o^.optLogFormat) mgr <- initHttpManager awe <- initAws o lgr mgr return $ Env awe met lgr mgr def (o^.optSettings) diff --git a/services/cargohold/src/CargoHold/Options.hs b/services/cargohold/src/CargoHold/Options.hs index 3043dad1afb..2791fe07e21 100644 --- a/services/cargohold/src/CargoHold/Options.hs +++ b/services/cargohold/src/CargoHold/Options.hs @@ -6,7 +6,7 @@ import Imports import CargoHold.CloudFront (Domain (..), KeyPairId (..)) import Control.Lens hiding (Level) import Data.Aeson.TH -import System.Logger (Level) +import System.Logger.Extended (Level, LogFormat) import Util.Options import Util.Options.Common @@ -62,8 +62,9 @@ data Opts = Opts , _optSettings :: !Settings -- Logging , _optLogLevel :: !Level -- ^ Log level (Debug, Info, etc) - , _optLogNetStrings :: !Bool -- ^ Use netstrings encoding: - -- + , _optLogNetStrings :: !(Maybe (Last Bool)) -- ^ Use netstrings encoding: + -- + , _optLogFormat :: !(Maybe (Last LogFormat)) --- ^ Log format } deriving (Show, Generic) deriveFromJSON toOptionFieldName ''Opts diff --git a/services/galley/galley.integration.yaml b/services/galley/galley.integration.yaml index 8e6a3d0cbe7..c6dd2d9d00a 100644 --- a/services/galley/galley.integration.yaml +++ b/services/galley/galley.integration.yaml @@ -26,6 +26,24 @@ settings: maxConvSize: 16 intraListing: false conversationCodeURI: https://app.wire.com/join/ + featureFlags: + # SSO: this sets the default setting for each time, which can + # always be overridden by customer support / backoffice. + # IMPORTANT: if you change sso from 'enabled' to 'disabled' after + # running 'enabled' in production, you need to run this migration + # script to fix all teams that have registered an idp: + # https://github.com/wireapp/wire-server/tree/master/tools/db/migrate-sso-feature-flag + # if you don't, the idp will keep working, but the admin won't be + # able to register new idps. + # disabled for integration tests (the ones who need it on will + # turn it on themselves). + sso: false + + # Legal Hold: this decides whether customer support / backoffice + # is allowed to turn the feature on for individual teams. the + # default for new teams is always "false", no matter what the + # feature flag is set to. + legalhold: true logLevel: Info logNetStrings: false diff --git a/services/galley/src/Galley/API.hs b/services/galley/src/Galley/API.hs index 5fc89f373b9..6c2d729a935 100644 --- a/services/galley/src/Galley/API.hs +++ b/services/galley/src/Galley/API.hs @@ -360,6 +360,7 @@ sitemap = do parameter Path "cnv" bytes' $ description "Conversation ID" errorResponse Error.convNotFound + errorResponse Error.convAccessDenied --- @@ -828,6 +829,32 @@ sitemap = do accept "application" "json" .&. query "base_url" + --- team feature flags (public) + + get "/teams/:tid/features/legalhold" (continue Teams.getLegalholdStatus) $ + zauthUserId + .&. capture "tid" + .&. accept "application" "json" + + document "GET" "getLegalholdStatus" $ do + summary "Shows whether the LegalHold feature is enabled for team" + parameter Path "tid" bytes' $ + description "Team ID" + returns (ref Model.legalHoldTeamConfig) + response 200 "LegalHold status" end + + get "/teams/:tid/features/sso" (continue Teams.getSSOStatus) $ + 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 Model.ssoTeamConfig) + response 200 "SSO status" end + -- internal put "/i/conversations/:cnv/channel" (continue $ const (return empty)) $ @@ -912,20 +939,10 @@ sitemap = do get "/i/users/:uid/team" (continue getBindingTeamId) $ capture "uid" - -- Start of team features; enabling this should only be + -- Start of team features (internal); enabling this should only be -- possible internally. Viewing the status should be allowed -- for any admin - get "/teams/:tid/features/legalhold" (continue Teams.getLegalholdStatus) $ - zauthUserId - .&. capture "tid" - .&. accept "application" "json" - - get "/teams/:tid/features/sso" (continue Teams.getSSOStatus) $ - zauthUserId - .&. capture "tid" - .&. accept "application" "json" - get "/i/teams/:tid/features/legalhold" (continue Teams.getLegalholdStatusInternal) $ capture "tid" .&. accept "application" "json" diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 25de2f576e4..bd7c1e1bfd6 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -124,6 +124,9 @@ legalHoldServiceNotRegistered = Error status400 "legalhold-not-registered" "lega legalHoldServiceBadResponse :: Error legalHoldServiceBadResponse = Error status400 "legalhold-status-bad" "legal hold service: invalid response" +legalHoldFeatureFlagNotEnabled :: Error +legalHoldFeatureFlagNotEnabled = Error status403 "legalhold-not-enabled" "legal hold is not enabled for this wire instance" + legalHoldNotEnabled :: Error legalHoldNotEnabled = Error status403 "legalhold-not-enabled" "legal hold is not enabled for this team" diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index d570a66fd2f..9abb37d61b4 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -3,12 +3,12 @@ module Galley.API.LegalHold where import Imports import Galley.API.Error import Brig.Types.Provider -import Brig.Types.Team.LegalHold +import Brig.Types.Team.LegalHold hiding (userId) import Brig.Types.Client.Prekey import Control.Monad.Catch import Control.Lens (view, (^.)) import Data.Id -import Data.ByteString.Conversion (toByteString') +import Data.ByteString.Conversion (toByteString', toByteString) import Data.Misc import Data.LegalHold (UserLegalHoldStatus(..)) import Galley.API.Util @@ -42,6 +42,10 @@ createSettings (zusr ::: tid ::: req ::: _) = do assertLegalHoldEnabled tid membs <- Data.teamMembers tid + let zothers = map (view userId) membs + Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) + . Log.msg (Log.val "LegalHold.createSettings") + void $ permissionCheck zusr ChangeLegalHoldTeamSettings membs newService :: NewLegalHoldService @@ -71,8 +75,11 @@ getSettings (zusr ::: tid ::: _) = do removeSettings :: UserId ::: TeamId ::: JsonRequest RemoveLegalHoldSettingsRequest ::: JSON -> Galley Response removeSettings (zusr ::: tid ::: req ::: _) = do assertLegalHoldEnabled tid - membs <- Data.teamMembers tid + let zothers = map (view userId) membs + Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) + . Log.msg (Log.val "LegalHold.removeSettings") + void $ permissionCheck zusr ChangeLegalHoldTeamSettings membs RemoveLegalHoldSettingsRequest mPassword <- fromJsonBody req ensureReAuthorised zusr mPassword @@ -87,6 +94,10 @@ removeSettings' -> Galley () removeSettings' tid mMembers = do membs <- maybe (Data.teamMembers tid) pure mMembers + let zothers = map (view userId) membs + Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) + . Log.msg (Log.val "LegalHold.removeSettings'") + let lhMembers = filter ((== UserLegalHoldEnabled) . view legalHoldStatus) membs -- I picked this number by fair dice roll, feel free to change it :P pooledMapConcurrentlyN_ 6 removeLHForUser lhMembers @@ -129,6 +140,8 @@ requestDevice :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response requestDevice (zusr ::: tid ::: uid ::: _) = do assertLegalHoldEnabled tid + Log.debug $ Log.field "targets" (toByteString uid) + . Log.msg (Log.val "LegalHold.requestDevice") membs <- Data.teamMembers tid void $ permissionCheck zusr ChangeLegalHoldUserSettings membs @@ -164,6 +177,8 @@ approveDevice -> Galley Response approveDevice (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do assertLegalHoldEnabled tid + Log.debug $ Log.field "targets" (toByteString uid) + . Log.msg (Log.val "LegalHold.approveDevice") unless (zusr == uid) (throwM accessDenied) assertOnTeam uid tid @@ -199,6 +214,8 @@ disableForUser :: UserId ::: TeamId ::: UserId ::: JsonRequest DisableLegalHoldForUserRequest ::: JSON -> Galley Response disableForUser (zusr ::: tid ::: uid ::: req ::: _) = do + Log.debug $ Log.field "targets" (toByteString uid) + . Log.msg (Log.val "LegalHold.disableForUser") membs <- Data.teamMembers tid void $ permissionCheck zusr ChangeLegalHoldUserSettings membs if userLHNotDisabled membs diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 4c375d67eaa..8193e90706c 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -44,7 +44,7 @@ getConversation (zusr ::: cnv ::: _) = do Data.deleteConversation cnv throwM convNotFound unless (zusr `isMember` Data.convMembers c) $ - throwM convNotFound + throwM convAccessDenied a <- conversationView zusr c return $ json a diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index d8a6f19c9b7..ac31ac1cdf4 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -71,6 +71,7 @@ import qualified Galley.Types as Conv import qualified Galley.Types.Teams as Teams import qualified Galley.Intra.Journal as Journal import qualified Galley.Intra.Spar as Spar +import qualified System.Logger.Class as Log getTeam :: UserId ::: TeamId ::: JSON -> Galley Response getTeam (zusr::: tid ::: _) = @@ -112,6 +113,8 @@ createNonBindingTeam (zusr::: zcon ::: req ::: _) = do let zothers = map (view userId) others ensureUnboundUsers (zusr : zothers) ensureConnected zusr zothers + Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) + . Log.msg (Log.val "Teams.createNonBindingTeam") team <- Data.createTeam Nothing zusr (body^.newTeamName) (body^.newTeamIcon) (body^.newTeamIconKey) NonBinding finishCreateTeam team owner others (Just zcon) @@ -149,6 +152,9 @@ updateTeam :: UserId ::: ConnId ::: TeamId ::: JsonRequest TeamUpdateData ::: JS updateTeam (zusr::: zcon ::: tid ::: req ::: _) = do body <- fromJsonBody req membs <- Data.teamMembers tid + let zothers = map (view userId) membs + Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) + . Log.msg (Log.val "Teams.updateTeam") void $ permissionCheck zusr SetTeamData membs Data.updateTeam tid body now <- liftIO getCurrentTime @@ -243,16 +249,17 @@ uncheckedGetTeamMembers (tid ::: _) = do addTeamMember :: UserId ::: ConnId ::: TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley Response addTeamMember (zusr ::: zcon ::: tid ::: req ::: _) = do nmem <- fromJsonBody req + let uid = nmem^.ntmNewTeamMember.userId + Log.debug $ Log.field "targets" (toByteString uid) + . Log.msg (Log.val "Teams.addTeamMember") mems <- Data.teamMembers tid - -- verify permissions tmem <- permissionCheck zusr AddTeamMember mems let targetPermissions = nmem^.ntmNewTeamMember.permissions targetPermissions `ensureNotElevated` tmem - ensureNonBindingTeam tid - ensureUnboundUsers [nmem^.ntmNewTeamMember.userId] - ensureConnected zusr [nmem^.ntmNewTeamMember.userId] + ensureUnboundUsers [uid] + ensureConnected zusr [uid] addTeamMemberInternal tid (Just zusr) (Just zcon) nmem mems -- This function is "unchecked" because there is no need to check for user binding (invite only). @@ -272,6 +279,9 @@ updateTeamMember (zusr ::: zcon ::: tid ::: req ::: _) = do let targetId = targetMember^.userId targetPermissions = targetMember^.permissions + Log.debug $ Log.field "targets" (toByteString targetId) + . Log.msg (Log.val "Teams.updateTeamMember") + -- get the team and verify permissions team <- tdTeam <$> (Data.team tid >>= ifNothing teamNotFound) members <- Data.teamMembers tid @@ -305,6 +315,7 @@ updateTeamMember (zusr ::: zcon ::: tid ::: req ::: _) = do privilegedUpdate = mkUpdate $ Just targetPermissions privilegedRecipients = membersToRecipients Nothing privileged + now <- liftIO getCurrentTime let ePriv = newEvent MemberUpdate tid now & eventData ?~ privilegedUpdate @@ -315,6 +326,8 @@ updateTeamMember (zusr ::: zcon ::: tid ::: req ::: _) = do deleteTeamMember :: UserId ::: ConnId ::: TeamId ::: UserId ::: Request ::: Maybe JSON ::: JSON -> Galley Response deleteTeamMember (zusr::: zcon ::: tid ::: remove ::: req ::: _ ::: _) = do + Log.debug $ Log.field "targets" (toByteString remove) + . Log.msg (Log.val "Teams.deleteTeamMember") mems <- Data.teamMembers tid void $ permissionCheck zusr RemoveTeamMember mems okToDelete <- canBeDeleted [] remove tid @@ -447,10 +460,12 @@ ensureNotElevated targetPermissions member = addTeamMemberInternal :: TeamId -> Maybe UserId -> Maybe ConnId -> NewTeamMember -> [TeamMember] -> Galley Response addTeamMemberInternal tid origin originConn newMem mems = do + let new = newMem^.ntmNewTeamMember + Log.debug $ Log.field "targets" (toByteString (new^.userId)) + . Log.msg (Log.val "Teams.addTeamMemberInternal") o <- view options unless (length mems < fromIntegral (o^.optSettings.setMaxTeamSize)) $ throwM tooManyTeamMembers - let new = newMem^.ntmNewTeamMember Data.addTeamMember tid new cc <- filter (view managedConversation) <$> Data.teamConversations tid now <- liftIO getCurrentTime @@ -508,13 +523,16 @@ getLegalholdStatus (uid ::: tid ::: ct) = do -- These endpoints are internal only and meant to be called -- only from authorized personnel (e.g., from a backoffice tool) --- | Get legal SSO status for a team. +-- | Get SSO status for a team. getSSOStatusInternal :: TeamId ::: JSON -> Galley Response getSSOStatusInternal (tid ::: _) = do + defConfig <- do + featureSSO <- view (options . optSettings . featureEnabled FeatureSSO) + pure $ if featureSSO + then SSOTeamConfig SSOEnabled + else SSOTeamConfig SSODisabled ssoTeamConfig <- SSOData.getSSOTeamConfig tid pure . json . fromMaybe defConfig $ ssoTeamConfig - where - defConfig = SSOTeamConfig SSODisabled -- | Enable or disable SSO for a team. setSSOStatusInternal :: TeamId ::: JsonRequest SSOTeamConfig ::: JSON -> Galley Response @@ -537,6 +555,9 @@ getLegalholdStatusInternal (tid ::: _) = do -- | Enable or disable legal hold for a team. setLegalholdStatusInternal :: TeamId ::: JsonRequest LegalHoldTeamConfig ::: JSON -> Galley Response setLegalholdStatusInternal (tid ::: req ::: _) = do + do featureLegalHold <- view (options . optSettings . featureEnabled FeatureLegalHold) + unless featureLegalHold $ throwM legalHoldFeatureFlagNotEnabled + legalHoldTeamConfig <- fromJsonBody req case legalHoldTeamConfigStatus legalHoldTeamConfig of LegalHoldDisabled -> removeSettings' tid Nothing diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index f043a62c4aa..eb7eb137427 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -128,7 +128,7 @@ instance HasRequestId Galley where createEnv :: Metrics -> Opts -> IO Env createEnv m o = do - l <- Logger.mkLogger (o ^. optLogLevel) (o ^. optLogNetStrings) + l <- Logger.mkLogger (o ^. optLogLevel) (o ^. optLogNetStrings) (o ^. optLogFormat) mgr <- initHttpManager o Env def m o l mgr <$> initCassandra o l <*> Q.new 16000 diff --git a/services/galley/src/Galley/Options.hs b/services/galley/src/Galley/Options.hs index 019a37ad480..41977fdf406 100644 --- a/services/galley/src/Galley/Options.hs +++ b/services/galley/src/Galley/Options.hs @@ -5,8 +5,9 @@ import Control.Lens hiding ((.=), Level) import Data.Aeson.TH (deriveFromJSON) import Util.Options import Util.Options.Common -import System.Logger.Class (Level) +import System.Logger.Extended (Level, LogFormat) import Data.Misc +import Galley.Types.Teams (FeatureFlags(..), FeatureFlag) data Settings = Settings { @@ -20,11 +21,19 @@ data Settings = Settings , _setIntraListing :: !Bool -- | URI prefix for conversations with access mode @code@ , _setConversationCodeURI :: !HttpsUrl + , _setFeatureFlags :: !(Maybe FeatureFlags) } deriving (Show, Generic) deriveFromJSON toOptionFieldName ''Settings makeLenses ''Settings +featureEnabled :: FeatureFlag -> Getter Settings Bool +featureEnabled flag + = setFeatureFlags + . to (\case + Nothing -> False + Just (FeatureFlags flags) -> flag `elem` flags) + data JournalOpts = JournalOpts { _awsQueueName :: !Text -- ^ SQS queue name to send team events , _awsEndpoint :: !AWSEndpoint -- ^ AWS endpoint @@ -45,8 +54,9 @@ data Opts = Opts -- disables journaling) -- Logging , _optLogLevel :: !Level -- ^ Log level (Debug, Info, etc) - , _optLogNetStrings :: !Bool -- ^ Use netstrings encoding: - -- + , _optLogNetStrings :: !(Maybe (Last Bool)) -- ^ Use netstrings encoding + -- + , _optLogFormat :: !(Maybe (Last LogFormat)) -- ^ What log format to use } deriveFromJSON toOptionFieldName ''Opts diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 2ad135dc4cd..7cbcef3b99d 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -141,7 +141,7 @@ postConvOk = do cvs <- mapM (convView cid) [alice, bob, jane] liftIO $ mapM_ WS.assertSuccess =<< Async.mapConcurrently (checkWs alice) (zip cvs [wsA, wsB, wsJ]) where - convView cnv usr = decodeBody' "conversation" <$> getConv usr cnv + convView cnv usr = decodeBodyMsg "conversation" <$> getConv usr cnv checkWs alice (cnv, ws) = WS.awaitMatch (5 # Second) ws $ \n -> do ntfTransient n @?= False let e = List1.head (WS.unpackPayload n) @@ -251,12 +251,12 @@ postCryptoMessage2 = do let m = [(bob, bc, "hello bob")] r1 <- postOtrMessage id alice ac conv m Map.lookup eve (userClientMap p) @=? Just [ec] @@ -274,12 +274,12 @@ postCryptoMessage3 = do let m = otrRecipients [(bob, [(bc, ciphertext)])] r1 <- postProtoOtrMessage alice ac conv m Map.lookup eve (userClientMap p) @=? Just [ec] @@ -327,7 +327,7 @@ postCryptoMessage5 = do const 201 === statusCode _rs <- postOtrMessage (queryItem "report_missing" (toByteString' eve)) alice ac conv [] postO2OConv alice bob (Just "gossip1") + cnv1 <- decodeBodyMsg "conversation" <$> postO2OConv alice bob (Just "gossip1") getConvs alice (Just $ Left [cnvId cnv1]) Nothing !!! do const 200 === statusCode const (Just [cnvId cnv1]) === fmap (map cnvId . convList) . decodeBody -- create & get group conv carl <- randomUser connectUsers alice (singleton carl) - cnv2 <- decodeBody' "conversation" <$> postConv alice [bob, carl] (Just "gossip2") [] Nothing Nothing + cnv2 <- decodeBodyMsg "conversation" <$> postConv alice [bob, carl] (Just "gossip2") [] Nothing Nothing getConvs alice (Just $ Left [cnvId cnv2]) Nothing !!! do const 200 === statusCode const (Just [cnvId cnv2]) === fmap (map cnvId . convList) . decodeBody @@ -709,7 +709,7 @@ postRepeatConnectConvCancel = do -- Alice wants to connect rsp1 <- postConnectConv alice bob "A" "a" Nothing getConv bob (cnvId cnv) + cnvX <- decodeBodyMsg "conversation" <$> getConv bob (cnvId cnv) liftIO $ do ConnectConv @=? cnvType cnvX (Just "B") @=? cnvName cnvX @@ -749,7 +749,7 @@ postRepeatConnectConvCancel = do -- Alice accepts, finally turning it into a 1-1 putConvAccept alice (cnvId cnv) !!! const 200 === statusCode - cnv4 <- decodeBody' "conversation" <$> getConv alice (cnvId cnv) + cnv4 <- decodeBodyMsg "conversation" <$> getConv alice (cnvId cnv) liftIO $ do One2OneConv @=? cnvType cnv4 (Just "B") @=? cnvName cnv4 @@ -759,17 +759,17 @@ postRepeatConnectConvCancel = do g <- view tsGalley put (g . paths ["/i/conversations", toByteString' (cnvId c), "block"] . zUser u) !!! const 200 === statusCode - getConv u (cnvId c) !!! const 404 === statusCode + getConv u (cnvId c) !!! const 403 === statusCode putBlockConvOk :: TestM () putBlockConvOk = do g <- view tsGalley alice <- randomUser bob <- randomUser - conv <- decodeBody' "conversation" <$> postConnectConv alice bob "Alice" "connect with me!" (Just "me@me.com") + conv <- decodeBodyMsg "conversation" <$> postConnectConv alice bob "Alice" "connect with me!" (Just "me@me.com") getConv alice (cnvId conv) !!! const 200 === statusCode - getConv bob (cnvId conv) !!! const 404 === statusCode + getConv bob (cnvId conv) !!! const 403 === statusCode put (g . paths ["/i/conversations", toByteString' (cnvId conv), "block"] . zUser bob) !!! const 200 === statusCode @@ -777,7 +777,7 @@ putBlockConvOk = do -- A is still the only member of the 1-1 getConv alice (cnvId conv) !!! do const 200 === statusCode - const (cnvMembers conv) === cnvMembers . decodeBody' "conversation" + const (cnvMembers conv) === cnvMembers . decodeBodyMsg "conversation" -- B accepts the conversation by unblocking put (g . paths ["/i/conversations", toByteString' (cnvId conv), "unblock"] . zUser bob) !!! @@ -789,7 +789,7 @@ putBlockConvOk = do const 200 === statusCode -- B no longer sees the 1-1 - getConv bob (cnvId conv) !!! const 404 === statusCode + getConv bob (cnvId conv) !!! const 403 === statusCode -- B unblocks A in the 1-1 put (g . paths ["/i/conversations", toByteString' (cnvId conv), "unblock"] . zUser bob) !!! @@ -922,6 +922,10 @@ deleteMembersOk = do conv <- decodeConvId <$> postConv alice [bob, eve] (Just "gossip") [] Nothing Nothing deleteMember bob bob conv !!! const 200 === statusCode deleteMember bob bob conv !!! const 404 === statusCode + + -- if conversation still exists, don't respond with 404, but with 403. + getConv bob conv !!! const 403 === statusCode + deleteMember alice eve conv !!! const 200 === statusCode deleteMember alice eve conv !!! const 204 === statusCode deleteMember alice alice conv !!! const 200 === statusCode diff --git a/services/galley/test/integration/API/MessageTimer.hs b/services/galley/test/integration/API/MessageTimer.hs index 50a42bb9431..a09c2787f18 100644 --- a/services/galley/test/integration/API/MessageTimer.hs +++ b/services/galley/test/integration/API/MessageTimer.hs @@ -80,7 +80,7 @@ messageTimerChangeGuest = do -- Try to change the timer (as the guest user) and observe failure putMessageTimerUpdate guest cid (ConversationMessageTimerUpdate timer1sec) !!! do const 403 === statusCode - const "access-denied" === (label . decodeBody' "error label") + const "access-denied" === (label . decodeBodyMsg "error label") getConv guest cid !!! const Nothing === (cnvMessageTimer <=< decodeBody) -- Try to change the timer (as a team member) and observe success @@ -100,9 +100,9 @@ messageTimerChangeO2O = do -- Try to change the timer and observe failure putMessageTimerUpdate alice cid (ConversationMessageTimerUpdate timer1sec) !!! do const 403 === statusCode - const "invalid-op" === (label . decodeBody' "error label") + const "invalid-op" === (label . decodeBodyMsg "error label") getConv alice cid !!! - const Nothing === (cnvMessageTimer <=< decodeBody) + const Nothing === (cnvMessageTimer <=< decodeBodyM) messageTimerEvent :: TestM () messageTimerEvent = do diff --git a/services/galley/test/integration/API/SQS.hs b/services/galley/test/integration/API/SQS.hs index 738d3de8778..829fe19d9a1 100644 --- a/services/galley/test/integration/API/SQS.hs +++ b/services/galley/test/integration/API/SQS.hs @@ -2,7 +2,7 @@ -- instead. module API.SQS where -import Imports hiding (trace) +import Imports import Control.Exception (SomeAsyncException, asyncExceptionFromException) import Control.Lens hiding ((.=)) import Control.Monad.Catch hiding (bracket) diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 5f9d7126462..b5b74e640db 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -15,6 +15,7 @@ import Data.Id import Data.List1 import Data.Misc (PlainTextPassword (..)) import Data.Range +import Galley.Options (optSettings, featureEnabled) import Galley.Types hiding (EventType (..), EventData (..), MemberUpdate (..)) import Galley.Types.Teams import Galley.Types.Teams.Intra @@ -22,7 +23,7 @@ import Galley.Types.Teams.SSO import Gundeck.Types.Notification import Network.HTTP.Types.Status (status403) import TestHelpers (test) -import TestSetup (TestSetup, TestM, tsCannon, tsGalley) +import TestSetup (TestSetup, TestM, tsCannon, tsGalley, tsGConf) import Test.Tasty import Test.Tasty.Cannon (TimeoutUnit (..), (#)) import Test.Tasty.HUnit @@ -175,7 +176,12 @@ testEnableSSOPerTeam = do assertEqual "bad status" status403 status assertEqual "bad label" "not-implemented" label - check "Teams should start with SSO disabled" SSODisabled + featureSSO <- view (tsGConf . optSettings . featureEnabled FeatureSSO) + if not featureSSO + then do + check "Teams should start with SSO disabled" SSODisabled + else do + check "Teams should start with SSO enabled" SSOEnabled putSSOEnabledInternal tid SSOEnabled check "Calling 'putEnabled True' should enable SSO" SSOEnabled @@ -195,7 +201,7 @@ testCreateOne2OneFailNonBindingTeamMembers = do -- Cannot create a 1-1 conversation, not connected and in the same team but not binding Util.createOne2OneTeamConv (mem1^.userId) (mem2^.userId) Nothing tid !!! do const 404 === statusCode - const "non-binding-team" === (Error.label . Util.decodeBody' "error label") + const "non-binding-team" === (Error.label . Util.decodeBodyMsg "error label") -- Both have a binding team but not the same team owner1 <- Util.randomUser tid1 <- Util.createTeamInternal "foo" owner1 @@ -205,7 +211,7 @@ testCreateOne2OneFailNonBindingTeamMembers = do assertQueue "create another team" tActivate Util.createOne2OneTeamConv owner1 owner2 Nothing tid1 !!! do const 403 === statusCode - const "non-binding-team-members" === (Error.label . Util.decodeBody' "error label") + const "non-binding-team-members" === (Error.label . Util.decodeBodyMsg "error label") testCreateOne2OneWithMembers :: HasCallStack @@ -384,7 +390,7 @@ testRemoveBindingTeamMember ownerHasPassword = do . json (newTeamMemberDeleteData (Just $ PlainTextPassword "wrong passwd")) ) !!! do const 403 === statusCode - const "access-denied" === (Error.label . Util.decodeBody' "error label") + const "access-denied" === (Error.label . Util.decodeBodyMsg "error label") -- Mem1 is still part of Wire Util.ensureDeletedState False owner (mem1^.userId) @@ -491,7 +497,7 @@ testAddTeamConvAsExternalPartner = do (Just "blaa") acc (Just TeamAccessRole) Nothing !!! do const 403 === statusCode - const "operation-denied" === (Error.label . Util.decodeBody' "error label") + const "operation-denied" === (Error.label . Util.decodeBodyMsg "error label") testAddManagedConv :: TestM () testAddManagedConv = do @@ -550,7 +556,7 @@ testAddTeamMemberToConv = do Util.assertNotConvMember (mem3^.userId) cid Util.postMembers (mem3^.userId) (list1 (mem1^.userId) []) cid !!! do const 403 === statusCode - const "operation-denied" === (Error.label . Util.decodeBody' "error label") + const "operation-denied" === (Error.label . Util.decodeBodyMsg "error label") testUpdateTeamConv :: Role -- ^ Role of the user who creates the conversation @@ -613,7 +619,7 @@ testDeleteTeam = do Util.getConv u x !!! const 404 === statusCode Util.getSelfMember u x !!! do const 200 === statusCode - const (Just Null) === Util.decodeBody + const (Just Null) === Util.decodeBodyM assertQueueEmpty testDeleteBindingTeam :: Bool -> TestM () @@ -644,7 +650,7 @@ testDeleteBindingTeam ownerHasPassword = do . json (newTeamDeleteData (Just $ PlainTextPassword "wrong passwd")) ) !!! do const 403 === statusCode - const "access-denied" === (Error.label . Util.decodeBody' "error label") + const "access-denied" === (Error.label . Util.decodeBodyMsg "error label") delete ( g . paths ["teams", toByteString' tid, "members", toByteString' (mem3^.userId)] @@ -809,7 +815,7 @@ testUpdateTeamMember = do . json changeOwner ) !!! do const 403 === statusCode - const "no-other-owner" === (Error.label . Util.decodeBody' "error label") + const "no-other-owner" === (Error.label . Util.decodeBodyMsg "error label") let changeMember = newNewTeamMember (member & permissions .~ fullPermissions) WS.bracketR2 c owner (member^.userId) $ \(wsOwner, wsMember) -> do put ( g @@ -869,7 +875,7 @@ testUpdateTeamStatus = do . json (TeamStatusUpdate Deleted Nothing) ) !!! do const 403 === statusCode - const "invalid-team-status-update" === (Error.label . Util.decodeBody' "error label") + const "invalid-team-status-update" === (Error.label . Util.decodeBodyMsg "error label") checkUserDeleteEvent :: HasCallStack => UserId -> WS.WebSocket -> TestM () checkUserDeleteEvent uid w = WS.assertMatch_ timeout w $ \notif -> do @@ -1138,12 +1144,15 @@ getLegalHoldEnabledInternal tid = do . paths ["i", "teams", toByteString' tid, "features", "legalhold"] putLegalHoldEnabledInternal :: HasCallStack => TeamId -> LegalHoldStatus -> TestM () -putLegalHoldEnabledInternal tid enabled = do +putLegalHoldEnabledInternal = putLegalHoldEnabledInternal' expect2xx + +putLegalHoldEnabledInternal' :: HasCallStack => (Request -> Request) -> TeamId -> LegalHoldStatus -> TestM () +putLegalHoldEnabledInternal' reqmod tid enabled = do g <- view tsGalley void . put $ g . paths ["i", "teams", toByteString' tid, "features", "legalhold"] . json (LegalHoldTeamConfig enabled) - . expect2xx + . reqmod testFeatureFlags :: TestM () @@ -1166,12 +1175,21 @@ testFeatureFlags = do setSSOInternal :: HasCallStack => SSOStatus -> TestM () setSSOInternal = putSSOEnabledInternal tid - getSSO SSODisabled - getSSOInternal SSODisabled + featureSSO <- view (tsGConf . optSettings . featureEnabled FeatureSSO) + if not featureSSO + then do -- disabled + getSSO SSODisabled + getSSOInternal SSODisabled + + setSSOInternal SSOEnabled + getSSO SSOEnabled + getSSOInternal SSOEnabled - setSSOInternal SSOEnabled - getSSO SSOEnabled - getSSOInternal SSOEnabled + else do -- enabled + -- 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 -- legalhold @@ -1191,6 +1209,11 @@ testFeatureFlags = do getLegalHold LegalHoldDisabled getLegalHoldInternal LegalHoldDisabled - setLegalHoldInternal LegalHoldEnabled - getLegalHold LegalHoldEnabled - getLegalHoldInternal LegalHoldEnabled + featureLegalHold <- view (tsGConf . optSettings . featureEnabled FeatureLegalHold) + if featureLegalHold + then do + setLegalHoldInternal LegalHoldEnabled + getLegalHold LegalHoldEnabled + getLegalHoldInternal LegalHoldEnabled + else do + putLegalHoldEnabledInternal' expect4xx tid LegalHoldEnabled diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 42da85d3506..55f352369ef 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -31,6 +31,7 @@ import Data.Text.Encoding (encodeUtf8) import Galley.API.Swagger (GalleyRoutes) import Galley.External.LegalHoldService (validateServiceKey) import Galley.Types.Teams +import Galley.Options (optSettings, featureEnabled) import GHC.Generics hiding (to) import GHC.TypeLits import Gundeck.Types.Notification (ntfPayload) @@ -39,6 +40,7 @@ import Network.Wai import Network.Wai as Wai import Servant.Swagger (validateEveryToJSON) import System.Environment (withArgs) +import System.IO (hPutStrLn) import TestHelpers import Test.Hspec (hspec) import Test.QuickCheck.Instances () @@ -65,27 +67,34 @@ import qualified Galley.Types.Clients as Clients import qualified Test.Tasty.Cannon as WS +onlyIfLhEnabled :: TestM () -> TestM () +onlyIfLhEnabled action = do + featureLegalHold <- view (tsGConf . optSettings . featureEnabled FeatureLegalHold) + if featureLegalHold + then action + else liftIO $ hPutStrLn stderr "*** legalhold feature flag disabled, not running integration tests" + tests :: IO TestSetup -> TestTree tests s = testGroup "Teams LegalHold API" - [ test s "swagger / json consistency" testSwaggerJsonConsistency + [ test s "swagger / json consistency" (onlyIfLhEnabled testSwaggerJsonConsistency) -- device handling (CRUD) - , test s "POST /teams/{tid}/legalhold/{uid}" testRequestLegalHoldDevice - , test s "PUT /teams/{tid}/legalhold/approve" testApproveLegalHoldDevice + , test s "POST /teams/{tid}/legalhold/{uid}" (onlyIfLhEnabled testRequestLegalHoldDevice) + , test s "PUT /teams/{tid}/legalhold/approve" (onlyIfLhEnabled testApproveLegalHoldDevice) , test s "(user denies approval: nothing needs to be done in backend)" (pure ()) - , test s "GET /teams/{tid}/legalhold/{uid}" testGetLegalHoldDeviceStatus - , test s "DELETE /teams/{tid}/legalhold/{uid}" testDisableLegalHoldForUser + , test s "GET /teams/{tid}/legalhold/{uid}" (onlyIfLhEnabled testGetLegalHoldDeviceStatus) + , test s "DELETE /teams/{tid}/legalhold/{uid}" (onlyIfLhEnabled testDisableLegalHoldForUser) -- legal hold settings - , test s "POST /teams/{tid}/legalhold/settings" testCreateLegalHoldTeamSettings - , test s "GET /teams/{tid}/legalhold/settings" testGetLegalHoldTeamSettings - , test s "DELETE /teams/{tid}/legalhold/settings" testRemoveLegalHoldFromTeam - , test s "GET, PUT [/i]?/teams/{tid}/legalhold" testEnablePerTeam + , test s "POST /teams/{tid}/legalhold/settings" (onlyIfLhEnabled testCreateLegalHoldTeamSettings) + , test s "GET /teams/{tid}/legalhold/settings" (onlyIfLhEnabled testGetLegalHoldTeamSettings) + , test s "DELETE /teams/{tid}/legalhold/settings" (onlyIfLhEnabled testRemoveLegalHoldFromTeam) + , test s "GET, PUT [/i]?/teams/{tid}/legalhold" (onlyIfLhEnabled testEnablePerTeam) -- behavior of existing end-points - , test s "POST /clients" testCannotCreateLegalHoldDeviceOldAPI + , test s "POST /clients" (onlyIfLhEnabled testCannotCreateLegalHoldDeviceOldAPI) - , test s "GET /teams/{tid}/members" testGetTeamMembersIncludesLHStatus + , test s "GET /teams/{tid}/members" (onlyIfLhEnabled testGetTeamMembersIncludesLHStatus) -- See also Client Tests in Brig; where behaviour around deleting/adding LH clients is -- tested @@ -345,7 +354,7 @@ testCreateLegalHoldTeamSettings = do -- behaving or not) let lhapp :: HasCallStack => IsWorking -> Chan Void -> Application lhapp NotWorking _ _ cont = cont respondBad - lhapp Working _ req cont = trace "APP" $ do + lhapp Working _ req cont = do if | pathInfo req /= ["legalhold", "status"] -> cont respondBad | requestMethod req /= "GET" -> cont respondBad | otherwise -> cont respondOk diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index cf09c45a59f..1485041b042 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -93,25 +93,25 @@ getTeam :: HasCallStack => UserId -> TeamId -> TestM Team getTeam usr tid = do g <- view tsGalley r <- get (g . paths ["teams", toByteString' tid] . zUser usr) UserId -> TeamId -> TestM TeamMemberList getTeamMembers usr tid = do g <- view tsGalley r <- get (g . paths ["teams", toByteString' tid, "members"] . zUser usr) UserId -> TeamId -> UserId -> TestM TeamMember getTeamMember usr tid mid = do g <- view tsGalley r <- get (g . paths ["teams", toByteString' tid, "members", toByteString' mid] . zUser usr) TeamId -> UserId -> TestM TeamMember getTeamMemberInternal tid mid = do g <- view tsGalley r <- get (g . paths ["i", "teams", toByteString' tid, "members", toByteString' mid]) UserId -> TeamId -> TeamMember -> TestM () addTeamMember usr tid mem = do @@ -449,13 +449,13 @@ assertConvMember :: HasCallStack => UserId -> ConvId -> TestM () assertConvMember u c = getSelfMember u c !!! do const 200 === statusCode - const (Just u) === (fmap memId <$> decodeBody) + const (Right u) === (fmap memId <$> decodeBodyE) assertNotConvMember :: HasCallStack => UserId -> ConvId -> TestM () assertNotConvMember u c = getSelfMember u c !!! do - const 200 === statusCode - const (Just Null) === decodeBody + const 200 === statusCode + const (Right Null) === decodeBodyE ------------------------------------------------------------------------------- -- Common Assertions @@ -608,10 +608,10 @@ decodeConvId r = fromMaybe (error "Failed to parse conversation") $ cnvId <$> decodeBody r decodeConvList :: Response (Maybe Lazy.ByteString) -> [Conversation] -decodeConvList = convList . decodeBody' "conversations" +decodeConvList = convList . decodeBodyMsg "conversations" decodeConvIdList :: Response (Maybe Lazy.ByteString) -> [ConvId] -decodeConvIdList = convList . decodeBody' "conversation-ids" +decodeConvIdList = convList . decodeBodyMsg "conversation-ids" zUser :: UserId -> Request -> Request zUser = header "Z-User" . toByteString' @@ -785,15 +785,19 @@ randomUserWithClient lk = do newNonce :: TestM (Id ()) newNonce = randomId -decodeBody :: (HasCallStack, FromJSON a) => Response (Maybe Lazy.ByteString) -> Maybe a -decodeBody r = do - b <- responseBody r - case decode b of - Nothing -> traceShow b Nothing - Just a -> Just a +decodeBodyE :: (HasCallStack, FromJSON a) => Response (Maybe Lazy.ByteString) -> Either String a +decodeBodyE rsp = do + bdy <- maybe (Left "no body") Right $ responseBody rsp + eitherDecode bdy -decodeBody' :: (HasCallStack, FromJSON a) => String -> Response (Maybe Lazy.ByteString) -> a -decodeBody' s = fromMaybe (error $ "decodeBody: " ++ s) . decodeBody +decodeBodyM :: (HasCallStack, FromJSON a) => Response (Maybe Lazy.ByteString) -> Maybe a +decodeBodyM = either (const Nothing) Just . decodeBodyE + +decodeBody :: (HasCallStack, FromJSON a) => Response (Maybe Lazy.ByteString) -> a +decodeBody = decodeBodyMsg mempty + +decodeBodyMsg :: (HasCallStack, FromJSON a) => String -> Response (Maybe Lazy.ByteString) -> a +decodeBodyMsg usrerr = either (\prserr -> error $ "decodeBody: " ++ show (prserr, usrerr)) id . decodeBodyE fromBS :: (HasCallStack, FromByteString a, Monad m) => ByteString -> m a fromBS = maybe (fail "fromBS: no parse") return . fromByteString diff --git a/services/gundeck/package.yaml b/services/gundeck/package.yaml index 31bfa6f5b6b..c4ca4033a46 100644 --- a/services/gundeck/package.yaml +++ b/services/gundeck/package.yaml @@ -15,32 +15,6 @@ library: source-dirs: src ghc-options: - -fwarn-incomplete-uni-patterns - exposed-modules: - - Gundeck.API - - Gundeck.API.Error - - Gundeck.Aws - - Gundeck.Aws.Arn - - Gundeck.Aws.Sns - - Gundeck.Client - - Gundeck.Env - - Gundeck.Instances - - Gundeck.Monad - - Gundeck.Notification - - Gundeck.Notification.Data - - Gundeck.Options - - Gundeck.Presence - - Gundeck.Presence.Data - - Gundeck.Push - - Gundeck.Push.Data - - Gundeck.Push.Native - - Gundeck.Push.Native.Serialise - - Gundeck.Push.Native.Types - - Gundeck.Push.Websocket - - Gundeck.React - - Gundeck.Run - - Gundeck.Util - - Gundeck.Util.DelayQueue - - Gundeck.Util.Redis dependencies: - aeson >=0.11 - amazonka >=1.3.7 diff --git a/services/gundeck/src/Gundeck/Env.hs b/services/gundeck/src/Gundeck/Env.hs index 6670955f5d3..df349104d52 100644 --- a/services/gundeck/src/Gundeck/Env.hs +++ b/services/gundeck/src/Gundeck/Env.hs @@ -41,7 +41,7 @@ schemaVersion = 7 createEnv :: Metrics -> Opts -> IO Env createEnv m o = do - l <- Logger.mkLogger (o ^. optLogLevel) (o ^. optLogNetStrings) + l <- Logger.mkLogger (o ^. optLogLevel) (o ^. optLogNetStrings) (o ^. optLogFormat) c <- maybe (C.initialContactsPlain (o^.optCassandra.casEndpoint.epHost)) (C.initialContactsDisco "cassandra_gundeck") (unpack <$> o^.optDiscoUrl) diff --git a/services/gundeck/src/Gundeck/Options.hs b/services/gundeck/src/Gundeck/Options.hs index 87fcad453b0..eb0effdc4f0 100644 --- a/services/gundeck/src/Gundeck/Options.hs +++ b/services/gundeck/src/Gundeck/Options.hs @@ -7,7 +7,7 @@ import Control.Lens hiding (Level) import Data.Aeson.TH import Data.Yaml (FromJSON) import Gundeck.Aws.Arn -import System.Logger (Level) +import System.Logger.Extended (Level, LogFormat) import Util.Options import Util.Options.Common @@ -50,8 +50,9 @@ data Opts = Opts , _optSettings :: !Settings -- Logging , _optLogLevel :: !Level -- ^ Log level (Debug, Info, etc) - , _optLogNetStrings :: !Bool -- ^ Use netstrings encoding: + , _optLogNetStrings :: !(Maybe (Last Bool)) -- ^ Use netstrings encoding: -- + , _optLogFormat :: !(Maybe (Last LogFormat)) } deriving (Show, Generic) deriveFromJSON toOptionFieldName ''Opts diff --git a/services/proxy/package.yaml b/services/proxy/package.yaml index 231917c582b..a930bdf79f4 100644 --- a/services/proxy/package.yaml +++ b/services/proxy/package.yaml @@ -15,12 +15,6 @@ library: source-dirs: src ghc-options: - -funbox-strict-fields - exposed-modules: - - Proxy.API - - Proxy.Env - - Proxy.Options - - Proxy.Proxy - - Proxy.Run dependencies: - base >=4.6 && <5 - aeson >=1.0 diff --git a/services/proxy/src/Proxy/Env.hs b/services/proxy/src/Proxy/Env.hs index 1fbb7f27c01..f997da756c0 100644 --- a/services/proxy/src/Proxy/Env.hs +++ b/services/proxy/src/Proxy/Env.hs @@ -37,7 +37,7 @@ makeLenses ''Env createEnv :: Metrics -> Opts -> IO Env createEnv m o = do - g <- Logger.mkLogger (o^.logLevel) (o^.logNetStrings) + g <- Logger.mkLogger (o^.logLevel) (o^.logNetStrings) (o^.logFormat) n <- newManager tlsManagerSettings { managerConnCount = o^.httpPoolSize , managerIdleConnectionCount = 3 * (o^.httpPoolSize) diff --git a/services/proxy/src/Proxy/Options.hs b/services/proxy/src/Proxy/Options.hs index 8a1da25d44f..5c86858bbfe 100644 --- a/services/proxy/src/Proxy/Options.hs +++ b/services/proxy/src/Proxy/Options.hs @@ -7,6 +7,7 @@ module Proxy.Options , maxConns , logLevel , logNetStrings + , logFormat , mockOpts ) where @@ -14,7 +15,7 @@ import Imports import Control.Lens hiding (Level) import Data.Aeson import Data.Aeson.TH -import System.Logger.Class (Level(Debug)) +import System.Logger.Extended (Level(Debug), LogFormat) data Opts = Opts { _host :: !String -- ^ Host to listen on @@ -24,8 +25,8 @@ data Opts = Opts , _maxConns :: !Int -- ^ Maximum number of incoming connections -- Logging , _logLevel :: !Level -- ^ Log level (Debug, Info, etc) - , _logNetStrings :: !Bool -- ^ Use netstrings encoding (see - -- ) + , _logNetStrings :: !(Maybe (Last Bool)) -- ^ Use netstrings encoding + , _logFormat :: !(Maybe (Last LogFormat))-- ^ choose Encoding } deriving (Show, Generic) makeLenses ''Opts @@ -41,5 +42,6 @@ mockOpts secrets = Opts , _httpPoolSize = 0 , _maxConns = 0 , _logLevel = Debug - , _logNetStrings = True + , _logNetStrings = pure $ pure $ True + , _logFormat = mempty } diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 664c36bfe99..d21ee53ed2a 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -189,7 +189,7 @@ autoprovisionSamlUserWithId buid suid mbName managedBy = do if null scimtoks then createSamlUserWithId buid suid mbName managedBy else throwError . SAML.Forbidden $ - "bad credentials (note that your team has uses SCIM, " <> + "bad credentials (note that your team uses SCIM, " <> "which disables saml auto-provisioning)" -- | Check if 'UserId' is in the team that hosts the idp that owns the 'UserRef'. If so, write the diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index 3684c3e6c36..33f363c281c 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -83,7 +83,7 @@ runServer sparCtxOpts = do mkApp :: Opts -> IO (Application, Env) mkApp sparCtxOpts = do let logLevel = toLevel $ saml sparCtxOpts ^. SAML.cfgLogLevel - sparCtxLogger <- Log.mkLogger logLevel (logNetStrings sparCtxOpts) + sparCtxLogger <- Log.mkLogger logLevel (logNetStrings sparCtxOpts) (logFormat sparCtxOpts) sparCtxCas <- initCassandra sparCtxOpts sparCtxLogger sparCtxHttpManager <- newManager defaultManagerSettings let sparCtxHttpBrig = diff --git a/services/spar/src/Spar/Types.hs b/services/spar/src/Spar/Types.hs index e1a5651473a..425ccf7654b 100644 --- a/services/spar/src/Spar/Types.hs +++ b/services/spar/src/Spar/Types.hs @@ -27,6 +27,7 @@ import URI.ByteString import Util.Options import Web.Cookie import Web.HttpApiData +import System.Logger.Extended (LogFormat) import qualified Data.ByteString.Builder as Builder import qualified Data.Text as ST @@ -189,7 +190,8 @@ data Opts' a = Opts -- | Wire/AWS specific; optional; used to discover Cassandra instance -- IPs using describe-instances. , discoUrl :: !(Maybe Text) - , logNetStrings :: !Bool + , logNetStrings :: !(Maybe (Last Bool)) + , logFormat :: !(Maybe (Last LogFormat)) -- , optSettings :: !Settings -- (nothing yet; see other services for what belongs in here.) , derivedOpts :: !a } diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 177b749db9d..03f8187b284 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -12,9 +12,10 @@ import Data.Id import Data.Proxy import Data.String.Conversions import Data.UUID as UUID hiding (null, fromByteString) +import Network.HTTP.Types (status200) import SAML2.WebSSO as SAML -import SAML2.WebSSO.Test.MockResponse import SAML2.WebSSO.Test.Lenses +import SAML2.WebSSO.Test.MockResponse import Spar.API.Types import Spar.Types import URI.ByteString.QQ (uri) @@ -531,6 +532,20 @@ specCRUDIdentityProvider = do whichone (env ^. teSpar) (Just newmember) idpid `shouldRespondWith` checkErr (== 403) "insufficient-permissions" + -- Authenticate via sso, and assign owner status to the thus created user. (This + -- doesn't work via the cookie, since we don't talk to nginz here, so we assume there + -- is only one user in the team, which is the original owner.) + mkSsoOwner :: UserId -> TeamId -> IdP -> TestSpar UserId + mkSsoOwner firstOwner tid idp = do + spmeta <- getTestSPMetadata + (privcreds, authnreq) <- negotiateAuthnRequest idp + authnresp <- runSimpleSP $ mkAuthnResponse privcreds idp spmeta authnreq True + loginresp <- submitAuthnResponse authnresp + liftIO $ responseStatus loginresp `shouldBe` status200 + [ssoOwner] <- filter (/= firstOwner) <$> getTeamMembers firstOwner tid + promoteTeamMember firstOwner tid ssoOwner + pure ssoOwner + describe "GET /identity-providers/:idp" $ do testGetPutDelete callIdpGet' @@ -542,6 +557,14 @@ specCRUDIdentityProvider = do _ <- call $ callIdpGet (env ^. teSpar) (Just owner) idpid passes + context "known IdP, client is team owner (authenticated via sso, user without email)" $ do + it "responds with 2xx and IdP" $ do + env <- ask + (firstOwner, tid, idp) <- registerTestIdP + ssoOwner <- mkSsoOwner firstOwner tid idp + _ <- call $ callIdpGet (env ^. teSpar) (Just ssoOwner) (idp ^. idpId) + passes + describe "GET /identity-providers" $ do context "client is not team owner" $ do @@ -555,8 +578,8 @@ specCRUDIdentityProvider = do callIdpGetAll' (env ^. teSpar) (Just member) `shouldRespondWith` checkErr (== 403) "insufficient-permissions" - context "client is team owner" $ do - context "no idps registered" $ do + context "no idps registered" $ do + context "client is team owner" $ do it "returns an empty list" $ do env <- ask (owner :: UserId, _teamid :: TeamId) @@ -564,7 +587,8 @@ specCRUDIdentityProvider = do callIdpGetAll (env ^. teSpar) (Just owner) `shouldRespondWith` (null . _idplProviders) - context "some idps are registered" $ do + context "some idps are registered" $ do + context "client is team owner with email" $ do it "returns a non-empty empty list" $ do env <- ask metadata <- makeTestIdPMetadata @@ -572,12 +596,21 @@ specCRUDIdentityProvider = do callIdpGetAll (env ^. teSpar) (Just owner) `shouldRespondWith` (not . null . _idplProviders) + context "client is team owner without email" $ do + it "returns a non-empty empty list" $ do + env <- ask + metadata <- makeTestIdPMetadata + (firstOwner, tid, idp) <- registerTestIdPFrom metadata (env ^. teMgr) (env ^. teBrig) (env ^. teGalley) (env ^. teSpar) + ssoOwner <- mkSsoOwner firstOwner tid idp + callIdpGetAll (env ^. teSpar) (Just ssoOwner) + `shouldRespondWith` (not . null . _idplProviders) + describe "DELETE /identity-providers/:idp" $ do testGetPutDelete callIdpDelete' context "known IdP, client is team owner" $ do - it "responds with 2xx and removes IdP" $ do + context "without email" $ it "responds with 2xx and removes IdP" $ do env <- ask (userid, _, (^. idpId) -> idpid) <- registerTestIdP callIdpDelete' (env ^. teSpar) (Just userid) idpid @@ -585,6 +618,15 @@ specCRUDIdentityProvider = do callIdpGet' (env ^. teSpar) (Just userid) idpid `shouldRespondWith` checkErr (== 404) "not-found" + context "with email" $ it "responds with 2xx and removes IdP" $ do + env <- ask + (firstOwner, tid, idp) <- registerTestIdP + ssoOwner <- mkSsoOwner firstOwner tid idp + callIdpDelete' (env ^. teSpar) (Just ssoOwner) (idp ^. idpId) + `shouldRespondWith` \resp -> statusCode resp < 300 + callIdpGet' (env ^. teSpar) (Just ssoOwner) (idp ^. idpId) + `shouldRespondWith` checkErr (== 404) "not-found" + -- there are no routes for PUT yet. xdescribe "PUT /identity-providers/:idp" $ do @@ -602,6 +644,8 @@ specCRUDIdentityProvider = do pending -- (only test for signature here, but make sure that the same validity tests -- are performed as for POST in Spar.API.) + it "also works with sso-authenticated users (see above)" $ pending + describe "POST /identity-providers" $ do context "sso disabled for team" $ do @@ -661,7 +705,7 @@ specCRUDIdentityProvider = do statusCode resp3 `shouldBe` 400 responseJSON resp3 `shouldBe` Right (TestErrorLabel "idp-already-in-use") - context "everything in order" $ do + context "client is owner with email" $ do it "responds with 2xx; makes IdP available for GET /identity-providers/" $ do env <- ask (owner, _) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) @@ -670,6 +714,10 @@ specCRUDIdentityProvider = do idp' <- call $ callIdpGet (env ^. teSpar) (Just owner) (idp ^. idpId) liftIO $ idp `shouldBe` idp' + context "client is owner without email" $ do + it "responds with 2xx; makes IdP available for GET /identity-providers/" $ do + pending + describe "with json body" $ do context "bad json" $ do it "responds with a 'client error'" $ do diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index f1bc063f724..2deac91f144 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -33,6 +33,8 @@ module Util.Core , createTeamMember , deleteUserOnBrig , getTeams + , getTeamMembers + , promoteTeamMember , getSelfProfile , nextWireId , nextSAMLID @@ -180,7 +182,7 @@ cliOptsParser = (,) <$> mkEnv :: HasCallStack => IntegrationConfig -> Opts -> IO TestEnv mkEnv _teTstOpts _teOpts = do _teMgr :: Manager <- newManager defaultManagerSettings - sparCtxLogger <- Log.mkLogger (toLevel $ saml _teOpts ^. SAML.cfgLogLevel) (logNetStrings _teOpts) + sparCtxLogger <- Log.mkLogger (toLevel $ saml _teOpts ^. SAML.cfgLogLevel) (logNetStrings _teOpts) (logFormat _teOpts) _teCql :: ClientState <- initCassandra _teOpts sparCtxLogger let _teBrig = endpointToReq (cfgBrig _teTstOpts) _teGalley = endpointToReq (cfgGalley _teTstOpts) @@ -371,6 +373,23 @@ getTeams u gly = do ) return $ decodeBody' r +getTeamMembers :: HasCallStack => UserId -> TeamId -> TestSpar [UserId] +getTeamMembers usr tid = do + gly <- view teGalley + resp <- call $ get (gly . paths ["teams", toByteString' tid, "members"] . zUser usr) + (mems ^. Galley.teamMembers) + +promoteTeamMember :: HasCallStack => UserId -> TeamId -> UserId -> TestSpar () +promoteTeamMember usr tid memid = do + gly <- view teGalley + let bdy :: Galley.NewTeamMember + bdy = Galley.newNewTeamMember $ Galley.newTeamMember memid Galley.fullPermissions Nothing + call $ put (gly . paths ["teams", toByteString' tid, "members"] . zAuthAccess usr "conn" . json bdy) + !!! const 200 === statusCode + getSelfProfile :: (HasCallStack, MonadHttp m, MonadIO m) => BrigReq -> UserId -> m Brig.SelfProfile getSelfProfile brg usr = do rsp <- get $ brg . path "/self" . zUser usr diff --git a/tools/api-simulations/package.yaml b/tools/api-simulations/package.yaml index 24c485565d7..1d716b2ceb6 100644 --- a/tools/api-simulations/package.yaml +++ b/tools/api-simulations/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: api-simulations version: '0.4.2' @@ -19,8 +19,6 @@ dependencies: - split >=0.2 library: source-dirs: lib/src - exposed-modules: - - Network.Wire.Simulations dependencies: - aeson >=0.7 - base >=4.6 diff --git a/tools/bonanza/package.yaml b/tools/bonanza/package.yaml index 7832ba05de5..69676d95f51 100644 --- a/tools/bonanza/package.yaml +++ b/tools/bonanza/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: bonanza version: '3.6.0' @@ -19,28 +19,6 @@ library: ghc-options: - -funbox-small-strict-fields - -fno-warn-unused-do-bind - exposed-modules: - - Bonanza.Anon - - Bonanza.App - - Bonanza.Geo - - Bonanza.Metrics - - Bonanza.Parser.CommonLog - - Bonanza.Parser.IP - - Bonanza.Parser.Internal - - Bonanza.Parser.Journald - - Bonanza.Parser.Netstrings - - Bonanza.Parser.Nginz - - Bonanza.Parser.Rkt - - Bonanza.Parser.Socklog - - Bonanza.Parser.Svlogd - - Bonanza.Parser.Time - - Bonanza.Parser.Tinylog - - Bonanza.Streaming.Binary - - Bonanza.Streaming.Kibana - - Bonanza.Streaming.Parser - - Bonanza.Streaming.Protobuf - - Bonanza.Streaming.Snappy - - Bonanza.Types dependencies: - base ==4.* - aeson >=1.0 diff --git a/tools/makedeb/package.yaml b/tools/makedeb/package.yaml index 103f8aefe0b..7fba18cca67 100644 --- a/tools/makedeb/package.yaml +++ b/tools/makedeb/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: makedeb version: '0.3.0' @@ -13,8 +13,6 @@ dependencies: - imports library: source-dirs: src - exposed-modules: - - System.MakeDeb dependencies: - base >=4.6 && <5.0 - directory >=1.2 diff --git a/tools/stern/package.yaml b/tools/stern/package.yaml index 88e2b1c413f..f290f3c23c3 100644 --- a/tools/stern/package.yaml +++ b/tools/stern/package.yaml @@ -16,10 +16,6 @@ library: source-dirs: src ghc-options: - -funbox-strict-fields - exposed-modules: - - Stern.API - - Stern.App - - Stern.Options dependencies: - base >= 4.5 && < 5 - aeson >= 0.11 diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 9ae15bb5e9f..485f09a2532 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -306,7 +306,6 @@ sitemap = do description "Team ID" Doc.returns Doc.bool' Doc.response 200 "SSO status" Doc.end - Doc.returns Doc.bool' put "/teams/:tid/features/sso" (continue setSSOStatus) $ contentType "application" "json" diff --git a/tools/stern/src/Stern/App.hs b/tools/stern/src/Stern/App.hs index cd20dc649fd..b26e3a3946a 100644 --- a/tools/stern/src/Stern/App.hs +++ b/tools/stern/src/Stern/App.hs @@ -56,7 +56,7 @@ makeLenses ''Env newEnv :: Opts -> IO Env newEnv o = do mt <- Metrics.metrics - l <- Log.mkLogger (O.logLevel o) (O.logNetStrings o) + l <- Log.mkLogger (O.logLevel o) (O.logNetStrings o) (O.logFormat o) Env (mkRequest $ O.brig o) (mkRequest $ O.galley o) (mkRequest $ O.gundeck o) (mkRequest $ O.ibis o) (mkRequest $ O.galeb o) l mt <$> pure def <*> Bilge.newManager (Bilge.defaultManagerSettings { Bilge.managerResponseTimeout = responseTimeoutMicro 10000000 }) diff --git a/tools/stern/src/Stern/Options.hs b/tools/stern/src/Stern/Options.hs index 595ef90fced..9c4c4032106 100644 --- a/tools/stern/src/Stern/Options.hs +++ b/tools/stern/src/Stern/Options.hs @@ -7,7 +7,7 @@ import Data.Yaml (FromJSON(..)) import GHC.Generics import Imports import Util.Options -import System.Logger (Level) +import System.Logger.Extended (Level, LogFormat) -- | Options that are consumed on startup data Opts = Opts @@ -21,7 +21,8 @@ data Opts = Opts , galeb :: !Endpoint -- Logging , logLevel :: !Level - , logNetStrings :: !Bool + , logNetStrings :: !(Maybe (Last Bool)) + , logFormat :: !(Maybe (Last LogFormat)) } deriving (Show, Generic) instance FromJSON Opts