diff --git a/CHANGELOG.md b/CHANGELOG.md index 56689513437..05411c73826 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,26 @@ +# 2020-09-04 + +## Release Notes + +## Bug Fixes + +* Fixed logic related to ephemeral users (#1197) + +## New Features + +* SFT servers now exposed over /calls/config/v2 (#1177) +* First federation endpoint (#1188) + +## Internal changes + +* ormolu upgrade to 0.1.2.0 and formatting (#1145, #1185, #1186) +* handy cqlsh make target to manually poke at the database (#1170) +* spar cleanup +* brig user name during scim user parsing (#1195) +* invitation refactor (#1196) +* SCIM users are never ephemeral (#1198) + + # 2020-07-29 ## Release Notes diff --git a/SECURITY.md b/SECURITY.md new file mode 100644 index 00000000000..0c552947319 --- /dev/null +++ b/SECURITY.md @@ -0,0 +1 @@ +Please check Wire's [global SECURITY.md](https://github.com/wireapp/wire/blob/master/SECURITY.md). diff --git a/docs/reference/user/registration.md b/docs/reference/user/registration.md index 16eeec5e005..331932e774e 100644 --- a/docs/reference/user/registration.md +++ b/docs/reference/user/registration.md @@ -180,14 +180,13 @@ We need an option to block 1, 2, 5 on-prem; 3, 4 should remain available (no blo * Allow team members to register (via email/phone or SSO) * Allow ephemeral users -During registration, we can take advantage of [NewUserOrigin](https://github.com/wireapp/wire-server/blob/a89b9cd818997e7837e5d0938ecfd90cf8dd9e52/libs/wire-api/src/Wire/API/User.hs#L625); we're particularly interested in `NewUserOriginTeamUser` --> only `NewTeamMember` or `NewTeamMemberSSO` should be accepted. In case this is a `Nothing`, we need to check if the user expires, i.e., `newUserExpiresIn` must be a `Just`. +During registration, we can take advantage of [NewUserOrigin](https://github.com/wireapp/wire-server/blob/a89b9cd818997e7837e5d0938ecfd90cf8dd9e52/libs/wire-api/src/Wire/API/User.hs#L625); we're particularly interested in `NewUserOriginTeamUser` --> only `NewTeamMember` or `NewTeamMemberSSO` should be accepted. In case this is a `Nothing`, we need to check if the user expires, i.e., if the user has no identity (and thus `Ephemeral`). So `/register` should only succeed iff at least one of these conditions is true: ``` -newUserTeam == (Just (NewTeamMember _)) OR -newUserTeam == (Just (NewTeamMemberSSO _)) OR -newUserExpiresIn == (Just _) +import Brig.Types.User +isNewUserTeamMember || isNewUserEphemeral ``` The rest of the unauthorized end-points is safe: diff --git a/libs/api-bot/src/Network/Wire/Bot/Cache.hs b/libs/api-bot/src/Network/Wire/Bot/Cache.hs index ff532c5befc..94fe9c7b9ab 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Cache.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Cache.hs @@ -62,7 +62,7 @@ empty :: IO Cache empty = Cache <$> newIORef [] get :: (MonadIO m, HasCallStack) => Cache -> m CachedUser -get c = liftIO $ atomicModifyIORef (cache c) $ \u -> +get c = liftIO . atomicModifyIORef (cache c) $ \u -> case u of [] -> error @@ -71,7 +71,7 @@ get c = liftIO $ atomicModifyIORef (cache c) $ \u -> (x : xs) -> (xs, x) put :: MonadIO m => Cache -> CachedUser -> m () -put c a = liftIO $ atomicModifyIORef (cache c) $ \u -> (a : u, ()) +put c a = liftIO . atomicModifyIORef (cache c) $ \u -> (a : u, ()) toUser :: HasCallStack => Logger -> [CachedUser] -> [LText] -> IO [CachedUser] toUser _ acc [i, e, p] = do diff --git a/libs/api-bot/src/Network/Wire/Bot/Crypto.hs b/libs/api-bot/src/Network/Wire/Bot/Crypto.hs index 672ec009fbe..3167ef5fb21 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Crypto.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Crypto.hs @@ -181,9 +181,9 @@ decryptSymmetric _ (SymmetricKeys ekey mkey) msg = liftIO $ do let (dgst, ciphertext) = BS.splitAt 32 msg sha256 <- requireMaybe (digestFromByteString dgst) "Bad MAC" let mac = hmac (toByteString' mkey) ciphertext :: HMAC SHA256 - unless (HMAC sha256 == mac) - $ throwM - $ RequirementFailed "Bad MAC" + unless (HMAC sha256 == mac) $ + throwM $ + RequirementFailed "Bad MAC" let (iv, dat) = BS.splitAt 16 ciphertext return $ unpadPKCS7 $ cbcDecrypt aes (aesIV iv) dat diff --git a/libs/api-bot/src/Network/Wire/Bot/Crypto/Glue.hs b/libs/api-bot/src/Network/Wire/Bot/Crypto/Glue.hs index 6da93041c3d..61e306f7f27 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Crypto/Glue.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Crypto/Glue.hs @@ -50,7 +50,7 @@ deleteBox :: UserId -> Maybe Text -> IO () deleteBox uid label = do dir <- getBoxDir uid label removePathForcibly dir -- using "forcibly" so that it wouldn't fail - -- if the directory doesn't exist + -- if the directory doesn't exist genPrekeys :: Box -> Word16 -> IO [C.Prekey] genPrekeys box n = mapM (genPrekey box) [1 .. n - 1] diff --git a/libs/api-bot/src/Network/Wire/Bot/Monad.hs b/libs/api-bot/src/Network/Wire/Bot/Monad.hs index 81dc76665d9..da01c668e79 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Monad.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Monad.hs @@ -187,16 +187,16 @@ initMetrics = do return m where counters = - Metrics.assertionsTotal - : Metrics.assertionsFailed - : Metrics.exceptionsTotal - : Metrics.botsCreatedNew - : Metrics.botsCreatedCached - : Metrics.eventsTotalRcvd - : Metrics.eventsTotalAckd - : Metrics.eventsTotalIgnd - : Metrics.eventsTotalMssd - : concatMap etc [(minBound :: EventType) ..] + Metrics.assertionsTotal : + Metrics.assertionsFailed : + Metrics.exceptionsTotal : + Metrics.botsCreatedNew : + Metrics.botsCreatedCached : + Metrics.eventsTotalRcvd : + Metrics.eventsTotalAckd : + Metrics.eventsTotalIgnd : + Metrics.eventsTotalMssd : + concatMap etc [(minBound :: EventType) ..] etc t = [ Metrics.eventTypeRcvd t, Metrics.eventTypeAckd t, @@ -562,9 +562,9 @@ assertEqual a b m = assertTrue :: (HasCallStack, MonadBotNet m) => Bool -> Text -> m () assertTrue b m = - whenAsserts - $ unless b - $ assertFailure m -- the 'unless' is hidden under 'whenAsserts' + whenAsserts $ + unless b $ + assertFailure m -- the 'unless' is hidden under 'whenAsserts' -- because we don't want 'b' to be evaluated -- when asserts are disabled @@ -615,7 +615,7 @@ scheduleAssert bot typ f out = whenAsserts $ do writeTQueue (botAsserts bot) (EventAssertion typ t f out callStack) writeTVar (botAssertCount bot) (n + 1) return True - unless r $ liftBotNet $ do + unless r . liftBotNet $ do incrAssertFailed runBotSession bot . log Error . msg $ "Too many event assertions. Dropped: " <> eventTypeText typ @@ -698,7 +698,7 @@ mkBot tag user pw = do return bot connectPush :: Bot -> BotNetEnv -> IO (Async ()) -connectPush bot e = runBotNet e $ runBotSession bot $ do +connectPush bot e = runBotNet e . runBotSession bot $ do log Info $ msg (val "Establishing push channel") awaitNotifications (consume bot e) @@ -725,14 +725,14 @@ heartbeat bot e = forever $ do let l = botNetLogger e -- Refresh the auth token, if necessary (auth, expiry) <- readIORef $ botAuth bot - when (now > expiry) - $ void . forkIO . runBotNet e . runBotSession bot - $ do - log Debug $ msg (val "Refreshing auth token") - refreshAuth auth - >>= maybe - (log Error $ msg (val "Failed to refresh auth token")) - setAuth + when (now > expiry) $ + void . forkIO . runBotNet e . runBotSession bot $ + do + log Debug $ msg (val "Refreshing auth token") + refreshAuth auth + >>= maybe + (log Error $ msg (val "Failed to refresh auth token")) + setAuth -- Event & assertion maintenance when (botNetAssert e) $ do -- Remove old events from the inbox @@ -742,17 +742,18 @@ heartbeat bot e = forever $ do msg ("Event Timeout: " <> showEventType evt) -- Check if the event inbox is full and if so, log a warning size <- fst <$> readTVarIO (botEvents bot) - when (size == botMaxEvents (botSettings bot)) - $ botLog l bot Warn - $ msg (val "Event inbox full!") + when (size == botMaxEvents (botSettings bot)) $ + botLog l bot Warn $ + msg (val "Event inbox full!") -- Remove old assertions from the backlog asserts <- atomically $ gcBacklog bot now forM_ asserts $ \(EventAssertion typ _ _ out stack) -> do for_ out $ liftIO . atomically . flip tryPutTMVar Nothing - botLog l bot Warn $ msg $ - "Assertion Timeout: " <> eventTypeText typ - <> "\nAssertion was created at: " - <> pack (prettyCallStack stack) + botLog l bot Warn $ + msg $ + "Assertion Timeout: " <> eventTypeText typ + <> "\nAssertion was created at: " + <> pack (prettyCallStack stack) -- Re-establish the push connection, if it died push <- maybe (return Nothing) poll =<< readIORef (botPushThread bot) case push of @@ -922,24 +923,25 @@ incrEventsMssd b e = HashMap.insertWith (+) (Metrics.eventTypeMssd e) 1 transferBotMetrics :: MonadBotNet m => Bot -> m () -transferBotMetrics b = getMetrics >>= \m -> liftIO $ do - -- Obtain current values - l@[rcvd, ackd, ignd, mssd] <- atomically $ do - rcvd <- readTVar $ botEventsRcvd (botMetrics b) - ackd <- readTVar $ botEventsAckd (botMetrics b) - ignd <- readTVar $ botEventsIgnd (botMetrics b) - mssd <- readTVar $ botEventsMssd (botMetrics b) - return [rcvd, ackd, ignd, mssd] - -- Update per event type counters - let add (p, n) = Metrics.counterAdd n p m - mapM_ add (concatMap HashMap.toList l) - -- Update Totals - add (Metrics.eventsTotalRcvd, sum rcvd) - add (Metrics.eventsTotalAckd, sum ackd) - add (Metrics.eventsTotalIgnd, sum ignd) - let s = sum mssd - add (Metrics.eventsTotalMssd, s) - add (Metrics.assertionsFailed, s) +transferBotMetrics b = + getMetrics >>= \m -> liftIO $ do + -- Obtain current values + l@[rcvd, ackd, ignd, mssd] <- atomically $ do + rcvd <- readTVar $ botEventsRcvd (botMetrics b) + ackd <- readTVar $ botEventsAckd (botMetrics b) + ignd <- readTVar $ botEventsIgnd (botMetrics b) + mssd <- readTVar $ botEventsMssd (botMetrics b) + return [rcvd, ackd, ignd, mssd] + -- Update per event type counters + let add (p, n) = Metrics.counterAdd n p m + mapM_ add (concatMap HashMap.toList l) + -- Update Totals + add (Metrics.eventsTotalRcvd, sum rcvd) + add (Metrics.eventsTotalAckd, sum ackd) + add (Metrics.eventsTotalIgnd, sum ignd) + let s = sum mssd + add (Metrics.eventsTotalMssd, s) + add (Metrics.assertionsFailed, s) ------------------------------------------------------------------------------- -- Logging diff --git a/libs/bilge/src/Bilge/Assert.hs b/libs/bilge/src/Bilge/Assert.hs index f2bfe648ddf..472117d11ff 100644 --- a/libs/bilge/src/Bilge/Assert.hs +++ b/libs/bilge/src/Bilge/Assert.hs @@ -85,9 +85,11 @@ io String diff --git a/libs/bilge/src/Bilge/IO.hs b/libs/bilge/src/Bilge/IO.hs index 221a3552d84..0a794cb2691 100644 --- a/libs/bilge/src/Bilge/IO.hs +++ b/libs/bilge/src/Bilge/IO.hs @@ -205,7 +205,7 @@ instance MonadBaseControl IO (HttpT IO) where instance MonadUnliftIO m => MonadUnliftIO (HttpT m) where withRunInIO inner = - HttpT $ ReaderT $ \r -> + HttpT . ReaderT $ \r -> withRunInIO $ \run -> inner (run . runHttpT r) diff --git a/libs/bilge/src/Bilge/RPC.hs b/libs/bilge/src/Bilge/RPC.hs index b671eabf961..50d8a6507b4 100644 --- a/libs/bilge/src/Bilge/RPC.hs +++ b/libs/bilge/src/Bilge/RPC.hs @@ -109,9 +109,9 @@ statusCheck :: Response (Maybe LByteString) -> m () statusCheck c f r = - unless (statusCode r == c) - $ throwError - $ f ("unexpected status code: " <> pack (show $ statusCode r)) + unless (statusCode r == c) $ + throwError $ + f ("unexpected status code: " <> pack (show $ statusCode r)) parseResponse :: (Exception e, MonadThrow m, Monad m, FromJSON a) => diff --git a/libs/bilge/src/Bilge/Response.hs b/libs/bilge/src/Bilge/Response.hs index 9aba3b8446d..5b6e373cba4 100644 --- a/libs/bilge/src/Bilge/Response.hs +++ b/libs/bilge/src/Bilge/Response.hs @@ -80,12 +80,12 @@ getCookieValue :: ByteString -> Response a -> Maybe ByteString getCookieValue cookieName resp = resp ^? to responseHeaders - . traversed -- Over each header - . filtered ((== "Set-Cookie") . fst) -- Select the cookie headers by name - . _2 -- Select Set-Cookie values - . to parseSetCookie - . filtered ((== cookieName) . setCookieName) -- Select only the cookie we want - . to setCookieValue -- extract the cookie value + . traversed -- Over each header + . filtered ((== "Set-Cookie") . fst) -- Select the cookie headers by name + . _2 -- Select Set-Cookie values + . to parseSetCookie + . filtered ((== cookieName) . setCookieName) -- Select only the cookie we want + . to setCookieValue -- extract the cookie value type ResponseLBS = Response (Maybe LByteString) diff --git a/libs/brig-types/brig-types.cabal b/libs/brig-types/brig-types.cabal index 53bcdd0e1fd..d467905e717 100644 --- a/libs/brig-types/brig-types.cabal +++ b/libs/brig-types/brig-types.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 7497d04521f12339e2a8f5537dacf242839dea9034f69e67f0a254b1548cadd9 +-- hash: fe16e52e870cb548573366fe9192319004e52c3e4d2ece172df69e408cbe391b name: brig-types version: 1.35.0 @@ -21,6 +21,7 @@ library exposed-modules: Brig.Types Brig.Types.Activation + Brig.Types.Calling Brig.Types.Client Brig.Types.Client.Prekey Brig.Types.Code @@ -37,7 +38,6 @@ library Brig.Types.Team.Invitation Brig.Types.Team.LegalHold Brig.Types.Test.Arbitrary - Brig.Types.TURN Brig.Types.User Brig.Types.User.Auth other-modules: diff --git a/libs/brig-types/src/Brig/Types.hs b/libs/brig-types/src/Brig/Types.hs index b4f3307ba91..fb1cff375a9 100644 --- a/libs/brig-types/src/Brig/Types.hs +++ b/libs/brig-types/src/Brig/Types.hs @@ -21,10 +21,10 @@ module Brig.Types where import Brig.Types.Activation as M +import Brig.Types.Calling as M import Brig.Types.Client as M import Brig.Types.Connection as M import Brig.Types.Properties as M import Brig.Types.Search as M -import Brig.Types.TURN as M import Brig.Types.Team as M import Brig.Types.User as M diff --git a/libs/brig-types/src/Brig/Types/TURN.hs b/libs/brig-types/src/Brig/Types/Calling.hs similarity index 96% rename from libs/brig-types/src/Brig/Types/TURN.hs rename to libs/brig-types/src/Brig/Types/Calling.hs index 0244e753405..2d7ee7ecfc1 100644 --- a/libs/brig-types/src/Brig/Types/TURN.hs +++ b/libs/brig-types/src/Brig/Types/Calling.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.Types.TURN +module Brig.Types.Calling ( -- * re-exports RTCConfiguration, rtcConfiguration, @@ -50,4 +50,4 @@ module Brig.Types.TURN ) where -import Wire.API.Call.TURN +import Wire.API.Call.Config diff --git a/libs/brig-types/src/Brig/Types/User.hs b/libs/brig-types/src/Brig/Types/User.hs index 11aebab832c..036681fcc55 100644 --- a/libs/brig-types/src/Brig/Types/User.hs +++ b/libs/brig-types/src/Brig/Types/User.hs @@ -43,6 +43,8 @@ module Brig.Types.User newUserEmail, newUserPhone, newUserSSOId, + isNewUserEphemeral, + isNewUserTeamMember, InvitationCode (..), BindingNewTeamUser (..), NewTeamUser (..), diff --git a/libs/brig-types/test/unit/Test/Brig/Roundtrip.hs b/libs/brig-types/test/unit/Test/Brig/Roundtrip.hs index 3bb3ac81d17..937baf53744 100644 --- a/libs/brig-types/test/unit/Test/Brig/Roundtrip.hs +++ b/libs/brig-types/test/unit/Test/Brig/Roundtrip.hs @@ -21,7 +21,7 @@ import Data.Aeson (FromJSON, ToJSON, parseJSON, toJSON) import Data.Aeson.Types (parseEither) import Imports import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck ((===), Arbitrary, counterexample, testProperty) +import Test.Tasty.QuickCheck (Arbitrary, counterexample, testProperty, (===)) import Type.Reflection (typeRep) testRoundTrip :: diff --git a/libs/cassandra-util/src/Cassandra/Exec.hs b/libs/cassandra-util/src/Cassandra/Exec.hs index 711b2beda91..bfe15af27f1 100644 --- a/libs/cassandra-util/src/Cassandra/Exec.hs +++ b/libs/cassandra-util/src/Cassandra/Exec.hs @@ -33,10 +33,10 @@ where import Cassandra.CQL (Consistency, R) import Control.Monad.Catch import Data.Conduit --- Things we just import and re-export. -import Database.CQL.IO as C (BatchM, Client, ClientState, MonadClient, Page (..), PrepQuery, Row, addPrepQuery, addQuery, adjustConsistency, adjustResponseTimeout, adjustSendTimeout, batch, emptyPage, init, liftClient, localState, paginate, prepared, query, query1, queryString, retry, runClient, schema, setConsistency, setSerialConsistency, setType, shutdown, trans, write) -- We only use these locally. import Database.CQL.IO (RetrySettings, RunQ, defRetrySettings, eagerRetrySettings) +-- Things we just import and re-export. +import Database.CQL.IO as C (BatchM, Client, ClientState, MonadClient, Page (..), PrepQuery, Row, addPrepQuery, addQuery, adjustConsistency, adjustResponseTimeout, adjustSendTimeout, batch, emptyPage, init, liftClient, localState, paginate, prepared, query, query1, queryString, retry, runClient, schema, setConsistency, setSerialConsistency, setType, shutdown, trans, write) import Database.CQL.Protocol (Error, QueryParams (QueryParams), Tuple) import Imports hiding (init) diff --git a/libs/cassandra-util/src/Cassandra/Schema.hs b/libs/cassandra-util/src/Cassandra/Schema.hs index 64243832540..9abf9b4ba27 100644 --- a/libs/cassandra-util/src/Cassandra/Schema.hs +++ b/libs/cassandra-util/src/Cassandra/Schema.hs @@ -125,12 +125,12 @@ schemaVersion = catch (fmap runIdentity <$> qry) h versionCheck :: Int32 -> Client () versionCheck v = do v' <- schemaVersion - unless (Just v <= v') - $ error - $ "Schema Version too old! Expecting at least: " - <> show v - <> ", but got: " - <> fromMaybe "" (show <$> v') + unless (Just v <= v') $ + error $ + "Schema Version too old! Expecting at least: " + <> show v + <> ", but got: " + <> fromMaybe "" (show <$> v') createKeyspace :: Keyspace -> ReplicationStrategy -> Client () createKeyspace (Keyspace k) rs = void $ schema (cql rs) (params All ()) @@ -165,8 +165,8 @@ migrateSchema :: Log.Logger -> MigrationOpts -> [Migration] -> IO () migrateSchema l o ms = do hosts <- initialContactsPlain $ pack (migHost o) p <- - CQL.init - $ setLogger (CT.mkLogger l) + CQL.init $ + setLogger (CT.mkLogger l) . setContacts (NonEmpty.head hosts) (NonEmpty.tail hosts) . setPortNumber (fromIntegral $ migPort o) . setMaxConnections 1 @@ -183,7 +183,7 @@ migrateSchema l o ms = do . setSendTimeout 20 . setResponseTimeout 50 . setProtocolVersion V4 - $ defSettings + $ defSettings runClient p $ do let keyspace = Keyspace . migKeyspace $ o when (migReset o) $ do diff --git a/libs/cassandra-util/src/Cassandra/Settings.hs b/libs/cassandra-util/src/Cassandra/Settings.hs index eab36353dc1..f11c0b7a6c2 100644 --- a/libs/cassandra-util/src/Cassandra/Settings.hs +++ b/libs/cassandra-util/src/Cassandra/Settings.hs @@ -46,13 +46,14 @@ initialContactsDisco (pack -> srv) url = liftIO $ do Nothing -> [srv, srv <> "_seed"] Just _ -> [srv] -- requesting only seeds is a valid use-case let ip = - rs ^.. responseBody - . key "roles" - . members - . indices (`elem` srvs) - . values - . key "privateIpAddress" - . _String + rs + ^.. responseBody + . key "roles" + . members + . indices (`elem` srvs) + . values + . key "privateIpAddress" + . _String & map unpack case ip of i : ii -> return (i :| ii) diff --git a/libs/cassandra-util/src/Cassandra/Util.hs b/libs/cassandra-util/src/Cassandra/Util.hs index 828c02e5706..348c1fa0f2a 100644 --- a/libs/cassandra-util/src/Cassandra/Util.hs +++ b/libs/cassandra-util/src/Cassandra/Util.hs @@ -38,9 +38,9 @@ writeTimeToUTC = posixSecondsToUTCTime . fromIntegral . (`div` 1000000) defInitCassandra :: Text -> Text -> Word16 -> Log.Logger -> IO ClientState defInitCassandra ks h p lg = - init - $ setLogger (CT.mkLogger lg) + init $ + setLogger (CT.mkLogger lg) . setPortNumber (fromIntegral p) . setContacts (unpack h) [] . setKeyspace (Keyspace ks) - $ defSettings + $ defSettings diff --git a/libs/federation-util/LICENSE b/libs/dns-util/LICENSE similarity index 100% rename from libs/federation-util/LICENSE rename to libs/dns-util/LICENSE diff --git a/libs/dns-util/dns-util.cabal b/libs/dns-util/dns-util.cabal new file mode 100644 index 00000000000..5f48111b480 --- /dev/null +++ b/libs/dns-util/dns-util.cabal @@ -0,0 +1,63 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 82f20a0525faea5f899c0a68fdc8a82623913d8b063f34a6cd4c6e32aa6acf54 + +name: dns-util +version: 0.1.0 +synopsis: Library to deal with DNS SRV records +description: Library to deal with DNS SRV records +category: Network +author: Wire Swiss GmbH +maintainer: Wire Swiss GmbH +copyright: (c) 2020 Wire Swiss GmbH +license: AGPL-3 +license-file: LICENSE +build-type: Simple + +library + exposed-modules: + Wire.Network.DNS.Effect + Wire.Network.DNS.SRV + other-modules: + Paths_dns_util + hs-source-dirs: + src + default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + build-depends: + base >=4.6 && <5.0 + , dns + , imports + , polysemy + , random + , text >=0.11 + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Wire.Network.DNS.SRVSpec + Paths_dns_util + hs-source-dirs: + test + default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + QuickCheck + , base >=4.6 && <5.0 + , dns + , dns-util + , hspec + , hspec-discover + , imports + , polysemy + , random + , text >=0.11 + default-language: Haskell2010 diff --git a/libs/dns-util/package.yaml b/libs/dns-util/package.yaml new file mode 100644 index 00000000000..210a4299ab6 --- /dev/null +++ b/libs/dns-util/package.yaml @@ -0,0 +1,34 @@ +defaults: + local: ../../package-defaults.yaml +name: dns-util +version: '0.1.0' +synopsis: Library to deal with DNS SRV records +description: Library to deal with DNS SRV records +category: Network +author: Wire Swiss GmbH +maintainer: Wire Swiss GmbH +copyright: (c) 2020 Wire Swiss GmbH +license: AGPL-3 +dependencies: +- base >=4.6 && <5.0 +- dns +- random +- text >=0.11 +- imports +- polysemy +library: + source-dirs: src + +tests: + spec: + main: Spec.hs + source-dirs: + - test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-tools: + - hspec-discover:hspec-discover + dependencies: + - hspec + - hspec-discover + - QuickCheck + - dns-util diff --git a/services/brig/src/Brig/TURN.hs b/libs/dns-util/src/Wire/Network/DNS/Effect.hs similarity index 59% rename from services/brig/src/Brig/TURN.hs rename to libs/dns-util/src/Wire/Network/DNS/Effect.hs index 0c95068938e..c70cdafa2a5 100644 --- a/services/brig/src/Brig/TURN.hs +++ b/libs/dns-util/src/Wire/Network/DNS/Effect.hs @@ -15,25 +15,22 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.TURN where +module Wire.Network.DNS.Effect where -import Brig.Types (TurnURI) -import Control.Lens -import Data.List1 import Imports -import OpenSSL.EVP.Digest (Digest) -import System.Random.MWC (GenIO, createSystemRandom) +import Network.DNS (Domain) +import qualified Network.DNS as DNS +import Polysemy +import Wire.Network.DNS.SRV -data Env = Env - { _turnServers :: List1 TurnURI, - _turnTokenTTL :: Word32, - _turnConfigTTL :: Word32, - _turnSecret :: ByteString, - _turnSHA512 :: Digest, - _turnPrng :: GenIO - } +data DNSLookup m a where + LookupSRV :: Domain -> DNSLookup m SrvResponse -makeLenses ''Env +makeSem ''DNSLookup -newEnv :: Digest -> List1 TurnURI -> Word32 -> Word32 -> ByteString -> IO Env -newEnv sha512 srvs tTTL cTTL secret = Env srvs tTTL cTTL secret sha512 <$> createSystemRandom +runDNSLookupDefault :: Member (Embed IO) r => Sem (DNSLookup ': r) a -> Sem r a +runDNSLookupDefault = + interpret $ \(LookupSRV domain) -> embed $ do + rs <- DNS.makeResolvSeed DNS.defaultResolvConf + DNS.withResolver rs $ \resolver -> + interpretResponse <$> DNS.lookupSRV resolver domain diff --git a/libs/federation-util/src/Network/Federation/Util/Internal.hs b/libs/dns-util/src/Wire/Network/DNS/SRV.hs similarity index 76% rename from libs/federation-util/src/Network/Federation/Util/Internal.hs rename to libs/dns-util/src/Wire/Network/DNS/SRV.hs index 26d2160175b..27105010929 100644 --- a/libs/federation-util/src/Network/Federation/Util/Internal.hs +++ b/libs/dns-util/src/Wire/Network/DNS/SRV.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . --- Parts of this code, namely functions srvLookup'' and orderSrvResult, +-- Parts of this code, namely functions interpretResponse and orderSrvResult, -- which were taken from http://hackage.haskell.org/package/pontarius-xmpp -- are also licensed under the three-clause BSD license: -- @@ -55,12 +55,12 @@ -- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -module Network.Federation.Util.Internal where +module Wire.Network.DNS.SRV where import Control.Category ((>>>)) -import Data.Text.Encoding (encodeUtf8) +import Data.List.NonEmpty (NonEmpty (..)) import Imports -import Network.DNS (DNSError, Domain, ResolvSeed, Resolver, lookupSRV, withResolver) +import Network.DNS (DNSError, Domain) import System.Random (randomRIO) data SrvEntry = SrvEntry @@ -78,37 +78,21 @@ data SrvTarget = SrvTarget } deriving (Eq, Show) -toSrvEntry :: (Word16, Word16, Word16, Domain) -> SrvEntry -toSrvEntry (prio, weight, port, domain) = SrvEntry prio weight (SrvTarget domain port) +data SrvResponse + = SrvNotAvailable + | SrvAvailable (NonEmpty SrvEntry) + | SrvResponseError DNSError + deriving (Eq, Show) --- Given a prefix (e.g. _wire-server) and a domain (e.g. wire.com), --- provides a list of A(AAA) names and port numbers upon a successful --- DNS-SRV request, or `Nothing' if the DNS-SRV request failed. --- Modified version inspired from http://hackage.haskell.org/package/pontarius-xmpp -srvLookup' :: Text -> Text -> ResolvSeed -> IO (Maybe [SrvTarget]) -srvLookup' = srvLookup'' lookupSRV +interpretResponse :: Either DNSError [(Word16, Word16, Word16, Domain)] -> SrvResponse +interpretResponse = \case + Left err -> SrvResponseError err + Right [] -> SrvNotAvailable + Right [(_, _, _, ".")] -> SrvNotAvailable -- According to RFC2782 + Right (r : rs) -> SrvAvailable $ fmap toSrvEntry (r :| rs) --- internal version for testing --- --- FUTUREWORK: return more precise errors than 'Nothing'? -srvLookup'' :: - (Resolver -> Domain -> IO (Either DNSError [(Word16, Word16, Word16, Domain)])) -> - Text -> - Text -> - ResolvSeed -> - IO (Maybe [SrvTarget]) -srvLookup'' lookupF prefix realm resolvSeed = withResolver resolvSeed $ \resolver -> do - srvResult <- lookupF resolver $ encodeUtf8 $ prefix <> "._tcp." <> realm <> "." - case srvResult of - -- The service is not available at this domain. - Left _ -> return Nothing - Right [] -> return Nothing - Right [(_, _, _, ".")] -> return Nothing -- "not available" as in RFC2782 - Right srvResult' -> do - let srvEntries = toSrvEntry <$> srvResult' - -- Get [(Domain, PortNumber)] of SRV request, if any. - -- Sorts the records based on the priority value. - Just . fmap srvTarget <$> orderSrvResult srvEntries +toSrvEntry :: (Word16, Word16, Word16, Domain) -> SrvEntry +toSrvEntry (prio, weight, port, domain) = SrvEntry prio weight (SrvTarget domain port) -- FUTUREWORK: maybe improve sorting algorithm here? (with respect to performance and code style) -- @@ -121,7 +105,7 @@ srvLookup'' lookupF prefix realm resolvSeed = withResolver resolvSeed $ \resolve orderSrvResult :: [SrvEntry] -> IO [SrvEntry] orderSrvResult = -- Order the result set by priority. - sortBy (comparing srvPriority) + sortOn srvPriority -- Group elements in sublists based on their priority. -- The result type is `[[(Word16, Word16, Word16, Domain)]]' (nested list). >>> groupBy ((==) `on` srvPriority) @@ -148,7 +132,7 @@ orderSrvResult = (b, (c : e)) -> (b, c, e) _ -> error "orderSrvResult: no record with running sum greater than random number" -- Remove the running total number from the remaining elements. - let remainingSrvs = map (\(srv, _) -> srv) (concat [beginning, end]) + let remainingSrvs = map fst (concat [beginning, end]) -- Repeat the ordering procedure on the remaining elements. rest <- orderSublist remainingSrvs return $ firstSrv : rest diff --git a/libs/federation-util/test/Spec.hs b/libs/dns-util/test/Spec.hs similarity index 100% rename from libs/federation-util/test/Spec.hs rename to libs/dns-util/test/Spec.hs diff --git a/libs/federation-util/test/Test/DNSSpec.hs b/libs/dns-util/test/Test/Wire/Network/DNS/SRVSpec.hs similarity index 60% rename from libs/federation-util/test/Test/DNSSpec.hs rename to libs/dns-util/test/Test/Wire/Network/DNS/SRVSpec.hs index f559f4a0dda..39c67a1ee2b 100644 --- a/libs/federation-util/test/Test/DNSSpec.hs +++ b/libs/dns-util/test/Test/Wire/Network/DNS/SRVSpec.hs @@ -15,16 +15,38 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.DNSSpec where +module Test.Wire.Network.DNS.SRVSpec where +import Data.List.NonEmpty (NonEmpty (..)) import Imports -import Network.DNS -import Network.Federation.Util.Internal +import qualified Network.DNS as DNS import Test.Hspec +import Wire.Network.DNS.SRV spec :: Spec spec = do - describe "order" $ do + describe "interpretResponse" $ do + it "should interpret error correctly" $ + interpretResponse (Left DNS.UnknownDNSError) `shouldBe` SrvResponseError DNS.UnknownDNSError + + it "should interpret empty response as SrvNotAvailable" $ + interpretResponse (Right []) `shouldBe` SrvNotAvailable + + it "should interpret explicitly not available response as SrvNotAvailable" $ + interpretResponse (Right [(0, 0, 0, ".")]) `shouldBe` SrvNotAvailable + + it "should interpret an available service correctly" $ do + let input = + [ (0, 1, 443, "service01.example.com."), + (10, 20, 8443, "service02.example.com.") + ] + let expectedOutput = + SrvAvailable + ( SrvEntry 0 1 (SrvTarget "service01.example.com." 443) + :| [SrvEntry 10 20 (SrvTarget "service02.example.com." 8443)] + ) + interpretResponse (Right input) `shouldBe` expectedOutput + describe "orderSrvResult" $ do it "orders records according to ascending priority" $ do actual <- orderSrvResult . map toSrvEntry $ @@ -59,29 +81,3 @@ spec = do length x `shouldSatisfy` (< 49) length y `shouldSatisfy` (> 0) length y `shouldSatisfy` (< 49) - describe "srvLookup" $ do - it "returns the expected result for wire.com" $ do - rs <- makeResolvSeed defaultResolvConf - wire <- srvLookup'' mockLookupSRV "_wire-server" "wire.com" rs - wire `shouldBe` Just [SrvTarget "wire.com" 443] - it "filters out single '.' results" $ do - rs <- makeResolvSeed defaultResolvConf - exampleDotCom <- srvLookup'' mockLookupSRV "_wire-server" "example.com" rs - exampleDotCom `shouldBe` Nothing - it "can return multiple results" $ do - rs <- makeResolvSeed defaultResolvConf - zinfra <- srvLookup'' mockLookupSRV "_wire-server" "zinfra.io" rs - (length <$> zinfra) `shouldBe` Just 2 - it "returns Nothing if there is no DNS record" $ do - rs <- makeResolvSeed defaultResolvConf - noRecord <- srvLookup'' mockLookupSRV "_wire-server" "no-record-here" rs - noRecord `shouldBe` Nothing - --- mock function matching Network.DNS's 'lookupSRV' types -mockLookupSRV :: Resolver -> Domain -> IO (Either DNSError [(Word16, Word16, Word16, Domain)]) -mockLookupSRV _ domain = do - case domain of - "_wire-server._tcp.wire.com." -> return $ Right [(0, 0, 443, "wire.com")] - "_wire-server._tcp.zinfra.io." -> return $ Right [(0, 0, 443, "server1.zinfra.io"), (0, 0, 443, "server2.zinfra.io")] - "_wire-server._tcp.example.com." -> return $ Right [(0, 0, 443, ".")] - _ -> return $ Right [] diff --git a/libs/extended/src/Servant/API/Extended.hs b/libs/extended/src/Servant/API/Extended.hs index 9b8a7c1c70c..5122f4f737f 100644 --- a/libs/extended/src/Servant/API/Extended.hs +++ b/libs/extended/src/Servant/API/Extended.hs @@ -92,9 +92,9 @@ instance -- See also "W3C Internet Media Type registration, consistency of use" -- http://www.w3.org/2001/tag/2002/0129-mime let contentTypeH = - fromMaybe "application/octet-stream" - $ lookup hContentType - $ requestHeaders request + fromMaybe "application/octet-stream" $ + lookup hContentType $ + requestHeaders request case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of Nothing -> delayedFail err415 Just f -> return f diff --git a/libs/federation-util/.ghcid b/libs/federation-util/.ghcid deleted file mode 100644 index fdd66810c9b..00000000000 --- a/libs/federation-util/.ghcid +++ /dev/null @@ -1 +0,0 @@ ---command "stack ghci federation-util --test" diff --git a/libs/federation-util/src/Network/Federation/Util/DNS.hs b/libs/federation-util/src/Network/Federation/Util/DNS.hs deleted file mode 100644 index 14ac4db02b4..00000000000 --- a/libs/federation-util/src/Network/Federation/Util/DNS.hs +++ /dev/null @@ -1,45 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Network.Federation.Util.DNS - ( srvLookup, - SrvTarget (..), - ) -where - -import Imports -import Network.DNS -import Network.Federation.Util.Internal - --- | Looks up a SRV record given a domain, returning A(AAA) records with their --- ports (ordered by priority and weight according to RFC 2782). Connection --- attempts should be made to the returned result list in order. --- --- Example: --- --- > import Network.DNS.Resolver --- > import Network.Federation.Util --- > --- > main :: IO () --- > main = do --- > rs <- makeResolvSeed defaultResolvConf --- > x <- srvLookup "staging.zinfra.io" rs -srvLookup :: Text -> ResolvSeed -> IO (Maybe [SrvTarget]) -srvLookup = srvLookup' srvDefaultPrefix - -srvDefaultPrefix :: Text -srvDefaultPrefix = "_wire-server" diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index bfcf6c6aa05..7aba8945405 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -126,7 +126,7 @@ module Galley.Types.Teams where import Control.Exception (ErrorCall (ErrorCall)) -import Control.Lens ((^.), makeLenses, view) +import Control.Lens (makeLenses, view, (^.)) import Control.Monad.Catch import Data.Aeson import Data.Id (UserId) @@ -137,8 +137,8 @@ import qualified Data.Set as Set import Data.String.Conversions (cs) import Imports import Wire.API.Event.Team -import Wire.API.Team (NewTeam (..), Team (..), TeamBinding (..)) import Wire.API.Team +import Wire.API.Team (NewTeam (..), Team (..), TeamBinding (..)) import Wire.API.Team.Conversation import Wire.API.Team.Feature import Wire.API.Team.Member diff --git a/libs/galley-types/test/unit/Test/Galley/Roundtrip.hs b/libs/galley-types/test/unit/Test/Galley/Roundtrip.hs index 71b733c6d69..095ca336c14 100644 --- a/libs/galley-types/test/unit/Test/Galley/Roundtrip.hs +++ b/libs/galley-types/test/unit/Test/Galley/Roundtrip.hs @@ -21,7 +21,7 @@ import Data.Aeson (FromJSON, ToJSON, parseJSON, toJSON) import Data.Aeson.Types (parseEither) import Imports import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck ((===), Arbitrary, counterexample, testProperty) +import Test.Tasty.QuickCheck (Arbitrary, counterexample, testProperty, (===)) import Type.Reflection (typeRep) testRoundTrip :: diff --git a/libs/galley-types/test/unit/Test/Galley/Types.hs b/libs/galley-types/test/unit/Test/Galley/Types.hs index 5c8fd8336e4..bee8c4c8a20 100644 --- a/libs/galley-types/test/unit/Test/Galley/Types.hs +++ b/libs/galley-types/test/unit/Test/Galley/Types.hs @@ -38,14 +38,13 @@ tests = "Tests" [ testCase "owner has all permissions" $ rolePermissions RoleOwner @=? fullPermissions, - testCase "smaller roles (further to the left/top in the type def) are strictly more powerful" - $ + testCase "smaller roles (further to the left/top in the type def) are strictly more powerful" $ -- we may not want to maintain this property in the future when adding more roles, but for -- now it's true, and it's nice to have that written down somewhere. - forM_ [(r1, r2) | r1 <- [minBound ..], r2 <- drop 1 [r1 ..]] - $ \(r1, r2) -> do - assertBool "owner.self" ((rolePermissions r2 ^. self) `isSubsetOf` (rolePermissions r1 ^. self)) - assertBool "owner.copy" ((rolePermissions r2 ^. copy) `isSubsetOf` (rolePermissions r1 ^. copy)), + forM_ [(r1, r2) | r1 <- [minBound ..], r2 <- drop 1 [r1 ..]] $ + \(r1, r2) -> do + assertBool "owner.self" ((rolePermissions r2 ^. self) `isSubsetOf` (rolePermissions r1 ^. self)) + assertBool "owner.copy" ((rolePermissions r2 ^. copy) `isSubsetOf` (rolePermissions r1 ^. copy)), testCase "permissions for viewing feature flags" $ -- We currently (at the time of writing this test) grant view permissions for all -- 'TeamFeatureName's to all roles. If we add more features in the future and forget to diff --git a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs index a4e6d4902a7..c59537aff06 100644 --- a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs +++ b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs @@ -155,14 +155,16 @@ instance ToJSON Recipient where -- "All clients" is encoded in the API as an empty list. instance FromJSON RecipientClients where - parseJSON x = parseJSON @[ClientId] x >>= \case - [] -> pure RecipientClientsAll - c : cs -> pure (RecipientClientsSome (list1 c cs)) + parseJSON x = + parseJSON @[ClientId] x >>= \case + [] -> pure RecipientClientsAll + c : cs -> pure (RecipientClientsSome (list1 c cs)) instance ToJSON RecipientClients where - toJSON = toJSON . \case - RecipientClientsAll -> [] - RecipientClientsSome cs -> toList cs + toJSON = + toJSON . \case + RecipientClientsAll -> [] + RecipientClientsSome cs -> toList cs ----------------------------------------------------------------------------- -- ApsData diff --git a/libs/hscim/src/Web/Scim/ContentType.hs b/libs/hscim/src/Web/Scim/ContentType.hs index 7527123e854..60cc857037d 100644 --- a/libs/hscim/src/Web/Scim/ContentType.hs +++ b/libs/hscim/src/Web/Scim/ContentType.hs @@ -38,10 +38,10 @@ data SCIM instance Accept SCIM where contentTypes _ = "application" // "scim+json" /: ("charset", "utf-8") - :| "application" // "scim+json" - : "application" // "json" /: ("charset", "utf-8") - : "application" // "json" - : [] + :| "application" // "scim+json" : + "application" // "json" /: ("charset", "utf-8") : + "application" // "json" : + [] instance ToJSON a => MimeRender SCIM a where mimeRender _ = mimeRender (Proxy @JSON) diff --git a/libs/hscim/src/Web/Scim/Filter.hs b/libs/hscim/src/Web/Scim/Filter.hs index 32589b0f74b..6a910399b5b 100644 --- a/libs/hscim/src/Web/Scim/Filter.hs +++ b/libs/hscim/src/Web/Scim/Filter.hs @@ -56,7 +56,7 @@ module Web.Scim.Filter ) where -import Control.Applicative ((<|>), optional) +import Control.Applicative (optional, (<|>)) import Data.Aeson as Aeson import Data.Aeson.Parser as Aeson import Data.Aeson.Text as Aeson diff --git a/libs/hscim/src/Web/Scim/Schema/PatchOp.hs b/libs/hscim/src/Web/Scim/Schema/PatchOp.hs index 893aba422f2..b44fe9f7a30 100644 --- a/libs/hscim/src/Web/Scim/Schema/PatchOp.hs +++ b/libs/hscim/src/Web/Scim/Schema/PatchOp.hs @@ -20,12 +20,12 @@ module Web.Scim.Schema.PatchOp where import Control.Applicative import Control.Monad (guard) import Control.Monad.Except -import Data.Aeson.Types ((.:), (.:?), (.=), FromJSON (parseJSON), ToJSON (toJSON), Value (String), object, withObject, withText) +import Data.Aeson.Types (FromJSON (parseJSON), ToJSON (toJSON), Value (String), object, withObject, withText, (.:), (.:?), (.=)) import qualified Data.Aeson.Types as Aeson import Data.Attoparsec.ByteString (Parser, endOfInput, parseOnly) import Data.Bifunctor (first) -import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HM +import qualified Data.HashMap.Strict as HashMap import Data.Text (Text, toCaseFold, toLower) import Data.Text.Encoding (encodeUtf8) import Web.Scim.AttrName (AttrName (..)) diff --git a/libs/hscim/src/Web/Scim/Schema/User.hs b/libs/hscim/src/Web/Scim/Schema/User.hs index 9786a6660b4..c16aa8709d5 100644 --- a/libs/hscim/src/Web/Scim/Schema/User.hs +++ b/libs/hscim/src/Web/Scim/Schema/User.hs @@ -182,9 +182,10 @@ instance FromJSON (UserExtra tag) => FromJSON (User tag) where parseJSON = withObject "User" $ \obj -> do -- Lowercase all fields let o = HM.fromList . map (over _1 toLower) . HM.toList $ obj - schemas <- o .:? "schemas" <&> \case - Nothing -> [User20] - Just xs -> if User20 `elem` xs then xs else User20 : xs + schemas <- + o .:? "schemas" <&> \case + Nothing -> [User20] + Just xs -> if User20 `elem` xs then xs else User20 : xs userName <- o .: "username" externalId <- o .:? "externalid" name <- o .:? "name" diff --git a/libs/hscim/src/Web/Scim/Test/Util.hs b/libs/hscim/src/Web/Scim/Test/Util.hs index fef6c1f97d3..38feba2a0ef 100644 --- a/libs/hscim/src/Web/Scim/Test/Util.hs +++ b/libs/hscim/src/Web/Scim/Test/Util.hs @@ -52,7 +52,7 @@ where import qualified Control.Retry as Retry import Data.Aeson -import Data.Aeson.Internal ((), JSONPathElement (Key)) +import Data.Aeson.Internal (JSONPathElement (Key), ()) import Data.Aeson.QQ import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -71,8 +71,7 @@ import Network.Wai (Application) import Network.Wai.Test (SResponse) import Test.Hspec.Expectations (expectationFailure) import Test.Hspec.Wai hiding (patch, post, put, shouldRespondWith) -import Test.Hspec.Wai.Matcher (bodyEquals) -import Test.Hspec.Wai.Matcher (match) +import Test.Hspec.Wai.Matcher (bodyEquals, match) import Web.Scim.Class.Auth (AuthTypes (..)) import Web.Scim.Class.Group (GroupTypes (..)) import Web.Scim.Schema.Schema (Schema (CustomSchema, User20)) diff --git a/libs/hscim/test/Test/Schema/PatchOpSpec.hs b/libs/hscim/test/Test/Schema/PatchOpSpec.hs index 1fc7240bc1c..49d46331134 100644 --- a/libs/hscim/test/Test/Schema/PatchOpSpec.hs +++ b/libs/hscim/test/Test/Schema/PatchOpSpec.hs @@ -21,8 +21,8 @@ module Test.Schema.PatchOpSpec where import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson import Data.Aeson.Types (Result (Error, Success), Value (String), fromJSON, toJSON) +import qualified Data.Aeson.Types as Aeson import Data.Attoparsec.ByteString (parseOnly) import Data.Either (isLeft) import Data.Foldable (for_) diff --git a/libs/imports/src/Imports.hs b/libs/imports/src/Imports.hs index 85d3c80bffb..50be52f3589 100644 --- a/libs/imports/src/Imports.hs +++ b/libs/imports/src/Imports.hs @@ -117,25 +117,8 @@ module Imports ) where --- Explicitly saying what to import because some things from Prelude clash --- with e.g. UnliftIO modules - -import Control.Applicative hiding (empty, many, optional, some) -- common in - -- some libs - --- conflicts with Options.Applicative.Option (should we care?) --- First and Last are going to be deprecated. Use Semigroup instead - --- 'insert' and 'delete' are --- common in database modules - --- Handle is hidden --- because it's common --- in Brig --- Permissions is common in Galley - --- Lazy and strict versions are the same - +-- common in some libs +import Control.Applicative hiding (empty, many, optional, some) import Control.DeepSeq (NFData (..), deepseq) import Control.Monad hiding (forM, forM_, mapM, mapM_, msum, sequence, sequence_) import Control.Monad.Extra (unlessM, whenM) @@ -165,11 +148,15 @@ import Data.Functor.Identity import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import Data.Int +-- 'insert' and 'delete' are common in database modules import Data.List hiding (delete, insert) +-- Lazy and strict versions are the same import Data.Map (Map) import Data.Maybe +-- First and Last are going to be deprecated. Use Semigroup instead import Data.Monoid hiding (First (..), Last (..)) import Data.Ord +-- conflicts with Options.Applicative.Option (should we care?) import Data.Semigroup hiding (Option, diff, option) import Data.Set (Set) import Data.String @@ -184,17 +171,19 @@ import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Text.Read (readEither, readMaybe) import UnliftIO.Concurrent +-- Permissions is common in Galley import UnliftIO.Directory hiding (Permissions) import UnliftIO.Environment import UnliftIO.Exception +-- Handle is hidden because it's common in Brig import UnliftIO.IO hiding (Handle, getMonotonicTime) import UnliftIO.IORef import UnliftIO.MVar import UnliftIO.STM -import qualified Prelude as P +-- Explicitly saying what to import because some things from Prelude clash +-- with e.g. UnliftIO modules import Prelude - ( ($!), - Bounded (..), + ( Bounded (..), Double, Enum (..), Eq (..), @@ -215,8 +204,6 @@ import Prelude RealFrac (..), Show (..), ShowS, - (^), - (^^), error, even, fromIntegral, @@ -235,7 +222,11 @@ import Prelude shows, subtract, undefined, + ($!), + (^), + (^^), ) +import qualified Prelude as P ---------------------------------------------------------------------------- -- Type aliases diff --git a/libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs b/libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs index e6e19b80465..b35e502da28 100644 --- a/libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs +++ b/libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs @@ -21,8 +21,7 @@ module Data.Metrics.Middleware.Prometheus where import Data.Maybe (fromMaybe) -import Data.Metrics.Types (Paths) -import Data.Metrics.Types (treeLookup) +import Data.Metrics.Types (Paths, treeLookup) import Data.Metrics.WaiRoute (treeToPaths) import Data.Text (Text) import qualified Data.Text.Encoding as T diff --git a/libs/ropes/src/Ropes/Nexmo.hs b/libs/ropes/src/Ropes/Nexmo.hs index 11cd3a98990..7ec1e976432 100644 --- a/libs/ropes/src/Ropes/Nexmo.hs +++ b/libs/ropes/src/Ropes/Nexmo.hs @@ -319,9 +319,9 @@ sendFeedback cr mgr fb = httpLbs req mgr >>= parseResponse -- You must _always_ specify a timestamp nexmoTimeFormat = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" parseResponse res = - unless (responseStatus res == status200) - $ throwIO - $ FeedbackErrorResponse (decodeUtf8 . toStrict . responseBody $ res) + unless (responseStatus res == status200) $ + throwIO $ + FeedbackErrorResponse (decodeUtf8 . toStrict . responseBody $ res) sendMessage :: Credentials -> Manager -> Message -> IO MessageResponse sendMessage cr mgr msg = N.head <$> sendMessages cr mgr (msg :| []) diff --git a/libs/tasty-cannon/src/Test/Tasty/Cannon.hs b/libs/tasty-cannon/src/Test/Tasty/Cannon.hs index 9423da4fcaa..c40cef37ef2 100644 --- a/libs/tasty-cannon/src/Test/Tasty/Cannon.hs +++ b/libs/tasty-cannon/src/Test/Tasty/Cannon.hs @@ -75,7 +75,7 @@ import Data.ByteString.Conversion import Data.Id import Data.List1 import Data.Misc ((<$$>)) -import Data.Timeout ((#), Timeout, TimeoutUnit (..)) +import Data.Timeout (Timeout, TimeoutUnit (..), (#)) import Gundeck.Types import Imports import Network.HTTP.Client @@ -240,15 +240,16 @@ awaitMatch t ws match = go [] [] go buf errs = do mn <- await t ws case mn of - Just n -> do - liftIO (match n) - refill buf - return (Right n) - `catchAll` \e -> case asyncExceptionFromException e of - Just x -> throwM (x :: SomeAsyncException) - Nothing -> - let e' = MatchFailure e - in go (n : buf) (e' : errs) + Just n -> + do + liftIO (match n) + refill buf + return (Right n) + `catchAll` \e -> case asyncExceptionFromException e of + Just x -> throwM (x :: SomeAsyncException) + Nothing -> + let e' = MatchFailure e + in go (n : buf) (e' : errs) Nothing -> do refill buf return (Left (MatchTimeout errs)) diff --git a/libs/types-common-aws/src/Util/Test/SQS.hs b/libs/types-common-aws/src/Util/Test/SQS.hs index 4ffa22f3a81..dddaa98d67d 100644 --- a/libs/types-common-aws/src/Util/Test/SQS.hs +++ b/libs/types-common-aws/src/Util/Test/SQS.hs @@ -91,8 +91,8 @@ receive :: Int -> Text -> SQS.ReceiveMessage receive n url = SQS.receiveMessage url & set SQS.rmWaitTimeSeconds (Just 1) - . set SQS.rmMaxNumberOfMessages (Just n) - . set SQS.rmVisibilityTimeout (Just 1) + . set SQS.rmMaxNumberOfMessages (Just n) + . set SQS.rmVisibilityTimeout (Just 1) fetchMessage :: (MonadIO m, AWS.MonadAWS m, Message a) => Text -> String -> (String -> Maybe a -> IO ()) -> m () fetchMessage url label callback = do @@ -140,9 +140,10 @@ tryMatch label tries url callback = go tries when (null ok) $ do liftIO $ threadDelay (10 ^ (6 :: Int)) go (n - 1) - check e = do - liftIO $ callback label e - return (Right $ show e) - `catchAll` \ex -> case asyncExceptionFromException ex of - Just x -> throwM (x :: SomeAsyncException) - Nothing -> return . Left $ MatchFailure (e, ex) + check e = + do + liftIO $ callback label e + return (Right $ show e) + `catchAll` \ex -> case asyncExceptionFromException ex of + Just x -> throwM (x :: SomeAsyncException) + Nothing -> return . Left $ MatchFailure (e, ex) diff --git a/libs/types-common/src/Data/Handle.hs b/libs/types-common/src/Data/Handle.hs index 6ee2059a031..81699f9f3b7 100644 --- a/libs/types-common/src/Data/Handle.hs +++ b/libs/types-common/src/Data/Handle.hs @@ -83,6 +83,7 @@ handleParser = do isHandleChar = Atto.inClass "a-z0-9_.-" instance Arbitrary Handle where - arbitrary = Handle . Text.pack <$> do - len <- oneof [choose (2, 10), choose (2, 256)] -- prefer short handles - replicateM len (elements $ ['a' .. 'z'] <> ['0' .. '9'] <> "_-.") + arbitrary = + Handle . Text.pack <$> do + len <- oneof [choose (2, 10), choose (2, 256)] -- prefer short handles + replicateM len (elements $ ['a' .. 'z'] <> ['0' .. '9'] <> "_-.") diff --git a/libs/types-common/src/Data/IdMapping.hs b/libs/types-common/src/Data/IdMapping.hs index 0eac38efec3..41db2cced9f 100644 --- a/libs/types-common/src/Data/IdMapping.hs +++ b/libs/types-common/src/Data/IdMapping.hs @@ -19,7 +19,7 @@ module Data.IdMapping where -import Data.Aeson ((.=), ToJSON (toJSON)) +import Data.Aeson (ToJSON (toJSON), (.=)) import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS import Data.Domain (domainText) diff --git a/libs/types-common/src/Data/Json/Util.hs b/libs/types-common/src/Data/Json/Util.hs index 03d8a495d4c..b2479a4e48b 100644 --- a/libs/types-common/src/Data/Json/Util.hs +++ b/libs/types-common/src/Data/Json/Util.hs @@ -36,7 +36,7 @@ module Data.Json.Util where import qualified Cassandra as CQL -import Control.Lens ((%~), coerced) +import Control.Lens (coerced, (%~)) import Data.Aeson import Data.Aeson.Types import qualified Data.ByteString.Base64.Lazy as EL diff --git a/libs/types-common/src/Data/Misc.hs b/libs/types-common/src/Data/Misc.hs index b2fe9456421..b58c715e2ac 100644 --- a/libs/types-common/src/Data/Misc.hs +++ b/libs/types-common/src/Data/Misc.hs @@ -42,6 +42,7 @@ module Data.Misc -- * HttpsUrl HttpsUrl (..), mkHttpsUrl, + ensureHttpsUrl, -- * Fingerprint Fingerprint (..), @@ -60,7 +61,7 @@ module Data.Misc where import Cassandra -import Control.Lens ((^.), makeLenses) +import Control.Lens (makeLenses, (.~), (^.)) import Data.Aeson import qualified Data.Aeson.Types as Json import qualified Data.Attoparsec.ByteString.Char8 as Chars @@ -236,7 +237,7 @@ instance Cql Milliseconds where newtype HttpsUrl = HttpsUrl { httpsUrl :: URIRef Absolute } - deriving stock (Eq, Generic) + deriving stock (Eq, Ord, Generic) mkHttpsUrl :: URIRef Absolute -> Either String HttpsUrl mkHttpsUrl uri = @@ -244,6 +245,9 @@ mkHttpsUrl uri = then Right $ HttpsUrl uri else Left $ "Non-HTTPS URL: " ++ show uri +ensureHttpsUrl :: URIRef Absolute -> HttpsUrl +ensureHttpsUrl = HttpsUrl . (uriSchemeL . schemeBSL .~ "https") + instance Show HttpsUrl where showsPrec i = showsPrec i . httpsUrl diff --git a/libs/types-common/src/Data/Range.hs b/libs/types-common/src/Data/Range.hs index a9e444768a1..f372dbe0c0e 100644 --- a/libs/types-common/src/Data/Range.hs +++ b/libs/types-common/src/Data/Range.hs @@ -89,6 +89,10 @@ newtype Range (n :: Nat) (m :: Nat) a = Range } deriving (Eq, Ord, Show) +instance (Show a, Num a, Within a n m, KnownNat n, KnownNat m) => Bounded (Range n m a) where + minBound = unsafeRange $ (fromKnownNat (Proxy @n) :: a) + maxBound = unsafeRange $ (fromKnownNat (Proxy @m) :: a) + instance NFData (Range n m a) where rnf (Range a) = seq a () instance ToJSON a => ToJSON (Range n m a) where diff --git a/libs/types-common/src/Data/Text/Ascii.hs b/libs/types-common/src/Data/Text/Ascii.hs index 7ed284749a1..f759d9d4bcc 100644 --- a/libs/types-common/src/Data/Text/Ascii.hs +++ b/libs/types-common/src/Data/Text/Ascii.hs @@ -371,12 +371,13 @@ check m f t | otherwise = Left m parseBytes :: (Text -> Either String a) -> Parser a -parseBytes f = parser >>= \bs -> - case decodeUtf8' bs of - Left _ -> fail $ "Invalid ASCII characters in: " ++ C8.unpack bs - Right t -> case f t of - Left e -> fail $ e ++ ": " ++ Text.unpack t - Right a -> pure a +parseBytes f = + parser >>= \bs -> + case decodeUtf8' bs of + Left _ -> fail $ "Invalid ASCII characters in: " ++ C8.unpack bs + Right t -> case f t of + Left e -> fail $ e ++ ": " ++ Text.unpack t + Right a -> pure a unsafeString :: (Text -> Either String a) -> String -> a unsafeString f s = case f (Text.pack s) of diff --git a/libs/types-common/src/Util/Test.hs b/libs/types-common/src/Util/Test.hs index 3123ce652b5..69b5d8deb6a 100644 --- a/libs/types-common/src/Util/Test.hs +++ b/libs/types-common/src/Util/Test.hs @@ -35,11 +35,12 @@ instance IsOption IntegrationConfigFile where optionName = return "integration-config" optionHelp = return "Integration config file to read from" optionCLParser = - fmap IntegrationConfigFile $ strOption $ - ( short (untag (return 'i' :: Tagged IntegrationConfigFile Char)) - <> long (untag (optionName :: Tagged IntegrationConfigFile String)) - <> help (untag (optionHelp :: Tagged IntegrationConfigFile String)) - ) + fmap IntegrationConfigFile $ + strOption $ + ( short (untag (return 'i' :: Tagged IntegrationConfigFile Char)) + <> long (untag (optionName :: Tagged IntegrationConfigFile String)) + <> help (untag (optionHelp :: Tagged IntegrationConfigFile String)) + ) handleParseError :: (Show a) => Either a b -> IO (Maybe b) handleParseError (Left err) = do diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index 901da290a5a..913d09341f6 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -99,14 +99,14 @@ newSettings (Server h p l m t) = do -- (Atomically) initialise the standard metrics, to avoid races. void $ gaugeGet (path "net.connections") m void $ counterGet (path "net.errors") m - return - $ setHost (fromString h) + return $ + setHost (fromString h) . setPort (fromIntegral p) . setBeforeMainLoop logStart . setOnOpen (const $ connStart >> return True) . setOnClose (const connEnd) . setTimeout (fromMaybe 300 t) - $ defaultSettings + $ defaultSettings where connStart = gaugeIncr (path "net.connections") m connEnd = gaugeDecr (path "net.connections") m @@ -357,10 +357,11 @@ runHandlers e [] = throw e runHandlers e (Handler h : hs) = maybe (runHandlers e hs) h (fromException e) restrict :: Int -> Int -> Predicate r P.Error Int -> Predicate r P.Error Int -restrict l u = fmap $ \x -> x >>= \v -> - if v >= l && v <= u - then x - else Fail (setMessage (emsg v) . setReason TypeError $ e400) +restrict l u = fmap $ \x -> + x >>= \v -> + if v >= l && v <= u + then x + else Fail (setMessage (emsg v) . setReason TypeError $ e400) where emsg v = LBS.toStrict . toLazyByteString $ diff --git a/libs/wire-api-federation/LICENSE b/libs/wire-api-federation/LICENSE new file mode 100644 index 00000000000..dba13ed2ddf --- /dev/null +++ b/libs/wire-api-federation/LICENSE @@ -0,0 +1,661 @@ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU Affero General Public License is a free, copyleft license for +software and other kinds of works, specifically designed to ensure +cooperation with the community in the case of network server software. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +our General Public Licenses are intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + Developers that use our General Public Licenses protect your rights +with two steps: (1) assert copyright on the software, and (2) offer +you this License which gives you legal permission to copy, distribute +and/or modify the software. + + A secondary benefit of defending all users' freedom is that +improvements made in alternate versions of the program, if they +receive widespread use, become available for other developers to +incorporate. Many developers of free software are heartened and +encouraged by the resulting cooperation. However, in the case of +software used on network servers, this result may fail to come about. +The GNU General Public License permits making a modified version and +letting the public access it on a server without ever releasing its +source code to the public. + + The GNU Affero General Public License is designed specifically to +ensure that, in such cases, the modified source code becomes available +to the community. It requires the operator of a network server to +provide the source code of the modified version running there to the +users of that server. Therefore, public use of a modified version, on +a publicly accessible server, gives the public access to the source +code of the modified version. + + An older license, called the Affero General Public License and +published by Affero, was designed to accomplish similar goals. This is +a different license, not a version of the Affero GPL, but Affero has +released a new version of the Affero GPL which permits relicensing under +this license. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU Affero General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Remote Network Interaction; Use with the GNU General Public License. + + Notwithstanding any other provision of this License, if you modify the +Program, your modified version must prominently offer all users +interacting with it remotely through a computer network (if your version +supports such interaction) an opportunity to receive the Corresponding +Source of your version by providing access to the Corresponding Source +from a network server at no charge, through some standard or customary +means of facilitating copying of software. This Corresponding Source +shall include the Corresponding Source for any work covered by version 3 +of the GNU General Public License that is incorporated pursuant to the +following paragraph. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the work with which it is combined will remain governed by version +3 of the GNU General Public License. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU Affero General Public License from time to time. Such new versions +will be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU Affero General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU Affero General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU Affero General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If your software can interact with users remotely through a computer +network, you should also make sure that it provides a way for users to +get its source. For example, if your program is a web application, its +interface could display a "Source" link that leads users to an archive +of the code. There are many ways you could offer source, and different +solutions will be better for different programs; see section 13 for the +specific requirements. + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU AGPL, see +. diff --git a/libs/federation-util/package.yaml b/libs/wire-api-federation/package.yaml similarity index 65% rename from libs/federation-util/package.yaml rename to libs/wire-api-federation/package.yaml index ea89acc6bc6..38e1c253a9d 100644 --- a/libs/federation-util/package.yaml +++ b/libs/wire-api-federation/package.yaml @@ -1,32 +1,30 @@ defaults: local: ../../package-defaults.yaml -name: federation-util +name: wire-api-federation version: '0.1.0' -synopsis: Various helpers for federation -description: Small helper functions useful when federating. +synopsis: The Wire server-to-server API for federation +description: Servant endpoints and types for implementing a Wire backend that can federate with others category: Web author: Wire Swiss GmbH maintainer: Wire Swiss GmbH copyright: (c) 2020 Wire Swiss GmbH license: AGPL-3 dependencies: -- async >=2.0 +- aeson >=1.4 - base >=4.6 && <5.0 - bytestring >=0.10 - bytestring-conversion >=0.3 - containers >=0.5 - errors >=2.0 - exceptions >=0.6 -- http-types >=0.8 - imports -- dns -- random -- streaming-commons >=0.1 -- string-conversions -- stm +- servant >=0.16 - text >=0.11 +- time >=1.8 - transformers >=0.3 -- tinylog >=0.8 +- types-common +- QuickCheck >=2.13 + library: source-dirs: src @@ -37,9 +35,7 @@ tests: - test ghc-options: -threaded -rtsopts -with-rtsopts=-N dependencies: + - wire-api-federation - hspec - hspec-discover - - QuickCheck - - federation-util - - uri-bytestring - + - metrics-wai diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs new file mode 100644 index 00000000000..7bb48ee3da2 --- /dev/null +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -0,0 +1,30 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.Federation.API where + +import GHC.Generics (Generic) +import Servant.API.Generic (AsApi, ToServant, (:-)) +import qualified Wire.API.Federation.API.Conversation as Conversation (Api) + +type PlainApi = ToServant Api AsApi + +-- FUTUREWORK: Add Swagger docs +data Api routes = Api + { conversation :: routes :- ToServant Conversation.Api AsApi + } + deriving stock (Generic) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Conversation.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Conversation.hs new file mode 100644 index 00000000000..6640cff5917 --- /dev/null +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Conversation.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DerivingVia #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.Federation.API.Conversation where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Id (ConvId, UserId) +import Data.Qualified (Qualified) +import Imports +import Servant.API (Capture, JSON, Post, ReqBody, (:>)) +import Servant.API.Generic ((:-)) +import Test.QuickCheck (Arbitrary (arbitrary)) +import qualified Test.QuickCheck as QC +import Wire.API.Federation.Event (ConversationEvent, MemberJoin) +import Wire.API.Federation.Util.Aeson (CustomEncoded (CustomEncoded)) + +data Api routes = Api + { joinConversationById :: + routes + :- "f" + :> "conversation" + :> Capture "cnv" (Qualified ConvId) + :> "join" + :> ReqBody '[JSON] JoinConversationByIdRequest + :> Post '[JSON] (ConversationUpdateResult MemberJoin) + } + deriving stock (Generic) + +data JoinConversationByIdRequest = JoinConversationByIdRequest + { joinUserId :: Qualified UserId + } + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON) via (CustomEncoded JoinConversationByIdRequest) + +data ConversationUpdateResult a + = ConversationUpdated (ConversationEvent a) + | ConversationUnchanged + deriving stock (Eq, Show, Generic, Foldable, Functor, Traversable) + deriving (ToJSON, FromJSON) via (CustomEncoded (ConversationUpdateResult a)) + +-- Arbitrary + +instance Arbitrary JoinConversationByIdRequest where + arbitrary = JoinConversationByIdRequest <$> arbitrary + +instance Arbitrary a => Arbitrary (ConversationUpdateResult a) where + arbitrary = QC.oneof [pure ConversationUnchanged, ConversationUpdated <$> arbitrary] diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Event.hs b/libs/wire-api-federation/src/Wire/API/Federation/Event.hs new file mode 100644 index 00000000000..45c456bdb7b --- /dev/null +++ b/libs/wire-api-federation/src/Wire/API/Federation/Event.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StrictData #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.Federation.Event + ( AnyEvent (..), + ConversationEvent (..), + + -- * MemberJoin + MemberJoin (..), + SimpleMember (..), + ConversationRole (..), + ) +where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Id +import Data.Qualified (Qualified) +import Data.Time +import Imports +import Test.QuickCheck (Arbitrary (arbitrary)) +import qualified Test.QuickCheck as QC +import Wire.API.Federation.Util.Aeson (CustomEncoded (CustomEncoded)) + +data AnyEvent + = EventMemberJoin (ConversationEvent MemberJoin) + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON) via (CustomEncoded AnyEvent) + +-- | Similar to 'Wire.API.Event.ConversationEvent', but all IDs are qualified to allow +-- this representation to be sent across backends. +-- +-- Also, instead of having a sum type in 'eventData', it allows specifying which type +-- of event it is, e.g. @ConversationEvent MemberJoin@. +-- To represent possiblity of multiple different event types, use a sum type around it. +data ConversationEvent a = ConversationEvent + { eventConversation :: Qualified ConvId, + eventFrom :: Qualified UserId, + eventTime :: UTCTime, + eventData :: a + } + deriving stock (Eq, Show, Generic, Foldable, Functor, Traversable) + deriving (ToJSON, FromJSON) via (CustomEncoded (ConversationEvent a)) + +newtype MemberJoin = MemberJoin + { smUsers :: [SimpleMember] + } + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON) via (CustomEncoded MemberJoin) + +data SimpleMember = SimpleMember + { smId :: Qualified UserId, + smConversationRole :: ConversationRole + } + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON) via (CustomEncoded SimpleMember) + +data ConversationRole + = ConversationRoleAdmin + | ConversationRoleMember + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON) via (CustomEncoded ConversationRole) + +-- Arbitrary + +instance Arbitrary AnyEvent where + arbitrary = + QC.oneof + [ EventMemberJoin <$> arbitrary + ] + +instance Arbitrary a => Arbitrary (ConversationEvent a) where + arbitrary = ConversationEvent <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary MemberJoin where + arbitrary = MemberJoin <$> arbitrary + +instance Arbitrary SimpleMember where + arbitrary = SimpleMember <$> arbitrary <*> arbitrary + +instance Arbitrary ConversationRole where + arbitrary = QC.elements [ConversationRoleAdmin, ConversationRoleMember] diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Util/Aeson.hs b/libs/wire-api-federation/src/Wire/API/Federation/Util/Aeson.hs new file mode 100644 index 00000000000..c288f0100be --- /dev/null +++ b/libs/wire-api-federation/src/Wire/API/Federation/Util/Aeson.hs @@ -0,0 +1,45 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.Federation.Util.Aeson + ( customEncodingOptions, + CustomEncoded (..), + ) +where + +import Data.Aeson +import qualified Data.Char as Char +import GHC.Generics (Rep) +import Imports + +-- | Drops record field name prefixes (anything until the first upper-case char) +-- and turns the rest into snake_case. +-- +-- For example, it converts @_recordFieldLabel@ into @field_label@. +customEncodingOptions :: Options +customEncodingOptions = + defaultOptions + { fieldLabelModifier = camelTo2 '_' . dropWhile (not . Char.isUpper) + } + +newtype CustomEncoded a = CustomEncoded {unCustomEncoded :: a} + +instance (Generic a, GToJSON Zero (Rep a)) => ToJSON (CustomEncoded a) where + toJSON = genericToJSON @a customEncodingOptions . unCustomEncoded + +instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (CustomEncoded a) where + parseJSON = fmap CustomEncoded . genericParseJSON @a customEncodingOptions diff --git a/libs/federation-util/src/Network/Federation/Util.hs b/libs/wire-api-federation/test/Spec.hs similarity index 87% rename from libs/federation-util/src/Network/Federation/Util.hs rename to libs/wire-api-federation/test/Spec.hs index bd9a191b618..7b57431c0d0 100644 --- a/libs/federation-util/src/Network/Federation/Util.hs +++ b/libs/wire-api-federation/test/Spec.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -14,10 +16,3 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . - -module Network.Federation.Util - ( module Network.Federation.Util.DNS, - ) -where - -import Network.Federation.Util.DNS diff --git a/services/federator/src/Federator/Util.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/APISpec.hs similarity index 57% rename from services/federator/src/Federator/Util.hs rename to libs/wire-api-federation/test/Test/Wire/API/Federation/APISpec.hs index c947f0e0e46..770447c8f11 100644 --- a/services/federator/src/Federator/Util.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/APISpec.hs @@ -15,25 +15,15 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Federator.Util - ( wireJsonOptions, - ) -where +module Test.Wire.API.Federation.APISpec where -import Data.Aeson as Aeson +import Data.Metrics.Servant (routesToPaths) +import Data.Metrics.Test (pathsConsistencyCheck) import Imports +import Test.Hspec (Spec, it, shouldBe) +import Wire.API.Federation.API as API -dropPrefix :: String -> String -> Maybe String -dropPrefix pfx str = - if length pfx > length str - then Nothing - else case splitAt (length pfx) str of - (pfx', sfx) -> - if pfx' /= pfx - then Nothing - else Just sfx - --- | This is a partial function; totality of all calls must be verified by roundtrip tests on --- the aeson instances involved. -wireJsonOptions :: String -> Options -wireJsonOptions pfx = defaultOptions {fieldLabelModifier = fromJust . dropPrefix pfx . fmap toLower} +spec :: Spec +spec = do + it "API consistency" $ do + pathsConsistencyCheck (routesToPaths @API.PlainApi) `shouldBe` mempty diff --git a/libs/federation-util/federation-util.cabal b/libs/wire-api-federation/wire-api-federation.cabal similarity index 77% rename from libs/federation-util/federation-util.cabal rename to libs/wire-api-federation/wire-api-federation.cabal index 8f9d28983e7..7ad62767acf 100644 --- a/libs/federation-util/federation-util.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -1,15 +1,15 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: d327ef72460d5f79332d80fa4a70516b7351472f50c17a8c491d28c65ec0f024 +-- hash: 942d9870717b6c174641f5f84d1344154f017118bd6870e939fba4eedc747d34 -name: federation-util +name: wire-api-federation version: 0.1.0 -synopsis: Various helpers for federation -description: Small helper functions useful when federating. +synopsis: The Wire server-to-server API for federation +description: Servant endpoints and types for implementing a Wire backend that can federate with others category: Web author: Wire Swiss GmbH maintainer: Wire Swiss GmbH @@ -20,66 +20,60 @@ build-type: Simple library exposed-modules: - Network.Federation.Util - Network.Federation.Util.DNS - Network.Federation.Util.Internal + Wire.API.Federation.API + Wire.API.Federation.API.Conversation + Wire.API.Federation.Event + Wire.API.Federation.Util.Aeson other-modules: - Paths_federation_util + Paths_wire_api_federation hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: - async >=2.0 + QuickCheck >=2.13 + , aeson >=1.4 , base >=4.6 && <5.0 , bytestring >=0.10 , bytestring-conversion >=0.3 , containers >=0.5 - , dns , errors >=2.0 , exceptions >=0.6 - , http-types >=0.8 , imports - , random - , stm - , streaming-commons >=0.1 - , string-conversions + , servant >=0.16 , text >=0.11 - , tinylog >=0.8 + , time >=1.8 , transformers >=0.3 + , types-common default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Test.DNSSpec - Paths_federation_util + Test.Wire.API.Federation.APISpec + Paths_wire_api_federation hs-source-dirs: test default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N build-depends: - QuickCheck - , async >=2.0 + QuickCheck >=2.13 + , aeson >=1.4 , base >=4.6 && <5.0 , bytestring >=0.10 , bytestring-conversion >=0.3 , containers >=0.5 - , dns , errors >=2.0 , exceptions >=0.6 - , federation-util , hspec , hspec-discover - , http-types >=0.8 , imports - , random - , stm - , streaming-commons >=0.1 - , string-conversions + , metrics-wai + , servant >=0.16 , text >=0.11 - , tinylog >=0.8 + , time >=1.8 , transformers >=0.3 - , uri-bytestring + , types-common + , wire-api-federation default-language: Haskell2010 diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index c7f8a436f5e..7cb775cf62a 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -70,3 +70,4 @@ tests: - tasty-expected-failure - tasty-hunit - tasty-quickcheck + - unordered-containers diff --git a/libs/wire-api/src/Wire/API/Arbitrary.hs b/libs/wire-api/src/Wire/API/Arbitrary.hs index 5558eec1889..d1621f02a48 100644 --- a/libs/wire-api/src/Wire/API/Arbitrary.hs +++ b/libs/wire-api/src/Wire/API/Arbitrary.hs @@ -43,8 +43,8 @@ import Data.List1 (List1, list1) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import GHC.Generics (Rep) +import Generic.Random (listOf', (:+) ((:+))) import qualified Generic.Random as Generic -import Generic.Random ((:+) ((:+)), listOf') import Imports import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) import qualified Test.QuickCheck.Arbitrary as QC diff --git a/libs/wire-api/src/Wire/API/Asset/V3.hs b/libs/wire-api/src/Wire/API/Asset/V3.hs index 748a13ff6bc..fea687bc4a0 100644 --- a/libs/wire-api/src/Wire/API/Asset/V3.hs +++ b/libs/wire-api/src/Wire/API/Asset/V3.hs @@ -68,7 +68,7 @@ import Data.ByteString.Builder import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as LBS import Data.Id -import Data.Json.Util ((#), toUTCTimeMillis) +import Data.Json.Util (toUTCTimeMillis, (#)) import Data.Text.Ascii (AsciiBase64Url) import qualified Data.Text.Encoding as T import Data.Time.Clock @@ -303,13 +303,14 @@ instance ToByteString AssetRetention where -- | ByteString representation is used in AssetKey instance FromByteString AssetRetention where - parser = decimal >>= \d -> case (d :: Word) of - 1 -> return AssetEternal - 2 -> return AssetPersistent - 3 -> return AssetVolatile - 4 -> return AssetEternalInfrequentAccess - 5 -> return AssetExpiring - _ -> fail $ "Invalid asset retention: " ++ show d + parser = + decimal >>= \d -> case (d :: Word) of + 1 -> return AssetEternal + 2 -> return AssetPersistent + 3 -> return AssetVolatile + 4 -> return AssetEternalInfrequentAccess + 5 -> return AssetExpiring + _ -> fail $ "Invalid asset retention: " ++ show d instance ToJSON AssetRetention where toJSON = String . retentionToTextRep diff --git a/libs/wire-api/src/Wire/API/Asset/V3/Resumable.hs b/libs/wire-api/src/Wire/API/Asset/V3/Resumable.hs index 71aebb10aa7..15778704c4e 100644 --- a/libs/wire-api/src/Wire/API/Asset/V3/Resumable.hs +++ b/libs/wire-api/src/Wire/API/Asset/V3/Resumable.hs @@ -46,7 +46,7 @@ import Control.Lens (makeLenses) import Data.Aeson import Data.Aeson.Types import Data.ByteString.Conversion -import Data.Json.Util ((#), toUTCTimeMillis) +import Data.Json.Util (toUTCTimeMillis, (#)) import Data.Time.Clock import Imports import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) diff --git a/libs/wire-api/src/Wire/API/Call/TURN.hs b/libs/wire-api/src/Wire/API/Call/Config.hs similarity index 83% rename from libs/wire-api/src/Wire/API/Call/TURN.hs rename to libs/wire-api/src/Wire/API/Call/Config.hs index f49be9689c9..e7ccbcd6f5e 100644 --- a/libs/wire-api/src/Wire/API/Call/TURN.hs +++ b/libs/wire-api/src/Wire/API/Call/Config.hs @@ -20,11 +20,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.Call.TURN +module Wire.API.Call.Config ( -- * RTCConfiguration RTCConfiguration, rtcConfiguration, rtcConfIceServers, + rtcConfSftServers, rtcConfTTL, -- * RTCIceServer @@ -55,6 +56,11 @@ module Wire.API.Call.TURN tuT, tuRandom, + -- * SFTServer + SFTServer, + sftServer, + sftURL, + -- * convenience isUdp, isTcp, @@ -74,8 +80,8 @@ import Data.Attoparsec.Text hiding (parse) import Data.ByteString.Builder import qualified Data.ByteString.Conversion as BC import qualified Data.IP as IP -import Data.List1 -import Data.Misc (IpAddr (IpAddr), Port (..)) +import Data.List.NonEmpty (NonEmpty) +import Data.Misc (HttpsUrl (..), IpAddr (IpAddr), Port (..)) import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text as Text import Data.Text.Ascii @@ -93,16 +99,18 @@ import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) -- | A configuration object resembling \"RTCConfiguration\" -- -- The \"ttl\" field is a proprietary extension +-- The \"sft_servers\" field is a proprietary extension -- -- cf. https://developer.mozilla.org/en-US/docs/Web/API/RTCPeerConnection/RTCPeerConnection#RTCConfiguration_dictionary data RTCConfiguration = RTCConfiguration - { _rtcConfIceServers :: List1 RTCIceServer, + { _rtcConfIceServers :: NonEmpty RTCIceServer, + _rtcConfSftServers :: Maybe (NonEmpty SFTServer), _rtcConfTTL :: Word32 } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform RTCConfiguration) -rtcConfiguration :: List1 RTCIceServer -> Word32 -> RTCConfiguration +rtcConfiguration :: NonEmpty RTCIceServer -> Maybe (NonEmpty SFTServer) -> Word32 -> RTCConfiguration rtcConfiguration = RTCConfiguration modelRtcConfiguration :: Doc.Model @@ -110,19 +118,53 @@ modelRtcConfiguration = Doc.defineModel "RTCConfiguration" $ do Doc.description "A subset of the WebRTC 'RTCConfiguration' dictionary" Doc.property "ice_servers" (Doc.array (Doc.ref modelRtcIceServer)) $ Doc.description "Array of 'RTCIceServer' objects" + Doc.property "sft_servers" (Doc.array (Doc.ref modelRtcSftServer)) $ + Doc.description "Array of 'SFTServer' objects (optional)" Doc.property "ttl" Doc.int32' $ Doc.description "Number of seconds after which the configuration should be refreshed (advisory)" instance ToJSON RTCConfiguration where - toJSON (RTCConfiguration srvs ttl) = + toJSON (RTCConfiguration srvs sfts ttl) = object - [ "ice_servers" .= srvs, - "ttl" .= ttl - ] + ( [ "ice_servers" .= srvs, + "ttl" .= ttl + ] + <> ["sft_servers" .= sfts | isJust sfts] + ) instance FromJSON RTCConfiguration where parseJSON = withObject "RTCConfiguration" $ \o -> - RTCConfiguration <$> o .: "ice_servers" <*> o .: "ttl" + RTCConfiguration <$> o .: "ice_servers" <*> o .:? "sft_servers" <*> o .: "ttl" + +-------------------------------------------------------------------------------- +-- SFTServer + +newtype SFTServer = SFTServer + { _sftURL :: HttpsUrl + } + deriving stock (Eq, Show, Ord, Generic) + deriving (Arbitrary) via (GenericUniform SFTServer) + +instance ToJSON SFTServer where + toJSON (SFTServer url) = + object + [ "urls" .= [url] + ] + +instance FromJSON SFTServer where + parseJSON = withObject "SFTServer" $ \o -> + o .: "urls" >>= \case + [url] -> pure $ SFTServer url + xs -> fail $ "SFTServer can only have exactly one URL, found " <> show (length xs) + +sftServer :: HttpsUrl -> SFTServer +sftServer = SFTServer + +modelRtcSftServer :: Doc.Model +modelRtcSftServer = Doc.defineModel "RTC SFT Server" $ do + Doc.description "Inspired by WebRTC 'RTCIceServer' object, contains details of SFT servers" + Doc.property "urls" (Doc.array Doc.string') $ + Doc.description "Array containing exactly one SFT server address of the form 'https://:'" -------------------------------------------------------------------------------- -- RTCIceServer @@ -131,14 +173,14 @@ instance FromJSON RTCConfiguration where -- -- cf. https://developer.mozilla.org/en-US/docs/Web/API/RTCIceServer data RTCIceServer = RTCIceServer - { _iceURLs :: List1 TurnURI, + { _iceURLs :: NonEmpty TurnURI, _iceUsername :: TurnUsername, _iceCredential :: AsciiBase64 } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform RTCIceServer) -rtcIceServer :: List1 TurnURI -> TurnUsername -> AsciiBase64 -> RTCIceServer +rtcIceServer :: NonEmpty TurnURI -> TurnUsername -> AsciiBase64 -> RTCIceServer rtcIceServer = RTCIceServer modelRtcIceServer :: Doc.Model @@ -207,7 +249,7 @@ parseTurnURI = parseOnly (parser <* endOfInput) <$> ((takeWhile1 (/= ':') <* char ':' >>= parseScheme) "parsingScheme") <*> ((takeWhile1 (/= ':') <* char ':' >>= parseHost) "parsingHost") <*> (decimal "parsingPort") - <*> ((optional ((string "?transport=" *> takeText) >>= parseTransport)) "parsingTransport") + <*> (optional ((string "?transport=" *> takeText) >>= parseTransport) "parsingTransport") parseScheme = parse "parseScheme" parseHost = parse "parseHost" parseTransport = parse "parseTransport" @@ -240,10 +282,11 @@ instance BC.ToByteString Scheme where builder SchemeTurns = "turns" instance BC.FromByteString Scheme where - parser = BC.parser >>= \t -> case (t :: ByteString) of - "turn" -> pure SchemeTurn - "turns" -> pure SchemeTurns - _ -> fail $ "Invalid turn scheme: " ++ show t + parser = + BC.parser >>= \t -> case (t :: ByteString) of + "turn" -> pure SchemeTurn + "turns" -> pure SchemeTurns + _ -> fail $ "Invalid turn scheme: " ++ show t instance ToJSON Scheme where toJSON = String . TE.decodeUtf8 . BC.toByteString' @@ -306,10 +349,11 @@ instance BC.ToByteString Transport where builder TransportTCP = "tcp" instance BC.FromByteString Transport where - parser = BC.parser >>= \t -> case (t :: ByteString) of - "udp" -> pure TransportUDP - "tcp" -> pure TransportTCP - _ -> fail $ "Invalid turn transport: " ++ show t + parser = + BC.parser >>= \t -> case (t :: ByteString) of + "udp" -> pure TransportUDP + "tcp" -> pure TransportTCP + _ -> fail $ "Invalid turn transport: " ++ show t instance ToJSON Transport where toJSON = String . TE.decodeUtf8 . BC.toByteString' @@ -421,21 +465,22 @@ limitServers uris limit = limitServers' [] limit uris isUdp :: TurnURI -> Bool isUdp uri = _turiScheme uri == SchemeTurn - && ( _turiTransport uri == Just (TransportUDP) - || _turiTransport uri == Nothing + && ( _turiTransport uri == Just TransportUDP + || isNothing (_turiTransport uri) ) isTcp :: TurnURI -> Bool isTcp uri = _turiScheme uri == SchemeTurn - && _turiTransport uri == Just (TransportTCP) + && _turiTransport uri == Just TransportTCP isTls :: TurnURI -> Bool isTls uri = _turiScheme uri == SchemeTurns - && _turiTransport uri == Just (TransportTCP) + && _turiTransport uri == Just TransportTCP makeLenses ''RTCConfiguration makeLenses ''RTCIceServer makeLenses ''TurnURI makeLenses ''TurnUsername +makeLenses ''SFTServer diff --git a/libs/wire-api/src/Wire/API/Connection.hs b/libs/wire-api/src/Wire/API/Connection.hs index b40c579a813..4003290b77d 100644 --- a/libs/wire-api/src/Wire/API/Connection.hs +++ b/libs/wire-api/src/Wire/API/Connection.hs @@ -186,14 +186,15 @@ instance FromJSON Relation where parseJSON _ = mzero instance FromByteString Relation where - parser = takeByteString >>= \b -> case b of - "accepted" -> return Accepted - "blocked" -> return Blocked - "pending" -> return Pending - "ignored" -> return Ignored - "sent" -> return Sent - "cancelled" -> return Cancelled - x -> fail $ "Invalid relation-type " <> show x + parser = + takeByteString >>= \b -> case b of + "accepted" -> return Accepted + "blocked" -> return Blocked + "pending" -> return Pending + "ignored" -> return Ignored + "sent" -> return Sent + "cancelled" -> return Cancelled + x -> fail $ "Invalid relation-type " <> show x -------------------------------------------------------------------------------- -- Message diff --git a/libs/wire-api/src/Wire/API/Conversation/Code.hs b/libs/wire-api/src/Wire/API/Conversation/Code.hs index 6b8ff56635c..49c2b19194c 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Code.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Code.hs @@ -34,7 +34,7 @@ module Wire.API.Conversation.Code where import Control.Lens ((.~)) -import Data.Aeson ((.:), (.:?), (.=), FromJSON (parseJSON), ToJSON (toJSON)) +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), (.:), (.:?), (.=)) import qualified Data.Aeson as JSON import Data.ByteString.Conversion (toByteString') -- FUTUREWORK: move content of Data.Code here? diff --git a/libs/wire-api/src/Wire/API/Event/Conversation.hs b/libs/wire-api/src/Wire/API/Event/Conversation.hs index 1d0efa3d4b7..491c640b001 100644 --- a/libs/wire-api/src/Wire/API/Event/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Event/Conversation.hs @@ -67,19 +67,18 @@ import Data.Aeson import Data.Aeson.Types (Parser) import qualified Data.HashMap.Strict as HashMap import Data.Id -import Data.Json.Util ((#), ToJSONObject (toJSONObject), toUTCTimeMillis) +import Data.Json.Util (ToJSONObject (toJSONObject), toUTCTimeMillis, (#)) import qualified Data.Swagger.Build.Api as Doc import Data.Time import Imports import qualified Test.QuickCheck as QC import URI.ByteString () import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) -import Wire.API.Conversation (modelConversationAccessUpdate, modelConversationMessageTimerUpdate, modelConversationReceiptModeUpdate, modelConversationUpdateName) import Wire.API.Conversation +import Wire.API.Conversation (modelConversationAccessUpdate, modelConversationMessageTimerUpdate, modelConversationReceiptModeUpdate, modelConversationUpdateName) import Wire.API.Conversation.Code (ConversationCode (..), modelConversationCode) import Wire.API.Conversation.Role -import Wire.API.Conversation.Typing (modelTyping) -import Wire.API.Conversation.Typing (TypingData (..)) +import Wire.API.Conversation.Typing (TypingData (..), modelTyping) import Wire.API.User (UserIdList (..)) -------------------------------------------------------------------------------- @@ -225,9 +224,6 @@ instance FromJSON EventType where parseJSON (String "conversation.otr-message-add") = return OtrMessageAdd parseJSON x = fail $ "No event-type: " <> show (encode x) --- FUTUREWORK(federation, #1213): --- A lot of information in the events can contain remote IDs, but the --- receiver might be on another backend, so mapped IDs don't work for them. data EventData = EdMembersJoin SimpleMembers | EdMembersLeave UserIdList @@ -359,9 +355,9 @@ newtype SimpleMembers = SimpleMembers -- | Used both for 'SimpleMembers' and 'UserIdList'. modelMembers :: Doc.Model modelMembers = - Doc.defineModel "Members" - $ Doc.property "users" (Doc.unique $ Doc.array Doc.bytes') - $ Doc.description "List of user IDs" + Doc.defineModel "Members" $ + Doc.property "users" (Doc.unique $ Doc.array Doc.bytes') $ + Doc.description "List of user IDs" instance ToJSON SimpleMembers where toJSON e = diff --git a/libs/wire-api/src/Wire/API/Event/Team.hs b/libs/wire-api/src/Wire/API/Event/Team.hs index 604de971b65..a51b1fd2cfb 100644 --- a/libs/wire-api/src/Wire/API/Event/Team.hs +++ b/libs/wire-api/src/Wire/API/Event/Team.hs @@ -98,9 +98,9 @@ modelMemberEvent = Doc.defineModel "TeamMemberEvent" $ do modelMemberData :: Doc.Model modelMemberData = - Doc.defineModel "MemberData" - $ Doc.property "user" Doc.bytes' - $ Doc.description "user ID" + Doc.defineModel "MemberData" $ + Doc.property "user" Doc.bytes' $ + Doc.description "user ID" modelConvEvent :: Doc.Model modelConvEvent = Doc.defineModel "TeamConversationEvent" $ do @@ -109,9 +109,9 @@ modelConvEvent = Doc.defineModel "TeamConversationEvent" $ do modelConversationData :: Doc.Model modelConversationData = - Doc.defineModel "ConversationData" - $ Doc.property "conv" Doc.bytes' - $ Doc.description "conversation ID" + Doc.defineModel "ConversationData" $ + Doc.property "conv" Doc.bytes' $ + Doc.description "conversation ID" modelUpdateEvent :: Doc.Model modelUpdateEvent = Doc.defineModel "TeamUpdateEvent" $ do diff --git a/libs/wire-api/src/Wire/API/Notification.hs b/libs/wire-api/src/Wire/API/Notification.hs index 1bc4b6018ce..fc2a343b9cd 100644 --- a/libs/wire-api/src/Wire/API/Notification.hs +++ b/libs/wire-api/src/Wire/API/Notification.hs @@ -42,8 +42,8 @@ module Wire.API.Notification where import Control.Lens (makeLenses) +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), (.!=), (.:), (.:?), (.=)) import qualified Data.Aeson as JSON -import Data.Aeson ((.!=), (.:), (.:?), (.=), FromJSON (parseJSON), ToJSON (toJSON)) import Data.Id import Data.Json.Util ((#)) import Data.List1 diff --git a/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs b/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs index 5363d8678d0..61f94d9d916 100644 --- a/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs +++ b/libs/wire-api/src/Wire/API/Provider/Service/Tag.hs @@ -45,8 +45,8 @@ import qualified Data.Aeson as JSON import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion -import qualified Data.Range as Range import Data.Range (LTE, Range, fromRange) +import qualified Data.Range as Range import qualified Data.Set as Set import qualified Data.Text.Encoding as Text import GHC.TypeLits (KnownNat, Nat) @@ -97,39 +97,40 @@ data ServiceTag deriving (Arbitrary) via (GenericUniform ServiceTag) instance FromByteString ServiceTag where - parser = parser >>= \t -> case (t :: ByteString) of - "audio" -> pure AudioTag - "books" -> pure BooksTag - "business" -> pure BusinessTag - "design" -> pure DesignTag - "education" -> pure EducationTag - "entertainment" -> pure EntertainmentTag - "finance" -> pure FinanceTag - "fitness" -> pure FitnessTag - "food-drink" -> pure FoodDrinkTag - "games" -> pure GamesTag - "graphics" -> pure GraphicsTag - "health" -> pure HealthTag - "integration" -> pure IntegrationTag - "lifestyle" -> pure LifestyleTag - "media" -> pure MediaTag - "medical" -> pure MedicalTag - "movies" -> pure MoviesTag - "music" -> pure MusicTag - "news" -> pure NewsTag - "photography" -> pure PhotographyTag - "poll" -> pure PollTag - "productivity" -> pure ProductivityTag - "quiz" -> pure QuizTag - "rating" -> pure RatingTag - "shopping" -> pure ShoppingTag - "social" -> pure SocialTag - "sports" -> pure SportsTag - "travel" -> pure TravelTag - "tutorial" -> pure TutorialTag - "video" -> pure VideoTag - "weather" -> pure WeatherTag - _ -> fail $ "Invalid tag: " ++ show t + parser = + parser >>= \t -> case (t :: ByteString) of + "audio" -> pure AudioTag + "books" -> pure BooksTag + "business" -> pure BusinessTag + "design" -> pure DesignTag + "education" -> pure EducationTag + "entertainment" -> pure EntertainmentTag + "finance" -> pure FinanceTag + "fitness" -> pure FitnessTag + "food-drink" -> pure FoodDrinkTag + "games" -> pure GamesTag + "graphics" -> pure GraphicsTag + "health" -> pure HealthTag + "integration" -> pure IntegrationTag + "lifestyle" -> pure LifestyleTag + "media" -> pure MediaTag + "medical" -> pure MedicalTag + "movies" -> pure MoviesTag + "music" -> pure MusicTag + "news" -> pure NewsTag + "photography" -> pure PhotographyTag + "poll" -> pure PollTag + "productivity" -> pure ProductivityTag + "quiz" -> pure QuizTag + "rating" -> pure RatingTag + "shopping" -> pure ShoppingTag + "social" -> pure SocialTag + "sports" -> pure SportsTag + "travel" -> pure TravelTag + "tutorial" -> pure TutorialTag + "video" -> pure VideoTag + "weather" -> pure WeatherTag + _ -> fail $ "Invalid tag: " ++ show t instance ToByteString ServiceTag where builder AudioTag = "audio" diff --git a/libs/wire-api/src/Wire/API/Push/V2/Token.hs b/libs/wire-api/src/Wire/API/Push/V2/Token.hs index 9d8fc8de8c9..ad2a8d9de99 100644 --- a/libs/wire-api/src/Wire/API/Push/V2/Token.hs +++ b/libs/wire-api/src/Wire/API/Push/V2/Token.hs @@ -156,13 +156,14 @@ instance FromJSON Transport where x -> fail $ "Invalid push transport: " ++ show x instance FromByteString Transport where - parser = takeByteString >>= \case - "GCM" -> return GCM - "APNS" -> return APNS - "APNS_SANDBOX" -> return APNSSandbox - "APNS_VOIP" -> return APNSVoIP - "APNS_VOIP_SANDBOX" -> return APNSVoIPSandbox - x -> fail $ "Invalid push transport: " <> show x + parser = + takeByteString >>= \case + "GCM" -> return GCM + "APNS" -> return APNS + "APNS_SANDBOX" -> return APNSSandbox + "APNS_VOIP" -> return APNSVoIP + "APNS_VOIP_SANDBOX" -> return APNSVoIPSandbox + x -> fail $ "Invalid push transport: " <> show x newtype Token = Token { tokenText :: Text diff --git a/libs/wire-api/src/Wire/API/Swagger.hs b/libs/wire-api/src/Wire/API/Swagger.hs index 3feada1b9db..32e0f205732 100644 --- a/libs/wire-api/src/Wire/API/Swagger.hs +++ b/libs/wire-api/src/Wire/API/Swagger.hs @@ -18,7 +18,7 @@ module Wire.API.Swagger where import Data.Swagger.Build.Api (Model) -import qualified Wire.API.Call.TURN as Call.TURN +import qualified Wire.API.Call.Config as Call.Config import qualified Wire.API.Connection as Connection import qualified Wire.API.Conversation as Conversation import qualified Wire.API.Conversation.Code as Conversation.Code @@ -53,8 +53,8 @@ import qualified Wire.API.User.Search as User.Search models :: [Model] models = - [ Call.TURN.modelRtcConfiguration, - Call.TURN.modelRtcIceServer, + [ Call.Config.modelRtcConfiguration, + Call.Config.modelRtcIceServer, Connection.modelConnectionList, Connection.modelConnection, Connection.modelConnectionRequest, diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 5ed9fd781f0..23ea0ae9874 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -51,15 +51,16 @@ data TeamFeatureName deriving (Arbitrary) via (GenericUniform TeamFeatureName) instance FromByteString TeamFeatureName where - parser = Parser.takeByteString >>= \b -> - case T.decodeUtf8' b of - Left e -> fail $ "Invalid TeamFeatureName: " <> show e - Right "legalhold" -> pure TeamFeatureLegalHold - Right "sso" -> pure TeamFeatureSSO - Right "search-visibility" -> pure TeamFeatureSearchVisibility - Right "validate-saml-emails" -> pure TeamFeatureValidateSAMLEmails - Right "digital-signatures" -> pure TeamFeatureDigitalSignatures - Right t -> fail $ "Invalid TeamFeatureName: " <> T.unpack t + parser = + Parser.takeByteString >>= \b -> + case T.decodeUtf8' b of + Left e -> fail $ "Invalid TeamFeatureName: " <> show e + Right "legalhold" -> pure TeamFeatureLegalHold + Right "sso" -> pure TeamFeatureSSO + Right "search-visibility" -> pure TeamFeatureSearchVisibility + Right "validate-saml-emails" -> pure TeamFeatureValidateSAMLEmails + Right "digital-signatures" -> pure TeamFeatureDigitalSignatures + Right t -> fail $ "Invalid TeamFeatureName: " <> T.unpack t instance ToByteString TeamFeatureName where builder TeamFeatureLegalHold = "legalhold" @@ -121,9 +122,10 @@ instance ToByteString TeamFeatureStatusValue where builder TeamFeatureDisabled = "disabled" instance FromByteString TeamFeatureStatusValue where - parser = Parser.takeByteString >>= \b -> - case T.decodeUtf8' b of - Right "enabled" -> pure TeamFeatureEnabled - Right "disabled" -> pure TeamFeatureDisabled - Right t -> fail $ "Invalid TeamFeatureStatusValue: " <> T.unpack t - Left e -> fail $ "Invalid TeamFeatureStatusValue: " <> show e + parser = + Parser.takeByteString >>= \b -> + case T.decodeUtf8' b of + Right "enabled" -> pure TeamFeatureEnabled + Right "disabled" -> pure TeamFeatureDisabled + Right t -> fail $ "Invalid TeamFeatureStatusValue: " <> T.unpack t + Left e -> fail $ "Invalid TeamFeatureStatusValue: " <> show e diff --git a/libs/wire-api/src/Wire/API/Team/Invitation.hs b/libs/wire-api/src/Wire/API/Team/Invitation.hs index 20b8e71b9a1..1473300149e 100644 --- a/libs/wire-api/src/Wire/API/Team/Invitation.hs +++ b/libs/wire-api/src/Wire/API/Team/Invitation.hs @@ -44,12 +44,11 @@ import Wire.API.User.Profile (Locale, Name) -- InvitationRequest data InvitationRequest = InvitationRequest - { irEmail :: Email, - irName :: Name, - irLocale :: Maybe Locale, + { irLocale :: Maybe Locale, irRole :: Maybe Role, irInviteeName :: Maybe Name, - irPhone :: Maybe Phone + irInviteeEmail :: Email, + irInviteePhone :: Maybe Phone } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform InvitationRequest) @@ -57,42 +56,40 @@ data InvitationRequest = InvitationRequest modelTeamInvitationRequest :: Doc.Model modelTeamInvitationRequest = Doc.defineModel "TeamInvitationRequest" $ do Doc.description "A request to join a team on Wire." - Doc.property "inviter_name" Doc.string' $ - Doc.description "Name of the inviter (1 - 128 characters)" - Doc.property "email" Doc.string' $ - Doc.description "Email of the invitee" Doc.property "locale" Doc.string' $ do Doc.description "Locale to use for the invitation." Doc.optional Doc.property "role" typeRole $ do - Doc.description "Role of the invited user" + Doc.description "Role of the invitee (invited user)." Doc.optional Doc.property "name" Doc.string' $ do - Doc.description "Name of the invitee (1 - 128 characters)" + Doc.description "Name of the invitee (1 - 128 characters)." Doc.optional + Doc.property "email" Doc.string' $ + Doc.description "Email of the invitee." Doc.property "phone" Doc.string' $ do - Doc.description "Phone number of the invitee, in the E.164 format" + Doc.description "Phone number of the invitee, in the E.164 format." Doc.optional + Doc.property "inviter_name" Doc.string' $ + Doc.description "DEPRECATED - WILL BE IGNORED IN FAVOR OF REQ AUTH DATA - Name of the inviter (1 - 128 characters)." instance ToJSON InvitationRequest where toJSON i = object $ - [ "email" .= irEmail i, - "inviter_name" .= irName i, - "locale" .= irLocale i, + [ "locale" .= irLocale i, "role" .= irRole i, "name" .= irInviteeName i, - "phone" .= irPhone i + "email" .= irInviteeEmail i, + "phone" .= irInviteePhone i ] instance FromJSON InvitationRequest where parseJSON = withObject "invitation-request" $ \o -> InvitationRequest - <$> o .: "email" - <*> o .: "inviter_name" - <*> o .:? "locale" + <$> o .:? "locale" <*> o .:? "role" <*> o .:? "name" + <*> o .: "email" <*> o .:? "phone" -------------------------------------------------------------------------------- @@ -102,22 +99,19 @@ data Invitation = Invitation { inTeam :: TeamId, inRole :: Role, inInvitation :: InvitationId, - inIdentity :: Email, inCreatedAt :: UTCTimeMillis, -- | this is always 'Just' for new invitations, but for -- migration it is allowed to be 'Nothing'. inCreatedBy :: Maybe UserId, + inInviteeEmail :: Email, inInviteeName :: Maybe Name, - inPhone :: Maybe Phone + inInviteePhone :: Maybe Phone } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform Invitation) --- | This is *not* the swagger model for the 'TeamInvitation' type (which does not exist), but --- for the use of 'Invitation' under @/teams/{tid}/invitations@. --- --- TODO: swagger should be replaced by something more type-safe at some point so this will be --- forcibly resolved and won't happen again. +-- | (This is *not* the swagger model for the 'TeamInvitation' type (which does not exist), +-- but for the use of 'Invitation' under @/teams/{tid}/invitations@.) modelTeamInvitation :: Doc.Model modelTeamInvitation = Doc.defineModel "TeamInvitation" $ do Doc.description "An invitation to join a team on Wire" @@ -128,13 +122,13 @@ modelTeamInvitation = Doc.defineModel "TeamInvitation" $ do Doc.optional Doc.property "id" Doc.bytes' $ Doc.description "UUID used to refer the invitation" - Doc.property "email" Doc.string' $ - Doc.description "Email of the invitee" Doc.property "created_at" Doc.dateTime' $ Doc.description "Timestamp of invitation creation" Doc.property "created_by" Doc.bytes' $ do Doc.description "ID of the inviting user" Doc.optional + Doc.property "email" Doc.string' $ + Doc.description "Email of the invitee" Doc.property "name" Doc.string' $ do Doc.description "Name of the invitee (1 - 128 characters)" Doc.optional @@ -148,11 +142,11 @@ instance ToJSON Invitation where [ "team" .= inTeam i, "role" .= inRole i, "id" .= inInvitation i, - "email" .= inIdentity i, "created_at" .= inCreatedAt i, "created_by" .= inCreatedBy i, + "email" .= inInviteeEmail i, "name" .= inInviteeName i, - "phone" .= inPhone i + "phone" .= inInviteePhone i ] instance FromJSON Invitation where @@ -162,9 +156,9 @@ instance FromJSON Invitation where -- clients, when leaving "role" empty, can leave the default role choice to us <*> o .:? "role" .!= defaultRole <*> o .: "id" - <*> o .: "email" <*> o .: "created_at" <*> o .:? "created_by" + <*> o .: "email" <*> o .:? "name" <*> o .:? "phone" diff --git a/libs/wire-api/src/Wire/API/Team/Permission.hs b/libs/wire-api/src/Wire/API/Team/Permission.hs index c6eae0c2fc9..4c3e023a7d6 100644 --- a/libs/wire-api/src/Wire/API/Team/Permission.hs +++ b/libs/wire-api/src/Wire/API/Team/Permission.hs @@ -44,9 +44,9 @@ where import qualified Cassandra as Cql import qualified Control.Error.Util as Err -import Control.Lens ((^.), makeLenses) +import Control.Lens (makeLenses, (^.)) import Data.Aeson -import Data.Bits ((.|.), testBit) +import Data.Bits (testBit, (.|.)) import Data.Json.Util import qualified Data.Set as Set import qualified Data.Swagger.Build.Api as Doc @@ -89,10 +89,11 @@ instance FromJSON Permissions where Just ps -> pure ps instance Arbitrary Permissions where - arbitrary = maybe (error "instance Arbitrary Permissions") pure =<< do - selfperms <- arbitrary - copyperms <- Set.intersection selfperms <$> arbitrary - pure $ newPermissions selfperms copyperms + arbitrary = + maybe (error "instance Arbitrary Permissions") pure =<< do + selfperms <- arbitrary + copyperms <- Set.intersection selfperms <$> arbitrary + pure $ newPermissions selfperms copyperms newPermissions :: -- | User's permissions diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index e0f6a886ddb..5afbd6d6bf7 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -36,12 +36,15 @@ module Wire.API.User -- * NewUser NewUserPublic (..), NewUser (..), + emptyNewUser, ExpiresIn, newUserInvitationCode, newUserTeam, newUserEmail, newUserPhone, newUserSSOId, + isNewUserEphemeral, + isNewUserTeamMember, -- * NewUserOrigin NewUserOrigin (..), @@ -56,6 +59,7 @@ module Wire.API.User EmailUpdate (..), PhoneUpdate (..), HandleUpdate (..), + NameUpdate (..), -- * Account Deletion DeleteUser (..), @@ -96,7 +100,7 @@ import qualified Data.Currency as Currency import Data.Handle (Handle) import qualified Data.HashMap.Strict as HashMap import Data.Id -import Data.Json.Util ((#), UTCTimeMillis) +import Data.Json.Util (UTCTimeMillis, (#)) import Data.Misc (PlainTextPassword (..)) import Data.Range import qualified Data.Swagger.Build.Api as Doc @@ -491,6 +495,25 @@ validateNewUserPublic nu | otherwise = Right (NewUserPublic nu) +-- | A user is Ephemeral if she has neither email, phone, nor sso credentials and is not +-- created via scim. Ephemeral users can be deleted after expires_in or sessionTokenTimeout +-- (whichever comes earlier). +isNewUserEphemeral :: NewUser -> Bool +isNewUserEphemeral u = noId && noScim + where + noId = isNothing $ newUserIdentity u + noScim = case newUserManagedBy u of + Nothing -> True + Just ManagedByWire -> True + Just ManagedByScim -> False + +isNewUserTeamMember :: NewUser -> Bool +isNewUserTeamMember u = case newUserTeam u of + Just (NewTeamMember _) -> True + Just (NewTeamMemberSSO _) -> True + Just (NewTeamCreator _) -> False + Nothing -> False + instance Arbitrary NewUserPublic where arbitrary = arbitrary `QC.suchThatMap` (rightMay . validateNewUserPublic) @@ -514,6 +537,25 @@ data NewUser = NewUser } deriving stock (Eq, Show, Generic) +emptyNewUser :: Name -> NewUser +emptyNewUser name = + NewUser + { newUserDisplayName = name, + newUserUUID = Nothing, + newUserIdentity = Nothing, + newUserPict = Nothing, + newUserAssets = [], + newUserAccentId = Nothing, + newUserEmailCode = Nothing, + newUserPhoneCode = Nothing, + newUserOrigin = Nothing, + newUserLabel = Nothing, + newUserLocale = Nothing, + newUserPassword = Nothing, + newUserExpiresIn = Nothing, + newUserManagedBy = Nothing + } + -- | 1 second - 1 week type ExpiresIn = Range 1 604800 Integer @@ -855,6 +897,17 @@ instance FromJSON HandleUpdate where parseJSON = withObject "handle-update" $ \o -> HandleUpdate <$> o .: "handle" +newtype NameUpdate = NameUpdate {nuHandle :: Text} + deriving stock (Eq, Show, Generic) + deriving newtype (Arbitrary) + +instance ToJSON NameUpdate where + toJSON h = object ["name" .= nuHandle h] + +instance FromJSON NameUpdate where + parseJSON = withObject "name-update" $ \o -> + NameUpdate <$> o .: "name" + ----------------------------------------------------------------------------- -- Account Deletion diff --git a/libs/wire-api/src/Wire/API/User/Client.hs b/libs/wire-api/src/Wire/API/User/Client.hs index d9e4ae8bb06..31b52316050 100644 --- a/libs/wire-api/src/Wire/API/User/Client.hs +++ b/libs/wire-api/src/Wire/API/User/Client.hs @@ -124,9 +124,9 @@ newtype UserClients = UserClients modelUserClients :: Doc.Model modelUserClients = - Doc.defineModel "UserClients" - $ Doc.property "" (Doc.unique $ Doc.array Doc.bytes') - $ Doc.description "Map of user IDs to sets of client IDs ({ UserId: [ClientId] })." + Doc.defineModel "UserClients" $ + Doc.property "" (Doc.unique $ Doc.array Doc.bytes') $ + Doc.description "Map of user IDs to sets of client IDs ({ UserId: [ClientId] })." instance ToJSON UserClients where toJSON = @@ -256,12 +256,15 @@ instance FromJSON PubClient where -- team on a per-user basis -- * A LegalHoldClient is a client outside that user's control (but under the + -- control of that team's business) -- * Users need to click "accept" before a LegalHoldClient is added to their + -- account. -- * Any user interacting with a user which has a LegalHoldClient will upon + -- first interaction receive a warning, have the option of cancelling the -- interaction, and on an ongoing basis see a visual indication in all -- conversations where such a device is active. diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index edf244b6811..92acc22a824 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -219,11 +219,12 @@ instance FromByteString Phone where parser = parser >>= maybe (fail "Invalid phone") return . parsePhone instance Arbitrary Phone where - arbitrary = Phone . Text.pack <$> do - let mkdigits n = replicateM n (QC.elements ['0' .. '9']) - mini <- mkdigits 8 - maxi <- mkdigits =<< QC.chooseInt (0, 7) - pure $ '+' : mini <> maxi + arbitrary = + Phone . Text.pack <$> do + let mkdigits n = replicateM n (QC.elements ['0' .. '9']) + mini <- mkdigits 8 + maxi <- mkdigits =<< QC.chooseInt (0, 7) + pure $ '+' : mini <> maxi -- | Parses a phone number in E.164 format with a mandatory leading '+'. parsePhone :: Text -> Maybe Phone diff --git a/libs/wire-api/src/Wire/API/User/Profile.hs b/libs/wire-api/src/Wire/API/User/Profile.hs index 9005dda98b7..07a10a4050d 100644 --- a/libs/wire-api/src/Wire/API/User/Profile.hs +++ b/libs/wire-api/src/Wire/API/User/Profile.hs @@ -21,6 +21,7 @@ module Wire.API.User.Profile ( Name (..), + mkName, ColourId (..), defaultAccentId, @@ -58,6 +59,7 @@ import Control.Applicative (optional) import Control.Error (hush) import Data.Aeson hiding (()) import qualified Data.Aeson.Types as Json +import Data.Attoparsec.ByteString.Char8 (takeByteString) import Data.Attoparsec.Text import Data.ByteString.Conversion import Data.ISO3166_CountryCodes @@ -81,6 +83,9 @@ newtype Name = Name deriving newtype (ToJSON, FromByteString, ToByteString) deriving (Arbitrary) via (Ranged 1 128 Text) +mkName :: Text -> Either String Name +mkName txt = Name . fromRange <$> checkedEitherMsg @_ @1 @128 "Name" txt + modelUserDisplayName :: Doc.Model modelUserDisplayName = Doc.defineModel "UserDisplayName" $ do Doc.description "User name" @@ -271,9 +276,10 @@ typeManagedBy = ] instance ToJSON ManagedBy where - toJSON = String . \case - ManagedByWire -> "wire" - ManagedByScim -> "scim" + toJSON = + String . \case + ManagedByWire -> "wire" + ManagedByScim -> "scim" instance FromJSON ManagedBy where parseJSON = withText "ManagedBy" $ \case @@ -281,6 +287,17 @@ instance FromJSON ManagedBy where "scim" -> pure ManagedByScim other -> fail $ "Invalid ManagedBy: " ++ show other +instance ToByteString ManagedBy where + builder ManagedByWire = "wire" + builder ManagedByScim = "scim" + +instance FromByteString ManagedBy where + parser = + takeByteString >>= \case + "wire" -> pure ManagedByWire + "scim" -> pure ManagedByScim + x -> fail $ "Invalid ManagedBy value: " <> show x + defaultManagedBy :: ManagedBy defaultManagedBy = ManagedByWire diff --git a/libs/wire-api/test/unit/Main.hs b/libs/wire-api/test/unit/Main.hs index 53893a18af8..15bfb7b4178 100644 --- a/libs/wire-api/test/unit/Main.hs +++ b/libs/wire-api/test/unit/Main.hs @@ -22,7 +22,7 @@ where import Imports import Test.Tasty -import qualified Test.Wire.API.Call.TURN as Call.TURN +import qualified Test.Wire.API.Call.Config as Call.Config import qualified Test.Wire.API.Roundtrip.Aeson as Roundtrip.Aeson import qualified Test.Wire.API.Roundtrip.ByteString as Roundtrip.ByteString import qualified Test.Wire.API.Team.Member as Team.Member @@ -34,7 +34,7 @@ main = defaultMain $ testGroup "Tests" - [ Call.TURN.tests, + [ Call.Config.tests, Team.Member.tests, User.tests, User.RichInfo.tests, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Call/TURN.hs b/libs/wire-api/test/unit/Test/Wire/API/Call/Config.hs similarity index 80% rename from libs/wire-api/test/unit/Test/Wire/API/Call/TURN.hs rename to libs/wire-api/test/unit/Test/Wire/API/Call/Config.hs index 84c13902572..9394f8bd32d 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Call/TURN.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Call/Config.hs @@ -15,14 +15,15 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Wire.API.Call.TURN where +module Test.Wire.API.Call.Config where import Data.Aeson +import qualified Data.HashMap.Strict as HM import Imports import Test.Tasty import Test.Tasty.QuickCheck hiding (total) import Wire.API.Arbitrary () -import Wire.API.Call.TURN (TurnURI, isTcp, isTls, isUdp, limitServers) +import Wire.API.Call.Config (RTCConfiguration, TurnURI, isTcp, isTls, isUdp, limitServers) tests :: TestTree tests = @@ -33,7 +34,8 @@ tests = testProperty "limitServers/fairness udp" (fairnessProp isUdp), testProperty "limitServers/fairness tls" (fairnessProp isTls), testProperty "limitServers/fairness tcp" (fairnessProp isTcp), - testProperty "limitServers/udpPriority" udpPriority + testProperty "limitServers/udpPriority" udpPriority, + testProperty "RTCConfiguration/toJson: sftServersAreNeverNull" sftServersAreNeverNull ] turnURIid :: TurnURI -> Property @@ -64,6 +66,11 @@ udpPriority uris = do then returnedUdp >= 2 else True +sftServersAreNeverNull :: RTCConfiguration -> Bool +sftServersAreNeverNull cfg = case toJSON cfg of + Object o -> HM.lookup "sft_servers" o /= Just Null + v -> error . show $ "type mismatch, expected RTCConfiguration to be Object, but got: " <> encode v + newtype ZeroToTen = ZeroToTen Int deriving (Eq, Show) diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index b4174ca0478..d6268514913 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -23,11 +23,11 @@ import Data.Id (ConvId) import Imports import qualified Test.Tasty as T import Test.Tasty.ExpectedFailure (ignoreTest) -import Test.Tasty.QuickCheck ((===), Arbitrary, counterexample, testProperty) +import Test.Tasty.QuickCheck (Arbitrary, counterexample, testProperty, (===)) import Type.Reflection (typeRep) import qualified Wire.API.Asset as Asset import qualified Wire.API.Asset.V3.Resumable as Asset.Resumable -import qualified Wire.API.Call.TURN as Call.TURN +import qualified Wire.API.Call.Config as Call.Config import qualified Wire.API.Connection as Connection import qualified Wire.API.Conversation as Conversation import qualified Wire.API.Conversation.Bot as Conversation.Bot @@ -85,13 +85,14 @@ tests = testRoundTrip @Asset.Resumable.ChunkSize, testRoundTrip @Asset.Resumable.Offset, currentlyFailing (testRoundTrip @Asset.Resumable.ResumableAsset), -- because ToJSON is rounding UTCTime - testRoundTrip @Call.TURN.TurnHost, - testRoundTrip @Call.TURN.Scheme, - testRoundTrip @Call.TURN.Transport, - testRoundTrip @Call.TURN.TurnURI, - testRoundTrip @Call.TURN.TurnUsername, - testRoundTrip @Call.TURN.RTCIceServer, - testRoundTrip @Call.TURN.RTCConfiguration, + testRoundTrip @Call.Config.TurnHost, + testRoundTrip @Call.Config.Scheme, + testRoundTrip @Call.Config.Transport, + testRoundTrip @Call.Config.TurnURI, + testRoundTrip @Call.Config.TurnUsername, + testRoundTrip @Call.Config.RTCIceServer, + testRoundTrip @Call.Config.RTCConfiguration, + testRoundTrip @Call.Config.SFTServer, testRoundTrip @Connection.ConnectionRequest, testRoundTrip @Connection.Relation, testRoundTrip @Connection.Message, @@ -219,6 +220,7 @@ tests = testRoundTrip @Team.Role.Role, testRoundTrip @Team.SearchVisibility.TeamSearchVisibility, testRoundTrip @Team.SearchVisibility.TeamSearchVisibilityView, + testRoundTrip @User.NameUpdate, testRoundTrip @User.NewUser, testRoundTrip @User.NewUserPublic, testRoundTrip @User.UserIdList, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs index 579ecdeb5d1..c98a5472085 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs @@ -20,12 +20,12 @@ module Test.Wire.API.Roundtrip.ByteString (tests) where import Data.ByteString.Conversion import Imports import qualified Test.Tasty as T -import Test.Tasty.QuickCheck ((===), Arbitrary, counterexample, testProperty) +import Test.Tasty.QuickCheck (Arbitrary, counterexample, testProperty, (===)) import Type.Reflection (typeRep) import qualified Wire.API.Arbitrary as Arbitrary () import qualified Wire.API.Asset.V3 as Asset.V3 import qualified Wire.API.Asset.V3.Resumable as Asset.V3.Resumable -import qualified Wire.API.Call.TURN as Call.TURN +import qualified Wire.API.Call.Config as Call.Config import qualified Wire.API.Conversation.Code as Conversation.Code import qualified Wire.API.Conversation.Role as Conversation.Role import qualified Wire.API.Properties as Properties @@ -50,10 +50,10 @@ tests = testRoundTrip @Asset.V3.Resumable.ChunkSize, testRoundTrip @Asset.V3.Resumable.Offset, testRoundTrip @Asset.V3.Resumable.TotalSize, - testRoundTrip @Call.TURN.Scheme, - testRoundTrip @Call.TURN.Transport, - testRoundTrip @Call.TURN.TurnHost, - testRoundTrip @Call.TURN.TurnURI, + testRoundTrip @Call.Config.Scheme, + testRoundTrip @Call.Config.Transport, + testRoundTrip @Call.Config.TurnHost, + testRoundTrip @Call.Config.TurnURI, testRoundTrip @Conversation.Code.Key, testRoundTrip @Conversation.Code.Value, testRoundTrip @Conversation.Role.RoleName, @@ -61,6 +61,8 @@ tests = testRoundTrip @Provider.HttpsUrl, testRoundTrip @Provider.Service.ServiceKeyPEM, testRoundTrip @Provider.Service.ServiceToken, + testRoundTrip @(Provider.Service.Tag.QueryAllTags 3 5), + testRoundTrip @(Provider.Service.Tag.QueryAnyTags 3 5), testRoundTrip @Provider.Service.Tag.ServiceTag, testRoundTrip @Push.V2.Token.Token, testRoundTrip @Team.Feature.TeamFeatureName, @@ -73,11 +75,10 @@ tests = testRoundTrip @User.InvitationCode, testRoundTrip @User.Password.PasswordResetCode, testRoundTrip @User.Password.PasswordResetKey, - testRoundTrip @User.Profile.Name, - testRoundTrip @(Provider.Service.Tag.QueryAllTags 3 5), - testRoundTrip @(Provider.Service.Tag.QueryAnyTags 3 5) + testRoundTrip @User.Profile.ManagedBy, + testRoundTrip @User.Profile.Name -- FUTUREWORK: - -- testCase "Call.TURN.TurnUsername (doesn't have FromByteString)" ... + -- testCase "Call.Config.TurnUsername (doesn't have FromByteString)" ... -- testCase "User.Activation.ActivationTarget (doesn't have FromByteString)" ... ] diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index f084cc5bf6e..fb28ea708cc 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: b5bd8bb8589df54572262f534ebd7e422f17cc5bb76b88b1b64ef0390ffbd6ad +-- hash: 806e7ef5feb03ce2ead26b199aff52dd62cdd2126aa4930b74ae089c40b15d84 name: wire-api version: 0.1.0 @@ -23,7 +23,7 @@ library Wire.API.Asset Wire.API.Asset.V3 Wire.API.Asset.V3.Resumable - Wire.API.Call.TURN + Wire.API.Call.Config Wire.API.Connection Wire.API.Conversation Wire.API.Conversation.Bot @@ -121,7 +121,7 @@ test-suite wire-api-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - Test.Wire.API.Call.TURN + Test.Wire.API.Call.Config Test.Wire.API.Roundtrip.Aeson Test.Wire.API.Roundtrip.ByteString Test.Wire.API.Team.Member @@ -145,5 +145,6 @@ test-suite wire-api-tests , tasty-hunit , tasty-quickcheck , types-common >=0.16 + , unordered-containers , wire-api default-language: Haskell2010 diff --git a/libs/zauth/main/Main.hs b/libs/zauth/main/Main.hs index 5c58885a800..924804b2d84 100644 --- a/libs/zauth/main/Main.hs +++ b/libs/zauth/main/Main.hs @@ -179,15 +179,16 @@ options = long "data" <> metavar "STRING" <> help "token data" - toMode = readerAsk >>= \s -> case s of - "create-user" -> return CreateUser - "create-session" -> return CreateSession - "create-access" -> return CreateAccess - "create-bot" -> return CreateBot - "create-provider" -> return CreateProvider - "verify-user" -> return VerifyUser - "verify-access" -> return VerifyAccess - "verify-bot" -> return VerifyBot - "verify-provider" -> return VerifyProvider - "gen-keypair" -> return GenKeyPair - other -> readerError $ "invalid mode: " <> other + toMode = + readerAsk >>= \s -> case s of + "create-user" -> return CreateUser + "create-session" -> return CreateSession + "create-access" -> return CreateAccess + "create-bot" -> return CreateBot + "create-provider" -> return CreateProvider + "verify-user" -> return VerifyUser + "verify-access" -> return VerifyAccess + "verify-bot" -> return VerifyBot + "verify-provider" -> return VerifyProvider + "gen-keypair" -> return GenKeyPair + other -> readerError $ "invalid mode: " <> other diff --git a/libs/zauth/src/Data/ZAuth/Creation.hs b/libs/zauth/src/Data/ZAuth/Creation.hs index 389e6b38a8b..b3dc42126b0 100644 --- a/libs/zauth/src/Data/ZAuth/Creation.hs +++ b/libs/zauth/src/Data/ZAuth/Creation.hs @@ -53,7 +53,7 @@ import Data.ByteString.Conversion import Data.ByteString.Lazy (toStrict) import Data.Time.Clock.POSIX import Data.UUID -import Data.Vector ((!), Vector) +import Data.Vector (Vector, (!)) import qualified Data.Vector as Vec import Data.ZAuth.Token hiding (signature) import Imports diff --git a/libs/zauth/src/Data/ZAuth/Token.hs b/libs/zauth/src/Data/ZAuth/Token.hs index 45b1772917d..33ab055b67e 100644 --- a/libs/zauth/src/Data/ZAuth/Token.hs +++ b/libs/zauth/src/Data/ZAuth/Token.hs @@ -185,40 +185,46 @@ makeLenses ''LegalHoldUser makeLenses ''LegalHoldAccess instance FromByteString (Token Access) where - parser = takeLazyByteString >>= \b -> - case readToken A readAccessBody b of - Nothing -> fail "Invalid access token" - Just t -> return t + parser = + takeLazyByteString >>= \b -> + case readToken A readAccessBody b of + Nothing -> fail "Invalid access token" + Just t -> return t instance FromByteString (Token User) where - parser = takeLazyByteString >>= \b -> - case readToken U readUserBody b of - Nothing -> fail "Invalid user token" - Just t -> return t + parser = + takeLazyByteString >>= \b -> + case readToken U readUserBody b of + Nothing -> fail "Invalid user token" + Just t -> return t instance FromByteString (Token Bot) where - parser = takeLazyByteString >>= \b -> - case readToken B readBotBody b of - Nothing -> fail "Invalid bot token" - Just t -> return t + parser = + takeLazyByteString >>= \b -> + case readToken B readBotBody b of + Nothing -> fail "Invalid bot token" + Just t -> return t instance FromByteString (Token Provider) where - parser = takeLazyByteString >>= \b -> - case readToken P readProviderBody b of - Nothing -> fail "Invalid provider token" - Just t -> return t + parser = + takeLazyByteString >>= \b -> + case readToken P readProviderBody b of + Nothing -> fail "Invalid provider token" + Just t -> return t instance FromByteString (Token LegalHoldAccess) where - parser = takeLazyByteString >>= \b -> - case readToken LA readLegalHoldAccessBody b of - Nothing -> fail "Invalid access token" - Just t -> return t + parser = + takeLazyByteString >>= \b -> + case readToken LA readLegalHoldAccessBody b of + Nothing -> fail "Invalid access token" + Just t -> return t instance FromByteString (Token LegalHoldUser) where - parser = takeLazyByteString >>= \b -> - case readToken LU readLegalHoldUserBody b of - Nothing -> fail "Invalid user token" - Just t -> return t + parser = + takeLazyByteString >>= \b -> + case readToken LU readLegalHoldUserBody b of + Nothing -> fail "Invalid user token" + Just t -> return t instance ToByteString a => ToByteString (Token a) where builder = writeToken diff --git a/libs/zauth/src/Data/ZAuth/Validation.hs b/libs/zauth/src/Data/ZAuth/Validation.hs index ae2812ba5e4..6f514d10eca 100644 --- a/libs/zauth/src/Data/ZAuth/Validation.hs +++ b/libs/zauth/src/Data/ZAuth/Validation.hs @@ -37,7 +37,7 @@ import Control.Monad.Except import qualified Data.ByteString as Strict import Data.ByteString.Conversion import Data.Time.Clock.POSIX -import Data.Vector ((!), Vector) +import Data.Vector (Vector, (!)) import qualified Data.Vector as Vec import Data.ZAuth.Token import Imports diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 9fe0cc99d48..5ec599d4eca 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -1,10 +1,10 @@ -cabal-version: 2.0 +cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: f150b19d31eda4f6f32ad2782dccc7deae05b01ffd46558fe1f403ba49500307 +-- hash: 0efba75abb2e931761d20c36d7c690eb2cf9711711c4b002dfd2cd5ff7bd60ee name: brig version: 1.35.0 @@ -36,6 +36,9 @@ library Brig.AWS.SesNotification Brig.AWS.Types Brig.Budget + Brig.Calling + Brig.Calling.API + Brig.Calling.Internal Brig.Code Brig.Data.Activation Brig.Data.Blacklist @@ -50,6 +53,10 @@ library Brig.Data.User Brig.Data.UserKey Brig.Email + Brig.Index.Eval + Brig.Index.Migrations + Brig.Index.Migrations.Types + Brig.Index.Options Brig.InternalEvent.Process Brig.InternalEvent.Types Brig.IO.Intra @@ -59,6 +66,7 @@ library Brig.Options Brig.Password Brig.Phone + Brig.PolyLog Brig.Provider.API Brig.Provider.DB Brig.Provider.Email @@ -76,8 +84,6 @@ library Brig.Team.Template Brig.Team.Util Brig.Template - Brig.TURN - Brig.TURN.API Brig.Unique Brig.User.API.Auth Brig.User.API.Search @@ -137,6 +143,8 @@ library , data-default >=0.5 , data-timeout >=0.3 , directory >=1.2 + , dns + , dns-util , either >=4.3 , enclosed-exceptions >=1.0 , errors >=1.4 @@ -172,6 +180,7 @@ library , network-uri >=2.6 , optparse-applicative >=0.11 , pem >=0.2 + , polysemy , prometheus-client , proto-lens >=0.1 , random-shuffle >=0.0.3 @@ -222,40 +231,6 @@ library , zauth >=0.10.3 default-language: Haskell2010 -library brig-index-lib - exposed-modules: - Brig.Index.Eval - Brig.Index.Migrations - Brig.Index.Migrations.Types - Brig.Index.Options - Main - other-modules: - Paths_brig - hs-source-dirs: - index/src - default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields - build-depends: - aeson - , base - , bloodhound - , brig - , cassandra-util >=0.12 - , exceptions - , http-client - , imports - , lens - , metrics-core - , mtl - , optparse-applicative >=0.13 - , retry - , text - , time - , tinylog - , types-common - , uri-bytestring - default-language: Haskell2010 - executable brig main-is: src/Main.hs other-modules: @@ -280,7 +255,7 @@ executable brig-index ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields -threaded -with-rtsopts=-N build-depends: base - , brig-index-lib + , brig , imports , optparse-applicative , tinylog @@ -289,6 +264,7 @@ executable brig-index executable brig-integration main-is: Main.hs other-modules: + API.Calling API.IdMapping API.Metrics API.Provider @@ -298,7 +274,6 @@ executable brig-integration API.Settings API.Team API.Team.Util - API.TURN API.User API.User.Account API.User.Auth @@ -326,7 +301,6 @@ executable brig-integration , bilge , bloodhound , brig - , brig-index-lib , brig-types , bytestring >=0.9 , bytestring-conversion @@ -462,6 +436,8 @@ test-suite brig-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: + Test.Brig.Calling + Test.Brig.Calling.Internal Test.Brig.User.Search.Index.Types Paths_brig hs-source-dirs: @@ -474,9 +450,17 @@ test-suite brig-tests , bloodhound , brig , brig-types + , dns + , dns-util , imports + , polysemy + , retry , tasty , tasty-hunit + , tinylog , types-common + , unliftio + , uri-bytestring , uuid + , wire-api default-language: Haskell2010 diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 53aee10de4d..8e6e3f711be 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -40,6 +40,8 @@ library: - data-default >=0.5 - data-timeout >=0.3 - directory >=1.2 + - dns + - dns-util - either >=4.3 - enclosed-exceptions >=1.0 - errors >=1.4 @@ -80,6 +82,7 @@ library: - network-uri >=2.6 - optparse-applicative >=0.11 - pem >=0.2 + - polysemy - proto-lens >=0.1 - prometheus-client - resourcet >=1.1 @@ -128,28 +131,6 @@ library: - wire-api - yaml >=0.8.22 - zauth >=0.10.3 -internal-libraries: - brig-index-lib: - source-dirs: index/src - dependencies: - - aeson - - base - - bloodhound - - brig - - cassandra-util >=0.12 - - exceptions - - http-client - - imports - - lens - - metrics-core - - mtl - - optparse-applicative >=0.13 - - retry - - text - - time - - tinylog - - types-common - - uri-bytestring tests: brig-tests: main: Main.hs @@ -163,11 +144,19 @@ tests: - bloodhound - brig - brig-types + - dns + - dns-util + - polysemy - imports + - retry - tasty - tasty-hunit + - tinylog - types-common + - unliftio + - uri-bytestring - uuid + - wire-api executables: brig-schema: main: Main.hs @@ -194,7 +183,6 @@ executables: - bloodhound - base - brig - - brig-index-lib - brig-types - bytestring >=0.9 - bytestring-conversion @@ -260,7 +248,7 @@ executables: - -with-rtsopts=-N dependencies: - base - - brig-index-lib + - brig - imports - optparse-applicative - tinylog diff --git a/services/brig/schema/src/V42.hs b/services/brig/schema/src/V42.hs index 8c6eaa9d1c3..38fcd0c3b9d 100644 --- a/services/brig/schema/src/V42.hs +++ b/services/brig/schema/src/V42.hs @@ -26,9 +26,9 @@ import Text.RawString.QQ migration :: Migration migration = - Migration 42 "Remove user.tracking_id" - $ void - $ schema' - [r| + Migration 42 "Remove user.tracking_id" $ + void $ + schema' + [r| alter columnfamily user drop tracking_id; |] diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 21910465d04..795a3741b6a 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -57,8 +57,8 @@ import Control.Lens (view) import Data.Bitraversable (bitraverse) import Data.ByteString.Conversion import Data.IP (IP) -import qualified Data.Id as Id import Data.Id (ClientId, ConnId, UserId, makeIdOpaque, makeMappedIdOpaque) +import qualified Data.Id as Id import Data.IdMapping import Data.List.NonEmpty (nonEmpty) import Data.List.Split (chunksOf) @@ -108,10 +108,10 @@ addClient u con ip new = do Intra.newClient u (clientId clt) Intra.onClientEvent u con (ClientAdded u clt) when (clientType clt == LegalHoldClientType) $ Intra.onUserEvent u con (UserLegalHoldEnabled u) - when (count > 1) - $ for_ (userEmail usr) - $ \email -> - sendNewClientEmail (userDisplayName usr) email clt (userLocale usr) + when (count > 1) $ + for_ (userEmail usr) $ + \email -> + sendNewClientEmail (userDisplayName usr) email clt (userLocale usr) return clt where clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index eff56ce4243..f6032e6374b 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -77,16 +77,16 @@ createConnectionToLocalUser :: ConnId -> ExceptT ConnectionError AppIO ConnectionResult createConnectionToLocalUser self crUser ConnectionRequest {crName, crMessage} conn = do - when (self == crUser) - $ throwE - $ InvalidUser (makeIdOpaque crUser) + when (self == crUser) $ + throwE $ + InvalidUser (makeIdOpaque crUser) selfActive <- lift $ Data.isActivated self unless selfActive $ throwE ConnectNoIdentity otherActive <- lift $ Data.isActivated crUser - unless otherActive - $ throwE - $ InvalidUser (makeIdOpaque crUser) + unless otherActive $ + throwE $ + InvalidUser (makeIdOpaque crUser) -- Users belonging to the same team are always treated as connected, so creating a -- connection between them is useless. {#RefConnectionTeam} sameTeam <- lift $ belongSameTeam @@ -209,7 +209,7 @@ updateConnection self other newStatus conn = do (old, _, new) | old == new -> return Nothing _ -> throwE $ InvalidTransition self newStatus - lift $ for_ s2o' $ \c -> + lift . for_ s2o' $ \c -> let e2s = ConnectionUpdated c (Just $ ucStatus s2o) Nothing in Intra.onConnectionEvent self conn e2s return s2o' @@ -219,12 +219,12 @@ updateConnection self other newStatus conn = do Log.info $ Log.connection self (ucTo s2o) . msg (val "Accepting connection") - cnv <- lift $ for (ucConvId s2o) $ Intra.acceptConnectConv self conn + cnv <- lift . for (ucConvId s2o) $ Intra.acceptConnectConv self conn -- Note: The check for @Pending@ accounts for situations in which both -- sides are pending, which can occur due to rare race conditions -- when sending mutual connection requests, combined with untimely -- crashes. - when (ucStatus o2s `elem` [Sent, Pending]) $ lift $ do + when (ucStatus o2s `elem` [Sent, Pending]) . lift $ do o2s' <- if (cnvType <$> cnv) /= Just ConnectConv then Data.updateConnection o2s Accepted @@ -244,8 +244,8 @@ updateConnection self other newStatus conn = do Log.info $ Log.connection self (ucTo s2o) . msg (val "Unblocking connection") - cnv <- lift $ for (ucConvId s2o) $ Intra.unblockConv (ucFrom s2o) conn - when (ucStatus o2s == Sent && new == Accepted) $ lift $ do + cnv <- lift . for (ucConvId s2o) $ Intra.unblockConv (ucFrom s2o) conn + when (ucStatus o2s == Sent && new == Accepted) . lift $ do o2s' <- if (cnvType <$> cnv) /= Just ConnectConv then Data.updateConnection o2s Accepted @@ -257,7 +257,7 @@ updateConnection self other newStatus conn = do Log.info $ Log.connection self (ucTo s2o) . msg (val "Cancelling connection") - lift $ for_ (ucConvId s2o) $ Intra.blockConv (ucFrom s2o) conn + lift . for_ (ucConvId s2o) $ Intra.blockConv (ucFrom s2o) conn o2s' <- lift $ Data.updateConnection o2s Cancelled let e2o = ConnectionUpdated o2s' (Just $ ucStatus o2s) Nothing lift $ Intra.onConnectionEvent self conn e2o @@ -321,6 +321,6 @@ checkLimit :: UserId -> ExceptT ConnectionError AppIO () checkLimit u = do n <- lift $ Data.countConnections u [Accepted, Sent] l <- setUserMaxConnections <$> view settings - unless (n < l) - $ throwE - $ TooManyConnections u + unless (n < l) $ + throwE $ + TooManyConnections u diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index f0a4baf0f95..4929008cce4 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -79,10 +79,10 @@ onError :: Logger -> Request -> Continue IO -> Error -> IO ResponseReceived onError g r k e = do Server.logError g (Just r) we Server.flushRequestBody r - k - $ setStatus (WaiError.code we) + k $ + setStatus (WaiError.code we) . appEndo (foldMap (Endo . uncurry addHeader) hs) - $ json e + $ json e where (we, hs) = case e of StdError x -> (x, []) diff --git a/services/brig/src/Brig/API/IdMapping.hs b/services/brig/src/Brig/API/IdMapping.hs index 0599799d772..915a9e1bb98 100644 --- a/services/brig/src/Brig/API/IdMapping.hs +++ b/services/brig/src/Brig/API/IdMapping.hs @@ -32,15 +32,15 @@ import Brig.App (AppIO) import qualified Brig.Data.IdMapping as Data (getIdMapping, insertIdMapping) import qualified Brig.IO.Intra.IdMapping as Intra import Control.Monad.Catch (throwM) -import qualified Data.Id as Id import Data.Id (Id (Id, toUUID), OpaqueUserId, idToText) +import qualified Data.Id as Id import Data.IdMapping (IdMapping (IdMapping, _imQualifiedId), MappedOrLocalId (Local, Mapped), hashQualifiedId) import Data.Qualified (Qualified, renderQualifiedId) import Galley.Types.IdMapping (PostIdMappingRequest (PostIdMappingRequest), PostIdMappingResponse (PostIdMappingResponse), mkPostIdMappingRequest) import Imports import Network.HTTP.Types (forbidden403, notFound404) import Network.Wai (Response) -import Network.Wai.Predicate ((.&.), (:::) ((:::)), accept) +import Network.Wai.Predicate (accept, (.&.), (:::) ((:::))) import Network.Wai.Routing (Routes, capture, continue, get, post) import Network.Wai.Utilities (JsonRequest, empty, json, jsonRequest, setStatus) import qualified System.Logger.Class as Log @@ -147,12 +147,12 @@ createIdMapping qualifiedId = do let idMapping = IdMapping mappedId qualifiedId Data.getIdMapping mappedId >>= \case Just existingMapping -> - when (_imQualifiedId existingMapping /= qualifiedId) - $ Log.err - $ Log.msg @Text "Conflict when creating IdMapping" - . Log.field "mapped_id" (idToText mappedId) - . Log.field "existing_qualified_id" (renderQualifiedId qualifiedId) - . Log.field "new_qualified_id" (renderQualifiedId (_imQualifiedId existingMapping)) + when (_imQualifiedId existingMapping /= qualifiedId) $ + Log.err $ + Log.msg @Text "Conflict when creating IdMapping" + . Log.field "mapped_id" (idToText mappedId) + . Log.field "existing_qualified_id" (renderQualifiedId qualifiedId) + . Log.field "new_qualified_id" (renderQualifiedId (_imQualifiedId existingMapping)) Nothing -> do Data.insertIdMapping idMapping Intra.createIdMappingInGalley (mkPostIdMappingRequest qualifiedId) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index f4fc89853a3..9fe36ce232a 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -89,7 +89,7 @@ sitemap = do accept "application" "json" .&. jsonRequest @NewUser - -- internal email activation (used in tests and in spar for validating emails obtains as + -- internal email activation (used in tests and in spar for validating emails obtained as -- SAML user identifiers). if the validate query parameter is false or missing, only set -- the activation timeout, but do not send an email, and do not do anything about activating -- the email. @@ -257,12 +257,12 @@ autoConnectH (_ ::: uid ::: conn ::: req) = do autoConnect :: UserId -> Maybe ConnId -> UserSet -> Handler [UserConnection] autoConnect uid conn (UserSet to) = do let num = Set.size to - when (num < 1) - $ throwStd - $ badRequest "No users given for auto-connect." - when (num > 25) - $ throwStd - $ badRequest "Too many users given for auto-connect (> 25)." + when (num < 1) $ + throwStd $ + badRequest "No users given for auto-connect." + when (num > 25) $ + throwStd $ + badRequest "Too many users given for auto-connect (> 25)." API.autoConnect uid to conn !>> connError createUserNoVerifyH :: JSON ::: JsonRequest NewUser -> Handler Response diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 071c441b831..ef9158eff73 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -31,11 +31,12 @@ import Brig.API.IdMapping (resolveOpaqueUserId) import qualified Brig.API.Properties as API import Brig.API.Types import qualified Brig.API.User as API +import qualified Brig.API.Util as API import Brig.App +import qualified Brig.Calling.API as Calling import qualified Brig.Data.User as Data import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Provider.API as Provider -import qualified Brig.TURN.API as TURN import qualified Brig.Team.API as Team import qualified Brig.Team.Email as Team import Brig.Types.Intra (AccountStatus (Ephemeral), UserAccount (UserAccount, accountUser)) @@ -45,7 +46,7 @@ import qualified Brig.User.Auth.Cookie as Auth import Brig.User.Email import Brig.User.Phone import Control.Error hiding (bool) -import Control.Lens ((^.), view) +import Control.Lens (view, (^.)) import Control.Monad.Catch (throwM) import Data.Aeson hiding (json) import Data.ByteString.Conversion @@ -55,7 +56,7 @@ import Data.Handle (Handle, parseHandle) import Data.Id as Id import Data.IdMapping (MappedOrLocalId (Local)) import qualified Data.Map.Strict as Map -import Data.Misc ((<$$>), IpAddr (..)) +import Data.Misc (IpAddr (..), (<$$>)) import Data.Qualified (OptionallyQualified, eitherQualifiedOrNot) import Data.Range import qualified Data.Swagger.Build.Api as Doc @@ -781,7 +782,7 @@ sitemap o = do Auth.routesPublic Search.routesPublic Team.routesPublic - TURN.routesPublic + Calling.routesPublic apiDocs :: Opts -> Routes Doc.ApiBuilder Handler () apiDocs o = do @@ -1136,31 +1137,14 @@ changeLocaleH (u ::: conn ::: req) = do lift $ API.changeLocale u conn l return empty -data CheckHandleResp - = CheckHandleInvalid - | CheckHandleFound - | CheckHandleNotFound - +-- | (zusr are is ignored by this handler, ie. checking handles is allowed as long as you have +-- *any* account.) checkHandleH :: UserId ::: Text -> Handler Response -checkHandleH (uid ::: hndl) = do - checkHandle uid hndl >>= \case - CheckHandleInvalid -> throwE (StdError invalidHandle) - CheckHandleFound -> pure $ setStatus status200 empty - CheckHandleNotFound -> pure $ setStatus status404 empty - -checkHandle :: UserId -> Text -> Handler CheckHandleResp -checkHandle _ uhandle = do - handle <- validateHandle uhandle - owner <- lift $ API.lookupHandle handle - if | isJust owner -> - -- Handle is taken (=> getHandleInfo will return 200) - return CheckHandleFound - | API.isBlacklistedHandle handle -> - -- Handle is free but cannot be taken - return CheckHandleInvalid - | otherwise -> - -- Handle is free and can be taken - return CheckHandleNotFound +checkHandleH (_uid ::: hndl) = do + API.checkHandle hndl >>= \case + API.CheckHandleInvalid -> throwE (StdError invalidHandle) + API.CheckHandleFound -> pure $ setStatus status200 empty + API.CheckHandleNotFound -> pure $ setStatus status404 empty checkHandlesH :: JSON ::: UserId ::: JsonRequest Public.CheckHandles -> Handler Response checkHandlesH (_ ::: _ ::: req) = do @@ -1192,7 +1176,7 @@ changeHandleH (u ::: conn ::: req) = do changeHandle :: UserId -> ConnId -> Public.HandleUpdate -> Handler () changeHandle u conn (Public.HandleUpdate h) = do - handle <- validateHandle h + handle <- API.validateHandle h API.changeHandle u conn handle !>> changeHandleError beginPasswordResetH :: JSON ::: JsonRequest Public.NewPasswordReset -> Handler Response @@ -1356,9 +1340,6 @@ deprecatedCompletePasswordResetH (_ ::: k ::: req) = do -- Utilities -validateHandle :: Text -> Handler Handle -validateHandle = maybe (throwE (StdError invalidHandle)) return . parseHandle - ifNothing :: Utilities.Error -> Maybe a -> Handler a ifNothing e = maybe (throwStd e) return diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index e30bd700644..5c0fa7b9964 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -28,6 +28,8 @@ module Brig.API.User changeEmail, changePhone, changeHandle, + CheckHandleResp (..), + checkHandle, lookupHandle, changeManagedBy, changeAccountStatus, @@ -36,7 +38,6 @@ module Brig.API.User Data.lookupAccount, Data.lookupStatus, lookupAccountsByIdentity, - lookupSelfProfile, lookupProfile, lookupProfiles, Data.lookupName, @@ -84,7 +85,9 @@ module Brig.API.User where import qualified Brig.API.Error as Error +import qualified Brig.API.Handler as API (Handler) import Brig.API.Types +import Brig.API.Util (fetchUserIdentity, validateHandle) import Brig.App import qualified Brig.Code as Code import Brig.Data.Activation (ActivationEvent (..)) @@ -119,7 +122,7 @@ import qualified Brig.User.Search.Index as Index import Control.Arrow ((&&&)) import Control.Concurrent.Async (mapConcurrently, mapConcurrently_) import Control.Error -import Control.Lens ((^.), view) +import Control.Lens (view, (^.)) import Control.Monad.Catch import Data.ByteString.Conversion import qualified Data.Currency as Currency @@ -129,8 +132,7 @@ import Data.IdMapping (MappedOrLocalId, partitionMappedOrLocalIds) import Data.Json.Util import Data.List1 (List1) import qualified Data.Map.Strict as Map -import Data.Misc ((<$$>)) -import Data.Misc (PlainTextPassword (..)) +import Data.Misc (PlainTextPassword (..), (<$$>)) import Data.Time.Clock (diffUTCTime) import Data.UUID.V4 (nextRandom) import qualified Galley.Types.Teams as Team @@ -177,14 +179,14 @@ createUser new@NewUser {..} = do activatedTeam <- lift $ do Data.insertAccount account Nothing pw False Intra.createSelfConv uid - Intra.onUserEvent uid Nothing (UserCreated account) + Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) -- If newUserEmailCode is set, team gets activated _now_ else createUser fails case (tid, newTeam) of (Just t, Just nt) -> createTeam uid (isJust newUserEmailCode) (bnuTeam nt) t _ -> return Nothing (teamEmailInvited, joinedTeamInvite) <- case teamInvitation of Just (inv, invInfo) -> do - let em = Team.inIdentity inv + let em = Team.inInviteeEmail inv acceptTeamInvitation account inv invInfo (userEmailKey em) (EmailIdentity em) Team.TeamName nm <- lift $ Intra.getTeamName (Team.inTeam inv) return (True, Just $ CreateUserTeam (Team.inTeam inv) nm) @@ -229,9 +231,9 @@ createUser new@NewUser {..} = do where checkKey u k = do av <- lift $ Data.keyAvailable k u - unless av - $ throwE - $ DuplicateUserKey k + unless av $ + throwE $ + DuplicateUserKey k createTeam uid activating t tid = do created <- Intra.createTeam uid t tid return $ @@ -248,24 +250,27 @@ createUser new@NewUser {..} = do Maybe (Team.Invitation, Team.InvitationInfo), Maybe TeamId ) - handleTeam (Just (NewTeamMember i)) e = findTeamInvitation e i >>= return . \case - Just (inv, info, tid) -> (Nothing, Just (inv, info), Just tid) - Nothing -> (Nothing, Nothing, Nothing) + handleTeam (Just (NewTeamMember i)) e = + findTeamInvitation e i + >>= return . \case + Just (inv, info, tid) -> (Nothing, Just (inv, info), Just tid) + Nothing -> (Nothing, Nothing, Nothing) handleTeam (Just (NewTeamCreator t)) _ = (Just t,Nothing,) <$> (Just . Id <$> liftIO nextRandom) handleTeam (Just (NewTeamMemberSSO tid)) _ = pure (Nothing, Nothing, Just tid) handleTeam Nothing _ = return (Nothing, Nothing, Nothing) findTeamInvitation :: Maybe UserKey -> InvitationCode -> ExceptT CreateUserError AppIO (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) findTeamInvitation Nothing _ = throwE MissingIdentity - findTeamInvitation (Just e) c = lift (Team.lookupInvitationInfo c) >>= \case - Just ii -> do - inv <- lift $ Team.lookupInvitation (Team.iiTeam ii) (Team.iiInvId ii) - case (inv, Team.inIdentity <$> inv) of - (Just invite, Just em) - | e == userEmailKey em -> do - _ <- ensureMemberCanJoin (Team.iiTeam ii) - return $ Just (invite, ii, Team.iiTeam ii) - _ -> throwE InvalidInvitationCode - Nothing -> throwE InvalidInvitationCode + findTeamInvitation (Just e) c = + lift (Team.lookupInvitationInfo c) >>= \case + Just ii -> do + inv <- lift $ Team.lookupInvitation (Team.iiTeam ii) (Team.iiInvId ii) + case (inv, Team.inInviteeEmail <$> inv) of + (Just invite, Just em) + | e == userEmailKey em -> do + _ <- ensureMemberCanJoin (Team.iiTeam ii) + return $ Just (invite, ii, Team.iiTeam ii) + _ -> throwE InvalidInvitationCode + Nothing -> throwE InvalidInvitationCode ensureMemberCanJoin :: TeamId -> ExceptT CreateUserError AppIO () ensureMemberCanJoin tid = do maxSize <- fromIntegral . setMaxTeamSize <$> view settings @@ -281,9 +286,9 @@ createUser new@NewUser {..} = do acceptTeamInvitation account inv ii uk ident = do let uid = userId (accountUser account) ok <- lift $ Data.claimKey uk uid - unless ok - $ throwE - $ DuplicateUserKey uk + unless ok $ + throwE $ + DuplicateUserKey uk let minvmeta :: (Maybe (UserId, UTCTimeMillis), Team.Role) minvmeta = ((,inCreatedAt inv) <$> inCreatedBy inv, Team.inRole inv) added <- lift $ Intra.addTeamMember uid (Team.iiTeam ii) minvmeta @@ -316,28 +321,19 @@ createUser new@NewUser {..} = do -- | docs/reference/user/registration.md {#RefRestrictRegistration}. checkRestrictedUserCreation :: NewUser -> ExceptT CreateUserError AppIO () checkRestrictedUserCreation new = do - let nTeam = newUserTeam new - nExpires = newUserExpiresIn new - restrictPlease <- lift . asks $ fromMaybe False . setRestrictUserCreation . view settings when ( restrictPlease - && not (isTeamMember nTeam) - && not (isEphemeral nExpires) + && not (isNewUserTeamMember new) + && not (isNewUserEphemeral new) ) $ throwE UserCreationRestricted - where - isTeamMember (Just (NewTeamMember _)) = True - isTeamMember (Just (NewTeamMemberSSO _)) = True - isTeamMember _ = False - isEphemeral (Just _) = True - isEphemeral _ = False ------------------------------------------------------------------------------- -- Update Profile -- FUTUREWORK: this and other functions should refuse to modify a ManagedByScim user. See --- {#SparBrainDump} +-- {#SparBrainDump} https://github.com/zinfra/backend-issues/issues/1632 updateUser :: UserId -> ConnId -> UserUpdate -> AppIO () updateUser uid conn uu = do @@ -375,11 +371,38 @@ changeHandle uid conn hdl = do claim u = do unless (isJust (userIdentity u)) $ throwE ChangeHandleNoIdentity - claimed <- lift $ claimHandle u hdl + claimed <- lift $ claimHandle (userId u) (userHandle u) hdl unless claimed $ throwE ChangeHandleExists lift $ Intra.onUserEvent uid (Just conn) (handleUpdated uid hdl) +-------------------------------------------------------------------------------- +-- Check Handle + +data CheckHandleResp + = CheckHandleInvalid + | CheckHandleFound + | CheckHandleNotFound + +checkHandle :: Text -> API.Handler CheckHandleResp +checkHandle uhandle = do + xhandle <- validateHandle uhandle + owner <- lift $ lookupHandle xhandle + if + | isJust owner -> + -- Handle is taken (=> getHandleInfo will return 200) + return CheckHandleFound + | isBlacklistedHandle xhandle -> + -- Handle is free but cannot be taken + -- + -- FUTUREWORK: i wonder if this is correct? isn't this the error for malformed + -- handles? shouldn't we throw not-found here? or should there be a fourth case + -- 'CheckHandleBlacklisted'? + return CheckHandleInvalid + | otherwise -> + -- Handle is free and can be taken + return CheckHandleNotFound + -------------------------------------------------------------------------------- -- Check Handles @@ -432,9 +455,9 @@ changeEmail u email = do when blacklisted $ throwE (ChangeBlacklistedEmail email) available <- lift $ Data.keyAvailable ek (Just u) - unless available - $ throwE - $ EmailExists email + unless available $ + throwE $ + EmailExists email usr <- maybe (throwM $ UserProfileNotFound u) return =<< lift (Data.lookupUser u) case join (emailIdentity <$> userIdentity usr) of -- The user already has an email address and the new one is exactly the same @@ -456,9 +479,9 @@ changePhone u phone = do =<< lift (validatePhone phone) let pk = userPhoneKey ph available <- lift $ Data.keyAvailable pk (Just u) - unless available - $ throwE - $ PhoneExists phone + unless available $ + throwE $ + PhoneExists phone timeout <- setActivationTimeout <$> view settings act <- lift $ Data.newActivation pk timeout (Just u) return (act, ph) @@ -504,15 +527,16 @@ revokeIdentity key = do mu <- Data.lookupKey uk case mu of Nothing -> return () - Just u -> fetchUserIdentity u >>= \case - Just (FullIdentity _ _) -> revokeKey u uk - Just (EmailIdentity e) | Left e == key -> do - revokeKey u uk - Data.deactivateUser u - Just (PhoneIdentity p) | Right p == key -> do - revokeKey u uk - Data.deactivateUser u - _ -> return () + Just u -> + fetchUserIdentity u >>= \case + Just (FullIdentity _ _) -> revokeKey u uk + Just (EmailIdentity e) | Left e == key -> do + revokeKey u uk + Data.deactivateUser u + Just (PhoneIdentity p) | Right p == key -> do + revokeKey u uk + Data.deactivateUser u + _ -> return () where revokeKey u uk = do deleteKey uk @@ -545,9 +569,10 @@ changeAccountStatus usrs status = do Intra.onUserEvent u Nothing (ev u) suspendAccount :: HasCallStack => List1 UserId -> AppIO () -suspendAccount usrs = runExceptT (changeAccountStatus usrs Suspended) >>= \case - Right _ -> pure () - Left InvalidAccountStatus -> error "impossible." +suspendAccount usrs = + runExceptT (changeAccountStatus usrs Suspended) >>= \case + Right _ -> pure () + Left InvalidAccountStatus -> error "impossible." ------------------------------------------------------------------------------- -- Activation @@ -580,9 +605,9 @@ activateWithCurrency tgt code usr cur = do Nothing -> return ActivationPass Just e -> do (uid, ident, first) <- lift $ onActivated e - when first - $ lift - $ activateTeam uid + when first $ + lift $ + activateTeam uid return $ ActivationSuccess ident first where activateTeam uid = do @@ -599,7 +624,7 @@ onActivated (AccountActivated account) = do let uid = userId (accountUser account) Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.onActivated") Log.info $ field "user" (toByteString uid) . msg (val "User activated") - Intra.onUserEvent uid Nothing $ UserActivated account + Intra.onUserEvent uid Nothing $ UserActivated (accountUser account) return (uid, userIdentity (accountUser account), True) onActivated (EmailActivated uid email) = do Intra.onUserEvent uid Nothing (emailUpdated uid email) @@ -618,9 +643,9 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of (return . userEmailKey) (validateEmail email) exists <- lift $ isJust <$> Data.lookupKey ek - when exists - $ throwE - $ UserKeyInUse ek + when exists $ + throwE $ + UserKeyInUse ek blacklisted <- lift $ Blacklist.exists ek when blacklisted $ throwE (ActivationBlacklistedUserKey ek) @@ -638,9 +663,9 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of =<< lift (validatePhone phone) let pk = userPhoneKey canonical exists <- lift $ isJust <$> Data.lookupKey pk - when exists - $ throwE - $ UserKeyInUse pk + when exists $ + throwE $ + UserKeyInUse pk blacklisted <- lift $ Blacklist.exists pk when blacklisted $ throwE (ActivationBlacklistedUserKey pk) @@ -874,7 +899,7 @@ deleteAccount account@(accountUser -> user) = do -- Free unique keys for_ (userEmail user) $ deleteKey . userEmailKey for_ (userPhone user) $ deleteKey . userPhoneKey - for_ (userHandle user) $ freeHandle user + for_ (userHandle user) $ freeHandle (userId user) -- Wipe data Data.clearProperties uid tombstone <- mkTombstone @@ -981,7 +1006,7 @@ lookupProfilesOfLocalUsers self others = do where toMap :: [ConnectionStatus] -> Map UserId Relation toMap = Map.fromList . map (csFrom &&& csStatus) - -- + getSelfInfo :: AppIO (Maybe (TeamId, Team.TeamMember)) getSelfInfo = do -- FUTUREWORK: it is an internal error for the two lookups (for 'User' and 'TeamMember') @@ -991,7 +1016,7 @@ lookupProfilesOfLocalUsers self others = do case userTeam =<< mUser of Nothing -> pure Nothing Just tid -> (tid,) <$$> Intra.getTeamMember self tid - -- + toProfile :: EmailVisibility' -> Map UserId Relation -> User -> UserProfile toProfile emailVisibility'' css u = let cs = Map.lookup (userId u) css @@ -1025,12 +1050,6 @@ getEmailForProfile profileOwner (EmailVisibleIfOnSameTeam' (Just (viewerTeamId, getEmailForProfile _ (EmailVisibleIfOnSameTeam' Nothing) = Nothing getEmailForProfile _ EmailVisibleToSelf' = Nothing --- | Obtain a profile for a user as he can see himself. -lookupSelfProfile :: UserId -> AppIO (Maybe SelfProfile) -lookupSelfProfile = fmap (fmap mk) . Data.lookupAccount - where - mk a = SelfProfile (accountUser a) - -- | Find user accounts for a given identity, both activated and those -- currently pending activation. lookupAccountsByIdentity :: Either Email Phone -> AppIO [UserAccount] @@ -1063,14 +1082,3 @@ phonePrefixDelete = Blacklist.deletePrefix phonePrefixInsert :: ExcludedPrefix -> AppIO () phonePrefixInsert = Blacklist.insertPrefix - -------------------------------------------------------------------------------- --- Utilities - --- TODO: Move to a util module or similar -fetchUserIdentity :: UserId -> AppIO (Maybe UserIdentity) -fetchUserIdentity uid = - lookupSelfProfile uid - >>= maybe - (throwM $ UserProfileNotFound uid) - (return . userIdentity . selfUser) diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index a82fd2130bf..2831f49df5e 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -15,17 +15,30 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.API.Util where +module Brig.API.Util + ( fetchUserIdentity, + isFederationEnabled, + lookupProfilesMaybeFilterSameTeamOnly, + lookupSelfProfile, + validateHandle, + viewFederationDomain, + ) +where +import qualified Brig.API.Error as Error import Brig.API.Handler -import Brig.App (Env, settings) +import Brig.API.Types +import Brig.App (AppIO, Env, settings) import qualified Brig.Data.User as Data import Brig.Options (enableFederationWithDomain) import Brig.Types +import Brig.Types.Intra (accountUser) import Control.Lens (view) -import Control.Monad +import Control.Monad.Catch (throwM) +import Control.Monad.Trans.Except (throwE) import Data.Domain (Domain) -import Data.Id as Id +import Data.Handle (Handle, parseHandle) +import Data.Id import Data.Maybe import Imports @@ -36,6 +49,22 @@ lookupProfilesMaybeFilterSameTeamOnly self us = do Just team -> filter (\x -> profileTeam x == Just team) us Nothing -> us +fetchUserIdentity :: UserId -> AppIO (Maybe UserIdentity) +fetchUserIdentity uid = + lookupSelfProfile uid + >>= maybe + (throwM $ UserProfileNotFound uid) + (return . userIdentity . selfUser) + +-- | Obtain a profile for a user as he can see himself. +lookupSelfProfile :: UserId -> AppIO (Maybe SelfProfile) +lookupSelfProfile = fmap (fmap mk) . Data.lookupAccount + where + mk a = SelfProfile (accountUser a) + +validateHandle :: Text -> Handler Handle +validateHandle = maybe (throwE (Error.StdError Error.invalidHandle)) return . parseHandle + -------------------------------------------------------------------------------- -- Federation diff --git a/services/brig/src/Brig/AWS.hs b/services/brig/src/Brig/AWS.hs index 09af84e1a5d..745ed6408d7 100644 --- a/services/brig/src/Brig/AWS.hs +++ b/services/brig/src/Brig/AWS.hs @@ -102,7 +102,7 @@ newtype Amazon a = Amazon ) instance MonadUnliftIO Amazon where - askUnliftIO = Amazon $ ReaderT $ \r -> + askUnliftIO = Amazon . ReaderT $ \r -> withUnliftIO $ \u -> return (UnliftIO (unliftIO u . flip runReaderT r . unAmazon)) @@ -173,7 +173,7 @@ instance Exception Error -- SQS listen :: (FromJSON a, Show a) => Int -> Text -> (a -> IO ()) -> Amazon () -listen throttleMillis url callback = forever $ handleAny unexpectedError $ do +listen throttleMillis url callback = forever . handleAny unexpectedError $ do msgs <- view rmrsMessages <$> send receive void $ mapConcurrently onMessage msgs when (null msgs) $ @@ -182,7 +182,7 @@ listen throttleMillis url callback = forever $ handleAny unexpectedError $ do receive = SQS.receiveMessage url & set SQS.rmWaitTimeSeconds (Just 20) - . set SQS.rmMaxNumberOfMessages (Just 10) + . set SQS.rmMaxNumberOfMessages (Just 10) onMessage m = case decodeStrict =<< Text.encodeUtf8 <$> m ^. mBody of Nothing -> err $ msg ("Failed to parse SQS event: " ++ show m) @@ -252,9 +252,9 @@ execCatch :: a -> m (Either AWS.Error (Rs a)) execCatch e cmd = - runResourceT . AWST.runAWST e - $ AWST.trying AWS._Error - $ AWST.send cmd + runResourceT . AWST.runAWST e $ + AWST.trying AWS._Error $ + AWST.send cmd exec :: (AWSRequest a, AWS.HasEnv r, MonadUnliftIO m, MonadCatch m, MonadThrow m, MonadIO m) => diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index a711ac4f39a..1daf11a86c6 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -51,6 +51,7 @@ module Brig.App applog, turnEnv, turnEnvV2, + sftEnv, internalEvents, -- * App Monad @@ -67,13 +68,13 @@ import Bilge (Manager, MonadHttp, RequestId (..), newManager, withResponse) import qualified Bilge as RPC import Bilge.RPC (HasRequestId (..)) import qualified Brig.AWS as AWS +import qualified Brig.Calling as Calling import Brig.Options (Opts, Settings) import qualified Brig.Options as Opt import Brig.Provider.Template import qualified Brig.Queue.Stomp as Stomp import Brig.Queue.Types (Queue (..)) import qualified Brig.SMTP as SMTP -import qualified Brig.TURN as TURN import Brig.Team.Template import Brig.Template (Localised, TemplateBranding, forLocale, genTemplateBranding) import Brig.Types (Locale (..), TurnURI) @@ -88,7 +89,7 @@ import qualified Cassandra.Settings as Cas import Control.AutoUpdate import Control.Error import Control.Exception.Enclosed (handleAny) -import Control.Lens hiding ((.=), index) +import Control.Lens hiding (index, (.=)) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Trans.Resource import Data.ByteString.Conversion @@ -155,8 +156,9 @@ data Env = Env _twilioCreds :: Twilio.Credentials, _geoDb :: Maybe (IORef GeoIp.GeoDB), _fsWatcher :: FS.WatchManager, - _turnEnv :: IORef TURN.Env, - _turnEnvV2 :: IORef TURN.Env, + _turnEnv :: IORef Calling.Env, + _turnEnvV2 :: IORef Calling.Env, + _sftEnv :: Maybe Calling.SFTEnv, _currentTime :: IO UTCTime, _zauthEnv :: ZAuth.Env, _digestSHA256 :: Digest, @@ -202,6 +204,7 @@ newEnv o = do eventsQueue <- case Opt.internalEventsQueue (Opt.internalEvents o) of StompQueue q -> pure (StompQueue q) SqsQueue q -> SqsQueue <$> AWS.getQueueUrl (aws ^. AWS.amazonkaEnv) q + mSFTEnv <- mapM Calling.mkSFTEnv $ Opt.sft o return $! Env { _cargohold = mkEndpoint $ Opt.cargohold o, @@ -227,6 +230,7 @@ newEnv o = do _geoDb = g, _turnEnv = turn, _turnEnvV2 = turnV2, + _sftEnv = mSFTEnv, _fsWatcher = w, _currentTime = clock, _zauthEnv = zau, @@ -264,7 +268,7 @@ geoSetup lgr w (Just db) = do startWatching w path (replaceGeoDb lgr geodb) return $ Just geodb -turnSetup :: Logger -> FS.WatchManager -> Digest -> Opt.TurnOpts -> IO (IORef TURN.Env, IORef TURN.Env) +turnSetup :: Logger -> FS.WatchManager -> Digest -> Opt.TurnOpts -> IO (IORef Calling.Env, IORef Calling.Env) turnSetup lgr w dig o = do secret <- Text.encodeUtf8 . Text.strip <$> Text.readFile (Opt.secret o) cfg <- setupTurn secret (Opt.servers o) @@ -274,7 +278,7 @@ turnSetup lgr w dig o = do setupTurn secret cfg = do path <- canonicalizePath cfg servers <- fromMaybe (error "Empty TURN list, check turn file!") <$> readTurnList path - te <- newIORef =<< TURN.newEnv dig servers (Opt.tokenTTL o) (Opt.configTTL o) secret + te <- newIORef =<< Calling.newEnv dig servers (Opt.tokenTTL o) (Opt.configTTL o) secret startWatching w path (replaceTurnServers lgr te) return te @@ -293,14 +297,15 @@ replaceGeoDb g ref e = do GeoIp.openGeoDB (FS.eventPath e) >>= atomicWriteIORef ref Log.info g (msg $ val "New GeoIP database loaded.") -replaceTurnServers :: Logger -> IORef TURN.Env -> FS.Event -> IO () +replaceTurnServers :: Logger -> IORef Calling.Env -> FS.Event -> IO () replaceTurnServers g ref e = do let logErr x = Log.err g (msg $ val "Error loading turn servers: " +++ show x) handleAny logErr $ readTurnList (FS.eventPath e) >>= \case - Just servers -> readIORef ref >>= \old -> do - atomicWriteIORef ref (old & TURN.turnServers .~ servers) - Log.info g (msg $ val "New turn servers loaded.") + Just servers -> + readIORef ref >>= \old -> do + atomicWriteIORef ref (old & Calling.turnServers .~ servers) + Log.info g (msg $ val "New turn servers loaded.") Nothing -> Log.warn g (msg $ val "Empty or malformed turn servers list, ignoring!") initZAuth :: Opts -> IO ZAuth.Env @@ -377,8 +382,8 @@ initCassandra o g = do (Cas.initialContactsDisco "cassandra_brig") (unpack <$> Opt.discoUrl o) p <- - Cas.init - $ Cas.setLogger (Cas.mkLogger (Log.clone (Just "cassandra.brig") g)) + Cas.init $ + Cas.setLogger (Cas.mkLogger (Log.clone (Just "cassandra.brig") g)) . Cas.setContacts (NE.head c) (NE.tail c) . Cas.setPortNumber (fromIntegral ((Opt.cassandra o) ^. casEndpoint . epPort)) . Cas.setKeyspace (Keyspace ((Opt.cassandra o) ^. casKeyspace)) @@ -387,7 +392,7 @@ initCassandra o g = do . Cas.setSendTimeout 3 . Cas.setResponseTimeout 10 . Cas.setProtocolVersion Cas.V4 - $ Cas.defSettings + $ Cas.defSettings runClient p $ versionCheck schemaVersion return p @@ -470,7 +475,7 @@ instance Monad m => HasRequestId (AppT m) where instance MonadUnliftIO m => MonadUnliftIO (AppT m) where withRunInIO inner = - AppT $ ReaderT $ \r -> + AppT . ReaderT $ \r -> withRunInIO $ \run -> inner (run . flip runReaderT r . unAppT) @@ -496,13 +501,14 @@ forkAppIO u ma = do user = maybe id (field "user" . toByteString) locationOf :: (MonadIO m, MonadReader Env m) => IP -> m (Maybe Location) -locationOf ip = view geoDb >>= \case - Just g -> do - database <- liftIO $ readIORef g - return $! do - loc <- GeoIp.geoLocation =<< hush (GeoIp.findGeoData database "en" ip) - return $ location (Latitude $ GeoIp.locationLatitude loc) (Longitude $ GeoIp.locationLongitude loc) - Nothing -> return Nothing +locationOf ip = + view geoDb >>= \case + Just g -> do + database <- liftIO $ readIORef g + return $! do + loc <- GeoIp.geoLocation =<< hush (GeoIp.findGeoData database "en" ip) + return $ location (Latitude $ GeoIp.locationLatitude loc) (Longitude $ GeoIp.locationLongitude loc) + Nothing -> return Nothing readTurnList :: FilePath -> IO (Maybe (List1 TurnURI)) readTurnList = Text.readFile >=> return . fn . mapMaybe fromByteString . fmap Text.encodeUtf8 . Text.lines diff --git a/services/brig/src/Brig/Calling.hs b/services/brig/src/Brig/Calling.hs new file mode 100644 index 00000000000..61fdf80e98f --- /dev/null +++ b/services/brig/src/Brig/Calling.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE RecordWildCards #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Brig.Calling where + +import Brig.Options (SFTOptions (..), defSftDiscoveryIntervalSeconds, defSftServiceName) +import qualified Brig.Options as Opts +import Brig.PolyLog +import Brig.Types (TurnURI) +import Control.Lens +import Data.List.NonEmpty +import Data.List1 +import Data.Time.Clock (DiffTime, diffTimeToPicoseconds) +import Imports +import qualified Network.DNS as DNS +import OpenSSL.EVP.Digest (Digest) +import Polysemy +import qualified System.Logger as Log +import System.Random.MWC (GenIO, createSystemRandom) +import Wire.Network.DNS.Effect +import Wire.Network.DNS.SRV + +data SFTEnv = SFTEnv + { -- | Starts off as `NotDiscoveredYet`, once it has servers, it should never + -- go back to `NotDiscoveredYet` and continue having stale values if + -- subsequent discovries fail + sftServers :: IORef (Discovery (NonEmpty SrvEntry)), + sftDomain :: DNS.Domain, + -- | Microseconds, as expected by 'threadDelay' + sftDiscoveryInterval :: Int + } + +data Discovery a + = NotDiscoveredYet + | Discovered a + deriving (Show, Eq) + +discoveryToMaybe :: Discovery a -> Maybe a +discoveryToMaybe = \case + NotDiscoveredYet -> Nothing + Discovered x -> Just x + +discoverSFTServers :: Members [DNSLookup, PolyLog] r => DNS.Domain -> Sem r (Maybe (NonEmpty SrvEntry)) +discoverSFTServers domain = + lookupSRV domain >>= \case + SrvAvailable es -> pure $ Just es + SrvNotAvailable -> do + polyLog Log.Warn (Log.msg ("No SFT servers available" :: ByteString)) + pure Nothing + SrvResponseError e -> do + polyLog Log.Error (Log.msg ("DNS Lookup failed for SFT Discovery" :: ByteString) . Log.field "Error" (show e)) + pure Nothing + +mkSFTDomain :: SFTOptions -> DNS.Domain +mkSFTDomain SFTOptions {..} = DNS.normalize $ maybe defSftServiceName ("_" <>) sftSRVServiceName <> "._tcp." <> sftBaseDomain + +-- FUTUREWORK: Remove Embed IO from here and put threadDelay into another +-- effect. This will also make tests for this faster and deterministic +sftDiscoveryLoop :: Members [DNSLookup, PolyLog, Embed IO] r => SFTEnv -> Sem r () +sftDiscoveryLoop SFTEnv {..} = forever $ do + servers <- discoverSFTServers sftDomain + case servers of + Nothing -> pure () + Just es -> atomicWriteIORef sftServers (Discovered es) + threadDelay sftDiscoveryInterval + +mkSFTEnv :: SFTOptions -> IO SFTEnv +mkSFTEnv opts = + SFTEnv + <$> newIORef NotDiscoveredYet + <*> pure (mkSFTDomain opts) + <*> pure (diffTimeToMicroseconds (fromMaybe defSftDiscoveryIntervalSeconds (Opts.sftDiscoveryIntervalSeconds opts))) + +startSFTServiceDiscovery :: Log.Logger -> SFTEnv -> IO () +startSFTServiceDiscovery logger = + runM . runPolyLog logger . runDNSLookupDefault . sftDiscoveryLoop + +-- | >>> diffTimeToMicroseconds 1 +-- 1000000 +diffTimeToMicroseconds :: DiffTime -> Int +diffTimeToMicroseconds = fromIntegral . (`quot` 1000000) . diffTimeToPicoseconds + +-- TURN specific + +data Env = Env + { _turnServers :: List1 TurnURI, + _turnTokenTTL :: Word32, + _turnConfigTTL :: Word32, + _turnSecret :: ByteString, + _turnSHA512 :: Digest, + _turnPrng :: GenIO + } + +makeLenses ''Env + +newEnv :: Digest -> List1 TurnURI -> Word32 -> Word32 -> ByteString -> IO Env +newEnv sha512 srvs tTTL cTTL secret = Env srvs tTTL cTTL secret sha512 <$> createSystemRandom diff --git a/services/brig/src/Brig/TURN/API.hs b/services/brig/src/Brig/Calling/API.hs similarity index 72% rename from services/brig/src/Brig/TURN/API.hs rename to services/brig/src/Brig/Calling/API.hs index ec0785cc0bd..e1900114acf 100644 --- a/services/brig/src/Brig/TURN/API.hs +++ b/services/brig/src/Brig/Calling/API.hs @@ -15,23 +15,26 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.TURN.API +module Brig.Calling.API ( routesPublic, ) where import Brig.API.Handler import Brig.App -import Brig.TURN hiding (Env) -import qualified Brig.TURN as TURN +import Brig.Calling +import qualified Brig.Calling as Calling +import Brig.Calling.Internal import Control.Lens import Control.Monad.Fail (MonadFail) import Control.Monad.Random.Class import Data.ByteString.Conversion (toByteString') import Data.ByteString.Lens import Data.Id -import Data.List1 (List1) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List1 as List1 +import Data.Misc ((<$$>)) import Data.Range import qualified Data.Swagger.Build.Api as Doc import Data.Text.Ascii (AsciiBase64, encodeBase64) @@ -39,22 +42,26 @@ import Data.Text.Strict.Lens import Data.Time.Clock.POSIX (getPOSIXTime) import Imports hiding (head) import Network.Wai (Response) -import Network.Wai.Predicate hiding ((#), and, result, setStatus) +import Network.Wai.Predicate hiding (and, result, setStatus, (#)) import Network.Wai.Routing hiding (toList) import Network.Wai.Utilities hiding (code, message) import Network.Wai.Utilities.Swagger (document) import OpenSSL.EVP.Digest (Digest, hmacBS) import qualified System.Random.MWC as MWC import System.Random.Shuffle -import qualified Wire.API.Call.TURN as Public +import qualified Wire.API.Call.Config as Public +import Wire.Network.DNS.SRV (srvTarget) routesPublic :: Routes Doc.ApiBuilder Handler () routesPublic = do + -- Deprecated endpoint, but still used by old clients. + -- See https://github.com/zinfra/backend-issues/issues/1616 for context get "/calls/config" (continue getCallsConfigH) $ accept "application" "json" .&. header "Z-User" .&. header "Z-Connection" document "GET" "getCallsConfig" $ do + Doc.deprecated Doc.summary "Retrieve TURN server addresses and credentials for \ \ IP addresses, scheme `turn` and transport `udp` only " @@ -78,23 +85,24 @@ routesPublic = do Doc.response 200 "RTCConfiguration" Doc.end getCallsConfigV2H :: JSON ::: UserId ::: ConnId ::: Maybe (Range 1 10 Int) -> Handler Response -getCallsConfigV2H (_ ::: uid ::: connid ::: limit) = do +getCallsConfigV2H (_ ::: uid ::: connid ::: limit) = json <$> getCallsConfigV2 uid connid limit -- | ('UserId', 'ConnId' are required as args here to make sure this is an authenticated end-point.) getCallsConfigV2 :: UserId -> ConnId -> Maybe (Range 1 10 Int) -> Handler Public.RTCConfiguration getCallsConfigV2 _ _ limit = do env <- liftIO =<< readIORef <$> view turnEnvV2 - newConfig env limit + sftEnv' <- view sftEnv + newConfig env sftEnv' limit getCallsConfigH :: JSON ::: UserId ::: ConnId -> Handler Response -getCallsConfigH (_ ::: uid ::: connid) = do +getCallsConfigH (_ ::: uid ::: connid) = json <$> getCallsConfig uid connid getCallsConfig :: UserId -> ConnId -> Handler Public.RTCConfiguration getCallsConfig _ _ = do env <- liftIO =<< readIORef <$> view turnEnv - dropTransport <$> newConfig env Nothing + dropTransport <$> newConfig env Nothing Nothing where -- In order to avoid being backwards incompatible, remove the `transport` query param from the URIs dropTransport :: Public.RTCConfiguration -> Public.RTCConfiguration @@ -103,11 +111,11 @@ getCallsConfig _ _ = do (Public.rtcConfIceServers . traverse . Public.iceURLs . traverse . Public.turiTransport) Nothing -newConfig :: MonadIO m => TURN.Env -> Maybe (Range 1 10 Int) -> m Public.RTCConfiguration -newConfig env limit = do +newConfig :: MonadIO m => Calling.Env -> Maybe SFTEnv -> Maybe (Range 1 10 Int) -> m Public.RTCConfiguration +newConfig env mSftEnv limit = do let (sha, secret, tTTL, cTTL, prng) = (env ^. turnSHA512, env ^. turnSecret, env ^. turnTokenTTL, env ^. turnConfigTTL, env ^. turnPrng) -- randomize list of servers (before limiting the list, to ensure not always the same servers are chosen if limit is set) - randomizedUris <- liftIO $ randomize (env ^. turnServers) + randomizedUris <- liftIO $ randomize (List1.toNonEmpty $ env ^. turnServers) let limitedUris = case limit of Nothing -> randomizedUris Just lim -> limitedList randomizedUris lim @@ -115,22 +123,27 @@ newConfig env limit = do finalUris <- liftIO $ randomize limitedUris srvs <- for finalUris $ \uri -> do u <- liftIO $ genUsername tTTL prng - pure $ Public.rtcIceServer (List1.singleton uri) u (computeCred sha secret u) - pure $ Public.rtcConfiguration srvs cTTL + pure $ Public.rtcIceServer (uri :| []) u (computeCred sha secret u) + sftSrvEntries <- maybe (pure Nothing) ((fmap discoveryToMaybe) . readIORef . sftServers) mSftEnv + -- According to RFC2782, the SRV Entries are supposed to be tried in order of + -- priority and weight, but we internally agreed to randomize the list of + -- available servers for poor man's "load balancing" purposes. + -- FUTUREWORK: be smarter about list orderding depending on how much capacity SFT servers have. + randomizedSftEntries <- liftIO $ mapM randomize sftSrvEntries + pure $ Public.rtcConfiguration srvs (sftServerFromSrvTarget . srvTarget <$$> randomizedSftEntries) cTTL where -- NOTE: even though `shuffleM` works only for [a], input is List1 so it's -- safe to pattern match; ideally, we'd have `shuffleM` for `NonEmpty` - randomize :: (MonadRandom m, MonadFail m) => List1 Public.TurnURI -> m (List1 Public.TurnURI) - randomize xs = do - (f : fs) <- shuffleM (toList xs) - return $ List1.list1 f fs - limitedList :: List1 Public.TurnURI -> Range 1 10 Int -> List1 Public.TurnURI - limitedList uris lim = do + randomize :: (MonadRandom m, MonadFail m) => NonEmpty a -> m (NonEmpty a) + randomize xs = NonEmpty.fromList <$> shuffleM (NonEmpty.toList xs) + -- + limitedList :: NonEmpty Public.TurnURI -> Range 1 10 Int -> NonEmpty Public.TurnURI + limitedList uris lim = -- assuming limitServers is safe with respect to the length of its return value -- (see property tests in brig-types) -- since the input is List1 and limit is in Range 1 10 -- it should also be safe to assume the returning list has length >= 1 - List1.maybeList1 (Public.limitServers (toList uris) (fromRange lim)) + NonEmpty.nonEmpty (Public.limitServers (NonEmpty.toList uris) (fromRange lim)) & fromMaybe (error "newConfig:limitedList: empty list of servers") genUsername :: Word32 -> MWC.GenIO -> IO Public.TurnUsername genUsername ttl prng = do diff --git a/services/brig/src/Brig/Calling/Internal.hs b/services/brig/src/Brig/Calling/Internal.hs new file mode 100644 index 00000000000..0ce1947b094 --- /dev/null +++ b/services/brig/src/Brig/Calling/Internal.hs @@ -0,0 +1,42 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Brig.Calling.Internal where + +import Control.Lens ((?~)) +import qualified Data.ByteString.Char8 as BS +import Data.Misc (ensureHttpsUrl) +import Imports +import qualified URI.ByteString as URI +import qualified URI.ByteString.QQ as URI +import qualified Wire.API.Call.Config as Public +import Wire.Network.DNS.SRV (SrvTarget (..)) + +-- FUTUREWORK: Extract function to translate SrvTarget to HttpsUrl and use it +-- wherever we use DNS for service discovery +sftServerFromSrvTarget :: SrvTarget -> Public.SFTServer +sftServerFromSrvTarget (SrvTarget host port) = + let uriPort = URI.Port (fromIntegral port) + uriHost = URI.Host (dropTrailingDot host) + uri = [URI.uri|https://|] & URI.authorityL ?~ URI.Authority Nothing uriHost (Just uriPort) + in Public.sftServer (ensureHttpsUrl uri) + where + dropTrailingDot :: ByteString -> ByteString + dropTrailingDot bs = + if BS.last bs == '.' + then BS.init bs + else bs diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 027a8462d78..11ef153147e 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -118,9 +118,9 @@ activateKey k c u = verifyCode k c >>= pickUser >>= activate return . Just $ foldKey (EmailActivated uid) (PhoneActivated uid) key claim key uid = do ok <- lift $ claimKey key uid - unless ok - $ throwE . UserKeyExists . LT.fromStrict - $ foldKey fromEmail fromPhone key + unless ok $ + throwE . UserKeyExists . LT.fromStrict $ + foldKey fromEmail fromPhone key -- | Create a new pending activation for a given 'UserKey'. newActivation :: @@ -162,7 +162,8 @@ verifyCode key code = do s <- lift . retry x1 . query1 keySelect $ params Quorum (Identity key) case s of Just (ttl, Ascii t, k, c, u, r) -> - if | c == code -> mkScope t k u + if + | c == code -> mkScope t k u | r >= 1 -> countdown (key, t, k, c, u, r -1, ttl) >> throwE invalidCode | otherwise -> revoke >> throwE invalidCode Nothing -> throwE invalidCode diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 139d83de840..d21931764c0 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -91,9 +91,9 @@ addClient u newId c maxPermClients loc = do let typed = filter ((== newClientType c) . clientType) clients let count = length typed let upsert = any exists typed - unless (count == 0 || upsert) - $ fmapLT ClientReAuthError - $ User.reauthenticate u (newClientPassword c) + unless (count == 0 || upsert) $ + fmapLT ClientReAuthError $ + User.reauthenticate u (newClientPassword c) let capacity = fmap (+ (- count)) limit unless (maybe True (> 0) capacity || upsert) $ throwE TooManyClients diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index d380f0ab589..6e4f49ad9fc 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -37,7 +37,7 @@ import Brig.Data.Types as T import Brig.Types import Brig.Types.Intra import Cassandra -import Data.Conduit ((.|), runConduit) +import Data.Conduit (runConduit, (.|)) import qualified Data.Conduit.List as C import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) @@ -49,13 +49,13 @@ import UnliftIO.Async (pooledMapConcurrentlyN_) connectUsers :: UserId -> [(UserId, ConvId)] -> AppIO [UserConnection] connectUsers from to = do now <- toUTCTimeMillis <$> liftIO getCurrentTime - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchLogged setConsistency Quorum forM_ to $ \(u, c) -> do addPrepQuery connectionInsert (from, u, Accepted, now, Nothing, c) addPrepQuery connectionInsert (u, from, Accepted, now, Nothing, c) - return $ concat $ (`map` to) $ \(u, c) -> + return . concat . (`map` to) $ \(u, c) -> [ UserConnection from u Accepted now Nothing (Just c), UserConnection u from Accepted now Nothing (Just c) ] @@ -97,9 +97,10 @@ lookupConnection from to = -- | For a given user 'A', lookup his outgoing connections (A -> X) to other users. lookupConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO (ResultPage UserConnection) -lookupConnections from start (fromRange -> size) = toResult <$> case start of - Just u -> retry x1 $ paginate connectionsSelectFrom (paramsP Quorum (from, u) (size + 1)) - Nothing -> retry x1 $ paginate connectionsSelect (paramsP Quorum (Identity from) (size + 1)) +lookupConnections from start (fromRange -> size) = + toResult <$> case start of + Just u -> retry x1 $ paginate connectionsSelectFrom (paramsP Quorum (from, u) (size + 1)) + Nothing -> retry x1 $ paginate connectionsSelect (paramsP Quorum (Identity from) (size + 1)) where toResult = cassandraResultPage . fmap toUserConnection . trim trim p = p {result = take (fromIntegral size) (result p)} diff --git a/services/brig/src/Brig/Data/IdMapping.hs b/services/brig/src/Brig/Data/IdMapping.hs index 525103725e5..96ad9db05d7 100644 --- a/services/brig/src/Brig/Data/IdMapping.hs +++ b/services/brig/src/Brig/Data/IdMapping.hs @@ -33,8 +33,9 @@ import Imports -- | Only a single namespace/table is used for for potentially multiple different types of -- mapped IDs. getIdMapping :: Id (Mapped a) -> AppIO (Maybe (IdMapping a)) -getIdMapping mappedId = fmap toIdMapping <$> do - retry x1 $ query1 idMappingSelect (params Quorum (Identity mappedId)) +getIdMapping mappedId = + fmap toIdMapping <$> do + retry x1 $ query1 idMappingSelect (params Quorum (Identity mappedId)) where toIdMapping (remoteId, domain) = IdMapping mappedId (Qualified remoteId domain) diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index a82e9da0a84..6387da78ba8 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -105,11 +105,12 @@ data ReAuthError newAccount :: NewUser -> Maybe InvitationId -> Maybe TeamId -> AppIO (UserAccount, Maybe Password) newAccount u inv tid = do defLoc <- setDefaultLocale <$> view settings - uid <- Id <$> do - case (inv, newUserUUID u) of - (Just (toUUID -> uuid), _) -> pure uuid - (_, Just uuid) -> pure uuid - (Nothing, Nothing) -> liftIO nextRandom + uid <- + Id <$> do + case (inv, newUserUUID u) of + (Just (toUUID -> uuid), _) -> pure uuid + (_, Just uuid) -> pure uuid + (Nothing, Nothing) -> liftIO nextRandom passwd <- maybe (return Nothing) (fmap Just . liftIO . mkSafePassword) pass expiry <- case status of Ephemeral -> do @@ -127,12 +128,10 @@ newAccount u inv tid = do name = newUserDisplayName u pict = fromMaybe noPict (newUserPict u) assets = newUserAssets u - status = case ident of - Nothing -> - -- any user registering without either an email or a phone is Ephemeral, - -- i.e. can be deleted after expires_in or sessionTokenTimeout - Ephemeral - Just _ -> Active + status = + if isNewUserEphemeral u + then Ephemeral + else Active colour = fromMaybe defaultAccentId (newUserAccentId u) locale defLoc = fromMaybe defLoc (newUserLocale u) managedBy = fromMaybe defaultManagedBy (newUserManagedBy u) @@ -140,27 +139,29 @@ newAccount u inv tid = do -- | Mandatory password authentication. authenticate :: UserId -> PlainTextPassword -> ExceptT AuthError AppIO () -authenticate u pw = lift (lookupAuth u) >>= \case - Nothing -> throwE AuthInvalidUser - Just (_, Deleted) -> throwE AuthInvalidUser - Just (_, Suspended) -> throwE AuthSuspended - Just (_, Ephemeral) -> throwE AuthEphemeral - Just (Nothing, _) -> throwE AuthInvalidCredentials - Just (Just pw', Active) -> - unless (verifyPassword pw pw') $ - throwE AuthInvalidCredentials +authenticate u pw = + lift (lookupAuth u) >>= \case + Nothing -> throwE AuthInvalidUser + Just (_, Deleted) -> throwE AuthInvalidUser + Just (_, Suspended) -> throwE AuthSuspended + Just (_, Ephemeral) -> throwE AuthEphemeral + Just (Nothing, _) -> throwE AuthInvalidCredentials + Just (Just pw', Active) -> + unless (verifyPassword pw pw') $ + throwE AuthInvalidCredentials -- | Password reauthentication. If the account has a password, reauthentication -- is mandatory. If the account has no password and no password is given, -- reauthentication is a no-op. reauthenticate :: (MonadClient m) => UserId -> Maybe PlainTextPassword -> ExceptT ReAuthError m () -reauthenticate u pw = lift (lookupAuth u) >>= \case - Nothing -> throwE (ReAuthError AuthInvalidUser) - Just (_, Deleted) -> throwE (ReAuthError AuthInvalidUser) - Just (_, Suspended) -> throwE (ReAuthError AuthSuspended) - Just (Nothing, _) -> for_ pw $ const (throwE $ ReAuthError AuthInvalidCredentials) - Just (Just pw', Active) -> maybeReAuth pw' - Just (Just pw', Ephemeral) -> maybeReAuth pw' +reauthenticate u pw = + lift (lookupAuth u) >>= \case + Nothing -> throwE (ReAuthError AuthInvalidUser) + Just (_, Deleted) -> throwE (ReAuthError AuthInvalidUser) + Just (_, Suspended) -> throwE (ReAuthError AuthSuspended) + Just (Nothing, _) -> for_ pw $ const (throwE $ ReAuthError AuthInvalidCredentials) + Just (Just pw', Active) -> maybeReAuth pw' + Just (Just pw', Ephemeral) -> maybeReAuth pw' where maybeReAuth pw' = case pw of Nothing -> throwE ReAuthMissingPassword @@ -177,7 +178,7 @@ insertAccount :: -- | Whether the user is activated Bool -> AppIO () -insertAccount (UserAccount u status) mbConv password activated = retry x5 $ batch $ do +insertAccount (UserAccount u status) mbConv password activated = retry x5 . batch $ do setType BatchLogged setConsistency Quorum let Locale l c = userLocale u @@ -223,7 +224,7 @@ updateLocale :: UserId -> Locale -> AppIO () updateLocale u (Locale l c) = write userLocaleUpdate (params Quorum (l, c, u)) updateUser :: UserId -> UserUpdate -> AppIO () -updateUser u UserUpdate {..} = retry x5 $ batch $ do +updateUser u UserUpdate {..} = retry x5 . batch $ do setType BatchLogged setConsistency Quorum for_ uupName $ \n -> addPrepQuery userDisplayNameUpdate (n, u) @@ -270,7 +271,7 @@ deleteServiceUser :: ProviderId -> ServiceId -> BotId -> AppIO () deleteServiceUser pid sid bid = do lookupServiceUser pid sid bid >>= \case Nothing -> pure () - Just (_, mbTid) -> retry x5 $ batch $ do + Just (_, mbTid) -> retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery cql (pid, sid, bid) diff --git a/services/brig/src/Brig/Email.hs b/services/brig/src/Brig/Email.hs index fedd0e07a42..1335ef784a2 100644 --- a/services/brig/src/Brig/Email.hs +++ b/services/brig/src/Brig/Email.hs @@ -50,9 +50,10 @@ import Network.Mail.Mime ------------------------------------------------------------------------------- sendMail :: Mail -> AppIO () -sendMail m = view smtpEnv >>= \case - Just smtp -> SMTP.sendMail smtp m - Nothing -> view awsEnv >>= \e -> AWS.execute e $ AWS.sendMail m +sendMail m = + view smtpEnv >>= \case + Just smtp -> SMTP.sendMail smtp m + Nothing -> view awsEnv >>= \e -> AWS.execute e $ AWS.sendMail m ------------------------------------------------------------------------------- -- Unique Keys diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index c1eaf44e849..3f41449e971 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -67,11 +67,10 @@ import Brig.Data.Connection (lookupContactList) import qualified Brig.IO.Journal as Journal import Brig.RPC import Brig.Types -import Brig.Types.Intra import Brig.User.Event import qualified Brig.User.Event.Log as Log import qualified Brig.User.Search.Index as Search -import Control.Lens ((.~), (?~), (^.), view) +import Control.Lens (view, (.~), (?~), (^.)) import Control.Retry import Data.Aeson hiding (json) import Data.ByteString.Conversion @@ -80,8 +79,7 @@ import Data.Coerce (coerce) import qualified Data.Currency as Currency import qualified Data.HashMap.Strict as M import Data.Id -import Data.Json.Util ((#), UTCTimeMillis) -import Data.Json.Util () +import Data.Json.Util (UTCTimeMillis, (#)) import Data.List.Split (chunksOf) import Data.List1 (List1, list1, singleton) import Data.Range @@ -96,7 +94,7 @@ import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import qualified Network.Wai.Utilities.Error as Wai -import System.Logger.Class as Log hiding ((.=), name) +import System.Logger.Class as Log hiding (name, (.=)) import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus) ----------------------------------------------------------------------------- @@ -181,7 +179,7 @@ updateSearchIndex orig e = case e of journalEvent :: UserId -> UserEvent -> AppIO () journalEvent orig e = case e of UserActivated acc -> - Journal.userActivate (accountUser acc) + Journal.userActivate acc UserUpdated UserUpdatedData {eupName = Just name} -> Journal.userUpdate orig Nothing Nothing (Just name) UserUpdated UserUpdatedData {eupLocale = Just loc} -> @@ -267,23 +265,24 @@ rawPush (toList -> events) usrs orig route conn = do for_ events $ \e -> debug $ remote "gundeck" . msg (fst e) g <- view gundeck forM_ recipients $ \rcps -> - void . recovering x3 rpcHandlers $ const $ - rpc' - "gundeck" - g - ( method POST - . path "/i/push/v2" - . zUser orig - . json (map (mkPush rcps . snd) events) - . expect2xx - ) + void . recovering x3 rpcHandlers $ + const $ + rpc' + "gundeck" + g + ( method POST + . path "/i/push/v2" + . zUser orig + . json (map (mkPush rcps . snd) events) + . expect2xx + ) where recipients :: [Range 1 1024 (Set.Set Recipient)] recipients = - map (unsafeRange . Set.fromList) - $ chunksOf 512 - $ map (`recipient` route) - $ toList usrs + map (unsafeRange . Set.fromList) $ + chunksOf 512 $ + map (`recipient` route) $ + toList usrs mkPush :: Range 1 1024 (Set.Set Recipient) -> (Object, Maybe ApsData) -> Push mkPush rcps (o, aps) = newPush @@ -332,9 +331,9 @@ notifyContacts :: AppIO () notifyContacts events orig route conn = do env <- ask - notify events orig route conn - $ runAppT env - $ list1 orig <$> liftA2 (++) contacts teamContacts + notify events orig route conn $ + runAppT env $ + list1 orig <$> liftA2 (++) contacts teamContacts where contacts :: AppIO [UserId] contacts = lookupContactList orig @@ -350,13 +349,13 @@ notifyContacts events orig route conn = do -- Event Serialisation: toPushFormat :: Event -> Maybe Object -toPushFormat (UserEvent (UserCreated (UserAccount u _))) = +toPushFormat (UserEvent (UserCreated u)) = Just $ M.fromList [ "type" .= ("user.new" :: Text), "user" .= SelfProfile (u {userIdentity = Nothing}) ] -toPushFormat (UserEvent (UserActivated (UserAccount u _))) = +toPushFormat (UserEvent (UserActivated u)) = Just $ M.fromList [ "type" .= ("user.activate" :: Text), @@ -404,13 +403,14 @@ toPushFormat (UserEvent (UserIdentityRemoved (UserIdentityRemovedData i e p))) = ) ] toPushFormat (ConnectionEvent (ConnectionUpdated uc _ name)) = - Just $ M.fromList $ - "type" .= ("user.connection" :: Text) - # "connection" .= uc - # "user" .= case name of - Just n -> Just $ object ["name" .= n] - Nothing -> Nothing - # [] + Just $ + M.fromList $ + "type" .= ("user.connection" :: Text) + # "connection" .= uc + # "user" .= case name of + Just n -> Just $ object ["name" .= n] + Nothing -> Nothing + # [] toPushFormat (UserEvent (UserSuspended i)) = Just $ M.fromList @@ -520,9 +520,9 @@ createConnectConv from to cname mess conn = do . remote "galley" . msg (val "Creating connect conversation") r <- galleyRequest POST req - maybe (error "invalid conv id") return - $ fromByteString - $ getHeader' "Location" r + maybe (error "invalid conv id") return $ + fromByteString $ + getHeader' "Location" r where req = path "/i/conversations/connect" @@ -669,15 +669,16 @@ rmClient u c = do . field "client" (BL.fromStrict cid) . msg (val "unregister push client") g <- view gundeck - void . recovering x3 rpcHandlers $ const $ - rpc' - "gundeck" - g - ( method DELETE - . paths ["i", "clients", cid] - . zUser u - . expect expected - ) + void . recovering x3 rpcHandlers $ + const $ + rpc' + "gundeck" + g + ( method DELETE + . paths ["i", "clients", cid] + . zUser u + . expect expected + ) where expected = [status200, status204, status404] @@ -729,9 +730,9 @@ createTeam u t@(Team.BindingNewTeam bt) teamid = do . msg (val "Creating Team") r <- galleyRequest PUT $ req teamid tid <- - maybe (error "invalid team id") return - $ fromByteString - $ getHeader' "Location" r + maybe (error "invalid team id") return $ + fromByteString $ + getHeader' "Location" r return (CreateUserTeam tid $ fromRange (bt ^. Team.newTeamName)) where req tid = @@ -838,9 +839,10 @@ getTeamLegalHoldStatus tid = do -- | Calls 'Galley.API.getSearchVisibilityInternalH'. getTeamSearchVisibility :: TeamId -> AppIO Team.TeamSearchVisibility -getTeamSearchVisibility tid = coerce @Team.TeamSearchVisibilityView @Team.TeamSearchVisibility <$> do - debug $ remote "galley" . msg (val "Get search visibility settings") - galleyRequest GET req >>= decodeBody "galley" +getTeamSearchVisibility tid = + coerce @Team.TeamSearchVisibilityView @Team.TeamSearchVisibility <$> do + debug $ remote "galley" . msg (val "Get search visibility settings") + galleyRequest GET req >>= decodeBody "galley" where req = paths ["i", "teams", toByteString' tid, "search-visibility"] diff --git a/services/brig/src/Brig/IO/Journal.hs b/services/brig/src/Brig/IO/Journal.hs index 799edc4f08f..fbb51f54167 100644 --- a/services/brig/src/Brig/IO/Journal.hs +++ b/services/brig/src/Brig/IO/Journal.hs @@ -60,17 +60,18 @@ userDelete :: UserId -> AppIO () userDelete uid = journalEvent UserEvent'USER_DELETE uid Nothing Nothing Nothing Nothing journalEvent :: UserEvent'EventType -> UserId -> Maybe Email -> Maybe Locale -> Maybe TeamId -> Maybe Name -> AppIO () -journalEvent typ uid em loc tid nm = view awsEnv >>= \env -> for_ (view AWS.userJournalQueue env) $ \queue -> do - ts <- now - rnd <- liftIO nextRandom - let userEvent :: UserEvent = - defMessage - & U.eventType .~ typ - & U.userId .~ (toBytes uid) - & U.utcTime .~ ts - & U.maybe'email .~ (toByteString' <$> em) - & U.maybe'locale .~ (pack . show <$> loc) - & U.maybe'teamId .~ (toBytes <$> tid) - & U.maybe'name .~ (toByteString' <$> nm) -- [] - encoded = fromStrict $ B64.encode $ encodeMessage userEvent - AWS.execute env (AWS.enqueueFIFO queue "user.events" rnd encoded) +journalEvent typ uid em loc tid nm = + view awsEnv >>= \env -> for_ (view AWS.userJournalQueue env) $ \queue -> do + ts <- now + rnd <- liftIO nextRandom + let userEvent :: UserEvent = + defMessage + & U.eventType .~ typ + & U.userId .~ (toBytes uid) + & U.utcTime .~ ts + & U.maybe'email .~ (toByteString' <$> em) + & U.maybe'locale .~ (pack . show <$> loc) + & U.maybe'teamId .~ (toBytes <$> tid) + & U.maybe'name .~ (toByteString' <$> nm) -- [] + encoded = fromStrict $ B64.encode $ encodeMessage userEvent + AWS.execute env (AWS.enqueueFIFO queue "user.events" rnd encoded) diff --git a/services/brig/index/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs similarity index 96% rename from services/brig/index/src/Brig/Index/Eval.hs rename to services/brig/src/Brig/Index/Eval.hs index 147eae33fcc..a5249152a29 100644 --- a/services/brig/index/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -99,13 +99,13 @@ runCommand l = \case ES.mkBHEnv (toESServer esURI) <$> newManager defaultManagerSettings initDb cas = - C.init - $ C.setLogger (C.mkLogger l) + C.init $ + C.setLogger (C.mkLogger l) . C.setContacts (view cHost cas) [] . C.setPortNumber (fromIntegral (view cPort cas)) . C.setKeyspace (view cKeyspace cas) . C.setProtocolVersion C.V4 - $ C.defSettings + $ C.defSettings waitForTaskToComplete :: forall a m. (ES.MonadBH m, MonadIO m, MonadThrow m, FromJSON a) => Int -> ES.TaskNodeId -> m () waitForTaskToComplete timeoutSeconds taskNodeId = do @@ -117,14 +117,15 @@ waitForTaskToComplete timeoutSeconds taskNodeId = do unless (ES.taskResponseCompleted task) $ do throwM $ ReindexFromAnotherIndexError $ "Timed out waiting for task: " <> show taskNodeId when (isJust $ ES.taskResponseError task) $ do - throwM $ ReindexFromAnotherIndexError $ - "Task failed with error: " - <> LensBS.unpackLazy8 (Aeson.encode $ ES.taskResponseError task) + throwM $ + ReindexFromAnotherIndexError $ + "Task failed with error: " + <> LensBS.unpackLazy8 (Aeson.encode $ ES.taskResponseError task) where isTaskComplete :: Either ES.EsError (ES.TaskResponse a) -> m Bool isTaskComplete (Left e) = throwM $ ReindexFromAnotherIndexError $ "Error response while getting task: " <> show e isTaskComplete (Right taskRes) = pure $ ES.taskResponseCompleted taskRes - -- + errTaskGet :: MonadThrow m => ES.EsError -> m x errTaskGet e = throwM $ ReindexFromAnotherIndexError $ "Error response while getting task: " <> show e diff --git a/services/brig/index/src/Brig/Index/Migrations.hs b/services/brig/src/Brig/Index/Migrations.hs similarity index 95% rename from services/brig/index/src/Brig/Index/Migrations.hs rename to services/brig/src/Brig/Index/Migrations.hs index 10987ddfaca..14ea80ebf4e 100644 --- a/services/brig/index/src/Brig/Index/Migrations.hs +++ b/services/brig/src/Brig/Index/Migrations.hs @@ -25,9 +25,9 @@ import qualified Brig.Index.Options as Opts import qualified Brig.User.Search.Index as Search import qualified Cassandra as C import qualified Cassandra.Settings as C -import Control.Lens ((^.), view) +import Control.Lens (view, (^.)) import Control.Monad.Catch (Exception, MonadThrow, finally, throwM) -import Data.Aeson ((.=), Value, object) +import Data.Aeson (Value, object, (.=)) import qualified Data.Metrics as Metrics import qualified Data.Text as Text import qualified Database.Bloodhound as ES @@ -79,13 +79,13 @@ mkEnv l es cas = (Opts.toESServer (es ^. Opts.esServer)) <$> HTTP.newManager HTTP.defaultManagerSettings initCassandra = - C.init - $ C.setLogger (C.mkLogger l) + C.init $ + C.setLogger (C.mkLogger l) . C.setContacts (view Opts.cHost cas) [] . C.setPortNumber (fromIntegral (view Opts.cPort cas)) . C.setKeyspace (view Opts.cKeyspace cas) . C.setProtocolVersion C.V4 - $ C.defSettings + $ C.defSettings initLogger = pure l createMigrationsIndexIfNotPresent :: (MonadThrow m, MonadIO m, ES.MonadBH m) => m () @@ -98,9 +98,9 @@ createMigrationsIndexIfNotPresent = >>= throwIfNotCreated PutMappingFailed where throwIfNotCreated err response = - unless (ES.isSuccess response) - $ throwM - $ err (show response) + unless (ES.isSuccess response) $ + throwM $ + err (show response) failIfIndexAbsent :: (MonadThrow m, MonadIO m, ES.MonadBH m) => ES.IndexName -> m () failIfIndexAbsent targetIndex = diff --git a/services/brig/index/src/Brig/Index/Migrations/Types.hs b/services/brig/src/Brig/Index/Migrations/Types.hs similarity index 97% rename from services/brig/index/src/Brig/Index/Migrations/Types.hs rename to services/brig/src/Brig/Index/Migrations/Types.hs index 33e404ff0be..920ed007e1d 100644 --- a/services/brig/index/src/Brig/Index/Migrations/Types.hs +++ b/services/brig/src/Brig/Index/Migrations/Types.hs @@ -24,7 +24,7 @@ import qualified Brig.User.Search.Index as Search import qualified Cassandra as C import Control.Monad.Catch (MonadThrow) import Control.Monad.Reader (MonadReader (..), ReaderT, lift, runReaderT) -import Data.Aeson ((.:), (.=), FromJSON (..), ToJSON (..), object, withObject) +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=)) import Data.Metrics (Metrics) import qualified Database.Bloodhound as ES import Imports diff --git a/services/brig/index/src/Brig/Index/Options.hs b/services/brig/src/Brig/Index/Options.hs similarity index 100% rename from services/brig/index/src/Brig/Index/Options.hs rename to services/brig/src/Brig/Index/Options.hs diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index ca9ca7a12aa..e4a02e8f3f3 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -55,9 +55,10 @@ onEvent n = handleTimeout $ case n of ~~ field "service" (toByteString sid) API.finishDeleteService pid sid where - handleTimeout act = timeout 60000000 act >>= \case - Just x -> pure x - Nothing -> throwM (InternalEventTimeout n) + handleTimeout act = + timeout 60000000 act >>= \case + Just x -> pure x + Nothing -> throwM (InternalEventTimeout n) data InternalEventException = -- | 'onEvent' has timed out diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 76c301ec2de..dd3c3a6a747 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -30,13 +30,18 @@ import qualified Control.Lens as Lens import Data.Aeson (withText) import qualified Data.Aeson as Aeson import Data.Aeson.Types (typeMismatch) +import qualified Data.Char as Char import Data.Domain (Domain) import Data.Id +import Data.Misc ((<$$>)) import Data.Scientific (toBoundedInteger) -import Data.Time.Clock (NominalDiffTime) -import Data.Yaml (FromJSON (..), ToJSON (..)) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Time.Clock (DiffTime, NominalDiffTime, secondsToDiffTime) +import Data.Yaml (FromJSON (..), ToJSON (..), (.:), (.:?)) import qualified Data.Yaml as Y import Imports +import qualified Network.DNS as DNS import System.Logger.Extended (Level, LogFormat) import Util.Options @@ -379,8 +384,8 @@ data Opts = Opts logFormat :: !(Maybe (Last LogFormat)), -- | TURN server settings turn :: !TurnOpts, - -- Runtime settings - + -- | SFT Settings + sft :: !(Maybe SFTOptions), -- | Runtime settings optSettings :: !Settings } @@ -519,6 +524,26 @@ data CustomerExtensions = CustomerExtensions newtype DomainsBlockedForRegistration = DomainsBlockedForRegistration [Domain] deriving newtype (Show, FromJSON, Generic) +data SFTOptions = SFTOptions + { sftBaseDomain :: !DNS.Domain, + sftSRVServiceName :: !(Maybe ByteString), -- defaults to defSftServiceName if unset + sftDiscoveryIntervalSeconds :: !(Maybe DiffTime) -- defaults to defSftDiscoveryIntervalSeconds + } + deriving (Show, Generic) + +instance FromJSON SFTOptions where + parseJSON = Y.withObject "SFTOptions" $ \o -> + SFTOptions + <$> (asciiOnly =<< o .: "sftBaseDomain") + <*> (mapM asciiOnly =<< o .:? "sftSRVServiceName") + <*> (secondsToDiffTime <$$> o .:? "sftDiscoveryIntervalSeconds") + where + asciiOnly :: Text -> Y.Parser ByteString + asciiOnly t = + if Text.all Char.isAscii t + then pure $ Text.encodeUtf8 t + else fail $ "Expected ascii string only, found: " <> Text.unpack t + defMaxKeyLen :: Int64 defMaxKeyLen = 1024 @@ -534,14 +559,20 @@ defSqsThrottleMillis = 500 defUserMaxPermClients :: Int defUserMaxPermClients = 7 +defSftServiceName :: ByteString +defSftServiceName = "_sft" + +defSftDiscoveryIntervalSeconds :: DiffTime +defSftDiscoveryIntervalSeconds = secondsToDiffTime 10 + instance FromJSON Timeout where parseJSON (Y.Number n) = let defaultV = 3600 bounded = toBoundedInteger n :: Maybe Int64 - in pure - $ Timeout - $ fromIntegral @Int - $ maybe defaultV fromIntegral bounded + in pure $ + Timeout $ + fromIntegral @Int $ + maybe defaultV fromIntegral bounded parseJSON v = typeMismatch "activationTimeout" v instance FromJSON Settings @@ -551,7 +582,8 @@ instance FromJSON Opts -- TODO: Does it make sense to generate lens'es for all? Lens.makeLensesFor [ ("optSettings", "optionSettings"), - ("elasticsearch", "elasticsearchL") + ("elasticsearch", "elasticsearchL"), + ("sft", "sftL") ] ''Opts @@ -572,3 +604,5 @@ Lens.makeLensesFor ("additionalWriteIndex", "additionalWriteIndexL") ] ''ElasticSearchOpts + +Lens.makeLensesFor [("sftBaseDomain", "sftBaseDomainL")] ''SFTOptions diff --git a/services/brig/src/Brig/Phone.hs b/services/brig/src/Brig/Phone.hs index d1c32501459..41520c0dc41 100644 --- a/services/brig/src/Brig/Phone.hs +++ b/services/brig/src/Brig/Phone.hs @@ -80,8 +80,9 @@ sendCall call = unless (isTestPhone $ Nexmo.callTo call) $ do cred <- view nexmoCreds withCallBudget (Nexmo.callTo call) $ do r <- - liftIO . try @_ @Nexmo.CallErrorResponse . recovering x3 nexmoHandlers $ const $ - Nexmo.sendCall cred m call + liftIO . try @_ @Nexmo.CallErrorResponse . recovering x3 nexmoHandlers $ + const $ + Nexmo.sendCall cred m call case r of Left ex -> case Nexmo.caStatus ex of Nexmo.CallDestinationNotPermitted -> unreachable ex @@ -135,9 +136,10 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do sendNexmoSms :: Manager -> AppIO () sendNexmoSms mgr = do crd <- view nexmoCreds - void . liftIO . recovering x3 nexmoHandlers $ const - $ Nexmo.sendMessage crd mgr - $ Nexmo.Message "Wire" smsTo smsText (toNexmoCharset loc) + void . liftIO . recovering x3 nexmoHandlers $ + const $ + Nexmo.sendMessage crd mgr $ + Nexmo.Message "Wire" smsTo smsText (toNexmoCharset loc) toNexmoCharset :: Locale -> Nexmo.Charset toNexmoCharset l = case fromLanguage (lLanguage l) of RU -> Nexmo.UCS2 @@ -151,8 +153,9 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do sendTwilioSms :: Manager -> AppIO () sendTwilioSms mgr = do crd <- view twilioCreds - void . liftIO . recovering x3 twilioHandlers $ const $ - Twilio.sendMessage crd mgr (Twilio.Message smsFrom smsTo smsText) + void . liftIO . recovering x3 twilioHandlers $ + const $ + Twilio.sendMessage crd mgr (Twilio.Message smsFrom smsTo smsText) nexmoFailed = [ Handler $ \(ex :: HttpException) -> return (Just (SomeException ex)), @@ -199,8 +202,10 @@ validatePhone (Phone p) c <- view twilioCreds m <- view httpManager r <- - liftIO . try @_ @Twilio.ErrorResponse $ recovering x3 httpHandlers $ const $ - Twilio.lookupPhone c m p LookupNoDetail Nothing + liftIO . try @_ @Twilio.ErrorResponse $ + recovering x3 httpHandlers $ + const $ + Twilio.lookupPhone c m p LookupNoDetail Nothing case r of Right x -> return (Just (Phone (Twilio.lookupE164 x))) Left e | Twilio.errStatus e == 404 -> return Nothing diff --git a/services/brig/src/Brig/PolyLog.hs b/services/brig/src/Brig/PolyLog.hs new file mode 100644 index 00000000000..758e5283548 --- /dev/null +++ b/services/brig/src/Brig/PolyLog.hs @@ -0,0 +1,19 @@ +module Brig.PolyLog where + +import Imports +import Polysemy +import qualified System.Logger as Log + +-- | This effect will help us write tests for log messages +-- +-- FUTUREWORK: Move this to a separate module if it is required +-- +-- FUTUREWORK: Either write an orphan instance for MonadLogger or provide +-- equivalent functions in System.Logger.Class +data PolyLog m a where + PolyLog :: Log.Level -> (Log.Msg -> Log.Msg) -> PolyLog m () + +makeSem 'PolyLog + +runPolyLog :: Member (Embed IO) r => Log.Logger -> Sem (PolyLog ': r) a -> Sem r a +runPolyLog logger = interpret $ \(PolyLog lvl msg) -> Log.log logger lvl msg diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index d72d16131da..b2b27087678 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -47,35 +47,31 @@ import qualified Brig.Queue as Queue import Brig.Team.Util import Brig.Types.Client (Client (..), ClientType (..), newClient, newClientPrekeys) import Brig.Types.Intra (AccountStatus (..), UserAccount (..)) -import Brig.Types.Provider (DeleteProvider (..), PasswordChange (..), Provider (..), ProviderLogin (..), UpdateProvider (..)) -import Brig.Types.Provider (Service (..), ServiceProfile (..), ServiceToken (..)) -import Brig.Types.Provider (DeleteService (..), NewService (..), UpdateService (..), UpdateServiceConn (..), UpdateServiceWhitelist (..)) -import Brig.Types.Provider (AddBot (..), UpdateBotPrekeys (..)) +import Brig.Types.Provider (AddBot (..), DeleteProvider (..), DeleteService (..), NewService (..), PasswordChange (..), Provider (..), ProviderLogin (..), Service (..), ServiceProfile (..), ServiceToken (..), UpdateBotPrekeys (..), UpdateProvider (..), UpdateService (..), UpdateServiceConn (..), UpdateServiceWhitelist (..)) import qualified Brig.Types.Provider.External as Ext import Brig.Types.User (ManagedBy (..), Name (..), Pict (..), User (..), defaultAccentId) import qualified Brig.ZAuth as ZAuth import Control.Error (throwE) import Control.Exception.Enclosed (handleAny) -import Control.Lens ((^.), view) +import Control.Lens (view, (^.)) import Data.Aeson hiding (json) import Data.ByteString.Conversion import qualified Data.ByteString.Lazy.Char8 as LC8 -import Data.Conduit ((.|), runConduit) +import Data.Conduit (runConduit, (.|)) import qualified Data.Conduit.List as C import Data.Hashable (hash) import Data.Id import qualified Data.List as List import Data.List1 (maybeList1) import qualified Data.Map.Strict as Map -import Data.Misc ((<$$>), Fingerprint (..), Rsa) +import Data.Misc (Fingerprint (..), Rsa, (<$$>)) import Data.Predicate import Data.Range import qualified Data.Set as Set import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text.Ascii as Ascii import qualified Data.Text.Encoding as Text -import Galley.Types (AccessRole (..), ConvMembers (..), ConvType (..), Conversation (..)) -import Galley.Types (OtherMember (..)) +import Galley.Types (AccessRole (..), ConvMembers (..), ConvType (..), Conversation (..), OtherMember (..)) import Galley.Types.Bot (newServiceRef, serviceRefId, serviceRefProvider) import Galley.Types.Conversations.Roles (roleNameWireAdmin) import qualified Galley.Types.Teams as Teams @@ -784,15 +780,16 @@ updateServiceWhitelist uid con tid upd = do (True, False) -> do -- When the service is de-whitelisted, remove its bots from team -- conversations - lift $ runConduit $ - User.lookupServiceUsersForTeam pid sid tid - .| C.mapM_ - ( pooledMapConcurrentlyN_ - 16 - ( \(bid, cid) -> - deleteBot uid (Just con) bid cid - ) - ) + lift $ + runConduit $ + User.lookupServiceUsersForTeam pid sid tid + .| C.mapM_ + ( pooledMapConcurrentlyN_ + 16 + ( \(bid, cid) -> + deleteBot uid (Just con) bid cid + ) + ) DB.deleteServiceWhitelist (Just tid) pid sid return UpdateServiceWhitelistRespChanged @@ -1007,20 +1004,21 @@ deleteBot zusr zcon bid cid = do return ev validateServiceKey :: MonadIO m => Public.ServiceKeyPEM -> m (Maybe (Public.ServiceKey, Fingerprint Rsa)) -validateServiceKey pem = liftIO $ - readPublicKey >>= \pk -> - case join (SSL.toPublicKey <$> pk) of - Nothing -> return Nothing - Just pk' -> do - Just sha <- SSL.getDigestByName "SHA256" - let size = SSL.rsaSize (pk' :: SSL.RSAPubKey) - if size < minRsaKeySize - then return Nothing - else do - fpr <- Fingerprint <$> SSL.rsaFingerprint sha pk' - let bits = fromIntegral size * 8 - let key = Public.ServiceKey Public.RsaServiceKey bits pem - return $ Just (key, fpr) +validateServiceKey pem = + liftIO $ + readPublicKey >>= \pk -> + case join (SSL.toPublicKey <$> pk) of + Nothing -> return Nothing + Just pk' -> do + Just sha <- SSL.getDigestByName "SHA256" + let size = SSL.rsaSize (pk' :: SSL.RSAPubKey) + if size < minRsaKeySize + then return Nothing + else do + fpr <- Fingerprint <$> SSL.rsaFingerprint sha pk' + let bits = fromIntegral size * 8 + let key = Public.ServiceKey Public.RsaServiceKey bits pem + return $ Just (key, fpr) where readPublicKey = handleAny diff --git a/services/brig/src/Brig/Provider/DB.hs b/services/brig/src/Brig/Provider/DB.hs index 44e30b5b427..c9adc1089a8 100644 --- a/services/brig/src/Brig/Provider/DB.hs +++ b/services/brig/src/Brig/Provider/DB.hs @@ -65,7 +65,7 @@ updateAccountProfile :: Maybe HttpsUrl -> Maybe Text -> m () -updateAccountProfile p name url descr = retry x5 $ batch $ do +updateAccountProfile p name url descr = retry x5 . batch $ do setType BatchUnLogged setConsistency Quorum for_ name $ \x -> addPrepQuery cqlName (x, p) @@ -110,10 +110,10 @@ lookupPassword :: ProviderId -> m (Maybe Password) lookupPassword p = - fmap (fmap runIdentity) - $ retry x1 - $ query1 cql - $ params Quorum (Identity p) + fmap (fmap runIdentity) $ + retry x1 $ + query1 cql $ + params Quorum (Identity p) where cql :: PrepQuery R (Identity ProviderId) (Identity Password) cql = "SELECT password FROM provider WHERE id = ?" @@ -148,7 +148,7 @@ insertKey :: Maybe EmailKey -> EmailKey -> m () -insertKey p old new = retry x5 $ batch $ do +insertKey p old new = retry x5 . batch $ do setConsistency Quorum setType BatchLogged for_ old $ \old' -> addPrepQuery cqlKeyDelete (Identity (emailKeyUniq old')) @@ -167,10 +167,10 @@ lookupKey :: EmailKey -> m (Maybe ProviderId) lookupKey k = - fmap (fmap runIdentity) - $ retry x1 - $ query1 cql - $ params Quorum (Identity (emailKeyUniq k)) + fmap (fmap runIdentity) $ + retry x1 $ + query1 cql $ + params Quorum (Identity (emailKeyUniq k)) where cql :: PrepQuery R (Identity Text) (Identity ProviderId) cql = "SELECT provider FROM provider_keys WHERE key = ?" @@ -200,10 +200,11 @@ insertService :: insertService pid name summary descr url token key fprint assets tags = do sid <- randomId let tagSet = C.Set (Set.toList tags) - retry x5 $ write cql $ - params - Quorum - (pid, sid, name, summary, descr, url, [token], [key], [fprint], assets, tagSet, False) + retry x5 $ + write cql $ + params + Quorum + (pid, sid, name, summary, descr, url, [token], [key], [fprint], assets, tagSet, False) return sid where cql :: @@ -234,10 +235,10 @@ lookupService :: ServiceId -> m (Maybe Service) lookupService pid sid = - fmap (fmap mk) - $ retry x1 - $ query1 cql - $ params Quorum (pid, sid) + fmap (fmap mk) $ + retry x1 $ + query1 cql $ + params Quorum (pid, sid) where cql :: PrepQuery @@ -255,10 +256,10 @@ listServices :: ProviderId -> m [Service] listServices p = - fmap (map mk) - $ retry x1 - $ query cql - $ params Quorum (Identity p) + fmap (map mk) $ + retry x1 $ + query cql $ + params Quorum (Identity p) where cql :: PrepQuery @@ -285,7 +286,7 @@ updateService :: Maybe (RangedServiceTags, RangedServiceTags) -> Bool -> m () -updateService pid sid svcName svcTags nameChange summary descr assets tagsChange enabled = retry x5 $ batch $ do +updateService pid sid svcName svcTags nameChange summary descr assets tagsChange enabled = retry x5 . batch $ do setConsistency Quorum setType BatchUnLogged -- If there is a name change, update the service name; if enabled, update indexes @@ -330,7 +331,7 @@ deleteService pid sid name tags = do -- (or as a part of the last batch, in this case) because otherwise API -- consumers won't be able to retry a half-done 'deleteService' call. deleteServiceWhitelist Nothing pid sid - retry x5 $ batch $ do + retry x5 . batch $ do setConsistency Quorum setType BatchUnLogged addPrepQuery cql (pid, sid) @@ -350,10 +351,10 @@ lookupServiceProfile :: ServiceId -> m (Maybe ServiceProfile) lookupServiceProfile p s = - fmap (fmap mk) - $ retry x1 - $ query1 cql - $ params One (p, s) + fmap (fmap mk) $ + retry x1 $ + query1 cql $ + params One (p, s) where cql :: PrepQuery R (ProviderId, ServiceId) (Name, Maybe Text, Text, [Asset], C.Set ServiceTag, Bool) cql = @@ -369,10 +370,10 @@ listServiceProfiles :: ProviderId -> m [ServiceProfile] listServiceProfiles p = - fmap (map mk) - $ retry x1 - $ query cql - $ params One (Identity p) + fmap (map mk) $ + retry x1 $ + query cql $ + params One (Identity p) where cql :: PrepQuery @@ -405,10 +406,10 @@ lookupServiceConn :: ServiceId -> m (Maybe ServiceConn) lookupServiceConn pid sid = - fmap (fmap mk) - $ retry x1 - $ query1 cql - $ params Quorum (pid, sid) + fmap (fmap mk) $ + retry x1 $ + query1 cql $ + params Quorum (pid, sid) where cql :: PrepQuery R (ProviderId, ServiceId) (HttpsUrl, List1 ServiceToken, List1 (Fingerprint Rsa), Bool) cql = @@ -426,7 +427,7 @@ updateServiceConn :: Maybe (List1 (ServiceKey, Fingerprint Rsa)) -> Maybe Bool -> m () -updateServiceConn pid sid url tokens keys enabled = retry x5 $ batch $ do +updateServiceConn pid sid url tokens keys enabled = retry x5 . batch $ do setConsistency Quorum setType BatchLogged for_ url $ \x -> addPrepQuery cqlBaseUrl (x, pid, sid) @@ -458,7 +459,7 @@ insertServiceIndexes :: RangedServiceTags -> m () insertServiceIndexes pid sid name tags = - retry x5 $ batch $ do + retry x5 . batch $ do setConsistency Quorum setType BatchLogged insertServicePrefix pid sid name @@ -472,7 +473,7 @@ deleteServiceIndexes :: RangedServiceTags -> m () deleteServiceIndexes pid sid name tags = - retry x5 $ batch $ do + retry x5 . batch $ do setConsistency Quorum setType BatchLogged deleteServicePrefix sid name @@ -686,8 +687,9 @@ paginateServiceNames mbPrefix size providerFilter = liftClient $ do \FROM service_prefix \ \WHERE prefix = ? AND name >= ?" p <- - retry x1 $ paginate cql $ - paramsP One (mkPrefixIndex (Name prefix), prefix) len + retry x1 $ + paginate cql $ + paramsP One (mkPrefixIndex (Name prefix), prefix) len return $! p {result = trim size (result p)} -- Pagination utilities @@ -718,7 +720,7 @@ resolveRow (_, pid, sid) = lookupServiceProfile pid sid insertServiceWhitelist :: MonadClient m => TeamId -> ProviderId -> ServiceId -> m () insertServiceWhitelist tid pid sid = - retry x5 $ batch $ do + retry x5 . batch $ do addPrepQuery insert1 (tid, pid, sid) addPrepQuery insert1Rev (tid, pid, sid) where @@ -740,13 +742,13 @@ deleteServiceWhitelist :: MonadClient m => Maybe TeamId -> ProviderId -> Service deleteServiceWhitelist mbTid pid sid = case mbTid of Nothing -> do teams <- retry x5 $ query lookupRev $ params Quorum (pid, sid) - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery deleteAllRev (pid, sid) for_ teams $ \(Identity tid) -> addPrepQuery delete1 (tid, pid, sid) Just tid -> - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery delete1 (tid, pid, sid) diff --git a/services/brig/src/Brig/Provider/RPC.hs b/services/brig/src/Brig/Provider/RPC.hs index 5bbbd436c38..faef52a3e19 100644 --- a/services/brig/src/Brig/Provider/RPC.hs +++ b/services/brig/src/Brig/Provider/RPC.hs @@ -36,7 +36,7 @@ import Brig.RPC import Brig.Types.Provider (HttpsUrl (..)) import Brig.Types.Provider.External import Control.Error -import Control.Lens ((^.), set, view) +import Control.Lens (set, view, (^.)) import Control.Monad.Catch import Control.Retry (recovering) import Data.Aeson @@ -70,10 +70,13 @@ createBot scon new = do let fprs = toList (sconFingerprints scon) (man, verifyFingerprints) <- view extGetManager extHandleAll onExc $ do - rs <- lift $ recovering x3 httpHandlers $ const $ liftIO - $ withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder - $ \req -> - Http.httpLbs req man + rs <- lift $ + recovering x3 httpHandlers $ + const $ + liftIO $ + withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ + \req -> + Http.httpLbs req man case Bilge.statusCode rs of 201 -> decodeBytes "External" (responseBody rs) 409 -> throwE ServiceBotConflict diff --git a/services/brig/src/Brig/Queue.hs b/services/brig/src/Brig/Queue.hs index bf0f292ae0e..31bf303774d 100644 --- a/services/brig/src/Brig/Queue.hs +++ b/services/brig/src/Brig/Queue.hs @@ -29,7 +29,7 @@ import Brig.Options import qualified Brig.Queue.Stomp as Stomp import Brig.Queue.Types import Control.Exception (ErrorCall (..)) -import Control.Lens ((^.), view) +import Control.Lens (view, (^.)) import Control.Monad.Catch import Data.Aeson import qualified Data.ByteString.Base16 as B16 diff --git a/services/brig/src/Brig/Queue/Stomp.hs b/services/brig/src/Brig/Queue/Stomp.hs index cbb1d3b698b..75d4462876d 100644 --- a/services/brig/src/Brig/Queue/Stomp.hs +++ b/services/brig/src/Brig/Queue/Stomp.hs @@ -94,19 +94,20 @@ enqueue b q m = retryPredicate _ res = pure (isLeft res) retryPolicy = limitRetries 5 <> exponentialBackoff 50000 enqueueAction = - liftIO $ try @StomplException - $ stompTimeout "enqueue" 500000 - $ withConnection' b - $ \conn -> - withWriter - conn - (unpack q) - (unpack q) - [OWithReceipt, OWaitReceipt] - [] - oconv - $ \w -> - writeQ w jsonType [("persistent", "true")] m + liftIO $ + try @StomplException $ + stompTimeout "enqueue" 500000 $ + withConnection' b $ + \conn -> + withWriter + conn + (unpack q) + (unpack q) + [OWithReceipt, OWaitReceipt] + [] + oconv + $ \w -> + writeQ w jsonType [("persistent", "true")] m -- Note [receipts] -- ~~~ @@ -159,7 +160,7 @@ listen b q callback = runInIO $ callback (msgContent m) stompTimeout "listen/ack" 1000000 $ ack conn m handlers = skipAsyncExceptions ++ [logError] - logError = const $ Handler $ \(e :: SomeException) -> do + logError = const . Handler $ \(e :: SomeException) -> do Log.err $ msg (val "Exception when listening to a STOMP queue") ~~ field "queue" (show q) @@ -204,8 +205,10 @@ withConnection' b = -- | Like 'timeout', but throws an 'AppException' instead of returning a -- 'Maybe'. Not very composable, but kinda convenient here. stompTimeout :: String -> Int -> IO a -> IO a -stompTimeout location t act = timeout t act >>= \case - Just x -> pure x - Nothing -> - throwIO $ AppException $ - location <> ": STOMP request took more than " <> show t <> "mcs and has timed out" +stompTimeout location t act = + timeout t act >>= \case + Just x -> pure x + Nothing -> + throwIO $ + AppException $ + location <> ": STOMP request took more than " <> show t <> "mcs and has timed out" diff --git a/services/brig/src/Brig/RPC.hs b/services/brig/src/Brig/RPC.hs index 9dca1c62ebd..1bb3a0f9419 100644 --- a/services/brig/src/Brig/RPC.hs +++ b/services/brig/src/Brig/RPC.hs @@ -35,7 +35,7 @@ import Imports import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), checkResponse) import Network.HTTP.Types.Method import Network.HTTP.Types.Status -import System.Logger.Class hiding ((.=), name) +import System.Logger.Class hiding (name, (.=)) x3 :: RetryPolicy x3 = limitRetries 3 <> exponentialBackoff 100000 @@ -55,9 +55,9 @@ expect ss rq = rq {checkResponse = check} check rq' rs = do let s = responseStatus rs rs' = rs {responseBody = ()} - when (statusIsServerError s || s `notElem` ss) - $ throwM - $ HttpExceptionRequest rq' (StatusCodeException rs' mempty) + when (statusIsServerError s || s `notElem` ss) $ + throwM $ + HttpExceptionRequest rq' (StatusCodeException rs' mempty) cargoholdRequest :: StdMethod -> @@ -85,8 +85,9 @@ serviceRequest :: AppIO (Response (Maybe BL.ByteString)) serviceRequest nm svc m r = do service <- view svc - recovering x3 rpcHandlers $ const $ - rpc' nm service (method m . r) + recovering x3 rpcHandlers $ + const $ + rpc' nm service (method m . r) -- | Failed to parse a response from another service. data ParseException = ParseException diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 4215bd3c223..1c573a72a03 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -27,6 +27,7 @@ import Brig.AWS (sesQueue) import qualified Brig.AWS as AWS import qualified Brig.AWS.SesNotification as SesNotification import Brig.App +import qualified Brig.Calling as Calling import qualified Brig.InternalEvent.Process as Internal import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Queue as Queue @@ -43,22 +44,28 @@ import Network.Wai.Utilities.Server import qualified Network.Wai.Utilities.Server as Server import Util.Options +-- FUTUREWORK: If any of these async threads die, we will have no clue about it +-- and brig could start misbehaving. We should ensure that brig dies whenever a +-- thread terminates for any reason. +-- https://github.com/zinfra/backend-issues/issues/1647 run :: Opts -> IO () run o = do (app, e) <- mkApp o s <- Server.newSettings (server e) internalEventListener <- - Async.async - $ runAppT e - $ Queue.listen (e ^. internalEvents) Internal.onEvent + Async.async $ + runAppT e $ + Queue.listen (e ^. internalEvents) Internal.onEvent let throttleMillis = fromMaybe defSqsThrottleMillis $ setSqsThrottleMillis (optSettings o) emailListener <- for (e ^. awsEnv . sesQueue) $ \q -> - Async.async - $ AWS.execute (e ^. awsEnv) - $ AWS.listen throttleMillis q (runAppT e . SesNotification.onEvent) + Async.async $ + AWS.execute (e ^. awsEnv) $ + AWS.listen throttleMillis q (runAppT e . SesNotification.onEvent) + sftDiscovery <- forM (e ^. sftEnv) $ Async.async . Calling.startSFTServiceDiscovery (e ^. applog) runSettingsWithShutdown s app 5 `finally` do mapM_ Async.cancel emailListener Async.cancel internalEventListener + mapM_ Async.cancel sftDiscovery closeEnv e where endpoint = brig o diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index f35071ea2b7..ee5d7366761 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -25,7 +25,7 @@ import Brig.API.Error import Brig.API.Handler import Brig.API.User (fetchUserIdentity) import qualified Brig.API.User as API -import Brig.App (currentTime, settings) +import Brig.App (AppIO, currentTime, settings) import qualified Brig.Data.Blacklist as Blacklist import Brig.Data.UserKey import qualified Brig.Data.UserKey as Data @@ -41,7 +41,7 @@ import Brig.Types.Team (TeamSize) import Brig.Types.Team.Invitation import Brig.Types.User (Email, InvitationCode, emailIdentity) import qualified Brig.User.Search.Index as ESIndex -import Control.Lens ((^.), view) +import Control.Lens (view, (^.)) import Data.Aeson hiding (json) import Data.ByteString.Conversion import Data.Id @@ -59,7 +59,7 @@ import Network.Wai.Utilities hiding (code, message) import Network.Wai.Utilities.Swagger (document) import qualified Network.Wai.Utilities.Swagger as Doc import qualified Wire.API.Team.Invitation as Public -import qualified Wire.API.User as Public (InvitationCode) +import qualified Wire.API.User as Public routesPublic :: Routes Doc.ApiBuilder Handler () routesPublic = do @@ -204,18 +204,27 @@ createInvitationH (_ ::: uid ::: tid ::: req) = do addHeader "Location" $ "/teams/" <> toByteString' tid <> "/invitations/" <> toByteString' iid +data CreateInvitationInviter = CreateInvitationInviter + { inviterUid :: UserId, + inviterEmail :: Email + } + deriving (Eq, Show) + createInvitation :: UserId -> TeamId -> Public.InvitationRequest -> Handler Public.Invitation createInvitation uid tid body = do - idt <- maybe (throwStd noIdentity) return =<< lift (fetchUserIdentity uid) - from <- maybe (throwStd noEmail) return (emailIdentity idt) let inviteePerms = Team.rolePermissions inviteeRole inviteeRole = fromMaybe Team.defaultRole . irRole $ body - ensurePermissionToAddUser uid tid inviteePerms + inviter <- do + idt <- maybe (throwStd noIdentity) return =<< lift (fetchUserIdentity uid) + from <- maybe (throwStd noEmail) return (emailIdentity idt) + ensurePermissionToAddUser uid tid inviteePerms + pure $ CreateInvitationInviter uid from + -- FUTUREWORK: These validations are nearly copy+paste from accountCreation and -- sendActivationCode. Refactor this to a single place -- Validate e-mail - email <- either (const $ throwStd invalidEmail) return (Email.validateEmail (irEmail body)) + email <- either (const $ throwStd invalidEmail) return (Email.validateEmail (irInviteeEmail body)) let uke = userEmailKey email blacklistedEm <- lift $ Blacklist.exists uke when blacklistedEm $ @@ -224,7 +233,7 @@ createInvitation uid tid body = do when emailTaken $ throwStd emailExists -- Validate phone - phone <- for (irPhone body) $ \p -> do + phone <- for (irInviteePhone body) $ \p -> do validatedPhone <- maybe (throwStd invalidPhone) return =<< lift (Phone.validatePhone p) let ukp = userPhoneKey validatedPhone blacklistedPh <- lift $ Blacklist.exists ukp @@ -238,14 +247,34 @@ createInvitation uid tid body = do pending <- lift $ DB.countInvitations tid when (fromIntegral pending >= maxSize) $ throwStd tooManyTeamInvitations - doInvite inviteeRole email from (irLocale body) (irInviteeName body) phone + + iid <- liftIO DB.mkInvitationId + lift $ doInvite iid inviteeRole inviter (irLocale body) email (irInviteeName body) phone where - doInvite role toEmail from lc toName toPhone = lift $ do + doInvite :: + InvitationId -> + Team.Role -> + CreateInvitationInviter -> + Maybe Public.Locale -> + Email -> + Maybe Public.Name -> + Maybe Public.Phone -> + AppIO Invitation + doInvite iid role inviter lc toEmail toName toPhone = do now <- liftIO =<< view currentTime timeout <- setTeamInvitationTimeout <$> view settings - (newInv, code) <- DB.insertInvitation tid role toEmail now (Just uid) toName toPhone timeout - void $ sendInvitationMail toEmail tid from code lc - return newInv + (newInv, code) <- + DB.insertInvitation + iid + tid + role + now + (Just $ inviterUid inviter) + toEmail + toName + toPhone + timeout + newInv <$ sendInvitationMail toEmail tid (inviterEmail inviter) code lc deleteInvitationH :: JSON ::: UserId ::: TeamId ::: InvitationId -> Handler Response deleteInvitationH (_ ::: uid ::: tid ::: iid) = do diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs index 2b8763ff63b..76a472b768b 100644 --- a/services/brig/src/Brig/Team/DB.hs +++ b/services/brig/src/Brig/Team/DB.hs @@ -44,7 +44,7 @@ import Brig.Types.Common import Brig.Types.Team.Invitation import Brig.Types.User import Cassandra as C -import Data.Conduit ((.|), runConduit) +import Data.Conduit (runConduit, (.|)) import qualified Data.Conduit.List as C import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) @@ -79,21 +79,21 @@ data InvitationByEmail insertInvitation :: MonadClient m => + InvitationId -> TeamId -> Role -> - Email -> UTCTime -> Maybe UserId -> + Email -> Maybe Name -> Maybe Phone -> -- | The timeout for the invitation code. Timeout -> m (Invitation, InvitationCode) -insertInvitation t role email (toUTCTimeMillis -> now) minviter inviteeName phone timeout = do - iid <- liftIO mkInvitationId +insertInvitation iid t role (toUTCTimeMillis -> now) minviter email inviteeName phone timeout = do code <- liftIO mkInvitationCode - let inv = Invitation t role iid email now minviter inviteeName phone - retry x5 $ batch $ do + let inv = Invitation t role iid now minviter email inviteeName phone + retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery cqlInvitation (t, role, iid, code, email, now, minviter, inviteeName, phone, round timeout) @@ -114,13 +114,14 @@ lookupInvitation t r = fmap toInvitation <$> retry x1 (query1 cqlInvitation (params Quorum (t, r))) where - cqlInvitation :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, Email, UTCTimeMillis, Maybe UserId, Maybe Name, Maybe Phone) - cqlInvitation = "SELECT team, role, id, email, created_at, created_by, name, phone FROM team_invitation WHERE team = ? AND id = ?" + cqlInvitation :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, Email, Maybe Name, Maybe Phone) + cqlInvitation = "SELECT team, role, id, created_at, created_by, email, name, phone FROM team_invitation WHERE team = ? AND id = ?" lookupInvitationByCode :: MonadClient m => InvitationCode -> m (Maybe Invitation) -lookupInvitationByCode i = lookupInvitationInfo i >>= \case - Just InvitationInfo {..} -> lookupInvitation iiTeam iiInvId - _ -> return Nothing +lookupInvitationByCode i = + lookupInvitationInfo i >>= \case + Just InvitationInfo {..} -> lookupInvitation iiTeam iiInvId + _ -> return Nothing lookupInvitationCode :: MonadClient m => TeamId -> InvitationId -> m (Maybe InvitationCode) lookupInvitationCode t r = @@ -150,16 +151,16 @@ lookupInvitations team start (fromRange -> size) = do { result = invs, hasMore = more } - cqlSelect :: PrepQuery R (Identity TeamId) (TeamId, Maybe Role, InvitationId, Email, UTCTimeMillis, Maybe UserId, Maybe Name, Maybe Phone) - cqlSelect = "SELECT team, role, id, email, created_at, created_by, name, phone FROM team_invitation WHERE team = ? ORDER BY id ASC" - cqlSelectFrom :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, Email, UTCTimeMillis, Maybe UserId, Maybe Name, Maybe Phone) - cqlSelectFrom = "SELECT team, role, id, email, created_at, created_by, name, phone FROM team_invitation WHERE team = ? AND id > ? ORDER BY id ASC" + cqlSelect :: PrepQuery R (Identity TeamId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, Email, Maybe Name, Maybe Phone) + cqlSelect = "SELECT team, role, id, created_at, created_by, email, name, phone FROM team_invitation WHERE team = ? ORDER BY id ASC" + cqlSelectFrom :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, Email, Maybe Name, Maybe Phone) + cqlSelectFrom = "SELECT team, role, id, created_at, created_by, email, name, phone FROM team_invitation WHERE team = ? AND id > ? ORDER BY id ASC" deleteInvitation :: MonadClient m => TeamId -> InvitationId -> m () deleteInvitation t i = do codeEmail <- lookupInvitationCodeEmail t i case codeEmail of - Just (invCode, invEmail) -> retry x5 $ batch $ do + Just (invCode, invEmail) -> retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery cqlInvitation (t, i) @@ -177,10 +178,10 @@ deleteInvitation t i = do deleteInvitations :: (MonadClient m, MonadUnliftIO m) => TeamId -> m () deleteInvitations t = - liftClient - $ runConduit - $ paginateC cqlSelect (paramsP Quorum (Identity t) 100) x1 - .| C.mapM_ (pooledMapConcurrentlyN_ 16 (deleteInvitation t . runIdentity)) + liftClient $ + runConduit $ + paginateC cqlSelect (paramsP Quorum (Identity t) 100) x1 + .| C.mapM_ (pooledMapConcurrentlyN_ 16 (deleteInvitation t . runIdentity)) where cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId) cqlSelect = "SELECT id FROM team_invitation WHERE team = ? ORDER BY id ASC" @@ -197,9 +198,10 @@ lookupInvitationInfo ic@(InvitationCode c) cqlInvitationInfo = "SELECT team, id FROM team_invitation_info WHERE code = ?" lookupInvitationByEmail :: (Log.MonadLogger m, MonadClient m) => Email -> m (Maybe Invitation) -lookupInvitationByEmail e = lookupInvitationInfoByEmail e >>= \case - InvitationByEmail InvitationInfo {..} -> lookupInvitation iiTeam iiInvId - _ -> return Nothing +lookupInvitationByEmail e = + lookupInvitationInfoByEmail e >>= \case + InvitationByEmail InvitationInfo {..} -> lookupInvitation iiTeam iiInvId + _ -> return Nothing lookupInvitationInfoByEmail :: (Log.MonadLogger m, MonadClient m) => Email -> m InvitationByEmail lookupInvitationInfoByEmail email = do @@ -229,5 +231,16 @@ countInvitations t = -- | brig used to not store the role, so for migration we allow this to be empty and fill in the -- default here. -toInvitation :: (TeamId, Maybe Role, InvitationId, Email, UTCTimeMillis, Maybe UserId, Maybe Name, Maybe Phone) -> Invitation -toInvitation (t, r, i, e, tm, minviter, inviteeName, p) = Invitation t (fromMaybe Team.defaultRole r) i e tm minviter inviteeName p +toInvitation :: + ( TeamId, + Maybe Role, + InvitationId, + UTCTimeMillis, + Maybe UserId, + Email, + Maybe Name, + Maybe Phone + ) -> + Invitation +toInvitation (t, r, i, tm, minviter, e, inviteeName, p) = + Invitation t (fromMaybe Team.defaultRole r) i tm minviter e inviteeName p diff --git a/services/brig/src/Brig/Template.hs b/services/brig/src/Brig/Template.hs index 1751143e23c..91e6e732a7b 100644 --- a/services/brig/src/Brig/Template.hs +++ b/services/brig/src/Brig/Template.hs @@ -79,7 +79,8 @@ readLocalesDir defLocale base typ load = do -- Ignore locales if no such directory exist for the locale ls <- filterM (doesDirectoryExist . basePath) - . filter (/= defLocaleDir) =<< listDirectory base + . filter (/= defLocaleDir) + =<< listDirectory base Map.fromList . zip (map readLocale ls) <$> mapM (load . basePath) ls where basePath :: FilePath -> FilePath diff --git a/services/brig/src/Brig/Unique.hs b/services/brig/src/Brig/Unique.hs index dfa8051cde1..2fc7849d22f 100644 --- a/services/brig/src/Brig/Unique.hs +++ b/services/brig/src/Brig/Unique.hs @@ -96,10 +96,10 @@ deleteClaim u v t = do -- | Lookup the current claims on a value. lookupClaims :: MonadClient m => Text -> m [Id a] lookupClaims v = - fmap (maybe [] (fromSet . runIdentity)) - $ retry x1 - $ query1 cql - $ params Quorum (Identity v) + fmap (maybe [] (fromSet . runIdentity)) $ + retry x1 $ + query1 cql $ + params Quorum (Identity v) where cql :: PrepQuery R (Identity Text) (Identity (C.Set (Id a))) cql = "SELECT claims FROM unique_claims WHERE value = ?" diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index f4a0ec7be2b..251e094d446 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -99,11 +99,12 @@ sendLoginCode phone call force = do return c lookupLoginCode :: Phone -> AppIO (Maybe PendingLoginCode) -lookupLoginCode phone = Data.lookupKey (userPhoneKey phone) >>= \case - Nothing -> return Nothing - Just u -> do - Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.lookupLoginCode") - Data.lookupLoginCode u +lookupLoginCode phone = + Data.lookupKey (userPhoneKey phone) >>= \case + Nothing -> return Nothing + Just u -> do + Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.lookupLoginCode") + Data.lookupLoginCode u login :: Login -> CookieType -> ExceptT LoginError AppIO (Access ZAuth.User) login (PasswordLogin li pw label) typ = do diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index daf97b573ca..037c2b8016b 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -136,20 +136,21 @@ renewCookie old = do -- '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 +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 :: forall u a. ZAuth.TokenPair u a => Cookie (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> AppIO AccessToken newAccessToken c mt = do diff --git a/services/brig/src/Brig/User/Auth/DB/Cookie.hs b/services/brig/src/Brig/User/Auth/DB/Cookie.hs index 9d8dae2a5ca..9654883f479 100644 --- a/services/brig/src/Brig/User/Auth/DB/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/DB/Cookie.hs @@ -88,7 +88,7 @@ listCookies u = } deleteCookies :: MonadClient m => UserId -> [Cookie a] -> m () -deleteCookies u cs = retry x5 $ batch $ do +deleteCookies u cs = retry x5 . batch $ do setType BatchUnLogged setConsistency Quorum for_ cs $ \c -> addPrepQuery cql (u, cookieExpires c, cookieId c) diff --git a/services/brig/src/Brig/User/Event.hs b/services/brig/src/Brig/User/Event.hs index 50569d494ea..6144b9d2555 100644 --- a/services/brig/src/Brig/User/Event.hs +++ b/services/brig/src/Brig/User/Event.hs @@ -20,7 +20,6 @@ module Brig.User.Event where import Brig.Types -import Brig.Types.Intra import Data.Handle (Handle) import Data.Id import Imports @@ -32,10 +31,10 @@ data Event | ClientEvent !ClientEvent data UserEvent - = UserCreated !UserAccount + = UserCreated !User | -- | A user is activated when the first user identity (email address or phone number) -- is verified. {#RefActivationEvent} - UserActivated !UserAccount + UserActivated !User | -- | Account & API access of a user has been suspended. UserSuspended !UserId | -- | Account & API access of a previously suspended user @@ -157,8 +156,8 @@ connEventUserId :: ConnectionEvent -> UserId connEventUserId ConnectionUpdated {..} = ucFrom ucConn userEventUserId :: UserEvent -> UserId -userEventUserId (UserCreated u) = userId (accountUser u) -userEventUserId (UserActivated u) = userId (accountUser u) +userEventUserId (UserCreated u) = userId u +userEventUserId (UserActivated u) = userId u userEventUserId (UserSuspended u) = u userEventUserId (UserResumed u) = u userEventUserId (UserDeleted u) = u diff --git a/services/brig/src/Brig/User/Handle.hs b/services/brig/src/Brig/User/Handle.hs index 40f9b0b3f1c..b04e959bc15 100644 --- a/services/brig/src/Brig/User/Handle.hs +++ b/services/brig/src/Brig/User/Handle.hs @@ -27,52 +27,59 @@ where import Brig.App import Brig.Data.Instances () import qualified Brig.Data.User as User -import Brig.Types.User import Brig.Unique import Cassandra import Data.Handle (Handle, fromHandle) import Data.Id import Imports -claimHandle :: User -> Handle -> AppIO Bool -claimHandle u h = do +-- | Claim a new handle for an existing 'User'. +claimHandle :: UserId -> Maybe Handle -> Handle -> AppIO Bool +claimHandle uid oldHandle newHandle = isJust <$> claimHandleWith (User.updateHandle) uid oldHandle newHandle + +-- | Claim a handle for an invitation or a user. Invitations can be referenced by the coerced +-- 'UserId'. +claimHandleWith :: (UserId -> Handle -> AppIO a) -> UserId -> Maybe Handle -> Handle -> AppIO (Maybe a) +claimHandleWith updOperation uid oldHandle h = do owner <- lookupHandle h case owner of - Just u' | userId u /= u' -> return False + Just uid' | uid /= uid' -> return Nothing _ -> do env <- ask let key = "@" <> fromHandle h - claimed <- withClaim (userId u) key (30 # Minute) - $ runAppT env - $ do - -- Record ownership - retry x5 $ write handleInsert (params Quorum (h, userId u)) - -- Update profile - User.updateHandle (userId u) h - -- Free old handle (if it changed) - for_ (mfilter (/= h) (userHandle u)) $ - freeHandle u - return (isJust claimed) + withClaim uid key (30 # Minute) $ + runAppT env $ + do + -- Record ownership + retry x5 $ write handleInsert (params Quorum (h, uid)) + -- Update profile + result <- updOperation uid h + -- Free old handle (if it changed) + for_ (mfilter (/= h) oldHandle) $ + freeHandle uid + return result -- | Free a 'Handle', making it available to be claimed again. -freeHandle :: User -> Handle -> AppIO () -freeHandle u h = do +freeHandle :: UserId -> Handle -> AppIO () +freeHandle uid h = do retry x5 $ write handleDelete (params Quorum (Identity h)) let key = "@" <> fromHandle h - deleteClaim (userId u) key (30 # Minute) + deleteClaim uid key (30 # Minute) -- | Lookup the current owner of a 'Handle'. lookupHandle :: Handle -> AppIO (Maybe UserId) -lookupHandle h = - join . fmap runIdentity - <$> retry x1 (query1 handleSelect (params Quorum (Identity h))) +lookupHandle = lookupHandleWithPolicy Quorum -- | A weaker version of 'lookupHandle' that trades availability -- (and potentially speed) for the possibility of returning stale data. glimpseHandle :: Handle -> AppIO (Maybe UserId) -glimpseHandle h = +glimpseHandle = lookupHandleWithPolicy One + +{-# INLINE lookupHandleWithPolicy #-} +lookupHandleWithPolicy :: Consistency -> Handle -> AppIO (Maybe UserId) +lookupHandleWithPolicy policy h = do join . fmap runIdentity - <$> retry x1 (query1 handleSelect (params One (Identity h))) + <$> retry x1 (query1 handleSelect (params policy (Identity h))) -------------------------------------------------------------------------------- -- Queries diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index b3ba41883c0..95ceb2ec267 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -82,13 +82,13 @@ import Network.HTTP.Client hiding (path) import Network.HTTP.Types (hContentType, statusCode) import qualified System.Logger as Log import System.Logger.Class - ( (+++), - Logger, + ( Logger, MonadLogger (..), field, info, msg, val, + (+++), (~~), ) @@ -246,30 +246,30 @@ defaultUserQuery u teamSearchInfo (normalized -> term') = mkUserQuery :: UserId -> TeamSearchInfo -> ES.Query -> IndexQuery Contact mkUserQuery (review _TextId -> self) teamSearchInfo q = - IndexQuery q - $ ES.Filter . ES.QueryBoolQuery - $ boolQuery - { ES.boolQueryMustNotMatch = [termQ "_id" self], - ES.boolQueryMustMatch = - [ optionallySearchWithinTeam teamSearchInfo, - ES.QueryBoolQuery - boolQuery - { ES.boolQueryShouldMatch = - [ termQ "account_status" "active", - -- Also match entries where the account_status field is not present. - -- These must have been inserted before we added the account_status - -- and at that time we only inserted active users in the first place. - -- This should be unnecessary after re-indexing, but let's be lenient - -- here for a while. - ES.QueryBoolQuery - boolQuery - { ES.boolQueryMustNotMatch = - [ES.QueryExistsQuery (ES.FieldName "account_status")] - } - ] - } - ] - } + IndexQuery q $ + ES.Filter . ES.QueryBoolQuery $ + boolQuery + { ES.boolQueryMustNotMatch = [termQ "_id" self], + ES.boolQueryMustMatch = + [ optionallySearchWithinTeam teamSearchInfo, + ES.QueryBoolQuery + boolQuery + { ES.boolQueryShouldMatch = + [ termQ "account_status" "active", + -- Also match entries where the account_status field is not present. + -- These must have been inserted before we added the account_status + -- and at that time we only inserted active users in the first place. + -- This should be unnecessary after re-indexing, but let's be lenient + -- here for a while. + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustNotMatch = + [ES.QueryExistsQuery (ES.FieldName "account_status")] + } + ] + } + ] + } where termQ f v = ES.TermQuery @@ -477,8 +477,9 @@ updateMapping = liftIndexIO $ do -- FUTUREWORK: check return code (ES.isSuccess) and fail if appropriate. -- But to do that we have to consider the consequences of this failing in our helm chart: -- https://github.com/wireapp/wire-server-deploy/blob/92311d189818ffc5e26ff589f81b95c95de8722c/charts/elasticsearch-index/templates/create-index.yaml - void $ traceES "Put mapping" $ - ES.putMapping idx (ES.MappingName "user") indexMapping + void $ + traceES "Put mapping" $ + ES.putMapping idx (ES.MappingName "user") indexMapping resetIndex :: MonadIndexIO m => @@ -488,9 +489,10 @@ resetIndex :: m () resetIndex settings shardCount = liftIndexIO $ do idx <- asks idxName - gone <- ES.indexExists idx >>= \case - True -> ES.isSuccess <$> traceES "Delete Index" (ES.deleteIndex idx) - False -> return True + gone <- + ES.indexExists idx >>= \case + True -> ES.isSuccess <$> traceES "Delete Index" (ES.deleteIndex idx) + False -> return True if gone then createIndex settings shardCount else throwM (IndexError "Index deletion failed.") @@ -784,10 +786,10 @@ reindexRowToIndexUser (u, mteam, name, t0, status, t1, handle, t2, colour, t4, a then iu & set iuTeam mteam - . set iuName (Just name) - . set iuHandle handle - . set iuColourId (Just colour) - . set iuAccountStatus status + . set iuName (Just name) + . set iuHandle handle + . set iuColourId (Just colour) + . set iuAccountStatus status else iu -- We insert a tombstone-style user here, as it's easier than deleting the old one. diff --git a/services/brig/src/Brig/ZAuth.hs b/services/brig/src/Brig/ZAuth.hs index 1ce133b3814..f357959b8ba 100644 --- a/services/brig/src/Brig/ZAuth.hs +++ b/services/brig/src/Brig/ZAuth.hs @@ -88,7 +88,7 @@ module Brig.ZAuth ) where -import Control.Lens (Lens', (^.), makeLenses, over) +import Control.Lens (Lens', makeLenses, over, (^.)) import Control.Monad.Catch import Data.Aeson import Data.Bits @@ -292,51 +292,58 @@ instance UserTokenLike LegalHoldUser where mkUserToken' :: MonadZAuth m => UserId -> Word32 -> UTCTime -> m UserToken mkUserToken' u r t = liftZAuth $ do z <- ask - liftIO $ ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ - ZC.newToken (utcTimeToPOSIXSeconds t) U Nothing (mkUser (toUUID u) r) + liftIO $ + ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ + ZC.newToken (utcTimeToPOSIXSeconds t) U Nothing (mkUser (toUUID u) r) newUserToken' :: MonadZAuth m => UserId -> m UserToken newUserToken' u = liftZAuth $ do z <- ask r <- liftIO randomValue - liftIO $ ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ - let UserTokenTimeout ttl = z ^. settings . userTokenTimeout - in ZC.userToken ttl (toUUID u) r + liftIO $ + ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ + let UserTokenTimeout ttl = z ^. settings . userTokenTimeout + in ZC.userToken ttl (toUUID u) r newSessionToken' :: MonadZAuth m => UserId -> m UserToken newSessionToken' u = liftZAuth $ do z <- ask r <- liftIO randomValue - liftIO $ ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ - let SessionTokenTimeout ttl = z ^. settings . sessionTokenTimeout - in ZC.sessionToken ttl (toUUID u) r + liftIO $ + ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ + let SessionTokenTimeout ttl = z ^. settings . sessionTokenTimeout + in ZC.sessionToken ttl (toUUID u) r newAccessToken' :: MonadZAuth m => UserToken -> m AccessToken newAccessToken' xt = liftZAuth $ do z <- ask - liftIO $ ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ - let AccessTokenTimeout ttl = z ^. settings . accessTokenTimeout - in ZC.accessToken1 ttl (xt ^. body . user) + liftIO $ + ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ + let AccessTokenTimeout ttl = z ^. settings . accessTokenTimeout + in ZC.accessToken1 ttl (xt ^. body . user) renewAccessToken' :: MonadZAuth m => AccessToken -> m AccessToken renewAccessToken' old = liftZAuth $ do z <- ask - liftIO $ ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ - let AccessTokenTimeout ttl = z ^. settings . accessTokenTimeout - in ZC.renewToken ttl old + liftIO $ + ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ + let AccessTokenTimeout ttl = z ^. settings . accessTokenTimeout + in ZC.renewToken ttl old newBotToken :: MonadZAuth m => ProviderId -> BotId -> ConvId -> m BotToken newBotToken pid bid cid = liftZAuth $ do z <- ask - liftIO $ ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ - ZC.botToken (toUUID pid) (toUUID (botUserId bid)) (toUUID cid) + liftIO $ + ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ + ZC.botToken (toUUID pid) (toUUID (botUserId bid)) (toUUID cid) newProviderToken :: MonadZAuth m => ProviderId -> m ProviderToken newProviderToken pid = liftZAuth $ do z <- ask - liftIO $ ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ - let ProviderTokenTimeout ttl = z ^. settings . providerTokenTimeout - in ZC.providerToken ttl (toUUID pid) + liftIO $ + ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ + let ProviderTokenTimeout ttl = z ^. settings . providerTokenTimeout + in ZC.providerToken ttl (toUUID pid) -- FUTUREWORK: this function is very similar to mkUserToken', -- the differences are @@ -347,30 +354,34 @@ newProviderToken pid = liftZAuth $ do mkLegalHoldUserToken :: MonadZAuth m => UserId -> Word32 -> UTCTime -> m LegalHoldUserToken mkLegalHoldUserToken u r t = liftZAuth $ do z <- ask - liftIO $ ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ - ZC.newToken (utcTimeToPOSIXSeconds t) LU Nothing (mkLegalHoldUser (toUUID u) r) + liftIO $ + ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ + ZC.newToken (utcTimeToPOSIXSeconds t) LU Nothing (mkLegalHoldUser (toUUID u) r) newLegalHoldUserToken :: MonadZAuth m => UserId -> m LegalHoldUserToken newLegalHoldUserToken u = liftZAuth $ do z <- ask r <- liftIO randomValue - liftIO $ ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ - let LegalHoldUserTokenTimeout ttl = z ^. settings . legalHoldUserTokenTimeout - in ZC.legalHoldUserToken ttl (toUUID u) r + liftIO $ + ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ + let LegalHoldUserTokenTimeout ttl = z ^. settings . legalHoldUserTokenTimeout + in ZC.legalHoldUserToken ttl (toUUID u) r newLegalHoldAccessToken :: MonadZAuth m => LegalHoldUserToken -> m LegalHoldAccessToken newLegalHoldAccessToken xt = liftZAuth $ do z <- ask - liftIO $ ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ - let LegalHoldAccessTokenTimeout ttl = z ^. settings . legalHoldAccessTokenTimeout - in ZC.legalHoldAccessToken1 ttl (xt ^. body . legalHoldUser . user) + liftIO $ + ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ + let LegalHoldAccessTokenTimeout ttl = z ^. settings . legalHoldAccessTokenTimeout + in ZC.legalHoldAccessToken1 ttl (xt ^. body . legalHoldUser . user) renewLegalHoldAccessToken :: MonadZAuth m => LegalHoldAccessToken -> m LegalHoldAccessToken renewLegalHoldAccessToken old = liftZAuth $ do z <- ask - liftIO $ ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ - let LegalHoldAccessTokenTimeout ttl = z ^. settings . legalHoldAccessTokenTimeout - in ZC.renewToken ttl old + liftIO $ + ZC.runCreate (z ^. private) (z ^. settings . keyIndex) $ + let LegalHoldAccessTokenTimeout ttl = z ^. settings . legalHoldAccessTokenTimeout + in ZC.renewToken ttl old validateToken :: (MonadZAuth m, ToByteString a) => diff --git a/services/brig/test/integration/API/TURN.hs b/services/brig/test/integration/API/Calling.hs similarity index 75% rename from services/brig/test/integration/API/TURN.hs rename to services/brig/test/integration/API/Calling.hs index a7804c6e65d..b36a2182270 100644 --- a/services/brig/test/integration/API/TURN.hs +++ b/services/brig/test/integration/API/Calling.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -15,37 +17,46 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module API.TURN where +module API.Calling where import Bilge import Bilge.Assert +import qualified Brig.Options as Opts import Brig.Types -import Control.Lens ((^.)) +import Control.Lens (view, (?~), (^.)) +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Data.Bifunctor (Bifunctor (first)) import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as LB import Data.Id import Data.List ((\\)) +import qualified Data.List.NonEmpty as NonEmpty import Data.List1 (List1) import qualified Data.List1 as List1 -import Data.Misc (Port) +import Data.Misc (Port, mkHttpsUrl) +import qualified Data.Set as Set import Imports import Network.HTTP.Client (Manager) import System.FilePath (()) import Test.Tasty import Test.Tasty.HUnit +import URI.ByteString (laxURIParserOptions, parseURI) import UnliftIO.Exception (finally) import qualified UnliftIO.Temporary as Temp import Util +import Wire.API.Call.Config -tests :: Manager -> Brig -> FilePath -> FilePath -> IO TestTree -tests m b turn turnV2 = do +tests :: Manager -> Brig -> Opts.Opts -> FilePath -> FilePath -> IO TestTree +tests m b opts turn turnV2 = do return $ - testGroup - "turn" - [ 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" . withTurnFile turn $ testCallsConfigMultiple b, - test m "multiple servers /calls/config/v2 - 200" . withTurnFile turnV2 $ testCallsConfigMultipleV2 b + testGroup "calling" $ + [ testGroup "turn" $ + [ 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" . withTurnFile turn $ testCallsConfigMultiple b, + test m "multiple servers /calls/config/v2 - 200" . withTurnFile turnV2 $ testCallsConfigMultipleV2 b + ], + testGroup "sft" $ [test m "SFT servers /calls/config/v2 - 200" $ testSFT b opts] ] testCallsConfig :: Brig -> Http () @@ -75,6 +86,26 @@ testCallsConfigMultiple b turnUpdater = do let _expected = List1.singleton (toTurnURILegacy "127.0.0.1" 3478) modifyAndAssert b uid getTurnConfigurationV1 turnUpdater "turn:127.0.0.1:3478" _expected +testSFT :: Brig -> Opts.Opts -> Http () +testSFT b opts = do + uid <- userId <$> randomUser b + cfg <- getTurnConfigurationV2 uid b + liftIO $ + assertEqual + "when SFT discovery is not enabled, sft_servers shouldn't be returned" + Nothing + (cfg ^. rtcConfSftServers) + withSettingsOverrides (opts & Opts.sftL ?~ Opts.SFTOptions "integration-tests.zinfra.io" Nothing (Just 0.001)) $ do + cfg1 <- retryWhileN 10 (isNothing . view rtcConfSftServers) (getTurnConfigurationV2 uid b) + -- These values are controlled by https://github.com/zinfra/cailleach/tree/77ca2d23cf2959aa183dd945d0a0b13537a8950d/environments/dns-integration-tests + let Right server1 = mkHttpsUrl =<< first show (parseURI laxURIParserOptions "https://sft01.integration-tests.zinfra.io:443") + let Right server2 = mkHttpsUrl =<< first show (parseURI laxURIParserOptions "https://sft02.integration-tests.zinfra.io:8443") + liftIO $ + assertEqual + "when SFT discovery is enabled, sft_servers should be returned" + (Set.fromList [sftServer server1, sftServer server2]) + (Set.fromList $ maybe [] NonEmpty.toList $ cfg1 ^. rtcConfSftServers) + modifyAndAssert :: Brig -> UserId -> @@ -150,10 +181,10 @@ assertConfiguration cfg turns = getTurnConfigurationV1 :: UserId -> Brig -> Http RTCConfiguration getTurnConfigurationV1 = getAndValidateTurnConfiguration "" -getTurnConfigurationV2 :: UserId -> Brig -> Http RTCConfiguration +getTurnConfigurationV2 :: HasCallStack => UserId -> Brig -> ((Monad m, MonadHttp m, MonadIO m, MonadCatch m) => m RTCConfiguration) getTurnConfigurationV2 = getAndValidateTurnConfiguration "v2" -getTurnConfiguration :: ByteString -> UserId -> Brig -> Http (Response (Maybe LB.ByteString)) +getTurnConfiguration :: ByteString -> UserId -> Brig -> ((MonadHttp m, MonadIO m) => m (Response (Maybe LB.ByteString))) getTurnConfiguration suffix u b = get ( b @@ -162,7 +193,7 @@ getTurnConfiguration suffix u b = . zConn "conn" ) -getAndValidateTurnConfiguration :: HasCallStack => ByteString -> UserId -> Brig -> Http RTCConfiguration +getAndValidateTurnConfiguration :: HasCallStack => ByteString -> UserId -> Brig -> ((Monad m, MonadIO m, MonadHttp m, MonadThrow m, MonadCatch m) => m RTCConfiguration) getAndValidateTurnConfiguration suffix u b = responseJsonError =<< (getTurnConfiguration suffix u b getHeader "Set-Cookie" _rs now <- liftIO getCurrentTime let ttl = (`diffUTCTime` now) <$> setCookieExpires cok @@ -372,7 +360,7 @@ testUpdateService config db brig = do let newSummary = "short" let newDescr = "looooooooooooong" let newAssets = [] -- TODO - -- Exercise all updateable attributes + -- Exercise all updateable attributes let upd = UpdateService { updateServiceName = Just newName, @@ -1558,7 +1546,8 @@ randServiceKey = liftIO $ do waitFor :: MonadIO m => Timeout -> (a -> Bool) -> m a -> m a waitFor t f ma = do a <- ma - if | f a -> return a + if + | f a -> return a | t <= 0 -> liftIO $ throwM TimedOut | otherwise -> do liftIO $ threadDelay (1 # Second) @@ -1600,9 +1589,9 @@ runService config mkApp go = do let defs = Warp.defaultSettings {Warp.settingsPort = botPort config} buf <- liftIO newChan srv <- - liftIO . Async.async - $ Warp.runTLS tlss defs - $ mkApp buf + liftIO . Async.async $ + Warp.runTLS tlss defs $ + mkApp buf go buf `finally` liftIO (Async.cancel srv) data TestBot = TestBot @@ -1667,48 +1656,52 @@ defServiceApp buf = k $ responseLBS status200 [] "success" wsAssertMemberJoin :: MonadIO m => WS.WebSocket -> ConvId -> UserId -> [UserId] -> m () -wsAssertMemberJoin ws conv usr new = void $ liftIO - $ WS.assertMatch (5 # Second) ws - $ \n -> do - let e = List1.head (unpackEvents n) - ntfTransient n @?= False - evtConv e @?= conv - evtType e @?= MemberJoin - evtFrom e @?= usr - evtData e @?= Just (EdMembersJoin (SimpleMembers (fmap (\u -> SimpleMember u roleNameWireAdmin) new))) +wsAssertMemberJoin ws conv usr new = void $ + liftIO $ + WS.assertMatch (5 # Second) ws $ + \n -> do + let e = List1.head (unpackEvents n) + ntfTransient n @?= False + evtConv e @?= conv + evtType e @?= MemberJoin + evtFrom e @?= usr + evtData e @?= Just (EdMembersJoin (SimpleMembers (fmap (\u -> SimpleMember u roleNameWireAdmin) new))) wsAssertMemberLeave :: MonadIO m => WS.WebSocket -> ConvId -> UserId -> [UserId] -> m () -wsAssertMemberLeave ws conv usr old = void $ liftIO - $ WS.assertMatch (5 # Second) ws - $ \n -> do - let e = List1.head (unpackEvents n) - ntfTransient n @?= False - evtConv e @?= conv - evtType e @?= MemberLeave - evtFrom e @?= usr - evtData e @?= Just (EdMembersLeave (UserIdList old)) +wsAssertMemberLeave ws conv usr old = void $ + liftIO $ + WS.assertMatch (5 # Second) ws $ + \n -> do + let e = List1.head (unpackEvents n) + ntfTransient n @?= False + evtConv e @?= conv + evtType e @?= MemberLeave + evtFrom e @?= usr + evtData e @?= Just (EdMembersLeave (UserIdList old)) wsAssertConvDelete :: MonadIO m => WS.WebSocket -> ConvId -> UserId -> m () -wsAssertConvDelete ws conv from = void $ liftIO - $ WS.assertMatch (5 # Second) ws - $ \n -> do - let e = List1.head (WS.unpackPayload n) - ntfTransient n @?= False - evtConv e @?= conv - evtType e @?= ConvDelete - evtFrom e @?= from - evtData e @?= Nothing +wsAssertConvDelete ws conv from = void $ + liftIO $ + WS.assertMatch (5 # Second) ws $ + \n -> do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= conv + evtType e @?= ConvDelete + evtFrom e @?= from + evtData e @?= Nothing wsAssertMessage :: MonadIO m => WS.WebSocket -> ConvId -> UserId -> ClientId -> ClientId -> Text -> m () -wsAssertMessage ws conv fromu fromc to txt = void $ liftIO - $ WS.assertMatch (5 # Second) ws - $ \n -> do - let e = List1.head (unpackEvents n) - ntfTransient n @?= False - evtConv e @?= conv - evtType e @?= OtrMessageAdd - evtFrom e @?= fromu - evtData e @?= Just (EdOtrMessage (OtrMessage fromc to txt (Just "data"))) +wsAssertMessage ws conv fromu fromc to txt = void $ + liftIO $ + WS.assertMatch (5 # Second) ws $ + \n -> do + let e = List1.head (unpackEvents n) + ntfTransient n @?= False + evtConv e @?= conv + evtType e @?= OtrMessageAdd + evtFrom e @?= fromu + evtData e @?= Just (EdOtrMessage (OtrMessage fromc to txt (Just "data"))) svcAssertMemberJoin :: MonadIO m => Chan TestBotEvent -> UserId -> [UserId] -> ConvId -> m () svcAssertMemberJoin buf usr new cnv = liftIO $ do diff --git a/services/brig/test/integration/API/RichInfo/Util.hs b/services/brig/test/integration/API/RichInfo/Util.hs index 782ab54a2f6..63a5643a9ac 100644 --- a/services/brig/test/integration/API/RichInfo/Util.hs +++ b/services/brig/test/integration/API/RichInfo/Util.hs @@ -40,7 +40,8 @@ getRichInfo brig self uid = do . paths ["users", toByteString' uid, "rich-info"] . zUser self ) - if | statusCode r == 200 -> Right <$> responseJsonError r + if + | statusCode r == 200 -> Right <$> responseJsonError r | statusCode r `elem` [403, 404] -> pure . Left . statusCode $ r | otherwise -> error $ diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index 31873c5ffc8..7574a5be620 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -32,7 +32,7 @@ import Control.Lens ((.~), (?~), (^.)) import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Fail (MonadFail) import Control.Retry -import Data.Aeson ((.=), FromJSON, Value) +import Data.Aeson (FromJSON, Value, (.=)) import qualified Data.Aeson as Aeson import Data.Handle (fromHandle) import Data.Id @@ -41,8 +41,8 @@ import qualified Data.Text as Text import qualified Database.Bloodhound as ES import qualified Galley.Types.Teams.SearchVisibility as Team import Imports -import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client (Manager) +import qualified Network.HTTP.Client as HTTP import qualified Network.Wai.Test as WaiTest import Test.Tasty import Test.Tasty.HUnit @@ -53,9 +53,9 @@ import Wire.API.Team.Feature (TeamFeatureStatusValue (..)) tests :: Opt.Opts -> Manager -> Galley -> Brig -> IO TestTree tests opts mgr galley brig = do testSetupOutboundOnly <- runHttpT mgr prepareUsersForSearchVisibilityNoNameOutsideTeamTests - return - $ testGroup "search" - $ [ testWithBothIndices opts mgr "by-name" $ testSearchByName brig, + return $ + testGroup "search" $ + [ testWithBothIndices opts mgr "by-name" $ testSearchByName brig, testWithBothIndices opts mgr "by-handle" $ testSearchByHandle brig, test mgr "reindex" $ testReindex brig, testWithBothIndices opts mgr "no match" $ testSearchNoMatch brig, diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 0073cedfb70..1a83cdad7af 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -118,10 +118,11 @@ testTeamSize brig = do assertSize tid expectedSize where assertSize :: HasCallStack => TeamId -> Natural -> Http () - assertSize tid expectedSize = void $ - get (brig . paths ["i", "teams", toByteString' tid, "size"]) Http () testInvitationEmail brig = do (inviter, tid) <- createUserWithTeam brig - invitee <- randomEmail - let invite = stdInvitationRequest invitee (Name "Bob") Nothing Nothing + invite <- stdInvitationRequest <$> randomEmail void $ postInvitation brig tid inviter invite testInvitationEmailLookup :: Brig -> Http () @@ -171,12 +171,12 @@ testInvitationEmailLookup brig = do -- expect no invitation to be found for an email before that person is invited headInvitationByEmail brig email 404 (uid, tid) <- createUserWithTeam brig - let invite = stdInvitationRequest email (Name "Bob") Nothing Nothing + let invite = stdInvitationRequest email void $ postInvitation brig tid uid invite -- expect an invitation to be found querying with email after invite headInvitationByEmail brig email 200 (uid2, tid2) <- createUserWithTeam brig - let invite2 = stdInvitationRequest email (Name "Bob2") Nothing Nothing + let invite2 = stdInvitationRequest email void $ postInvitation brig tid2 uid2 invite2 -- expect a 409 conflict result for a second team inviting the same user headInvitationByEmail brig email 409 @@ -185,7 +185,7 @@ testInvitationEmailLookupRegister :: Brig -> Http () testInvitationEmailLookupRegister brig = do email <- randomEmail (owner, tid) <- createUserWithTeam brig - let invite = stdInvitationRequest email (Name "Bob") Nothing Nothing + let invite = stdInvitationRequest email void $ postInvitation brig tid owner invite inv :: Invitation <- responseJsonError =<< postInvitation brig tid owner invite -- expect an invitation to be found querying with email after invite @@ -200,7 +200,7 @@ testInvitationEmailLookupNginz brig nginz = do -- expect no invitation to be found for an email before that person is invited headInvitationByEmail nginz email 404 (uid, tid) <- createUserWithTeam brig - let invite = stdInvitationRequest email (Name "Bob") Nothing Nothing + let invite = stdInvitationRequest email void $ postInvitation brig tid uid invite -- expect an invitation to be found querying with email after invite headInvitationByEmail nginz email 200 @@ -214,13 +214,11 @@ testInvitationTooManyPending :: Brig -> TeamSizeLimit -> Http () testInvitationTooManyPending brig (TeamSizeLimit limit) = do (inviter, tid) <- createUserWithTeam brig emails <- replicateConcurrently (fromIntegral limit) randomEmail - let invite e = stdInvitationRequest e (Name "Bob") Nothing Nothing - pooledForConcurrentlyN_ 16 emails $ \email -> - postInvitation brig tid inviter (invite email) - e <- randomEmail + pooledForConcurrentlyN_ 16 emails $ postInvitation brig tid inviter . stdInvitationRequest + email <- randomEmail -- TODO: If this test takes longer to run than `team-invitation-timeout`, then some of the -- invitations have likely expired already and this test will actually _fail_ - postInvitation brig tid inviter (invite e) !!! do + postInvitation brig tid inviter (stdInvitationRequest email) !!! do const 403 === statusCode const (Just "too-many-team-invitations") === fmap Error.label . responseJsonMaybe @@ -244,13 +242,13 @@ testInvitationRoles brig galley = do -- owner creates a member alice. alice :: UserId <- do aliceEmail <- randomEmail - let invite = stdInvitationRequest aliceEmail (Name "Alice") Nothing (Just Team.RoleAdmin) + let invite = stdInvitationRequest' Nothing (Just Team.RoleAdmin) aliceEmail inv :: Invitation <- responseJsonError =<< postInvitation brig tid owner invite registerInvite brig tid inv aliceEmail -- alice creates a external partner bob. success! bob only has externalPartner perms. do bobEmail <- randomEmail - let invite = stdInvitationRequest bobEmail (Name "Bob") Nothing (Just Team.RoleExternalPartner) + let invite = stdInvitationRequest' Nothing (Just Team.RoleExternalPartner) bobEmail inv :: Invitation <- responseJsonError =<< ( postInvitation brig tid alice invite Galley -> Http () testInvitationEmailAccepted brig galley = do inviteeEmail <- randomEmail - let invite = stdInvitationRequest inviteeEmail (Name "Bob") Nothing Nothing - void $ createAndVerifyInvitation (accept (irEmail invite)) invite brig galley + let invite = stdInvitationRequest inviteeEmail + void $ createAndVerifyInvitation (accept (irInviteeEmail invite)) invite brig galley -- | Related: 'testDomainsBlockedForRegistration'. When we remove the customer-specific -- extension of domain blocking, this test will fail to compile (so you will know it's time to @@ -282,18 +280,18 @@ testInvitationEmailAccepted brig galley = do testInvitationEmailAcceptedInBlockedDomain :: Opt.Opts -> Brig -> Galley -> Http () testInvitationEmailAcceptedInBlockedDomain opts brig galley = do inviteeEmail :: Email <- randomEmail - let invite = stdInvitationRequest inviteeEmail (Name "Bob") Nothing Nothing + let invite = stdInvitationRequest inviteeEmail replacementBrigApp = withDomainsBlockedForRegistration opts [emailDomain inviteeEmail] - void $ createAndVerifyInvitation' (Just replacementBrigApp) (accept (irEmail invite)) invite brig galley + void $ createAndVerifyInvitation' (Just replacementBrigApp) (accept (irInviteeEmail invite)) invite brig galley testInvitationEmailAndPhoneAccepted :: Brig -> Galley -> Http () testInvitationEmailAndPhoneAccepted brig galley = do inviteeEmail <- randomEmail inviteePhone <- randomPhone -- Prepare the extended invitation - let stdInvite = stdInvitationRequest inviteeEmail (Name "Bob") Nothing Nothing + let stdInvite = stdInvitationRequest inviteeEmail inviteeName = Name "Invited Member" - extInvite = stdInvite {irPhone = Just inviteePhone, irInviteeName = Just inviteeName} + extInvite = stdInvite {irInviteePhone = Just inviteePhone, irInviteeName = Just inviteeName} -- Register the same (pre verified) phone number let phoneReq = RequestBodyLBS . encode $ object ["phone" .= fromPhone inviteePhone] post (brig . path "/activate/send" . contentJson . body phoneReq) !!! (const 200 === statusCode) @@ -303,7 +301,7 @@ testInvitationEmailAndPhoneAccepted brig galley = do liftIO $ assertEqual "Wrong name in profile" (Just inviteeName) (userDisplayName . selfUser <$> profile) liftIO $ assertEqual "Wrong name in invitation" (Just inviteeName) (inInviteeName invitation) liftIO $ assertEqual "Wrong phone number in profile" (Just inviteePhone) (join (userPhone . selfUser <$> profile)) - liftIO $ assertEqual "Wrong phone number in invitation" (Just inviteePhone) (inPhone invitation) + liftIO $ assertEqual "Wrong phone number in invitation" (Just inviteePhone) (inInviteePhone invitation) -- | FUTUREWORK: this is an alternative helper to 'createPopulatedBindingTeam'. it has been -- added concurrently, and the two should probably be consolidated. @@ -390,7 +388,7 @@ testCreateTeam brig galley aws = do liftIO $ assertBool "Member not part of the team" (uid == mem ^. Team.userId) -- Verify that the user cannot send invitations before activating their account inviteeEmail <- randomEmail - let invite = stdInvitationRequest inviteeEmail (Name "Bob") Nothing Nothing + let invite = stdInvitationRequest inviteeEmail postInvitation brig (team ^. Team.teamId) uid invite !!! const 403 === statusCode -- Verify that the team is still in status "pending" team2 <- getTeam galley (team ^. Team.teamId) @@ -426,7 +424,7 @@ testCreateTeamPreverified brig galley aws = do liftIO $ assertEqual "Team should already be active" Team.Active (Team.tdStatus team2) -- Verify that the user can already send invitations before activating their account inviteeEmail <- randomEmail - let invite = stdInvitationRequest inviteeEmail (Name "Bob") Nothing Nothing + let invite = stdInvitationRequest inviteeEmail postInvitation brig (team ^. Team.teamId) uid invite !!! const 201 === statusCode testInvitationNoPermission :: Brig -> Http () @@ -434,7 +432,7 @@ testInvitationNoPermission brig = do (_, tid) <- createUserWithTeam brig alice <- userId <$> randomUser brig email <- randomEmail - let invite = stdInvitationRequest email (Name "Bob") Nothing Nothing + let invite = stdInvitationRequest email postInvitation brig tid alice invite !!! do const 403 === statusCode const (Just "insufficient-permissions") === fmap Error.label . responseJsonMaybe @@ -474,9 +472,9 @@ testTeamNoPassword brig = do testInvitationCodeExists :: Brig -> Http () testInvitationCodeExists brig = do - email <- randomEmail (uid, tid) <- createUserWithTeam brig - let invite email_ = stdInvitationRequest email_ (Name "Bob") Nothing Nothing + let invite email = stdInvitationRequest email + email <- randomEmail rsp <- postInvitation brig tid uid (invite email) responseJsonMaybe rsp Just invCode <- getInvitationCode brig tid invId @@ -556,14 +554,14 @@ testInvitationTooManyMembers brig galley (TeamSizeLimit limit) = do pooledForConcurrentlyN_ 16 [1 .. limit -1] $ \_ -> do void $ createTeamMember brig galley creator tid Team.fullPermissions SearchUtil.refreshIndex brig - em <- randomEmail - let invite = stdInvitationRequest em (Name "Bob") Nothing Nothing - inv <- responseJsonError =<< postInvitation brig tid creator invite + let invite email = stdInvitationRequest email + email <- randomEmail + inv <- responseJsonError =<< postInvitation brig tid creator (invite email) Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) post ( brig . path "/register" . contentJson - . body (accept em inviteeCode) + . body (accept email inviteeCode) ) !!! do const 403 === statusCode @@ -574,7 +572,7 @@ testInvitationPaging brig = do before <- liftIO $ toUTCTimeMillis . addUTCTime (-1) <$> getCurrentTime (uid, tid) <- createUserWithTeam brig let total = 5 - invite email = stdInvitationRequest email (Name "Bob") Nothing Nothing + invite email = stdInvitationRequest email emails <- replicateM total $ do email <- randomEmail postInvitation brig tid uid (invite email) !!! const 201 === statusCode @@ -595,7 +593,7 @@ testInvitationPaging brig = do validateInv :: Invitation -> Assertion validateInv inv = do assertEqual "tid" tid (inTeam inv) - assertBool "email" (inIdentity inv `elem` emails) + assertBool "email" (inInviteeEmail inv `elem` emails) -- (the output list is not ordered chronologically and emails are unique, so we just -- check whether the email is one of the valid ones.) assertBool "timestamp" (inCreatedAt inv > before && inCreatedAt inv < after1ms) @@ -610,7 +608,7 @@ testInvitationInfo :: Brig -> Http () testInvitationInfo brig = do email <- randomEmail (uid, tid) <- createUserWithTeam brig - let invite = stdInvitationRequest email (Name "Bob") Nothing Nothing + let invite = stdInvitationRequest email inv <- responseJsonError =<< postInvitation brig tid uid invite Just invCode <- getInvitationCode brig tid (inInvitation inv) Just invitation <- getInvitation brig invCode @@ -627,7 +625,7 @@ testInvitationInfoExpired :: Brig -> Opt.Timeout -> Http () testInvitationInfoExpired brig timeout = do email <- randomEmail (uid, tid) <- createUserWithTeam brig - let invite = stdInvitationRequest email (Name "Bob") Nothing Nothing + let invite = stdInvitationRequest email inv <- responseJsonError =<< postInvitation brig tid uid invite -- Note: This value must be larger than the option passed as `team-invitation-timeout` awaitExpiry (round timeout + 5) tid (inInvitation inv) @@ -654,7 +652,7 @@ testSuspendTeam brig = do inviteeEmail2 <- randomEmail (inviter, tid) <- createUserWithTeam brig -- invite and register invitee - let invite = stdInvitationRequest inviteeEmail (Name "Bob") Nothing Nothing + let invite = stdInvitationRequest inviteeEmail inv <- responseJsonError =<< postInvitation brig tid inviter invite Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) rsp2 <- @@ -666,7 +664,8 @@ testSuspendTeam brig = do responseJsonMaybe rsp2 -- invite invitee2 (don't register) - let invite2 = stdInvitationRequest inviteeEmail2 (Name "Bob") Nothing Nothing + let invite2 = stdInvitationRequest inviteeEmail2 + inv2 <- responseJsonError =<< postInvitation brig tid inviter invite2 Just _ <- getInvitationCode brig tid (inInvitation inv2) -- suspend team @@ -765,9 +764,10 @@ testCreateUserInternalSSO brig galley = do postUser' True False "dummy" True False Nothing (Just teamid) brig !!! const 400 === statusCode -- creating user with sso_id, team_id is ok - resp <- postUser "dummy" True False (Just ssoid) (Just teamid) brig responseJsonMaybe resp profile <- getSelfProfile brig uid diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 65439f284d6..107ac430dba 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -84,7 +84,7 @@ createPopulatedBindingTeamWithNames brig names = do (inviter, tid) <- createUserWithTeam' brig invitees <- forM names $ \name -> do inviteeEmail <- randomEmail - let invite = stdInvitationRequest inviteeEmail name Nothing Nothing + let invite = stdInvitationRequest inviteeEmail inv <- responseJsonError =<< postInvitation brig tid (userId inviter) invite Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) rsp2 <- @@ -113,9 +113,9 @@ createTeam u galley = do . expect2xx . lbytes (encode newTeam) ) - maybe (error "invalid team id") return - $ fromByteString - $ getHeader' "Location" r + maybe (error "invalid team id") return $ + fromByteString $ + getHeader' "Location" r -- | Create user and binding team. -- @@ -170,7 +170,7 @@ inviteAndRegisterUser :: m User inviteAndRegisterUser u tid brig = do inviteeEmail <- randomEmail - let invite = stdInvitationRequest inviteeEmail (Name "Bob") Nothing Nothing + let invite = stdInvitationRequest inviteeEmail inv <- responseJsonError =<< postInvitation brig tid u invite Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) rspInvitee <- @@ -218,9 +218,9 @@ createTeamConv g tid u us mtimer = do ) Galley -> TeamId -> UserId -> [UserId] -> Maybe Milliseconds -> Http ConvId @@ -240,9 +240,9 @@ createManagedConv g tid u us mtimer = do ) Galley -> TeamId -> ConvId -> UserId -> Http () deleteTeamConv g tid cid u = do @@ -437,9 +437,12 @@ isActivatedUser uid brig = do Just (_ : _) -> True _ -> False -stdInvitationRequest :: Email -> Name -> Maybe Locale -> Maybe Team.Role -> InvitationRequest -stdInvitationRequest e inviterName loc role = - InvitationRequest e inviterName loc role Nothing Nothing +stdInvitationRequest :: Email -> InvitationRequest +stdInvitationRequest = stdInvitationRequest' Nothing Nothing + +stdInvitationRequest' :: Maybe Locale -> Maybe Team.Role -> Email -> InvitationRequest +stdInvitationRequest' loc role email = + InvitationRequest loc role Nothing email Nothing setTeamTeamSearchVisibilityAvailable :: HasCallStack => Galley -> TeamId -> TeamFeatureStatusValue -> Http () setTeamTeamSearchVisibilityAvailable galley tid status = diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index e07fb265629..aba28d05f29 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -530,7 +530,7 @@ testUserUpdate brig cannon aws = do fmap userAssets u ) ) - . responseJsonMaybe + . responseJsonMaybe -- get only the new name get (brig . path "/self/name" . zUser alice) !!! do const 200 === statusCode @@ -842,7 +842,7 @@ testEmailPhoneDelete brig cannon = do WS.bracketR cannon uid $ \ws -> do delete (brig . path "/self/email" . zUser uid . zConn "c") !!! (const 200 === statusCode) - void . liftIO $ WS.assertMatch (5 # Second) ws $ \n -> do + void . liftIO . WS.assertMatch (5 # Second) ws $ \n -> do let j = Object $ List1.head (ntfPayload n) let etype = j ^? key "type" . _String let euser = j ^? key "user" . key "id" . _String @@ -869,7 +869,7 @@ testEmailPhoneDelete brig cannon = do WS.bracketR cannon uid $ \ws -> do delete (brig . path "/self/phone" . zUser uid . zConn "c") !!! const 200 === statusCode - void . liftIO $ WS.assertMatch (5 # Second) ws $ \n -> do + void . liftIO . WS.assertMatch (5 # Second) ws $ \n -> do let j = Object $ List1.head (ntfPayload n) let etype = j ^? key "type" . _String let euser = j ^? key "user" . key "id" . _String @@ -921,9 +921,10 @@ testDeleteUserByPassword brig cannon aws = do act <- getActivationCode brig (Left eml) case act of Nothing -> liftIO $ assertFailure "missing activation key/code" - Just kc -> activate brig kc !!! do - const 404 === statusCode - const (Just "invalid-code") === fmap Error.label . responseJsonMaybe + Just kc -> + activate brig kc !!! do + const 404 === statusCode + const (Just "invalid-code") === fmap Error.label . responseJsonMaybe -- Connections involving uid1 are gone (uid2 <-> uid3 remains) let u1Conns = UserConnectionList [] False let u2Conns = UserConnectionList (maybeToList (responseJsonMaybe con23)) False @@ -1078,14 +1079,6 @@ testRestrictedUserCreation opts brig = do let opts' = opts {Opt.optSettings = (Opt.optSettings opts) {Opt.setRestrictUserCreation = Just True}} withSettingsOverrides opts' $ do e <- randomEmail - -- Ephemeral users MUST have an expires_in - let Object ephemeralUserWithoutExpires = - object - [ "name" .= Name "Alice" - ] - postUserRegister' ephemeralUserWithoutExpires brig !!! do - const 403 === statusCode - const (Just "user-creation-restricted") === (^? AesonL.key "label" . AesonL._String) . (responseJsonUnsafe @Value) let Object regularUser = object @@ -1123,7 +1116,7 @@ testRestrictedUserCreation opts brig = do -- Ensure you can invite team users void $ inviteAndRegisterUser teamOwner createdTeam brig - -- Ephemeral users can always be created + -- Ephemeral users can always be created (expires_in is OPTIONAL) let Object ephemeralUser = object [ "name" .= Name "Alice", @@ -1131,6 +1124,14 @@ testRestrictedUserCreation opts brig = do ] postUserRegister' ephemeralUser brig !!! const 201 === statusCode + -- Ephemeral users can always be created (expires_in is OPTIONAL and + -- used for instance when creating guestrooms + let Object ephemeralUserWithoutExpires = + object + [ "name" .= Name "Alice" + ] + postUserRegister' ephemeralUserWithoutExpires brig !!! const 201 === statusCode + -- NOTE: SSO users are anyway not allowed on the `/register` endpoint teamid <- Id <$> liftIO UUID.nextRandom let ssoid = UserSSOId "nil" "nil" @@ -1156,7 +1157,7 @@ setHandleAndDeleteUser brig cannon u others aws execDelete = do -- Delete the user WS.bracketRN cannon (uid : others) $ \wss -> do execDelete uid - void . liftIO $ WS.assertMatchN (5 # Second) wss $ \n -> do + void . liftIO . WS.assertMatchN (5 # Second) wss $ \n -> do let j = Object $ List1.head (ntfPayload n) let etype = j ^? key "type" . _String let euser = j ^? key "id" . _String @@ -1207,7 +1208,7 @@ setHandleAndDeleteUser brig cannon u others aws execDelete = do userHandle =<< u' ) ) - . responseJsonMaybe + . responseJsonMaybe assertDeletedProfilePublic = do const 200 === statusCode const (Just noPict, Just True, Nothing) @@ -1217,4 +1218,4 @@ setHandleAndDeleteUser brig cannon u others aws execDelete = do profileHandle =<< u' ) ) - . responseJsonMaybe + . responseJsonMaybe diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index 2f96bc96cac..2059a71d956 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -36,7 +36,7 @@ import Brig.Types.User.Auth import qualified Brig.Types.User.Auth as Auth import Brig.ZAuth (ZAuth, runZAuth) import qualified Brig.ZAuth as ZAuth -import Control.Lens ((^.), (^?), set) +import Control.Lens (set, (^.), (^?)) import Control.Retry import Data.Aeson import Data.Aeson.Lens @@ -158,8 +158,9 @@ testNginz b n = do _rs <- get (n . path "/clients" . header "Authorization" ("Bearer " <> (toByteString' t))) liftIO $ assertEqual "Ensure nginz is started. Ensure nginz and brig share the same private/public zauth keys. Ensure ACL file is correct." 200 (statusCode _rs) -- ensure nginz allows refresh at /access - _rs <- post (n . path "/access" . cookie c . header "Authorization" ("Bearer " <> (toByteString' t))) (toByteString' t))) (toByteString' t))) !!! const 200 === statusCode @@ -591,19 +592,21 @@ testNewPersistentCookie config b = do -- Wait for the cookie to be eligible for renewal liftIO $ threadDelay minAge -- Refresh tokens - _rs <- post (b . path "/access" . cookie c) cookie_expiry_time c) -- Refresh with the old cookie should still work for the -- duration of another BRIG_COOKIE_RENEW_AGE seconds, -- but the response should keep advertising the new cookie. - _rs <- post (b . path "/access" . cookie c) do + void . liftIO . WS.assertMatch (5 # Second) ws $ \n -> do let j = Object $ List1.head (ntfPayload n) let etype = j ^? key "type" . _String let eclient = j ^? key "client" @@ -228,7 +228,7 @@ testRemoveClient hasPwd brig cannon = do WS.bracketR cannon uid $ \ws -> do deleteClient brig uid (clientId c) (if hasPwd then Just defPassword else Nothing) !!! const 200 === statusCode - void . liftIO $ WS.assertMatch (5 # Second) ws $ \n -> do + void . liftIO . WS.assertMatch (5 # Second) ws $ \n -> do let j = Object $ List1.head (ntfPayload n) let etype = j ^? key "type" . _String let eclient = j ^? key "client" . key "id" . _String diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 1799f762b45..92f60fae1d8 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -305,9 +305,10 @@ testBadUpdateConnection brig = do assertBadUpdate uid1 uid2 Accepted assertBadUpdate uid2 uid1 Sent where - assertBadUpdate u1 u2 s = putConnection brig u1 u2 s !!! do - const 403 === statusCode - const (Just "bad-conn-update") === fmap Error.label . responseJsonMaybe + assertBadUpdate u1 u2 s = + putConnection brig u1 u2 s !!! do + const 403 === statusCode + const (Just "bad-conn-update") === fmap Error.label . responseJsonMaybe testConnectionPaging :: Brig -> Http () testConnectionPaging b = do @@ -357,11 +358,12 @@ testAutoConnectionOK :: Brig -> Galley -> Http () testAutoConnectionOK brig galley = do uid1 <- userId <$> randomUser brig uid2 <- userId <$> randomUser brig - bdy <- postAutoConnection brig uid1 [uid2] do - b <- responseBody r - Vec.length <$> (decode b :: Maybe (Vector UserConnection)) + bdy <- + postAutoConnection brig uid1 [uid2] do + b <- responseBody r + Vec.length <$> (decode b :: Maybe (Vector UserConnection)) assertConnections brig uid1 [ConnectionStatus uid1 uid2 Accepted] assertConnections brig uid2 [ConnectionStatus uid2 uid1 Accepted] case responseJsonMaybe bdy >>= headMay >>= ucConvId of diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index e5d566690aa..8b38683f68f 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -27,7 +27,7 @@ import Bilge hiding (accept, timeout) import Bilge.Assert import qualified Brig.Options as Opt import Brig.Types -import Control.Lens hiding ((#), from) +import Control.Lens hiding (from, (#)) import Control.Monad.Catch (MonadCatch) import Data.Aeson import Data.Aeson.Lens @@ -75,7 +75,7 @@ testHandleUpdate brig cannon = do WS.bracketR cannon uid $ \ws -> do put (brig . path "/self/handle" . contentJson . zUser uid . zConn "c" . body update) !!! const 200 === statusCode - void . liftIO $ WS.assertMatch (5 # Second) ws $ \n -> do + void . liftIO . WS.assertMatch (5 # Second) ws $ \n -> do let j = Object $ List1.head (ntfPayload n) j ^? key "type" . _String @?= Just "user.update" let u = j ^?! key "user" @@ -126,10 +126,10 @@ testHandleRace brig = do -- 10 races. In each race, 10 users try to claim the same handle. -- At most one of them should get the handle in each race -- (usually no-one due to the contention). - void $ replicateM 10 $ do + void . replicateM 10 $ do hdl <- randomHandle let update = RequestBodyLBS . encode $ HandleUpdate hdl - void $ flip mapConcurrently us $ \u -> + void . flip mapConcurrently us $ \u -> put (brig . path "/self/handle" . contentJson . zUser u . zConn "c" . body update) ps <- forM us $ \u -> responseJsonMaybe <$> get (brig . path "/self" . zUser u) let owners = catMaybes $ filter (maybe False ((== Just (Handle hdl)) . userHandle)) ps diff --git a/services/brig/test/integration/API/User/RichInfo.hs b/services/brig/test/integration/API/User/RichInfo.hs index 9b0fcef4003..d2facf6849e 100644 --- a/services/brig/test/integration/API/User/RichInfo.hs +++ b/services/brig/test/integration/API/User/RichInfo.hs @@ -116,9 +116,10 @@ testRichInfoSizeLimit brig conf = do RichInfoAssocList [ RichField "department" (Text.replicate (fromIntegral maxSize) "#") ] - bad2 = RichInfoAssocList $ - [0 .. ((maxSize `div` 2))] - <&> \i -> RichField (CI.mk $ Text.pack $ show i) "#" + bad2 = + RichInfoAssocList $ + [0 .. ((maxSize `div` 2))] + <&> \i -> RichField (CI.mk $ Text.pack $ show i) "#" putRichInfo brig owner bad1 !!! const 413 === statusCode putRichInfo brig owner bad2 !!! const 413 === statusCode diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 433842a5c06..01256e41418 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -28,7 +28,7 @@ import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.Types.User.Auth hiding (user) import qualified CargoHold.Types.V3 as CHV3 import qualified Codec.MIME.Type as MIME -import Control.Lens ((^?), preview) +import Control.Lens (preview, (^?)) import Control.Monad.Catch (MonadCatch) import Data.Aeson import Data.Aeson.Lens @@ -131,9 +131,10 @@ activateEmail brig email = do act <- getActivationCode brig (Left email) case act of Nothing -> liftIO $ assertFailure "missing activation key/code" - Just kc -> activate brig kc !!! do - const 200 === statusCode - const (Just False) === fmap activatedFirst . responseJsonMaybe + Just kc -> + activate brig kc !!! do + const 200 === statusCode + const (Just False) === fmap activatedFirst . responseJsonMaybe checkEmail :: HasCallStack => Brig -> UserId -> Email -> HttpT IO () checkEmail brig uid expectedEmail = @@ -254,9 +255,10 @@ countCookies brig u label = do return $ Vec.length <$> (preview (key "cookies" . _Array) =<< responseJsonMaybe @Value r) assertConnections :: HasCallStack => Brig -> UserId -> [ConnectionStatus] -> Http () -assertConnections brig u cs = listConnections brig u !!! do - const 200 === statusCode - const (Just True) === fmap (check . map status . clConnections) . responseJsonMaybe +assertConnections brig u cs = + listConnections brig u !!! do + const 200 === statusCode + const (Just True) === fmap (check . map status . clConnections) . responseJsonMaybe where check xs = all (`elem` xs) cs status c = ConnectionStatus (ucFrom c) (ucTo c) (ucStatus c) diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index f5d167cfc92..6782d7aecae 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -20,12 +20,12 @@ module Main ) where +import qualified API.Calling as Calling import qualified API.IdMapping as IdMapping import qualified API.Metrics as Metrics import qualified API.Provider as Provider import qualified API.Search as Search import qualified API.Settings as Settings -import qualified API.TURN as TURN import qualified API.Team as Team import qualified API.User as User import Bilge hiding (header) @@ -97,7 +97,7 @@ runTests iConf bConf otherArgs = do providerApi <- Provider.tests (provider <$> iConf) mg db b c g searchApis <- Search.tests brigOpts mg g b teamApis <- Team.tests brigOpts mg n b c g awsEnv - turnApi <- TURN.tests mg b turnFile turnFileV2 + turnApi <- Calling.tests mg b brigOpts turnFile turnFileV2 idMappingApi <- pure $ IdMapping.tests brigOpts mg b metricsApi <- Metrics.tests mg b settingsApi <- Settings.tests brigOpts mg b g diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index 6e21af2e25e..405ee2b69df 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -25,6 +25,8 @@ import Bilge import Bilge.Assert import qualified Brig.AWS as AWS import Brig.AWS.Types +import Brig.App (applog, sftEnv) +import Brig.Calling as Calling import qualified Brig.Options as Opts import qualified Brig.Run as Run import Brig.Types.Activation @@ -33,12 +35,12 @@ import Brig.Types.Connection import Brig.Types.Intra import Brig.Types.User import Brig.Types.User.Auth -import Control.Lens ((^?), (^?!)) +import Control.Lens ((^.), (^?), (^?!)) import Control.Monad.Catch (MonadCatch) import Control.Monad.Fail (MonadFail) import Control.Retry import Data.Aeson -import Data.Aeson.Lens (_Integral, _JSON, _String, key) +import Data.Aeson.Lens (key, _Integral, _JSON, _String) import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString as BS import Data.ByteString.Char8 (pack) @@ -62,6 +64,7 @@ import Test.Tasty (TestName, TestTree) import Test.Tasty.Cannon import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit +import qualified UnliftIO.Async as Async import Util.AWS import Wire.API.Conversation.Member (Member (..)) @@ -571,9 +574,10 @@ updatePhone brig uid phn = do act <- getActivationCode brig (Right phn) case act of Nothing -> liftIO $ assertFailure "missing activation key/code" - Just kc -> activate brig kc !!! do - const 200 === statusCode - const (Just False) === fmap activatedFirst . responseJsonMaybe + Just kc -> + activate brig kc !!! do + const 200 === statusCode + const (Just False) === fmap activatedFirst . responseJsonMaybe defEmailLogin :: Email -> Login defEmailLogin e = emailLogin e defPassword (Just defCookieLabel) @@ -704,10 +708,17 @@ retryWhileN n f m = -- | This allows you to run requests against a brig instantiated using the given options. -- Note that ONLY 'brig' calls should occur within the provided action, calls to other -- services will fail. +-- +-- Beware: Not all async parts of brig are running in this. withSettingsOverrides :: MonadIO m => Opts.Opts -> WaiTest.Session a -> m a withSettingsOverrides opts action = liftIO $ do - (brigApp, _) <- Run.mkApp opts - WaiTest.runSession action brigApp + (brigApp, env) <- Run.mkApp opts + sftDiscovery <- + forM (env ^. sftEnv) $ \sftEnv' -> + Async.async $ Calling.startSFTServiceDiscovery (env ^. applog) sftEnv' + res <- WaiTest.runSession action brigApp + mapM_ Async.cancel sftDiscovery + pure res -- | When we remove the customer-specific extension of domain blocking, this test will fail to -- compile. diff --git a/services/brig/test/unit/Main.hs b/services/brig/test/unit/Main.hs index 6f12acae661..75aa2dfddf8 100644 --- a/services/brig/test/unit/Main.hs +++ b/services/brig/test/unit/Main.hs @@ -21,6 +21,8 @@ module Main where import Imports +import qualified Test.Brig.Calling +import qualified Test.Brig.Calling.Internal import qualified Test.Brig.User.Search.Index.Types import Test.Tasty @@ -29,5 +31,7 @@ main = defaultMain $ testGroup "Tests" - [ Test.Brig.User.Search.Index.Types.tests + [ Test.Brig.User.Search.Index.Types.tests, + Test.Brig.Calling.tests, + Test.Brig.Calling.Internal.tests ] diff --git a/services/brig/test/unit/Test/Brig/Calling.hs b/services/brig/test/unit/Test/Brig/Calling.hs new file mode 100644 index 00000000000..02248bbef0b --- /dev/null +++ b/services/brig/test/unit/Test/Brig/Calling.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE RecordWildCards #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Brig.Calling where + +import Brig.Calling +import Brig.Options +import Brig.PolyLog +import Control.Retry +import Data.List.NonEmpty (NonEmpty (..)) +import Imports +import Network.DNS +import Polysemy +import qualified System.Logger as Log +import Test.Tasty +import Test.Tasty.HUnit +import qualified UnliftIO.Async as Async +import Wire.Network.DNS.Effect +import Wire.Network.DNS.SRV + +data FakeDNSEnv = FakeDNSEnv + { fakeLookupFn :: Domain -> SrvResponse, + fakeLookupCalls :: IORef [Domain] + } + +newFakeDNSEnv :: (Domain -> SrvResponse) -> IO FakeDNSEnv +newFakeDNSEnv lookupFn = do + FakeDNSEnv lookupFn <$> newIORef [] + +runFakeDNSLookup :: Member (Embed IO) r => FakeDNSEnv -> Sem (DNSLookup ': r) a -> Sem r a +runFakeDNSLookup FakeDNSEnv {..} = interpret $ \case + LookupSRV domain -> do + modifyIORef' fakeLookupCalls (++ [domain]) + pure $ fakeLookupFn domain + +newtype LogRecorder = LogRecorder {recordedLogs :: IORef [(Log.Level, LByteString)]} + +newLogRecorder :: IO LogRecorder +newLogRecorder = LogRecorder <$> newIORef [] + +recordLogs :: Member (Embed IO) r => LogRecorder -> Sem (PolyLog ': r) a -> Sem r a +recordLogs LogRecorder {..} = interpret $ \(PolyLog lvl msg) -> + modifyIORef' recordedLogs (++ [(lvl, Log.render (Log.renderDefault ", ") msg)]) + +ignoreLogs :: Sem (PolyLog ': r) a -> Sem r a +ignoreLogs = interpret $ \(PolyLog _ _) -> pure () + +tests :: TestTree +tests = + testGroup "Calling" $ + [ testGroup "mkSFTDomain" $ + [ testCase "when service name is provided" $ + assertEqual + "should use the service name to form domain" + "_foo._tcp.example.com." + (mkSFTDomain (SFTOptions "example.com" (Just "foo") Nothing)), + testCase "when service name is not provided" $ + assertEqual + "should assume service name to be 'sft'" + "_sft._tcp.example.com." + (mkSFTDomain (SFTOptions "example.com" Nothing Nothing)) + ], + testGroup "sftDiscoveryLoop" $ + [ testCase "when service can be discovered" $ void testDiscoveryLoopWhenSuccessful, + testCase "when service can be discovered and the URLs change" testDiscoveryLoopWhenURLsChange, + testCase "when service cannot be discovered" testDiscoveryLoopWhenUnsuccessful, + testCase "when service cannot be discovered after a successful discovery" testDiscoveryLoopWhenUnsuccessfulAfterSuccess + ], + testGroup "discoverSFTServers" $ + [ testCase "when service is available" testSFTDiscoverWhenAvailable, + testCase "when service is not available" testSFTDiscoverWhenNotAvailable, + testCase "when dns lookup fails" testSFTDiscoverWhenDNSFails + ] + ] + +testDiscoveryLoopWhenSuccessful :: IO SFTEnv +testDiscoveryLoopWhenSuccessful = do + let entry1 = SrvEntry 0 0 (SrvTarget "sft1.foo.example.com." 443) + entry2 = SrvEntry 0 0 (SrvTarget "sft2.foo.example.com." 443) + entry3 = SrvEntry 0 0 (SrvTarget "sft3.foo.example.com." 443) + returnedEntries = (entry1 :| [entry2, entry3]) + fakeDNSEnv <- newFakeDNSEnv (\_ -> SrvAvailable returnedEntries) + sftEnv <- mkSFTEnv (SFTOptions "foo.example.com" Nothing (Just 0.001)) + + discoveryLoop <- Async.async $ runM . ignoreLogs . runFakeDNSLookup fakeDNSEnv $ sftDiscoveryLoop sftEnv + void $ retryEvery10MicrosWhileN 2000 (== 0) (length <$> readIORef (fakeLookupCalls fakeDNSEnv)) + -- We don't want to stop the loop before it has written to the sftServers IORef + void $ retryEvery10MicrosWhileN 2000 (== NotDiscoveredYet) (readIORef (sftServers sftEnv)) + Async.cancel discoveryLoop + + actualServers <- readIORef (sftServers sftEnv) + assertEqual "servers should be the ones read from DNS" (Discovered returnedEntries) actualServers + pure sftEnv + +testDiscoveryLoopWhenUnsuccessful :: IO () +testDiscoveryLoopWhenUnsuccessful = do + fakeDNSEnv <- newFakeDNSEnv (\_ -> SrvNotAvailable) + sftEnv <- mkSFTEnv (SFTOptions "foo.example.com" Nothing (Just 0.001)) + + discoveryLoop <- Async.async $ runM . ignoreLogs . runFakeDNSLookup fakeDNSEnv $ sftDiscoveryLoop sftEnv + -- We wait for at least two lookups to be sure that the lookup loop looped at + -- least once + void $ retryEvery10MicrosWhileN 2000 (<= 1) (length <$> readIORef (fakeLookupCalls fakeDNSEnv)) + Async.cancel discoveryLoop + + actualServers <- readIORef (sftServers sftEnv) + assertEqual "servers should be the ones read from DNS" NotDiscoveredYet actualServers + +testDiscoveryLoopWhenUnsuccessfulAfterSuccess :: IO () +testDiscoveryLoopWhenUnsuccessfulAfterSuccess = do + sftEnv <- testDiscoveryLoopWhenSuccessful + previousEntries <- readIORef (sftServers sftEnv) + + -- In the following lines we re-use the 'sftEnv' from a successful lookup to + -- replicate what will happen when a dns lookup fails after success + failingFakeDNSEnv <- newFakeDNSEnv (\_ -> SrvNotAvailable) + discoveryLoop <- Async.async $ runM . ignoreLogs . runFakeDNSLookup failingFakeDNSEnv $ sftDiscoveryLoop sftEnv + -- We wait for at least two lookups to be sure that the lookup loop looped at + -- least once + void $ retryEvery10MicrosWhileN 2000 (<= 1) (length <$> readIORef (fakeLookupCalls failingFakeDNSEnv)) + Async.cancel discoveryLoop + + actualServers <- readIORef (sftServers sftEnv) + assertEqual "servers shouldn't get overwriten" previousEntries actualServers + +testDiscoveryLoopWhenURLsChange :: IO () +testDiscoveryLoopWhenURLsChange = do + sftEnv <- testDiscoveryLoopWhenSuccessful + + -- In the following lines we re-use the 'sftEnv' from a successful lookup to + -- replicate what will happen when a dns lookup returns new URLs + let entry1 = SrvEntry 0 0 (SrvTarget "sft4.foo.example.com." 443) + entry2 = SrvEntry 0 0 (SrvTarget "sft5.foo.example.com." 443) + newEntries = (entry1 :| [entry2]) + + fakeDNSEnv <- newFakeDNSEnv (\_ -> SrvAvailable newEntries) + discoveryLoop <- Async.async $ runM . ignoreLogs . runFakeDNSLookup fakeDNSEnv $ sftDiscoveryLoop sftEnv + void $ retryEvery10MicrosWhileN 2000 (== 0) (length <$> readIORef (fakeLookupCalls fakeDNSEnv)) + -- We don't want to stop the loop before it has written to the sftServers IORef + void $ retryEvery10MicrosWhileN 2000 (== Discovered newEntries) (readIORef (sftServers sftEnv)) + Async.cancel discoveryLoop + + actualServers <- readIORef (sftServers sftEnv) + assertEqual "servers should get overwritten" (Discovered newEntries) actualServers + +testSFTDiscoverWhenAvailable :: IO () +testSFTDiscoverWhenAvailable = do + logRecorder <- newLogRecorder + let entry1 = SrvEntry 0 0 (SrvTarget "sft7.foo.example.com." 443) + entry2 = SrvEntry 0 0 (SrvTarget "sft8.foo.example.com." 8843) + returnedEntries = (entry1 :| [entry2]) + fakeDNSEnv <- newFakeDNSEnv (\_ -> SrvAvailable returnedEntries) + + assertEqual "discovered servers should be returned" (Just returnedEntries) + =<< ( runM . recordLogs logRecorder . runFakeDNSLookup fakeDNSEnv $ + discoverSFTServers "_sft._tcp.foo.example.com" + ) + assertEqual "nothing should be logged" [] + =<< readIORef (recordedLogs logRecorder) + +testSFTDiscoverWhenNotAvailable :: IO () +testSFTDiscoverWhenNotAvailable = do + logRecorder <- newLogRecorder + fakeDNSEnv <- newFakeDNSEnv (\_ -> SrvNotAvailable) + + assertEqual "discovered servers should be returned" Nothing + =<< ( runM . recordLogs logRecorder . runFakeDNSLookup fakeDNSEnv $ + discoverSFTServers "_sft._tcp.foo.example.com" + ) + assertEqual "should warn about it in the logs" [(Log.Warn, "No SFT servers available\n")] + =<< readIORef (recordedLogs logRecorder) + +testSFTDiscoverWhenDNSFails :: IO () +testSFTDiscoverWhenDNSFails = do + logRecorder <- newLogRecorder + fakeDNSEnv <- newFakeDNSEnv (\_ -> SrvResponseError IllegalDomain) + + assertEqual "discovered servers should be returned" Nothing + =<< ( runM . recordLogs logRecorder . runFakeDNSLookup fakeDNSEnv $ + discoverSFTServers "_sft._tcp.foo.example.com" + ) + assertEqual "should warn about it in the logs" [(Log.Error, "DNS Lookup failed for SFT Discovery, Error=IllegalDomain\n")] + =<< readIORef (recordedLogs logRecorder) + +retryEvery10MicrosWhileN :: (MonadIO m) => Int -> (a -> Bool) -> m a -> m a +retryEvery10MicrosWhileN n f m = + retrying + (constantDelay 10 <> limitRetries n) + (const (return . f)) + (const m) diff --git a/services/brig/test/unit/Test/Brig/Calling/Internal.hs b/services/brig/test/unit/Test/Brig/Calling/Internal.hs new file mode 100644 index 00000000000..5289db03eb7 --- /dev/null +++ b/services/brig/test/unit/Test/Brig/Calling/Internal.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Brig.Calling.Internal where + +import Brig.Calling.Internal +import Data.Misc (mkHttpsUrl) +import Imports +import Test.Tasty +import Test.Tasty.HUnit +import URI.ByteString.QQ as URI +import Wire.API.Call.Config (sftServer) +import Wire.Network.DNS.SRV (SrvTarget (SrvTarget)) + +tests :: TestTree +tests = + testGroup "Calling.API" $ + [ testGroup "sftServerFromSrvTarget" $ + [ testCase "when srvTarget ends with a dot" $ do + let Right expectedServer = sftServer <$> mkHttpsUrl [URI.uri|https://sft1.env.example.com:9364|] + assertEqual + "the dot should be stripped from sft server" + expectedServer + (sftServerFromSrvTarget $ SrvTarget "sft1.env.example.com." 9364), + testCase "when srvTarget doesn't end with a dot" $ do + let Right expectedServer = sftServer <$> mkHttpsUrl [URI.uri|https://sft2.env.example.com:443|] + assertEqual + "the dot should be stripped from sft server" + expectedServer + (sftServerFromSrvTarget $ SrvTarget "sft2.env.example.com" 443) + ] + ] diff --git a/services/cannon/src/Cannon/App.hs b/services/cannon/src/Cannon/App.hs index 921597f12ba..74de9451438 100644 --- a/services/cannon/src/Cannon/App.hs +++ b/services/cannon/src/Cannon/App.hs @@ -26,7 +26,7 @@ import Cannon.WS import Control.Concurrent.Async import Control.Concurrent.Timeout import Control.Monad.Catch -import Data.Aeson hiding ((.=), Error) +import Data.Aeson hiding (Error, (.=)) import Data.ByteString.Conversion import Data.ByteString.Lazy (toStrict) import Data.Id (ClientId) @@ -106,7 +106,8 @@ writeLoop ws clock (TTL ttl) st = loop where loop = do s <- readIORef st - if | s ^. counter == 0 -> do + if + | s ^. counter == 0 -> do set counter st succ threadDelay $ s ^. pingFreq keepAlive diff --git a/services/cannon/src/Cannon/Dict.hs b/services/cannon/src/Cannon/Dict.hs index 3e214743ed0..3ba43b99ec3 100644 --- a/services/cannon/src/Cannon/Dict.hs +++ b/services/cannon/src/Cannon/Dict.hs @@ -30,7 +30,7 @@ where import Data.Hashable (Hashable, hash) import Data.SizedHashMap (SizedHashMap) import qualified Data.SizedHashMap as SHM -import Data.Vector ((!), Vector) +import Data.Vector (Vector, (!)) import qualified Data.Vector as V import Imports hiding (lookup) @@ -51,7 +51,7 @@ insert :: (Eq a, Hashable a, MonadIO m) => a -> b -> Dict a b -> m () insert k v = mutDict (SHM.insert k v) . getSlice k add :: (Eq a, Hashable a, MonadIO m) => a -> b -> Dict a b -> m Bool -add k v d = liftIO $ atomicModifyIORef' (getSlice k d) $ \m -> +add k v d = liftIO . atomicModifyIORef' (getSlice k d) $ \m -> if k `elem` SHM.keys m then (m, False) else (SHM.insert k v m, True) @@ -60,7 +60,7 @@ remove :: (Eq a, Hashable a, MonadIO m) => a -> Dict a b -> m Bool remove = removeIf (const True) removeIf :: (Eq a, Hashable a, MonadIO m) => (Maybe b -> Bool) -> a -> Dict a b -> m Bool -removeIf f k d = liftIO $ atomicModifyIORef' (getSlice k d) $ \m -> +removeIf f k d = liftIO . atomicModifyIORef' (getSlice k d) $ \m -> if f (SHM.lookup k m) then (SHM.delete k m, True) else (m, False) @@ -76,7 +76,7 @@ mutDict :: (SizedHashMap a b -> SizedHashMap a b) -> IORef (SizedHashMap a b) -> m () -mutDict f d = liftIO $ atomicModifyIORef' d $ \m -> (f m, ()) +mutDict f d = liftIO . atomicModifyIORef' d $ \m -> (f m, ()) getSlice :: (Hashable a) => a -> Dict a b -> IORef (SizedHashMap a b) getSlice k (Dict m) = m ! (hash k `mod` V.length m) diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index 7cf605b4b08..9f12e9d59c8 100644 --- a/services/cannon/src/Cannon/Run.hs +++ b/services/cannon/src/Cannon/Run.hs @@ -30,8 +30,7 @@ import Cannon.WS hiding (env) import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (catchAny) import Control.Lens ((^.)) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Catch (finally) +import Control.Monad.Catch (MonadCatch, finally) import Data.Metrics.Middleware (gaugeSet, path) import qualified Data.Metrics.Middleware as Middleware import Data.Metrics.Middleware.Prometheus (waiPrometheusMiddleware) @@ -95,7 +94,8 @@ refreshMetrics = do threadDelay 1000000 where safeForever :: (MonadIO m, LC.MonadLogger m, MonadCatch m) => m () -> m () - safeForever action = forever $ - action `catchAny` \exc -> do - LC.err $ "error" LC..= show exc LC.~~ LC.msg (LC.val "refreshMetrics failed") - threadDelay 60000000 -- pause to keep worst-case noise in logs manageable + safeForever action = + forever $ + action `catchAny` \exc -> do + LC.err $ "error" LC..= show exc LC.~~ LC.msg (LC.val "refreshMetrics failed") + threadDelay 60000000 -- pause to keep worst-case noise in logs manageable diff --git a/services/cannon/src/Cannon/Types.hs b/services/cannon/src/Cannon/Types.hs index 0d4a598d83f..b70f40a358c 100644 --- a/services/cannon/src/Cannon/Types.hs +++ b/services/cannon/src/Cannon/Types.hs @@ -81,9 +81,10 @@ newtype Cannon a = Cannon ) mapConcurrentlyCannon :: Traversable t => (a -> Cannon b) -> t a -> Cannon (t b) -mapConcurrentlyCannon action inputs = Cannon $ - ask >>= \e -> - liftIO $ mapConcurrently ((`runReaderT` e) . unCannon . action) inputs +mapConcurrentlyCannon action inputs = + Cannon $ + ask >>= \e -> + liftIO $ mapConcurrently ((`runReaderT` e) . unCannon . action) inputs instance MonadLogger Cannon where log l m = Cannon $ do diff --git a/services/cannon/src/Cannon/WS.hs b/services/cannon/src/Cannon/WS.hs index db53f1293cb..aeff344f222 100644 --- a/services/cannon/src/Cannon/WS.hs +++ b/services/cannon/src/Cannon/WS.hs @@ -61,7 +61,7 @@ import Data.Default (def) import Data.Hashable import Data.Id (ClientId, ConnId (..), UserId) import Data.Text.Encoding (decodeUtf8) -import Data.Timeout ((#), TimeoutUnit (..)) +import Data.Timeout (TimeoutUnit (..), (#)) import Gundeck.Types import Imports hiding (threadDelay) import Network.HTTP.Types.Method @@ -69,7 +69,7 @@ import Network.HTTP.Types.Status import Network.Wai.Utilities.Error import Network.WebSockets hiding (Request) import qualified System.Logger as Logger -import System.Logger.Class hiding ((.=), Error, Settings, close) +import System.Logger.Class hiding (Error, Settings, close, (.=)) import System.Random.MWC (GenIO, uniform) ----------------------------------------------------------------------------- @@ -115,7 +115,7 @@ newtype Clock = Clock (IORef Word64) mkClock :: IO Clock mkClock = do r <- newIORef 0 - void . forkIO $ forever $ do + void . forkIO . forever $ do threadDelay (1 # Second) modifyIORef' r (+ 1) return $ Clock r @@ -208,16 +208,19 @@ registerRemote k c = do debug $ client kb . msg (val "register-remote") e <- WS ask i <- regInfo k c - void $ recovering retry3x rpcHandlers $ const $ - rpc' "gundeck" (upstream e) (method POST . path "/i/presences" . i . expect2xx) + void $ + recovering retry3x rpcHandlers $ + const $ + rpc' "gundeck" (upstream e) (method POST . path "/i/presences" . i . expect2xx) debug $ client kb . msg (val "registered") isRemoteRegistered :: UserId -> ConnId -> WS Bool isRemoteRegistered u c = do e <- WS ask rs <- - recovering retry3x rpcHandlers $ const $ - rpc' "gundeck" (upstream e) (method GET . paths ["/i/presences", toByteString' u] . expect2xx) + recovering retry3x rpcHandlers $ + const $ + rpc' "gundeck" (upstream e) (method GET . paths ["/i/presences", toByteString' u] . expect2xx) cs <- map connId <$> parseResponse (Error status502 "server-error") rs return $ c `elem` cs diff --git a/services/cannon/test/Test/Cannon/Dict.hs b/services/cannon/test/Test/Cannon/Dict.hs index b08fa5d5e18..9303d8ba1ee 100644 --- a/services/cannon/test/Test/Cannon/Dict.hs +++ b/services/cannon/test/Test/Cannon/Dict.hs @@ -98,10 +98,11 @@ insertLookup = do action d k = do v <- toByteString <$> nextRandom added <- D.add k v d - when added $ replicateM_ 361 $ do - threadDelay 3571 - x <- D.lookup k d - Just v @=? x + when added $ + replicateM_ 361 $ do + threadDelay 3571 + x <- D.lookup k d + Just v @=? x assertEq :: (Show a, Eq a, Monad m) => String -> a -> a -> PropertyM m () assertEq m a b diff --git a/services/cargohold/src/CargoHold/API/Error.hs b/services/cargohold/src/CargoHold/API/Error.hs index f7ad71d4db3..be4acb92538 100644 --- a/services/cargohold/src/CargoHold/API/Error.hs +++ b/services/cargohold/src/CargoHold/API/Error.hs @@ -50,14 +50,15 @@ requestTimeout = invalidOffset :: Offset -> Offset -> Error invalidOffset expected given = - Error status409 "invalid-offset" $ toLazyText $ - "Invalid offset: " - <> "expected: " - <> decimal expected - <> ", " - <> "given: " - <> decimal given - <> "." + Error status409 "invalid-offset" $ + toLazyText $ + "Invalid offset: " + <> "expected: " + <> decimal expected + <> ", " + <> "given: " + <> decimal given + <> "." uploadTooSmall :: Error uploadTooSmall = @@ -77,14 +78,15 @@ uploadTooLarge = uploadIncomplete :: TotalSize -> TotalSize -> Error uploadIncomplete expected actual = - Error status403 "client-error" $ toLazyText $ - "The upload is incomplete: " - <> "expected size: " - <> decimal expected - <> ", " - <> "current size: " - <> decimal actual - <> "." + Error status403 "client-error" $ + toLazyText $ + "The upload is incomplete: " + <> "expected size: " + <> decimal expected + <> ", " + <> "current size: " + <> decimal actual + <> "." clientError :: LText -> Error clientError = Error status400 "client-error" diff --git a/services/cargohold/src/CargoHold/API/Public.hs b/services/cargohold/src/CargoHold/API/Public.hs index 4c0dab658f9..73ba7eb5dd4 100644 --- a/services/cargohold/src/CargoHold/API/Public.hs +++ b/services/cargohold/src/CargoHold/API/Public.hs @@ -30,7 +30,7 @@ import CargoHold.Options import qualified CargoHold.TUS as TUS import qualified CargoHold.Types.V3 as V3 (Principal (..)) import Control.Error -import Control.Lens ((^.), view) +import Control.Lens (view, (^.)) import Data.ByteString.Conversion import Data.Id import Data.Predicate diff --git a/services/cargohold/src/CargoHold/API/V3.hs b/services/cargohold/src/CargoHold/API/V3.hs index d579f764983..bbee56c0cd7 100644 --- a/services/cargohold/src/CargoHold/API/V3.hs +++ b/services/cargohold/src/CargoHold/API/V3.hs @@ -38,7 +38,7 @@ import qualified Codec.MIME.Type as MIME import qualified Conduit as Conduit import Control.Applicative (optional) import Control.Error -import Control.Lens ((^.), set, view) +import Control.Lens (set, view, (^.)) import Control.Monad.Trans.Resource import Crypto.Hash import Crypto.Random (getRandomBytes) @@ -214,9 +214,9 @@ headers names = count (length names) (header names) header :: [HeaderName] -> Parser (HeaderName, ByteString) header names = do name <- CI.mk <$> takeTill (== ':') "header name" - unless (name `elem` names) - $ fail - $ "Unexpected header: " ++ show (CI.original name) + unless (name `elem` names) $ + fail $ + "Unexpected header: " ++ show (CI.original name) _ <- char ':' skipSpace value <- takeTill isEOL "header value" diff --git a/services/cargohold/src/CargoHold/API/V3/Resumable.hs b/services/cargohold/src/CargoHold/API/V3/Resumable.hs index 0862a01fbfe..878842375b4 100644 --- a/services/cargohold/src/CargoHold/API/V3/Resumable.hs +++ b/services/cargohold/src/CargoHold/API/V3/Resumable.hs @@ -119,7 +119,7 @@ upload own key off len src = do let totalBytes = V3.totalSizeBytes (S3.resumableTotalSize r) let numBytes = min (chunkSize r) remaining if numBytes < chunkSize r && coerce offset + remaining < totalBytes - then-- Remaining input that is not a full chunk size and does + then -- Remaining input that is not a full chunk size and does -- not constitute the last chunk is ignored, i.e. all chunks -- except the last must have the same size (the chunk size). return (r, offset) diff --git a/services/cargohold/src/CargoHold/AWS.hs b/services/cargohold/src/CargoHold/AWS.hs index fe967ace206..096daf00d36 100644 --- a/services/cargohold/src/CargoHold/AWS.hs +++ b/services/cargohold/src/CargoHold/AWS.hs @@ -53,8 +53,8 @@ import qualified Network.AWS.Env as AWS import qualified Network.AWS.S3 as S3 import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Manager) import qualified System.Logger as Logger -import qualified System.Logger.Class as Log import System.Logger.Class (Logger, MonadLogger (log), (~~)) +import qualified System.Logger.Class as Log import Util.Options (AWSEndpoint (..)) data Env = Env @@ -97,7 +97,7 @@ instance MonadLogger Amazon where log l m = view logger >>= \g -> Logger.log g l m instance MonadUnliftIO Amazon where - askUnliftIO = Amazon $ ReaderT $ \r -> + askUnliftIO = Amazon . ReaderT $ \r -> withUnliftIO $ \u -> return (UnliftIO (unliftIO u . flip runReaderT r . unAmazon)) diff --git a/services/cargohold/src/CargoHold/App.hs b/services/cargohold/src/CargoHold/App.hs index 74657f73e39..54433d36354 100644 --- a/services/cargohold/src/CargoHold/App.hs +++ b/services/cargohold/src/CargoHold/App.hs @@ -49,7 +49,7 @@ import Bilge.RPC (HasRequestId (..)) import qualified CargoHold.AWS as AWS import CargoHold.Options as Opt import Control.Error (ExceptT, exceptT) -import Control.Lens ((^.), makeLenses, set, view) +import Control.Lens (makeLenses, set, view, (^.)) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Trans.Resource (ResourceT, runResourceT, transResourceT) import Data.Default (def) diff --git a/services/cargohold/src/CargoHold/Run.hs b/services/cargohold/src/CargoHold/Run.hs index e63a7d5a7b8..378d1d648ea 100644 --- a/services/cargohold/src/CargoHold/Run.hs +++ b/services/cargohold/src/CargoHold/Run.hs @@ -30,8 +30,8 @@ import Data.Text (unpack) import Imports import qualified Network.Wai as Wai import qualified Network.Wai.Middleware.Gzip as GZip -import qualified Network.Wai.Utilities.Server as Server import Network.Wai.Utilities.Server +import qualified Network.Wai.Utilities.Server as Server import Util.Options run :: Opts -> IO () diff --git a/services/cargohold/src/CargoHold/S3.hs b/services/cargohold/src/CargoHold/S3.hs index 7d99498cd5c..dbe4e84a721 100644 --- a/services/cargohold/src/CargoHold/S3.hs +++ b/services/cargohold/src/CargoHold/S3.hs @@ -59,7 +59,7 @@ import qualified Codec.MIME.Parse as MIME import qualified Codec.MIME.Type as MIME import Conduit import Control.Error (ExceptT, throwE) -import Control.Lens hiding ((.=), (:<), (:>), parts) +import Control.Lens hiding (parts, (.=), (:<), (:>)) import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion @@ -85,7 +85,7 @@ import Network.AWS.S3 import Network.Wai.Utilities.Error (Error (..)) import Safe (readMay) import qualified System.Logger.Class as Log -import System.Logger.Message ((.=), msg, val, (~~)) +import System.Logger.Message (msg, val, (.=), (~~)) import URI.ByteString newtype S3AssetKey = S3AssetKey {s3Key :: Text} @@ -175,9 +175,9 @@ updateMetadataV3 (s3Key . mkKey -> key) (S3AssetMeta prc tok ct) = do void $ exec req where copySrc b = - decodeLatin1 . LBS.toStrict . toLazyByteString - $ urlEncode [] - $ Text.encodeUtf8 (b <> "/" <> key) + decodeLatin1 . LBS.toStrict . toLazyByteString $ + urlEncode [] $ + Text.encodeUtf8 (b <> "/" <> key) req b = copyObject (BucketName b) (copySrc b) (ObjectKey key) & coContentType ?~ MIME.showType ct @@ -308,7 +308,8 @@ calculateChunkSize (fromIntegral -> total) = smallSize = total `quot` smallChunks bigSize = total `quot` bigChunks in V3.ChunkSize $ - if | smallChunks < maxSmallChunks -> minSmallSize + if + | smallChunks < maxSmallChunks -> minSmallSize | smallSize <= maxSmallSize -> smallSize | bigChunks < maxTotalChunks -> minBigSize | otherwise -> bigSize @@ -406,14 +407,14 @@ createResumable k p typ size tok = do chunkBytes = V3.chunkSizeBytes (resumableChunkSize r) totalBytes = V3.totalSizeBytes (resumableTotalSize r) resumableMeta csize expires upl = - setAmzMetaPrincipal p - : setAmzMetaTotalSize size - : setAmzMetaChunkSize csize - : setAmzMetaUploadExpires expires - : catMaybes - [ setAmzMetaToken <$> tok, - setAmzMetaUploadId <$> upl - ] + setAmzMetaPrincipal p : + setAmzMetaTotalSize size : + setAmzMetaChunkSize csize : + setAmzMetaUploadExpires expires : + catMaybes + [ setAmzMetaToken <$> tok, + setAmzMetaUploadId <$> upl + ] uploadChunk :: S3Resumable -> @@ -499,8 +500,8 @@ completeResumable r = do -- the same here. let rk = resumableKey r let keys = - s3ResumableKey rk - : map (s3ChunkKey . mkChunkKey rk . chunkNr) (toList chunks) + s3ResumableKey rk : + map (s3ChunkKey . mkChunkKey rk . chunkNr) (toList chunks) let del = delete' & dObjects .~ map (objectIdentifier . ObjectKey) keys & dQuiet ?~ True @@ -530,9 +531,9 @@ completeResumable r = do -- upload is complete. verifyChunks cs = do let !total = V3.TotalSize $ foldl' (\t v -> t + chunkSize v) 0 cs - unless (total == resumableTotalSize r) - $ throwE - $ uploadIncomplete (resumableTotalSize r) total + unless (total == resumableTotalSize r) $ + throwE $ + uploadIncomplete (resumableTotalSize r) total -- Construct a 'Source' by downloading the chunks. -- chunkSource :: AWS.Env -- -> Seq S3Chunk @@ -544,9 +545,10 @@ completeResumable r = do let b = view AWS.s3Bucket env let req = getObject (BucketName b) (ObjectKey ck) v <- - lift $ AWS.execute env $ - AWS.send req - >>= flip sinkBody Conduit.sinkLbs . view gorsBody + lift $ + AWS.execute env $ + AWS.send req + >>= flip sinkBody Conduit.sinkLbs . view gorsBody Conduit.yield (LBS.toStrict v) >> chunkSource env cc listChunks :: S3Resumable -> ExceptT Error App (Maybe (Seq S3Chunk)) diff --git a/services/cargohold/src/CargoHold/Util.hs b/services/cargohold/src/CargoHold/Util.hs index bfd9c9a29ef..22c2284fe01 100644 --- a/services/cargohold/src/CargoHold/Util.hs +++ b/services/cargohold/src/CargoHold/Util.hs @@ -28,7 +28,8 @@ import URI.ByteString hiding (urlEncode) genSignedURL :: (ToByteString p) => p -> Handler URI genSignedURL path = do - uri <- view (aws . cloudFront) >>= \case - Nothing -> S3.signedURL path - Just cf -> CloudFront.signedURL cf path + uri <- + view (aws . cloudFront) >>= \case + Nothing -> S3.signedURL path + Just cf -> CloudFront.signedURL cf path return $! uri diff --git a/services/cargohold/test/integration/API/V3.hs b/services/cargohold/test/integration/API/V3.hs index cc8161de81a..be66969654a 100644 --- a/services/cargohold/test/integration/API/V3.hs +++ b/services/cargohold/test/integration/API/V3.hs @@ -98,9 +98,10 @@ testSimpleRoundtrip c = do when (isJust $ join (V3.assetRetentionSeconds <$> (sets ^. V3.setAssetRetention))) $ do liftIO $ assertBool "invalid expiration" (Just utc < view V3.assetExpires ast) -- Lookup with token and download via redirect. - r2 <- get (c . path loc . zUser uid . header "Asset-Token" (toByteString' tok) . noRedirect) responseJsonMaybe r2 liftIO $ assertBool "token unchanged" (tok /= tok') -- Download by owner with new token. - r3 <- get (c . path loc . zUser uid . header "Asset-Token" (toByteString' tok') . noRedirect) CargoHold -> UserId -> V3.AssetKey -> Maybe V3.AssetToken -> Http (Response (Maybe Lazy.ByteString)) downloadAsset c u k t = do - r <- getAsset c u k t long (untag (optionName :: Tagged ServiceConfigFile String)) - <> help (untag (optionHelp :: Tagged ServiceConfigFile String)) - ) + fmap ServiceConfigFile $ + strOption $ + ( short (untag (return 's' :: Tagged ServiceConfigFile Char)) + <> long (untag (optionName :: Tagged ServiceConfigFile String)) + <> help (untag (optionHelp :: Tagged ServiceConfigFile String)) + ) runTests :: (String -> String -> TestTree) -> IO () -runTests run = defaultMainWithIngredients ings - $ askOption - $ \(ServiceConfigFile c) -> - askOption $ \(IntegrationConfigFile i) -> run c i +runTests run = defaultMainWithIngredients ings $ + askOption $ + \(ServiceConfigFile c) -> + askOption $ \(IntegrationConfigFile i) -> run c i where ings = includingOptions [ Option (Proxy :: Proxy ServiceConfigFile), Option (Proxy :: Proxy IntegrationConfigFile) - ] - : defaultIngredients + ] : + defaultIngredients main :: IO () main = runTests go diff --git a/services/cargohold/test/integration/TestSetup.hs b/services/cargohold/test/integration/TestSetup.hs index 0eb3e69dd5e..872332dbc24 100644 --- a/services/cargohold/test/integration/TestSetup.hs +++ b/services/cargohold/test/integration/TestSetup.hs @@ -27,7 +27,7 @@ where import Bilge (Request) import Bilge.IO (Http, Manager, runHttpT) -import Control.Lens ((^.), makeLenses) +import Control.Lens (makeLenses, (^.)) import Imports import Test.Tasty import Test.Tasty.HUnit diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index 0b26b11d71a..308f6966089 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 05e45399becaef2bbecfa958ec4d5633900e2e1d8e1c1a2e7ecd2afbdbc2404f +-- hash: 72597caf8878551b0609bfdc790852575f38db429ea5c83935a399c676ee3c2c name: federator version: 1.0.0 @@ -20,10 +20,10 @@ library exposed-modules: Federator.API Federator.App + Federator.Impl Federator.Options Federator.Run Federator.Types - Federator.Util other-modules: Paths_federator hs-source-dirs: @@ -35,14 +35,12 @@ library , aeson , base , bilge - , brig-types , bytestring-conversion , data-default , email-validate , errors , exceptions , extended - , galley-types , imports , lens , metrics-core @@ -60,6 +58,8 @@ library , wai , wai-utilities , warp + , wire-api + , wire-api-federation default-language: Haskell2010 executable federator @@ -75,7 +75,6 @@ executable federator , aeson , base , bilge - , brig-types , bytestring-conversion , data-default , email-validate @@ -83,7 +82,6 @@ executable federator , exceptions , extended , federator - , galley-types , imports , lens , metrics-core @@ -101,4 +99,6 @@ executable federator , wai , wai-utilities , warp + , wire-api + , wire-api-federation default-language: Haskell2010 diff --git a/services/federator/package.yaml b/services/federator/package.yaml index 892fe7194c8..6035999778c 100644 --- a/services/federator/package.yaml +++ b/services/federator/package.yaml @@ -12,14 +12,12 @@ dependencies: - aeson - base - bilge -- brig-types - bytestring-conversion - data-default - email-validate - errors - exceptions - extended -- galley-types - imports - lens - metrics-core @@ -38,6 +36,8 @@ dependencies: - wai - wai-utilities - warp +- wire-api +- wire-api-federation library: source-dirs: src executables: diff --git a/services/federator/src/Federator/API.hs b/services/federator/src/Federator/API.hs index 1ea46ddd105..ba5026aee23 100644 --- a/services/federator/src/Federator/API.hs +++ b/services/federator/src/Federator/API.hs @@ -17,53 +17,42 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Federator.API where - -import Brig.Types.Client.Prekey -import Brig.Types.Test.Arbitrary () -import Data.Aeson.TH (deriveJSON) -import Data.Handle (Handle (..)) -import Data.Id (UserId) -import Data.Qualified -import Federator.Util +module Federator.API + ( Api (..), + module Fed, + ) +where + +import Data.Id (ConvId, UserId) +import Data.Qualified (Qualified) import Imports import Servant.API import Servant.API.Generic -import Test.QuickCheck +import Wire.API.Federation.API.Conversation as Fed hiding (Api) +import Wire.API.Federation.Event as Fed +import Wire.API.User.Client.Prekey (PrekeyBundle) -data API route = API - { _gapiSearch :: - route - :- "i" - :> "search" - -- QUESTION: what exactly should the query be? text + domain? - :> QueryParam' [Required, Strict] "q" (Qualified Handle) - :> Get '[JSON] FUser, - _gapiPrekeys :: +data Api route = Api + { _gapiPrekeys :: route :- "i" :> "users" - :> Capture "fqu" (Qualified UserId) + :> Capture "id" (Qualified UserId) :> "prekeys" - :> Get '[JSON] PrekeyBundle + -- FUTUREWORK(federation): + -- this should return a version of PrekeyBundle with qualified UserId, + -- defined in wire-api-federation + :> Get '[JSON] PrekeyBundle, + _gapiJoinConversationById :: + route + :- "i" + :> "conversations" + :> Capture "cnv" (Qualified ConvId) + :> "join" + :> ReqBody '[JSON] Fed.JoinConversationByIdRequest + :> Post '[JSON] (Fed.ConversationUpdateResult Fed.MemberJoin) } deriving (Generic) --- curl http://localhost:8097/i/search?q=wef@a.com; curl http://localhost:8097/i/users/`uuid`@example.com/prekeys - ---------------------------------------------------------------------- --- TODO: add roundtrip tests for *HttpApiData, *JSON, ... --- --- TODO: the client ids in the 'PrekeyBundle' aren't really needed here. do we want to make a --- new type for that, then? - -data FUser = FUser - { _fuGlobalHandle :: !(Qualified Handle), - _fuFQU :: !(Qualified UserId) - } - deriving (Eq, Show, Generic) - -deriveJSON (wireJsonOptions "_fu") ''FUser - -instance Arbitrary FUser where - arbitrary = FUser <$> arbitrary <*> arbitrary +-- FUTUREWORK: add roundtrip tests for *HttpApiData, *JSON, ... diff --git a/services/federator/src/Federator/App.hs b/services/federator/src/Federator/App.hs index 2c375802d91..f6dcd763ab2 100644 --- a/services/federator/src/Federator/App.hs +++ b/services/federator/src/Federator/App.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -- This file is part of the Wire Server implementation. -- @@ -19,19 +19,66 @@ -- with this program. If not, see . module Federator.App - ( app, + ( AppT, + AppIO, + runAppT, + runAppResourceT, ) where -import Data.Proxy -import qualified Federator.API as API -import Federator.Types -import Network.Wai -import Servant.API.Generic -import Servant.Mock -import Servant.Server - -app :: Env -> Application -app _ = serve api (mock api Proxy) - where - api = Proxy @(ToServantApi API.API) +import Bilge (RequestId (unRequestId)) +import Bilge.RPC (HasRequestId (..)) +import Control.Error (ExceptT) +import Control.Lens (view) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Trans.Resource (MonadUnliftIO, ResourceT, runResourceT, transResourceT) +import Federator.Types (Env, applog, requestId) +import Imports +import Servant.API.Generic () +import Servant.Server () +import System.Logger.Class as LC +import qualified System.Logger.Extended as Log + +-- FUTUREWORK: this code re-occurs in every service. introduce 'MkAppT' in types-common that +-- takes 'Env' as one more argument. +newtype AppT m a = AppT + { unAppT :: ReaderT Env m a + } + deriving newtype + ( Functor, + Applicative, + Monad, + MonadIO, + MonadThrow, + MonadCatch, + MonadMask, + MonadReader Env + ) + +type AppIO = AppT IO + +instance MonadIO m => LC.MonadLogger (AppT m) where + log l m = do + g <- view applog + r <- view requestId + Log.log g l $ field "request" (unRequestId r) ~~ m + +instance MonadIO m => LC.MonadLogger (ExceptT err (AppT m)) where + log l m = lift (LC.log l m) + +instance Monad m => HasRequestId (AppT m) where + getRequestId = view requestId + +instance MonadUnliftIO m => MonadUnliftIO (AppT m) where + withRunInIO inner = + AppT . ReaderT $ \r -> + withRunInIO $ \runner -> + inner (runner . flip runReaderT r . unAppT) + +runAppT :: Env -> AppT m a -> m a +runAppT e (AppT ma) = runReaderT ma e + +runAppResourceT :: ResourceT AppIO a -> AppIO a +runAppResourceT ma = do + e <- ask + liftIO . runResourceT $ transResourceT (runAppT e) ma diff --git a/services/federator/src/Federator/Impl.hs b/services/federator/src/Federator/Impl.hs new file mode 100644 index 00000000000..75a01c5c800 --- /dev/null +++ b/services/federator/src/Federator/Impl.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Federator.Impl + ( app, + ) +where + +import Data.Proxy +import qualified Federator.API as API +import Federator.Types +import Network.Wai +import Servant.API.Generic +import Servant.Mock +import Servant.Server + +app :: Env -> Application +app _ = serve api (mock api Proxy) + where + api = Proxy @(ToServantApi API.Api) diff --git a/services/federator/src/Federator/Run.hs b/services/federator/src/Federator/Run.hs index e2f05c10252..023bbd0956a 100644 --- a/services/federator/src/Federator/Run.hs +++ b/services/federator/src/Federator/Run.hs @@ -25,32 +25,20 @@ module Federator.Run -- * App Environment newEnv, closeEnv, - - -- * App Monad - AppT, - AppIO, - runAppT, - runAppResourceT, ) where -import Bilge (RequestId (unRequestId)) -import Bilge.RPC (HasRequestId (..)) -import Control.Error -import Control.Lens ((^.), view) -import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) -import Control.Monad.Trans.Resource +import Control.Lens ((^.)) import Data.Default (def) import qualified Data.Metrics.Middleware as Metrics import Data.Text (unpack) -import qualified Federator.App as App +import qualified Federator.Impl as Impl import Federator.Options as Opt import Federator.Types import Imports import Network.Wai (Application) import qualified Network.Wai.Handler.Warp as Warp import Network.Wai.Utilities.Server as Server -import System.Logger.Class as LC import qualified System.Logger.Extended as Log import Util.Options @@ -66,7 +54,7 @@ run opts = do mkApp :: Opts -> IO (Application, Env) mkApp opts = do env <- newEnv opts - pure (App.app env, env) + pure (Impl.app env, env) ------------------------------------------------------------------------------- -- Environment @@ -82,50 +70,3 @@ closeEnv :: Env -> IO () closeEnv e = do Log.flush $ e ^. applog Log.close $ e ^. applog - -------------------------------------------------------------------------------- --- App Monad - --- FUTUREWORK: this code re-occurs in every service. introduce 'MkAppT' in types-common that --- takes 'Env' as one more argument. -newtype AppT m a = AppT - { unAppT :: ReaderT Env m a - } - deriving - ( Functor, - Applicative, - Monad, - MonadIO, - MonadThrow, - MonadCatch, - MonadMask, - MonadReader Env - ) - -type AppIO = AppT IO - -instance MonadIO m => LC.MonadLogger (AppT m) where - log l m = do - g <- view applog - r <- view requestId - Log.log g l $ field "request" (unRequestId r) ~~ m - -instance MonadIO m => LC.MonadLogger (ExceptT err (AppT m)) where - log l m = lift (LC.log l m) - -instance Monad m => HasRequestId (AppT m) where - getRequestId = view requestId - -instance MonadUnliftIO m => MonadUnliftIO (AppT m) where - withRunInIO inner = - AppT $ ReaderT $ \r -> - withRunInIO $ \runner -> - inner (runner . flip runReaderT r . unAppT) - -runAppT :: Env -> AppT m a -> m a -runAppT e (AppT ma) = runReaderT ma e - -runAppResourceT :: ResourceT AppIO a -> AppIO a -runAppResourceT ma = do - e <- ask - liftIO . runResourceT $ transResourceT (runAppT e) ma diff --git a/services/galley/migrate-data/src/Galley/DataMigration.hs b/services/galley/migrate-data/src/Galley/DataMigration.hs index 1b648ded6bf..8bf027be615 100644 --- a/services/galley/migrate-data/src/Galley/DataMigration.hs +++ b/services/galley/migrate-data/src/Galley/DataMigration.hs @@ -70,13 +70,13 @@ mkEnv l cas = <*> initLogger where initCassandra = - C.init - $ C.setLogger (C.mkLogger l) + C.init $ + C.setLogger (C.mkLogger l) . C.setContacts (cHost cas) [] . C.setPortNumber (fromIntegral (cPort cas)) . C.setKeyspace (cKeyspace cas) . C.setProtocolVersion C.V4 - $ C.defSettings + $ C.defSettings initLogger = pure l -- | Runs only the migrations which need to run diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 9c5b18657e0..0e23b73e02d 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -181,9 +181,9 @@ createOne2OneConversation :: UserId -> ConnId -> NewConvUnmanaged -> Galley Conv createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do other <- head . fromRange <$> (rangeChecked (newConvUsers j) :: Galley (Range 1 1 [OpaqueUserId])) (x, y) <- toUUIDs (makeIdOpaque zusr) other - when (x == y) - $ throwM - $ invalidOp "Cannot create a 1-1 with yourself" + when (x == y) $ + throwM $ + invalidOp "Cannot create a 1-1 with yourself" otherUserId <- IdMapping.resolveOpaqueUserId other case newConvTeam j of Just ti @@ -239,26 +239,27 @@ createConnectConversation usr conn j = do update n conv = let mems = Data.convMembers conv in conversationExisted usr - =<< if | Local usr `isMember` mems -> - -- we already were in the conversation, maybe also other - connect n conv - | otherwise -> do - now <- liftIO getCurrentTime - mm <- snd <$> Data.addMember now (Data.convId conv) usr - let conv' = - conv - { Data.convMembers = Data.convMembers conv <> toList mm - } - if null mems - then do - -- the conversation was empty - connect n conv' - else do - -- we were not in the conversation, but someone else - conv'' <- acceptOne2One usr conv' conn - if Data.convType conv'' == ConnectConv - then connect n conv'' - else return conv'' + =<< if + | Local usr `isMember` mems -> + -- we already were in the conversation, maybe also other + connect n conv + | otherwise -> do + now <- liftIO getCurrentTime + mm <- snd <$> Data.addMember now (Data.convId conv) usr + let conv' = + conv + { Data.convMembers = Data.convMembers conv <> toList mm + } + if null mems + then do + -- the conversation was empty + connect n conv' + else do + -- we were not in the conversation, but someone else + conv'' <- acceptOne2One usr conv' conn + if Data.convType conv'' == ConnectConv + then connect n conv'' + else return conv'' connect n conv | Data.convType conv == ConnectConv = do n' <- case n of diff --git a/services/galley/src/Galley/API/IdMapping.hs b/services/galley/src/Galley/API/IdMapping.hs index 37ce5e3e1c6..e2329bd83d9 100644 --- a/services/galley/src/Galley/API/IdMapping.hs +++ b/services/galley/src/Galley/API/IdMapping.hs @@ -29,8 +29,8 @@ module Galley.API.IdMapping where import Control.Monad.Catch (throwM) -import qualified Data.Id as Id import Data.Id (Id (Id, toUUID), OpaqueConvId, OpaqueUserId, idToText) +import qualified Data.Id as Id import Data.IdMapping (IdMapping (IdMapping, _imQualifiedId), MappedOrLocalId (Local, Mapped), hashQualifiedId) import Data.Qualified (Qualified, renderQualifiedId) import Galley.API.Error (federationNotEnabled) @@ -146,12 +146,12 @@ createIdMapping qualifiedId = do let idMapping = IdMapping mappedId qualifiedId Data.getIdMapping mappedId >>= \case Just existingMapping -> - when (_imQualifiedId existingMapping /= qualifiedId) - $ Log.err - $ Log.msg @Text "Conflict when creating IdMapping" - . Log.field "mapped_id" (idToText mappedId) - . Log.field "existing_qualified_id" (renderQualifiedId qualifiedId) - . Log.field "new_qualified_id" (renderQualifiedId (_imQualifiedId existingMapping)) + when (_imQualifiedId existingMapping /= qualifiedId) $ + Log.err $ + Log.msg @Text "Conflict when creating IdMapping" + . Log.field "mapped_id" (idToText mappedId) + . Log.field "existing_qualified_id" (renderQualifiedId qualifiedId) + . Log.field "new_qualified_id" (renderQualifiedId (_imQualifiedId existingMapping)) Nothing -> do Data.insertIdMapping idMapping Intra.createIdMappingInBrig (mkPostIdMappingRequest qualifiedId) diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index a7097605d90..4aa1a244d76 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -292,7 +292,7 @@ rmUser user conn = do return $ (Intra.newPush ListComplete (evtFrom e) (Intra.ConvEvent e) (Intra.recipient <$> Data.convMembers c)) <&> set Intra.pushConn conn - . set Intra.pushRoute Intra.RouteDirect + . set Intra.pushRoute Intra.RouteDirect | otherwise -> return Nothing for_ (maybeList1 (catMaybes pp)) @@ -315,7 +315,8 @@ deleteLoop = do liftIO $ threadDelay 1000000 safeForever :: (MonadIO m, MonadLogger m, MonadCatch m) => String -> m () -> m () -safeForever funName action = forever $ - action `catchAny` \exc -> do - err $ "error" .= show exc ~~ msg (val $ cs funName <> " failed") - threadDelay 60000000 -- pause to keep worst-case noise in logs manageable +safeForever funName action = + forever $ + action `catchAny` \exc -> do + err $ "error" .= show exc ~~ msg (val $ cs funName <> " failed") + threadDelay 60000000 -- pause to keep worst-case noise in logs manageable diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 1c32218de16..76d1a081834 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -31,7 +31,7 @@ where import Brig.Types.Client.Prekey import Brig.Types.Provider import Brig.Types.Team.LegalHold hiding (userId) -import Control.Lens ((^.), view) +import Control.Lens (view, (^.)) import Control.Monad.Catch import Data.ByteString.Conversion (toByteString, toByteString') import Data.Id diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index 2472200feda..56873878564 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -32,7 +32,7 @@ import Imports import Network.HTTP.Types.Status import Network.Wai.Utilities.Error import qualified System.Logger.Class as Log -import System.Logger.Message ((+++), msg, val) +import System.Logger.Message (msg, val, (+++)) import qualified Wire.API.Conversation as Public conversationView :: MappedOrLocalId Id.U -> Data.Conversation -> Galley Public.Conversation diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 791a5866f04..f21292b0e20 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -1071,10 +1071,11 @@ filterMissing = (>>= go) <$> (query "ignore_missing" ||| query "report_missing") users :: ByteString -> ByteString -> P.Result P.Error (Set OpaqueUserId) users src bs = case fromByteString bs of Nothing -> - P.Fail $ P.setMessage "Boolean or list of user IDs expected." - $ P.setReason P.TypeError - $ P.setSource src - $ P.err status400 + P.Fail $ + P.setMessage "Boolean or list of user IDs expected." $ + P.setReason P.TypeError $ + P.setSource src $ + P.err status400 -- NB. 'fromByteString' parses a comma-separated list ('List') of -- user IDs, and then 'fromList' unwraps it; took me a while to -- understand this diff --git a/services/galley/src/Galley/API/Swagger.hs b/services/galley/src/Galley/API/Swagger.hs index 973a21999fc..2d0da3ef867 100644 --- a/services/galley/src/Galley/API/Swagger.hs +++ b/services/galley/src/Galley/API/Swagger.hs @@ -33,8 +33,7 @@ import Brig.Types.Client.Prekey (LastPrekey, Prekey, PrekeyId) import Brig.Types.Provider import Brig.Types.Team.LegalHold import Control.Lens -import Data.Aeson (toJSON) -import Data.Aeson (Value (..)) +import Data.Aeson (Value (..), toJSON) import Data.HashMap.Strict.InsOrd import Data.Id import Data.LegalHold @@ -157,14 +156,15 @@ instance ToSchema NewLegalHoldService where instance ToSchema ViewLegalHoldService where declareNamedSchema _ = - pure $ NamedSchema (Just "ViewLegalHoldService") $ - mempty - & properties .~ properties_ - & example .~ Just (toJSON example_) - & required .~ ["status"] - & minProperties .~ Just 1 - & maxProperties .~ Just 2 - & type_ .~ Just SwaggerObject + pure $ + NamedSchema (Just "ViewLegalHoldService") $ + mempty + & properties .~ properties_ + & example .~ Just (toJSON example_) + & required .~ ["status"] + & minProperties .~ Just 1 + & maxProperties .~ Just 2 + & type_ .~ Just SwaggerObject where properties_ :: InsOrdHashMap Text (Referenced Schema) properties_ = @@ -204,12 +204,13 @@ instance ToSchema ViewLegalHoldServiceInfo where } -} declareNamedSchema _ = - pure $ NamedSchema (Just "ViewLegalHoldServiceInfo") $ - mempty - & properties .~ properties_ - & example .~ Just (toJSON example_) - & required .~ ["team_id", "base_url", "fingerprint", "auth_token", "public_key"] - & type_ .~ Just SwaggerObject + pure $ + NamedSchema (Just "ViewLegalHoldServiceInfo") $ + mempty + & properties .~ properties_ + & example .~ Just (toJSON example_) + & required .~ ["team_id", "base_url", "fingerprint", "auth_token", "public_key"] + & type_ .~ Just SwaggerObject where properties_ :: InsOrdHashMap Text (Referenced Schema) properties_ = @@ -226,12 +227,13 @@ instance ToSchema ViewLegalHoldServiceInfo where instance ToSchema TeamFeatureStatus where declareNamedSchema _ = - pure $ NamedSchema (Just "TeamFeatureStatus") $ - mempty - & properties .~ (fromList [("status", Inline statusValue)]) - & required .~ ["status"] - & type_ ?~ SwaggerObject - & description ?~ "whether a given team feature is enabled" + pure $ + NamedSchema (Just "TeamFeatureStatus") $ + mempty + & properties .~ (fromList [("status", Inline statusValue)]) + & required .~ ["status"] + & type_ ?~ SwaggerObject + & description ?~ "whether a given team feature is enabled" where statusValue = mempty @@ -259,13 +261,14 @@ instance ToSchema NewLegalHoldClient where instance ToSchema UserLegalHoldStatusResponse where declareNamedSchema _ = - pure $ NamedSchema (Just "UserLegalHoldStatusResponse") $ - mempty - & properties .~ properties_ - & required .~ ["status"] - & minProperties .~ Just 1 - & maxProperties .~ Just 3 - & type_ .~ Just SwaggerObject + pure $ + NamedSchema (Just "UserLegalHoldStatusResponse") $ + mempty + & properties .~ properties_ + & required .~ ["status"] + & minProperties .~ Just 1 + & maxProperties .~ Just 3 + & type_ .~ Just SwaggerObject where properties_ :: InsOrdHashMap Text (Referenced Schema) properties_ = @@ -277,11 +280,12 @@ instance ToSchema UserLegalHoldStatusResponse where instance ToSchema a => ToSchema (IdObject a) where declareNamedSchema _ = - pure $ NamedSchema (Just "IdObject a") $ - mempty - & properties .~ properties_ - & required .~ ["id"] - & type_ .~ Just SwaggerObject + pure $ + NamedSchema (Just "IdObject a") $ + mempty + & properties .~ properties_ + & required .~ ["id"] + & type_ .~ Just SwaggerObject where properties_ :: InsOrdHashMap Text (Referenced Schema) properties_ = diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index e5afb96ec76..0f73416b321 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -62,8 +62,8 @@ import Brig.Types.Team (TeamSize (..)) import Control.Lens import Control.Monad.Catch import Data.ByteString.Conversion hiding (fromList) -import qualified Data.Id as Id import Data.Id +import qualified Data.Id as Id import Data.IdMapping (MappedOrLocalId (Local)) import qualified Data.List.Extra as List import Data.List1 (list1) @@ -493,11 +493,12 @@ updateTeamMember zusr zcon tid targetMember = do -- user may not elevate permissions targetPermissions `ensureNotElevated` user - previousMember <- Data.teamMember tid targetId >>= \case - Nothing -> - -- target user must be in same team - throwM teamMemberNotFound - Just previousMember -> pure previousMember + previousMember <- + Data.teamMember tid targetId >>= \case + Nothing -> + -- target user must be in same team + throwM teamMemberNotFound + Just previousMember -> pure previousMember when ( downgradesOwner previousMember targetPermissions && not (canDowngradeOwner user previousMember) @@ -511,21 +512,20 @@ updateTeamMember zusr zcon tid targetMember = do updateJournal team updatedMembers updatePeers targetId targetPermissions updatedMembers where - -- canDowngradeOwner = canDeleteMember - -- + downgradesOwner :: TeamMember -> Permissions -> Bool downgradesOwner previousMember targetPermissions = permissionsRole (previousMember ^. permissions) == Just RoleOwner && permissionsRole targetPermissions /= Just RoleOwner - -- + updateJournal :: Team -> TeamMemberList -> Galley () updateJournal team mems = do when (team ^. teamBinding == Binding) $ do (TeamSize size) <- BrigTeam.getSize tid billingUserIds <- Journal.getBillingUserIds tid $ Just mems Journal.teamUpdate tid size billingUserIds - -- + updatePeers :: UserId -> Permissions -> TeamMemberList -> Galley () updatePeers targetId targetPermissions updatedMembers = do -- inform members of the team about the change @@ -609,12 +609,13 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do let tmids = Set.fromList $ map (Local . view userId) (mems ^. teamMembers) let edata = Conv.EdMembersLeave (Conv.UserIdList [remove]) cc <- Data.teamConversations tid - for_ cc $ \c -> Data.conversation (c ^. conversationId) >>= \conv -> - for_ conv $ \dc -> when (Local remove `isMember` Data.convMembers dc) $ do - Data.removeMember (Local remove) (c ^. conversationId) - -- If the list was truncated, then the tmids list is incomplete so we simply drop these events - unless (c ^. managedConversation || mems ^. teamMemberListType == ListTruncated) $ - pushEvent tmids edata now dc + for_ cc $ \c -> + Data.conversation (c ^. conversationId) >>= \conv -> + for_ conv $ \dc -> when (Local remove `isMember` Data.convMembers dc) $ do + Data.removeMember (Local remove) (c ^. conversationId) + -- If the list was truncated, then the tmids list is incomplete so we simply drop these events + unless (c ^. managedConversation || mems ^. teamMemberListType == ListTruncated) $ + pushEvent tmids edata now dc pushEvent :: Set (MappedOrLocalId Id.U) -> Conv.EventData -> UTCTime -> Data.Conversation -> Galley () pushEvent exceptTo edata now dc = do (bots, users) <- botsAndUsers (Data.convMembers dc) @@ -796,14 +797,14 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do where parseSince :: Galley (Maybe Public.NotificationId) parseSince = maybe (pure Nothing) (fmap Just . parseUUID) sinceRaw - -- + parseUUID :: ByteString -> Galley Public.NotificationId parseUUID raw = maybe (throwM invalidTeamNotificationId) (pure . Id) ((UUID.fromASCIIBytes >=> isV1UUID) raw) - -- + isV1UUID :: UUID.UUID -> Maybe UUID.UUID isV1UUID u = if UUID.version u == 1 then Just u else Nothing diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index e35bf40a6cc..127b44f0c7d 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -94,7 +94,7 @@ import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (_1, _2, failure, setStatus) +import Network.Wai.Predicate hiding (failure, setStatus, _1, _2) import Network.Wai.Utilities import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Code as Public @@ -119,9 +119,9 @@ blockConvH (zusr ::: cnv) = do blockConv :: UserId -> ConvId -> Galley () blockConv zusr cnv = do conv <- Data.conversation cnv >>= ifNothing convNotFound - unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) - $ throwM - $ invalidOp "block: invalid conversation type" + unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ + throwM $ + invalidOp "block: invalid conversation type" let mems = Data.convMembers conv when (Local zusr `isMember` mems) $ Data.removeMember (Local zusr) cnv @@ -132,9 +132,9 @@ unblockConvH (usr ::: conn ::: cnv) = do unblockConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation unblockConv usr conn cnv = do conv <- Data.conversation cnv >>= ifNothing convNotFound - unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) - $ throwM - $ invalidOp "unblock: invalid conversation type" + unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ + throwM $ + invalidOp "unblock: invalid conversation type" conv' <- acceptOne2One usr conv conn conversationView (Local usr) conv' @@ -690,9 +690,9 @@ newMessage usr con cnv msg now (m, c, t) ~(toBots, toUsers) = let p = newPush ListComplete (evtFrom e) (ConvEvent e) [r] <&> set pushConn con - . set pushNativePriority (newOtrNativePriority msg) - . set pushRoute (bool RouteDirect RouteAny (newOtrNativePush msg)) - . set pushTransient (newOtrTransient msg) + . set pushNativePriority (newOtrNativePriority msg) + . set pushRoute (bool RouteDirect RouteAny (newOtrNativePush msg)) + . set pushTransient (newOtrTransient msg) in (toBots, p : toUsers) updateConversationDeprecatedH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.ConversationRename -> Galley Response @@ -902,9 +902,10 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = Teams.withBindingTeam -- In large teams, we may still use the broadcast endpoint but only if `report_missing` -- is used and length `report_missing` < limit since we cannot fetch larger teams than -- that. - tMembers <- fmap (view userId) <$> case val of - OtrReportMissing us -> maybeFetchLimitedTeamMemberList limit tid us - _ -> maybeFetchAllMembersInTeam tid + tMembers <- + fmap (view userId) <$> case val of + OtrReportMissing us -> maybeFetchLimitedTeamMemberList limit tid us + _ -> maybeFetchAllMembersInTeam tid contacts <- getContactList usr let users = Set.toList $ Set.union (Set.fromList tMembers) (Set.fromList contacts) isInternal <- view $ options . optSettings . setIntraListing diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 3d94051c836..59e0fca8083 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -19,7 +19,7 @@ module Galley.API.Util where import Brig.Types (Relation (..)) import Brig.Types.Intra (ReAuthUser (..)) -import Control.Lens ((.~), (^.), view) +import Control.Lens (view, (.~), (^.)) import Control.Monad.Catch import Data.ByteString.Conversion import Data.Domain (Domain) @@ -154,11 +154,12 @@ assertOnTeam uid tid = do -- | If the conversation is in a team, throw iff zusr is a team member and does not have named -- permission. If the conversation is not in a team, do nothing (no error). permissionCheckTeamConv :: UserId -> ConvId -> Perm -> Galley () -permissionCheckTeamConv zusr cnv perm = Data.conversation cnv >>= \case - Just cnv' -> case Data.convTeam cnv' of - Just tid -> void $ permissionCheck perm =<< Data.teamMember tid zusr - Nothing -> pure () - Nothing -> throwM convNotFound +permissionCheckTeamConv zusr cnv perm = + Data.conversation cnv >>= \case + Just cnv' -> case Data.convTeam cnv' of + Just tid -> void $ permissionCheck perm =<< Data.teamMember tid zusr + Nothing -> pure () + Nothing -> throwM convNotFound -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: UserId -> Data.Conversation -> Maybe ConnId -> Galley Data.Conversation diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 038b5f1712a..43bd9784230 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -164,7 +164,7 @@ validateOptions l o = do instance MonadUnliftIO Galley where askUnliftIO = - Galley $ ReaderT $ \r -> + Galley . ReaderT $ \r -> withUnliftIO $ \u -> return (UnliftIO (unliftIO u . flip runReaderT r . unGalley)) diff --git a/services/galley/src/Galley/Aws.hs b/services/galley/src/Galley/Aws.hs index 0284eff6a67..5f5f055a7c6 100644 --- a/services/galley/src/Galley/Aws.hs +++ b/services/galley/src/Galley/Aws.hs @@ -95,7 +95,7 @@ newtype Amazon a = Amazon ) instance MonadUnliftIO Amazon where - askUnliftIO = Amazon $ ReaderT $ \r -> + askUnliftIO = Amazon . ReaderT $ \r -> withUnliftIO $ \u -> return (UnliftIO (unliftIO u . flip runReaderT r . unAmazon)) @@ -150,9 +150,9 @@ mkEnv lgr mgr opts = do getQueueUrl :: AWS.Env -> Text -> IO QueueUrl getQueueUrl e q = do x <- - runResourceT . AWST.runAWST e - $ AWST.trying AWS._Error - $ AWST.send (SQS.getQueueURL q) + runResourceT . AWST.runAWST e $ + AWST.trying AWS._Error $ + AWST.send (SQS.getQueueURL q) either (throwM . GeneralError) (return . QueueUrl . view SQS.gqursQueueURL) diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 7d2bbbbe940..355a6b09adb 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -369,7 +369,7 @@ deleteTeam tid = do addTeamMember :: MonadClient m => TeamId -> TeamMember -> m () addTeamMember t m = - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery @@ -394,7 +394,7 @@ updateTeamMember :: Permissions -> m () updateTeamMember oldPerms tid uid newPerms = do - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery Cql.updatePermissions (newPerms, tid, uid) @@ -411,7 +411,7 @@ updateTeamMember oldPerms tid uid newPerms = do removeTeamMember :: MonadClient m => TeamId -> UserId -> m () removeTeamMember t m = - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery Cql.deleteTeamMember (t, m) @@ -425,7 +425,7 @@ listBillingTeamMembers tid = removeTeamConv :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => TeamId -> ConvId -> m () removeTeamConv tid cid = do - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery Cql.markConvDeleted (Identity cid) @@ -436,7 +436,7 @@ updateTeamStatus :: MonadClient m => TeamId -> TeamStatus -> m () updateTeamStatus t s = retry x5 $ write Cql.updateTeamStatus (params Quorum (s, t)) updateTeam :: MonadClient m => TeamId -> TeamUpdateData -> m () -updateTeam tid u = retry x5 $ batch $ do +updateTeam tid u = retry x5 . batch $ do setType BatchLogged setConsistency Quorum for_ (u ^. nameUpdate) $ \n -> @@ -805,7 +805,7 @@ addMembersUncheckedWithRole t conv (orig, _origRole) usrs = do -- With chunk size of 64: -- [galley] Server warning: Batch for [galley_test.member, galley_test.user] is of size 7040, exceeding specified threshold of 5120 by 1920. for_ (List.chunksOf 32 (toList usrs)) $ \chunk -> do - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchLogged setConsistency Quorum for_ chunk $ \(u, r) -> do @@ -826,7 +826,7 @@ addMembersUncheckedWithRole t conv (orig, _origRole) usrs = do updateMember :: MonadClient m => ConvId -> UserId -> MemberUpdate -> m MemberUpdateData updateMember cid uid mup = do - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchUnLogged setConsistency Quorum let opaqueUserId = makeIdOpaque uid @@ -856,7 +856,7 @@ updateMember cid uid mup = do removeMembers :: MonadClient m => Conversation -> UserId -> List1 (MappedOrLocalId Id.U) -> m Event removeMembers conv orig victims = do t <- liftIO getCurrentTime - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchLogged setConsistency Quorum for_ (toList victims) $ \u -> do @@ -876,7 +876,7 @@ removeMembers conv orig victims = do Mapped _ -> Nothing removeMember :: MonadClient m => MappedOrLocalId Id.U -> ConvId -> m () -removeMember usr cnv = retry x5 $ batch $ do +removeMember usr cnv = retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery Cql.removeMember (cnv, opaqueIdFromMappedOrLocal usr) diff --git a/services/galley/src/Galley/Data/CustomBackend.hs b/services/galley/src/Galley/Data/CustomBackend.hs index 9d7a668956e..10cd979b8af 100644 --- a/services/galley/src/Galley/Data/CustomBackend.hs +++ b/services/galley/src/Galley/Data/CustomBackend.hs @@ -32,8 +32,9 @@ import Galley.Types import Imports getCustomBackend :: MonadClient m => Domain -> m (Maybe CustomBackend) -getCustomBackend domain = fmap toCustomBackend <$> do - retry x1 $ query1 Cql.selectCustomBackend (params Quorum (Identity domain)) +getCustomBackend domain = + fmap toCustomBackend <$> do + retry x1 $ query1 Cql.selectCustomBackend (params Quorum (Identity domain)) where toCustomBackend (backendConfigJsonUrl, backendWebappWelcomeUrl) = CustomBackend {..} diff --git a/services/galley/src/Galley/Data/IdMapping.hs b/services/galley/src/Galley/Data/IdMapping.hs index 4a03b3dcbd6..42df6870dc0 100644 --- a/services/galley/src/Galley/Data/IdMapping.hs +++ b/services/galley/src/Galley/Data/IdMapping.hs @@ -32,8 +32,9 @@ import Imports -- | Only a single namespace/table is used for for potentially multiple different types of -- mapped IDs. getIdMapping :: MonadClient m => Id (Mapped a) -> m (Maybe (IdMapping a)) -getIdMapping mappedId = fmap toIdMapping <$> do - retry x1 $ query1 Cql.selectIdMapping (params Quorum (Identity mappedId)) +getIdMapping mappedId = + fmap toIdMapping <$> do + retry x1 $ query1 Cql.selectIdMapping (params Quorum (Identity mappedId)) where toIdMapping (remoteId, domain) = IdMapping mappedId (Qualified remoteId domain) diff --git a/services/galley/src/Galley/Data/LegalHold.hs b/services/galley/src/Galley/Data/LegalHold.hs index 857fa9aa499..7a01ffb5824 100644 --- a/services/galley/src/Galley/Data/LegalHold.hs +++ b/services/galley/src/Galley/Data/LegalHold.hs @@ -48,8 +48,9 @@ createSettings (LegalHoldService tid url fpr tok key) = do -- | Returns 'Nothing' if no settings are saved -- The Caller is responsible for checking whether legal hold is enabled for this team getSettings :: MonadClient m => TeamId -> m (Maybe LegalHoldService) -getSettings tid = fmap toLegalHoldService <$> do - retry x1 $ query1 selectLegalHoldSettings (params Quorum (Identity tid)) +getSettings tid = + fmap toLegalHoldService <$> do + retry x1 $ query1 selectLegalHoldSettings (params Quorum (Identity tid)) where toLegalHoldService (httpsUrl, fingerprint, tok, key) = LegalHoldService tid httpsUrl fingerprint tok key @@ -57,10 +58,10 @@ removeSettings :: MonadClient m => TeamId -> m () removeSettings tid = retry x5 (write removeLegalHoldSettings (params Quorum (Identity tid))) insertPendingPrekeys :: MonadClient m => UserId -> [Prekey] -> m () -insertPendingPrekeys uid keys = retry x5 . batch - $ forM_ keys - $ \key -> - addPrepQuery Q.insertPendingPrekeys (toTuple key) +insertPendingPrekeys uid keys = retry x5 . batch $ + forM_ keys $ + \key -> + addPrepQuery Q.insertPendingPrekeys (toTuple key) where toTuple (Prekey keyId key) = (uid, keyId, key) diff --git a/services/galley/src/Galley/Data/SearchVisibility.hs b/services/galley/src/Galley/Data/SearchVisibility.hs index 72b3085ec34..680a74702b0 100644 --- a/services/galley/src/Galley/Data/SearchVisibility.hs +++ b/services/galley/src/Galley/Data/SearchVisibility.hs @@ -33,8 +33,9 @@ import Imports -- | Return whether a given team is allowed to enable/disable sso getSearchVisibility :: MonadClient m => TeamId -> m TeamSearchVisibility -getSearchVisibility tid = toSearchVisibility <$> do - retry x1 $ query1 selectSearchVisibility (params Quorum (Identity tid)) +getSearchVisibility tid = + toSearchVisibility <$> do + retry x1 $ query1 selectSearchVisibility (params Quorum (Identity tid)) where -- The value is either set or we return the default toSearchVisibility :: (Maybe (Identity (Maybe TeamSearchVisibility))) -> TeamSearchVisibility diff --git a/services/galley/src/Galley/Data/Services.hs b/services/galley/src/Galley/Data/Services.hs index 4692c52c758..b35fbcb5e2a 100644 --- a/services/galley/src/Galley/Data/Services.hs +++ b/services/galley/src/Galley/Data/Services.hs @@ -64,7 +64,7 @@ addBotMember :: UserId -> ServiceRef -> BotId -> ConvId -> UTCTime -> Galley (Ev addBotMember orig s bot cnv now = do let pid = s ^. serviceRefProvider let sid = s ^. serviceRefId - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery insertUserConv (botUserId bot, makeIdOpaque cnv, Nothing, Nothing) diff --git a/services/galley/src/Galley/Data/TeamNotifications.hs b/services/galley/src/Galley/Data/TeamNotifications.hs index 9feb8d22f12..1922c1580ab 100644 --- a/services/galley/src/Galley/Data/TeamNotifications.hs +++ b/services/galley/src/Galley/Data/TeamNotifications.hs @@ -35,7 +35,7 @@ import qualified Data.Aeson as JSON import Data.Id import Data.List1 (List1) import Data.Range (Range, fromRange) -import Data.Sequence ((<|), (><), Seq, ViewL (..), ViewR (..)) +import Data.Sequence (Seq, ViewL (..), ViewR (..), (<|), (><)) import qualified Data.Sequence as Seq import Gundeck.Types.Notification import Imports @@ -128,9 +128,9 @@ toNotif (i, b) ns = ns (\p1 -> queuedNotification notifId p1 : ns) ( JSON.decode' (fromBlob b) - -- FUTUREWORK: this is from the database, so it's slightly more ok to ignore parse - -- errors than if it's data provided by a client. it would still be better to have an - -- error entry in the log file and crash, rather than ignore the error and continue. + -- FUTUREWORK: this is from the database, so it's slightly more ok to ignore parse + -- errors than if it's data provided by a client. it would still be better to have an + -- error entry in the log file and crash, rather than ignore the error and continue. ) where notifId = Id (fromTimeUuid i) diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index a43dac6a93c..22b76e9a0af 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -103,17 +103,18 @@ deliver1 s bm e let u = s ^. serviceUrl let b = botMemId bm let HttpsUrl url = u - recovering x3 httpHandlers $ const - $ sendMessage (s ^. serviceFingerprints) - $ method POST - . maybe id host (urlHost u) - . maybe (port 443) port (urlPort u) - . paths [url ^. pathL, "bots", toByteString' b, "messages"] - . header "Authorization" ("Bearer " <> t) - . json e - . timeout 5000 - . secure - . expect2xx + recovering x3 httpHandlers $ + const $ + sendMessage (s ^. serviceFingerprints) $ + method POST + . maybe id host (urlHost u) + . maybe (port 443) port (urlPort u) + . paths [url ^. pathL, "bots", toByteString' b, "messages"] + . header "Authorization" ("Bearer " <> t) + . json e + . timeout 5000 + . secure + . expect2xx | otherwise = return () urlHost :: HttpsUrl -> Maybe ByteString @@ -128,7 +129,7 @@ urlPort (HttpsUrl u) = do sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> Galley () sendMessage fprs reqBuilder = do (man, verifyFingerprints) <- view (extEnv . extGetManager) - liftIO $ withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ \req -> + liftIO . withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ \req -> Http.withResponse req man (const $ return ()) x3 :: RetryPolicy diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index 39d0bb270c7..67d2f6bd9ac 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -70,7 +70,8 @@ import URI.ByteString (uriPath) checkLegalHoldServiceStatus :: Fingerprint Rsa -> HttpsUrl -> Galley () checkLegalHoldServiceStatus fpr url = do resp <- makeVerifiedRequestFreshManager fpr url reqBuilder - if | Bilge.statusCode resp < 400 -> pure () + if + | Bilge.statusCode resp < 400 -> pure () | otherwise -> do Log.info . Log.msg $ showResponse resp throwM legalHoldServiceBadResponse @@ -176,10 +177,12 @@ makeVerifiedRequestWithManager :: Http.Manager -> ([Fingerprint Rsa] -> SSL.SSL makeVerifiedRequestWithManager mgr verifyFingerprints fpr (HttpsUrl url) reqBuilder = do let verified = verifyFingerprints [fpr] extHandleAll errHandler $ do - recovering x3 httpHandlers $ const $ liftIO - $ withVerifiedSslConnection verified mgr (reqBuilderMods . reqBuilder) - $ \req -> - Http.httpLbs req mgr + recovering x3 httpHandlers $ + const $ + liftIO $ + withVerifiedSslConnection verified mgr (reqBuilderMods . reqBuilder) $ + \req -> + Http.httpLbs req mgr where reqBuilderMods = maybe id Bilge.host (Bilge.extHost url) @@ -211,20 +214,21 @@ makeVerifiedRequestWithManager mgr verifyFingerprints fpr (HttpsUrl url) reqBuil -- FUTUREWORK: It would be nice to move (part of) this to ssl-util, but it has types from -- brig-types and types-common. validateServiceKey :: MonadIO m => ServiceKeyPEM -> m (Maybe (ServiceKey, Fingerprint Rsa)) -validateServiceKey pem = liftIO $ - readPublicKey >>= \pk -> - case join (SSL.toPublicKey <$> pk) of - Nothing -> return Nothing - Just pk' -> do - Just sha <- SSL.getDigestByName "SHA256" - let size = SSL.rsaSize (pk' :: SSL.RSAPubKey) - if size < minRsaKeySize - then return Nothing - else do - fpr <- Fingerprint <$> SSL.rsaFingerprint sha pk' - let bits = fromIntegral size * 8 - let key = ServiceKey RsaServiceKey bits pem - return $ Just (key, fpr) +validateServiceKey pem = + liftIO $ + readPublicKey >>= \pk -> + case join (SSL.toPublicKey <$> pk) of + Nothing -> return Nothing + Just pk' -> do + Just sha <- SSL.getDigestByName "SHA256" + let size = SSL.rsaSize (pk' :: SSL.RSAPubKey) + if size < minRsaKeySize + then return Nothing + else do + fpr <- Fingerprint <$> SSL.rsaFingerprint sha pk' + let bits = fromIntegral size * 8 + let key = ServiceKey RsaServiceKey bits pem + return $ Just (key, fpr) where readPublicKey = handleAny diff --git a/services/galley/src/Galley/Intra/Journal.hs b/services/galley/src/Galley/Intra/Journal.hs index 84b118fd34a..234db9ebbac 100644 --- a/services/galley/src/Galley/Intra/Journal.hs +++ b/services/galley/src/Galley/Intra/Journal.hs @@ -65,16 +65,17 @@ teamSuspend :: TeamId -> Galley () teamSuspend tid = journalEvent TeamEvent'TEAM_SUSPEND tid Nothing Nothing journalEvent :: TeamEvent'EventType -> TeamId -> Maybe TeamEvent'EventData -> Maybe TeamCreationTime -> Galley () -journalEvent typ tid dat tim = view aEnv >>= \mEnv -> for_ mEnv $ \e -> do - -- writetime is in microseconds in cassandra 3.11 - ts <- maybe now (return . (`div` 1000000) . view tcTime) tim - let ev = - defMessage - & T.eventType .~ typ - & T.teamId .~ toBytes tid - & T.utcTime .~ ts - & T.maybe'eventData .~ dat - Aws.execute e (Aws.enqueue ev) +journalEvent typ tid dat tim = + view aEnv >>= \mEnv -> for_ mEnv $ \e -> do + -- writetime is in microseconds in cassandra 3.11 + ts <- maybe now (return . (`div` 1000000) . view tcTime) tim + let ev = + defMessage + & T.eventType .~ typ + & T.teamId .~ toBytes tid + & T.utcTime .~ ts + & T.maybe'eventData .~ dat + Aws.execute e (Aws.enqueue ev) ---------------------------------------------------------------------------- -- utils @@ -101,11 +102,11 @@ getBillingUserIds tid maybeMemberList = do where fetchFromDB :: Galley [UserId] fetchFromDB = Data.listBillingTeamMembers tid - -- + filterFromMembers :: TeamMemberList -> Galley [UserId] filterFromMembers list = pure $ map (view userId) $ filter (`hasPermission` SetBilling) (list ^. teamMembers) - -- + handleList :: Bool -> TeamMemberList -> Galley [UserId] handleList enableIndexedBillingTeamMembers list = case list ^. teamMemberListType of diff --git a/services/galley/src/Galley/Intra/Push.hs b/services/galley/src/Galley/Intra/Push.hs index e1f29fdbf30..27a4944fcc1 100644 --- a/services/galley/src/Galley/Intra/Push.hs +++ b/services/galley/src/Galley/Intra/Push.hs @@ -50,7 +50,7 @@ where import Bilge hiding (options) import Bilge.RPC import Bilge.Retry -import Control.Lens ((&), (.~), (^.), makeLenses, set, view) +import Control.Lens (makeLenses, set, view, (&), (.~), (^.)) import Control.Monad.Catch import Control.Retry import Data.Aeson (Object) @@ -159,12 +159,12 @@ push ps = do where (localRecipients, remoteRecipients) = partitionEithers . fmap localOrRemoteRecipient . toList $ pushRecipients p - -- + localOrRemoteRecipient :: RecipientBy (MappedOrLocalId Id.U) -> Either (RecipientBy UserId) (RecipientBy (IdMapping Id.U)) localOrRemoteRecipient rcp = case _recipientUserId rcp of Local localId -> Left $ rcp {_recipientUserId = localId} Mapped idMapping -> Right $ rcp {_recipientUserId = idMapping} - -- + mkPushTo :: [RecipientBy a] -> PushTo b -> Maybe (PushTo a) mkPushTo recipients p = nonEmpty recipients <&> \nonEmptyRecipients -> diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index 495c1de5be5..9e2dd2cd3b4 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -28,10 +28,9 @@ where import Bilge hiding (getHeader, options, statusCode) import Bilge.RPC -import Brig.Types.Connection (UserIds (..)) -import Brig.Types.Connection (ConnectionsStatusRequest (..), Relation (..)) -import Brig.Types.Intra (ConnectionStatus (..), ReAuthUser (..)) +import Brig.Types.Connection (ConnectionsStatusRequest (..), Relation (..), UserIds (..)) import Brig.Types.Intra +import Brig.Types.Intra (ConnectionStatus (..), ReAuthUser (..)) import Brig.Types.User (User) import Control.Monad.Catch (throwM) import Data.ByteString.Char8 (pack) @@ -71,13 +70,14 @@ getConnections uFrom uTo rlt = do deleteBot :: ConvId -> BotId -> Galley () deleteBot cid bot = do (h, p) <- brigReq - void $ call "brig" $ - method DELETE . host h . port p - . path "/bot/self" - . header "Z-Type" "bot" - . header "Z-Bot" (toByteString' bot) - . header "Z-Conversation" (toByteString' cid) - . expect2xx + void $ + call "brig" $ + method DELETE . host h . port p + . path "/bot/self" + . header "Z-Type" "bot" + . header "Z-Bot" (toByteString' bot) + . header "Z-Conversation" (toByteString' cid) + . expect2xx -- | Calls 'Brig.User.API.Auth.reAuthUserH'. reAuthUser :: UserId -> ReAuthUser -> Galley Bool @@ -129,10 +129,11 @@ getUser uid = do deleteUser :: UserId -> Galley () deleteUser uid = do (h, p) <- brigReq - void $ call "brig" $ - method DELETE . host h . port p - . paths ["/i/users", toByteString' uid] - . expect2xx + void $ + call "brig" $ + method DELETE . host h . port p + . paths ["/i/users", toByteString' uid] + . expect2xx -- | Calls 'Brig.API.getContactListH'. getContactList :: UserId -> Galley [UserId] diff --git a/services/galley/src/Galley/Options.hs b/services/galley/src/Galley/Options.hs index 079bae85332..9fa67bc5c5c 100644 --- a/services/galley/src/Galley/Options.hs +++ b/services/galley/src/Galley/Options.hs @@ -17,7 +17,7 @@ module Galley.Options where -import Control.Lens hiding ((.=), Level) +import Control.Lens hiding (Level, (.=)) import Data.Aeson.TH (deriveFromJSON) import Data.Domain (Domain) import Data.Misc diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 0749663760f..4d2786666f9 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -25,15 +25,15 @@ import Cassandra (runClient, shutdown) import Cassandra.Schema (versionCheck) import qualified Control.Concurrent.Async as Async import Control.Exception (finally) -import Control.Lens ((^.), view) +import Control.Lens (view, (^.)) import qualified Data.Metrics.Middleware as M import Data.Metrics.Middleware.Prometheus (waiPrometheusMiddleware) import Data.Misc (portNumber) import Data.Text (unpack) import Galley.API (sitemap) import qualified Galley.API.Internal as Internal -import qualified Galley.App as App import Galley.App +import qualified Galley.App as App import qualified Galley.Data as Data import Galley.Options (Opts, optGalley) import qualified Galley.Queue as Q diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index a261297f41d..34db3b8cfa2 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -54,7 +54,7 @@ import Gundeck.Types.Notification import Imports import Network.Wai.Utilities.Error import Test.Tasty -import Test.Tasty.Cannon ((#), TimeoutUnit (..)) +import Test.Tasty.Cannon (TimeoutUnit (..), (#)) import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import TestHelpers @@ -384,8 +384,9 @@ postJoinConvOk = do WS.bracketR2 c alice bob $ \(wsA, wsB) -> do postJoinConv bob conv !!! const 200 === statusCode postJoinConv bob conv !!! const 204 === statusCode - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB] $ - wsAssertMemberJoinWithRole conv bob [bob] roleNameWireMember + void . liftIO $ + WS.assertMatchN (5 # Second) [wsA, wsB] $ + wsAssertMemberJoinWithRole conv bob [bob] roleNameWireMember postJoinCodeConvOk :: TestM () postJoinCodeConvOk = do @@ -412,8 +413,9 @@ postJoinCodeConvOk = do postJoinCodeConv bob payload !!! const 204 === statusCode -- eve cannot join postJoinCodeConv eve payload !!! const 403 === statusCode - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB] $ - wsAssertMemberJoinWithRole conv bob [bob] roleNameWireMember + void . liftIO $ + WS.assertMatchN (5 # Second) [wsA, wsB] $ + wsAssertMemberJoinWithRole conv bob [bob] roleNameWireMember -- changing access to non-activated should give eve access let nonActivatedAccess = ConversationAccessUpdate [CodeAccess] NonActivatedAccessRole putAccessUpdate alice conv nonActivatedAccess !!! const 200 === statusCode @@ -441,8 +443,9 @@ postConvertCodeConv = do putAccessUpdate alice conv nonActivatedAccess !!! const 200 === statusCode -- test no-op putAccessUpdate alice conv nonActivatedAccess !!! const 204 === statusCode - void . liftIO $ WS.assertMatchN (5 # Second) [wsA] $ - wsAssertConvAccessUpdate conv alice nonActivatedAccess + void . liftIO $ + WS.assertMatchN (5 # Second) [wsA] $ + wsAssertConvAccessUpdate conv alice nonActivatedAccess -- Create/get/update/delete codes getConvCode alice conv !!! const 404 === statusCode c1 <- decodeConvCodeEvent <$> (postConvCode alice conv postConvCode alice conv WS.bracketR3 c alice bob eve $ \(wsA, wsB, wsE) -> do postJoinCodeConv mallory j !!! const 200 === statusCode - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB, wsE] $ - wsAssertMemberJoinWithRole conv mallory [mallory] roleNameWireMember + void . liftIO $ + WS.assertMatchN (5 # Second) [wsA, wsB, wsE] $ + wsAssertMemberJoinWithRole conv mallory [mallory] roleNameWireMember WS.bracketRN c [alice, bob, eve, mallory] $ \[wsA, wsB, wsE, wsM] -> do let teamAccess = ConversationAccessUpdate [InviteAccess, CodeAccess] TeamAccessRole putAccessUpdate alice conv teamAccess !!! const 200 === statusCode - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB, wsE, wsM] $ - wsAssertConvAccessUpdate conv alice teamAccess + void . liftIO $ + WS.assertMatchN (5 # Second) [wsA, wsB, wsE, wsM] $ + wsAssertConvAccessUpdate conv alice teamAccess -- non-team members get kicked out - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB, wsE, wsM] $ - wsAssertMemberLeave conv alice [eve, mallory] + void . liftIO $ + WS.assertMatchN (5 # Second) [wsA, wsB, wsE, wsM] $ + wsAssertMemberLeave conv alice [eve, mallory] -- joining (for mallory) is no longer possible postJoinCodeConv mallory j !!! const 403 === statusCode -- team members (dave) can still join @@ -535,7 +541,7 @@ getConvsOk2 = do let cs = convList <$> responseJsonUnsafe rs let c1 = cs >>= find ((== cnvId cnv1) . cnvId) let c2 = cs >>= find ((== cnvId cnv2) . cnvId) - liftIO $ forM_ [(cnv1, c1), (cnv2, c2)] $ \(expected, actual) -> do + liftIO . forM_ [(cnv1, c1), (cnv2, c2)] $ \(expected, actual) -> do assertEqual "name mismatch" (Just $ cnvName expected) @@ -968,7 +974,7 @@ putConvRenameOk = do -- This endpoint should be deprecated but clients still use it WS.bracketR2 c alice bob $ \(wsA, wsB) -> do void $ putConversationName bob conv "gossip++" !!! const 200 === statusCode - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB] $ \n -> do + void . liftIO . WS.assertMatchN (5 # Second) [wsA, wsB] $ \n -> do let e = List1.head (WS.unpackPayload n) ntfTransient n @?= False evtConv e @?= conv @@ -1030,7 +1036,7 @@ putMemberOk update = do -- Update member state & verify push notification WS.bracketR c bob $ \ws -> do putMember bob update conv !!! const 200 === statusCode - void . liftIO $ WS.assertMatch (5 # Second) ws $ \n -> do + void . liftIO . WS.assertMatch (5 # Second) ws $ \n -> do let e = List1.head (WS.unpackPayload n) ntfTransient n @?= False evtConv e @?= conv @@ -1141,10 +1147,12 @@ removeUser = do conv3 <- decodeConvId <$> postConv alice [carl] (Just "gossip3") [] Nothing Nothing WS.bracketR3 c alice bob carl $ \(wsA, wsB, wsC) -> do deleteUser bob - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB] $ - matchMemberLeave conv1 bob - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB, wsC] $ - matchMemberLeave conv2 bob + void . liftIO $ + WS.assertMatchN (5 # Second) [wsA, wsB] $ + matchMemberLeave conv1 bob + void . liftIO $ + WS.assertMatchN (5 # Second) [wsA, wsB, wsC] $ + matchMemberLeave conv2 bob -- Check memberships mems1 <- fmap cnvMembers . responseJsonUnsafe <$> getConv alice conv1 mems2 <- fmap cnvMembers . responseJsonUnsafe <$> getConv alice conv2 diff --git a/services/galley/test/integration/API/IdMapping.hs b/services/galley/test/integration/API/IdMapping.hs index 3717117b8d6..d35d550bf44 100644 --- a/services/galley/test/integration/API/IdMapping.hs +++ b/services/galley/test/integration/API/IdMapping.hs @@ -22,12 +22,12 @@ module API.IdMapping where import API.Util (withSettingsOverrides) import Bilge hiding (timeout) import Bilge.Assert -import Control.Lens ((?~), view) +import Control.Lens (view, (?~)) import Data.ByteString.Conversion (toByteString') import Data.Coerce (coerce) import Data.Domain (Domain, mkDomain) -import qualified Data.Id as Id import Data.Id (Id) +import qualified Data.Id as Id import Data.Qualified (Qualified (Qualified)) import Galley.Options (optSettings, setEnableFederationWithDomain) import Galley.Types.IdMapping (PostIdMappingRequest (PostIdMappingRequest), PostIdMappingResponse (PostIdMappingResponse)) diff --git a/services/galley/test/integration/API/MessageTimer.hs b/services/galley/test/integration/API/MessageTimer.hs index f6aa0584501..e87eb88864a 100644 --- a/services/galley/test/integration/API/MessageTimer.hs +++ b/services/galley/test/integration/API/MessageTimer.hs @@ -32,7 +32,7 @@ import qualified Galley.Types.Teams as Teams import Imports hiding (head) import Network.Wai.Utilities.Error import Test.Tasty -import Test.Tasty.Cannon ((#), TimeoutUnit (..)) +import Test.Tasty.Cannon (TimeoutUnit (..), (#)) import qualified Test.Tasty.Cannon as WS import TestHelpers import TestSetup @@ -151,8 +151,9 @@ messageTimerEvent = do let update = ConversationMessageTimerUpdate timer1sec putMessageTimerUpdate alice cid update !!! const 200 === statusCode - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB] $ - wsAssertConvMessageTimerUpdate cid alice update + void . liftIO $ + WS.assertMatchN (5 # Second) [wsA, wsB] $ + wsAssertConvMessageTimerUpdate cid alice update ---------------------------------------------------------------------------- -- Utilities diff --git a/services/galley/test/integration/API/Roles.hs b/services/galley/test/integration/API/Roles.hs index 8e8f72ff691..d9fb7837771 100644 --- a/services/galley/test/integration/API/Roles.hs +++ b/services/galley/test/integration/API/Roles.hs @@ -28,7 +28,7 @@ import Galley.Types.Conversations.Roles import Imports import Network.Wai.Utilities.Error import Test.Tasty -import Test.Tasty.Cannon ((#), TimeoutUnit (..)) +import Test.Tasty.Cannon (TimeoutUnit (..), (#)) import qualified Test.Tasty.Cannon as WS import TestHelpers import TestSetup @@ -59,12 +59,14 @@ handleConversationRoleAdmin = do let cid = decodeConvId rsp -- Make sure everyone gets the correct event postMembersWithRole alice (singleton eve) cid role !!! const 200 === statusCode - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB, wsC] $ - wsAssertMemberJoinWithRole cid alice [eve] role + void . liftIO $ + WS.assertMatchN (5 # Second) [wsA, wsB, wsC] $ + wsAssertMemberJoinWithRole cid alice [eve] role -- Add a member to help out with testing postMembersWithRole alice (singleton jack) cid roleNameWireMember !!! const 200 === statusCode - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB, wsC] $ - wsAssertMemberJoinWithRole cid alice [jack] roleNameWireMember + void . liftIO $ + WS.assertMatchN (5 # Second) [wsA, wsB, wsC] $ + wsAssertMemberJoinWithRole cid alice [jack] roleNameWireMember return cid -- Added bob as a wire_admin and do the checks wireAdminChecks cid alice bob jack @@ -72,7 +74,7 @@ handleConversationRoleAdmin = do WS.bracketR3 c alice bob chuck $ \(wsA, wsB, wsC) -> do let updateDown = OtherMemberUpdate (Just roleNameWireMember) putOtherMember alice bob updateDown cid !!! assertActionSucceeded - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB, wsC] $ do + void . liftIO . WS.assertMatchN (5 # Second) [wsA, wsB, wsC] $ do wsAssertMemberUpdateWithRole cid alice bob roleNameWireMember wireMemberChecks cid bob alice jack @@ -94,8 +96,9 @@ handleConversationRoleMember = do let cid = decodeConvId rsp -- Make sure everyone gets the correct event postMembersWithRole alice (singleton eve) cid role !!! const 200 === statusCode - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB, wsC] $ - wsAssertMemberJoinWithRole cid alice [eve] role + void . liftIO $ + WS.assertMatchN (5 # Second) [wsA, wsB, wsC] $ + wsAssertMemberJoinWithRole cid alice [eve] role return cid -- Added bob as a wire_member and do the checks wireMemberChecks cid bob alice chuck @@ -105,7 +108,7 @@ handleConversationRoleMember = do -- Chuck cannot update, member only putOtherMember chuck bob updateUp cid !!! assertActionDenied putOtherMember alice bob updateUp cid !!! assertActionSucceeded - void . liftIO $ WS.assertMatchN (5 # Second) [wsA, wsB, wsC] $ do + void . liftIO . WS.assertMatchN (5 # Second) [wsA, wsB, wsC] $ do wsAssertMemberUpdateWithRole cid alice bob roleNameWireAdmin wireAdminChecks cid bob alice chuck diff --git a/services/galley/test/integration/API/SQS.hs b/services/galley/test/integration/API/SQS.hs index 489192a145d..afd7f1f7663 100644 --- a/services/galley/test/integration/API/SQS.hs +++ b/services/galley/test/integration/API/SQS.hs @@ -59,20 +59,23 @@ ensureQueueEmptyIO (Just env) = liftIO $ Aws.execute env purgeQueue ensureQueueEmptyIO Nothing = return () assertQueue :: String -> (String -> Maybe E.TeamEvent -> IO ()) -> TestM () -assertQueue label check = view tsAwsEnv >>= \case - Just env -> liftIO $ Aws.execute env $ fetchMessage label check - Nothing -> return () +assertQueue label check = + view tsAwsEnv >>= \case + Just env -> liftIO $ Aws.execute env $ fetchMessage label check + Nothing -> return () -- Try to assert an event in the queue for a `timeout` amount of seconds tryAssertQueue :: Int -> String -> (String -> Maybe E.TeamEvent -> IO ()) -> TestM () -tryAssertQueue timeout label check = view tsAwsEnv >>= \case - Just env -> liftIO $ Aws.execute env $ awaitMessage label timeout check - Nothing -> return () +tryAssertQueue timeout label check = + view tsAwsEnv >>= \case + Just env -> liftIO $ Aws.execute env $ awaitMessage label timeout check + Nothing -> return () assertQueueEmpty :: (HasCallStack) => TestM () -assertQueueEmpty = view tsAwsEnv >>= \case - Just env -> liftIO $ Aws.execute env ensureNoMessages - Nothing -> return () +assertQueueEmpty = + view tsAwsEnv >>= \case + Just env -> liftIO $ Aws.execute env ensureNoMessages + Nothing -> return () tActivateWithCurrency :: HasCallStack => Maybe Currency.Alpha -> String -> Maybe E.TeamEvent -> IO () tActivateWithCurrency c l (Just e) = do @@ -161,12 +164,13 @@ tryMatch label tries url callback = go tries liftIO $ threadDelay (10 ^ (6 :: Int)) go (n - 1) check :: Maybe E.TeamEvent -> Amazon (Either MatchFailure String) - check e = do - liftIO $ callback label e - return (Right $ show e) - `catchAll` \ex -> case asyncExceptionFromException ex of - Just x -> throwM (x :: SomeAsyncException) - Nothing -> return . Left $ MatchFailure (e, ex) + check e = + do + liftIO $ callback label e + return (Right $ show e) + `catchAll` \ex -> case asyncExceptionFromException ex of + Just x -> throwM (x :: SomeAsyncException) + Nothing -> return . Left $ MatchFailure (e, ex) -- Note that Amazon's purge queue is a bit incovenient for testing purposes because -- it may be delayed in ~60 seconds which causes messages that are published later @@ -178,8 +182,8 @@ receive :: Int -> Text -> SQS.ReceiveMessage receive n url = SQS.receiveMessage url & set SQS.rmWaitTimeSeconds (Just 1) - . set SQS.rmMaxNumberOfMessages (Just n) - . set SQS.rmVisibilityTimeout (Just 1) + . set SQS.rmMaxNumberOfMessages (Just n) + . set SQS.rmVisibilityTimeout (Just 1) queueEvent :: E.TeamEvent -> Amazon () queueEvent e = do diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index ac1821742dd..dcd0b09600a 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -63,7 +63,7 @@ import qualified Network.Wai.Utilities.Error as Wai import qualified Proto.TeamEvents as E import qualified Proto.TeamEvents_Fields as E import Test.Tasty -import Test.Tasty.Cannon ((#), TimeoutUnit (..)) +import Test.Tasty.Cannon (TimeoutUnit (..), (#)) import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import TestHelpers (test) @@ -330,9 +330,10 @@ testEnableTeamSearchVisibilityPerTeam = do assertEqual "bad status" status403 status assertEqual "bad label" "team-search-visibility-not-enabled" label let getSearchVisibilityCheck :: (HasCallStack, MonadCatch m, MonadIO m, MonadHttp m) => TeamSearchVisibility -> m () - getSearchVisibilityCheck vis = getSearchVisibility g owner tid !!! do - const 200 === statusCode - const (Just (TeamSearchVisibilityView vis)) === responseJsonUnsafe + getSearchVisibilityCheck vis = + getSearchVisibility g owner tid !!! do + const 200 === statusCode + const (Just (TeamSearchVisibilityView vis)) === responseJsonUnsafe Util.withCustomSearchFeature FeatureTeamSearchVisibilityEnabledByDefault $ do check "Teams should start with Custom Search Visibility enabled" Public.TeamFeatureEnabled @@ -941,7 +942,7 @@ testDeleteTeam = do Util.assertConvMember owner cid1 Util.assertConvMember extern cid1 Util.assertNotConvMember (member ^. userId) cid1 - void $ WS.bracketR3 c owner extern (member ^. userId) $ \(wsOwner, wsExtern, wsMember) -> do + void . WS.bracketR3 c owner extern (member ^. userId) $ \(wsOwner, wsExtern, wsMember) -> do delete (g . paths ["teams", toByteString' tid] . zUser owner . zConn "conn") !!! const 202 === statusCode checkTeamDeleteEvent tid wsOwner @@ -1004,7 +1005,7 @@ testDeleteBindingTeamSingleMember = do (/= Just True) (getDeletedState extern (other ^. userId)) - void $ WS.bracketRN c [owner, extern] $ \[wsOwner, wsExtern] -> do + void . WS.bracketRN c [owner, extern] $ \[wsOwner, wsExtern] -> do delete ( g . paths ["/i/teams", toByteString' tid] @@ -1075,7 +1076,7 @@ testDeleteBindingTeam ownerHasPassword = do !!! const 202 === statusCode assertQueue "team member leave 1" $ tUpdate 4 [ownerWithPassword, owner] - void $ WS.bracketRN c [owner, (mem1 ^. userId), (mem2 ^. userId), extern] $ \[wsOwner, wsMember1, wsMember2, wsExtern] -> do + void . WS.bracketRN c [owner, (mem1 ^. userId), (mem2 ^. userId), extern] $ \[wsOwner, wsMember1, wsMember2, wsExtern] -> do delete ( g . paths ["teams", toByteString' tid] @@ -1327,7 +1328,7 @@ testTeamAddRemoveMemberAboveThresholdNoEvents = do deleteTeam tid owner otherRealUsersInTeam teamCidsThatExternBelongsTo extern = do c <- view tsCannon g <- view tsGalley - void $ WS.bracketRN c (owner : extern : otherRealUsersInTeam) $ \(_wsOwner : wsExtern : _wsotherRealUsersInTeam) -> do + void . WS.bracketRN c (owner : extern : otherRealUsersInTeam) $ \(_wsOwner : wsExtern : _wsotherRealUsersInTeam) -> do delete ( g . paths ["teams", toByteString' tid] @@ -1769,7 +1770,7 @@ postCryptoBroadcastMessageJson2 = do cc <- Util.randomClient charlie (someLastPrekeys !! 2) connectUsers alice (list1 charlie []) let t = 3 # Second -- WS receive timeout - -- Missing charlie + -- Missing charlie let m1 = [(bob, bc, "ciphertext1")] Util.postOtrBroadcastMessage id alice ac m1 !!! do const 412 === statusCode diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index c6107e06b4a..79b2e1f3f8b 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -121,18 +121,20 @@ testSearchVisibility = do TeamId -> Public.TeamFeatureStatusValue -> m () - getTeamSearchVisibility teamid expected = Util.getTeamSearchVisibilityAvailable g owner teamid !!! do - statusCode === const 200 - responseJsonEither === const (Right (Public.TeamFeatureStatus expected)) + getTeamSearchVisibility teamid expected = + Util.getTeamSearchVisibilityAvailable g owner teamid !!! do + statusCode === const 200 + responseJsonEither === const (Right (Public.TeamFeatureStatus expected)) let getTeamSearchVisibilityInternal :: (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => TeamId -> Public.TeamFeatureStatusValue -> m () - getTeamSearchVisibilityInternal teamid expected = Util.getTeamSearchVisibilityAvailableInternal g teamid !!! do - statusCode === const 200 - responseJsonEither === const (Right (Public.TeamFeatureStatus expected)) + getTeamSearchVisibilityInternal teamid expected = + Util.getTeamSearchVisibilityAvailableInternal g teamid !!! do + statusCode === const 200 + responseJsonEither === const (Right (Public.TeamFeatureStatus expected)) let setTeamSearchVisibilityInternal :: (Monad m, MonadHttp m, MonadIO m, HasCallStack) => @@ -187,6 +189,7 @@ testSimpleFlag feature = do getFlagInternal feature Public.TeamFeatureEnabled assertFlag :: HasCallStack => TestM ResponseLBS -> Public.TeamFeatureStatusValue -> TestM () -assertFlag res expected = res !!! do - statusCode === const 200 - responseJsonEither === const (Right (Public.TeamFeatureStatus expected)) +assertFlag res expected = + res !!! do + statusCode === const 200 + responseJsonEither === const (Right (Public.TeamFeatureStatus expected)) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index dd859e26e67..b66c6887d1a 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -41,7 +41,7 @@ import Control.Lens import Control.Monad.Catch import Control.Retry (RetryPolicy, RetryStatus, exponentialBackoff, limitRetries, retrying) import qualified Data.Aeson as Aeson -import Data.Aeson.Types ((.:), FromJSON) +import Data.Aeson.Types (FromJSON, (.:)) import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS @@ -321,7 +321,7 @@ testDisableLegalHoldForUser = do disableLegalHoldForUser Nothing tid owner member !!! const 403 === statusCode assertExactlyOneLegalHoldDevice member disableLegalHoldForUser (Just defPassword) tid owner member !!! testResponse 200 Nothing - liftIO $ assertMatchChan chan $ \(req, _) -> do + liftIO . assertMatchChan chan $ \(req, _) -> do assertEqual "method" "POST" (requestMethod req) assertEqual "path" (pathInfo req) ["legalhold", "remove"] assertNotification mws $ \case @@ -359,7 +359,8 @@ testCreateLegalHoldTeamSettings = do let lhapp :: HasCallStack => IsWorking -> Chan Void -> Application lhapp NotWorking _ _ cont = cont respondBad lhapp Working _ req cont = do - if | pathInfo req /= ["legalhold", "status"] -> cont respondBad + if + | pathInfo req /= ["legalhold", "status"] -> cont respondBad | requestMethod req /= "GET" -> cont respondBad | otherwise -> cont respondOk respondOk :: Wai.Response @@ -468,7 +469,7 @@ testRemoveLegalHoldFromTeam = do deleteSettings Nothing owner tid !!! testResponse 403 (Just "access-denied") let delete'' expectRemoteLHCall = do deleteSettings (Just defPassword) owner tid !!! testResponse 204 Nothing - when expectRemoteLHCall $ liftIO $ assertMatchChan chan $ \(req, _) -> do + when expectRemoteLHCall . liftIO . assertMatchChan chan $ \(req, _) -> do putStrLn (show (pathInfo req, pathInfo req == ["legalhold", "remove"])) putStrLn (show (requestMethod req, requestMethod req == "POST")) assertEqual "path" ["legalhold", "remove"] (pathInfo req) @@ -843,9 +844,9 @@ withTestService mkApp go = do let defs = Warp.defaultSettings {Warp.settingsPort = botPort config} buf <- liftIO newChan srv <- - liftIO . Async.async - $ Warp.runTLS tlss defs - $ mkApp buf + liftIO . Async.async $ + Warp.runTLS tlss defs $ + mkApp buf go buf `finally` liftIO (Async.cancel srv) publicKeyNotMatchingService :: PEM @@ -946,12 +947,13 @@ assertMatchChan c match = go [] go buf = do m <- liftIO . timeout (5 WS.# WS.Second) . readChan $ c case m of - Just n -> do - match n - refill buf - `catchAll` \e -> case asyncExceptionFromException e of - Just x -> throwM (x :: SomeAsyncException) - Nothing -> go (n : buf) + Just n -> + do + match n + refill buf + `catchAll` \e -> case asyncExceptionFromException e of + Just x -> throwM (x :: SomeAsyncException) + Nothing -> go (n : buf) Nothing -> do refill buf liftIO $ assertBool "Timeout" False diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 243dcff24df..8892fa136ee 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -25,12 +25,12 @@ import Bilge.Assert import Brig.Types import Brig.Types.Team.Invitation import Brig.Types.User.Auth (CookieLabel (..)) -import Control.Lens hiding ((#), (.=), from, to) +import Control.Lens hiding (from, to, (#), (.=)) import Control.Monad.Catch (MonadCatch) import Control.Monad.Fail (MonadFail) import Control.Retry (constantDelay, limitRetries, retrying) import Data.Aeson hiding (json) -import Data.Aeson.Lens (_String, key) +import Data.Aeson.Lens (key, _String) import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as C import Data.ByteString.Conversion @@ -46,16 +46,16 @@ import Data.Range import Data.Serialize (runPut) import qualified Data.Set as Set import Data.String.Conversions (ST, cs) -import qualified Data.Text.Encoding as Text import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text.Encoding as Text import qualified Data.UUID as UUID import Data.UUID.V4 import qualified Galley.Options as Opts import qualified Galley.Run as Run import Galley.Types hiding (InternalMember (..), Member) import Galley.Types.Conversations.Roles hiding (DeleteConversation) -import qualified Galley.Types.Teams as Team import Galley.Types.Teams hiding (Event, EventType (..)) +import qualified Galley.Types.Teams as Team import Galley.Types.Teams.Intra import Gundeck.Types.Notification ( Notification (..), @@ -71,7 +71,7 @@ import Gundeck.Types.Notification import Imports import qualified Network.Wai.Test as WaiTest import qualified Test.QuickCheck as Q -import Test.Tasty.Cannon ((#), TimeoutUnit (..)) +import Test.Tasty.Cannon (TimeoutUnit (..), (#)) import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import TestSetup @@ -138,9 +138,10 @@ createNonBindingTeam name owner mems = do g <- view tsGalley let mm = if null mems then Nothing else Just $ unsafeRange (take 127 mems) let nt = NonBindingNewTeam $ newNewTeam (unsafeRange name) (unsafeRange "icon") & newTeamMembers .~ mm - resp <- post (g . path "/teams" . zUser owner . zConn "conn" . zType "access" . json nt) TeamId -> TeamStatus -> TestM () @@ -164,9 +165,10 @@ createBindingTeamInternalNoActivate name owner = do g <- view tsGalley tid <- randomId let nt = BindingNewTeam $ newNewTeam (unsafeRange name) (unsafeRange "icon") - _ <- put (g . paths ["/i/teams", toByteString' tid] . zUser owner . zConn "conn" . zType "access" . json nt) Text -> UserId -> Currency.Alpha -> TestM TeamId @@ -241,9 +243,9 @@ bulkGetTeamMembersTruncated usr tid uids trnc = do ) getTeamMember :: HasCallStack => UserId -> TeamId -> UserId -> TestM TeamMember -getTeamMember usr tid mid = do +getTeamMember getter tid gettee = do g <- view tsGalley - r <- get (g . paths ["teams", toByteString' tid, "members", toByteString' mid] . zUser usr) TeamId -> UserId -> TestM TeamMember @@ -268,10 +270,6 @@ addTeamMemberInternal' tid mem = do let payload = json (newNewTeamMember mem) post (g . paths ["i", "teams", toByteString' tid, "members"] . payload) -stdInvitationRequest :: Email -> Name -> Maybe Locale -> Maybe Team.Role -> InvitationRequest -stdInvitationRequest e inviterName loc role = - InvitationRequest e inviterName loc role Nothing Nothing - addUserToTeam :: HasCallStack => UserId -> TeamId -> TestM TeamMember addUserToTeam = addUserToTeamWithRole Nothing @@ -280,11 +278,11 @@ addUserToTeam' u t = snd <$> addUserToTeamWithRole' Nothing u t addUserToTeamWithRole :: HasCallStack => Maybe Role -> UserId -> TeamId -> TestM TeamMember addUserToTeamWithRole role inviter tid = do - (inv, rsp2) <- addUserToTeamWithRole' role inviter tid -- TODO: getHeader "Set-Cookie" rsp2 liftIO $ assertEqual "Wrong cookie" (Just "zuid") (setCookieName <$> zuid) @@ -294,8 +292,7 @@ addUserToTeamWithRole' :: HasCallStack => Maybe Role -> UserId -> TeamId -> Test addUserToTeamWithRole' role inviter tid = do brig <- view tsBrig inviteeEmail <- randomEmail - let name = Name $ fromEmail inviteeEmail - let invite = stdInvitationRequest inviteeEmail name Nothing role + let invite = InvitationRequest Nothing role Nothing inviteeEmail Nothing invResponse <- postInvitation tid inviter invite inv <- responseJsonError invResponse Just inviteeCode <- getInvitationCode tid (inInvitation inv) @@ -303,7 +300,7 @@ addUserToTeamWithRole' role inviter tid = do post ( brig . path "/register" . contentJson - . body (acceptInviteBody name inviteeEmail inviteeCode) + . body (acceptInviteBody inviteeEmail inviteeCode) ) return (inv, r) @@ -328,11 +325,11 @@ makeOwner owner mem tid = do !!! const 200 === statusCode -acceptInviteBody :: Name -> Email -> InvitationCode -> RequestBody -acceptInviteBody name email code = +acceptInviteBody :: Email -> InvitationCode -> RequestBody +acceptInviteBody email code = RequestBodyLBS . encode $ object - [ "name" .= fromName name, + [ "name" .= Name "bob", "email" .= fromEmail email, "password" .= defPassword, "team_code" .= code @@ -844,10 +841,10 @@ getTeamQueue zusr msince msize onlyLast = do error $ "expected time: Nothing; but found: " <> show (qnl ^. queuedTime) | otherwise = fmap (_2 %~ parseEvt) . mconcat . fmap parseEvts . view queuedNotifications $ qnl - -- + parseEvts :: QueuedNotification -> [(NotificationId, Object)] parseEvts qn = (qn ^. queuedNotificationId,) <$> (toList . toNonEmpty $ qn ^. queuedNotificationPayload) - -- + parseEvt :: Object -> UserId parseEvt o = case fromJSON (Object o) of (Error msg) -> error msg @@ -1414,8 +1411,9 @@ withSettingsOverrides opts action = liftIO $ do waitForMemberDeletion :: UserId -> TeamId -> UserId -> TestM () waitForMemberDeletion zusr tid uid = do maybeTimedOut <- timeout 2000000 loop - liftIO $ when (isNothing maybeTimedOut) $ - assertFailure "Timed out waiting for member deletion" + liftIO $ + when (isNothing maybeTimedOut) $ + assertFailure "Timed out waiting for member deletion" where loop = do galley <- view tsGalley diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs index 183495679f4..99299b3ad64 100644 --- a/services/galley/test/integration/API/Util/TeamFeature.hs +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -17,10 +17,10 @@ module API.Util.TeamFeature where -import qualified API.Util as Util import API.Util (zUser) +import qualified API.Util as Util import Bilge -import Control.Lens ((.~), view) +import Control.Lens (view, (.~)) import Data.ByteString.Conversion (toByteString') import Data.Id (TeamId, UserId) import Galley.Options (optSettings, setFeatureFlags) diff --git a/services/galley/test/integration/Main.hs b/services/galley/test/integration/Main.hs index 244eb55b7d0..33794c1410e 100644 --- a/services/galley/test/integration/Main.hs +++ b/services/galley/test/integration/Main.hs @@ -60,24 +60,25 @@ instance IsOption ServiceConfigFile where optionName = return "service-config" optionHelp = return "Service config file to read from" optionCLParser = - fmap ServiceConfigFile $ strOption $ - ( short (untag (return 's' :: Tagged ServiceConfigFile Char)) - <> long (untag (optionName :: Tagged ServiceConfigFile String)) - <> help (untag (optionHelp :: Tagged ServiceConfigFile String)) - ) + fmap ServiceConfigFile $ + strOption $ + ( short (untag (return 's' :: Tagged ServiceConfigFile Char)) + <> long (untag (optionName :: Tagged ServiceConfigFile String)) + <> help (untag (optionHelp :: Tagged ServiceConfigFile String)) + ) runTests :: (String -> String -> TestTree) -> IO () -runTests run = defaultMainWithIngredients ings - $ askOption - $ \(ServiceConfigFile c) -> - askOption $ \(IntegrationConfigFile i) -> run c i +runTests run = defaultMainWithIngredients ings $ + askOption $ + \(ServiceConfigFile c) -> + askOption $ \(IntegrationConfigFile i) -> run c i where ings = includingOptions [ Option (Proxy :: Proxy ServiceConfigFile), Option (Proxy :: Proxy IntegrationConfigFile) - ] - : defaultIngredients + ] : + defaultIngredients main :: IO () main = withOpenSSL $ runTests go diff --git a/services/gundeck/src/Gundeck/Aws.hs b/services/gundeck/src/Gundeck/Aws.hs index aac05c7ad49..b4a05082752 100644 --- a/services/gundeck/src/Gundeck/Aws.hs +++ b/services/gundeck/src/Gundeck/Aws.hs @@ -72,8 +72,7 @@ import Gundeck.Options import Gundeck.Types.Push (AppName (..), Token, Transport (..)) import qualified Gundeck.Types.Push as Push import Imports -import Network.AWS (AWSRequest, Rs) -import Network.AWS (serviceAbbrev, serviceCode, serviceMessage, serviceStatus) +import Network.AWS (AWSRequest, Rs, serviceAbbrev, serviceCode, serviceMessage, serviceStatus) import qualified Network.AWS as AWS import qualified Network.AWS.Data as AWS import qualified Network.AWS.Env as AWS @@ -141,7 +140,7 @@ newtype Amazon a = Amazon ) instance MonadUnliftIO Amazon where - askUnliftIO = Amazon $ ReaderT $ \r -> + askUnliftIO = Amazon . ReaderT $ \r -> withUnliftIO $ \u -> return (UnliftIO (unliftIO u . flip runReaderT r . unAmazon)) @@ -202,9 +201,9 @@ mkEnv lgr opts mgr = do getQueueUrl :: AWS.Env -> Text -> IO QueueUrl getQueueUrl e q = do x <- - runResourceT . AWST.runAWST e - $ AWST.trying AWS._Error - $ AWST.send (SQS.getQueueURL q) + runResourceT . AWST.runAWST e $ + AWST.trying AWS._Error $ + AWST.send (SQS.getQueueURL q) either (throwM . GeneralError) (return . QueueUrl . view SQS.gqursQueueURL) @@ -438,7 +437,7 @@ publish arn txt attrs = do listen :: Int -> (Event -> IO ()) -> Amazon () listen throttleMillis callback = do QueueUrl url <- view eventQueue - forever $ handleAny unexpectedError $ do + forever . handleAny unexpectedError $ do msgs <- view rmrsMessages <$> send (receive url) void $ mapConcurrently (onMessage url) msgs when (null msgs) $ @@ -447,7 +446,7 @@ listen throttleMillis callback = do receive url = SQS.receiveMessage url & set SQS.rmWaitTimeSeconds (Just 20) - . set SQS.rmMaxNumberOfMessages (Just 10) + . set SQS.rmMaxNumberOfMessages (Just 10) onMessage url m = case decodeStrict =<< Text.encodeUtf8 <$> m ^. mBody of Nothing -> diff --git a/services/gundeck/src/Gundeck/Env.hs b/services/gundeck/src/Gundeck/Env.hs index 781d610f813..3c9888281d4 100644 --- a/services/gundeck/src/Gundeck/Env.hs +++ b/services/gundeck/src/Gundeck/Env.hs @@ -22,7 +22,7 @@ import Cassandra (ClientState, Keyspace (..)) import qualified Cassandra as C import qualified Cassandra.Settings as C import Control.AutoUpdate -import Control.Lens ((^.), makeLenses) +import Control.Lens (makeLenses, (^.)) import Data.Default (def) import qualified Data.List.NonEmpty as NE import Data.Metrics.Middleware (Metrics) @@ -73,17 +73,17 @@ createEnv m o = do managerResponseTimeout = responseTimeoutMicro 5000000 } r <- - Redis.mkPool (Logger.clone (Just "redis.gundeck") l) - $ Redis.setHost (unpack $ o ^. optRedis . epHost) + Redis.mkPool (Logger.clone (Just "redis.gundeck") l) $ + Redis.setHost (unpack $ o ^. optRedis . epHost) . Redis.setPort (o ^. optRedis . epPort) . Redis.setMaxConnections 100 . Redis.setPoolStripes 4 . Redis.setConnectTimeout 3 . Redis.setSendRecvTimeout 5 - $ Redis.defSettings + $ Redis.defSettings p <- - C.init - $ C.setLogger (C.mkLogger (Logger.clone (Just "cassandra.gundeck") l)) + C.init $ + C.setLogger (C.mkLogger (Logger.clone (Just "cassandra.gundeck") l)) . C.setContacts (NE.head c) (NE.tail c) . C.setPortNumber (fromIntegral $ o ^. optCassandra . casEndpoint . epPort) . C.setKeyspace (Keyspace (o ^. optCassandra . casKeyspace)) @@ -93,7 +93,7 @@ createEnv m o = do . C.setSendTimeout 3 . C.setResponseTimeout 10 . C.setProtocolVersion C.V4 - $ C.defSettings + $ C.defSettings a <- Aws.mkEnv l o n io <- mkAutoUpdate diff --git a/services/gundeck/src/Gundeck/Instances.hs b/services/gundeck/src/Gundeck/Instances.hs index e4211673aaa..e162984af34 100644 --- a/services/gundeck/src/Gundeck/Instances.hs +++ b/services/gundeck/src/Gundeck/Instances.hs @@ -83,7 +83,8 @@ instance ToText (Id a) where toText = Text.decodeUtf8 . Uuid.toASCIIBytes . toUUID instance FromText (Id a) where - parser = Parser.take 36 >>= \txt -> - txt & Text.encodeUtf8 - & Uuid.fromASCIIBytes - & maybe (fail "Invalid UUID") (return . Id) + parser = + Parser.take 36 >>= \txt -> + txt & Text.encodeUtf8 + & Uuid.fromASCIIBytes + & maybe (fail "Invalid UUID") (return . Id) diff --git a/services/gundeck/src/Gundeck/Monad.hs b/services/gundeck/src/Gundeck/Monad.hs index dd07d342028..510d7e3e414 100644 --- a/services/gundeck/src/Gundeck/Monad.hs +++ b/services/gundeck/src/Gundeck/Monad.hs @@ -75,7 +75,7 @@ newtype Gundeck a = Gundeck instance MonadUnliftIO Gundeck where askUnliftIO = - Gundeck $ ReaderT $ \r -> + Gundeck . ReaderT $ \r -> withUnliftIO $ \u -> return (UnliftIO (unliftIO u . flip runReaderT r . unGundeck)) diff --git a/services/gundeck/src/Gundeck/Notification/Data.hs b/services/gundeck/src/Gundeck/Notification/Data.hs index cea89377fb0..65bd3d6f793 100644 --- a/services/gundeck/src/Gundeck/Notification/Data.hs +++ b/services/gundeck/src/Gundeck/Notification/Data.hs @@ -31,7 +31,7 @@ import qualified Data.Aeson as JSON import Data.Id import Data.List1 (List1) import Data.Range (Range, fromRange) -import Data.Sequence ((<|), (><), Seq, ViewL (..), ViewR (..)) +import Data.Sequence (Seq, ViewL (..), ViewR (..), (<|), (><)) import qualified Data.Sequence as Seq import Gundeck.Options (NotificationTTL (..)) import Gundeck.Types.Notification @@ -87,9 +87,10 @@ fetchLast u c = do ls <- query cqlLast (params Quorum (Identity u)) & retry x1 case ls of [] -> return Nothing - ns@(n : _) -> ns `getFirstOrElse` do - p <- paginate cqlSeek (paramsP Quorum (u, n ^. _1) 100) & retry x1 - seek p + ns@(n : _) -> + ns `getFirstOrElse` do + p <- paginate cqlSeek (paramsP Quorum (u, n ^. _1) 100) & retry x1 + seek p where seek p = result p diff --git a/services/gundeck/src/Gundeck/Presence/Data.hs b/services/gundeck/src/Gundeck/Presence/Data.hs index 66583e60a0c..ab0e8956b7e 100644 --- a/services/gundeck/src/Gundeck/Presence/Data.hs +++ b/services/gundeck/src/Gundeck/Presence/Data.hs @@ -60,7 +60,7 @@ add p = do let k = toKey (userId p) let v = toField (connId p) let d = encode $ PresenceData (resource p) (clientId p) now - retry x3 $ commands $ do + retry x3 . commands $ do multi void $ hset k v d -- nb. All presences of a user are expired 'maxIdleTime' after the @@ -77,7 +77,7 @@ deleteAll [] = return () deleteAll pp = for_ pp $ \p -> do let k = toKey (userId p) let f = __field p - retry x3 $ commands $ do + retry x3 . commands $ do watch (pure k) value <- hget k f multi diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index ba8da833896..c1f07844c19 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -34,7 +34,7 @@ where import Control.Arrow ((&&&)) import Control.Error import Control.Exception (ErrorCall (ErrorCall)) -import Control.Lens ((%~), (.~), (^.), _2, view) +import Control.Lens (view, (%~), (.~), (^.), _2) import Control.Monad.Catch import Data.Aeson as Aeson (Object) import Data.Id @@ -65,7 +65,7 @@ import Gundeck.Util import Imports import Network.HTTP.Types import Network.Wai.Utilities -import System.Logger.Class ((+++), (.=), msg, val, (~~)) +import System.Logger.Class (msg, val, (+++), (.=), (~~)) import qualified System.Logger.Class as Log import UnliftIO.Concurrent (forkIO) import qualified Wire.API.Push.Token as Public @@ -221,9 +221,9 @@ pushAll pushes = do -- to be sent out. -- If perPushConcurrency is defined, we take the min with 'perNativePushConcurrency', as native push requests -- to cassandra and SNS are limited to 'perNativePushConcurrency' in parallel. - unless (psh ^. pushTransient) - $ mpaRunWithBudget cost () - $ mpaPushNative notif psh =<< nativeTargets psh rcps' alreadySent + unless (psh ^. pushTransient) $ + mpaRunWithBudget cost () $ + mpaPushNative notif psh =<< nativeTargets psh rcps' alreadySent -- REFACTOR: @[Presence]@ here should be @newtype WebSockedDelivered = WebSockedDelivered [Presence]@ compilePushReq :: (Push, (Notification, List1 (Recipient, [Presence]))) -> (Notification, [Presence]) @@ -319,10 +319,10 @@ nativeTargets psh rcps' alreadySent = addresses :: Recipient -> m [Address] addresses u = do addrs <- mntgtLookupAddresses (u ^. recipientId) - return - $ preference + return $ + preference . filter (eligible u) - $ addrs + $ addrs eligible :: Recipient -> Address -> Bool eligible u a -- Never include the origin client. @@ -408,14 +408,14 @@ addToken uid cid newtok = mpaRunWithBudget 1 AddTokenNoBudget $ do then (Just a, old) else (x, a : old) | otherwise = (x, old) - -- + continue :: PushToken -> Maybe Address -> Gundeck (Either AddTokenResponse Address) continue t Nothing = create (0 :: Int) t continue t (Just a) = update (0 :: Int) t (a ^. addrEndpoint) - -- + create :: Int -> PushToken -> @@ -445,7 +445,7 @@ addToken uid cid newtok = mpaRunWithBudget 1 AddTokenNoBudget $ do Right arn -> do Data.insert uid trp app tok arn cid (t ^. tokenClient) return (Right (mkAddr t arn)) - -- + update :: Int -> PushToken -> @@ -459,28 +459,29 @@ addToken uid cid newtok = mpaRunWithBudget 1 AddTokenNoBudget $ do ept <- Aws.execute aws (Aws.lookupEndpoint arn) case ept of Nothing -> create (n + 1) t - Just ep -> do - updateEndpoint uid t arn ep - Data.insert - uid - (t ^. tokenTransport) - (t ^. tokenApp) - (t ^. token) - arn - cid - (t ^. tokenClient) - return (Right (mkAddr t arn)) - `catch` \case - -- Note: If the endpoint was recently deleted (not necessarily - -- concurrently), we may get an EndpointNotFound error despite - -- the previous lookup, i.e. endpoint lookups may exhibit eventually - -- consistent semantics with regards to endpoint deletion (or - -- possibly updates in general). We make another attempt to (re-)create - -- the endpoint in these cases instead of failing immediately. - Aws.EndpointNotFound {} -> create (n + 1) t - Aws.InvalidCustomData {} -> return (Left AddTokenMetadataTooLong) - ex -> throwM ex - -- + Just ep -> + do + updateEndpoint uid t arn ep + Data.insert + uid + (t ^. tokenTransport) + (t ^. tokenApp) + (t ^. token) + arn + cid + (t ^. tokenClient) + return (Right (mkAddr t arn)) + `catch` \case + -- Note: If the endpoint was recently deleted (not necessarily + -- concurrently), we may get an EndpointNotFound error despite + -- the previous lookup, i.e. endpoint lookups may exhibit eventually + -- consistent semantics with regards to endpoint deletion (or + -- possibly updates in general). We make another attempt to (re-)create + -- the endpoint in these cases instead of failing immediately. + Aws.EndpointNotFound {} -> create (n + 1) t + Aws.InvalidCustomData {} -> return (Left AddTokenMetadataTooLong) + ex -> throwM ex + mkAddr :: PushToken -> EndpointArn -> diff --git a/services/gundeck/src/Gundeck/Push/Native.hs b/services/gundeck/src/Gundeck/Push/Native.hs index 5309b612e7c..5788de8cf85 100644 --- a/services/gundeck/src/Gundeck/Push/Native.hs +++ b/services/gundeck/src/Gundeck/Push/Native.hs @@ -22,7 +22,7 @@ module Gundeck.Push.Native ) where -import Control.Lens ((.~), (^.), view) +import Control.Lens (view, (.~), (^.)) import Control.Monad.Catch import Data.ByteString.Conversion.To import Data.Id diff --git a/services/gundeck/src/Gundeck/Push/Native/Serialise.hs b/services/gundeck/src/Gundeck/Push/Native/Serialise.hs index ff193eaeb7d..ac084dc1898 100644 --- a/services/gundeck/src/Gundeck/Push/Native/Serialise.hs +++ b/services/gundeck/src/Gundeck/Push/Native/Serialise.hs @@ -22,7 +22,7 @@ module Gundeck.Push.Native.Serialise where import Control.Lens ((^.), (^?), _Just) -import Data.Aeson ((.=), Value, object) +import Data.Aeson (Value, object, (.=)) import Data.Aeson.Text (encodeToTextBuilder) import qualified Data.ByteString as BS import Data.Json.Util @@ -85,8 +85,10 @@ renderText t aps prio x = case t of # "loc-args" .= (aps ^? _Just . apsLocArgs) # [] ) - # "sound" .= (aps ^? _Just . apsSound) - # "content-available" .= '1' + # "sound" + .= (aps ^? _Just . apsSound) + # "content-available" + .= '1' # [] apsDict LowPriority = object $ diff --git a/services/gundeck/src/Gundeck/Push/Native/Types.hs b/services/gundeck/src/Gundeck/Push/Native/Types.hs index 3787c238dd1..70f391a6c7f 100644 --- a/services/gundeck/src/Gundeck/Push/Native/Types.hs +++ b/services/gundeck/src/Gundeck/Push/Native/Types.hs @@ -40,7 +40,7 @@ module Gundeck.Push.Native.Types ) where -import Control.Lens (Lens', (^.), makeLenses, view) +import Control.Lens (Lens', makeLenses, view, (^.)) import Data.Id (ClientId, ConnId, UserId) import Gundeck.Aws.Arn import Gundeck.Types diff --git a/services/gundeck/src/Gundeck/Push/Websocket.hs b/services/gundeck/src/Gundeck/Push/Websocket.hs index 1c9f26e5e1f..6cfdab100ef 100644 --- a/services/gundeck/src/Gundeck/Push/Websocket.hs +++ b/services/gundeck/src/Gundeck/Push/Websocket.hs @@ -27,7 +27,7 @@ import Bilge.RPC import Bilge.Retry (rpcHandlers) import Control.Arrow ((&&&)) import Control.Exception (ErrorCall (ErrorCall)) -import Control.Lens ((%~), (^.), _2, view) +import Control.Lens (view, (%~), (^.), _2) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, catch, throwM, try) import Control.Retry import Data.Aeson (eitherDecode, encode) @@ -51,7 +51,7 @@ import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..)) import qualified Network.HTTP.Client.Internal as Http import Network.HTTP.Types (StdMethod (POST), status200, status410) import qualified Network.URI as URI -import System.Logger.Class ((+++), val, (~~)) +import System.Logger.Class (val, (+++), (~~)) import qualified System.Logger.Class as Log import UnliftIO (handleAny, mapConcurrently) @@ -368,12 +368,13 @@ send n pp = where fn js p = do req <- Http.setUri empty (fromURI (resource p)) - recovering x1 rpcHandlers $ const - $ rpc' "cannon" (check req) - $ method POST - . contentJson - . lbytes js - . timeout 3000 -- ms + recovering x1 rpcHandlers $ + const $ + rpc' "cannon" (check req) $ + method POST + . contentJson + . lbytes js + . timeout 3000 -- ms check r = r { Http.checkResponse = \rq rs -> diff --git a/services/gundeck/src/Gundeck/React.hs b/services/gundeck/src/Gundeck/React.hs index 358ce9ff7cc..d2d3a183cd3 100644 --- a/services/gundeck/src/Gundeck/React.hs +++ b/services/gundeck/src/Gundeck/React.hs @@ -22,7 +22,7 @@ module Gundeck.React ) where -import Control.Lens ((.~), (^.), view) +import Control.Lens (view, (.~), (^.)) import Data.ByteString.Conversion import Data.Id (ClientId, UserId) import qualified Data.List as List @@ -44,7 +44,7 @@ import qualified Gundeck.Push.Websocket as Web import Gundeck.Types import Gundeck.Util import Imports -import System.Logger.Class ((+++), (.=), Msg, msg, val, (~~)) +import System.Logger.Class (Msg, msg, val, (+++), (.=), (~~)) import qualified System.Logger.Class as Log onEvent :: Event -> Gundeck () @@ -76,7 +76,8 @@ onUpdated ev = withEndpoint ev $ \e as -> forM_ sup $ \a -> do logUserEvent (a ^. addrUser) ev $ msg (val "Removing superseded token") deleteToken (a ^. addrUser) ev (a ^. addrToken) (a ^. addrClient) - if | null sup -> return () + if + | null sup -> return () | null cur -> deleteEndpoint ev | otherwise -> updateEndpoint ev e (map (view addrUser) cur) diff --git a/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs b/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs index 8d66e207cc5..4ce346495a8 100644 --- a/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs +++ b/services/gundeck/src/Gundeck/ThreadBudget/Internal.hs @@ -226,14 +226,15 @@ removeStaleHandles ref = do "watchThreadBudgetState: total overall thread budget diverged from async weights (repaired)." where getStaleHandles :: m (Set UUID) - getStaleHandles = Set.fromList . mconcat <$> do - handles <- HM.toList . bmap <$> readIORef ref - forM handles $ \case - (_, (_, Nothing)) -> do - pure [] - (key, (_, Just handle)) -> do - status <- poll handle - pure [key | isJust status] + getStaleHandles = + Set.fromList . mconcat <$> do + handles <- HM.toList . bmap <$> readIORef ref + forM handles $ \case + (_, (_, Nothing)) -> do + pure [] + (key, (_, Just handle)) -> do + status <- poll handle + pure [key | isJust status] warnStaleHandles :: Int -> BudgetMap -> m () warnStaleHandles num (BudgetMap spent _) = LC.warn $ @@ -245,7 +246,8 @@ safeForever :: (MonadIO m, LC.MonadLogger m, MonadCatch m) => m () -> m () -safeForever action = forever $ - action `catchAny` \exc -> do - LC.err $ "error" LC..= show exc LC.~~ LC.msg (LC.val "watchThreadBudgetState: crashed; retrying") - threadDelay 60000000 -- pause to keep worst-case noise in logs manageable +safeForever action = + forever $ + action `catchAny` \exc -> do + LC.err $ "error" LC..= show exc LC.~~ LC.msg (LC.val "watchThreadBudgetState: crashed; retrying") + threadDelay 60000000 -- pause to keep worst-case noise in logs manageable diff --git a/services/gundeck/test/integration/API.hs b/services/gundeck/test/integration/API.hs index 6ca9d0a22f1..7cc5984ceaa 100644 --- a/services/gundeck/test/integration/API.hs +++ b/services/gundeck/test/integration/API.hs @@ -27,7 +27,7 @@ import Bilge.Assert import qualified Cassandra as Cql import Control.Arrow ((&&&)) import Control.Concurrent.Async (Async, async, concurrently_, forConcurrently_, wait) -import Control.Lens ((%~), (.~), (<&>), (^.), (^?), _2, view) +import Control.Lens (view, (%~), (.~), (<&>), (^.), (^?), _2) import Control.Retry (constantDelay, limitRetries, recoverAll, retrying) import Data.Aeson hiding (json) import Data.Aeson.Lens @@ -260,9 +260,10 @@ bulkPush isE2E numUsers numConnsPerUser = do ploadE2E :: ConnId -> List1 Aeson.Object ploadE2E connid = List1.singleton $ HashMap.fromList ["connid" .= connid] pushE2E :: UserId -> [(UserId, [(ConnId, Bool)])] -> [Push] - pushE2E u ucs = targets <&> \(uid, connid) -> - newPush u (toRecipients [uid]) (ploadE2E connid) - & pushConnections .~ Set.singleton connid + pushE2E u ucs = + targets <&> \(uid, connid) -> + newPush u (toRecipients [uid]) (ploadE2E connid) + & pushConnections .~ Set.singleton connid where targets :: [(UserId, ConnId)] targets = @@ -322,7 +323,7 @@ sendMultipleUsers = do -- 'uid1' and 'uid2' should each have 1 notification ntfs1 <- listNotifications uid1 Nothing ntfs2 <- listNotifications uid2 Nothing - liftIO $ forM_ [ntfs1, ntfs2] $ \ntfs -> do + liftIO . forM_ [ntfs1, ntfs2] $ \ntfs -> do assertEqual "Not exactly 1 notification" 1 (length ntfs) let p = view queuedNotificationPayload (Prelude.head ntfs) assertEqual "Wrong events in notification" pload p @@ -390,7 +391,7 @@ targetClientPush = do -- Check the notification stream ns1 <- listNotifications uid (Just cid1) ns2 <- listNotifications uid (Just cid2) - liftIO $ forM_ [(ns1, cid1), (ns2, cid2)] $ \(ns, c) -> do + liftIO . forM_ [(ns1, cid1), (ns2, cid2)] $ \(ns, c) -> do assertEqual "Not exactly 1 notification" 1 (length ns) let p = view queuedNotificationPayload (Prelude.head ns) assertEqual "Wrong events in notification" (pload c) p @@ -797,10 +798,10 @@ testSharePushToken = do let t2 = tk c2 t1' <- registerPushToken u1 t1 t2' <- registerPushToken u2 t2 -- share the token with u1 - -- Unfortunately this fails locally :( - -- "Duplicate endpoint token: 61d22005-af6e-4199-add9-899aae79c70a" - -- Instead of getting something in the lines of - -- "Invalid parameter: Token Reason: Endpoint " already exists with the same Token, but different attributes." + -- Unfortunately this fails locally :( + -- "Duplicate endpoint token: 61d22005-af6e-4199-add9-899aae79c70a" + -- Instead of getting something in the lines of + -- "Invalid parameter: Token Reason: Endpoint " already exists with the same Token, but different attributes." liftIO $ assertEqual "token mismatch" (t1 ^. token) t1' liftIO $ assertEqual "token mismatch" (t2 ^. token) t2' liftIO $ assertEqual "token mismatch" t1' t2' @@ -889,12 +890,13 @@ connectUsersAndDevicesWithSendingClients :: [(UserId, [ConnId])] -> TestM [(UserId, [(TChan ByteString, TChan ByteString)])] connectUsersAndDevicesWithSendingClients ca uidsAndConnIds = do - chs <- forM uidsAndConnIds $ \(uid, conns) -> (uid,) <$> do - forM conns $ \conn -> do - chread <- liftIO $ atomically newTChan - chwrite <- liftIO $ atomically newTChan - _ <- wsRun ca uid conn (wsReaderWriter chread chwrite) - pure (chread, chwrite) + chs <- forM uidsAndConnIds $ \(uid, conns) -> + (uid,) <$> do + forM conns $ \conn -> do + chread <- liftIO $ atomically newTChan + chwrite <- liftIO $ atomically newTChan + _ <- wsRun ca uid conn (wsReaderWriter chread chwrite) + pure (chread, chwrite) (\(uid, conns) -> wsAssertPresences uid (length conns)) `mapM_` uidsAndConnIds pure chs @@ -1009,20 +1011,22 @@ listNotifications u c = do (view queuedTime ns) getNotifications :: UserId -> Maybe ClientId -> TestM (Response (Maybe BL.ByteString)) -getNotifications u c = view tsGundeck >>= \gu -> - get $ - runGundeckR gu - . zUser u - . path "notifications" - . maybe id (queryItem "client" . toByteString') c +getNotifications u c = + view tsGundeck >>= \gu -> + get $ + runGundeckR gu + . zUser u + . path "notifications" + . maybe id (queryItem "client" . toByteString') c getLastNotification :: UserId -> Maybe ClientId -> TestM (Response (Maybe BL.ByteString)) -getLastNotification u c = view tsGundeck >>= \gu -> - get $ - runGundeckR gu - . zUser u - . paths ["notifications", "last"] - . maybe id (queryItem "client" . toByteString') c +getLastNotification u c = + view tsGundeck >>= \gu -> + get $ + runGundeckR gu + . zUser u + . paths ["notifications", "last"] + . maybe id (queryItem "client" . toByteString') c sendPush :: HasCallStack => Push -> TestM () sendPush push = sendPushes [push] @@ -1101,10 +1105,11 @@ toRecipients :: [UserId] -> Range 1 1024 (Set Recipient) toRecipients = unsafeRange . Set.fromList . map (`recipient` RouteAny) randomConnId :: MonadIO m => m ConnId -randomConnId = liftIO $ - ConnId <$> do - r <- randomIO :: IO Word32 - return $ C.pack $ show r +randomConnId = + liftIO $ + ConnId <$> do + r <- randomIO :: IO Word32 + return $ C.pack $ show r randomClientId :: MonadIO m => m ClientId randomClientId = liftIO $ newClientId <$> (randomIO :: IO Word64) diff --git a/services/gundeck/test/integration/Main.hs b/services/gundeck/test/integration/Main.hs index 21d4ea80a1b..a24fde8dc84 100644 --- a/services/gundeck/test/integration/Main.hs +++ b/services/gundeck/test/integration/Main.hs @@ -65,24 +65,25 @@ instance IsOption ServiceConfigFile where optionName = return "service-config" optionHelp = return "Service config file to read from" optionCLParser = - fmap ServiceConfigFile $ strOption $ - ( short (untag (return 's' :: Tagged ServiceConfigFile Char)) - <> long (untag (optionName :: Tagged ServiceConfigFile String)) - <> help (untag (optionHelp :: Tagged ServiceConfigFile String)) - ) + fmap ServiceConfigFile $ + strOption $ + ( short (untag (return 's' :: Tagged ServiceConfigFile Char)) + <> long (untag (optionName :: Tagged ServiceConfigFile String)) + <> help (untag (optionHelp :: Tagged ServiceConfigFile String)) + ) runTests :: (String -> String -> TestTree) -> IO () -runTests run = defaultMainWithIngredients ings - $ askOption - $ \(ServiceConfigFile c) -> - askOption $ \(IntegrationConfigFile i) -> run c i +runTests run = defaultMainWithIngredients ings $ + askOption $ + \(ServiceConfigFile c) -> + askOption $ \(IntegrationConfigFile i) -> run c i where ings = includingOptions [ Option (Proxy :: Proxy ServiceConfigFile), Option (Proxy :: Proxy IntegrationConfigFile) - ] - : defaultIngredients + ] : + defaultIngredients main :: IO () main = withOpenSSL $ runTests go diff --git a/services/gundeck/test/integration/TestSetup.hs b/services/gundeck/test/integration/TestSetup.hs index 3c7947850ed..47e41b27ac2 100644 --- a/services/gundeck/test/integration/TestSetup.hs +++ b/services/gundeck/test/integration/TestSetup.hs @@ -37,7 +37,7 @@ where import Bilge (HttpT (..), Manager, MonadHttp, Request, runHttpT) import qualified Cassandra as Cql -import Control.Lens ((^.), makeLenses) +import Control.Lens (makeLenses, (^.)) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Fail (MonadFail) import Imports diff --git a/services/gundeck/test/unit/MockGundeck.hs b/services/gundeck/test/unit/MockGundeck.hs index 2f65c2178d9..9ea022a2303 100644 --- a/services/gundeck/test/unit/MockGundeck.hs +++ b/services/gundeck/test/unit/MockGundeck.hs @@ -53,7 +53,7 @@ import qualified Data.IntMultiSet as MSet import qualified Data.List.NonEmpty as NE import Data.List1 import qualified Data.Map as Map -import Data.Misc ((<$$>), Milliseconds (Ms)) +import Data.Misc (Milliseconds (Ms), (<$$>)) import Data.Range import qualified Data.Scientific as Scientific import qualified Data.Set as Set @@ -237,9 +237,11 @@ genMockEnv = do in nubrec <$> forM uids gencids -- Build an 'MockEnv' containing a map with all those 'ClientInfo's, and -- check that it validates - env <- MockEnv . Map.fromList . fmap (_2 %~ Map.fromList) <$> do - forM (zip uids cidss) $ \(uid, cids) -> (uid,) <$> do - forM cids $ \cid -> (cid,) <$> genClientInfo uid cid + env <- + MockEnv . Map.fromList . fmap (_2 %~ Map.fromList) <$> do + forM (zip uids cidss) $ \(uid, cids) -> + (uid,) <$> do + forM cids $ \cid -> (cid,) <$> genClientInfo uid cid validateMockEnv env & either error (const $ pure env) -- Try to shrink a 'MockEnv' by removing some users from '_meClientInfos'. @@ -354,16 +356,17 @@ genPush env = do -- | Shuffle devices. With probability 0.5, drop at least one device, but not all. If number of -- devices is @<2@ or if devices are set to 'RecipientClientsAll', the input is returned. dropSomeDevices :: Recipient -> Gen Recipient -dropSomeDevices = recipientClients %%~ \case - RecipientClientsAll -> pure RecipientClientsAll - RecipientClientsSome cids -> do - numdevs :: Int <- - oneof - [ pure $ length cids, - choose (1, max 1 (length cids - 1)) - ] - RecipientClientsSome . unsafeList1 . take numdevs - <$> QC.shuffle (toList cids) +dropSomeDevices = + recipientClients %%~ \case + RecipientClientsAll -> pure RecipientClientsAll + RecipientClientsSome cids -> do + numdevs :: Int <- + oneof + [ pure $ length cids, + choose (1, max 1 (length cids - 1)) + ] + RecipientClientsSome . unsafeList1 . take numdevs + <$> QC.shuffle (toList cids) shrinkPushes :: HasCallStack => [Push] -> [[Push]] shrinkPushes = shrinkList shrinkPush @@ -408,7 +411,7 @@ runMockGundeck env (MockGundeck m) = instance MonadThrow MockGundeck where throwM = error . show -- (we are not expecting any interesting errors in these tests, so we might - -- as well crash badly here, as long as it doesn't go unnoticed...) + -- as well crash badly here, as long as it doesn't go unnoticed...) instance MonadPushAll MockGundeck where mpaNotificationTTL = pure $ NotificationTTL 300 -- (longer than we want any test to take.) @@ -418,7 +421,7 @@ instance MonadPushAll MockGundeck where mpaStreamAdd = mockStreamAdd mpaPushNative = mockPushNative mpaForkIO = id -- just don't fork. (this *may* cause deadlocks in principle, but as long as it - -- doesn't, this is good enough for testing). + -- doesn't, this is good enough for testing). mpaRunWithBudget = \_ _ -> id -- no throttling needed as long as we don't overdo it in the tests... @@ -670,9 +673,10 @@ mockOldSimpleWebPush notif tgts _senderid mconnid connWhitelist = do then id else targetClients %~ filter ((`elem` connWhitelist) . fakeConnId) emptyMeansFullHack :: NotificationTarget -> NotificationTarget - emptyMeansFullHack tgt = tgt & targetClients %~ \case - [] -> clientIdsOfUser env (tgt ^. targetUser) - same@(_ : _) -> same + emptyMeansFullHack tgt = + tgt & targetClients %~ \case + [] -> clientIdsOfUser env (tgt ^. targetUser) + same@(_ : _) -> same forM_ clients $ \(userid, clientid) -> do msWSQueue %= deliver (userid, clientid) (ntfPayload notif) pure $ uncurry fakePresence <$> clients @@ -693,9 +697,10 @@ shrinkPretty shrnk (Pretty xs) = Pretty <$> shrnk xs sublist1Of :: HasCallStack => [a] -> Gen (List1 a) sublist1Of [] = error "sublist1Of: empty list" -sublist1Of xs = sublistOf xs >>= \case - [] -> sublist1Of xs - c : cc -> pure (list1 c cc) +sublist1Of xs = + sublistOf xs >>= \case + [] -> sublist1Of xs + c : cc -> pure (list1 c cc) unsafeList1 :: HasCallStack => [a] -> List1 a unsafeList1 [] = error "unsafeList1: empty list" diff --git a/services/gundeck/test/unit/ThreadBudget.hs b/services/gundeck/test/unit/ThreadBudget.hs index 7bd07c4c3b8..b84154e88f4 100644 --- a/services/gundeck/test/unit/ThreadBudget.hs +++ b/services/gundeck/test/unit/ThreadBudget.hs @@ -154,8 +154,8 @@ testThreadBudgets :: Assertion testThreadBudgets = do let timeUnits n = MilliSeconds $ lengthOfTimeUnit * n lengthOfTimeUnit = 5 -- if you make this larger, the test will run more slowly, and be - -- less likely to have timing issues. if you make it too small, some of the calls to - -- 'delayms' may return too fast and some things may not be ready yet. + -- less likely to have timing issues. if you make it too small, some of the calls to + -- 'delayms' may return too fast and some things may not be ready yet. tbs <- mkThreadBudgetState (MaxConcurrentNativePushes (Just 5) (Just 5)) logHistory :: LogHistory <- newMVar [] watcher <- mkWatcher tbs logHistory diff --git a/services/proxy/src/Proxy/API/Public.hs b/services/proxy/src/Proxy/API/Public.hs index 8015a0a6854..3b7c0a5b058 100644 --- a/services/proxy/src/Proxy/API/Public.hs +++ b/services/proxy/src/Proxy/API/Public.hs @@ -117,16 +117,16 @@ spotifyToken rq = do req = baseReq {Client.requestHeaders = hdr} mgr <- view manager res <- liftIO $ recovering x2 [handler] $ const (Client.httpLbs (Req.lbytes b req) mgr) - when (isError (Client.responseStatus res)) - $ debug - $ msg (val "unexpected upstream response") - ~~ "upstream" .= val "spotify::token" - ~~ "status" .= S (Client.responseStatus res) - ~~ "body" .= B.take 256 (Client.responseBody res) + when (isError (Client.responseStatus res)) $ + debug $ + msg (val "unexpected upstream response") + ~~ "upstream" .= val "spotify::token" + ~~ "status" .= S (Client.responseStatus res) + ~~ "body" .= B.take 256 (Client.responseBody res) return $ plain (Client.responseBody res) & setStatus (Client.responseStatus res) - . maybeHeader hContentType res + . maybeHeader hContentType res where baseReq = Req.method POST @@ -142,16 +142,16 @@ soundcloudResolve url = do let req = Req.queryItem "client_id" s . Req.queryItem "url" url $ baseReq mgr <- view manager res <- liftIO $ recovering x2 [handler] $ const (Client.httpLbs req mgr) - when (isError (Client.responseStatus res)) - $ debug - $ msg (val "unexpected upstream response") - ~~ "upstream" .= val "soundcloud::resolve" - ~~ "status" .= S (Client.responseStatus res) - ~~ "body" .= B.take 256 (Client.responseBody res) + when (isError (Client.responseStatus res)) $ + debug $ + msg (val "unexpected upstream response") + ~~ "upstream" .= val "soundcloud::resolve" + ~~ "status" .= S (Client.responseStatus res) + ~~ "body" .= B.take 256 (Client.responseBody res) return $ plain (Client.responseBody res) & setStatus (Client.responseStatus res) - . maybeHeader hContentType res + . maybeHeader hContentType res where baseReq = Req.method GET @@ -184,7 +184,7 @@ x2 :: RetryPolicy x2 = exponentialBackoff 5000 <> limitRetries 2 handler :: (MonadIO m, MonadMask m) => RetryStatus -> Handler m Bool -handler = const $ Handler $ \case +handler = const . Handler $ \case Client.HttpExceptionRequest _ Client.NoResponseDataReceived -> return True Client.HttpExceptionRequest _ Client.IncompleteHeaders -> return True Client.HttpExceptionRequest _ (Client.ConnectionTimeout) -> return True diff --git a/services/proxy/src/Proxy/Env.hs b/services/proxy/src/Proxy/Env.hs index 8fb7f38ef4f..1befea351c6 100644 --- a/services/proxy/src/Proxy/Env.hs +++ b/services/proxy/src/Proxy/Env.hs @@ -28,7 +28,7 @@ module Proxy.Env ) where -import Control.Lens ((^.), makeLenses) +import Control.Lens (makeLenses, (^.)) import Data.Configurator import Data.Configurator.Types import Data.Default (def) diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index 3468c839e9e..3549a3a1b41 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -220,7 +220,7 @@ idpGetRaw zusr idpid = do _ <- authorizeIdP zusr idp wrapMonadClient (Data.getIdPRawMetadata idpid) >>= \case Just txt -> pure $ RawIdPMetadata txt - Nothing -> throwSpar SparNotFound + Nothing -> throwSpar SparIdPNotFound idpGetAll :: Maybe UserId -> Spar IdPList idpGetAll zusr = withDebugLog "idpGetAll" (const Nothing) $ do @@ -329,7 +329,7 @@ validateNewIdP _idpMetadata teamId mReplaces = do oldIssuers :: [SAML.Issuer] <- case mReplaces of Nothing -> pure [] Just replaces -> do - idp <- wrapMonadClient (Data.getIdPConfig replaces) >>= maybe (throwSpar SparNotFound) pure + idp <- wrapMonadClient (Data.getIdPConfig replaces) >>= maybe (throwSpar SparIdPNotFound) pure pure $ (idp ^. SAML.idpMetadata . SAML.edIssuer) : (idp ^. SAML.idpExtraInfo . wiOldIssuers) let requri = _idpMetadata ^. SAML.edRequestURI _idpExtraInfo = WireIdP teamId oldIssuers Nothing @@ -367,9 +367,10 @@ validateIdPUpdate :: SAML.IdPId -> m (TeamId, IdP) validateIdPUpdate zusr _idpMetadata _idpId = do - previousIdP <- wrapMonadClient (Data.getIdPConfig _idpId) >>= \case - Nothing -> throwError errUnknownIdPId - Just idp -> pure idp + previousIdP <- + wrapMonadClient (Data.getIdPConfig _idpId) >>= \case + Nothing -> throwError errUnknownIdPId + Just idp -> pure idp teamId <- authorizeIdP zusr previousIdP unless (previousIdP ^. SAML.idpExtraInfo . wiTeam == teamId) $ do throwError errUnknownIdP @@ -439,7 +440,7 @@ internalPutSsoSettings SsoSettings {defaultSsoCode = Just code} = do -- this will return a 404, which is not quite right, -- but it's an internal endpoint and the message clearly says -- "Could not find IdP". - throwSpar SparNotFound + throwSpar SparIdPNotFound Just _ -> do wrapMonadClient $ Data.storeDefaultSsoCode code pure NoContent diff --git a/services/spar/src/Spar/API/Swagger.hs b/services/spar/src/Spar/API/Swagger.hs index d0fd8f272ca..a642aa80a44 100644 --- a/services/spar/src/Spar/API/Swagger.hs +++ b/services/spar/src/Spar/API/Swagger.hs @@ -131,12 +131,13 @@ instance ToSchema SAML.IdPMetadata where instance ToSchema IdPMetadataInfo where declareNamedSchema _ = - pure $ NamedSchema (Just "IdPMetadataInfo") $ - mempty - & properties .~ properties_ - & minProperties ?~ 1 - & maxProperties ?~ 1 - & type_ .~ Just SwaggerObject + pure $ + NamedSchema (Just "IdPMetadataInfo") $ + mempty + & properties .~ properties_ + & minProperties ?~ 1 + & maxProperties ?~ 1 + & type_ .~ Just SwaggerObject where properties_ :: InsOrdHashMap Text (Referenced Schema) properties_ = diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index e02789a47af..d7f041c6794 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -36,14 +36,14 @@ module Spar.App where import Bilge -import Brig.Types (ManagedBy (..), Name) +import Brig.Types (ManagedBy (..)) import Cassandra import qualified Cassandra as Cas import Control.Exception (assert) import Control.Lens hiding ((.=)) import qualified Control.Monad.Catch as Catch import Control.Monad.Except -import Data.Aeson as Aeson ((.=), encode, object) +import Data.Aeson as Aeson (encode, object, (.=)) import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Id @@ -130,10 +130,10 @@ instance SPStoreIdP SparError Spar where storeIdPConfig idp = wrapMonadClient $ Data.storeIdPConfig idp getIdPConfig :: IdPId -> Spar IdP - getIdPConfig = (>>= maybe (throwSpar SparNotFound) pure) . wrapMonadClientWithEnv . Data.getIdPConfig + getIdPConfig = (>>= maybe (throwSpar SparIdPNotFound) pure) . wrapMonadClientWithEnv . Data.getIdPConfig getIdPConfigByIssuer :: Issuer -> Spar IdP - getIdPConfigByIssuer = (>>= maybe (throwSpar SparNotFound) pure) . wrapMonadClientWithEnv . Data.getIdPConfigByIssuer + getIdPConfigByIssuer = (>>= maybe (throwSpar SparIdPNotFound) pure) . wrapMonadClientWithEnv . Data.getIdPConfigByIssuer -- | 'wrapMonadClient' with an 'Env' in a 'ReaderT', and exceptions. If you -- don't need either of those, 'wrapMonadClient' will suffice. @@ -169,7 +169,7 @@ getUser uref = do case muid of Nothing -> pure Nothing Just uid -> do - itis <- Intra.isTeamUser uid + itis <- isJust <$> Intra.getBrigUserTeam uid pure $ if itis then Just uid else Nothing -- | Create a fresh 'Data.Id.UserId', store it on C* locally together with 'SAML.UserRef', then @@ -188,24 +188,25 @@ getUser uref = do -- FUTUREWORK: once we support , brig will refuse to delete -- users that have an sso id, unless the request comes from spar. then we can make users -- undeletable in the team admin page, and ask admins to go talk to their IdP system. -createSamlUserWithId :: UserId -> SAML.UserRef -> Maybe Name -> ManagedBy -> Spar () -createSamlUserWithId buid suid mbName managedBy = do +createSamlUserWithId :: UserId -> SAML.UserRef -> ManagedBy -> Spar () +createSamlUserWithId buid suid managedBy = do teamid <- (^. idpExtraInfo . wiTeam) <$> getIdPConfigByIssuer (suid ^. uidTenant) - buid' <- Intra.createBrigUser suid buid teamid mbName managedBy + uname <- either (throwSpar . SparBadUserName . cs) pure $ Intra.mkUserName Nothing suid + buid' <- Intra.createBrigUser suid buid teamid uname managedBy assert (buid == buid') $ pure () insertUser suid buid -- | If the team has no scim token, call 'createSamlUser'. Otherwise, raise "invalid -- credentials". -autoprovisionSamlUser :: SAML.UserRef -> Maybe Name -> ManagedBy -> Spar UserId -autoprovisionSamlUser suid mbName managedBy = do +autoprovisionSamlUser :: SAML.UserRef -> ManagedBy -> Spar UserId +autoprovisionSamlUser suid managedBy = do buid <- Id <$> liftIO UUID.nextRandom - autoprovisionSamlUserWithId buid suid mbName managedBy + autoprovisionSamlUserWithId buid suid managedBy pure buid -- | Like 'autoprovisionSamlUser', but for an already existing 'UserId'. -autoprovisionSamlUserWithId :: UserId -> SAML.UserRef -> Maybe Name -> ManagedBy -> Spar () -autoprovisionSamlUserWithId buid suid mbName managedBy = do +autoprovisionSamlUserWithId :: UserId -> SAML.UserRef -> ManagedBy -> Spar () +autoprovisionSamlUserWithId buid suid managedBy = do idp <- getIdPConfigByIssuer (suid ^. uidTenant) unless (isNothing $ idp ^. idpExtraInfo . wiReplacedBy) $ do throwSpar $ SparCannotCreateUsersOnReplacedIdP (cs . SAML.idPIdToST $ idp ^. idpId) @@ -213,7 +214,7 @@ autoprovisionSamlUserWithId buid suid mbName managedBy = do scimtoks <- wrapMonadClient $ Data.getScimTokens teamid if null scimtoks then do - createSamlUserWithId buid suid mbName managedBy + createSamlUserWithId buid suid managedBy validateEmailIfExists buid suid else throwError . SAML.Forbidden $ @@ -244,11 +245,7 @@ bindUser buid userref = do (uteamid == Just teamid) (throwSpar . SparBindFromWrongOrNoTeam . cs . show $ uteamid) insertUser userref buid - Intra.bindBrigUser buid userref >>= \case - True -> pure buid - False -> do - SAML.logger SAML.Warn $ "SparBindUserDisappearedFromBrig: " <> show buid - throwSpar SparBindUserDisappearedFromBrig + buid <$ Intra.setBrigUserUserRef buid userref instance SPHandler SparError Spar where type NTCTX Spar = Env @@ -367,7 +364,7 @@ verdictHandlerResultCore bindCky = \case -- This is the first SSO authentication, so we auto-create a user. We know the user -- has not been created via SCIM because then we would've ended up in the -- "reauthentication" branch, so we pass 'ManagedByWire'. - (Nothing, Nothing, Nothing) -> autoprovisionSamlUser userref Nothing ManagedByWire + (Nothing, Nothing, Nothing) -> autoprovisionSamlUser userref ManagedByWire -- If the user is only found under an old (previous) issuer, move it here. (Nothing, Nothing, Just (oldUserRef, uid)) -> moveUserToNewIssuer oldUserRef userref uid >> pure uid -- SSO re-authentication (the most common case). @@ -401,10 +398,11 @@ verdictHandlerResultCore bindCky = \case -- not be the title of any page sent by the IdP while it negotiates with the user. -- - The page broadcasts a message to '*', to be picked up by the app. verdictHandlerWeb :: HasCallStack => VerdictHandlerResult -> Spar SAML.ResponseVerdict -verdictHandlerWeb = pure . \case - VerifyHandlerGranted cky _uid -> successPage cky - VerifyHandlerDenied reasons -> forbiddenPage "forbidden" (explainDeniedReason <$> reasons) - VerifyHandlerError lbl msg -> forbiddenPage lbl [msg] +verdictHandlerWeb = + pure . \case + VerifyHandlerGranted cky _uid -> successPage cky + VerifyHandlerDenied reasons -> forbiddenPage "forbidden" (explainDeniedReason <$> reasons) + VerifyHandlerError lbl msg -> forbiddenPage lbl [msg] where forbiddenPage :: ST -> [ST] -> SAML.ResponseVerdict forbiddenPage errlbl reasons = diff --git a/services/spar/src/Spar/Data.hs b/services/spar/src/Spar/Data.hs index abefd39cc1b..8eb46193db0 100644 --- a/services/spar/src/Spar/Data.hs +++ b/services/spar/src/Spar/Data.hs @@ -142,7 +142,8 @@ mkTTL now maxttl endOfLife = mkTTLNDT maxttl $ endOfLife `diffUTCTime` now mkTTLNDT :: (MonadError TTLError m, KnownSymbol a) => TTL a -> NominalDiffTime -> m (TTL a) mkTTLNDT maxttl ttlNDT = - if | actualttl > maxttl -> throwError $ TTLTooLong (showTTL actualttl) (showTTL maxttl) + if + | actualttl > maxttl -> throwError $ TTLTooLong (showTTL actualttl) (showTTL maxttl) | actualttl <= 0 -> throwError $ TTLNegative (showTTL actualttl) | otherwise -> pure actualttl where @@ -320,8 +321,9 @@ insertBindCookie cky uid ttlNDT = do -- | The counter-part of 'insertBindCookie'. lookupBindCookie :: (HasCallStack, MonadClient m) => BindCookie -> m (Maybe UserId) -lookupBindCookie (cs . fromBindCookie -> ckyval :: ST) = runIdentity <$$> do - (retry x1 . query1 sel $ params Quorum (Identity ckyval)) +lookupBindCookie (cs . fromBindCookie -> ckyval :: ST) = + runIdentity <$$> do + (retry x1 . query1 sel $ params Quorum (Identity ckyval)) where sel :: PrepQuery R (Identity ST) (Identity UserId) sel = "SELECT session_owner FROM bind_cookie WHERE cookie = ?" @@ -465,7 +467,7 @@ deleteIdPConfig :: SAML.Issuer -> TeamId -> m () -deleteIdPConfig idp issuer team = retry x5 $ batch $ do +deleteIdPConfig idp issuer team = retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery delDefaultIdp (Identity idp) @@ -587,7 +589,7 @@ insertScimToken :: ScimToken -> ScimTokenInfo -> m () -insertScimToken token ScimTokenInfo {..} = retry x5 $ batch $ do +insertScimToken token ScimTokenInfo {..} = retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery insByToken (token, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr) @@ -650,7 +652,7 @@ deleteScimToken :: m () deleteScimToken team tokenid = do mbToken <- retry x1 . query1 selById $ params Quorum (team, tokenid) - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery delById (team, tokenid) @@ -683,7 +685,7 @@ deleteTeamScimTokens :: m () deleteTeamScimTokens team = do tokens <- retry x5 $ query sel $ params Quorum (Identity team) - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchLogged setConsistency Quorum addPrepQuery delByTeam (Identity team) diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index f5c8ea6eb79..cc9f7273c79 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -61,14 +61,13 @@ throwSpar :: MonadError SparError m => SparCustomError -> m a throwSpar = throwError . SAML.CustomError data SparCustomError - = SparNotFound + = SparIdPNotFound | SparMissingZUsr | SparNotInTeam | SparNotTeamOwner | SparSSODisabled | SparInitLoginWithAuth | SparInitBindWithoutAuth - | SparBindUserDisappearedFromBrig | SparNoSuchRequest | SparNoRequestRefInResponse LT | SparCouldNotSubstituteSuccessURI LT @@ -162,14 +161,13 @@ renderSparError SAML.BadSamlResponseIssuerMissing = Right $ Wai.Error status400 renderSparError SAML.BadSamlResponseNoAssertions = Right $ Wai.Error status400 "bad-response-saml" ("Bad response: no assertions in AuthnResponse") renderSparError SAML.BadSamlResponseAssertionWithoutID = Right $ Wai.Error status400 "bad-response-saml" ("Bad response: assertion without ID") renderSparError (SAML.BadSamlResponseInvalidSignature msg) = Right $ Wai.Error status400 "bad-response-signature" (cs msg) -renderSparError (SAML.CustomError SparNotFound) = Right $ Wai.Error status404 "not-found" "Could not find IdP." +renderSparError (SAML.CustomError SparIdPNotFound) = Right $ Wai.Error status404 "not-found" "Could not find IdP." renderSparError (SAML.CustomError SparMissingZUsr) = Right $ Wai.Error status400 "client-error" "[header] 'Z-User' required" renderSparError (SAML.CustomError SparNotInTeam) = Right $ Wai.Error status403 "no-team-member" "Requesting user is not a team member or not a member of this team." renderSparError (SAML.CustomError SparNotTeamOwner) = Right $ Wai.Error status403 "insufficient-permissions" "You need to be a team owner." renderSparError (SAML.CustomError SparSSODisabled) = Right $ Wai.Error status403 "sso-disabled" "Please ask customer support to enable this feature for your team." renderSparError (SAML.CustomError SparInitLoginWithAuth) = Right $ Wai.Error status403 "login-with-auth" "This end-point is only for login, not binding." renderSparError (SAML.CustomError SparInitBindWithoutAuth) = Right $ Wai.Error status403 "bind-without-auth" "This end-point is only for binding, not login." -renderSparError (SAML.CustomError SparBindUserDisappearedFromBrig) = Right $ Wai.Error status404 "bind-user-disappeared" "Your user appears to have been deleted?" renderSparError SAML.UnknownError = Right $ Wai.Error status500 "server-error" "Unknown server error." renderSparError (SAML.BadServerConfig msg) = Right $ Wai.Error status500 "server-error" ("Error in server config: " <> msg) renderSparError (SAML.InvalidCert msg) = Right $ Wai.Error status500 "invalid-certificate" ("Error in idp certificate: " <> msg) diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index c00757b9d04..1f2e579e707 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -22,6 +22,7 @@ module Spar.Intra.Brig ( toUserSSOId, fromUserSSOId, toExternalId, + mkUserName, getBrigUser, getBrigUserTeam, getBrigUsers, @@ -33,11 +34,9 @@ module Spar.Intra.Brig setBrigUserUserRef, setBrigUserRichInfo, checkHandleAvailable, - bindBrigUser, deleteBrigUser, createBrigUser, updateEmail, - isTeamUser, getZUsrOwnedTeam, ensureReAuthorised, ssoLogin, @@ -65,7 +64,6 @@ import Data.Handle (Handle (Handle, fromHandle)) import Data.Id (Id (Id), TeamId, UserId) import Data.Ix import Data.Misc (PlainTextPassword) -import Data.Range import Data.String.Conversions import Imports import Network.HTTP.Types.Method @@ -74,6 +72,7 @@ import qualified Servant.Server as Servant import Spar.Error import Spar.Intra.Galley as Galley (MonadSparToGalley, assertIsTeamOwner, isEmailValidationEnabledTeam) import Web.Cookie +import Wire.API.User import Wire.API.User.RichInfo as RichInfo ---------------------------------------------------------------------- @@ -96,6 +95,13 @@ toExternalId ssoid = do let subj = uref ^. SAML.uidSubject pure $ SAML.nameIDToST subj +-- | Take a maybe text, construct a 'Name' from what we have in a scim user. If the text +-- isn't present, use the saml subject (usually an email address). If both are 'Nothing', +-- fail. +mkUserName :: Maybe Text -> SAML.UserRef -> Either String Name +mkUserName (Just n) _ = mkName n +mkUserName Nothing uref = mkName (SAML.unsafeShowNameID $ uref ^. SAML.uidSubject) + parseResponse :: (FromJSON a, MonadError SparError m) => Response (Maybe LBS) -> m a parseResponse resp = do bdy <- maybe (throwSpar SparNoBodyInBrigResponse) pure $ responseBody resp @@ -120,47 +126,25 @@ class MonadError SparError m => MonadSparToBrig m where instance MonadSparToBrig m => MonadSparToBrig (ReaderT r m) where call = lift . call --- | Create a user on brig. User name is derived from 'SAML.UserRef'. +-- | Create a user on brig. createBrigUser :: (HasCallStack, MonadSparToBrig m) => -- | SSO identity SAML.UserRef -> UserId -> TeamId -> - -- | User name (if 'Nothing', the subject ID will be used) - Maybe Name -> + -- | User name + Name -> -- | Who should have control over the user ManagedBy -> m UserId -createBrigUser suid (Id buid) teamid mbName managedBy = do - uname :: Name <- case mbName of - Just n -> pure n - Nothing -> do - -- 1. use 'SAML.unsafeShowNameID' to get a 'Name'. rationale: it does not need to be - -- unique. - let subj = suid ^. SAML.uidSubject - subjtxt = SAML.unsafeShowNameID subj - muname = checked @ST @1 @128 subjtxt - err = SparBadUserName $ "must have >= 1, <= 128 chars: " <> cs subjtxt - case muname of - Just uname -> pure . Name . fromRange $ uname - Nothing -> throwSpar err +createBrigUser suid (Id buid) teamid uname managedBy = do let newUser :: NewUser newUser = - NewUser - { newUserDisplayName = uname, - newUserUUID = Just buid, + (emptyNewUser uname) + { newUserUUID = Just buid, newUserIdentity = Just $ SSOIdentity (toUserSSOId suid) Nothing Nothing, - newUserPict = Nothing, - newUserAssets = [], - newUserAccentId = Nothing, - newUserEmailCode = Nothing, - newUserPhoneCode = Nothing, newUserOrigin = Just . NewUserOriginTeamUser . NewTeamMemberSSO $ teamid, - newUserLabel = Nothing, - newUserLocale = Nothing, - newUserPassword = Nothing, - newUserExpiresIn = Nothing, newUserManagedBy = Just managedBy } resp :: Response (Maybe LBS) <- @@ -169,7 +153,8 @@ createBrigUser suid (Id buid) teamid mbName managedBy = do . path "/i/users" . json newUser let sCode = statusCode resp - if | sCode < 300 -> + if + | sCode < 300 -> userId . selfUser <$> parseResponse @SelfProfile resp | inRange (400, 499) sCode -> throwSpar . SparBrigErrorWith (responseStatus resp) $ "create user failed" @@ -256,7 +241,8 @@ setBrigUserName buid name = do uupAccentId = Nothing } let sCode = statusCode resp - if | sCode < 300 -> + if + | sCode < 300 -> pure () | inRange (400, 499) sCode -> throwSpar . SparBrigErrorWith (responseStatus resp) $ "set name failed" @@ -275,7 +261,8 @@ setBrigUserHandle buid handle = do . header "Z-Connection" "" . json (HandleUpdate (fromHandle handle)) let sCode = statusCode resp - if | sCode < 300 -> + if + | sCode < 300 -> pure () | inRange (400, 499) sCode -> throwSpar . SparBrigErrorWith (responseStatus resp) $ "set handle failed" @@ -292,7 +279,8 @@ setBrigUserManagedBy buid managedBy = do . paths ["i", "users", toByteString' buid, "managed-by"] . json (ManagedByUpdate managedBy) let sCode = statusCode resp - if | sCode < 300 -> + if + | sCode < 300 -> pure () | inRange (400, 499) sCode -> throwSpar . SparBrigErrorWith (responseStatus resp) $ "set managedBy failed" @@ -308,7 +296,8 @@ setBrigUserUserRef buid uref = do . paths ["i", "users", toByteString' buid, "sso-id"] . json (toUserSSOId uref) let sCode = statusCode resp - if | sCode < 300 -> + if + | sCode < 300 -> pure () | inRange (400, 499) sCode -> throwSpar . SparBrigErrorWith (responseStatus resp) $ "set UserSSOId failed" @@ -325,7 +314,8 @@ setBrigUserRichInfo buid richInfo = do . paths ["i", "users", toByteString' buid, "rich-info"] . json (RichInfoUpdate $ unRichInfo richInfo) let sCode = statusCode resp - if | sCode < 300 -> + if + | sCode < 300 -> pure () | inRange (400, 499) sCode -> throwSpar . SparBrigErrorWith (responseStatus resp) $ "set richInfo failed" @@ -334,16 +324,17 @@ setBrigUserRichInfo buid richInfo = do -- TODO: We should add an internal endpoint for this instead getBrigUserRichInfo :: (HasCallStack, MonadSparToBrig m) => UserId -> m RichInfo -getBrigUserRichInfo buid = RichInfo.RichInfo <$> do - resp <- - call $ - method GET - . paths ["users", toByteString' buid, "rich-info"] - . header "Z-User" (toByteString' buid) - . header "Z-Connection" "" - case statusCode resp of - 200 -> parseResponse resp - _ -> throwSpar (SparBrigErrorWith (responseStatus resp) "Could not retrieve rich info") +getBrigUserRichInfo buid = + RichInfo.RichInfo <$> do + resp <- + call $ + method GET + . paths ["users", toByteString' buid, "rich-info"] + . header "Z-User" (toByteString' buid) + . header "Z-Connection" "" + case statusCode resp of + 200 -> parseResponse resp + _ -> throwSpar (SparBrigErrorWith (responseStatus resp) "Could not retrieve rich info") -- | At the time of writing this, @HEAD /users/handles/:uid@ does not use the 'UserId' for -- anything but authorization. @@ -356,7 +347,8 @@ checkHandleAvailable hnd buid = do . header "Z-User" (toByteString' buid) . header "Z-Connection" "" let sCode = statusCode resp - if | sCode == 200 -> -- handle exists + if + | sCode == 200 -> -- handle exists pure False | sCode == 404 -> -- handle not found pure True @@ -365,19 +357,6 @@ checkHandleAvailable hnd buid = do | otherwise -> throwSpar . SparBrigError . cs $ "check handle failed with status " <> show sCode --- | This works under the assumption that the user must exist on brig. If it does not, brig --- responds with 404 and this function returns 'False'. --- --- See also: 'setBrigUserUserRef'. -bindBrigUser :: (HasCallStack, MonadSparToBrig m) => UserId -> SAML.UserRef -> m Bool -bindBrigUser uid (toUserSSOId -> ussoid) = do - resp <- - call $ - method PUT - . paths ["/i/users", toByteString' uid, "sso-id"] - . json ussoid - pure $ Bilge.statusCode resp < 300 - -- | Call brig to delete a user deleteBrigUser :: (HasCallStack, MonadSparToBrig m, MonadIO m) => UserId -> m () deleteBrigUser buid = do @@ -386,16 +365,13 @@ deleteBrigUser buid = do method DELETE . paths ["/i/users", toByteString' buid] let sCode = statusCode resp - if | sCode < 300 -> pure () + if + | sCode < 300 -> pure () | inRange (400, 499) sCode -> throwSpar $ SparBrigErrorWith (responseStatus resp) "failed to delete user" | otherwise -> throwSpar $ SparBrigError ("delete user failed with status " <> cs (show sCode)) --- | Check that a user id exists on brig and has a team id. -isTeamUser :: (HasCallStack, MonadSparToBrig m) => UserId -> m Bool -isTeamUser buid = isJust <$> getBrigUserTeam buid - -- | Check that a user id exists on brig and has a team id. getBrigUserTeam :: (HasCallStack, MonadSparToBrig m) => UserId -> m (Maybe TeamId) getBrigUserTeam buid = do @@ -430,7 +406,8 @@ ensureReAuthorised (Just uid) secret = do . paths ["/i/users", toByteString' uid, "reauthenticate"] . json (ReAuthUser secret) let sCode = statusCode resp - if | sCode == 200 -> + if + | sCode == 200 -> pure () | sCode == 403 -> throwSpar SparReAuthRequired @@ -454,7 +431,8 @@ ssoLogin buid = do . json (SsoLogin buid Nothing) . queryItem "persist" "true" let sCode = statusCode resp - if | sCode < 300 -> + if + | sCode < 300 -> Just <$> respToCookie resp | inRange (400, 499) sCode -> pure Nothing diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index e9603c5ae17..2feb83e0e70 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -119,8 +119,9 @@ apiScim = -- We caught an exception that's not a Spar exception at all. It is wrapped into -- Scim.serverError. Left someException -> - pure $ Left . SAML.CustomError . SparScimError $ - Scim.serverError (cs (displayException someException)) + pure $ + Left . SAML.CustomError . SparScimError $ + Scim.serverError (cs (displayException someException)) -- We caught a 'SparScimError' exception. It is left as-is. Right err@(Left (SAML.CustomError (SparScimError _))) -> pure err @@ -129,8 +130,9 @@ apiScim = -- TODO: does it have to be logged? Right (Left sparError) -> do err <- sparToServerErrorWithLogging (sparCtxLogger env) sparError - pure $ Left . SAML.CustomError . SparScimError $ - Scim.serverError (cs (errBody err)) + pure $ + Left . SAML.CustomError . SparScimError $ + Scim.serverError (cs (errBody err)) -- No exceptions! Good. Right (Right x) -> pure $ Right x diff --git a/services/spar/src/Spar/Scim/Auth.hs b/services/spar/src/Spar/Scim/Auth.hs index 0c5312d6469..642196698d2 100644 --- a/services/spar/src/Spar/Scim/Auth.hs +++ b/services/spar/src/Spar/Scim/Auth.hs @@ -34,20 +34,28 @@ module Spar.Scim.Auth ) where -import Control.Lens hiding ((.=), Strict) +import Control.Lens hiding (Strict, (.=)) import qualified Data.ByteString.Base64 as ES -import Data.Id -import Data.String.Conversions -import Data.Time +import Data.Id (ScimTokenId, UserId, randomId) +import Data.String.Conversions (cs) +import Data.Time (getCurrentTime) import Imports import OpenSSL.Random (randBytes) import qualified SAML2.WebSSO as SAML -import Servant -import Spar.App (Spar, sparCtxOpts, wrapMonadClient, wrapMonadClient) +import Servant (NoContent (NoContent), ServerT, (:<|>) ((:<|>))) +import Spar.App (Spar, sparCtxOpts, wrapMonadClient) import qualified Spar.Data as Data -import Spar.Error +import qualified Spar.Error as E import qualified Spar.Intra.Brig as Intra.Brig import Spar.Scim.Types + ( APIScimToken, + CreateScimToken (CreateScimToken), + CreateScimTokenResponse (..), + ScimTokenList (..), + SparTag, + createScimTokenDescr, + createScimTokenPassword, + ) import Spar.Types -- FUTUREWORK: these imports are not very handy. split up Spar.Scim into -- Spar.Scim.{Core,User,Group} to avoid at least some of the hscim name clashes? @@ -94,7 +102,7 @@ createScimToken zusr CreateScimToken {..} = do tokenNumber <- fmap length $ wrapMonadClient $ Data.getScimTokens teamid maxTokens <- asks (maxScimTokens . sparCtxOpts) unless (tokenNumber < maxTokens) $ - throwSpar SparProvisioningTokenLimitReached + E.throwSpar E.SparProvisioningTokenLimitReached idps <- wrapMonadClient $ Data.getIdPConfigsByTeam teamid case idps of [idp] -> do @@ -117,13 +125,13 @@ createScimToken zusr CreateScimToken {..} = do -- NB: if the two following cases do not result in errors, 'validateScimUser' needs to -- be changed. currently, it relies on the fact that there is always an IdP. [] -> - throwSpar $ - SparProvisioningNoSingleIdP + E.throwSpar $ + E.SparProvisioningNoSingleIdP "SCIM tokens can only be created for a team with an IdP, \ \but none are found" _ -> - throwSpar $ - SparProvisioningNoSingleIdP + E.throwSpar $ + E.SparProvisioningNoSingleIdP "SCIM tokens can only be created for a team with exactly one IdP, \ \but more are found" diff --git a/services/spar/src/Spar/Scim/Swagger.hs b/services/spar/src/Spar/Scim/Swagger.hs index 44651d4a240..60a20e52df4 100644 --- a/services/spar/src/Spar/Scim/Swagger.hs +++ b/services/spar/src/Spar/Scim/Swagger.hs @@ -30,16 +30,16 @@ module Spar.Scim.Swagger ) where -import Control.Lens -import Data.Id -import Data.Proxy +import Control.Lens (mapped, (&), (.~), (?~)) +import Data.Id (ScimTokenId, TeamId) +import Data.Proxy (Proxy (Proxy)) import Data.Swagger hiding (Header (..)) -import Data.Time +import Data.Time (UTCTime) import Imports import qualified SAML2.WebSSO as SAML import Spar.Orphans () -import Spar.Scim -import Spar.Types +import Spar.Scim (CreateScimToken, CreateScimTokenResponse (..), ScimTokenList (..)) +import Spar.Types (ScimToken, ScimTokenInfo) instance ToParamSchema ScimToken where toParamSchema _ = toParamSchema (Proxy @Text) @@ -56,50 +56,54 @@ instance ToSchema ScimTokenInfo where createdAtSchema <- declareSchemaRef (Proxy @UTCTime) idpSchema <- declareSchemaRef (Proxy @SAML.IdPId) descrSchema <- declareSchemaRef (Proxy @Text) - return $ NamedSchema (Just "ScimTokenInfo") $ - mempty - & type_ .~ Just SwaggerObject - & properties - .~ [ ("team", teamSchema), - ("id", idSchema), - ("created_at", createdAtSchema), - ("idp", idpSchema), - ("description", descrSchema) - ] - & required .~ ["team", "id", "created_at", "description"] + return $ + NamedSchema (Just "ScimTokenInfo") $ + mempty + & type_ .~ Just SwaggerObject + & properties + .~ [ ("team", teamSchema), + ("id", idSchema), + ("created_at", createdAtSchema), + ("idp", idpSchema), + ("description", descrSchema) + ] + & required .~ ["team", "id", "created_at", "description"] instance ToSchema CreateScimToken where declareNamedSchema _ = do textSchema <- declareSchemaRef (Proxy @Text) - return $ NamedSchema (Just "CreateScimToken") $ - mempty - & type_ .~ Just SwaggerObject - & properties - .~ [ ("description", textSchema), - ("password", textSchema) - ] - & required .~ ["description"] + return $ + NamedSchema (Just "CreateScimToken") $ + mempty + & type_ .~ Just SwaggerObject + & properties + .~ [ ("description", textSchema), + ("password", textSchema) + ] + & required .~ ["description"] instance ToSchema CreateScimTokenResponse where declareNamedSchema _ = do tokenSchema <- declareSchemaRef (Proxy @ScimToken) infoSchema <- declareSchemaRef (Proxy @ScimTokenInfo) - return $ NamedSchema (Just "CreateScimTokenResponse") $ - mempty - & type_ .~ Just SwaggerObject - & properties - .~ [ ("token", tokenSchema), - ("info", infoSchema) - ] - & required .~ ["token", "info"] + return $ + NamedSchema (Just "CreateScimTokenResponse") $ + mempty + & type_ .~ Just SwaggerObject + & properties + .~ [ ("token", tokenSchema), + ("info", infoSchema) + ] + & required .~ ["token", "info"] instance ToSchema ScimTokenList where declareNamedSchema _ = do infoListSchema <- declareSchemaRef (Proxy @[ScimTokenInfo]) - return $ NamedSchema (Just "ScimTokenList") $ - mempty - & type_ .~ Just SwaggerObject - & properties - .~ [ ("tokens", infoListSchema) - ] - & required .~ ["tokens"] + return $ + NamedSchema (Just "ScimTokenList") $ + mempty + & type_ .~ Just SwaggerObject + & properties + .~ [ ("tokens", infoListSchema) + ] + & required .~ ["tokens"] diff --git a/services/spar/src/Spar/Scim/Types.hs b/services/spar/src/Spar/Scim/Types.hs index 55fd8faa470..eb450b3c57f 100644 --- a/services/spar/src/Spar/Scim/Types.hs +++ b/services/spar/src/Spar/Scim/Types.hs @@ -41,21 +41,21 @@ module Spar.Scim.Types where import Brig.Types.Intra (AccountStatus (Active, Deleted, Ephemeral, Suspended)) -import Brig.Types.User as Brig -import Control.Lens hiding ((#), (.=), Strict) -import Data.Aeson as Aeson +import qualified Brig.Types.User as BT +import Control.Lens (makeLenses) +import Control.Monad.Except (throwError) +import qualified Data.Aeson as Aeson import qualified Data.CaseInsensitive as CI import Data.Handle (Handle) -import Data.Id -import Data.Json.Util ((#)) +import Data.Id (ScimTokenId, UserId) import qualified Data.Map as Map import Data.Misc (PlainTextPassword) import Imports import qualified SAML2.WebSSO as SAML -import Servant -import Servant.API.Generic ((:-), ToServantApi) -import Spar.API.Util -import Spar.Types +import Servant (DeleteNoContent, Get, Header, JSON, NoContent, Post, QueryParam', ReqBody, Required, Strict, (:<|>), (:>)) +import Servant.API.Generic (ToServantApi, (:-)) +import Spar.API.Util (OmitDocs) +import Spar.Types (ScimToken, ScimTokenInfo) import Web.Scim.AttrName (AttrName (..)) import qualified Web.Scim.Capabilities.MetaSchema as Scim.Meta import qualified Web.Scim.Class.Auth as Scim.Auth @@ -68,7 +68,7 @@ import qualified Web.Scim.Schema.PatchOp as Scim import Web.Scim.Schema.Schema (Schema (CustomSchema)) import qualified Web.Scim.Schema.Schema as Scim import qualified Web.Scim.Schema.User as Scim.User -import Wire.API.User.RichInfo +import qualified Wire.API.User.RichInfo as RI ---------------------------------------------------------------------------- -- Schemas @@ -76,8 +76,8 @@ import Wire.API.User.RichInfo userSchemas :: [Scim.Schema] userSchemas = [ Scim.User20, - Scim.CustomSchema richInfoAssocListURN, - Scim.CustomSchema richInfoMapURN + Scim.CustomSchema RI.richInfoAssocListURN, + Scim.CustomSchema RI.richInfoMapURN ] ---------------------------------------------------------------------------- @@ -137,42 +137,42 @@ newtype WrappedScimUser tag = WrappedScimUser -- | Extra Wire-specific data contained in a SCIM user profile. data ScimUserExtra = ScimUserExtra - { _sueRichInfo :: RichInfo + { _sueRichInfo :: RI.RichInfo } deriving (Eq, Show) makeLenses ''ScimUserExtra -instance FromJSON ScimUserExtra where - parseJSON v = ScimUserExtra <$> parseJSON v +instance Aeson.FromJSON ScimUserExtra where + parseJSON v = ScimUserExtra <$> Aeson.parseJSON v -instance ToJSON ScimUserExtra where - toJSON (ScimUserExtra rif) = toJSON rif +instance Aeson.ToJSON ScimUserExtra where + toJSON (ScimUserExtra rif) = Aeson.toJSON rif instance Scim.Patchable ScimUserExtra where - applyOperation (ScimUserExtra (RichInfo rinfRaw)) (Operation o (Just (NormalPath (AttrPath (Just (CustomSchema schema)) (AttrName (CI.mk -> ciAttrName)) Nothing))) val) - | schema == richInfoMapURN = - let rinf = richInfoMap $ fromRichInfoAssocList rinfRaw - unrinf = ScimUserExtra . RichInfo . toRichInfoAssocList . (`RichInfoMapAndList` mempty) + applyOperation (ScimUserExtra (RI.RichInfo rinfRaw)) (Operation o (Just (NormalPath (AttrPath (Just (CustomSchema schema)) (AttrName (CI.mk -> ciAttrName)) Nothing))) val) + | schema == RI.richInfoMapURN = + let rinf = RI.richInfoMap $ RI.fromRichInfoAssocList rinfRaw + unrinf = ScimUserExtra . RI.RichInfo . RI.toRichInfoAssocList . (`RI.RichInfoMapAndList` mempty) in unrinf <$> case o of Scim.Remove -> pure $ Map.delete ciAttrName rinf _AddOrReplace -> case val of - (Just (String textVal)) -> + (Just (Aeson.String textVal)) -> pure $ Map.insert ciAttrName textVal rinf _ -> throwError $ Scim.badRequest Scim.InvalidValue $ Just "rich info values can only be text" - | schema == richInfoAssocListURN = - let rinf = richInfoAssocList $ fromRichInfoAssocList rinfRaw - unrinf = ScimUserExtra . RichInfo . toRichInfoAssocList . (mempty `RichInfoMapAndList`) - matchesAttrName (RichField k _) = k == ciAttrName + | schema == RI.richInfoAssocListURN = + let rinf = RI.richInfoAssocList $ RI.fromRichInfoAssocList rinfRaw + unrinf = ScimUserExtra . RI.RichInfo . RI.toRichInfoAssocList . (mempty `RI.RichInfoMapAndList`) + matchesAttrName (RI.RichField k _) = k == ciAttrName in unrinf <$> case o of Scim.Remove -> pure $ filter (not . matchesAttrName) rinf _AddOrReplace -> case val of - (Just (String textVal)) -> - let newField = RichField ciAttrName textVal + (Just (Aeson.String textVal)) -> + let newField = RI.RichField ciAttrName textVal replaceIfMatchesAttrName f = if matchesAttrName f then newField else f newRichInfo = if not $ any matchesAttrName rinf @@ -202,8 +202,8 @@ instance Scim.Patchable ScimUserExtra where data ValidScimUser = ValidScimUser { _vsuUserRef :: SAML.UserRef, _vsuHandle :: Handle, - _vsuName :: Maybe Name, -- TODO: remove the 'Maybe' here, and construct the name not in "Spar.Intra.Brig", but in 'validateScimUser'. - _vsuRichInfo :: RichInfo, + _vsuName :: BT.Name, + _vsuRichInfo :: RI.RichInfo, _vsuActive :: Bool } deriving (Eq, Show) @@ -242,19 +242,19 @@ data CreateScimToken = CreateScimToken } deriving (Eq, Show) -instance FromJSON CreateScimToken where - parseJSON = withObject "CreateScimToken" $ \o -> do - createScimTokenDescr <- o .: "description" - createScimTokenPassword <- o .:? "password" +instance Aeson.FromJSON CreateScimToken where + parseJSON = Aeson.withObject "CreateScimToken" $ \o -> do + createScimTokenDescr <- o Aeson..: "description" + createScimTokenPassword <- o Aeson..:? "password" pure CreateScimToken {..} -- Used for integration tests -instance ToJSON CreateScimToken where +instance Aeson.ToJSON CreateScimToken where toJSON CreateScimToken {..} = - object $ - "description" .= createScimTokenDescr - # "password" .= createScimTokenPassword - # [] + Aeson.object + [ "description" Aeson..= createScimTokenDescr, + "password" Aeson..= createScimTokenPassword + ] -- | Type used for the response of 'APIScimTokenCreate'. data CreateScimTokenResponse = CreateScimTokenResponse @@ -264,17 +264,17 @@ data CreateScimTokenResponse = CreateScimTokenResponse deriving (Eq, Show) -- Used for integration tests -instance FromJSON CreateScimTokenResponse where - parseJSON = withObject "CreateScimTokenResponse" $ \o -> do - createScimTokenResponseToken <- o .: "token" - createScimTokenResponseInfo <- o .: "info" +instance Aeson.FromJSON CreateScimTokenResponse where + parseJSON = Aeson.withObject "CreateScimTokenResponse" $ \o -> do + createScimTokenResponseToken <- o Aeson..: "token" + createScimTokenResponseInfo <- o Aeson..: "info" pure CreateScimTokenResponse {..} -instance ToJSON CreateScimTokenResponse where +instance Aeson.ToJSON CreateScimTokenResponse where toJSON CreateScimTokenResponse {..} = - object - [ "token" .= createScimTokenResponseToken, - "info" .= createScimTokenResponseInfo + Aeson.object + [ "token" Aeson..= createScimTokenResponseToken, + "info" Aeson..= createScimTokenResponseInfo ] -- | Type used for responses of endpoints that return a list of SCIM tokens. @@ -286,15 +286,15 @@ data ScimTokenList = ScimTokenList } deriving (Eq, Show) -instance FromJSON ScimTokenList where - parseJSON = withObject "ScimTokenList" $ \o -> do - scimTokenListTokens <- o .: "tokens" +instance Aeson.FromJSON ScimTokenList where + parseJSON = Aeson.withObject "ScimTokenList" $ \o -> do + scimTokenListTokens <- o Aeson..: "tokens" pure ScimTokenList {..} -instance ToJSON ScimTokenList where +instance Aeson.ToJSON ScimTokenList where toJSON ScimTokenList {..} = - object - [ "tokens" .= scimTokenListTokens + Aeson.object + [ "tokens" Aeson..= scimTokenListTokens ] ---------------------------------------------------------------------- diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 66708ed7925..dfa849eaefd 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -42,30 +42,30 @@ module Spar.Scim.User where import Brig.Types.Intra (AccountStatus) -import Brig.Types.User as BrigTypes +import Brig.Types.User (ManagedBy (..), Name (..), User (..), ssoIdentity) +import qualified Brig.Types.User as BT import Control.Error ((!?), (??)) import Control.Exception (assert) import Control.Lens ((^.)) -import Control.Monad.Except -import Control.Monad.Trans.Maybe -import Crypto.Hash -import Data.Aeson as Aeson +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) +import Crypto.Hash (Digest, SHA256, hashlazy) +import qualified Data.Aeson as Aeson import Data.Handle (Handle (Handle), parseHandle) -import Data.Id +import Data.Id (Id (Id), UserId, idToText) import Data.Json.Util (UTCTimeMillis, fromUTCTimeMillis, toUTCTimeMillis) -import Data.Range -import Data.String.Conversions +import Data.String.Conversions (cs) import qualified Data.Text as Text import qualified Data.UUID.V4 as UUID import Imports -import Network.URI +import Network.URI (URI, parseURI) import qualified SAML2.WebSSO as SAML import Spar.App (Spar, getUser, sparCtxOpts, validateEmailIfExists, wrapMonadClient) import qualified Spar.Data as Data import qualified Spar.Intra.Brig as Brig import Spar.Scim.Auth () -import Spar.Scim.Types -import Spar.Types +import qualified Spar.Scim.Types as ST +import Spar.Types (IdP, ScimTokenInfo (..), derivedOpts, derivedOptsScimBaseURI, richInfoLimit, wiTeam) import qualified System.Logger.Class as Log import qualified URI.ByteString as URIBS import qualified Web.Scim.Class.User as Scim @@ -78,16 +78,16 @@ import qualified Web.Scim.Schema.Meta as Scim import qualified Web.Scim.Schema.ResourceType as Scim import qualified Web.Scim.Schema.User as Scim import qualified Web.Scim.Schema.User as Scim.User (schemas) -import Wire.API.User.RichInfo +import qualified Wire.API.User.RichInfo as RI ---------------------------------------------------------------------------- -- UserDB instance -instance Scim.UserDB SparTag Spar where +instance Scim.UserDB ST.SparTag Spar where getUsers :: ScimTokenInfo -> Maybe Scim.Filter -> - Scim.ScimHandler Spar (Scim.ListResponse (Scim.StoredUser SparTag)) + Scim.ScimHandler Spar (Scim.ListResponse (Scim.StoredUser ST.SparTag)) getUsers _ Nothing = do throwError $ Scim.badRequest Scim.TooMany (Just "Please specify a filter when getting users.") getUsers ScimTokenInfo {stiTeam, stiIdP} (Just filter') = do @@ -116,7 +116,7 @@ instance Scim.UserDB SparTag Spar where getUser :: ScimTokenInfo -> UserId -> - Scim.ScimHandler Spar (Scim.StoredUser SparTag) + Scim.ScimHandler Spar (Scim.StoredUser ST.SparTag) getUser ScimTokenInfo {stiTeam} uid = do let notfound = Scim.notFound "User" (idToText uid) brigUser <- lift (Brig.getBrigUser uid) >>= maybe (throwError notfound) pure @@ -125,15 +125,15 @@ instance Scim.UserDB SparTag Spar where postUser :: ScimTokenInfo -> - Scim.User SparTag -> - Scim.ScimHandler Spar (Scim.StoredUser SparTag) + Scim.User ST.SparTag -> + Scim.ScimHandler Spar (Scim.StoredUser ST.SparTag) postUser tokinfo user = createValidScimUser tokinfo =<< validateScimUser tokinfo user putUser :: ScimTokenInfo -> UserId -> - Scim.User SparTag -> - Scim.ScimHandler Spar (Scim.StoredUser SparTag) + Scim.User ST.SparTag -> + Scim.ScimHandler Spar (Scim.StoredUser ST.SparTag) putUser tokinfo uid newScimUser = updateValidScimUser tokinfo uid =<< validateScimUser tokinfo newScimUser @@ -150,8 +150,8 @@ validateScimUser :: (m ~ Scim.ScimHandler Spar) => -- | Used to decide what IdP to assign the user to ScimTokenInfo -> - Scim.User SparTag -> - m ValidScimUser + Scim.User ST.SparTag -> + m ST.ValidScimUser validateScimUser tokinfo user = do idpConfig <- tokenInfoToIdP tokinfo richInfoLimit <- lift $ asks (richInfoLimit . sparCtxOpts) @@ -204,44 +204,38 @@ validateScimUser' :: IdP -> -- | Rich info limit Int -> - Scim.User SparTag -> - m ValidScimUser + Scim.User ST.SparTag -> + m ST.ValidScimUser validateScimUser' idp richInfoLimit user = do uref :: SAML.UserRef <- mkUserRef idp (Scim.externalId user) handl <- validateHandle . Text.toLower . Scim.userName $ user -- FUTUREWORK: 'Scim.userName' should be case insensitive; then the toLower here would -- be a little less brittle. - mbName <- mapM validateName (Scim.displayName user) - richInfo <- validateRichInfo (Scim.extra user ^. sueRichInfo) + uname <- do + let err = throwError . Scim.badRequest Scim.InvalidValue . Just . cs + either err pure $ Brig.mkUserName (Scim.displayName user) uref + richInfo <- validateRichInfo (Scim.extra user ^. ST.sueRichInfo) let active = Scim.active user - pure $ ValidScimUser uref handl mbName richInfo (fromMaybe True active) + pure $ ST.ValidScimUser uref handl uname richInfo (fromMaybe True active) where - -- Validate a name (@displayName@). It has to conform to standard Wire rules. - validateName :: Text -> m Name - validateName txt = case checkedEitherMsg @_ @1 @128 "displayName" txt of - Right rtxt -> pure $ Name (fromRange rtxt) - Left err -> - throwError $ - Scim.badRequest - Scim.InvalidValue - (Just ("displayName must be a valid Wire name, but: " <> Text.pack err)) -- Validate rich info (@richInfo@). It must not exceed the rich info limit. - validateRichInfo :: RichInfo -> m RichInfo + validateRichInfo :: RI.RichInfo -> m RI.RichInfo validateRichInfo richInfo = do - let sze = richInfoSize richInfo - when (sze > richInfoLimit) $ throwError $ - ( Scim.badRequest - Scim.InvalidValue - ( Just . cs $ - show [richInfoMapURN, richInfoAssocListURN] - <> " together exceed the size limit: max " - <> show richInfoLimit - <> " characters, but got " - <> show sze - ) - ) - { Scim.status = Scim.Status 413 - } + let sze = RI.richInfoSize richInfo + when (sze > richInfoLimit) $ + throwError $ + ( Scim.badRequest + Scim.InvalidValue + ( Just . cs $ + show [RI.richInfoMapURN, RI.richInfoAssocListURN] + <> " together exceed the size limit: max " + <> show richInfoLimit + <> " characters, but got " + <> show sze + ) + ) + { Scim.status = Scim.Status 413 + } pure richInfo -- | Given an 'externalId' and an 'IdP', construct a 'SAML.UserRef'. @@ -294,9 +288,9 @@ createValidScimUser :: forall m. (m ~ Scim.ScimHandler Spar) => ScimTokenInfo -> - ValidScimUser -> - m (Scim.StoredUser SparTag) -createValidScimUser tokinfo vsu@(ValidScimUser uref handl mbName richInfo active) = do + ST.ValidScimUser -> + m (Scim.StoredUser ST.SparTag) +createValidScimUser tokinfo vsu@(ST.ValidScimUser uref handl mbName richInfo active) = do idpConfig <- tokenInfoToIdP tokinfo -- sanity check: do tenant of the URef and the Issuer of the IdP match? (this is mostly -- here to make sure a refactoring we did in the past is sound: we removed a lookup by @@ -345,7 +339,7 @@ createValidScimUser tokinfo vsu@(ValidScimUser uref handl mbName richInfo active -- checked.) lift $ Brig.getStatus buid >>= \old -> do - let new = scimActiveFlagToAccountStatus old (Just active) + let new = ST.scimActiveFlagToAccountStatus old (Just active) when (new /= old) $ Brig.setStatus buid new pure storedUser @@ -354,8 +348,8 @@ updateValidScimUser :: (m ~ Scim.ScimHandler Spar) => ScimTokenInfo -> UserId -> - ValidScimUser -> - m (Scim.StoredUser SparTag) + ST.ValidScimUser -> + m (Scim.StoredUser ST.SparTag) updateValidScimUser tokinfo uid newScimUser = do -- TODO: currently the types in @hscim@ are constructed in such a way that -- 'Scim.User.User' doesn't contain an ID, only 'Scim.StoredUser' @@ -369,20 +363,20 @@ updateValidScimUser tokinfo uid newScimUser = do -- TODO: how do we get this safe w.r.t. race conditions / crashes? -- construct old and new user values with metadata. - oldScimStoredUser :: Scim.StoredUser SparTag <- + oldScimStoredUser :: Scim.StoredUser ST.SparTag <- Scim.getUser tokinfo uid - oldValidScimUser :: ValidScimUser <- + oldValidScimUser :: ST.ValidScimUser <- validateScimUser tokinfo . Scim.value . Scim.thing $ oldScimStoredUser - assertUserRefNotUsedElsewhere (newScimUser ^. vsuUserRef) uid - assertHandleNotUsedElsewhere (newScimUser ^. vsuHandle) uid + assertUserRefNotUsedElsewhere (newScimUser ^. ST.vsuUserRef) uid + assertHandleNotUsedElsewhere (newScimUser ^. ST.vsuHandle) uid if oldValidScimUser == newScimUser then pure oldScimStoredUser else do - newScimStoredUser :: Scim.StoredUser SparTag <- + newScimStoredUser :: Scim.StoredUser ST.SparTag <- lift $ updScimStoredUser (synthesizeScimUser newScimUser) oldScimStoredUser -- update 'SAML.UserRef' on spar (also delete the old 'SAML.UserRef' if it exists and -- is different from the new one) - let newuref = newScimUser ^. vsuUserRef + let newuref = newScimUser ^. ST.vsuUserRef olduref <- do let extid :: Maybe Text extid = Scim.externalId . Scim.value . Scim.thing $ oldScimStoredUser @@ -392,34 +386,29 @@ updateValidScimUser tokinfo uid newScimUser = do lift . wrapMonadClient $ Data.deleteSAMLUser olduref lift . wrapMonadClient $ Data.insertSAMLUser newuref uid -- update 'SAML.UserRef' on brig - bindok <- lift $ Brig.bindBrigUser uid newuref - unless bindok . throwError $ - Scim.serverError "Failed to update SAML UserRef on brig." - -- this can only happen if user is found in spar.scim_user, but missing on brig. - -- (internal error? race condition?) + lift $ Brig.setBrigUserUserRef uid newuref -- TODO: if the user has been suspended or unsuspended in brig since the last scim -- write, we'll find the wrong information here. -- [see also](https://github.com/zinfra/backend-issues/issues/1006) - oldScimUser :: ValidScimUser <- + oldScimUser :: ST.ValidScimUser <- validateScimUser tokinfo . Scim.value . Scim.thing $ oldScimStoredUser -- the old scim user from our db is already validated, but this also recovers -- the extra details not stored in the DB that we need here. lift $ do - case newScimUser ^. vsuName of - Just nm | oldScimUser ^. vsuName /= Just nm -> Brig.setBrigUserName uid nm - _ -> pure () - when (oldScimUser ^. vsuHandle /= newScimUser ^. vsuHandle) - $ Brig.setBrigUserHandle uid - $ newScimUser ^. vsuHandle - when (oldScimUser ^. vsuRichInfo /= newScimUser ^. vsuRichInfo) - $ Brig.setBrigUserRichInfo uid - $ newScimUser ^. vsuRichInfo + when (newScimUser ^. ST.vsuName /= oldScimUser ^. ST.vsuName) $ + Brig.setBrigUserName uid (newScimUser ^. ST.vsuName) + when (oldScimUser ^. ST.vsuHandle /= newScimUser ^. ST.vsuHandle) $ + Brig.setBrigUserHandle uid $ + newScimUser ^. ST.vsuHandle + when (oldScimUser ^. ST.vsuRichInfo /= newScimUser ^. ST.vsuRichInfo) $ + Brig.setBrigUserRichInfo uid $ + newScimUser ^. ST.vsuRichInfo lift $ Brig.getStatus uid >>= \old -> do - let new = scimActiveFlagToAccountStatus old (Just $ newScimUser ^. vsuActive) + let new = ST.scimActiveFlagToAccountStatus old (Just $ newScimUser ^. ST.vsuActive) when (new /= old) $ Brig.setStatus uid new -- store new user value to scim_user table (spar). (this must happen last, so in case @@ -429,8 +418,8 @@ updateValidScimUser tokinfo uid newScimUser = do toScimStoredUser :: UserId -> - Scim.User SparTag -> - Spar (Scim.StoredUser SparTag) + Scim.User ST.SparTag -> + Spar (Scim.StoredUser ST.SparTag) toScimStoredUser uid usr = do SAML.Time (toUTCTimeMillis -> now) <- SAML.getNow (createdAt, lastUpdatedAt) <- fromMaybe (now, now) <$> wrapMonadClient (Data.readScimUserTimes uid) @@ -443,12 +432,12 @@ toScimStoredUser' :: UTCTimeMillis -> URIBS.URI -> UserId -> - Scim.User SparTag -> - Scim.StoredUser SparTag + Scim.User ST.SparTag -> + Scim.StoredUser ST.SparTag toScimStoredUser' createdAt lastChangedAt baseuri uid usr = - Scim.WithMeta meta - $ Scim.WithId uid - $ usr {Scim.User.schemas = userSchemas} + Scim.WithMeta meta $ + Scim.WithId uid $ + usr {Scim.User.schemas = ST.userSchemas} where mkLocation :: String -> URI mkLocation pathSuffix = convURI $ baseuri SAML.=/ cs pathSuffix @@ -470,18 +459,18 @@ toScimStoredUser' createdAt lastChangedAt baseuri uid usr = updScimStoredUser :: forall m. (SAML.HasNow m) => - Scim.User SparTag -> - Scim.StoredUser SparTag -> - m (Scim.StoredUser SparTag) + Scim.User ST.SparTag -> + Scim.StoredUser ST.SparTag -> + m (Scim.StoredUser ST.SparTag) updScimStoredUser usr storedusr = do SAML.Time (toUTCTimeMillis -> now) <- SAML.getNow pure $ updScimStoredUser' now usr storedusr updScimStoredUser' :: UTCTimeMillis -> - Scim.User SparTag -> - Scim.StoredUser SparTag -> - Scim.StoredUser SparTag + Scim.User ST.SparTag -> + Scim.StoredUser ST.SparTag -> + Scim.StoredUser ST.SparTag updScimStoredUser' now usr (Scim.WithMeta meta (Scim.WithId scimuid _)) = Scim.WithMeta meta' (Scim.WithId scimuid usr) where @@ -503,16 +492,15 @@ deleteScimUser ScimTokenInfo {stiTeam} uid = do -- FUTUREWORK: currently it's impossible to delete the last available team owner via SCIM -- (because that owner won't be managed by SCIM in the first place), but if it ever becomes -- possible, we should do a check here and prohibit it. - unless (userTeam brigUser == Just stiTeam) - $ + unless (userTeam brigUser == Just stiTeam) $ -- users from other teams get you a 404. - throwError - $ Scim.notFound "user" (idToText uid) + throwError $ + Scim.notFound "user" (idToText uid) ssoId <- maybe (logThenServerError $ "no userSSOId for user " <> cs (idToText uid)) pure - $ BrigTypes.userSSOId brigUser + $ BT.userSSOId brigUser uref <- either logThenServerError pure $ Brig.fromUserSSOId ssoId lift . wrapMonadClient $ Data.deleteSAMLUser uref lift . wrapMonadClient $ Data.deleteScimUserTimes uid @@ -539,7 +527,7 @@ deleteScimUser ScimTokenInfo {stiTeam} uid = do -- requirements of strong ETags ("same resources have the same version"). calculateVersion :: UserId -> - Scim.User SparTag -> + Scim.User ST.SparTag -> Scim.ETag calculateVersion uid usr = Scim.Weak (Text.pack (show h)) where @@ -573,9 +561,10 @@ assertHandleUnused :: Handle -> UserId -> Scim.ScimHandler Spar () assertHandleUnused = assertHandleUnused' "userName is already taken" assertHandleUnused' :: Text -> Handle -> UserId -> Scim.ScimHandler Spar () -assertHandleUnused' msg hndl uid = lift (Brig.checkHandleAvailable hndl uid) >>= \case - True -> pure () - False -> throwError Scim.conflict {Scim.detail = Just msg} +assertHandleUnused' msg hndl uid = + lift (Brig.checkHandleAvailable hndl uid) >>= \case + True -> pure () + False -> throwError Scim.conflict {Scim.detail = Just msg} assertHandleNotUsedElsewhere :: Handle -> UserId -> Scim.ScimHandler Spar () assertHandleNotUsedElsewhere hndl uid = do @@ -586,17 +575,17 @@ assertHandleNotUsedElsewhere hndl uid = do -- | Helper function that translates a given brig user into a 'Scim.StoredUser', with some -- effects like updating the 'ManagedBy' field in brig and storing creation and update time -- stamps. -synthesizeStoredUser :: BrigTypes.User -> Scim.ScimHandler Spar (Scim.StoredUser SparTag) +synthesizeStoredUser :: BT.User -> Scim.ScimHandler Spar (Scim.StoredUser ST.SparTag) synthesizeStoredUser usr = do - let readState :: Spar (RichInfo, AccountStatus, Maybe (UTCTimeMillis, UTCTimeMillis), URIBS.URI) + let readState :: Spar (RI.RichInfo, AccountStatus, Maybe (UTCTimeMillis, UTCTimeMillis), URIBS.URI) readState = do - richInfo <- Brig.getBrigUserRichInfo (BrigTypes.userId usr) - accStatus <- Brig.getStatus (BrigTypes.userId usr) - accessTimes <- wrapMonadClient (Data.readScimUserTimes (BrigTypes.userId usr)) + richInfo <- Brig.getBrigUserRichInfo (BT.userId usr) + accStatus <- Brig.getStatus (BT.userId usr) + accessTimes <- wrapMonadClient (Data.readScimUserTimes (BT.userId usr)) baseuri <- asks $ derivedOptsScimBaseURI . derivedOpts . sparCtxOpts pure (richInfo, accStatus, accessTimes, baseuri) - let writeState :: UserId -> Maybe (UTCTimeMillis, UTCTimeMillis) -> ManagedBy -> Scim.StoredUser SparTag -> Spar () + let writeState :: UserId -> Maybe (UTCTimeMillis, UTCTimeMillis) -> ManagedBy -> Scim.StoredUser ST.SparTag -> Spar () writeState uid accessTimes managedBy storedUser = do when (isNothing accessTimes) $ do wrapMonadClient $ Data.writeScimUserTimes storedUser @@ -619,7 +608,7 @@ synthesizeStoredUser usr = do createdAt lastUpdatedAt baseuri - lift $ writeState (BrigTypes.userId usr) accessTimes (BrigTypes.userManagedBy usr) storedUser + lift $ writeState (BT.userId usr) accessTimes (BT.userManagedBy usr) storedUser pure storedUser synthesizeStoredUser' :: @@ -627,40 +616,39 @@ synthesizeStoredUser' :: Maybe SAML.UserRef -> Name -> Handle -> - RichInfo -> + RI.RichInfo -> AccountStatus -> UTCTimeMillis -> UTCTimeMillis -> URIBS.URI -> - MonadError Scim.ScimError m => m (Scim.StoredUser SparTag) + MonadError Scim.ScimError m => m (Scim.StoredUser ST.SparTag) synthesizeStoredUser' uid ssoid dname handle richInfo accStatus createdAt lastUpdatedAt baseuri = do sso <- do let err = throwError $ Scim.notFound "User" (cs $ show uid) -- See https://github.com/zinfra/backend-issues/issues/1365 maybe err pure ssoid - let scimUser :: Scim.User SparTag + let scimUser :: Scim.User ST.SparTag scimUser = synthesizeScimUser - ValidScimUser - { _vsuUserRef = sso, - _vsuHandle = handle, -- 'Maybe' there is one in @usr@, but we want to type checker to make sure this exists. - _vsuName = Just dname, - _vsuRichInfo = richInfo, - _vsuActive = scimActiveFlagFromAccountStatus accStatus + ST.ValidScimUser + { ST._vsuUserRef = sso, + ST._vsuHandle = handle, -- 'Maybe' there is one in @usr@, but we want to type checker to make sure this exists. + ST._vsuName = dname, + ST._vsuRichInfo = richInfo, + ST._vsuActive = ST.scimActiveFlagFromAccountStatus accStatus } pure $ toScimStoredUser' createdAt lastUpdatedAt baseuri uid scimUser -synthesizeScimUser :: ValidScimUser -> Scim.User SparTag +synthesizeScimUser :: ST.ValidScimUser -> Scim.User ST.SparTag synthesizeScimUser info = - let Handle userName = info ^. vsuHandle - mDisplayName = fromName <$> (info ^. vsuName) + let Handle userName = info ^. ST.vsuHandle toExternalId' :: SAML.UserRef -> Maybe Text toExternalId' = either (const Nothing) Just . Brig.toExternalId . Brig.toUserSSOId - in (Scim.empty userSchemas userName (ScimUserExtra (info ^. vsuRichInfo))) - { Scim.externalId = toExternalId' $ info ^. vsuUserRef, - Scim.displayName = mDisplayName, - Scim.active = Just $ info ^. vsuActive + in (Scim.empty ST.userSchemas userName (ST.ScimUserExtra (info ^. ST.vsuRichInfo))) + { Scim.externalId = toExternalId' $ info ^. ST.vsuUserRef, + Scim.displayName = Just $ fromName (info ^. ST.vsuName), + Scim.active = Just $ info ^. ST.vsuActive } {- TODO: might be useful later. diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 10ad6ab4513..30a95b1e4e1 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -237,8 +237,8 @@ specFinalizeLogin = do . expect2xx ) liftIO $ threadDelay 100000 -- make sure deletion is done. if we don't want to take - -- the time, we should find another way to robustly - -- confirm that deletion has compelted in the background. + -- the time, we should find another way to robustly + -- confirm that deletion has compelted in the background. -- second login do @@ -288,7 +288,7 @@ specFinalizeLogin = do statusCode sparresp `shouldBe` 404 -- body should contain the error label in the title, the verbatim haskell error, and the request: (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:not-found" - (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "CustomError SparNotFound" + (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "CustomError SparIdPNotFound" (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "Input {iName = \"SAMLResponse\"" -- TODO(arianvp): Ask Matthias what this even means context "AuthnResponse does not match any request" $ do @@ -501,9 +501,6 @@ specBindingUsers = describe "binding existing users to sso identities" $ do context "with bind cookie and two other cookies in the request" $ do check (\bindcky -> Just . addAtEnd cky1 . addAtEnd cky2 . addAtBeginning cky3 $ bindcky) True -checkErr :: HasCallStack => (Int -> Bool) -> TestErrorLabel -> ResponseLBS -> Bool -checkErr statusIs label resp = statusIs (statusCode resp) && responseJsonEither resp == Right label - testGetPutDelete :: HasCallStack => (SparReq -> Maybe UserId -> IdPId -> IdPMetadataInfo -> Http ResponseLBS) -> SpecWith TestEnv testGetPutDelete whichone = do context "unknown IdP" $ do @@ -511,20 +508,20 @@ testGetPutDelete whichone = do env <- ask (_, _, _, (idpmeta, _)) <- registerTestIdPWithMeta whichone (env ^. teSpar) Nothing (IdPId UUID.nil) idpmeta - `shouldRespondWith` checkErr (== 404) "not-found" + `shouldRespondWith` checkErrHspec 404 "not-found" context "no zuser" $ do it "responds with 'client error'" $ do env <- ask (_, _, (^. idpId) -> idpid, (idpmeta, _)) <- registerTestIdPWithMeta whichone (env ^. teSpar) Nothing idpid idpmeta - `shouldRespondWith` checkErr (== 400) "client-error" + `shouldRespondWith` checkErrHspec 400 "client-error" context "zuser has no team" $ do it "responds with 'no team member'" $ do env <- ask (_, _, (^. idpId) -> idpid, (idpmeta, _)) <- registerTestIdPWithMeta (uid, _) <- call $ createRandomPhoneUser (env ^. teBrig) whichone (env ^. teSpar) (Just uid) idpid idpmeta - `shouldRespondWith` checkErr (== 403) "no-team-member" + `shouldRespondWith` checkErrHspec 403 "no-team-member" context "zuser is a team member, but not a team owner" $ do it "responds with 'insufficient-permissions' and a helpful message" $ do env <- ask @@ -533,7 +530,7 @@ testGetPutDelete whichone = do let Just perms = Galley.newPermissions mempty mempty in call $ createTeamMember (env ^. teBrig) (env ^. teGalley) teamid perms whichone (env ^. teSpar) (Just newmember) idpid idpmeta - `shouldRespondWith` checkErr (== 403) "insufficient-permissions" + `shouldRespondWith` checkErrHspec 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 @@ -559,7 +556,7 @@ specCRUDIdentityProvider = do (_, _, (^. idpId) -> idpid) <- registerTestIdP (uid, _) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) callIdpGet' (env ^. teSpar) (Just uid) idpid - `shouldRespondWith` checkErr (== 403) "no-team-member" + `shouldRespondWith` checkErrHspec 403 "no-team-member" context "known IdP, client is team owner" $ do it "responds with 2xx and IdP" $ do env <- ask @@ -581,7 +578,7 @@ specCRUDIdentityProvider = do let Just perms = Galley.newPermissions mempty mempty in call $ createTeamMember (env ^. teBrig) (env ^. teGalley) teamid perms callIdpGetAll' (env ^. teSpar) (Just member) - `shouldRespondWith` checkErr (== 403) "insufficient-permissions" + `shouldRespondWith` checkErrHspec 403 "insufficient-permissions" context "no idps registered" $ do context "client is team owner" $ do it "returns an empty list" $ do @@ -614,7 +611,7 @@ specCRUDIdentityProvider = do (_, _, (^. idpId) -> idpid) <- registerTestIdP (uid, _) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) callIdpDelete' (env ^. teSpar) (Just uid) idpid - `shouldRespondWith` checkErr (== 403) "no-team-member" + `shouldRespondWith` checkErrHspec 403 "no-team-member" context "known IdP, IdP empty, client is team owner, without email" $ do it "responds with 2xx and removes IdP" $ do env <- ask @@ -622,16 +619,16 @@ specCRUDIdentityProvider = do callIdpDelete' (env ^. teSpar) (Just userid) idpid `shouldRespondWith` \resp -> statusCode resp < 300 callIdpGet' (env ^. teSpar) (Just userid) idpid - `shouldRespondWith` checkErr (== 404) "not-found" + `shouldRespondWith` checkErrHspec 404 "not-found" callIdpGetRaw' (env ^. teSpar) (Just userid) idpid - `shouldRespondWith` checkErr (== 404) "not-found" + `shouldRespondWith` checkErrHspec 404 "not-found" context "with email, idp non-empty, purge=false" $ do it "responds with 412 and does not remove IdP" $ do env <- ask (firstOwner, tid, idp, (_, privcreds)) <- registerTestIdPWithMeta ssoOwner <- mkSsoOwner firstOwner tid idp privcreds callIdpDelete' (env ^. teSpar) (Just ssoOwner) (idp ^. idpId) - `shouldRespondWith` checkErr (== 412) "idp-has-bound-users" + `shouldRespondWith` checkErrHspec 412 "idp-has-bound-users" callIdpGet' (env ^. teSpar) (Just ssoOwner) (idp ^. idpId) `shouldRespondWith` \resp -> statusCode resp < 300 context "with email, idp non-empty, purge=true" $ do @@ -648,7 +645,7 @@ specCRUDIdentityProvider = do ssoOwner' `shouldBe` Nothing firstOwner' `shouldBe` Just firstOwner callIdpGet' (env ^. teSpar) (Just firstOwner) (idp ^. idpId) - `shouldRespondWith` checkErr (== 404) "not-found" + `shouldRespondWith` checkErrHspec 404 "not-found" describe "PUT /identity-providers/:idp" $ do testGetPutDelete callIdpUpdate' context "known IdP, client is team owner" $ do @@ -667,14 +664,14 @@ specCRUDIdentityProvider = do env <- ask (owner, _, (^. idpId) -> idpid) <- registerTestIdP callIdpUpdate' (env ^. teSpar) (Just owner) idpid (IdPMetadataValue "bloo" undefined) - `shouldRespondWith` ((== 400) . statusCode) + `shouldRespondWith` checkErrHspec 400 "invalid-metadata" describe "issuer changed to one that already exists in *another* team" $ do it "rejects" $ do env <- ask (owner1, _, (^. idpId) -> idpid1) <- registerTestIdP (_, _, _, (IdPMetadataValue _ idpmeta2, _)) <- registerTestIdPWithMeta callIdpUpdate' (env ^. teSpar) (Just owner1) idpid1 (IdPMetadataValue (cs $ SAML.encode idpmeta2) undefined) - `shouldRespondWith` checkErr (== 400) "idp-issuer-in-use" + `shouldRespondWith` checkErrHspec 400 "idp-issuer-in-use" describe "issuer changed to one that already exists in *the same* team" $ do it "rejects" $ do env <- ask @@ -683,7 +680,7 @@ specCRUDIdentityProvider = do _ <- call $ callIdpCreate (env ^. teSpar) (Just owner1) idpmeta2 let idpmeta3 = idpmeta1 & edIssuer .~ (idpmeta2 ^. edIssuer) callIdpUpdate' (env ^. teSpar) (Just owner1) idpid1 (IdPMetadataValue (cs $ SAML.encode idpmeta3) undefined) - `shouldRespondWith` checkErr (== 400) "idp-issuer-in-use" + `shouldRespondWith` checkErrHspec 400 "idp-issuer-in-use" describe "issuer changed to one that is new" $ do it "updates old idp, updating both issuer and old_issuers" $ do env <- ask @@ -797,25 +794,25 @@ specCRUDIdentityProvider = do (uid, _tid) <- call $ createUserWithTeamDisableSSO (env ^. teBrig) (env ^. teGalley) (SampleIdP metadata _ _ _) <- makeSampleIdPMetadata callIdpCreate' (env ^. teSpar) (Just uid) metadata - `shouldRespondWith` checkErr (== 403) "sso-disabled" + `shouldRespondWith` checkErrHspec 403 "sso-disabled" context "bad xml" $ do it "responds with a 'client error'" $ do env <- ask callIdpCreateRaw' (env ^. teSpar) Nothing "application/xml" "@@ bad xml ###" - `shouldRespondWith` checkErr (== 400) "invalid-metadata" + `shouldRespondWith` checkErrHspec 400 "invalid-metadata" context "no zuser" $ do it "responds with 'client error'" $ do env <- ask (SampleIdP idpmeta _ _ _) <- makeSampleIdPMetadata callIdpCreate' (env ^. teSpar) Nothing idpmeta - `shouldRespondWith` checkErr (== 400) "client-error" + `shouldRespondWith` checkErrHspec 400 "client-error" context "zuser has no team" $ do it "responds with 'no team member'" $ do env <- ask (uid, _) <- call $ createRandomPhoneUser (env ^. teBrig) (SampleIdP idpmeta _ _ _) <- makeSampleIdPMetadata callIdpCreate' (env ^. teSpar) (Just uid) idpmeta - `shouldRespondWith` checkErr (== 403) "no-team-member" + `shouldRespondWith` checkErrHspec 403 "no-team-member" context "zuser is a team member, but not a team owner" $ do it "responds with 'insufficient-permissions' and a helpful message" $ do env <- ask @@ -824,7 +821,7 @@ specCRUDIdentityProvider = do let Just perms = Galley.newPermissions mempty mempty in call $ createTeamMember (env ^. teBrig) (env ^. teGalley) tid perms callIdpCreate' (env ^. teSpar) (Just newmember) (idp ^. idpMetadata) - `shouldRespondWith` checkErr (== 403) "insufficient-permissions" + `shouldRespondWith` checkErrHspec 403 "insufficient-permissions" context "idp (identified by issuer) is in use by other team" $ do it "rejects" $ do env <- ask @@ -860,7 +857,7 @@ specCRUDIdentityProvider = do it "responds with a 'client error'" $ do env <- ask callIdpCreateRaw' (env ^. teSpar) Nothing "application/json" "@@ bad json ###" - `shouldRespondWith` checkErr (== 400) "invalid-metadata" + `shouldRespondWith` checkErrHspec 400 "invalid-metadata" context "good json" $ do it "responds with 2xx; makes IdP available for GET /identity-providers/" $ do env <- ask @@ -1015,10 +1012,10 @@ specDeleteCornerCases = describe "delete corner cases" $ do samlUserShouldSatisfy uref isJust deleteViaBrig uid samlUserShouldSatisfy uref isJust -- brig doesn't talk to spar right now when users - -- are deleted there. we need to work around this - -- fact for now. (if the test fails here, this may - -- mean that you fixed the behavior and can - -- change this to 'isNothing'.) + -- are deleted there. we need to work around this + -- fact for now. (if the test fails here, this may + -- mean that you fixed the behavior and can + -- change this to 'isNothing'.) (Just _) <- createViaSaml idp privcreds uref samlUserShouldSatisfy uref isJust where diff --git a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs index 909a13f4518..f4326721243 100644 --- a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs @@ -276,10 +276,3 @@ testAuthIsNeeded = do -- Try to do @GET /Users@ without a token and check that it fails listUsers_ Nothing Nothing (env ^. teSpar) !!! checkErr 401 Nothing - -checkErr :: HasCallStack => Int -> Maybe TestErrorLabel -> Assertions () -checkErr status mlabel = do - const status === statusCode - case mlabel of - Nothing -> pure () - Just label -> const (Right label) === responseJsonEither diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 3370899fcd0..3ac97e9a351 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -34,12 +34,11 @@ import Control.Lens import Control.Monad.Catch (MonadCatch) import Control.Retry (exponentialBackoff, limitRetries, recovering) import qualified Data.Aeson as Aeson -import Data.Aeson.Lens (_String, key) +import Data.Aeson.Lens (key, _String) import Data.Aeson.QQ (aesonQQ) import Data.Aeson.Types (fromJSON, toJSON) import Data.ByteString.Conversion -import Data.Handle (Handle (Handle)) -import Data.Handle (fromHandle) +import Data.Handle (Handle (Handle), fromHandle) import Data.Id (TeamId, UserId, randomId) import Data.Ix (inRange) import Data.String.Conversions (cs) @@ -50,8 +49,8 @@ import qualified SAML2.WebSSO.Types as SAML import qualified Spar.Data as Data import qualified Spar.Intra.Brig as Intra import Spar.Scim -import qualified Spar.Types import Spar.Types (IdP) +import qualified Spar.Types import qualified Text.XML.DSig as SAML import Util import qualified Web.Scim.Class.User as Scim.UserC @@ -129,7 +128,7 @@ specSuspend = do void $ aFewTimes (runSpar $ Intra.getStatus uid) (== Active) it "PUT will change state from active to inactive and back" $ do - void $ activeInactiveAndBack $ \tok uid user active -> + void . activeInactiveAndBack $ \tok uid user active -> updateUser tok uid user {Scim.User.active = Just active} it "PATCH will change state from active to inactive and back" $ do @@ -138,7 +137,7 @@ specSuspend = do PatchOp.Replace (Just (PatchOp.NormalPath (Filter.topLevelAttrPath name))) (Just (toJSON value)) - void $ activeInactiveAndBack $ \tok uid _user active -> + void . activeInactiveAndBack $ \tok uid _user active -> patchUser tok uid $ PatchOp.PatchOp [replaceAttrib "active" active] -- Consider the following series of events: @@ -416,10 +415,10 @@ testScimCreateVsUserRef = do samlUserShouldSatisfy uref isJust deleteViaBrig uid samlUserShouldSatisfy uref isJust -- brig doesn't talk to spar right now when users - -- are deleted there. we need to work around this - -- fact for now. (if the test fails here, this may - -- mean that you fixed the behavior and can - -- change this to 'isNothing'.) + -- are deleted there. we need to work around this + -- fact for now. (if the test fails here, this may + -- mean that you fixed the behavior and can + -- change this to 'isNothing'.) tok <- registerScimToken teamid (Just (idp ^. SAML.idpId)) storedusr :: Scim.UserC.StoredUser SparTag <- do @@ -844,11 +843,12 @@ testUpdateSameHandle = do let userid = scimUserId storedUser -- Overwrite the user with another randomly-generated user who has the same name and -- handle - user' <- randomScimUser <&> \u -> - u - { Scim.User.userName = Scim.User.userName user, - Scim.User.displayName = Scim.User.displayName user - } + user' <- + randomScimUser <&> \u -> + u + { Scim.User.userName = Scim.User.userName user, + Scim.User.displayName = Scim.User.displayName user + } updatedUser <- updateUser tok userid user' -- Get the updated user and check that it matches the user returned by 'updateUser' storedUser' <- getUser tok userid @@ -1189,7 +1189,7 @@ specEmailValidation = do let req = put $ galley . paths p . json (Feature.TeamFeatureStatus Feature.TeamFeatureEnabled) p = ["/i/teams", toByteString' tid, "features", "validate-saml-emails"] call req !!! const 204 === statusCode - -- + assertEmail :: HasCallStack => UserId -> Maybe Email -> TestSpar () assertEmail uid expectedEmail = do brig <- asks (^. teBrig) @@ -1197,10 +1197,10 @@ specEmailValidation = do call req !!! do const 200 === statusCode const expectedEmail === (userEmail <=< responseJsonMaybe) - -- + eventually :: HasCallStack => TestSpar a -> TestSpar a eventually = recovering (limitRetries 3 <> exponentialBackoff 100000) [] . const - -- + setup :: HasCallStack => Bool -> TestSpar (UserId, Email) setup enabled = do (tok, (_ownerid, teamid, idp)) <- registerIdPAndScimToken @@ -1212,7 +1212,7 @@ specEmailValidation = do brig <- asks (^. teBrig) call $ activateEmail brig email pure (uid, email) - -- + -- copied from brig integration tests. activateEmail :: HasCallStack => @@ -1223,11 +1223,12 @@ specEmailValidation = do act <- getActivationCode brig (Left email) case act of Nothing -> pure () -- missing activation key/code; this happens if the feature is - -- disabled (second test case below) - Just kc -> activate brig kc !!! do - const 200 === statusCode - const (Just False) === fmap Activation.activatedFirst . responseJsonMaybe - -- + -- disabled (second test case below) + Just kc -> + activate brig kc !!! do + const 200 === statusCode + const (Just False) === fmap Activation.activatedFirst . responseJsonMaybe + -- copied from brig integration tests. getActivationCode :: HasCallStack => @@ -1241,7 +1242,7 @@ specEmailValidation = do let akey = Activation.ActivationKey . Ascii.unsafeFromText <$> (lbs ^? key "key" . _String) let acode = Activation.ActivationCode . Ascii.unsafeFromText <$> (lbs ^? key "code" . _String) return $ (,) <$> akey <*> acode - -- + -- copied from brig integration tests. activate :: HasCallStack => diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 1b98b0fc4c4..e3669d33953 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -117,11 +117,13 @@ module Util.Core callGetDefaultSsoCode, callSetDefaultSsoCode, callDeleteDefaultSsoCode, + checkErr, + checkErrHspec, ) where import Bilge hiding (getCookie) -- we use Web.Cookie instead of the http-client type -import Bilge.Assert ((!!!), ( randomRIO (0 :: Int, 13371137) -- | Generate a 'SAML.UserRef' subject. nextSubject :: (HasCallStack, MonadIO m) => m NameID nextSubject = liftIO $ do - unameId <- randomRIO (0, 1 :: Int) >>= \case - 0 -> either (error . show) id . SAML.mkUNameIDEmail . Brig.fromEmail <$> randomEmail - 1 -> SAML.mkUNameIDUnspecified . UUID.toText <$> UUID.nextRandom - _ -> error "nextSubject: impossible" + unameId <- + randomRIO (0, 1 :: Int) >>= \case + 0 -> either (error . show) id . SAML.mkUNameIDEmail . Brig.fromEmail <$> randomEmail + 1 -> SAML.mkUNameIDUnspecified . UUID.toText <$> UUID.nextRandom + _ -> error "nextSubject: impossible" either (error . show) pure $ SAML.mkNameID unameId Nothing Nothing Nothing nextUserRef :: MonadIO m => m SAML.UserRef @@ -774,9 +777,9 @@ getCookie proxy rsp = do hasPersistentCookieHeader :: ResponseLBS -> Either String () hasPersistentCookieHeader rsp = do cky <- getCookie (Proxy @"zuid") rsp - when (isNothing . Web.setCookieExpires $ fromSimpleSetCookie cky) - $ Left - $ "expiration date should NOT empty: " <> show cky + when (isNothing . Web.setCookieExpires $ fromSimpleSetCookie cky) $ + Left $ + "expiration date should NOT empty: " <> show cky -- | A bind cookie is always sent, but if we do not want to send one, it looks like this: -- "wire.com=; Path=/sso/finalize-login; Expires=Thu, 01-Jan-1970 00:00:00 GMT; Max-Age=-1; Secure" @@ -833,10 +836,11 @@ negotiateAuthnRequest :: (HasCallStack, MonadIO m, MonadReader TestEnv m) => IdP -> m SAML.AuthnRequest -negotiateAuthnRequest idp = negotiateAuthnRequest' DoInitiateLogin idp id >>= \case - (req, cky) -> case maybe (Left "missing") isDeleteBindCookie cky of - Right () -> pure req - Left msg -> error $ "unexpected bind cookie: " <> show (cky, msg) +negotiateAuthnRequest idp = + negotiateAuthnRequest' DoInitiateLogin idp id >>= \case + (req, cky) -> case maybe (Left "missing") isDeleteBindCookie cky of + Right () -> pure req + Left msg -> error $ "unexpected bind cookie: " <> show (cky, msg) doInitiatePath :: DoInitiate -> [ST] doInitiatePath DoInitiateLogin = ["sso", "initiate-login"] @@ -1158,3 +1162,22 @@ getUserIdViaRef uref = maybe (error "not found") pure =<< getUserIdViaRef' uref getUserIdViaRef' :: HasCallStack => UserRef -> TestSpar (Maybe UserId) getUserIdViaRef' uref = do aFewTimes (runSparCass $ Data.getSAMLUser uref) isJust + +checkErr :: HasCallStack => Int -> Maybe TestErrorLabel -> Assertions () +checkErr status mlabel = do + const status === statusCode + case mlabel of + Nothing -> pure () + Just label -> const (Right label) === responseJsonEither + +checkErrHspec :: HasCallStack => Int -> TestErrorLabel -> ResponseLBS -> Bool +checkErrHspec status label resp = status == statusCode resp && responseJsonEither resp == Right label + +-- | copied from brig integration tests +stdInvitationRequest :: User.Email -> TeamInvitation.InvitationRequest +stdInvitationRequest = stdInvitationRequest' Nothing Nothing + +-- | copied from brig integration tests +stdInvitationRequest' :: Maybe User.Locale -> Maybe Galley.Role -> User.Email -> TeamInvitation.InvitationRequest +stdInvitationRequest' loc role email = + TeamInvitation.InvitationRequest loc role Nothing email Nothing diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index 7891181b40b..da87c4243c2 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -78,9 +78,10 @@ registerIdPAndScimTokenWithMeta = do registerScimToken :: HasCallStack => TeamId -> Maybe IdPId -> TestSpar ScimToken registerScimToken teamid midpid = do env <- ask - tok <- ScimToken <$> do - code <- liftIO UUID.nextRandom - pure $ "scim-test-token/" <> "team=" <> idToText teamid <> "/code=" <> UUID.toText code + tok <- + ScimToken <$> do + code <- liftIO UUID.nextRandom + pure $ "scim-test-token/" <> "team=" <> idToText teamid <> "/code=" <> UUID.toText code scimTokenId <- randomId now <- liftIO getCurrentTime runClient (env ^. teCql) $ @@ -121,17 +122,18 @@ randomScimUserWithSubjectAndRichInfo richInfo = do emails <- getRandomR (0, 3) >>= \n -> replicateM n randomScimEmail phones <- getRandomR (0, 3) >>= \n -> replicateM n randomScimPhone -- Related, but non-trivial to re-use here: 'nextSubject' - (externalId, subj) <- getRandomR (0, 1 :: Int) <&> \case - 0 -> - ( "scimuser_extid_" <> suffix <> "@example.com", - either (error . show) id $ - SAML.mkUNameIDEmail ("scimuser_extid_" <> suffix <> "@example.com") - ) - 1 -> - ( "scimuser_extid_" <> suffix, - SAML.mkUNameIDUnspecified ("scimuser_extid_" <> suffix) - ) - _ -> error "randomScimUserWithSubject: impossible" + (externalId, subj) <- + getRandomR (0, 1 :: Int) <&> \case + 0 -> + ( "scimuser_extid_" <> suffix <> "@example.com", + either (error . show) id $ + SAML.mkUNameIDEmail ("scimuser_extid_" <> suffix <> "@example.com") + ) + 1 -> + ( "scimuser_extid_" <> suffix, + SAML.mkUNameIDUnspecified ("scimuser_extid_" <> suffix) + ) + _ -> error "randomScimUserWithSubject: impossible" pure ( (Scim.User.empty userSchemas ("scimuser_" <> suffix) (ScimUserExtra richInfo)) { Scim.User.displayName = Just ("Scim User #" <> suffix), @@ -159,7 +161,7 @@ randomScimEmail :: MonadRandom m => m Email.Email randomScimEmail = do let typ :: Maybe Text = Nothing primary :: Maybe Bool = Nothing -- TODO: where should we catch users with more than one - -- primary email? + -- primary email? value :: Email.EmailAddress2 <- do localpart <- cs <$> replicateM 15 (getRandomR ('a', 'z')) domainpart <- (<> ".com") . cs <$> replicateM 15 (getRandomR ('a', 'z')) @@ -528,6 +530,10 @@ scimUserId = Scim.id . Scim.thing -- -- Note: we don't compare rich info here, because 'User' doesn't contain it. However, we have -- separate tests for rich info that cover that. +-- +-- FUTUREWORK: tenant, subject, subjectraw are not scim concepts, we should use the +-- corresponding scim terminology for that. subjectraw is externalId; the other two don't +-- have exact correspondences. perhaps they can be removed? or changed to fit scim better? class IsUser u where maybeUserId :: Maybe (u -> UserId) maybeHandle :: Maybe (u -> Maybe Handle) @@ -546,7 +552,7 @@ class IsUser u where instance IsUser ValidScimUser where maybeUserId = Nothing maybeHandle = Just (Just . view vsuHandle) - maybeName = Just (view vsuName) + maybeName = Just (Just . view vsuName) maybeTenant = Just (Just . view (vsuUserRef . SAML.uidTenant)) maybeSubject = Just (Just . view (vsuUserRef . SAML.uidSubject)) maybeSubjectRaw = Just (SAML.shortShowNameID . view (vsuUserRef . SAML.uidSubject)) diff --git a/services/spar/test-integration/Util/Types.hs b/services/spar/test-integration/Util/Types.hs index 66ba4e80da7..de0b9c50e55 100644 --- a/services/spar/test-integration/Util/Types.hs +++ b/services/spar/test-integration/Util/Types.hs @@ -104,6 +104,6 @@ _unitTestTestErrorLabel :: IO () _unitTestTestErrorLabel = do let val :: Either String TestErrorLabel val = Aeson.eitherDecode "{\"code\":404,\"message\":\"Not found.\",\"label\":\"not-found\"}" - unless (val == Right "not-found") - $ throwIO . ErrorCall . show - $ val + unless (val == Right "not-found") $ + throwIO . ErrorCall . show $ + val diff --git a/services/spar/test/Test/Spar/APISpec.hs b/services/spar/test/Test/Spar/APISpec.hs index ea483b4aa81..321bb4dd760 100644 --- a/services/spar/test/Test/Spar/APISpec.hs +++ b/services/spar/test/Test/Spar/APISpec.hs @@ -45,12 +45,12 @@ spec = do let withoutRaw (IdPMetadataValue _ x) = x (withoutRaw <$> (Aeson.eitherDecode . Aeson.encode) val) `shouldBe` Right (withoutRaw val) describe "SsoSettings JSON instance" $ do - it "always has and requires the field default_sso_code" - $ property - $ \(ssoSettings :: SsoSettings) -> do - let object = Aeson.toJSON ssoSettings - let objectWithoutKey = Lens.over Aeson._Object (HM.delete "default_sso_code") $ object - (HM.lookup "default_sso_code" =<< Lens.preview Aeson._Object object) - `shouldSatisfy` isJust - Aeson.parseMaybe (Aeson.parseJSON @SsoSettings) objectWithoutKey - `shouldSatisfy` isNothing + it "always has and requires the field default_sso_code" $ + property $ + \(ssoSettings :: SsoSettings) -> do + let object = Aeson.toJSON ssoSettings + let objectWithoutKey = Lens.over Aeson._Object (HM.delete "default_sso_code") $ object + (HM.lookup "default_sso_code" =<< Lens.preview Aeson._Object object) + `shouldSatisfy` isJust + Aeson.parseMaybe (Aeson.parseJSON @SsoSettings) objectWithoutKey + `shouldSatisfy` isNothing diff --git a/stack.yaml b/stack.yaml index e4b80a6b2f4..d417313b894 100644 --- a/stack.yaml +++ b/stack.yaml @@ -8,7 +8,7 @@ packages: - libs/cargohold-types - libs/cassandra-util - libs/extended -- libs/federation-util +- libs/dns-util - libs/galley-types - libs/gundeck-types - libs/hscim @@ -24,6 +24,7 @@ packages: - libs/types-common-journal - libs/wai-utilities - libs/wire-api +- libs/wire-api-federation - libs/zauth - services/brig - services/cannon @@ -170,11 +171,14 @@ extra-deps: - QuickCheck-2.14 - splitmix-0.0.4 # needed for QuickCheck +# Newer than the one one stackage +- polysemy-1.3.0.0 + ############################################################ # Development tools ############################################################ -- ormolu-0.0.5.0 -- ghc-lib-parser-8.10.1.20200412@sha256:b0517bb150a02957d7180f131f5b94abd2a7f58a7d1532a012e71618282339c2,8751 # for ormolu-0.0.5.0 +- ormolu-0.1.2.0 +- ghc-lib-parser-8.10.1.20200412@sha256:b0517bb150a02957d7180f131f5b94abd2a7f58a7d1532a012e71618282339c2,8751 # for ormolu-0.1.2.0 - headroom-0.2.1.0 diff --git a/stack.yaml.lock b/stack.yaml.lock index 0fea55f66bc..1d2d2035253 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -13,9 +13,6 @@ packages: hackage: swagger2-2.4 - completed: subdir: wai-middleware-prometheus - cabal-file: - size: 1314 - sha256: 1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4 name: wai-middleware-prometheus version: 1.0.0 git: https://github.com/fimad/prometheus-haskell @@ -28,9 +25,6 @@ packages: git: https://github.com/fimad/prometheus-haskell commit: 2e3282e5fb27ba8d989c271a0a989823fad7ec43 - completed: - cabal-file: - size: 8392 - sha256: 2c5d7f46633fb414eeb43facfe1018378f001b8b67dd77a45d110db84e46034c name: saml2-web-sso version: '0.18' git: https://github.com/wireapp/saml2-web-sso @@ -42,9 +36,6 @@ packages: git: https://github.com/wireapp/saml2-web-sso commit: 687d9ac8ac2994aff8436189c6ecce29faad8500 - completed: - cabal-file: - size: 912 - sha256: 71d9fd9fd55cfb7b549eb2cecfb5258171be14669f990e4d05c6b3508dd5878b name: collectd version: 0.0.0.2 git: https://github.com/kim/hs-collectd @@ -56,9 +47,6 @@ packages: git: https://github.com/kim/hs-collectd commit: 885da222be2375f78c7be36127620ed772b677c9 - completed: - cabal-file: - size: 1196 - sha256: 1321f0148c87e75202829edac7f375bffa6159dad050b9737403306a493579ba name: snappy-framing version: 0.1.1 git: https://github.com/kim/snappy-framing @@ -70,9 +58,6 @@ packages: git: https://github.com/kim/snappy-framing commit: d99f702c0086729efd6848dea8a01e5266c3a61c - completed: - cabal-file: - size: 3722 - sha256: 1509c11cbcc23595f4b9503bac28df4b10cc870cd7869f1859d43a373476d5a8 name: wai-routing version: 0.13.0 git: https://gitlab.com/twittner/wai-routing @@ -84,9 +69,6 @@ packages: git: https://gitlab.com/twittner/wai-routing commit: 7e996a93fec5901767f845a50316b3c18e51a61d - completed: - cabal-file: - size: 2490 - sha256: 7cca808c05cb584f1d4c6f60893bd28b0de41f450135bf48b70414a1f547d31f name: multihash version: 0.1.6 git: https://github.com/wireapp/haskell-multihash.git @@ -98,9 +80,6 @@ packages: git: https://github.com/wireapp/haskell-multihash.git commit: 300a6f46384bfca33e545c8bab52ef3717452d12 - completed: - cabal-file: - size: 2289 - sha256: 07c1e684acf4ba1c097fe5dd2525cb887269f7d3335c42783c1f4d2bfdc01283 name: hspec-wai version: 0.9.2 git: https://github.com/wireapp/hspec-wai @@ -112,9 +91,6 @@ packages: git: https://github.com/wireapp/hspec-wai commit: 0a5142cd3ba48116ff059c041348b817fb7bdb25 - completed: - cabal-file: - size: 3403 - sha256: 2fd9aef25802bf62848b7087a9476264b50bc7d9f195c7f0012e52d19ed2ebe3 name: bloodhound version: 0.17.0.0 git: https://github.com/wireapp/bloodhound @@ -143,9 +119,6 @@ packages: size: 11138812 subdir: amazonka url: https://github.com/wireapp/amazonka/archive/9de5e0e4b2511ec555fb0975581b3087a94c1b4a.tar.gz - cabal-file: - size: 3457 - sha256: 7ac360751e371ba853f56d357e861c5fe103b1da17f045ac47fd285c164a37f7 name: amazonka version: 1.6.1 sha256: b9277a51b60d639fbd91b630f353bf9db305f5759f8e1ee48f0ab026e6b43d00 @@ -161,9 +134,6 @@ packages: size: 11138812 subdir: amazonka-cloudfront url: https://github.com/wireapp/amazonka/archive/9de5e0e4b2511ec555fb0975581b3087a94c1b4a.tar.gz - cabal-file: - size: 5668 - sha256: 79c95e0ec544437a613cab891a2057bc35f1b0fed2361b36e7f05437839bdce2 name: amazonka-cloudfront version: 1.6.1 sha256: b9277a51b60d639fbd91b630f353bf9db305f5759f8e1ee48f0ab026e6b43d00 @@ -179,9 +149,6 @@ packages: size: 11138812 subdir: amazonka-dynamodb url: https://github.com/wireapp/amazonka/archive/9de5e0e4b2511ec555fb0975581b3087a94c1b4a.tar.gz - cabal-file: - size: 4459 - sha256: 6b8852049c65207a7b3741aafa3e4e6c77cfa115e05de3c74868218ae642b6b0 name: amazonka-dynamodb version: 1.6.1 sha256: b9277a51b60d639fbd91b630f353bf9db305f5759f8e1ee48f0ab026e6b43d00 @@ -197,9 +164,6 @@ packages: size: 11138812 subdir: amazonka-s3 url: https://github.com/wireapp/amazonka/archive/9de5e0e4b2511ec555fb0975581b3087a94c1b4a.tar.gz - cabal-file: - size: 6317 - sha256: 9d07240fca59ad5197fb614ce3051e701e4951e6d4625a2dab4a9c17a1900194 name: amazonka-s3 version: 1.6.1 sha256: b9277a51b60d639fbd91b630f353bf9db305f5759f8e1ee48f0ab026e6b43d00 @@ -215,9 +179,6 @@ packages: size: 11138812 subdir: amazonka-ses url: https://github.com/wireapp/amazonka/archive/9de5e0e4b2511ec555fb0975581b3087a94c1b4a.tar.gz - cabal-file: - size: 6425 - sha256: 335796c855121ca34affd35097676587d5ebe0b2e576da42faaedd9d163881b0 name: amazonka-ses version: 1.6.1 sha256: b9277a51b60d639fbd91b630f353bf9db305f5759f8e1ee48f0ab026e6b43d00 @@ -233,9 +194,6 @@ packages: size: 11138812 subdir: amazonka-sns url: https://github.com/wireapp/amazonka/archive/9de5e0e4b2511ec555fb0975581b3087a94c1b4a.tar.gz - cabal-file: - size: 4271 - sha256: b07fbf8a2806fe775b25ea74d0d78f14f286811e4aa59f9c50e97ed99f2a14a6 name: amazonka-sns version: 1.6.1 sha256: b9277a51b60d639fbd91b630f353bf9db305f5759f8e1ee48f0ab026e6b43d00 @@ -251,9 +209,6 @@ packages: size: 11138812 subdir: amazonka-sqs url: https://github.com/wireapp/amazonka/archive/9de5e0e4b2511ec555fb0975581b3087a94c1b4a.tar.gz - cabal-file: - size: 3708 - sha256: 1578844a31a2e53f9f21fd217e14406a3f02aefa637678ef88b201b01fbed492 name: amazonka-sqs version: 1.6.1 sha256: b9277a51b60d639fbd91b630f353bf9db305f5759f8e1ee48f0ab026e6b43d00 @@ -269,9 +224,6 @@ packages: size: 11138812 subdir: core url: https://github.com/wireapp/amazonka/archive/9de5e0e4b2511ec555fb0975581b3087a94c1b4a.tar.gz - cabal-file: - size: 4957 - sha256: 8ff9614130407588370e12e905f3539a733b76f6d9397ed3522ce54fc154d918 name: amazonka-core version: 1.6.1 sha256: b9277a51b60d639fbd91b630f353bf9db305f5759f8e1ee48f0ab026e6b43d00 @@ -284,9 +236,6 @@ packages: url: https://github.com/wireapp/amazonka/archive/9de5e0e4b2511ec555fb0975581b3087a94c1b4a.tar.gz sha256: b9277a51b60d639fbd91b630f353bf9db305f5759f8e1ee48f0ab026e6b43d00 - completed: - cabal-file: - size: 1150 - sha256: bbb1a78c1c8a2fe2a7b46a734f3b60754a86e07f07a1a27d781f121831918289 name: cryptobox-haskell version: 0.1.1 git: https://github.com/wireapp/cryptobox-haskell @@ -298,9 +247,6 @@ packages: git: https://github.com/wireapp/cryptobox-haskell commit: 7546a1a25635ef65183e3d44c1052285e8401608 - completed: - cabal-file: - size: 3593 - sha256: 1f822adc38dcba267caa05c4f1405f92c60a340ea17c4fbbf92934e71ccf4809 name: hsaml2 version: '0.1' git: https://github.com/wireapp/hsaml2 @@ -313,9 +259,6 @@ packages: commit: fe08618e81dee9b7a25f10f5b9d26d1ff1837c79 - completed: subdir: http-client - cabal-file: - size: 5350 - sha256: 868faa3479fa330ac6eb897e6888296a32f10a249d2d91ece5ab2add9f0c24d4 name: http-client version: 0.7.0 git: https://github.com/wireapp/http-client @@ -329,9 +272,6 @@ packages: commit: 9100baeddbd15d93dc58a826ae812dafff29d5fd - completed: subdir: http-client-openssl - cabal-file: - size: 1494 - sha256: 423d74b93d5b2a79991340da8d2cd8fccd496fb470483bad8c73857200509e4e name: http-client-openssl version: 0.3.1.0 git: https://github.com/wireapp/http-client @@ -345,9 +285,6 @@ packages: commit: 9100baeddbd15d93dc58a826ae812dafff29d5fd - completed: subdir: http-client-tls - cabal-file: - size: 2041 - sha256: 1043cb22bc772acdc5176b3db88ea74ae299a658d03aa7d4027f970328487f4c name: http-client-tls version: 0.3.5.3 git: https://github.com/wireapp/http-client @@ -361,9 +298,6 @@ packages: commit: 9100baeddbd15d93dc58a826ae812dafff29d5fd - completed: subdir: http-conduit - cabal-file: - size: 2910 - sha256: 4e0024c25cb1a6c5a20b687201c78a7a2c781a582f669d0f88125d113e65c326 name: http-conduit version: 2.3.7.3 git: https://github.com/wireapp/http-client @@ -565,12 +499,19 @@ packages: original: hackage: splitmix-0.0.4 - completed: - hackage: ormolu-0.0.5.0@sha256:e5f49c51c6ebd8b3cd16113e585312de7315c1e1561fbb599988cebc61c14f4e,7956 + hackage: polysemy-1.3.0.0@sha256:fa76e96a883fd1c4bdbad792a0a9d88f59f84817651aea5c71d9b4f74e42c5b6,6141 pantry-tree: - size: 66187 - sha256: fd591a96bb129610f89d23d2986b1b11dad8c1c41e23ea1c6f03340b7265b617 + size: 4309 + sha256: 3d2fb15ddda9053f6bfd4b0810a79a9542505acb5e7e528856ec3cd86d6df066 original: - hackage: ormolu-0.0.5.0 + hackage: polysemy-1.3.0.0 +- completed: + hackage: ormolu-0.1.2.0@sha256:24e6512750576978b6f045c1e53a7aad28ab61960f738a3c74fb0bc2beaf4030,6237 + pantry-tree: + size: 71915 + sha256: 5a857d9bf0e9579ee4daacfb63b4665cdf9e0a0de31d8e0715a27836007e9c42 + original: + hackage: ormolu-0.1.2.0 - completed: hackage: ghc-lib-parser-8.10.1.20200412@sha256:b0517bb150a02957d7180f131f5b94abd2a7f58a7d1532a012e71618282339c2,8751 pantry-tree: diff --git a/tools/api-simulations/loadtest/src/Main.hs b/tools/api-simulations/loadtest/src/Main.hs index 9352e225e0f..bca0c7eb2ae 100644 --- a/tools/api-simulations/loadtest/src/Main.hs +++ b/tools/api-simulations/loadtest/src/Main.hs @@ -92,14 +92,16 @@ ltsSettingsParser = do conversationRamp <- optional $ asum - [ fmap RampStep $ option auto $ - long "ramp-step" - <> metavar "INT" - <> help "delay in microseconds between conversations start", - fmap RampTotal $ option auto $ - long "ramp-total" - <> metavar "INT" - <> help "time in microseconds until full load" + [ fmap RampStep $ + option auto $ + long "ramp-step" + <> metavar "INT" + <> help "delay in microseconds between conversations start", + fmap RampTotal $ + option auto $ + long "ramp-total" + <> metavar "INT" + <> help "time in microseconds until full load" ] conversationsTotal <- option auto $ diff --git a/tools/api-simulations/loadtest/src/Network/Wire/Simulations/LoadTest.hs b/tools/api-simulations/loadtest/src/Network/Wire/Simulations/LoadTest.hs index cbc62c74fb6..f8bbad1cac3 100644 --- a/tools/api-simulations/loadtest/src/Network/Wire/Simulations/LoadTest.hs +++ b/tools/api-simulations/loadtest/src/Network/Wire/Simulations/LoadTest.hs @@ -113,7 +113,7 @@ runConv s g = do Clients.addMembers (botClientSessions client) conv (map botId bots) let removeClients (b, st) = mapM_ (removeBotClient b) (botClient st : botOtherClients st) - void $ flip mapConcurrently (zip bots states) $ \(b, st) -> + void . flip mapConcurrently (zip bots states) $ \(b, st) -> runBotSession b $ do log Info $ msg $ val "Starting bot" runBot s st `Ex.onException` removeClients (b, st) diff --git a/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs b/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs index fe0fa2730c1..720f65b75cd 100644 --- a/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs +++ b/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs @@ -128,15 +128,17 @@ mainBotNet n = do let carlWithTablet = (carl, carlTablet) let people :: [(Bot, ConvId, BotClient)] -- everyone except for Ally people = - (bill, a2b, billPC) : (carl, a2c, carlTablet) - : zip3 goons a2goons goonClients + (bill, a2b, billPC) : + (carl, a2c, carlTablet) : + zip3 goons a2goons goonClients info $ msg (val "OTR 1-1 greetings") -- Ally greets everyone in 1-1 - runBotSession ally $ for_ people $ \(user, conv, _client) -> do - botInitSession (botId user) - Clients.addMembers (botClientSessions allyPhone) conv [botId user] - let message = "Hey " <> unTag (botTag user) <> ", Everything secure?" - postOtrTextMsg allyPhone conv message >>= assertNoClientMismatch + runBotSession ally $ + for_ people $ \(user, conv, _client) -> do + botInitSession (botId user) + Clients.addMembers (botClientSessions allyPhone) conv [botId user] + let message = "Hey " <> unTag (botTag user) <> ", Everything secure?" + postOtrTextMsg allyPhone conv message >>= assertNoClientMismatch -- Everyone answers for_ people $ \(user, conv, client) -> runBotSession user $ do pkm <- awaitOtrMsg conv allyWithPhone (user, client) @@ -148,14 +150,15 @@ mainBotNet n = do Clients.addMembers (botClientSessions client) conv [botId ally] postOtrTextMsg client conv "Thanks Ally, All good." >>= assertNoClientMismatch -- Ally confirms the answers - runBotSession ally $ for_ people $ \(user, conv, client) -> do - message <- awaitOtrMsg conv (user, client) allyWithPhone - plain <- decryptTextMsg allyPhone message - assertEqual - plain - "Thanks Ally, All good." - ("Ally (from " <> unTag (botTag user) <> "): Plaintext /= CipherText") - postOtrTextMsg allyPhone conv "Glad to hear that." >>= assertNoClientMismatch + runBotSession ally $ + for_ people $ \(user, conv, client) -> do + message <- awaitOtrMsg conv (user, client) allyWithPhone + plain <- decryptTextMsg allyPhone message + assertEqual + plain + "Thanks Ally, All good." + ("Ally (from " <> unTag (botTag user) <> "): Plaintext /= CipherText") + postOtrTextMsg allyPhone conv "Glad to hear that." >>= assertNoClientMismatch -- Everyone checks Ally's response for_ people $ \(user, conv, client) -> runBotSession user $ do message <- awaitOtrMsg conv allyWithPhone (user, client) diff --git a/tools/bonanza/main/Kibanana.hs b/tools/bonanza/main/Kibanana.hs index de5abe0700c..d9954f5c35f 100644 --- a/tools/bonanza/main/Kibanana.hs +++ b/tools/bonanza/main/Kibanana.hs @@ -100,23 +100,24 @@ optInfo = data Signal = Stop | Go main :: IO () -main = execParser optInfo >>= \Opts {..} -> do - mgr <- newManager tlsManagerSettings - req <- baseReq url - buffer <- newTVarIO Seq.empty - signal <- newTVarIO Go - -- Start consumers - cs <- - replicateM concurrency - $ async - $ consume buffer req signal mgr maxBulkSize - -- Setup producer pipeline - runConduit $ - CB.sourceHandle stdin - .| breakByte 0 - .| CL.mapM_ (produce buffer maxBufferSize) - -- Graceful stop - drain buffer >> atomically (writeTVar signal Stop) >> mapM_ wait cs +main = + execParser optInfo >>= \Opts {..} -> do + mgr <- newManager tlsManagerSettings + req <- baseReq url + buffer <- newTVarIO Seq.empty + signal <- newTVarIO Go + -- Start consumers + cs <- + replicateM concurrency $ + async $ + consume buffer req signal mgr maxBulkSize + -- Setup producer pipeline + runConduit $ + CB.sourceHandle stdin + .| breakByte 0 + .| CL.mapM_ (produce buffer maxBufferSize) + -- Graceful stop + drain buffer >> atomically (writeTVar signal Stop) >> mapM_ wait cs where baseReq url = (\req -> req {path = "/_bulk", method = "POST"}) @@ -127,14 +128,15 @@ main = execParser optInfo >>= \Opts {..} -> do then retry else writeTVar b (xs |> x) consume b r s m i = do - chunk <- atomically $ - readTVar s >>= \case - Stop -> return Seq.empty - Go -> do - (now, later) <- Seq.splitAt i <$> readTVar b - if Seq.null now - then retry - else writeTVar b later >> return now + chunk <- + atomically $ + readTVar s >>= \case + Stop -> return Seq.empty + Go -> do + (now, later) <- Seq.splitAt i <$> readTVar b + if Seq.null now + then retry + else writeTVar b later >> return now unless (Seq.null chunk) $ do let body = requestBodySourceChunked (mapM_ yield chunk) let req = r {requestBody = body} diff --git a/tools/bonanza/src/Bonanza/Anon.hs b/tools/bonanza/src/Bonanza/Anon.hs index 4d11a720775..b82c3419619 100644 --- a/tools/bonanza/src/Bonanza/Anon.hs +++ b/tools/bonanza/src/Bonanza/Anon.hs @@ -21,7 +21,7 @@ module Bonanza.Anon where import Bonanza.Types -import Control.Lens ((%~), _Wrapped', over) +import Control.Lens (over, (%~), _Wrapped') import Data.HashMap.Strict (filterWithKey) import Imports diff --git a/tools/bonanza/src/Bonanza/App.hs b/tools/bonanza/src/Bonanza/App.hs index b2b2d8832a7..19368d9c011 100644 --- a/tools/bonanza/src/Bonanza/App.hs +++ b/tools/bonanza/src/Bonanza/App.hs @@ -33,7 +33,7 @@ import qualified Bonanza.Streaming.Snappy as Snappy import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL -import Data.Conduit ((.|), ConduitM, runConduit) +import Data.Conduit (ConduitM, runConduit, (.|)) import Data.Conduit.Binary (sinkHandle, sourceHandle) import qualified Data.Conduit.List as Conduit import qualified Data.Conduit.Zlib as Conduit @@ -184,48 +184,49 @@ optInfo = ) runBonanza :: IO () -runBonanza = execParser optInfo >>= \(Opts CommonOpts {..} cmd) -> do - started <- getCurrentTime - (bytes_in, bytes_out, events_in) <- - (,,) - <$> newIORef 0 - <*> newIORef 0 - <*> newIORef 0 - geoDB <- mkGeo geodat - runConduit $ - sourceHandle stdin - .| runDecompress decomp - .| Conduit.mapM - ( \bs -> - modifyIORef' bytes_in (+ fromIntegral (BS.length bs)) - *> pure bs - ) - .| readWith parser - .| Conduit.mapM - ( \evt -> - modifyIORef' events_in (+ 1) - *> pure evt - ) - .| runGeo geo geoDB - .| runAnonymise anon - .| runCmd cmd - .| runCompress comp - .| Conduit.mapM - ( \bs -> - modifyIORef' bytes_out (+ fromIntegral (BS.length bs)) - *> pure bs - ) - .| sinkHandle stdout - completed <- getCurrentTime - stats <- - Stats - <$> readIORef bytes_in - <*> readIORef bytes_out - <*> (picosecondsToDiffTime <$> getCPUTime) - <*> pure (completed `diffUTCTime` started) - <*> readIORef events_in - unless quiet $ do - dumpStderr stats +runBonanza = + execParser optInfo >>= \(Opts CommonOpts {..} cmd) -> do + started <- getCurrentTime + (bytes_in, bytes_out, events_in) <- + (,,) + <$> newIORef 0 + <*> newIORef 0 + <*> newIORef 0 + geoDB <- mkGeo geodat + runConduit $ + sourceHandle stdin + .| runDecompress decomp + .| Conduit.mapM + ( \bs -> + modifyIORef' bytes_in (+ fromIntegral (BS.length bs)) + *> pure bs + ) + .| readWith parser + .| Conduit.mapM + ( \evt -> + modifyIORef' events_in (+ 1) + *> pure evt + ) + .| runGeo geo geoDB + .| runAnonymise anon + .| runCmd cmd + .| runCompress comp + .| Conduit.mapM + ( \bs -> + modifyIORef' bytes_out (+ fromIntegral (BS.length bs)) + *> pure bs + ) + .| sinkHandle stdout + completed <- getCurrentTime + stats <- + Stats + <$> readIORef bytes_in + <*> readIORef bytes_out + <*> (picosecondsToDiffTime <$> getCPUTime) + <*> pure (completed `diffUTCTime` started) + <*> readIORef events_in + unless quiet $ do + dumpStderr stats where runGeo [] _ = Conduit.map id runGeo tags db = diff --git a/tools/bonanza/src/Bonanza/Parser/CommonLog.hs b/tools/bonanza/src/Bonanza/Parser/CommonLog.hs index 288f50a876e..4a4f1a8c8af 100644 --- a/tools/bonanza/src/Bonanza/Parser/CommonLog.hs +++ b/tools/bonanza/src/Bonanza/Parser/CommonLog.hs @@ -85,9 +85,9 @@ instance ToLogEvent CommonLogRecord where commonLogFields :: [Text] commonLogFields = - "remote_addr" - : "remote_user" - : map fst fieldParsers + "remote_addr" : + "remote_user" : + map fst fieldParsers fieldParsers :: [(Text, Parser CommonLogField)] fieldParsers = @@ -112,9 +112,9 @@ commonLogRecord moreFieldParsers = do (_, CEmpty) -> Nothing (k, CField v) -> Just (k, v) ) - $ ("remote_addr", raddr) - : ("remote_user", ruser) - : flds, + $ ("remote_addr", raddr) : + ("remote_user", ruser) : + flds, cRequest = req } where diff --git a/tools/bonanza/src/Bonanza/Parser/Tinylog.hs b/tools/bonanza/src/Bonanza/Parser/Tinylog.hs index 907e904123c..fce8c348f57 100644 --- a/tools/bonanza/src/Bonanza/Parser/Tinylog.hs +++ b/tools/bonanza/src/Bonanza/Parser/Tinylog.hs @@ -53,8 +53,8 @@ instance ToLogEvent TinyLogRecord where where tgs = Tags . fromList . map (second String) $ - ("level", T.singleton tLevel) - : tFields + ("level", T.singleton tLevel) : + tFields ++ maybeToList ((,) "time" <$> tDate) tinyLogRecord :: Parser TinyLogRecord diff --git a/tools/bonanza/test/unit/Test/Bonanza/Arbitrary.hs b/tools/bonanza/test/unit/Test/Bonanza/Arbitrary.hs index 9b7dc38f89c..dccf2a3c018 100644 --- a/tools/bonanza/test/unit/Test/Bonanza/Arbitrary.hs +++ b/tools/bonanza/test/unit/Test/Bonanza/Arbitrary.hs @@ -281,8 +281,8 @@ instance Arbitrary (ParseInput TinyLogRecord) where encodeUtf8 . mconcat $ [ maybe "" (\d -> decodeUtf8 $ df d <> ", ") date, T.intercalate ", " $ - T.singleton level - : map (\(k, v) -> alnum k <> "=" <> fieldValue v) fields + T.singleton level : + map (\(k, v) -> alnum k <> "=" <> fieldValue v) fields ++ [message] ] return $ ParseInput (rec, inp) @@ -351,9 +351,9 @@ instance Arbitrary (ParseInput (NginzLogRecord)) where { cTime = date, cFields = mapMaybe (\(k, v) -> (,) k <$> fromField v) $ - ("remote_addr", raddr) - : ("remote_user", ruser) - : fields, + ("remote_addr", raddr) : + ("remote_user", ruser) : + fields, cRequest = req } inp = diff --git a/tools/bonanza/test/unit/Test/Bonanza/Streaming.hs b/tools/bonanza/test/unit/Test/Bonanza/Streaming.hs index 76005abc601..4c17d7f8ca1 100644 --- a/tools/bonanza/test/unit/Test/Bonanza/Streaming.hs +++ b/tools/bonanza/test/unit/Test/Bonanza/Streaming.hs @@ -31,7 +31,7 @@ import Bonanza.Types import Data.Attoparsec.ByteString.Char8 import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as BL -import Data.Conduit ((.|), runConduit) +import Data.Conduit (runConduit, (.|)) import qualified Data.Conduit.Binary as Conduit import qualified Data.Conduit.List as Conduit import Imports @@ -110,12 +110,12 @@ run_prop :: [ParseInput a] -> Property run_prop p i = - ioProperty - $ runConduit - $ Conduit.sourceLbs inp - .| P.stream (P.MkParser p) - .| Conduit.consume - >>= pure . (=== out) . map secs + ioProperty $ + runConduit $ + Conduit.sourceLbs inp + .| P.stream (P.MkParser p) + .| Conduit.consume + >>= pure . (=== out) . map secs where inp = BL.fromStrict . B.intercalate "\n" $ map (snd . parseInput) i out = map (secs . toLogEvent . fst . parseInput) i diff --git a/tools/db/auto-whitelist/src/Work.hs b/tools/db/auto-whitelist/src/Work.hs index 103b3dc9499..b8ff4c84c50 100644 --- a/tools/db/auto-whitelist/src/Work.hs +++ b/tools/db/auto-whitelist/src/Work.hs @@ -72,7 +72,7 @@ whitelistService l (pid, sid, tid) = do . Log.field "provider" (show pid) . Log.field "service" (show sid) . Log.field "team" (show tid) - retry x5 $ batch $ do + retry x5 . batch $ do setConsistency Quorum setType BatchLogged addPrepQuery insert1 (tid, pid, sid) diff --git a/tools/db/billing-team-member-backfill/src/Work.hs b/tools/db/billing-team-member-backfill/src/Work.hs index e19dff15935..318610f8bef 100644 --- a/tools/db/billing-team-member-backfill/src/Work.hs +++ b/tools/db/billing-team-member-backfill/src/Work.hs @@ -68,7 +68,7 @@ getTeamMembers = paginateC cql (paramsP Quorum () pageSize) x5 createBillingTeamMembers :: [(TeamId, UserId)] -> Client () createBillingTeamMembers pairs = - retry x5 $ batch $ do + retry x5 . batch $ do setType BatchLogged setConsistency Quorum mapM_ (addPrepQuery cql) pairs diff --git a/tools/db/find-undead/src/Work.hs b/tools/db/find-undead/src/Work.hs index 32757e22c12..f60e30f9719 100644 --- a/tools/db/find-undead/src/Work.hs +++ b/tools/db/find-undead/src/Work.hs @@ -25,8 +25,8 @@ import Brig.Types.Intra (AccountStatus (..)) import Cassandra import Cassandra.Util (Writetime, writeTimeToUTC) import Conduit -import Control.Lens (_1, _2, view) -import Data.Aeson ((.:), FromJSON) +import Control.Lens (view, _1, _2) +import Data.Aeson (FromJSON, (.:)) import qualified Data.Aeson as Aeson import qualified Data.Conduit.List as C import qualified Data.Set as Set @@ -41,16 +41,16 @@ runCommand :: Logger -> ClientState -> ES.BHEnv -> String -> String -> IO () runCommand l cas es indexStr mappingStr = do let index = ES.IndexName $ Text.pack indexStr mapping = ES.MappingName $ Text.pack mappingStr - runConduit - $ transPipe (ES.runBH es) - $ getScrolled index mapping - .| C.iterM (logProgress l) - .| C.mapM - ( \uuids -> do - fromCas <- runClient cas $ usersInCassandra uuids - pure (uuids, fromCas) - ) - .| C.mapM_ (logDifference l) + runConduit $ + transPipe (ES.runBH es) $ + getScrolled index mapping + .| C.iterM (logProgress l) + .| C.mapM + ( \uuids -> do + fromCas <- runClient cas $ usersInCassandra uuids + pure (uuids, fromCas) + ) + .| C.mapM_ (logDifference l) ---------------------------------------------------------------------------- -- Queries diff --git a/tools/db/service-backfill/src/Work.hs b/tools/db/service-backfill/src/Work.hs index 5b439dd1856..5b73e8d68c6 100644 --- a/tools/db/service-backfill/src/Work.hs +++ b/tools/db/service-backfill/src/Work.hs @@ -84,7 +84,7 @@ writeBots :: [(ProviderId, ServiceId, BotId, ConvId, Maybe TeamId)] -> Client () writeBots [] = pure () -writeBots xs = retry x5 $ batch $ do +writeBots xs = retry x5 . batch $ do setConsistency Quorum setType BatchLogged forM_ xs $ \(pid, sid, bid, cid, mbTid) -> do diff --git a/tools/ormolu.sh b/tools/ormolu.sh index f6c6e4a037f..b7bc03d99d5 100755 --- a/tools/ormolu.sh +++ b/tools/ormolu.sh @@ -74,7 +74,7 @@ FAILURES=0 for hsfile in $(git ls-files | grep '\.hsc\?$'); do FAILED=0 - ormolu --mode $ARG_ORMOLU_MODE --check-idempotency $LANGUAGE_EXTS "$hsfile" || FAILED=1 + ormolu --mode $ARG_ORMOLU_MODE --check-idempotence $LANGUAGE_EXTS "$hsfile" || FAILED=1 if [ "$FAILED" == "1" ]; then ((++FAILURES)) echo "$hsfile... *** FAILED" diff --git a/tools/rebase-onto-formatter.sh b/tools/rebase-onto-formatter.sh new file mode 100755 index 00000000000..1196fad8a35 --- /dev/null +++ b/tools/rebase-onto-formatter.sh @@ -0,0 +1,123 @@ +#!/usr/bin/env bash + +set -euo pipefail + +command -v sed >/dev/null 2>&1 || { echo >&2 "sed is not installed, aborting."; exit 1; } + +BASE_COMMIT=${1:-} +TARGET_COMMIT=${2:-} +FORMATTING_COMMAND='make formatf' +USAGE=" +USAGE: $0 BASE_COMMIT TARGET_COMMIT + + BASE_COMMIT: + A commit that contains the changes to formatting version and + config already from TARGET_COMMIT, but not the automatically + applied formatting changes. Must be the first commit on the + branch you are about to rebase (not the one returned by + git-merge-base). It will be removed from the resulting branch. + TARGET_COMMIT: + The commit introducing the formatting that you want to rebase onto. + +Rebase a branch onto changes created by an automated formatter. The script +will keep the (linear) history of the branch intact and make the commits appear +as if the changes had been applied onto the newly-formatted version all along. + +INSTRUCTIONS: +1. Make a copy of your branch (or be prepared to salvage it from reflog). + $ git branch mybranch-backup +2. Find out what the base commit is. +3. Rebase onto the base commit yourself. + $ git rebase \$BASE_COMMIT +4. Make sure the formatting tool is installed with the correct version and settings. + $ stack install ormolu +5. Run this script. + $ $0 \$BASE_COMMIT \$TARGET_COMMIT + +" + +if [ -z "$BASE_COMMIT" ] || [ -z "$TARGET_COMMIT" ] || [ -z "$FORMATTING_COMMAND" ] +then + echo "$USAGE" 1>&2 + exit 1 +fi + +echo "Running the script now. This might take a while..." + +# The general idea is the following: +# +# We have a branch consisting of commits C1, C2, ... on top of our BASE_COMMIT C0. +# Also, from C0 an automated formatting change f was made on some branch (e.g. develop). +# +# C0 ----> C1 ----> C2 ----> ... ----> Cn +# | +# f +# | +# v +# C0' +# +# Now, how do we obtain versions of our commits operating on the formatted code (let's call them Ci')? +# +# C0 ----> C1 ----> C2 ----> ... ----> Cn +# | +# f +# | +# v +# C0' ---> C1' ---> C2' ---> ... ----> Cn' +# +# One useful thing is that since f is defined by an automated tool, +# we know f applied at every commit Ci, resulting in a hypothetical Ci'. +# +# C0 ----> C1 ----> C2 ----> ... ----> Cn +# | | | | +# f f f f +# | | | | +# v v v v +# C0' C1' C2' Cn' +# +# And we can also get its inverse g (applied at Ci') by reverting the commit. +# +# C0 ----> C1 ----> C2 ----> ... ----> Cn +# |^ |^ |^ |^ +# f| f| f| f| +# |g |g |g |g +# v| v| v| v| +# C0' C1' C2' Cn' +# +# Finally, we can get from C(i-1)' to Ci' by composing three arrows: +# - g at C(i-1) +# - Ci +# - f at C1 +# +# C0 ----> C1 ----> C2 ----> ... ----> Cn +# |^ |^ |^ |^ +# f| f| f| f| +# |g |g |g |g +# v| v| v| v| +# C0' ---> C1' ---> C2' ---> ... ----> Cn' + +set -x + +# edit every commit Ci, adding new commits representing f at Ci and it's inverse g +git rebase $BASE_COMMIT~1 --exec "$FORMATTING_COMMAND && git commit -am format && git revert HEAD --no-edit" + +# drop last commit (do not revert formatting at the end of the branch) +git reset HEAD~1 --hard + +# now for every Ci, squash with the previous and next commit (i.e. g at C(i-1) and f at Ci). +# However, we want to use Ci's commit message and author. +# To do this, we run the following command after each group of these 3 commits: +# Ci=$(git rev-parse HEAD~1); git reset --soft HEAD~3; git commit --reuse-message $Ci +# We do an interactive rebase, but instead of editing the commit sequence manually, +# we use sed for that, inserting an `exec` command after every 3 commits. +GIT_SEQUENCE_EDITOR='sed -i -e "4~3s/^\(pick \S* format\)$/\1\nexec Ci=\$(git rev-parse HEAD~1); git reset --soft HEAD~3; git commit --reuse-message \$Ci/"' \ + git rebase --interactive $BASE_COMMIT + +# rebase onto TARGET_COMMIT. +# Annoyingly, we still have this first "format" commit that should already be +# part of the TARGET_COMMIT. So we drop it. +GIT_SEQUENCE_EDITOR='sed -i "1s/pick/drop/"' \ + git rebase --interactive $BASE_COMMIT --onto $TARGET_COMMIT + +echo "Done." +echo "Please check that the history looks as it should and all expected commits are there." diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 5fb4d16c01f..4368489f85b 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -65,7 +65,7 @@ import qualified Stern.Intra as Intra import Stern.Options import qualified Stern.Swagger as Doc import Stern.Types -import System.Logger.Class hiding ((.=), Error, name, trace) +import System.Logger.Class hiding (Error, name, trace, (.=)) import Util.Options import qualified Wire.API.Team.Feature as Public import qualified Wire.API.Team.SearchVisibility as Public @@ -649,9 +649,9 @@ getTeamInvoice (tid ::: iid ::: _) = do getConsentLog :: Email -> Handler Response getConsentLog e = do acc <- (listToMaybe <$> Intra.getUserProfilesByIdentity (Left e)) - when (isJust acc) - $ throwE - $ Error status403 "user-exists" "Trying to access consent log of existing user!" + when (isJust acc) $ + throwE $ + Error status403 "user-exists" "Trying to access consent log of existing user!" consentLog <- Intra.getEmailConsentLog e marketo <- Intra.getMarketoResult e return . json $ diff --git a/tools/stern/src/Stern/App.hs b/tools/stern/src/Stern/App.hs index 0127a4c9863..fc5132def11 100644 --- a/tools/stern/src/Stern/App.hs +++ b/tools/stern/src/Stern/App.hs @@ -27,7 +27,7 @@ import qualified Bilge import qualified Bilge.IO as Bilge (withResponse) import Bilge.RPC (HasRequestId (..)) import Control.Error -import Control.Lens ((^.), makeLenses, set, view) +import Control.Lens (makeLenses, set, view, (^.)) import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.IO.Class import Control.Monad.Reader.Class diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index f52cc7bd202..bb8a891512f 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -63,7 +63,7 @@ import Brig.Types import Brig.Types.Intra import Brig.Types.User.Auth import Control.Error -import Control.Lens ((^.), view) +import Control.Lens (view, (^.)) import Control.Monad.Reader import Data.Aeson hiding (Error) import Data.Aeson.Types (emptyArray) @@ -89,7 +89,7 @@ import Network.HTTP.Types.Status hiding (statusCode) import Network.Wai.Utilities (Error (..)) import Stern.App import Stern.Types -import System.Logger.Class hiding ((.=), Error, name) +import System.Logger.Class hiding (Error, name, (.=)) import qualified System.Logger.Class as Log import UnliftIO.Exception hiding (Handler) import qualified Wire.API.Team.Feature as Public @@ -100,33 +100,35 @@ putUser :: UserId -> UserUpdate -> Handler () putUser uid upd = do info $ userMsg uid . msg "Changing user state" b <- view brig - void $ catchRpcErrors $ - rpc' - "brig" - b - ( method PUT - . path "/self" - . header "Z-User" (toByteString' uid) - . header "Z-Connection" (toByteString' "") - . lbytes (encode upd) - . contentJson - . expect2xx - ) + void $ + catchRpcErrors $ + rpc' + "brig" + b + ( method PUT + . path "/self" + . header "Z-User" (toByteString' uid) + . header "Z-Connection" (toByteString' "") + . lbytes (encode upd) + . contentJson + . expect2xx + ) putUserStatus :: AccountStatus -> UserId -> Handler () putUserStatus status uid = do info $ userMsg uid . msg "Changing user status" b <- view brig - void $ catchRpcErrors $ - rpc' - "brig" - b - ( method PUT - . paths ["/i/users", toByteString' uid, "status"] - . lbytes (encode payload) - . contentJson - . expect2xx - ) + void $ + catchRpcErrors $ + rpc' + "brig" + b + ( method PUT + . paths ["/i/users", toByteString' uid, "status"] + . lbytes (encode payload) + . contentJson + . expect2xx + ) where payload = AccountStatusUpdate status @@ -335,10 +337,11 @@ getUserBindingTeam u = do . expect2xx ) teams <- parseResponse (Error status502 "bad-upstream") r - return $ listToMaybe - $ fmap (view teamId) - $ filter ((== Binding) . view teamBinding) - $ teams ^. teamListTeams + return $ + listToMaybe $ + fmap (view teamId) $ + filter ((== Binding) . view teamBinding) $ + teams ^. teamListTeams getInvoiceUrl :: TeamId -> InvoiceId -> Handler ByteString getInvoiceUrl tid iid = do diff --git a/tools/stern/src/Stern/Types.hs b/tools/stern/src/Stern/Types.hs index 3ea26464e57..6f2e43a2729 100644 --- a/tools/stern/src/Stern/Types.hs +++ b/tools/stern/src/Stern/Types.hs @@ -42,10 +42,10 @@ instance ToJSON TeamMemberInfo where toJSON (TeamMemberInfo m) = case teamMemberJson (const True) m of Object o -> - Object - $ M.insert "can_update_billing" (Bool (hasPermission m SetBilling)) - $ M.insert "can_view_billing" (Bool (hasPermission m GetBilling)) - $ o + Object $ + M.insert "can_update_billing" (Bool (hasPermission m SetBilling)) $ + M.insert "can_view_billing" (Bool (hasPermission m GetBilling)) $ + o other -> error $ "toJSON TeamMemberInfo: not an object: " <> show (encode other)