diff --git a/cabal.project b/cabal.project index c0a106450cb..471d12e874a 100644 --- a/cabal.project +++ b/cabal.project @@ -31,6 +31,7 @@ packages: , libs/wire-api/ , libs/wire-api-federation/ , libs/wire-message-proto-lens/ + , libs/wire-subsystems/ , libs/zauth/ , services/background-worker/ , services/brig/ @@ -162,6 +163,8 @@ package wire-api-federation ghc-options: -Werror package wire-message-proto-lens ghc-options: -Werror +package wire-subsystems + ghc-options: -Werror package zauth ghc-options: -Werror package fedcalls diff --git a/changelog.d/5-internal/notification-subsystem b/changelog.d/5-internal/notification-subsystem new file mode 100644 index 00000000000..70c4197bfcd --- /dev/null +++ b/changelog.d/5-internal/notification-subsystem @@ -0,0 +1 @@ +Start refactoring code into subsystems, first subsystem being the NotificationSubsystem. \ No newline at end of file diff --git a/libs/extended/default.nix b/libs/extended/default.nix index b44a955a35f..ad03254ed71 100644 --- a/libs/extended/default.nix +++ b/libs/extended/default.nix @@ -31,6 +31,7 @@ , servant-server , temporary , text +, time , tinylog , unliftio , wai @@ -63,6 +64,7 @@ mkDerivation { servant-openapi3 servant-server text + time tinylog unliftio wai diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal index 9ff76607ba5..2bfb4d92022 100644 --- a/libs/extended/extended.cabal +++ b/libs/extended/extended.cabal @@ -19,6 +19,7 @@ build-type: Simple library -- cabal-fmt: expand src exposed-modules: + Data.Time.Clock.DiffTime Network.AMQP.Extended Network.RabbitMqAdmin Options.Applicative.Extended @@ -101,6 +102,7 @@ library , servant-openapi3 , servant-server , text + , time , tinylog , unliftio , wai diff --git a/libs/extended/src/Data/Time/Clock/DiffTime.hs b/libs/extended/src/Data/Time/Clock/DiffTime.hs new file mode 100644 index 00000000000..5541fd43d38 --- /dev/null +++ b/libs/extended/src/Data/Time/Clock/DiffTime.hs @@ -0,0 +1,43 @@ +module Data.Time.Clock.DiffTime + ( DiffTime, + weeksToDiffTime, + daysToDiffTime, + hoursToDiffTime, + minutesToDiffTime, + secondsToDiffTime, + millisecondsToDiffTime, + microsecondsToDiffTime, + nanosecondsToDiffTime, + picosecondsToDiffTime, + diffTimeToFullMicroseconds, + diffTimeToPicoseconds, + ) +where + +import Data.Time +import Imports + +weeksToDiffTime, + daysToDiffTime, + hoursToDiffTime, + minutesToDiffTime, + millisecondsToDiffTime, + microsecondsToDiffTime, + nanosecondsToDiffTime :: + Integer -> DiffTime +weeksToDiffTime = daysToDiffTime . (7 *) +daysToDiffTime = hoursToDiffTime . (24 *) +hoursToDiffTime = minutesToDiffTime . (60 *) +minutesToDiffTime = secondsToDiffTime . (60 *) +millisecondsToDiffTime = picosecondsToDiffTime . (e9 *) +microsecondsToDiffTime = picosecondsToDiffTime . (e6 *) +nanosecondsToDiffTime = picosecondsToDiffTime . (e3 *) + +-- | Rounds down. Useful for 'threadDelay', 'timeout', etc. +diffTimeToFullMicroseconds :: DiffTime -> Int +diffTimeToFullMicroseconds = fromInteger . (`div` e6) . diffTimeToPicoseconds + +e3, e6, e9 :: Integer +e3 = 1_000 +e6 = 1_000_000 +e9 = 1_000_000_000 diff --git a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs index f38723fe9e8..aedfc7f0164 100644 --- a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs +++ b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs @@ -171,14 +171,15 @@ instance ToJSON RecipientClients where -- ApsData newtype ApsSound = ApsSound {fromSound :: Text} - deriving (Eq, Show, ToJSON, FromJSON) + deriving (Eq, Show, ToJSON, FromJSON, Arbitrary) newtype ApsLocKey = ApsLocKey {fromLocKey :: Text} - deriving (Eq, Show, ToJSON, FromJSON) + deriving (Eq, Show, ToJSON, FromJSON, Arbitrary) data ApsPreference = ApsStdPreference - deriving (Eq, Show) + deriving (Eq, Show, Generic) + deriving (Arbitrary) via GenericUniform ApsPreference instance ToJSON ApsPreference where toJSON ApsStdPreference = "std" @@ -195,7 +196,8 @@ data ApsData = ApsData _apsPreference :: !(Maybe ApsPreference), _apsBadge :: !Bool } - deriving (Eq, Show) + deriving (Eq, Show, Generic) + deriving (Arbitrary) via GenericUniform ApsData makeLenses ''ApsData diff --git a/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal b/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal index 5e346eb0ea2..c6c363632e9 100644 --- a/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal +++ b/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal @@ -17,6 +17,7 @@ library Wire.Sem.Concurrency Wire.Sem.Concurrency.IO Wire.Sem.Concurrency.Sequential + Wire.Sem.Delay Wire.Sem.FromUTC Wire.Sem.Jwk Wire.Sem.Logger diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency.hs index cdafb1b54f9..29ac503809d 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Concurrency.hs @@ -80,6 +80,32 @@ unsafePooledMapConcurrentlyN_ n f as = (UnsafePooledMapConcurrentlyN_ n f as :: Concurrency 'Unsafe (Sem r) ()) {-# INLINEABLE unsafePooledMapConcurrentlyN_ #-} +unsafePooledForConcurrentlyN :: + forall r t a b. + (Member (Concurrency 'Unsafe) r, Foldable t) => + -- | Max. number of threads. Should not be less than 1. + Int -> + t a -> + (a -> Sem r b) -> + Sem r [b] +unsafePooledForConcurrentlyN n as f = + send + (UnsafePooledMapConcurrentlyN n f as :: Concurrency 'Unsafe (Sem r) [b]) +{-# INLINEABLE unsafePooledForConcurrentlyN #-} + +unsafePooledForConcurrentlyN_ :: + forall r t a b. + (Member (Concurrency 'Unsafe) r, Foldable t) => + -- | Max. number of threads. Should not be less than 1. + Int -> + t a -> + (a -> Sem r b) -> + Sem r () +unsafePooledForConcurrentlyN_ n as f = + send + (UnsafePooledMapConcurrentlyN_ n f as :: Concurrency 'Unsafe (Sem r) ()) +{-# INLINEABLE unsafePooledForConcurrentlyN_ #-} + pooledMapConcurrentlyN :: forall r' r t a b. r' ~ '[Final IO] => @@ -111,3 +137,35 @@ pooledMapConcurrentlyN_ n f as = Concurrency 'Safe (Sem r) () ) {-# INLINEABLE pooledMapConcurrentlyN_ #-} + +pooledForConcurrentlyN :: + forall r' r t a b. + r' ~ '[Final IO] => + (Member (Concurrency 'Safe) r, Subsume r' r, Foldable t) => + -- | Max. number of threads. Should not be less than 1. + Int -> + t a -> + (a -> Sem r' b) -> + Sem r [b] +pooledForConcurrentlyN n as f = + send + ( UnsafePooledMapConcurrentlyN n (subsume_ @r' @r . f) as :: + Concurrency 'Safe (Sem r) [b] + ) +{-# INLINEABLE pooledForConcurrentlyN #-} + +pooledForConcurrentlyN_ :: + forall r' r t a b. + r' ~ '[Final IO] => + (Member (Concurrency 'Safe) r, Subsume r' r, Foldable t) => + -- | Max. number of threads. Should not be less than 1. + Int -> + t a -> + (a -> Sem r' b) -> + Sem r () +pooledForConcurrentlyN_ n as f = + send + ( UnsafePooledMapConcurrentlyN_ n (subsume_ @r' @r . f) as :: + Concurrency 'Safe (Sem r) () + ) +{-# INLINEABLE pooledForConcurrentlyN_ #-} diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs new file mode 100644 index 00000000000..7b1395b8ed0 --- /dev/null +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.Sem.Delay where + +import Imports +import Polysemy + +data Delay m a where + Delay :: Int -> Delay m () + +makeSem ''Delay + +runDelay :: Member (Embed IO) r => Sem (Delay ': r) a -> Sem r a +runDelay = interpret $ \case + Delay i -> threadDelay i + +runControlledDelay :: forall r a. (Member (Embed IO) r) => MVar Int -> Sem (Delay : r) a -> Sem r a +runControlledDelay tickSource = interpret $ \case + Delay n -> waitForTicks n + where + waitForTicks :: Int -> Sem r () + waitForTicks 0 = pure () + waitForTicks remaining0 = do + passedTicks <- takeMVar tickSource + let remaining = remaining0 - passedTicks + if remaining <= 0 + then pure () + else waitForTicks remaining + +runDelayInstantly :: Sem (Delay : r) a -> Sem r a +runDelayInstantly = interpret $ \case + Delay _ -> pure () diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Logger/TinyLog.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Logger/TinyLog.hs index 69a768ed4bd..a7b63f7fe7d 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Logger/TinyLog.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Logger/TinyLog.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -21,12 +23,16 @@ module Wire.Sem.Logger.TinyLog stringLoggerToTinyLog, discardTinyLogs, module Wire.Sem.Logger.Level, + LogRecorder (..), + newLogRecorder, + recordLogs, ) where import Data.Id import Imports import Polysemy +import Polysemy.TinyLog (TinyLog) import qualified System.Logger as Log import Wire.Sem.Logger import Wire.Sem.Logger.Level @@ -58,3 +64,12 @@ stringLoggerToTinyLog = mapLogger @String Log.msg discardTinyLogs :: Sem (Logger (Log.Msg -> Log.Msg) ': r) a -> Sem r a discardTinyLogs = discardLogs + +newtype LogRecorder = LogRecorder {recordedLogs :: IORef [(Level, LByteString)]} + +newLogRecorder :: IO LogRecorder +newLogRecorder = LogRecorder <$> newIORef [] + +recordLogs :: Member (Embed IO) r => LogRecorder -> Sem (TinyLog ': r) a -> Sem r a +recordLogs LogRecorder {..} = interpret $ \(Log lvl msg) -> + modifyIORef' recordedLogs (++ [(lvl, Log.render (Log.renderDefault ", ") msg)]) diff --git a/libs/types-common/src/Data/Range.hs b/libs/types-common/src/Data/Range.hs index 898df2142c1..0ad0a3e2c14 100644 --- a/libs/types-common/src/Data/Range.hs +++ b/libs/types-common/src/Data/Range.hs @@ -508,6 +508,9 @@ genRange pack_ gc = instance (KnownNat n, KnownNat m, n <= m) => Arbitrary (Range n m Integer) where arbitrary = genIntegral +instance (KnownNat n, KnownNat m, n <= m) => Arbitrary (Range n m Int32) where + arbitrary = genIntegral + instance (KnownNat n, KnownNat m, n <= m) => Arbitrary (Range n m Word) where arbitrary = genIntegral diff --git a/libs/wire-subsystems/LICENSE b/libs/wire-subsystems/LICENSE new file mode 100644 index 00000000000..dba13ed2ddf --- /dev/null +++ b/libs/wire-subsystems/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/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix new file mode 100644 index 00000000000..bd3ef35a59c --- /dev/null +++ b/libs/wire-subsystems/default.nix @@ -0,0 +1,81 @@ +# WARNING: GENERATED FILE, DO NOT EDIT. +# This file is generated by running hack/bin/generate-local-nix-packages.sh and +# must be regenerated whenever local packages are added or removed, or +# dependencies are added or removed. +{ mkDerivation +, aeson +, async +, base +, bilge +, bytestring +, bytestring-conversion +, containers +, exceptions +, extended +, gitignoreSource +, gundeck-types +, hspec +, hspec-discover +, http-client +, http-types +, imports +, lens +, lib +, polysemy +, polysemy-wire-zoo +, QuickCheck +, quickcheck-instances +, retry +, text +, tinylog +, types-common +, wire-api +}: +mkDerivation { + pname = "wire-subsystems"; + version = "0.1.0"; + src = gitignoreSource ./.; + libraryHaskellDepends = [ + aeson + async + base + bilge + bytestring-conversion + containers + exceptions + extended + gundeck-types + http-client + http-types + imports + lens + polysemy + polysemy-wire-zoo + QuickCheck + retry + text + tinylog + types-common + wire-api + ]; + testHaskellDepends = [ + aeson + async + base + bilge + bytestring + containers + extended + gundeck-types + hspec + imports + polysemy + polysemy-wire-zoo + QuickCheck + quickcheck-instances + types-common + wire-api + ]; + testToolDepends = [ hspec-discover ]; + license = lib.licenses.agpl3Only; +} diff --git a/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs b/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs new file mode 100644 index 00000000000..1d0666880cf --- /dev/null +++ b/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.GundeckAPIAccess where + +import Bilge +import Data.ByteString.Conversion +import Data.Id +import Gundeck.Types.Push.V2 qualified as V2 +import Imports +import Network.HTTP.Types +import Polysemy +import Util.Options +import Wire.Rpc + +data GundeckAPIAccess m a where + PushV2 :: [V2.Push] -> GundeckAPIAccess m () + UserDeleted :: UserId -> GundeckAPIAccess m () + UnregisterPushClient :: UserId -> ClientId -> GundeckAPIAccess m () + GetPushTokens :: UserId -> GundeckAPIAccess m [V2.PushToken] + +makeSem ''GundeckAPIAccess + +runGundeckAPIAccess :: (Member Rpc r, Member (Embed IO) r) => Endpoint -> Sem (GundeckAPIAccess : r) a -> Sem r a +runGundeckAPIAccess ep = interpret $ \case + PushV2 pushes -> do + chunkedReq <- jsonChunkedIO pushes + -- No retries because the chunked request body cannot be replayed. + void . rpc "gundeck" ep $ + method POST + . path "/i/push/v2" + . expect2xx + . chunkedReq + UserDeleted uid -> do + void . rpcWithRetries "gundeck" ep $ + method DELETE + . path "/i/user" + . zUser uid + . expect2xx + UnregisterPushClient uid cid -> do + void . rpcWithRetries "gundeck" ep $ + method DELETE + . paths ["i", "clients", toByteString' cid] + . zUser uid + . expect [status200, status204, status404] + GetPushTokens uid -> do + rsp <- + rpcWithRetries "gundeck" ep $ + method GET + . paths ["i", "push-tokens", toByteString' uid] + . zUser uid + . expect2xx + responseJsonMaybe rsp & maybe (pure []) (pure . V2.pushTokens) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs new file mode 100644 index 00000000000..499b1eb12e4 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.NotificationSubsystem where + +import Control.Concurrent.Async (Async) +import Control.Lens (makeLenses) +import Data.Aeson +import Data.Id +import Data.List.NonEmpty (NonEmpty ((:|))) +import Gundeck.Types hiding (Push (..), Recipient, newPush) +import Imports +import Polysemy +import Wire.Arbitrary + +data Recipient = Recipient + { _recipientUserId :: UserId, + _recipientClients :: RecipientClients + } + deriving stock (Show, Ord, Eq, Generic) + deriving (Arbitrary) via GenericUniform Recipient + +makeLenses ''Recipient + +data Push = Push + { _pushConn :: Maybe ConnId, + _pushTransient :: Bool, + _pushRoute :: Route, + _pushNativePriority :: Maybe Priority, + pushOrigin :: Maybe UserId, + _pushRecipients :: NonEmpty Recipient, + pushJson :: Object, + _pushApsData :: Maybe ApsData + } + deriving stock (Eq, Generic, Show) + deriving (Arbitrary) via GenericUniform Push + +makeLenses ''Push + +-- | This subsystem governs mechanisms to send notifications to users. +data NotificationSubsystem m a where + -- | Bulk push notifications + PushNotifications :: [Push] -> NotificationSubsystem m () + -- | Bulk push notifications, but slowly. This should be used when there are + -- many notifications to be sent which could cause too much resource usage. + PushNotificationsSlowly :: [Push] -> NotificationSubsystem m () + -- | Bulk push notifications, but async. This should be used when failure to + -- send notifications is not critical. + -- + -- See 'Polysemy.Async' to know more about the 'Maybe' + PushNotificationsAsync :: [Push] -> NotificationSubsystem m (Async (Maybe ())) + CleanupUser :: UserId -> NotificationSubsystem m () + UnregisterPushClient :: UserId -> ClientId -> NotificationSubsystem m () + GetPushTokens :: UserId -> NotificationSubsystem m [PushToken] + +makeSem ''NotificationSubsystem + +newPush1 :: Maybe UserId -> Object -> NonEmpty Recipient -> Push +newPush1 from e rr = + Push + { _pushConn = Nothing, + _pushTransient = False, + _pushRoute = RouteAny, + _pushNativePriority = Nothing, + _pushApsData = Nothing, + pushJson = e, + pushOrigin = from, + _pushRecipients = rr + } + +newPush :: Maybe UserId -> Object -> [Recipient] -> Maybe Push +newPush _ _ [] = Nothing +newPush u e (r : rr) = Just $ newPush1 u e (r :| rr) + +newPushLocal :: UserId -> Object -> [Recipient] -> Maybe Push +newPushLocal uid = newPush (Just uid) + +newPushLocal1 :: UserId -> Object -> NonEmpty Recipient -> Push +newPushLocal1 uid = newPush1 (Just uid) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs new file mode 100644 index 00000000000..f59c79d0c2d --- /dev/null +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -0,0 +1,170 @@ +module Wire.NotificationSubsystem.Interpreter where + +import Bilge (RequestId) +import Control.Concurrent.Async (Async) +import Control.Lens (set, (.~)) +import Data.Aeson +import Data.List.NonEmpty (nonEmpty) +import Data.List1 (List1) +import Data.List1 qualified as List1 +import Data.Proxy +import Data.Range +import Data.Set qualified as Set +import Data.Time.Clock.DiffTime +import Gundeck.Types hiding (Push (..), Recipient, newPush) +import Gundeck.Types.Push.V2 qualified as V2 +import Imports +import Numeric.Natural (Natural) +import Polysemy +import Polysemy.Async (async, sequenceConcurrently) +import Polysemy.Async qualified as P +import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog qualified as P +import System.Logger.Class as Log +import Wire.API.Team.Member +import Wire.GundeckAPIAccess (GundeckAPIAccess) +import Wire.GundeckAPIAccess qualified as GundeckAPIAccess +import Wire.NotificationSubsystem +import Wire.Sem.Delay + +-- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. +runNotificationSubsystemGundeck :: + ( Member GundeckAPIAccess r, + Member P.Async r, + Member Delay r, + Member (Final IO) r, + Member P.TinyLog r + ) => + NotificationSubsystemConfig -> + Sem (NotificationSubsystem : r) a -> + Sem r a +runNotificationSubsystemGundeck cfg = interpret $ \case + PushNotifications ps -> runInputConst cfg $ pushImpl ps + PushNotificationsSlowly ps -> runInputConst cfg $ pushSlowlyImpl ps + PushNotificationsAsync ps -> runInputConst cfg $ pushAsyncImpl ps + CleanupUser uid -> GundeckAPIAccess.userDeleted uid + UnregisterPushClient uid cid -> GundeckAPIAccess.unregisterPushClient uid cid + GetPushTokens uid -> GundeckAPIAccess.getPushTokens uid + +data NotificationSubsystemConfig = NotificationSubsystemConfig + { fanoutLimit :: Range 1 HardTruncationLimit Int32, + chunkSize :: Natural, + slowPushDelay :: DiffTime, + requestId :: RequestId + } + +defaultNotificationSubsystemConfig :: RequestId -> NotificationSubsystemConfig +defaultNotificationSubsystemConfig reqId = + NotificationSubsystemConfig defaultFanoutLimit defaultChunkSize defaultSlowPushDelay reqId + +defaultFanoutLimit :: Range 1 HardTruncationLimit Int32 +defaultFanoutLimit = toRange (Proxy @HardTruncationLimit) + +defaultChunkSize :: Natural +defaultChunkSize = 128 + +defaultSlowPushDelay :: DiffTime +defaultSlowPushDelay = millisecondsToDiffTime 20 + +pushAsyncImpl :: + forall r. + ( Member GundeckAPIAccess r, + Member (Input NotificationSubsystemConfig) r, + Member P.Async r, + Member (Final IO) r, + Member P.TinyLog r + ) => + [Push] -> + Sem r (Async (Maybe ())) +pushAsyncImpl ps = async $ do + reqId <- inputs requestId + errorToIOFinal @SomeException (fromExceptionSem @SomeException $ pushImpl ps) >>= \case + Left e -> + P.err $ + Log.msg (Log.val "Error while pushing notifications") + . Log.field "requestId" reqId + . Log.field "error" (displayException e) + Right _ -> pure () + +pushImpl :: + forall r. + ( Member GundeckAPIAccess r, + Member (Input NotificationSubsystemConfig) r, + Member P.Async r + ) => + [Push] -> + Sem r () +pushImpl ps = do + currentFanoutLimit <- inputs fanoutLimit + pushChunkSize <- inputs chunkSize + + let pushes :: [[V2.Push]] = + mkPushes pushChunkSize $ + removeIfLargeFanout currentFanoutLimit ps + void $ + sequenceConcurrently $ + GundeckAPIAccess.pushV2 <$> pushes + +removeIfLargeFanout :: Range n m Int32 -> [Push] -> [Push] +removeIfLargeFanout limit = + filter \Push {_pushRecipients} -> + length _pushRecipients <= fromIntegral (fromRange limit) + +mkPushes :: Natural -> [Push] -> [[V2.Push]] +mkPushes chunkSize = map (map toV2Push) . chunkPushes chunkSize + +{-# INLINE [1] toV2Push #-} +toV2Push :: Push -> V2.Push +toV2Push p = + (V2.newPush p.pushOrigin (unsafeRange (Set.fromList recipients)) pload) + & V2.pushOriginConnection .~ _pushConn p + & V2.pushTransient .~ _pushTransient p + & maybe id (set V2.pushNativePriority) p._pushNativePriority + where + pload :: List1 Object + pload = List1.singleton (pushJson p) + recipients :: [V2.Recipient] + recipients = map toRecipient $ toList p._pushRecipients + toRecipient :: Recipient -> V2.Recipient + toRecipient r = + (recipient r._recipientUserId p._pushRoute) + { V2._recipientClients = r._recipientClients + } + +{-# INLINE [1] chunkPushes #-} +chunkPushes :: Natural -> [Push] -> [[Push]] +chunkPushes maxRecipients + | maxRecipients > 0 = go 0 [] + | otherwise = const [] + where + go _ [] [] = [] + go _ acc [] = [acc] + go n acc (y : ys) + | n >= maxRecipients = acc : go 0 [] (y : ys) + | otherwise = + let totalLength = (n + fromIntegral (length y._pushRecipients)) + in if totalLength > maxRecipients + then + let (y1, y2) = splitPush (maxRecipients - n) y + in go maxRecipients (y1 : acc) (y2 : ys) + else go totalLength (y : acc) ys + + -- n must be strictly > 0 and < length (_pushRecipients p) + splitPush :: Natural -> Push -> (Push, Push) + splitPush n p = + let (r1, r2) = splitAt (fromIntegral n) (toList p._pushRecipients) + in (p {_pushRecipients = fromJust $ nonEmpty r1}, p {_pushRecipients = fromJust $ nonEmpty r2}) + +pushSlowlyImpl :: + ( Member Delay r, + Member (Input NotificationSubsystemConfig) r, + Member GundeckAPIAccess r, + Member P.Async r + ) => + [Push] -> + Sem r () +pushSlowlyImpl ps = + for_ ps \p -> do + delay =<< inputs (diffTimeToFullMicroseconds . slowPushDelay) + pushImpl [p] diff --git a/libs/wire-subsystems/src/Wire/Rpc.hs b/libs/wire-subsystems/src/Wire/Rpc.hs new file mode 100644 index 00000000000..b7589d6128f --- /dev/null +++ b/libs/wire-subsystems/src/Wire/Rpc.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.Rpc + ( Rpc, + rpc, + rpcWithRetries, + runRpcWithHttp, + x3, + zUser, + expect, + ) +where + +import Bilge +import Bilge.RPC hiding (rpc) +import Bilge.Retry +import Control.Monad.Catch +import Control.Retry +import Data.ByteString.Conversion +import Data.Id +import Data.Text.Encoding (encodeUtf8) +import Imports +import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Types +import Polysemy +import Util.Options + +-- * Effect + +type ServiceName = LText + +data Rpc m a where + Rpc :: ServiceName -> Endpoint -> (Request -> Request) -> Rpc m (Response (Maybe LByteString)) + RpcWithRetries :: ServiceName -> Endpoint -> (Request -> Request) -> Rpc m (Response (Maybe LByteString)) + +makeSem ''Rpc + +runRpcWithHttp :: Member (Embed IO) r => Manager -> RequestId -> Sem (Rpc : r) a -> Sem r a +runRpcWithHttp mgr reqId = interpret $ \case + Rpc serviceName ep req -> + embed $ runHttpRpc mgr reqId $ rpcImpl serviceName ep req + RpcWithRetries serviceName ep req -> + embed $ runHttpRpc mgr reqId $ rpcWithRetriesImpl serviceName ep req + +rpcImpl :: ServiceName -> Endpoint -> (Request -> Request) -> HttpRpc (Response (Maybe LByteString)) +rpcImpl serviceName ep req = + rpc' serviceName empty $ + req + . Bilge.host (encodeUtf8 ep._host) + . Bilge.port ep._port + +rpcWithRetriesImpl :: ServiceName -> Endpoint -> (Request -> Request) -> HttpRpc (Response (Maybe LByteString)) +rpcWithRetriesImpl serviceName ep req = + recovering x3 rpcHandlers $ + const $ + rpcImpl serviceName ep req + +-- * Helpers + +x3 :: RetryPolicy +x3 = limitRetries 3 <> exponentialBackoff 100000 + +zUser :: UserId -> Request -> Request +zUser uid = header "Z-User" (toByteString' uid) + +expect :: [Status] -> Request -> Request +expect ss rq = rq {HTTP.checkResponse = check} + where + check rq' rs = do + let s = responseStatus rs + rs' = rs {responseBody = ()} + when (statusIsServerError s || s `notElem` ss) $ + throwM $ + HttpExceptionRequest rq' (HTTP.StatusCodeException rs' mempty) + +-- * Internals + +newtype HttpRpc a = HttpRpc {unHttpRpc :: ReaderT (Manager, RequestId) IO a} + deriving newtype + ( Functor, + Applicative, + Monad, + MonadIO, + MonadThrow, + MonadCatch, + MonadMask, + MonadReader (Manager, RequestId) + ) + +instance MonadHttp HttpRpc where + handleRequestWithCont :: Request -> (Response BodyReader -> IO a) -> HttpRpc a + handleRequestWithCont req responseConsumer = do + mgr <- asks fst + runHttpT mgr $ handleRequestWithCont req responseConsumer + +instance HasRequestId HttpRpc where + getRequestId = asks snd + +runHttpRpc :: Manager -> RequestId -> HttpRpc a -> IO a +runHttpRpc mgr reqId = + flip runReaderT (mgr, reqId) . unHttpRpc diff --git a/libs/wire-subsystems/test/Main.hs b/libs/wire-subsystems/test/Main.hs new file mode 100644 index 00000000000..96392ca769d --- /dev/null +++ b/libs/wire-subsystems/test/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Imports +import Spec +import Test.Hspec + +main :: IO () +main = hspec Spec.spec diff --git a/libs/wire-subsystems/test/unit/Spec.hs b/libs/wire-subsystems/test/unit/Spec.hs new file mode 100644 index 00000000000..5416ef6a866 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs new file mode 100644 index 00000000000..4677a0d1bfd --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -0,0 +1,358 @@ +module Wire.NotificationSubsystem.InterpreterSpec (spec) where + +import Bilge (RequestId (..)) +import Control.Concurrent.Async (async, wait) +import Control.Exception (throwIO) +import Data.Data (Proxy (Proxy)) +import Data.List.NonEmpty (NonEmpty ((:|)), fromList) +import Data.List1 qualified as List1 +import Data.Range (fromRange, toRange) +import Data.Set qualified as Set +import Data.Time.Clock.DiffTime +import Gundeck.Types.Push.V2 qualified as V2 +import Imports +import Numeric.Natural (Natural) +import Polysemy +import Polysemy.Async (Async, asyncToIOFinal, await) +import Polysemy.Input +import Polysemy.TinyLog qualified as P +import System.Timeout (timeout) +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Wire.GundeckAPIAccess +import Wire.GundeckAPIAccess qualified as GundeckAPIAccess +import Wire.NotificationSubsystem +import Wire.NotificationSubsystem.Interpreter +import Wire.Sem.Delay +import Wire.Sem.Logger.TinyLog + +spec :: Spec +spec = describe "NotificationSubsystem.Interpreter" do + describe "pushImpl" do + it "chunks and sends all notifications" do + let mockConfig = + NotificationSubsystemConfig + { fanoutLimit = toRange $ Proxy @30, + chunkSize = 12, + slowPushDelay = 0, + requestId = RequestId "N/A" + } + + connId2 <- generate arbitrary + origin2 <- generate arbitrary + (user1, user21, user22) <- generate arbitrary + (payload1, payload2) <- generate $ resize 1 arbitrary + clients1 <- generate $ resize 3 arbitrary + lotOfRecipients <- generate $ resize 24 arbitrary + apsData <- generate arbitrary + let push1 = + Push + { _pushConn = Nothing, + _pushTransient = True, + _pushRoute = V2.RouteDirect, + _pushNativePriority = Nothing, + pushOrigin = Nothing, + _pushRecipients = Recipient user1 (V2.RecipientClientsSome clients1) :| [], + pushJson = payload1, + _pushApsData = Nothing + } + push2 = + Push + { _pushConn = Just connId2, + _pushTransient = True, + _pushRoute = V2.RouteAny, + _pushNativePriority = Just V2.LowPriority, + pushOrigin = Just origin2, + _pushRecipients = + Recipient user21 V2.RecipientClientsAll + :| [Recipient user22 V2.RecipientClientsAll], + pushJson = payload2, + _pushApsData = Just apsData + } + duplicatePush = push2 + duplicatePushWithPush1Recipients = push2 {_pushRecipients = _pushRecipients push1} + largePush = push2 {_pushRecipients = lotOfRecipients} + pushes :: [Push] = + [ push1, + push2, + duplicatePush, + duplicatePushWithPush1Recipients, + largePush + ] + + (_, actualPushes) <- runMockStack mockConfig $ pushImpl pushes + + let expectedPushes = + map toV2Push + <$> + -- It's ok to use chunkPushes here because we're testing + -- that separately + chunkPushes mockConfig.chunkSize pushes + actualPushes `shouldBe` expectedPushes + + it "respects maximum fanout limit" do + let mockConfig = + NotificationSubsystemConfig + { fanoutLimit = toRange $ Proxy @30, + chunkSize = 12, + slowPushDelay = 0, + requestId = RequestId "N/A" + } + + connId2 <- generate arbitrary + origin2 <- generate arbitrary + (user21, user22) <- generate arbitrary + (payload1, payload2) <- generate $ resize 1 arbitrary + lotOfRecipients <- fromList <$> replicateM 31 (generate arbitrary) + apsData <- generate arbitrary + let pushBiggerThanFanoutLimit = + Push + { _pushConn = Nothing, + _pushTransient = True, + _pushRoute = V2.RouteDirect, + _pushNativePriority = Nothing, + pushOrigin = Nothing, + _pushRecipients = lotOfRecipients, + pushJson = payload1, + _pushApsData = Nothing + } + pushSmallerThanFanoutLimit = + Push + { _pushConn = Just connId2, + _pushTransient = True, + _pushRoute = V2.RouteAny, + _pushNativePriority = Just V2.LowPriority, + pushOrigin = Just origin2, + _pushRecipients = + Recipient user21 V2.RecipientClientsAll + :| [Recipient user22 V2.RecipientClientsAll], + pushJson = payload2, + _pushApsData = Just apsData + } + pushes = + [ pushBiggerThanFanoutLimit, + pushSmallerThanFanoutLimit + ] + + (_, actualPushes) <- runMockStack mockConfig $ pushImpl pushes + + let expectedPushes = + map toV2Push + <$> + -- It's ok to use chunkPushes here because we're testing + -- that separately + chunkPushes mockConfig.chunkSize [pushSmallerThanFanoutLimit] + actualPushes `shouldBe` expectedPushes + + describe "pushSlowlyImpl" do + it "sends each push one by one with a delay" do + let mockConfig = + NotificationSubsystemConfig + { fanoutLimit = toRange $ Proxy @30, + chunkSize = 12, + slowPushDelay = 1, + requestId = RequestId "N/A" + } + + connId2 <- generate arbitrary + origin2 <- generate arbitrary + (user1, user21, user22) <- generate arbitrary + (payload1, payload2) <- generate $ resize 1 arbitrary + clients1 <- generate $ resize 3 arbitrary + let push1 = + Push + { _pushConn = Nothing, + _pushTransient = True, + _pushRoute = V2.RouteDirect, + _pushNativePriority = Nothing, + pushOrigin = Nothing, + _pushRecipients = Recipient user1 (V2.RecipientClientsSome clients1) :| [], + pushJson = payload1, + _pushApsData = Nothing + } + push2 = + Push + { _pushConn = Just connId2, + _pushTransient = True, + _pushRoute = V2.RouteAny, + _pushNativePriority = Just V2.LowPriority, + pushOrigin = Just origin2, + _pushRecipients = + Recipient user21 V2.RecipientClientsAll + :| [Recipient user22 V2.RecipientClientsAll], + pushJson = payload2, + _pushApsData = Nothing + } + pushes = [push1, push2] + + actualPushesRef <- newIORef [] + delayControl <- newEmptyMVar + slowPushThread <- + async $ + runMockStackWithControlledDelay mockConfig delayControl actualPushesRef $ + pushSlowlyImpl pushes + + putMVar delayControl (diffTimeToFullMicroseconds mockConfig.slowPushDelay) + actualPushes1 <- timeout 100_000 $ (waitUntilPushes actualPushesRef 1) + actualPushes1 `shouldBe` Just [[toV2Push push1]] + + putMVar delayControl (diffTimeToFullMicroseconds mockConfig.slowPushDelay) + actualPushes2 <- timeout 100_000 $ (waitUntilPushes actualPushesRef 2) + actualPushes2 `shouldBe` Just [[toV2Push push1], [toV2Push push2]] + + timeout 100_000 (wait slowPushThread) `shouldReturn` Just () + + describe "pushAsyncImpl" do + it "logs errors" do + let mockConfig = + NotificationSubsystemConfig + { fanoutLimit = toRange $ Proxy @30, + chunkSize = 12, + slowPushDelay = 1, + requestId = RequestId "N/A" + } + + user1 <- generate arbitrary + payload1 <- generate $ resize 1 arbitrary + clients1 <- generate $ resize 3 arbitrary + let push1 = + Push + { _pushConn = Nothing, + _pushTransient = True, + _pushRoute = V2.RouteDirect, + _pushNativePriority = Nothing, + pushOrigin = Nothing, + _pushRecipients = Recipient user1 (V2.RecipientClientsSome clients1) :| [], + pushJson = payload1, + _pushApsData = Nothing + } + pushes = [push1] + (_, attemptedPushes, logs) <- runMockStackAsync mockConfig $ do + thread <- pushAsyncImpl pushes + await thread + + attemptedPushes `shouldBe` [[toV2Push push1]] + map fst logs `shouldBe` [Error] + cs (head (map snd logs)) `shouldContain` "error=TestException" + + describe "toV2Push" do + it "does the transformation correctly" $ property \(pushToUser :: Push) -> + let v2Push = toV2Push pushToUser + in -- Statically determined + v2Push._pushConnections === mempty + .&&. v2Push._pushNativeIncludeOrigin === True + .&&. v2Push._pushNativeEncrypt === True + .&&. v2Push._pushNativeAps === Nothing + -- derived from pushToUser + .&&. v2Push._pushOrigin === pushToUser.pushOrigin + .&&. v2Push._pushOriginConnection === pushToUser._pushConn + .&&. v2Push._pushTransient === pushToUser._pushTransient + .&&. v2Push._pushNativePriority === fromMaybe V2.HighPriority pushToUser._pushNativePriority + .&&. v2Push._pushPayload === List1.singleton (pushJson pushToUser) + .&&. Set.map V2._recipientRoute (fromRange v2Push._pushRecipients) === Set.singleton pushToUser._pushRoute + .&&. Set.map (\r -> Recipient r._recipientId r._recipientClients) (fromRange v2Push._pushRecipients) + === Set.fromList (toList pushToUser._pushRecipients) + + describe "chunkPushes" do + it "allows empty push" $ property \limit -> + chunkPushes limit [] === [] + it "produces no empty chunks" $ property \limit pushes -> + not (any null (chunkPushes limit pushes)) + it "allows concatenation if number was non-zero" $ property \(Positive limit) pushes -> + (chunkPushes limit pushes >>= reverse >>= normalisePush) + === (pushes >>= normalisePush) + it "respects the chunkSize limit" $ property \limit pushes -> + all ((<= limit) . sizeOfChunks) (chunkPushes limit pushes) + +runMockStack :: NotificationSubsystemConfig -> Sem [Input NotificationSubsystemConfig, Delay, GundeckAPIAccess, Embed IO, Async, Final IO] a -> IO (a, [[V2.Push]]) +runMockStack mockConfig action = do + actualPushesRef <- newIORef [] + x <- + runFinal + . asyncToIOFinal + . embedToFinal @IO + . runGundeckAPIAccessIORef actualPushesRef + . runDelayInstantly + . runInputConst mockConfig + $ action + (x,) <$> readIORef actualPushesRef + +runMockStackAsync :: NotificationSubsystemConfig -> Sem [Input NotificationSubsystemConfig, Delay, GundeckAPIAccess, P.TinyLog, Embed IO, Async, Final IO] a -> IO (a, [[V2.Push]], [(Level, LByteString)]) +runMockStackAsync mockConfig action = do + actualPushesRef <- newIORef [] + lr <- newLogRecorder + x <- + runFinal + . asyncToIOFinal + . embedToFinal @IO + . recordLogs lr + . runGundeckAPIAccessFailure actualPushesRef + . runDelayInstantly + . runInputConst mockConfig + $ action + (x,,) <$> readIORef actualPushesRef <*> readIORef lr.recordedLogs + +runMockStackWithControlledDelay :: + NotificationSubsystemConfig -> + MVar Int -> + IORef [[V2.Push]] -> + Sem [Input NotificationSubsystemConfig, Delay, GundeckAPIAccess, Embed IO, Async, Final IO] a -> + IO a +runMockStackWithControlledDelay mockConfig delayControl actualPushesRef = do + runFinal + . asyncToIOFinal + . embedToFinal @IO + . runGundeckAPIAccessIORef actualPushesRef + . runControlledDelay delayControl + . runInputConst mockConfig + +runGundeckAPIAccessFailure :: Member (Embed IO) r => IORef [[V2.Push]] -> Sem (GundeckAPIAccess : r) a -> Sem r a +runGundeckAPIAccessFailure pushesRef = + interpret $ \action -> do + case action of + PushV2 pushes -> liftIO $ do + modifyIORef pushesRef (<> [pushes]) + throwIO TestException + GundeckAPIAccess.UserDeleted uid -> + liftIO $ expectationFailure $ "Unexpected call to GundeckAPI: UserDeleted " <> show uid + GundeckAPIAccess.UnregisterPushClient uid cid -> + liftIO $ expectationFailure $ "Unexpected call to GundeckAPI: UnregisterPushClient " <> show uid <> " " <> show cid + GundeckAPIAccess.GetPushTokens uid -> do + liftIO $ expectationFailure $ "Unexpected call to GundeckAPI: GetPushTokens " <> show uid + error "impossible" + +data TestException = TestException + deriving (Show) + +instance Exception TestException + +runGundeckAPIAccessIORef :: Member (Embed IO) r => IORef [[V2.Push]] -> Sem (GundeckAPIAccess : r) a -> Sem r a +runGundeckAPIAccessIORef pushesRef = + interpret \case + PushV2 pushes -> modifyIORef pushesRef (<> [pushes]) + GundeckAPIAccess.UserDeleted uid -> + liftIO $ expectationFailure $ "Unexpected call to GundeckAPI: UserDeleted " <> show uid + GundeckAPIAccess.UnregisterPushClient uid cid -> + liftIO $ expectationFailure $ "Unexpected call to GundeckAPI: UnregisterPushClient " <> show uid <> " " <> show cid + GundeckAPIAccess.GetPushTokens uid -> do + liftIO $ expectationFailure $ "Unexpected call to GundeckAPI: GetPushTokens " <> show uid + error "impossible" + +waitUntilPushes :: IORef [a] -> Int -> IO [a] +waitUntilPushes pushesRef n = do + ps <- readIORef pushesRef + -- This thread delay ensures that this function yields to other work as it + -- is really just waiting for other threads to do work. + if length ps >= n + then pure ps + else threadDelay 1000 >> waitUntilPushes pushesRef n + +normalisePush :: Push -> [Push] +normalisePush p = + map + (\r -> p {_pushRecipients = r :| []}) + (toList (_pushRecipients p)) + +sizeOfChunks :: [Push] -> Natural +sizeOfChunks = fromIntegral . sum . map (length . _pushRecipients) diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal new file mode 100644 index 00000000000..a631c0e2737 --- /dev/null +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -0,0 +1,132 @@ +cabal-version: 3.0 +name: wire-subsystems +version: 0.1.0 +description: Subsystems of the Wire collaboration platform +category: Network +author: Wire Swiss GmbH +maintainer: Wire Swiss GmbH +copyright: (c) 2020 Wire Swiss GmbH +license: AGPL-3.0-only +license-file: LICENSE +build-type: Simple + +common common-all + default-language: Haskell2010 + ghc-options: + -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + -Wredundant-constraints + + default-extensions: + AllowAmbiguousTypes + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + NumericUnderscores + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + PackageImports + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + UndecidableInstances + ViewPatterns + +library + import: common-all + + -- cabal-fmt: expand src + exposed-modules: + Wire.GundeckAPIAccess + Wire.NotificationSubsystem + Wire.NotificationSubsystem.Interpreter + Wire.Rpc + + hs-source-dirs: src + build-depends: + , aeson + , async + , base + , bilge + , bytestring-conversion + , containers + , exceptions + , extended + , gundeck-types + , http-client + , http-types + , imports + , lens + , polysemy + , polysemy-wire-zoo + , QuickCheck + , retry + , text + , tinylog + , types-common + , wire-api + + default-language: GHC2021 + +test-suite wire-subsystems-tests + import: common-all + type: exitcode-stdio-1.0 + default-language: GHC2021 + hs-source-dirs: test/unit + main-is: ../Main.hs + + -- cabal-fmt: expand test/unit + other-modules: + Spec + Wire.NotificationSubsystem.InterpreterSpec + + build-tool-depends: hspec-discover:hspec-discover + build-depends: + , aeson + , async + , base + , bilge + , bytestring + , containers + , extended + , gundeck-types + , hspec + , imports + , polysemy + , polysemy-wire-zoo + , QuickCheck + , quickcheck-instances + , types-common + , wire-api + , wire-subsystems diff --git a/nix/local-haskell-packages.nix b/nix/local-haskell-packages.nix index 351f57b7273..289d38bdd7c 100644 --- a/nix/local-haskell-packages.nix +++ b/nix/local-haskell-packages.nix @@ -32,6 +32,7 @@ wire-api-federation = hself.callPackage ../libs/wire-api-federation/default.nix { inherit gitignoreSource; }; wire-api = hself.callPackage ../libs/wire-api/default.nix { inherit gitignoreSource; }; wire-message-proto-lens = hself.callPackage ../libs/wire-message-proto-lens/default.nix { inherit gitignoreSource; }; + wire-subsystems = hself.callPackage ../libs/wire-subsystems/default.nix { inherit gitignoreSource; }; zauth = hself.callPackage ../libs/zauth/default.nix { inherit gitignoreSource; }; background-worker = hself.callPackage ../services/background-worker/default.nix { inherit gitignoreSource; }; brig = hself.callPackage ../services/brig/default.nix { inherit gitignoreSource; }; diff --git a/nix/manual-overrides.nix b/nix/manual-overrides.nix index 90db54af1d0..51d0f437aea 100644 --- a/nix/manual-overrides.nix +++ b/nix/manual-overrides.nix @@ -42,6 +42,7 @@ hself: hsuper: { # ------------------------------------ bytestring-conversion = hlib.markUnbroken hsuper.bytestring-conversion; template = hlib.markUnbroken hsuper.template; + polysemy-test = hlib.markUnbroken hsuper.polysemy-test; # ----------------- # version overrides diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 0d0487355ef..5c86b737589 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -125,7 +125,6 @@ library Brig.Effects.BlacklistStore.Cassandra Brig.Effects.CodeStore Brig.Effects.CodeStore.Cassandra - Brig.Effects.Delay Brig.Effects.FederationConfigStore Brig.Effects.FederationConfigStore.Cassandra Brig.Effects.GalleyProvider @@ -134,10 +133,6 @@ library Brig.Effects.PasswordResetStore Brig.Effects.PasswordResetStore.CodeStore Brig.Effects.PublicKeyBundle - Brig.Effects.RPC - Brig.Effects.RPC.IO - Brig.Effects.ServiceRPC - Brig.Effects.ServiceRPC.IO Brig.Effects.SFT Brig.Effects.UserPendingActivationStore Brig.Effects.UserPendingActivationStore.Cassandra @@ -315,7 +310,9 @@ library , openapi3 , optparse-applicative >=0.11 , polysemy + , polysemy-conc , polysemy-plugin + , polysemy-time , polysemy-wire-zoo , proto-lens >=0.1 , random-shuffle >=0.0.3 @@ -363,6 +360,7 @@ library , wai-utilities >=0.16 , wire-api , wire-api-federation + , wire-subsystems , yaml >=0.8.22 , zauth >=0.10.3 diff --git a/services/brig/default.nix b/services/brig/default.nix index f8250c09f11..6c13f6194ea 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -89,7 +89,9 @@ , pem , pipes , polysemy +, polysemy-conc , polysemy-plugin +, polysemy-time , polysemy-wire-zoo , postie , process @@ -155,6 +157,7 @@ , warp-tls , wire-api , wire-api-federation +, wire-subsystems , yaml , zauth }: @@ -236,7 +239,9 @@ mkDerivation { openapi3 optparse-applicative polysemy + polysemy-conc polysemy-plugin + polysemy-time polysemy-wire-zoo proto-lens random-shuffle @@ -284,6 +289,7 @@ mkDerivation { wai-utilities wire-api wire-api-federation + wire-subsystems yaml zauth ]; diff --git a/services/brig/src/Brig/API/Auth.hs b/services/brig/src/Brig/API/Auth.hs index 976cd2ab417..6b0d93aa56e 100644 --- a/services/brig/src/Brig/API/Auth.hs +++ b/services/brig/src/Brig/API/Auth.hs @@ -43,13 +43,19 @@ import Network.HTTP.Types import Network.Wai.Utilities ((!>>)) import Network.Wai.Utilities.Error qualified as Wai import Polysemy +import Polysemy.TinyLog (TinyLog) import Wire.API.User import Wire.API.User.Auth hiding (access) import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.ReAuth import Wire.API.User.Auth.Sso +import Wire.NotificationSubsystem accessH :: + ( Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r + ) => Maybe ClientId -> [Either Text SomeUserToken] -> Maybe (Either Text SomeAccessToken) -> @@ -61,22 +67,34 @@ accessH mcid ut' mat' = do >>= either (uncurry (access mcid)) (uncurry (access mcid)) access :: - (TokenPair u a) => + ( TokenPair u a, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r + ) => Maybe ClientId -> NonEmpty (Token u) -> Maybe (Token a) -> Handler r SomeAccess access mcid t mt = traverse mkUserTokenCookie - =<< wrapHttpClientE (Auth.renewAccess (List1 t) mt mcid) !>> zauthError + =<< Auth.renewAccess (List1 t) mt mcid !>> zauthError -sendLoginCode :: SendLoginCode -> Handler r LoginCodeTimeout +sendLoginCode :: (Member TinyLog r) => SendLoginCode -> Handler r LoginCodeTimeout sendLoginCode (SendLoginCode phone call force) = do checkAllowlist (Right phone) - c <- wrapClientE (Auth.sendLoginCode phone call force) !>> sendLoginCodeError + c <- Auth.sendLoginCode phone call force !>> sendLoginCodeError pure $ LoginCodeTimeout (pendingLoginTimeout c) -login :: (Member GalleyProvider r) => Login -> Maybe Bool -> Handler r SomeAccess +login :: + ( Member GalleyProvider r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r + ) => + Login -> + Maybe Bool -> + Handler r SomeAccess login l (fromMaybe False -> persist) = do let typ = if persist then PersistentCookie else SessionCookie c <- Auth.login l typ !>> loginError @@ -94,7 +112,7 @@ logoutH uts' mat' = do logout :: TokenPair u a => NonEmpty (Token u) -> Maybe (Token a) -> Handler r () logout _ Nothing = throwStd authMissingToken -logout uts (Just at) = wrapHttpClientE $ Auth.logout (List1 uts) at !>> zauthError +logout uts (Just at) = Auth.logout (List1 uts) at !>> zauthError changeSelfEmailH :: Member BlacklistStore r => @@ -117,32 +135,46 @@ validateCredentials :: Handler r UserId validateCredentials _ Nothing = throwStd missingAccessToken validateCredentials uts mat = - fst <$> wrapHttpClientE (Auth.validateTokens (List1 uts) mat) !>> zauthError + fst <$> Auth.validateTokens (List1 uts) mat !>> zauthError listCookies :: Local UserId -> Maybe (CommaSeparatedList CookieLabel) -> Handler r CookieList listCookies lusr (fold -> labels) = CookieList <$> wrapClientE (Auth.listCookies (tUnqualified lusr) (toList labels)) -removeCookies :: Local UserId -> RemoveCookies -> Handler r () +removeCookies :: (Member TinyLog r) => Local UserId -> RemoveCookies -> Handler r () removeCookies lusr (RemoveCookies pw lls ids) = - wrapClientE (Auth.revokeAccess (tUnqualified lusr) pw ids lls) !>> authError + Auth.revokeAccess (tUnqualified lusr) pw ids lls !>> authError -legalHoldLogin :: (Member GalleyProvider r) => LegalHoldLogin -> Handler r SomeAccess +legalHoldLogin :: + ( Member GalleyProvider r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + LegalHoldLogin -> + Handler r SomeAccess legalHoldLogin lhl = do let typ = PersistentCookie -- Session cookie isn't a supported use case here c <- Auth.legalHoldLogin lhl typ !>> legalHoldLoginError traverse mkUserTokenCookie c -ssoLogin :: SsoLogin -> Maybe Bool -> Handler r SomeAccess +ssoLogin :: + ( Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r + ) => + SsoLogin -> + Maybe Bool -> + Handler r SomeAccess ssoLogin l (fromMaybe False -> persist) = do let typ = if persist then PersistentCookie else SessionCookie - c <- wrapHttpClientE (Auth.ssoLogin l typ) !>> loginError + c <- Auth.ssoLogin l typ !>> loginError traverse mkUserTokenCookie c -getLoginCode :: Phone -> Handler r PendingLoginCode +getLoginCode :: (Member TinyLog r) => Phone -> Handler r PendingLoginCode getLoginCode phone = do - code <- lift $ wrapClient $ Auth.lookupLoginCode phone + code <- lift $ Auth.lookupLoginCode phone maybe (throwStd loginCodeNotFound) pure code reauthenticate :: Member GalleyProvider r => UserId -> ReAuthUser -> Handler r () diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 2e7c16c1bd7..529b81ad0e9 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -89,7 +89,8 @@ import Data.Set qualified as Set import Imports import Network.HTTP.Types.Method (StdMethod) import Network.Wai.Utilities -import Polysemy (Member) +import Polysemy +import Polysemy.TinyLog import Servant (Link, ToHttpApiData (toUrlPiece)) import System.Logger.Class (field, msg, val, (~~)) import System.Logger.Class qualified as Log @@ -105,6 +106,7 @@ import Wire.API.User.Client import Wire.API.User.Client.DPoPAccessToken import Wire.API.User.Client.Prekey import Wire.API.UserMap (QualifiedUserMap (QualifiedUserMap, qualifiedUserMap), UserMap (userMap)) +import Wire.NotificationSubsystem import Wire.Sem.Concurrency import Wire.Sem.FromUTC (FromUTC (fromUTCTime)) import Wire.Sem.Now as Now @@ -153,7 +155,11 @@ lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError (AppT r) (UserMap ( lookupLocalPubClientsBulk = lift . wrapClient . Data.lookupPubClientsBulk addClient :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => UserId -> Maybe ConnId -> NewClient -> @@ -164,7 +170,11 @@ addClient = addClientWithReAuthPolicy Data.reAuthForNewClients -- a superset of the clients known to galley. addClientWithReAuthPolicy :: forall r. - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => Data.ReAuthPolicy -> UserId -> Maybe ConnId -> @@ -191,8 +201,8 @@ addClientWithReAuthPolicy policy u con new = do lift $ do for_ old $ execDelete u con liftSem $ GalleyProvider.newClient u (clientId clt) - wrapHttp $ Intra.onClientEvent u con (ClientAdded u clt) - when (clientType clt == LegalHoldClientType) $ wrapHttpClient $ Intra.onUserEvent u con (UserLegalHoldEnabled u) + liftSem $ Intra.onClientEvent u con (ClientAdded u clt) + when (clientType clt == LegalHoldClientType) $ liftSem $ Intra.onUserEvent u con (UserLegalHoldEnabled u) when (count > 1) $ for_ (userEmail usr) $ \email -> @@ -462,9 +472,16 @@ pubClient c = pubClientClass = clientClass c } -legalHoldClientRequested :: UserId -> LegalHoldClientRequest -> (AppT r) () +legalHoldClientRequested :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + LegalHoldClientRequest -> + AppT r () legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPrekey') = - wrapHttpClient $ Intra.onUserEvent targetUser Nothing lhClientEvent + liftSem $ Intra.onUserEvent targetUser Nothing lhClientEvent where clientId :: ClientId clientId = clientIdFromPrekey $ unpackLastPrekey lastPrekey' @@ -473,14 +490,20 @@ legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPreke lhClientEvent :: UserEvent lhClientEvent = LegalHoldClientRequested eventData -removeLegalHoldClient :: UserId -> (AppT r) () +removeLegalHoldClient :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + AppT r () removeLegalHoldClient uid = do clients <- wrapClient $ Data.lookupClients uid -- Should only be one; but just in case we'll treat it as a list let legalHoldClients = filter ((== LegalHoldClientType) . clientType) clients -- maybe log if this isn't the case forM_ legalHoldClients (execDelete uid Nothing) - wrapHttpClient $ Intra.onUserEvent uid Nothing (UserLegalHoldDisabled uid) + liftSem $ Intra.onUserEvent uid Nothing (UserLegalHoldDisabled uid) createAccessToken :: (Member JwtTools r, Member Now r, Member PublicKeyBundle r) => diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 88484ca4480..7debfb2ed6e 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -56,7 +56,8 @@ import Data.Qualified import Data.Range import Data.UUID.V4 qualified as UUID import Imports -import Polysemy (Member) +import Polysemy +import Polysemy.TinyLog import System.Logger.Class qualified as Log import System.Logger.Message import Wire.API.Connection hiding (relationWithHistory) @@ -64,6 +65,7 @@ import Wire.API.Conversation hiding (Member) import Wire.API.Error import Wire.API.Error.Brig qualified as E import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) +import Wire.NotificationSubsystem ensureNotSameTeam :: Member GalleyProvider r => Local UserId -> Local UserId -> (ConnectionM r) () ensureNotSameTeam self target = do @@ -74,7 +76,10 @@ ensureNotSameTeam self target = do createConnection :: ( Member FederationConfigStore r, - Member GalleyProvider r + Member GalleyProvider r, + Member NotificationSubsystem r, + Member TinyLog r, + Member (Embed HttpClientIO) r ) => Local UserId -> ConnId -> @@ -89,7 +94,12 @@ createConnection self con target = do target createConnectionToLocalUser :: - Member GalleyProvider r => + forall r. + ( Member GalleyProvider r, + Member NotificationSubsystem r, + Member TinyLog r, + Member (Embed HttpClientIO) r + ) => Local UserId -> ConnId -> Local UserId -> @@ -121,7 +131,7 @@ createConnectionToLocalUser self conn target = do ConnectionUpdated o2s' (ucStatus <$> o2s) <$> wrapClient (Data.lookupName (tUnqualified self)) let e2s = ConnectionUpdated s2o' (ucStatus <$> s2o) Nothing - mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] + liftSem $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] pure s2o' update :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (ResponseForExistedCreated UserConnection) @@ -158,7 +168,7 @@ createConnectionToLocalUser self conn target = do ConnectionUpdated o2s' (Just $ ucStatus o2s) <$> Data.lookupName (tUnqualified self) let e2s = ConnectionUpdated s2o' (Just $ ucStatus s2o) Nothing - lift $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] + lift $ liftSem $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] pure $ Existed s2o' resend :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (ResponseForExistedCreated UserConnection) @@ -205,7 +215,11 @@ checkLegalholdPolicyConflict uid1 uid2 = do oneway status2 status1 updateConnection :: - Member FederationConfigStore r => + ( Member FederationConfigStore r, + Member NotificationSubsystem r, + Member TinyLog r, + Member (Embed HttpClientIO) r + ) => Local UserId -> Qualified UserId -> Relation -> @@ -225,6 +239,11 @@ updateConnection self other newStatus conn = -- because a connection between two team members can not exist in the first place. -- {#RefConnectionTeam} updateConnectionToLocalUser :: + forall r. + ( Member NotificationSubsystem r, + Member TinyLog r, + Member (Embed HttpClientIO) r + ) => -- | From Local UserId -> -- | To @@ -279,7 +298,7 @@ updateConnectionToLocalUser self other newStatus conn = do -- invalid _ -> throwE $ InvalidTransition (tUnqualified self) let s2oUserConn = s2o' - lift . for_ s2oUserConn $ \c -> + lift . liftSem . for_ s2oUserConn $ \c -> let e2s = ConnectionUpdated c (Just $ ucStatus s2o) Nothing in Intra.onConnectionEvent (tUnqualified self) conn e2s pure s2oUserConn @@ -304,7 +323,7 @@ updateConnectionToLocalUser self other newStatus conn = do e2o <- ConnectionUpdated o2s' (Just $ ucStatus o2s) <$> wrapClient (Data.lookupName (tUnqualified self)) - Intra.onConnectionEvent (tUnqualified self) conn e2o + liftSem $ Intra.onConnectionEvent (tUnqualified self) conn e2o lift . wrapClient $ Just <$> Data.updateConnection s2o AcceptedWithHistory block :: UserConnection -> ExceptT ConnectionError (AppT r) (Maybe UserConnection) @@ -312,7 +331,7 @@ updateConnectionToLocalUser self other newStatus conn = do Log.info $ logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Blocking connection") - traverse_ (wrapHttp . Intra.blockConv self conn) (ucConvId s2o) + traverse_ (Intra.blockConv self conn) (ucConvId s2o) wrapClient $ Just <$> Data.updateConnection s2o BlockedWithHistory unblock :: UserConnection -> UserConnection -> Relation -> ExceptT ConnectionError (AppT r) (Maybe UserConnection) @@ -323,7 +342,7 @@ updateConnectionToLocalUser self other newStatus conn = do lift . Log.info $ logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Unblocking connection") - cnv <- lift $ traverse (wrapHttp . Intra.unblockConv self conn) (ucConvId s2o) + cnv <- lift $ traverse (Intra.unblockConv self conn) (ucConvId s2o) when (ucStatus o2s == Sent && new == Accepted) . lift $ do o2s' <- wrapClient $ @@ -335,7 +354,7 @@ updateConnectionToLocalUser self other newStatus conn = do ConnectionUpdated o2s' (Just $ ucStatus o2s) <$> Data.lookupName (tUnqualified self) -- TODO: is this correct? shouldnt o2s be sent to other? - Intra.onConnectionEvent (tUnqualified self) conn e2o + liftSem $ Intra.onConnectionEvent (tUnqualified self) conn e2o lift . wrapClient $ Just <$> Data.updateConnection s2o (mkRelationWithHistory (error "impossible") new) cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (Maybe UserConnection) @@ -344,10 +363,10 @@ updateConnectionToLocalUser self other newStatus conn = do logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) . msg (val "Cancelling connection") lfrom <- qualifyLocal (ucFrom s2o) - lift $ traverse_ (wrapHttp . Intra.blockConv lfrom conn) (ucConvId s2o) + lift $ traverse_ (Intra.blockConv lfrom conn) (ucConvId s2o) o2s' <- lift . wrapClient $ Data.updateConnection o2s CancelledWithHistory let e2o = ConnectionUpdated o2s' (Just $ ucStatus o2s) Nothing - lift $ Intra.onConnectionEvent (tUnqualified self) conn e2o + lift $ liftSem $ Intra.onConnectionEvent (tUnqualified self) conn e2o change s2o Cancelled change :: UserConnection -> Relation -> ExceptT ConnectionError (AppT r) (Maybe UserConnection) @@ -383,6 +402,10 @@ mkRelationWithHistory oldRel = \case updateConnectionInternal :: forall r. + ( Member NotificationSubsystem r, + Member TinyLog r, + Member (Embed HttpClientIO) r + ) => UpdateConnectionsInternal -> ExceptT ConnectionError (AppT r) () updateConnectionInternal = \case @@ -411,10 +434,10 @@ updateConnectionInternal = \case o2s <- localConnection other self for_ [s2o, o2s] $ \(uconn :: UserConnection) -> lift $ do lfrom <- qualifyLocal (ucFrom uconn) - traverse_ (wrapHttp . Intra.blockConv lfrom Nothing) (ucConvId uconn) + traverse_ (Intra.blockConv lfrom Nothing) (ucConvId uconn) uconn' <- wrapClient $ Data.updateConnection uconn (mkRelationWithHistory (ucStatus uconn) MissingLegalholdConsent) let ev = ConnectionUpdated uconn' (Just $ ucStatus uconn) Nothing - Intra.onConnectionEvent (tUnqualified self) Nothing ev + liftSem $ Intra.onConnectionEvent (tUnqualified self) Nothing ev removeLHBlocksInvolving :: Local UserId -> ExceptT ConnectionError (AppT r) () removeLHBlocksInvolving self = @@ -446,7 +469,7 @@ updateConnectionInternal = \case unblockDirected :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) () unblockDirected uconn uconnRev = do lfrom <- qualifyLocal (ucFrom uconnRev) - void . lift . for (ucConvId uconn) $ wrapHttp . Intra.unblockConv lfrom Nothing + void . lift . for (ucConvId uconn) $ Intra.unblockConv lfrom Nothing uconnRevRel :: RelationWithHistory <- relationWithHistory lfrom (ucTo uconnRev) uconnRev' <- lift . wrapClient $ Data.updateConnection uconnRev (undoRelationHistory uconnRevRel) connName <- lift . wrapClient $ Data.lookupName (tUnqualified lfrom) @@ -456,7 +479,7 @@ updateConnectionInternal = \case ucPrev = Just $ ucStatus uconnRev, ucName = connName } - lift $ Intra.onConnectionEvent (ucFrom uconn) Nothing connEvent + lift $ liftSem $ Intra.onConnectionEvent (ucFrom uconn) Nothing connEvent relationWithHistory :: Local UserId -> diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 8d75155198a..96c446d603a 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -48,6 +48,7 @@ import Wire.API.Federation.API.Brig import Wire.API.Routes.Internal.Galley.ConversationsIntra (Actor (..), DesiredMembership (..), UpsertOne2OneConversationRequest (..), UpsertOne2OneConversationResponse (uuorConvId)) import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) import Wire.API.User +import Wire.NotificationSubsystem data LocalConnectionAction = LocalConnect @@ -145,6 +146,7 @@ updateOne2OneConv lUsr _mbConn remoteUser mbConvId rel actor = do -- -- Returns the connection, and whether it was updated or not. transitionTo :: + (Member NotificationSubsystem r) => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -185,12 +187,18 @@ transitionTo self mzcon other (Just connection) (Just rel) actor = lift $ do pure (Existed connection', True) -- | Send an event to the local user when the state of a connection changes. -pushEvent :: Local UserId -> Maybe ConnId -> UserConnection -> (AppT r) () +pushEvent :: + (Member NotificationSubsystem r) => + Local UserId -> + Maybe ConnId -> + UserConnection -> + AppT r () pushEvent self mzcon connection = do let event = ConnectionUpdated connection Nothing Nothing - Intra.onConnectionEvent (tUnqualified self) mzcon event + liftSem $ Intra.onConnectionEvent (tUnqualified self) mzcon event performLocalAction :: + (Member NotificationSubsystem r) => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -246,6 +254,7 @@ performLocalAction self mzcon other mconnection action = do -- B connects & A reacts: Accepted Accepted -- @ performRemoteAction :: + (Member NotificationSubsystem r) => Local UserId -> Remote UserId -> Maybe UserConnection -> @@ -263,7 +272,9 @@ performRemoteAction self other mconnection action = do reaction _ = Nothing createConnectionToRemoteUser :: - Member FederationConfigStore r => + ( Member FederationConfigStore r, + Member NotificationSubsystem r + ) => Local UserId -> ConnId -> Remote UserId -> @@ -275,7 +286,9 @@ createConnectionToRemoteUser self zcon other = do fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect updateConnectionToRemoteUser :: - Member FederationConfigStore r => + ( Member NotificationSubsystem r, + Member FederationConfigStore r + ) => Local UserId -> Remote UserId -> Relation -> diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index d77fa67f554..7515577d073 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -46,7 +46,6 @@ import Data.Domain import Data.Handle (Handle (..), parseHandle) import Data.Id (ClientId, TeamId, UserId) import Data.List.NonEmpty (nonEmpty) -import Data.List1 import Data.Qualified import Data.Range import Data.Set (fromList, (\\)) @@ -56,7 +55,6 @@ import Network.Wai.Utilities.Error ((!>>)) import Polysemy import Servant (ServerT) import Servant.API -import UnliftIO.Async (pooledForConcurrentlyN_) import Wire.API.Connection import Wire.API.Federation.API.Brig hiding (searchPolicy) import Wire.API.Federation.API.Common @@ -72,6 +70,7 @@ import Wire.API.User.Client import Wire.API.User.Client.Prekey import Wire.API.User.Search hiding (searchPolicy) import Wire.API.UserMap (UserMap) +import Wire.NotificationSubsystem import Wire.Sem.Concurrency type FederationAPI = "federation" :> BrigApi @@ -79,7 +78,8 @@ type FederationAPI = "federation" :> BrigApi federationSitemap :: ( Member GalleyProvider r, Member (Concurrency 'Unsafe) r, - Member FederationConfigStore r + Member FederationConfigStore r, + Member NotificationSubsystem r ) => ServerT FederationAPI (Handler r) federationSitemap = @@ -110,7 +110,9 @@ getFederationStatus _ request = do pure $ NonConnectedBackends (request.domains \\ fedDomains) sendConnectionAction :: - Member FederationConfigStore r => + ( Member FederationConfigStore r, + Member NotificationSubsystem r + ) => Domain -> NewConnectionRequest -> Handler r NewConnectionResponse @@ -254,7 +256,13 @@ getMLSClients _domain mcr = do getMLSClientsV0 :: Domain -> MLSClientsRequestV0 -> Handler r (Set ClientInfo) getMLSClientsV0 domain mcr0 = getMLSClients domain (mlsClientsRequestFromV0 mcr0) -onUserDeleted :: Domain -> UserDeletedConnectionsNotification -> (Handler r) EmptyResponse +onUserDeleted :: + ( Member (Concurrency 'Unsafe) r, + Member NotificationSubsystem r + ) => + Domain -> + UserDeletedConnectionsNotification -> + (Handler r) EmptyResponse onUserDeleted origDomain udcn = lift $ do let deletedUser = toRemoteUnsafe origDomain udcn.user connections = udcn.connections @@ -263,8 +271,8 @@ onUserDeleted origDomain udcn = lift $ do map csv2From . filter (\x -> csv2Status x == Accepted) <$> wrapClient (Data.lookupRemoteConnectionStatuses (fromRange connections) (fmap pure deletedUser)) - wrapHttp $ - pooledForConcurrentlyN_ 16 (nonEmpty acceptedLocals) $ \(List1 -> recipients) -> + liftSem $ + unsafePooledForConcurrentlyN_ 16 (nonEmpty acceptedLocals) $ \recipients -> notify event (tUnqualified deletedUser) Push.RouteDirect Nothing (pure recipients) wrapClient $ Data.deleteRemoteConnections deletedUser connections pure EmptyResponse diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 72e6eaeb8ff..f811894c335 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -76,11 +76,11 @@ import Imports hiding (head) import Network.Wai.Routing hiding (toList) import Network.Wai.Utilities as Utilities import Polysemy +import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) import Servant.OpenApi.Internal.Orphans () import System.Logger.Class qualified as Log -import System.Logger.Message as Log -import UnliftIO.Async +import UnliftIO.Async (pooledMapConcurrentlyN) import Wire.API.Connection import Wire.API.Error import Wire.API.Error.Brig qualified as E @@ -96,6 +96,8 @@ import Wire.API.User import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.RichInfo +import Wire.NotificationSubsystem +import Wire.Sem.Concurrency --------------------------------------------------------------------------- -- Sitemap (servant) @@ -108,7 +110,11 @@ servantSitemap :: Member PasswordResetStore r, Member GalleyProvider r, Member (UserPendingActivationStore p) r, - Member FederationConfigStore r + Member FederationConfigStore r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r, + Member (Concurrency 'Unsafe) r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -129,7 +135,7 @@ istatusAPI :: forall r. ServerT BrigIRoutes.IStatusAPI (Handler r) istatusAPI = Named @"get-status" (pure NoContent) ejpdAPI :: - (Member GalleyProvider r) => + (Member GalleyProvider r, Member NotificationSubsystem r) => ServerT BrigIRoutes.EJPD_API (Handler r) ejpdAPI = Brig.User.EJPD.ejpdRequest @@ -148,7 +154,10 @@ accountAPI :: Member BlacklistPhonePrefixStore r, Member PasswordResetStore r, Member GalleyProvider r, - Member (UserPendingActivationStore p) r + Member (UserPendingActivationStore p) r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -188,7 +197,11 @@ accountAPI = teamsAPI :: ( Member GalleyProvider r, Member (UserPendingActivationStore p) r, - Member BlacklistStore r + Member BlacklistStore r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member (Concurrency 'Unsafe) r, + Member TinyLog r ) => ServerT BrigIRoutes.TeamsAPI (Handler r) teamsAPI = @@ -209,7 +222,13 @@ userAPI = clientAPI :: ServerT BrigIRoutes.ClientAPI (Handler r) clientAPI = Named @"update-client-last-active" updateClientLastActive -authAPI :: (Member GalleyProvider r) => ServerT BrigIRoutes.AuthAPI (Handler r) +authAPI :: + ( Member GalleyProvider r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r + ) => + ServerT BrigIRoutes.AuthAPI (Handler r) authAPI = Named @"legalhold-login" (callsFed (exposeAnnotations legalHoldLogin)) :<|> Named @"sso-login" (callsFed (exposeAnnotations ssoLogin)) @@ -304,7 +323,7 @@ getMLSClients usr suite = do lusr <- qualifyLocal usr suiteTag <- maybe (mlsProtocolError "Unknown ciphersuite") pure (cipherSuiteTag suite) allClients <- lift (wrapClient (API.lookupUsersClientIds (pure usr))) >>= getResult - clientInfo <- lift . wrapClient $ pooledMapConcurrentlyN 16 (\c -> getValidity lusr c suiteTag) (toList allClients) + clientInfo <- lift . wrapClient $ UnliftIO.Async.pooledMapConcurrentlyN 16 (\c -> getValidity lusr c suiteTag) (toList allClients) pure . Set.fromList . map (uncurry ClientInfo) $ clientInfo where getResult [] = pure mempty @@ -348,7 +367,11 @@ sitemap = unsafeCallsFed @'Brig @"on-user-deleted-connections" $ do -- | Add a client without authentication checks addClientInternalH :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => UserId -> Maybe Bool -> NewClient -> @@ -360,11 +383,24 @@ addClientInternalH usr mSkipReAuth new connId = do | otherwise = Data.reAuthForNewClients API.addClientWithReAuthPolicy policy usr connId new !>> clientError -legalHoldClientRequestedH :: UserId -> LegalHoldClientRequest -> (Handler r) NoContent +legalHoldClientRequestedH :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + LegalHoldClientRequest -> + (Handler r) NoContent legalHoldClientRequestedH targetUser clientRequest = do lift $ NoContent <$ API.legalHoldClientRequested targetUser clientRequest -removeLegalHoldClientH :: UserId -> (Handler r) NoContent +removeLegalHoldClientH :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + (Handler r) NoContent removeLegalHoldClientH uid = do lift $ NoContent <$ API.removeLegalHoldClient uid @@ -380,7 +416,10 @@ internalListFullClientsH (UserSet usrs) = lift $ do createUserNoVerify :: ( Member BlacklistStore r, Member GalleyProvider r, - Member (UserPendingActivationStore p) r + Member (UserPendingActivationStore p) r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r ) => NewUser -> (Handler r) (Either RegisterError SelfProfile) @@ -398,7 +437,11 @@ createUserNoVerify uData = lift . runExceptT $ do pure . SelfProfile $ usr createUserNoVerifySpar :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => NewUserSpar -> (Handler r) (Either CreateUserSparError SelfProfile) createUserNoVerifySpar uData = @@ -415,9 +458,15 @@ createUserNoVerifySpar uData = in API.activate key code (Just uid) !>> CreateUserSparRegistrationError . activationErrorToRegisterError pure . SelfProfile $ usr -deleteUserNoAuthH :: UserId -> (Handler r) DeleteUserResponse +deleteUserNoAuthH :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + (Handler r) DeleteUserResponse deleteUserNoAuthH uid = do - r <- lift $ wrapHttp $ API.ensureAccountDeleted uid + r <- lift $ API.ensureAccountDeleted uid case r of NoUser -> throwStd (errorToWai @'E.UserNotFound) AccountAlreadyDeleted -> pure UserResponseAccountAlreadyDeleted @@ -525,10 +574,17 @@ getPasswordResetCode :: getPasswordResetCode emailOrPhone = (GetPasswordResetCodeResp <$$> lift (API.lookupPasswordResetCode emailOrPhone)) >>= maybe (throwStd (errorToWai @'E.InvalidPasswordResetKey)) pure -changeAccountStatusH :: UserId -> AccountStatusUpdate -> (Handler r) NoContent +changeAccountStatusH :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + AccountStatusUpdate -> + (Handler r) NoContent changeAccountStatusH usr (suStatus -> status) = do - Log.info $ (Log.msg (Log.val "Change Account Status")) ~~ Log.field "usr" (toByteString usr) ~~ Log.field "status" (show status) - wrapHttpClientE (API.changeSingleAccountStatus usr status) !>> accountStatusError -- FUTUREWORK: use CanThrow and related machinery + Log.info $ (Log.msg (Log.val "Change Account Status")) . Log.field "usr" (toByteString usr) . Log.field "status" (show status) + API.changeSingleAccountStatus usr status !>> accountStatusError -- FUTUREWORK: use CanThrow and related machinery pure NoContent getAccountStatusH :: UserId -> (Handler r) AccountStatusResp @@ -563,12 +619,25 @@ getConnectionsStatus (ConnectionsStatusRequestV2 froms mtos mrel) = do where filterByRelation l rel = filter ((== rel) . csv2Status) l -revokeIdentityH :: Maybe Email -> Maybe Phone -> (Handler r) NoContent +revokeIdentityH :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + Maybe Email -> + Maybe Phone -> + (Handler r) NoContent revokeIdentityH (Just email) Nothing = lift $ NoContent <$ API.revokeIdentity (Left email) revokeIdentityH Nothing (Just phone) = lift $ NoContent <$ API.revokeIdentity (Right phone) revokeIdentityH bade badp = throwStd (badRequest ("need exactly one of email, phone: " <> Imports.cs (show (bade, badp)))) -updateConnectionInternalH :: UpdateConnectionsInternal -> (Handler r) NoContent +updateConnectionInternalH :: + ( Member NotificationSubsystem r, + Member TinyLog r, + Member (Embed HttpClientIO) r + ) => + UpdateConnectionsInternal -> + (Handler r) NoContent updateConnectionInternalH updateConn = do API.updateConnectionInternal updateConn !>> connError pure NoContent @@ -613,21 +682,34 @@ deleteFromPhonePrefixH prefix = lift $ NoContent <$ API.phonePrefixDelete prefix addPhonePrefixH :: Member BlacklistPhonePrefixStore r => ExcludedPrefix -> (Handler r) NoContent addPhonePrefixH prefix = lift $ NoContent <$ API.phonePrefixInsert prefix -updateSSOIdH :: UserId -> UserSSOId -> (Handler r) UpdateSSOIdResponse +updateSSOIdH :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + UserSSOId -> + (Handler r) UpdateSSOIdResponse updateSSOIdH uid ssoid = do success <- lift $ wrapClient $ Data.updateSSOId uid (Just ssoid) if success then do - lift $ wrapHttpClient $ Intra.onUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOId = Just ssoid})) + lift $ liftSem $ Intra.onUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOId = Just ssoid})) pure UpdateSSOIdSuccess else pure UpdateSSOIdNotFound -deleteSSOIdH :: UserId -> (Handler r) UpdateSSOIdResponse +deleteSSOIdH :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + (Handler r) UpdateSSOIdResponse deleteSSOIdH uid = do success <- lift $ wrapClient $ Data.updateSSOId uid Nothing if success then do - lift $ wrapHttpClient $ Intra.onUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOIdRemoved = True})) + lift $ liftSem $ Intra.onUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOIdRemoved = True})) pure UpdateSSOIdSuccess else pure UpdateSSOIdNotFound @@ -680,13 +762,29 @@ getRichInfoMultiH :: Maybe (CommaSeparatedList UserId) -> (Handler r) [(UserId, getRichInfoMultiH (maybe [] fromCommaSeparatedList -> uids) = lift $ wrapClient $ API.lookupRichInfoMultiUsers uids -updateHandleH :: Member GalleyProvider r => UserId -> HandleUpdate -> (Handler r) NoContent +updateHandleH :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member GalleyProvider r, + Member TinyLog r + ) => + UserId -> + HandleUpdate -> + (Handler r) NoContent updateHandleH uid (HandleUpdate handleUpd) = NoContent <$ do handle <- validateHandle handleUpd API.changeHandle uid Nothing handle API.AllowSCIMUpdates !>> changeHandleError -updateUserNameH :: Member GalleyProvider r => UserId -> NameUpdate -> (Handler r) NoContent +updateUserNameH :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member GalleyProvider r, + Member TinyLog r + ) => + UserId -> + NameUpdate -> + (Handler r) NoContent updateUserNameH uid (NameUpdate nameUpd) = NoContent <$ do name <- either (const $ throwStd (errorToWai @'E.InvalidUser)) pure $ mkName nameUpd diff --git a/services/brig/src/Brig/API/Properties.hs b/services/brig/src/Brig/API/Properties.hs index 358850a70a0..3443ace2956 100644 --- a/services/brig/src/Brig/API/Properties.hs +++ b/services/brig/src/Brig/API/Properties.hs @@ -34,19 +34,21 @@ import Brig.Types.User.Event import Control.Error import Data.Id import Imports +import Polysemy import Wire.API.Properties +import Wire.NotificationSubsystem -setProperty :: UserId -> ConnId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError (AppT r) () +setProperty :: (Member NotificationSubsystem r) => UserId -> ConnId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError (AppT r) () setProperty u c k v = do wrapClientE $ Data.insertProperty u k (propertyRaw v) - lift $ Intra.onPropertyEvent u c (PropertySet u k v) + lift $ liftSem $ Intra.onPropertyEvent u c (PropertySet u k v) -deleteProperty :: UserId -> ConnId -> PropertyKey -> AppT r () +deleteProperty :: (Member NotificationSubsystem r) => UserId -> ConnId -> PropertyKey -> AppT r () deleteProperty u c k = do wrapClient $ Data.deleteProperty u k - Intra.onPropertyEvent u c (PropertyDeleted u k) + liftSem $ Intra.onPropertyEvent u c (PropertyDeleted u k) -clearProperties :: UserId -> ConnId -> AppT r () +clearProperties :: (Member NotificationSubsystem r) => UserId -> ConnId -> AppT r () clearProperties u c = do wrapClient $ Data.clearProperties u - Intra.onPropertyEvent u c (PropertiesCleared u) + liftSem $ Intra.onPropertyEvent u c (PropertiesCleared u) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index d61beffefa4..8beab24c7d3 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -101,6 +101,7 @@ import Imports hiding (head) import Network.Socket (PortNumber) import Network.Wai.Utilities as Utilities import Polysemy +import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) import Servant qualified import Servant.OpenApi.Internal.Orphans () @@ -150,6 +151,7 @@ import Wire.API.User.Password qualified as Public import Wire.API.User.RichInfo qualified as Public import Wire.API.UserMap qualified as Public import Wire.API.Wrapped qualified as Public +import Wire.NotificationSubsystem import Wire.Sem.Concurrency import Wire.Sem.Jwk (Jwk) import Wire.Sem.Now (Now) @@ -271,7 +273,10 @@ servantSitemap :: Member PublicKeyBundle r, Member (UserPendingActivationStore p) r, Member Jwk r, - Member FederationConfigStore r + Member FederationConfigStore r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r ) => ServerT BrigAPI (Handler r) servantSitemap = @@ -437,7 +442,7 @@ servantSitemap = --------------------------------------------------------------------------- -- Handlers -setProperty :: UserId -> ConnId -> Public.PropertyKey -> Public.RawPropertyValue -> Handler r () +setProperty :: (Member NotificationSubsystem r) => UserId -> ConnId -> Public.PropertyKey -> Public.RawPropertyValue -> Handler r () setProperty u c key raw = do checkPropertyKey key val <- safeParsePropertyValue raw @@ -476,10 +481,10 @@ parseStoredPropertyValue raw = case propertyValueFromRaw raw of . Log.field "parse_error" e throwStd internalServerError -deleteProperty :: UserId -> ConnId -> Public.PropertyKey -> Handler r () +deleteProperty :: (Member NotificationSubsystem r) => UserId -> ConnId -> Public.PropertyKey -> Handler r () deleteProperty u c k = lift (API.deleteProperty u c k) -clearProperties :: UserId -> ConnId -> Handler r () +clearProperties :: (Member NotificationSubsystem r) => UserId -> ConnId -> Handler r () clearProperties u c = lift (API.clearProperties u c) getProperty :: UserId -> Public.PropertyKey -> Handler r (Maybe Public.RawPropertyValue) @@ -555,7 +560,11 @@ getMultiUserPrekeyBundleH zusr qualUserClients = do API.claimMultiPrekeyBundles (ProtectedUser zusr) qualUserClients !>> clientError addClient :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => UserId -> ConnId -> Public.NewClient -> @@ -674,7 +683,10 @@ createAccessToken method luid cid proof = do createUser :: ( Member BlacklistStore r, Member GalleyProvider r, - Member (UserPendingActivationStore p) r + Member (UserPendingActivationStore p) r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r ) => Public.NewUserPublic -> (Handler r) (Either Public.RegisterError Public.RegisterSuccess) @@ -862,7 +874,16 @@ newtype GetActivationCodeResp instance ToJSON GetActivationCodeResp where toJSON (GetActivationCodeResp (k, c)) = object ["key" .= k, "code" .= c] -updateUser :: Member GalleyProvider r => UserId -> ConnId -> Public.UserUpdate -> (Handler r) (Maybe Public.UpdateProfileError) +updateUser :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member GalleyProvider r, + Member TinyLog r + ) => + UserId -> + ConnId -> + Public.UserUpdate -> + (Handler r) (Maybe Public.UpdateProfileError) updateUser uid conn uu = do eithErr <- lift $ runExceptT $ API.updateUser uid (Just conn) uu API.ForbidSCIMUpdates pure $ either Just (const Nothing) eithErr @@ -881,11 +902,25 @@ changePhone u _ (Public.puPhone -> phone) = lift . exceptTToMaybe $ do let apair = (activationKey adata, activationCode adata) lift . wrapClient $ sendActivationSms pn apair loc -removePhone :: UserId -> ConnId -> (Handler r) (Maybe Public.RemoveIdentityError) +removePhone :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + ConnId -> + (Handler r) (Maybe Public.RemoveIdentityError) removePhone self conn = lift . exceptTToMaybe $ API.removePhone self conn -removeEmail :: UserId -> ConnId -> (Handler r) (Maybe Public.RemoveIdentityError) +removeEmail :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + ConnId -> + (Handler r) (Maybe Public.RemoveIdentityError) removeEmail self conn = lift . exceptTToMaybe $ API.removeEmail self conn @@ -895,10 +930,26 @@ checkPasswordExists = fmap isJust . lift . wrapClient . API.lookupPassword changePassword :: UserId -> Public.PasswordChange -> (Handler r) (Maybe Public.ChangePasswordError) changePassword u cp = lift . exceptTToMaybe $ API.changePassword u cp -changeLocale :: UserId -> ConnId -> Public.LocaleUpdate -> (Handler r) () +changeLocale :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + ConnId -> + Public.LocaleUpdate -> + (Handler r) () changeLocale u conn l = lift $ API.changeLocale u conn l -changeSupportedProtocols :: Local UserId -> ConnId -> Public.SupportedProtocolUpdate -> Handler r () +changeSupportedProtocols :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + Local UserId -> + ConnId -> + Public.SupportedProtocolUpdate -> + Handler r () changeSupportedProtocols (tUnqualified -> u) conn (Public.SupportedProtocolUpdate prots) = lift $ API.changeSupportedProtocols u conn prots @@ -933,13 +984,22 @@ getHandleInfoUnqualifiedH self handle = do Public.UserHandleInfo . Public.profileQualifiedId <$$> Handle.getHandleInfo self (Qualified handle domain) -changeHandle :: Member GalleyProvider r => UserId -> ConnId -> Public.HandleUpdate -> (Handler r) (Maybe Public.ChangeHandleError) +changeHandle :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member GalleyProvider r, + Member TinyLog r + ) => + UserId -> + ConnId -> + Public.HandleUpdate -> + (Handler r) (Maybe Public.ChangeHandleError) changeHandle u conn (Public.HandleUpdate h) = lift . exceptTToMaybe $ do handle <- maybe (throwError Public.ChangeHandleInvalid) pure $ parseHandle h API.changeHandle u (Just conn) handle API.ForbidSCIMUpdates beginPasswordReset :: - Member PasswordResetStore r => + (Member PasswordResetStore r, Member TinyLog r) => Public.NewPasswordReset -> (Handler r) () beginPasswordReset (Public.NewPasswordReset target) = do @@ -952,7 +1012,8 @@ beginPasswordReset (Public.NewPasswordReset target) = do completePasswordReset :: ( Member CodeStore r, - Member PasswordResetStore r + Member PasswordResetStore r, + Member TinyLog r ) => Public.CompletePasswordReset -> (Handler r) () @@ -990,7 +1051,11 @@ customerExtensionCheckBlockedDomains email = do customerExtensionBlockedDomain domain createConnectionUnqualified :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member NotificationSubsystem r, + Member TinyLog r, + Member (Embed HttpClientIO) r + ) => UserId -> ConnId -> Public.ConnectionRequest -> @@ -1002,7 +1067,10 @@ createConnectionUnqualified self conn cr = do createConnection :: ( Member FederationConfigStore r, - Member GalleyProvider r + Member GalleyProvider r, + Member NotificationSubsystem r, + Member TinyLog r, + Member (Embed HttpClientIO) r ) => UserId -> ConnId -> @@ -1013,6 +1081,10 @@ createConnection self conn target = do API.createConnection lself conn target !>> connError updateLocalConnection :: + ( Member NotificationSubsystem r, + Member TinyLog r, + Member (Embed HttpClientIO) r + ) => UserId -> ConnId -> UserId -> @@ -1025,7 +1097,11 @@ updateLocalConnection self conn other (Public.cuStatus -> newStatus) = do <$> API.updateConnectionToLocalUser lself lother newStatus (Just conn) !>> connError updateConnection :: - Member FederationConfigStore r => + ( Member FederationConfigStore r, + Member NotificationSubsystem r, + Member TinyLog r, + Member (Embed HttpClientIO) r + ) => UserId -> ConnId -> Qualified UserId -> @@ -1095,14 +1171,24 @@ getConnection self other = do lift . wrapClient $ Data.lookupConnection lself other deleteSelfUser :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r + ) => UserId -> Public.DeleteUser -> (Handler r) (Maybe Code.Timeout) deleteSelfUser u body = do API.deleteSelfUser u (Public.deleteUserPassword body) !>> deleteUserError -verifyDeleteUser :: Public.VerifyDeleteUser -> Handler r () +verifyDeleteUser :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + Public.VerifyDeleteUser -> + Handler r () verifyDeleteUser body = API.verifyDeleteUser body !>> deleteUserError updateUserEmail :: @@ -1137,7 +1223,11 @@ updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do -- activation activate :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r + ) => Public.ActivationKey -> Public.ActivationCode -> (Handler r) ActivationRespWithStatus @@ -1147,7 +1237,11 @@ activate k c = do -- docs/reference/user/activation.md {#RefActivationSubmit} activateKey :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r + ) => Public.Activate -> (Handler r) ActivationRespWithStatus activateKey (Public.Activate tgt code dryrun) @@ -1226,7 +1320,8 @@ deprecatedOnboarding _ _ = pure DeprecatedMatchingResult deprecatedCompletePasswordReset :: ( Member CodeStore r, - Member PasswordResetStore r + Member PasswordResetStore r, + Member TinyLog r ) => Public.PasswordResetKey -> Public.PasswordReset -> diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index d9674b685a3..bd5c84d555c 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -93,8 +93,6 @@ module Brig.API.User ) where -import Bilge.IO (MonadHttp) -import Bilge.RPC (HasRequestId) import Brig.API.Error qualified as Error import Brig.API.Handler qualified as API (Handler, UserNotAllowedToJoinTeam (..)) import Brig.API.Types @@ -139,7 +137,7 @@ import Brig.User.Email import Brig.User.Handle import Brig.User.Handle.Blacklist import Brig.User.Phone -import Brig.User.Search.Index (MonadIndexIO, reindex) +import Brig.User.Search.Index (reindex) import Brig.User.Search.TeamSize qualified as TeamSize import Cassandra hiding (Set) import Control.Arrow ((&&&)) @@ -165,10 +163,11 @@ import Galley.Types.Teams qualified as Team import Imports hiding (cs) import Network.Wai.Utilities import Polysemy +import Polysemy.TinyLog (TinyLog) +import Polysemy.TinyLog qualified as Log import System.Logger.Class (MonadLogger) -import System.Logger.Class qualified as Log import System.Logger.Message -import UnliftIO.Async +import UnliftIO.Async (mapConcurrently_) import Wire.API.Connection import Wire.API.Error import Wire.API.Error.Brig qualified as E @@ -188,6 +187,7 @@ import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.Password import Wire.API.User.RichInfo +import Wire.NotificationSubsystem import Wire.Sem.Concurrency data AllowSCIMUpdates @@ -229,7 +229,11 @@ verifyUniquenessAndCheckBlacklist uk = do createUserSpar :: forall r. - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => NewUserSpar -> ExceptT CreateUserSparError (AppT r) CreateUserResult createUserSpar new = do @@ -250,7 +254,7 @@ createUserSpar new = do Just richInfo -> wrapClient $ Data.updateRichInfo uid richInfo Nothing -> pure () -- Nothing to do liftSem $ GalleyProvider.createSelfConv uid - wrapHttpClient $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) + liftSem $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) pure account @@ -282,10 +286,11 @@ createUserSpar new = do lift $ do wrapClient $ activateUser uid ident void $ onActivated (AccountActivated account) - Log.info $ - field "user" (toByteString uid) - . field "team" (toByteString tid) - . msg (val "Added via SSO") + liftSem $ + Log.info $ + field "user" (toByteString uid) + . field "team" (toByteString tid) + . msg (val "Added via SSO") Team.TeamName nm <- lift $ liftSem $ GalleyProvider.getTeamName tid pure $ CreateUserTeam tid nm @@ -294,7 +299,10 @@ createUser :: forall r p. ( Member BlacklistStore r, Member GalleyProvider r, - Member (UserPendingActivationStore p) r + Member (UserPendingActivationStore p) r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r ) => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult @@ -346,12 +354,13 @@ createUser new = do (account, pw) <- wrapClient $ newAccount new' mbInv tid mbHandle let uid = userId (accountUser account) - Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.createUser") - Log.info $ field "user" (toByteString uid) . msg (val "Creating user") + liftSem $ do + Log.debug $ field "user" (toByteString uid) . field "action" (val "User.createUser") + Log.info $ field "user" (toByteString uid) . msg (val "Creating user") wrapClient $ Data.insertAccount account Nothing pw False liftSem $ GalleyProvider.createSelfConv uid - wrapHttpClient $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) + liftSem $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) pure account @@ -464,10 +473,11 @@ createUser new = do lift $ do wrapClient $ activateUser uid ident -- ('insertAccount' sets column activated to False; here it is set to True.) void $ onActivated (AccountActivated account) - Log.info $ - field "user" (toByteString uid) - . field "team" (toByteString $ Team.iiTeam ii) - . msg (val "Accepting invitation") + liftSem $ + Log.info $ + field "user" (toByteString uid) + . field "team" (toByteString $ Team.iiTeam ii) + . msg (val "Accepting invitation") liftSem $ UserPendingActivationStore.remove uid wrapClient $ do Team.deleteInvitation (Team.inTeam inv) (Team.inInvitation inv) @@ -481,10 +491,11 @@ createUser new = do lift $ do wrapClient $ activateUser uid ident void $ onActivated (AccountActivated account) - Log.info $ - field "user" (toByteString uid) - . field "team" (toByteString tid) - . msg (val "Added via SSO") + liftSem $ + Log.info $ + field "user" (toByteString uid) + . field "team" (toByteString tid) + . msg (val "Added via SSO") Team.TeamName nm <- lift $ liftSem $ GalleyProvider.getTeamName tid pure $ CreateUserTeam tid nm @@ -495,7 +506,7 @@ createUser new = do Nothing -> do timeout <- setActivationTimeout <$> view settings edata <- lift . wrapClient $ Data.newActivation ek timeout (Just uid) - lift . Log.info $ + lift . liftSem . Log.info $ field "user" (toByteString uid) . field "activation.key" (toByteString $ activationKey edata) . msg (val "Created email activation key/code pair") @@ -514,7 +525,7 @@ createUser new = do Nothing -> do timeout <- setActivationTimeout <$> view settings pdata <- lift . wrapClient $ Data.newActivation pk timeout (Just uid) - lift . Log.info $ + lift . liftSem . Log.info $ field "user" (toByteString uid) . field "activation.key" (toByteString $ activationKey pdata) . msg (val "Created phone activation key/code pair") @@ -534,7 +545,8 @@ initAccountFeatureConfig uid = do -- users are invited to the team via scim. createUserInviteViaScim :: ( Member BlacklistStore r, - Member (UserPendingActivationStore p) r + Member (UserPendingActivationStore p) r, + Member TinyLog r ) => UserId -> NewUserScimInvitation -> @@ -544,7 +556,7 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail _) = do let emKey = userEmailKey email verifyUniquenessAndCheckBlacklist emKey !>> identityErrorToBrigError account <- lift . wrapClient $ newAccountInviteViaScim uid tid loc name email - lift . Log.debug $ field "user" (toByteString . userId . accountUser $ account) . field "action" (Log.val "User.createUserInviteViaScim") + lift . liftSem . Log.debug $ field "user" (toByteString . userId . accountUser $ account) . field "action" (val "User.createUserInviteViaScim") -- add the expiry table entry first! (if brig creates an account, and then crashes before -- creating the expiry table entry, gc will miss user data.) @@ -576,7 +588,17 @@ checkRestrictedUserCreation new = do ------------------------------------------------------------------------------- -- Update Profile -updateUser :: Member GalleyProvider r => UserId -> Maybe ConnId -> UserUpdate -> AllowSCIMUpdates -> ExceptT UpdateProfileError (AppT r) () +updateUser :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member GalleyProvider r, + Member TinyLog r + ) => + UserId -> + Maybe ConnId -> + UserUpdate -> + AllowSCIMUpdates -> + ExceptT UpdateProfileError (AppT r) () updateUser uid mconn uu allowScim = do for_ (uupName uu) $ \newName -> do mbUser <- lift . wrapClient $ Data.lookupUser WithPendingInvitations uid @@ -593,36 +615,70 @@ updateUser uid mconn uu allowScim = do lift $ do wrapClient $ Data.updateUser uid uu - wrapHttpClient $ Intra.onUserEvent uid mconn (profileUpdated uid uu) + liftSem $ Intra.onUserEvent uid mconn (profileUpdated uid uu) ------------------------------------------------------------------------------- -- Update Locale -changeLocale :: UserId -> ConnId -> LocaleUpdate -> (AppT r) () +changeLocale :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + ConnId -> + LocaleUpdate -> + (AppT r) () changeLocale uid conn (LocaleUpdate loc) = do wrapClient $ Data.updateLocale uid loc - wrapHttpClient $ Intra.onUserEvent uid (Just conn) (localeUpdate uid loc) + liftSem $ Intra.onUserEvent uid (Just conn) (localeUpdate uid loc) ------------------------------------------------------------------------------- -- Update ManagedBy -changeManagedBy :: UserId -> ConnId -> ManagedByUpdate -> (AppT r) () +changeManagedBy :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + ConnId -> + ManagedByUpdate -> + (AppT r) () changeManagedBy uid conn (ManagedByUpdate mb) = do wrapClient $ Data.updateManagedBy uid mb - wrapHttpClient $ Intra.onUserEvent uid (Just conn) (managedByUpdate uid mb) + liftSem $ Intra.onUserEvent uid (Just conn) (managedByUpdate uid mb) ------------------------------------------------------------------------------- -- Update supported protocols -changeSupportedProtocols :: UserId -> ConnId -> Set BaseProtocolTag -> AppT r () +changeSupportedProtocols :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + ConnId -> + Set BaseProtocolTag -> + AppT r () changeSupportedProtocols uid conn prots = do wrapClient $ Data.updateSupportedProtocols uid prots - wrapHttpClient $ Intra.onUserEvent uid (Just conn) (supportedProtocolUpdate uid prots) + liftSem $ Intra.onUserEvent uid (Just conn) (supportedProtocolUpdate uid prots) -------------------------------------------------------------------------------- -- Change Handle -changeHandle :: Member GalleyProvider r => UserId -> Maybe ConnId -> Handle -> AllowSCIMUpdates -> ExceptT ChangeHandleError (AppT r) () +changeHandle :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member GalleyProvider r, + Member TinyLog r + ) => + UserId -> + Maybe ConnId -> + Handle -> + AllowSCIMUpdates -> + ExceptT ChangeHandleError (AppT r) () changeHandle uid mconn hdl allowScim = do when (isBlacklistedHandle hdl) $ throwE ChangeHandleInvalid @@ -647,7 +703,7 @@ changeHandle uid mconn hdl allowScim = do claimed <- lift . wrapClient $ claimHandle (userId u) (userHandle u) hdl unless claimed $ throwE ChangeHandleExists - lift $ wrapHttpClient $ Intra.onUserEvent uid mconn (handleUpdated uid hdl) + lift $ liftSem $ Intra.onUserEvent uid mconn (handleUpdated uid hdl) -------------------------------------------------------------------------------- -- Check Handle @@ -781,21 +837,35 @@ changePhone u phone = do ------------------------------------------------------------------------------- -- Remove Email -removeEmail :: UserId -> ConnId -> ExceptT RemoveIdentityError (AppT r) () +removeEmail :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + ConnId -> + ExceptT RemoveIdentityError (AppT r) () removeEmail uid conn = do ident <- lift $ fetchUserIdentity uid case ident of Just (FullIdentity e _) -> lift $ do wrapClient . deleteKey $ userEmailKey e wrapClient $ Data.deleteEmail uid - wrapHttpClient $ Intra.onUserEvent uid (Just conn) (emailRemoved uid e) + liftSem $ Intra.onUserEvent uid (Just conn) (emailRemoved uid e) Just _ -> throwE LastIdentity Nothing -> throwE NoIdentity ------------------------------------------------------------------------------- -- Remove Phone -removePhone :: UserId -> ConnId -> ExceptT RemoveIdentityError (AppT r) () +removePhone :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + UserId -> + ConnId -> + ExceptT RemoveIdentityError (AppT r) () removePhone uid conn = do ident <- lift $ fetchUserIdentity uid case ident of @@ -806,14 +876,21 @@ removePhone uid conn = do lift $ do wrapClient . deleteKey $ userPhoneKey p wrapClient $ Data.deletePhone uid - wrapHttpClient $ Intra.onUserEvent uid (Just conn) (phoneRemoved uid p) + liftSem $ Intra.onUserEvent uid (Just conn) (phoneRemoved uid p) Just _ -> throwE LastIdentity Nothing -> throwE NoIdentity ------------------------------------------------------------------------------- -- Forcefully revoke a verified identity -revokeIdentity :: Either Email Phone -> AppT r () +revokeIdentity :: + forall r. + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + Either Email Phone -> + AppT r () revokeIdentity key = do let uk = either userEmailKey userPhoneKey key mu <- wrapClient $ Data.lookupKey uk @@ -838,7 +915,7 @@ revokeIdentity key = do (\(_ :: Email) -> Data.deleteEmail u) (\(_ :: Phone) -> Data.deletePhone u) uk - wrapHttpClient $ + liftSem $ Intra.onUserEvent u Nothing $ foldKey (emailRemoved u) @@ -849,57 +926,49 @@ revokeIdentity key = do -- Change Account Status changeAccountStatus :: - forall m. - ( MonadClient m, - MonadLogger m, - MonadIndexIO m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m + forall r. + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member (Concurrency 'Unsafe) r, + Member TinyLog r ) => List1 UserId -> AccountStatus -> - ExceptT AccountStatusError m () + ExceptT AccountStatusError (AppT r) () changeAccountStatus usrs status = do ev <- mkUserEvent usrs status - lift $ mapConcurrently_ (update ev) usrs + lift $ liftSem $ unsafePooledMapConcurrentlyN_ 16 (update ev) usrs where update :: (UserId -> UserEvent) -> UserId -> - m () + Sem r () update ev u = do - Data.updateStatus u status + embed $ Data.updateStatus u status Intra.onUserEvent u Nothing (ev u) changeSingleAccountStatus :: - forall m. - ( MonadClient m, - MonadLogger m, - MonadIndexIO m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r ) => UserId -> AccountStatus -> - ExceptT AccountStatusError m () + ExceptT AccountStatusError (AppT r) () changeSingleAccountStatus uid status = do - unlessM (Data.userExists uid) $ throwE AccountNotFound + unlessM (wrapClientE $ Data.userExists uid) $ throwE AccountNotFound ev <- mkUserEvent (List1.singleton uid) status lift $ do - Data.updateStatus uid status - Intra.onUserEvent uid Nothing (ev uid) + wrapClient $ Data.updateStatus uid status + liftSem $ Intra.onUserEvent uid Nothing (ev uid) -mkUserEvent :: (MonadUnliftIO m, Traversable t, MonadClient m) => t UserId -> AccountStatus -> ExceptT AccountStatusError m (UserId -> UserEvent) +mkUserEvent :: (Traversable t) => t UserId -> AccountStatus -> ExceptT AccountStatusError (AppT r) (UserId -> UserEvent) mkUserEvent usrs status = case status of Active -> pure UserResumed - Suspended -> lift $ mapConcurrently revokeAllCookies usrs >> pure UserSuspended + Suspended -> do + lift $ wrapHttpClient (mapConcurrently_ revokeAllCookies usrs) + pure UserSuspended Deleted -> throwE InvalidAccountStatus Ephemeral -> throwE InvalidAccountStatus PendingInvitation -> throwE InvalidAccountStatus @@ -908,7 +977,11 @@ mkUserEvent usrs status = -- Activation activate :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r + ) => ActivationTarget -> ActivationCode -> -- | The user for whom to activate the key. @@ -917,7 +990,11 @@ activate :: activate tgt code usr = activateWithCurrency tgt code usr Nothing activateWithCurrency :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r + ) => ActivationTarget -> ActivationCode -> -- | The user for whom to activate the key. @@ -928,7 +1005,7 @@ activateWithCurrency :: ExceptT ActivationError (AppT r) ActivationResult activateWithCurrency tgt code usr cur = do key <- wrapClientE $ mkActivationKey tgt - lift . Log.info $ + lift . liftSem . Log.info $ field "activation.key" (toByteString key) . field "activation.code" (toByteString code) . msg (val "Activating") @@ -957,19 +1034,25 @@ preverify tgt code = do key <- mkActivationKey tgt void $ Data.verifyCode key code -onActivated :: ActivationEvent -> (AppT r) (UserId, Maybe UserIdentity, Bool) -onActivated (AccountActivated account) = do +onActivated :: + ( Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r + ) => + ActivationEvent -> + (AppT r) (UserId, Maybe UserIdentity, Bool) +onActivated (AccountActivated account) = liftSem $ do let uid = userId (accountUser account) - Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.onActivated") + Log.debug $ field "user" (toByteString uid) . field "action" (val "User.onActivated") Log.info $ field "user" (toByteString uid) . msg (val "User activated") - wrapHttpClient $ Intra.onUserEvent uid Nothing $ UserActivated (accountUser account) + Intra.onUserEvent uid Nothing $ UserActivated (accountUser account) pure (uid, userIdentity (accountUser account), True) onActivated (EmailActivated uid email) = do - wrapHttpClient $ Intra.onUserEvent uid Nothing (emailUpdated uid email) + liftSem $ Intra.onUserEvent uid Nothing (emailUpdated uid email) wrapHttpClient $ Data.deleteEmailUnvalidated uid pure (uid, Just (EmailIdentity email), False) onActivated (PhoneActivated uid phone) = do - wrapHttpClient $ Intra.onUserEvent uid Nothing (phoneUpdated uid phone) + liftSem $ Intra.onUserEvent uid Nothing (phoneUpdated uid phone) pure (uid, Just (PhoneIdentity phone), False) -- docs/reference/user/activation.md {#RefActivationRequest} @@ -1102,13 +1185,15 @@ changePassword uid cp = do lift $ wrapClient (Data.updatePassword uid newpw) >> wrapClient (revokeAllCookies uid) beginPasswordReset :: - Member PasswordResetStore r => + ( Member TinyLog r, + Member PasswordResetStore r + ) => Either Email Phone -> ExceptT PasswordResetError (AppT r) (UserId, PasswordResetPair) beginPasswordReset target = do let key = either userEmailKey userPhoneKey target user <- lift (wrapClient $ Data.lookupKey key) >>= maybe (throwE InvalidPasswordResetKey) pure - lift . Log.debug $ field "user" (toByteString user) . field "action" (Log.val "User.beginPasswordReset") + lift . liftSem . Log.debug $ field "user" (toByteString user) . field "action" (val "User.beginPasswordReset") status <- lift . wrapClient $ Data.lookupStatus user unless (status == Just Active) $ throwE InvalidPasswordResetKey @@ -1119,7 +1204,8 @@ beginPasswordReset target = do completePasswordReset :: ( Member CodeStore r, - Member PasswordResetStore r + Member PasswordResetStore r, + Member TinyLog r ) => PasswordResetIdentity -> PasswordResetCode -> @@ -1131,7 +1217,7 @@ completePasswordReset ident code pw = do case muid of Nothing -> throwE InvalidPasswordResetCode Just uid -> do - lift . Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.completePasswordReset") + lift . liftSem . Log.debug $ field "user" (toByteString uid) . field "action" (val "User.completePasswordReset") checkNewIsDifferent uid pw lift $ do wrapClient $ Data.updatePassword uid pw @@ -1176,7 +1262,11 @@ mkPasswordResetKey ident = case ident of -- TODO: communicate deletions of SSO users to SSO service. deleteSelfUser :: forall r. - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r + ) => UserId -> Maybe PlainTextPassword6 -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) @@ -1210,9 +1300,9 @@ deleteSelfUser uid pwd = do Just emailOrPhone -> sendCode a emailOrPhone Nothing -> case pwd of Just _ -> throwE DeleteUserMissingPassword - Nothing -> lift $ wrapHttpClient $ deleteAccount a >> pure Nothing + Nothing -> lift . liftSem $ deleteAccount a >> pure Nothing byPassword a pw = do - lift . Log.info $ + lift . liftSem . Log.info $ field "user" (toByteString uid) . msg (val "Attempting account deletion with a password") actual <- lift . wrapClient $ Data.lookupPassword uid @@ -1222,14 +1312,14 @@ deleteSelfUser uid pwd = do -- We're deleting a user, no sense in updating their pwd, so we ignore pwd status unless (verifyPassword pw p) $ throwE DeleteUserInvalidPassword - lift $ wrapHttpClient $ deleteAccount a >> pure Nothing + lift . liftSem $ deleteAccount a >> pure Nothing sendCode a target = do gen <- Code.mkGen (either Code.ForEmail Code.ForPhone target) pending <- lift . wrapClient $ Code.lookup (Code.genKey gen) Code.AccountDeletion case pending of Just c -> throwE $! DeleteUserPendingCode (Code.codeTTL c) Nothing -> do - lift . Log.info $ + lift . liftSem . Log.info $ field "user" (toByteString uid) . msg (val "Sending verification code for account deletion") c <- @@ -1253,43 +1343,44 @@ deleteSelfUser uid pwd = do -- | Conclude validation and scheduling of user's deletion request that was initiated in -- 'deleteUser'. Called via @post /delete@. -verifyDeleteUser :: VerifyDeleteUser -> ExceptT DeleteUserError (AppT r) () +verifyDeleteUser :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => + VerifyDeleteUser -> + ExceptT DeleteUserError (AppT r) () verifyDeleteUser d = do let key = verifyDeleteUserKey d let code = verifyDeleteUserCode d c <- lift . wrapClient $ Code.verify key Code.AccountDeletion code a <- maybe (throwE DeleteUserInvalidCode) pure (Code.codeAccount =<< c) account <- lift . wrapClient $ Data.lookupAccount (Id a) - for_ account $ lift . wrapHttpClient . deleteAccount + for_ account $ lift . liftSem . deleteAccount lift . wrapClient $ Code.delete key Code.AccountDeletion -- | Check if `deleteAccount` succeeded and run it again if needed. -- Called via @delete /i/user/:uid@. ensureAccountDeleted :: - ( MonadLogger m, - MonadIndexIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - MonadClient m, - MonadReader Env m + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r ) => UserId -> - m DeleteUserResult + AppT r DeleteUserResult ensureAccountDeleted uid = do - mbAcc <- lookupAccount uid + mbAcc <- wrapClient $ lookupAccount uid case mbAcc of Nothing -> pure NoUser Just acc -> do - probs <- Data.lookupPropertyKeysAndValues uid + probs <- wrapClient $ Data.lookupPropertyKeysAndValues uid let accIsDeleted = accountStatus acc == Deleted - clients <- Data.lookupClients uid + clients <- wrapClient $ Data.lookupClients uid localUid <- qualifyLocal uid - conCount <- countConnections localUid [(minBound @Relation) .. maxBound] - cookies <- listCookies uid [] + conCount <- wrapClient $ countConnections localUid [(minBound @Relation) .. maxBound] + cookies <- wrapClient $ listCookies uid [] if notNull probs || not accIsDeleted @@ -1297,7 +1388,7 @@ ensureAccountDeleted uid = do || conCount > 0 || notNull cookies then do - deleteAccount acc + liftSem $ deleteAccount acc pure AccountDeleted else pure AccountAlreadyDeleted @@ -1311,36 +1402,33 @@ ensureAccountDeleted uid = do -- statements matters! Other functions reason upon some states to imply other -- states. Please change this order only with care! deleteAccount :: - ( MonadLogger m, - MonadIndexIO m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - MonadClient m + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r ) => UserAccount -> - m () + Sem r () deleteAccount account@(accountUser -> user) = do let uid = userId user Log.info $ field "user" (toByteString uid) . msg (val "Deleting account") - -- Free unique keys - for_ (userEmail user) $ deleteKeyForUser uid . userEmailKey - for_ (userPhone user) $ deleteKeyForUser uid . userPhoneKey - for_ (userHandle user) $ freeHandle (userId user) - -- Wipe data - Data.clearProperties uid - tombstone <- mkTombstone - Data.insertAccount tombstone Nothing Nothing False + embed $ do + -- Free unique keys + for_ (userEmail user) $ deleteKeyForUser uid . userEmailKey + for_ (userPhone user) $ deleteKeyForUser uid . userPhoneKey + for_ (userHandle user) $ freeHandle (userId user) + -- Wipe data + Data.clearProperties uid + tombstone <- mkTombstone + Data.insertAccount tombstone Nothing Nothing False Intra.rmUser uid (userAssets user) - Data.lookupClients uid >>= mapM_ (Data.rmClient uid . clientId) - luid <- qualifyLocal uid + embed $ Data.lookupClients uid >>= mapM_ (Data.rmClient uid . clientId) + luid <- embed $ qualifyLocal uid Intra.onUserEvent uid Nothing (UserDeleted (tUntagged luid)) - -- Note: Connections can only be deleted afterwards, since - -- they need to be notified. - Data.deleteConnections uid - revokeAllCookies uid + embed $ do + -- Note: Connections can only be deleted afterwards, since + -- they need to be notified. + Data.deleteConnections uid + revokeAllCookies uid where mkTombstone = do defLoc <- setDefaultUserLocale <$> view settings diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 8ead8601f91..80c938c5d06 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -35,7 +35,8 @@ module Brig.App stompEnv, cargohold, galley, - gundeck, + galleyEndpoint, + gundeckEndpoint, federator, casClient, userTemplates, @@ -80,6 +81,7 @@ module Brig.App wrapHttpClientE, wrapHttp, HttpClientIO (..), + runHttpClientIO, liftSem, lowerAppT, temporaryGetEnv, @@ -158,7 +160,8 @@ schemaVersion = Migrations.lastSchemaVersion data Env = Env { _cargohold :: RPC.Request, _galley :: RPC.Request, - _gundeck :: RPC.Request, + _galleyEndpoint :: Endpoint, + _gundeckEndpoint :: Endpoint, _federator :: Maybe Endpoint, -- FUTUREWORK: should we use a better type here? E.g. to avoid fresh connections all the time? _casClient :: Cas.ClientState, _smtpEnv :: Maybe SMTP.SMTP, @@ -257,7 +260,8 @@ newEnv o = do Env { _cargohold = mkEndpoint $ Opt.cargohold o, _galley = mkEndpoint $ Opt.galley o, - _gundeck = mkEndpoint $ Opt.gundeck o, + _galleyEndpoint = Opt.galley o, + _gundeckEndpoint = Opt.gundeck o, _federator = Opt.federatorInternal o, _casClient = cas, _smtpEnv = emailSMTP, @@ -305,13 +309,13 @@ newEnv o = do mkEndpoint service = RPC.host (encodeUtf8 (service ^. host)) . RPC.port (service ^. port) $ RPC.empty mkIndexEnv :: Opts -> Logger -> Manager -> Metrics -> Endpoint -> IndexEnv -mkIndexEnv o lgr mgr mtr galleyEndpoint = +mkIndexEnv o lgr mgr mtr galleyEp = let bhe = ES.mkBHEnv (ES.Server (Opt.url (Opt.elasticsearch o))) mgr lgr' = Log.clone (Just "index.brig") lgr mainIndex = ES.IndexName $ Opt.index (Opt.elasticsearch o) additionalIndex = ES.IndexName <$> Opt.additionalWriteIndex (Opt.elasticsearch o) additionalBhe = flip ES.mkBHEnv mgr . ES.Server <$> Opt.additionalWriteIndexUrl (Opt.elasticsearch o) - in IndexEnv mtr lgr' bhe Nothing mainIndex additionalIndex additionalBhe galleyEndpoint mgr + in IndexEnv mtr lgr' bhe Nothing mainIndex additionalIndex additionalBhe galleyEp mgr initZAuth :: Opts -> IO ZAuth.Env initZAuth o = do @@ -525,14 +529,12 @@ wrapClientM = mapMaybeT wrapClient wrapHttp :: HttpClientIO a -> AppT r a -wrapHttp (HttpClientIO m) = do - c <- view casClient +wrapHttp action = do env <- ask - manager <- view httpManager - liftIO . runClient c . runHttpT manager $ runReaderT m env + runHttpClientIO env action newtype HttpClientIO a = HttpClientIO - { runHttpClientIO :: ReaderT Env (HttpT Cas.Client) a + { unHttpClientIO :: ReaderT Env (HttpT Cas.Client) a } deriving newtype ( Functor, @@ -549,6 +551,13 @@ newtype HttpClientIO a = HttpClientIO MonadIndexIO ) +runHttpClientIO :: MonadIO m => Env -> HttpClientIO a -> m a +runHttpClientIO env = + runClient (env ^. casClient) + . runHttpT (env ^. httpManager) + . flip runReaderT env + . unHttpClientIO + instance MonadZAuth HttpClientIO where liftZAuth za = view zauthEnv >>= flip runZAuth za diff --git a/services/brig/src/Brig/Calling.hs b/services/brig/src/Brig/Calling.hs index 1af030f701e..890531bd63a 100644 --- a/services/brig/src/Brig/Calling.hs +++ b/services/brig/src/Brig/Calling.hs @@ -48,7 +48,6 @@ module Brig.Calling ) where -import Brig.Effects.Delay import Brig.Options (SFTOptions (..), defSftListLength, defSftServiceName, defSrvDiscoveryIntervalSeconds) import Brig.Options qualified as Opts import Control.Exception.Enclosed (handleAny) @@ -80,6 +79,7 @@ import UnliftIO.Async qualified as Async import Wire.API.Call.Config import Wire.Network.DNS.Effect import Wire.Network.DNS.SRV +import Wire.Sem.Delay import Wire.Sem.Logger.TinyLog -- | NOTE SFTServers: diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 386033d74f4..c76802a40ae 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -10,15 +10,11 @@ import Brig.Effects.CodeStore.Cassandra (codeStoreToCassandra, interpretClientTo import Brig.Effects.FederationConfigStore (FederationConfigStore) import Brig.Effects.FederationConfigStore.Cassandra (interpretFederationDomainConfig, remotesMapFromCfgFile) import Brig.Effects.GalleyProvider (GalleyProvider) -import Brig.Effects.GalleyProvider.RPC (interpretGalleyProviderToRPC) +import Brig.Effects.GalleyProvider.RPC import Brig.Effects.JwtTools import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.PasswordResetStore.CodeStore (passwordResetStoreToCodeStore) import Brig.Effects.PublicKeyBundle -import Brig.Effects.RPC (RPC) -import Brig.Effects.RPC.IO (interpretRpcToIO) -import Brig.Effects.ServiceRPC (Service (Galley), ServiceRPC) -import Brig.Effects.ServiceRPC.IO (interpretServiceRpcToRpc) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore.Cassandra (userPendingActivationStoreToCassandra) import Brig.Options (ImplicitNoFederationRestriction (federationDomainConfig), federationDomainConfigs, federationStrategy) @@ -28,10 +24,18 @@ import Control.Lens ((^.)) import Control.Monad.Catch (throwM) import Imports import Polysemy (Embed, Final, embedToFinal, runFinal) +import Polysemy.Async +import Polysemy.Conc +import Polysemy.Embed (runEmbedded) import Polysemy.Error (Error, mapError, runError) import Polysemy.TinyLog (TinyLog) +import Wire.GundeckAPIAccess +import Wire.NotificationSubsystem +import Wire.NotificationSubsystem.Interpreter (defaultNotificationSubsystemConfig, runNotificationSubsystemGundeck) +import Wire.Rpc import Wire.Sem.Concurrency import Wire.Sem.Concurrency.IO +import Wire.Sem.Delay import Wire.Sem.Jwk import Wire.Sem.Logger.TinyLog (loggerToTinyLog) import Wire.Sem.Now (Now) @@ -39,7 +43,9 @@ import Wire.Sem.Now.IO (nowToIOAction) import Wire.Sem.Paging.Cassandra (InternalPaging) type BrigCanonicalEffects = - '[ FederationConfigStore, + '[ NotificationSubsystem, + GundeckAPIAccess, + FederationConfigStore, Jwk, PublicKeyBundle, JwtTools, @@ -48,15 +54,18 @@ type BrigCanonicalEffects = PasswordResetStore, UserPendingActivationStore InternalPaging, Now, + Delay, CodeStore, GalleyProvider, - ServiceRPC 'Galley, - RPC, + Rpc, Embed Cas.Client, Error ParseException, Error SomeException, TinyLog, + Embed HttpClientIO, Embed IO, + Race, + Async, Concurrency 'Unsafe, Final IO ] @@ -66,15 +75,18 @@ runBrigToIO e (AppT ma) = do ( either throwM pure <=< ( runFinal . unsafelyPerformConcurrency + . asyncToIOFinal + . interpretRace . embedToFinal + . runEmbedded (runHttpClientIO e) . loggerToTinyLog (e ^. applog) . runError @SomeException . mapError @ParseException SomeException . interpretClientToIO (e ^. casClient) - . interpretRpcToIO (e ^. httpManager) (e ^. requestId) - . interpretServiceRpcToRpc @'Galley "galley" (e ^. galley) - . interpretGalleyProviderToRPC (e ^. disabledVersions) + . runRpcWithHttp (e ^. httpManager) (e ^. requestId) + . interpretGalleyProviderToRpc (e ^. disabledVersions) (e ^. galleyEndpoint) . codeStoreToCassandra @Cas.Client + . runDelay . nowToIOAction (e ^. currentTime) . userPendingActivationStoreToCassandra . passwordResetStoreToCodeStore @@ -84,6 +96,8 @@ runBrigToIO e (AppT ma) = do . interpretPublicKeyBundle . interpretJwk . interpretFederationDomainConfig (e ^. settings . federationStrategy) (foldMap (remotesMapFromCfgFile . fmap (.federationDomainConfig)) (e ^. settings . federationDomainConfigs)) + . runGundeckAPIAccess (e ^. gundeckEndpoint) + . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig (e ^. requestId)) ) ) $ runReaderT ma e diff --git a/services/brig/src/Brig/Effects/Delay.hs b/services/brig/src/Brig/Effects/Delay.hs deleted file mode 100644 index 8a3b9dc6e91..00000000000 --- a/services/brig/src/Brig/Effects/Delay.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Brig.Effects.Delay where - -import Imports -import Polysemy - -data Delay m a where - Delay :: Int -> Delay m () - -makeSem ''Delay - -runDelay :: Member (Embed IO) r => Sem (Delay ': r) a -> Sem r a -runDelay = interpret $ \case - Delay i -> threadDelay i diff --git a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs index 2605aa1219c..481b4d28c09 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs +++ b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs @@ -14,16 +14,13 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -{-# OPTIONS_GHC -Wno-unused-matches #-} module Brig.Effects.GalleyProvider.RPC where import Bilge hiding (head, options, requestId) import Brig.API.Types import Brig.Effects.GalleyProvider (GalleyProvider (..)) -import Brig.Effects.ServiceRPC (Service (Galley), ServiceRPC) -import Brig.Effects.ServiceRPC qualified as ServiceRPC -import Brig.RPC +import Brig.RPC hiding (galleyRequest) import Brig.Team.Types (ShowOrHideInvitationUrl (..)) import Control.Error (hush) import Control.Lens ((^.)) @@ -43,8 +40,11 @@ import Network.HTTP.Types.Status import Network.Wai.Utilities.Error qualified as Wai import Polysemy import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog import Servant.API (toHeader) -import System.Logger (Msg, field, msg, val) +import System.Logger (field, msg, val) +import Util.Options import Wire.API.Conversation hiding (Member) import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Routes.Version @@ -55,43 +55,51 @@ import Wire.API.Team.Member qualified as Member import Wire.API.Team.Member qualified as Team import Wire.API.Team.Role import Wire.API.Team.SearchVisibility -import Wire.Sem.Logger +import Wire.Rpc -interpretGalleyProviderToRPC :: +interpretGalleyProviderToRpc :: ( Member (Error ParseException) r, - Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + Member Rpc r, + Member TinyLog r ) => Set Version -> + Endpoint -> Sem (GalleyProvider ': r) a -> Sem r a -interpretGalleyProviderToRPC disabledVersions = +interpretGalleyProviderToRpc disabledVersions galleyEndpoint = let v = fromMaybe (error "service can't run with undefined API version") $ maxAvailableVersion disabledVersions - in interpret $ \case - CreateSelfConv id' -> createSelfConv v id' - GetConv id' id'' -> getConv v id' id'' - GetTeamConv id' id'' id'2 -> getTeamConv v id' id'' id'2 - NewClient id' ci -> newClient id' ci - CheckUserCanJoinTeam id' -> checkUserCanJoinTeam id' - AddTeamMember id' id'' x0 -> addTeamMember id' id'' x0 - CreateTeam id' bnt id'' -> createTeam id' bnt id'' - GetTeamMember id' id'' -> getTeamMember id' id'' - GetTeamMembers id' -> getTeamMembers id' - GetTeamId id' -> getTeamId id' - GetTeam id' -> getTeam id' - GetTeamName id' -> getTeamName id' - GetTeamLegalHoldStatus id' -> getTeamLegalHoldStatus id' - GetTeamSearchVisibility id' -> getTeamSearchVisibility id' - ChangeTeamStatus id' ts m_al -> changeTeamStatus id' ts m_al - MemberIsTeamOwner id' id'' -> memberIsTeamOwner id' id'' - GetAllFeatureConfigsForUser m_id' -> getAllFeatureConfigsForUser m_id' - GetVerificationCodeEnabled id' -> getVerificationCodeEnabled id' - GetExposeInvitationURLsToTeamAdmin id' -> getTeamExposeInvitationURLsToTeamAdmin id' + in interpret $ + runInputConst galleyEndpoint . \case + CreateSelfConv id' -> createSelfConv v id' + GetConv id' id'' -> getConv v id' id'' + GetTeamConv id' id'' id'2 -> getTeamConv v id' id'' id'2 + NewClient id' ci -> newClient id' ci + CheckUserCanJoinTeam id' -> checkUserCanJoinTeam id' + AddTeamMember id' id'' x0 -> addTeamMember id' id'' x0 + CreateTeam id' bnt id'' -> createTeam id' bnt id'' + GetTeamMember id' id'' -> getTeamMember id' id'' + GetTeamMembers id' -> getTeamMembers id' + GetTeamId id' -> getTeamId id' + GetTeam id' -> getTeam id' + GetTeamName id' -> getTeamName id' + GetTeamLegalHoldStatus id' -> getTeamLegalHoldStatus id' + GetTeamSearchVisibility id' -> getTeamSearchVisibility id' + ChangeTeamStatus id' ts m_al -> changeTeamStatus id' ts m_al + MemberIsTeamOwner id' id'' -> memberIsTeamOwner id' id'' + GetAllFeatureConfigsForUser m_id' -> getAllFeatureConfigsForUser m_id' + GetVerificationCodeEnabled id' -> getVerificationCodeEnabled id' + GetExposeInvitationURLsToTeamAdmin id' -> getTeamExposeInvitationURLsToTeamAdmin id' + +galleyRequest :: (Member Rpc r, Member (Input Endpoint) r) => (Request -> Request) -> Sem r (Response (Maybe LByteString)) +galleyRequest req = do + ep <- input + rpcWithRetries "galley" ep req -- | Calls 'Galley.API.createSelfConversationH'. createSelfConv :: - ( Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + ( Member Rpc r, + Member TinyLog r, + Member (Input Endpoint) r ) => Version -> UserId -> @@ -100,18 +108,19 @@ createSelfConv v u = do debug $ remote "galley" . msg (val "Creating self conversation") - void $ ServiceRPC.request @'Galley POST req - where - req = - paths [toHeader v, "conversations", "self"] + void $ + galleyRequest $ + method POST + . paths [toHeader v, "conversations", "self"] . zUser u . expect2xx -- | Calls 'Galley.API.getConversationH'. getConv :: ( Member (Error ParseException) r, - Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => Version -> UserId -> @@ -123,26 +132,28 @@ getConv v usr lcnv = do . field "domain" (toByteString (tDomain lcnv)) . field "conv" (toByteString (tUnqualified lcnv)) . msg (val "Getting conversation") - rs <- ServiceRPC.request @'Galley GET req + rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs _ -> pure Nothing where req = - paths - [ toHeader v, - "conversations", - toByteString' (tDomain lcnv), - toByteString' (tUnqualified lcnv) - ] + method GET + . paths + [ toHeader v, + "conversations", + toByteString' (tDomain lcnv), + toByteString' (tUnqualified lcnv) + ] . zUser usr . expect [status200, status404] -- | Calls 'Galley.API.getTeamConversationH'. getTeamConv :: ( Member (Error ParseException) r, - Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => Version -> UserId -> @@ -154,26 +165,28 @@ getTeamConv v usr tid cnv = do remote "galley" . field "conv" (toByteString cnv) . msg (val "Getting team conversation") - rs <- ServiceRPC.request @'Galley GET req + rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs _ -> pure Nothing where req = - paths - [ toHeader v, - "teams", - toByteString' tid, - "conversations", - toByteString' cnv - ] + method GET + . paths + [ toHeader v, + "teams", + toByteString' tid, + "conversations", + toByteString' cnv + ] . zUser usr . expect [status200, status404] -- | Calls 'Galley.API.addClientH'. newClient :: - ( Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + ( Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => UserId -> ClientId -> @@ -184,13 +197,17 @@ newClient u c = do . field "user" (toByteString u) . field "client" (toByteString c) . msg (val "new client") - let p = paths ["i", "clients", toByteString' c] - void $ ServiceRPC.request @'Galley POST (p . zUser u . expect2xx) + void . galleyRequest $ + method POST + . paths ["i", "clients", toByteString' c] + . zUser u + . expect2xx -- | Calls 'Galley.API.canUserJoinTeamH'. checkUserCanJoinTeam :: - ( Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + ( Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => TeamId -> Sem r (Maybe Wai.Error) @@ -198,7 +215,7 @@ checkUserCanJoinTeam tid = do debug $ remote "galley" . msg (val "Check if can add member to team") - rs <- ServiceRPC.request @'Galley GET req + rs <- galleyRequest req pure $ case Bilge.statusCode rs of 200 -> Nothing _ -> case decodeBodyMaybe "galley" rs of @@ -206,13 +223,15 @@ checkUserCanJoinTeam tid = do Nothing -> error ("Invalid response from galley: " <> show rs) where req = - paths ["i", "teams", toByteString' tid, "members", "check"] + method GET + . paths ["i", "teams", toByteString' tid, "members", "check"] . header "Content-Type" "application/json" -- | Calls 'Galley.API.uncheckedAddTeamMemberH'. addTeamMember :: - ( Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + ( Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => UserId -> TeamId -> @@ -222,7 +241,7 @@ addTeamMember u tid (minvmeta, role) = do debug $ remote "galley" . msg (val "Adding member to team") - rs <- ServiceRPC.request @'Galley POST req + rs <- galleyRequest req pure $ case Bilge.statusCode rs of 200 -> True _ -> False @@ -230,7 +249,8 @@ addTeamMember u tid (minvmeta, role) = do prm = Team.rolePermissions role bdy = Member.mkNewTeamMember u prm minvmeta req = - paths ["i", "teams", toByteString' tid, "members"] + method POST + . paths ["i", "teams", toByteString' tid, "members"] . header "Content-Type" "application/json" . zUser u . expect [status200, status403] @@ -238,8 +258,9 @@ addTeamMember u tid (minvmeta, role) = do -- | Calls 'Galley.API.createBindingTeamH'. createTeam :: - ( Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + ( Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => UserId -> BindingNewTeam -> @@ -249,7 +270,7 @@ createTeam u t@(BindingNewTeam bt) teamid = do debug $ remote "galley" . msg (val "Creating Team") - r <- ServiceRPC.request @'Galley PUT $ req teamid + r <- galleyRequest $ req teamid tid <- maybe (error "invalid team id") pure $ fromByteString $ @@ -257,7 +278,8 @@ createTeam u t@(BindingNewTeam bt) teamid = do pure (CreateUserTeam tid $ fromRange (bt ^. newTeamName)) where req tid = - paths ["i", "teams", toByteString' tid] + method PUT + . paths ["i", "teams", toByteString' tid] . header "Content-Type" "application/json" . zUser u . expect2xx @@ -266,8 +288,9 @@ createTeam u t@(BindingNewTeam bt) teamid = do -- | Calls 'Galley.API.uncheckedGetTeamMemberH'. getTeamMember :: ( Member (Error ParseException) r, - Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => UserId -> TeamId -> @@ -276,13 +299,14 @@ getTeamMember u tid = do debug $ remote "galley" . msg (val "Get team member") - rs <- ServiceRPC.request @'Galley GET req + rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs _ -> pure Nothing where req = - paths ["i", "teams", toByteString' tid, "members", toByteString' u] + method GET + . paths ["i", "teams", toByteString' tid, "members", toByteString' u] . zUser u . expect [status200, status404] @@ -293,131 +317,146 @@ getTeamMember u tid = do -- be suspended, and the rest will remain active. getTeamMembers :: ( Member (Error ParseException) r, - Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => TeamId -> Sem r Team.TeamMemberList getTeamMembers tid = do debug $ remote "galley" . msg (val "Get team members") - ServiceRPC.request @'Galley GET req >>= decodeBodyOrThrow "galley" + galleyRequest req >>= decodeBodyOrThrow "galley" where req = - paths ["i", "teams", toByteString' tid, "members"] + method GET + . paths ["i", "teams", toByteString' tid, "members"] . expect2xx memberIsTeamOwner :: - Member (ServiceRPC 'Galley) r => + (Member Rpc r, Member (Input Endpoint) r) => TeamId -> UserId -> Sem r Bool memberIsTeamOwner tid uid = do r <- - ServiceRPC.request @'Galley GET $ - paths ["i", "teams", toByteString' tid, "is-team-owner", toByteString' uid] + galleyRequest $ + method GET + . paths ["i", "teams", toByteString' tid, "is-team-owner", toByteString' uid] pure $ responseStatus r /= status403 -- | Calls 'Galley.API.getBindingTeamIdH'. getTeamId :: ( Member (Error ParseException) r, - Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => UserId -> Sem r (Maybe TeamId) getTeamId u = do debug $ remote "galley" . msg (val "Get team from user") - rs <- ServiceRPC.request @'Galley GET req + rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs _ -> pure Nothing where req = - paths ["i", "users", toByteString' u, "team"] + method GET + . paths ["i", "users", toByteString' u, "team"] . expect [status200, status404] -- | Calls 'Galley.API.getTeamInternalH'. getTeam :: ( Member (Error ParseException) r, - Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => TeamId -> Sem r Team.TeamData getTeam tid = do debug $ remote "galley" . msg (val "Get team info") - ServiceRPC.request @'Galley GET req >>= decodeBodyOrThrow "galley" + galleyRequest req >>= decodeBodyOrThrow "galley" where req = - paths ["i", "teams", toByteString' tid] + method GET + . paths ["i", "teams", toByteString' tid] . expect2xx -- | Calls 'Galley.API.getTeamInternalH'. getTeamName :: ( Member (Error ParseException) r, - Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => TeamId -> Sem r Team.TeamName getTeamName tid = do debug $ remote "galley" . msg (val "Get team info") - ServiceRPC.request @'Galley GET req >>= decodeBodyOrThrow "galley" + galleyRequest req >>= decodeBodyOrThrow "galley" where req = - paths ["i", "teams", toByteString' tid, "name"] + method GET + . paths ["i", "teams", toByteString' tid, "name"] . expect2xx -- | Calls 'Galley.API.getTeamFeatureStatusH'. getTeamLegalHoldStatus :: ( Member (Error ParseException) r, - Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => TeamId -> Sem r (WithStatus LegalholdConfig) getTeamLegalHoldStatus tid = do debug $ remote "galley" . msg (val "Get legalhold settings") - ServiceRPC.request @'Galley GET req >>= decodeBodyOrThrow "galley" + galleyRequest req >>= decodeBodyOrThrow "galley" where req = - paths ["i", "teams", toByteString' tid, "features", featureNameBS @LegalholdConfig] + method GET + . paths ["i", "teams", toByteString' tid, "features", featureNameBS @LegalholdConfig] . expect2xx -- | Calls 'Galley.API.getSearchVisibilityInternalH'. getTeamSearchVisibility :: ( Member (Error ParseException) r, - Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => TeamId -> Sem r TeamSearchVisibility getTeamSearchVisibility tid = coerce @TeamSearchVisibilityView @TeamSearchVisibility <$> do debug $ remote "galley" . msg (val "Get search visibility settings") - ServiceRPC.request @'Galley GET req >>= decodeBodyOrThrow "galley" + galleyRequest req >>= decodeBodyOrThrow "galley" where req = - paths ["i", "teams", toByteString' tid, "search-visibility"] + method GET + . paths ["i", "teams", toByteString' tid, "search-visibility"] . expect2xx getVerificationCodeEnabled :: ( Member (Error ParseException) r, - Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => TeamId -> Sem r Bool getVerificationCodeEnabled tid = do debug $ remote "galley" . msg (val "Get snd factor password challenge settings") - response <- ServiceRPC.request @'Galley GET req + response <- galleyRequest req status <- wsStatus <$> decodeBodyOrThrow @(WithStatus SndFactorPasswordChallengeConfig) "galley" response case status of FeatureStatusEnabled -> pure True FeatureStatusDisabled -> pure False where req = - paths ["i", "teams", toByteString' tid, "features", featureNameBS @SndFactorPasswordChallengeConfig] + method GET + . paths ["i", "teams", toByteString' tid, "features", featureNameBS @SndFactorPasswordChallengeConfig] . expect2xx decodeBodyOrThrow :: forall a r. (Typeable a, FromJSON a, Member (Error ParseException) r) => Text -> Response (Maybe BL.ByteString) -> Sem r a @@ -433,21 +472,22 @@ decodeBodyMaybe :: (Typeable a, FromJSON a) => Text -> Response (Maybe BL.ByteSt decodeBodyMaybe t r = hush $ decodeBody t r getAllFeatureConfigsForUser :: - Member (ServiceRPC 'Galley) r => + (Member Rpc r, Member (Input Endpoint) r) => Maybe UserId -> Sem r AllFeatureConfigs getAllFeatureConfigsForUser mbUserId = responseJsonUnsafe - <$> ServiceRPC.request @'Galley - GET - ( paths ["i", "feature-configs"] + <$> galleyRequest + ( method GET + . paths ["i", "feature-configs"] . maybe id (queryItem "user_id" . toByteString') mbUserId ) -- | Calls 'Galley.API.updateTeamStatusH'. changeTeamStatus :: - ( Member (ServiceRPC 'Galley) r, - Member (Logger (Msg -> Msg)) r + ( Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r ) => TeamId -> Team.TeamStatus -> @@ -455,29 +495,32 @@ changeTeamStatus :: Sem r () changeTeamStatus tid s cur = do debug $ remote "galley" . msg (val "Change Team status") - void $ ServiceRPC.request @'Galley PUT req + void $ galleyRequest req where req = - paths ["i", "teams", toByteString' tid, "status"] + method PUT + . paths ["i", "teams", toByteString' tid, "status"] . header "Content-Type" "application/json" . expect2xx . lbytes (encode $ Team.TeamStatusUpdate s cur) getTeamExposeInvitationURLsToTeamAdmin :: - ( Member (ServiceRPC 'Galley) r, + ( Member Rpc r, + Member (Input Endpoint) r, Member (Error ParseException) r, - Member (Logger (Msg -> Msg)) r + Member TinyLog r ) => TeamId -> Sem r ShowOrHideInvitationUrl getTeamExposeInvitationURLsToTeamAdmin tid = do debug $ remote "galley" . msg (val "Get expose invitation URLs to team admin settings") - response <- ServiceRPC.request @'Galley GET req + response <- galleyRequest req status <- wsStatus <$> decodeBodyOrThrow @(WithStatus ExposeInvitationURLsToTeamAdminConfig) "galley" response case status of FeatureStatusEnabled -> pure ShowInvitationUrl FeatureStatusDisabled -> pure HideInvitationUrl where req = - paths ["i", "teams", toByteString' tid, "features", featureNameBS @ExposeInvitationURLsToTeamAdminConfig] + method GET + . paths ["i", "teams", toByteString' tid, "features", featureNameBS @ExposeInvitationURLsToTeamAdminConfig] . expect2xx diff --git a/services/brig/src/Brig/Effects/RPC.hs b/services/brig/src/Brig/Effects/RPC.hs deleted file mode 100644 index 526db218e82..00000000000 --- a/services/brig/src/Brig/Effects/RPC.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Brig.Effects.RPC where - -import Bilge -import Data.ByteString.Lazy qualified as BL -import Data.Text.Lazy qualified as LT -import Imports -import Network.HTTP.Types.Method -import Polysemy - -data RPC m a where - ServiceRequest :: - LT.Text -> - Request -> - StdMethod -> - (Request -> Request) -> - RPC m (Response (Maybe BL.ByteString)) - -makeSem ''RPC diff --git a/services/brig/src/Brig/Effects/RPC/IO.hs b/services/brig/src/Brig/Effects/RPC/IO.hs deleted file mode 100644 index d3259f2d443..00000000000 --- a/services/brig/src/Brig/Effects/RPC/IO.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Brig.Effects.RPC.IO where - -import Bilge (HttpT, MonadHttp, RequestId) -import Bilge.IO (Manager, runHttpT) -import Bilge.RPC -import Brig.Effects.RPC -import Brig.RPC qualified as RPC -import Control.Monad.Catch -import Imports -import Polysemy - -interpretRpcToIO :: Member (Final IO) r => Manager -> RequestId -> Sem (RPC ': r) a -> Sem r a -interpretRpcToIO mgr rid = interpret $ \case - ServiceRequest txt f sm g -> - embedFinal @IO $ viaHttpIO mgr rid $ RPC.serviceRequestImpl txt f sm g - -viaHttpIO :: Manager -> RequestId -> HttpIO a -> IO a -viaHttpIO mgr rid = runHttpT mgr . flip runReaderT rid . runHttpIO - -newtype HttpIO a = HttpIO - { runHttpIO :: ReaderT RequestId (HttpT IO) a - } - deriving newtype - ( Functor, - Applicative, - Monad, - MonadHttp, - MonadIO, - MonadThrow, - MonadCatch, - MonadMask, - MonadUnliftIO - ) - -instance HasRequestId HttpIO where - getRequestId = HttpIO ask diff --git a/services/brig/src/Brig/Effects/ServiceRPC.hs b/services/brig/src/Brig/Effects/ServiceRPC.hs deleted file mode 100644 index 49fc6bf4336..00000000000 --- a/services/brig/src/Brig/Effects/ServiceRPC.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Brig.Effects.ServiceRPC where - -import Bilge -import Data.ByteString.Lazy qualified as BL -import Imports -import Network.HTTP.Types.Method -import Polysemy - -data Service - = Galley - -data ServiceRPC (service :: Service) m a where - Request :: - StdMethod -> - (Request -> Request) -> - ServiceRPC service m (Response (Maybe BL.ByteString)) - -makeSem ''ServiceRPC diff --git a/services/brig/src/Brig/Effects/ServiceRPC/IO.hs b/services/brig/src/Brig/Effects/ServiceRPC/IO.hs deleted file mode 100644 index bca763adc16..00000000000 --- a/services/brig/src/Brig/Effects/ServiceRPC/IO.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Brig.Effects.ServiceRPC.IO where - -import Bilge (Request) -import Brig.Effects.RPC -import Brig.Effects.ServiceRPC -import Data.Text.Lazy qualified as LT -import Imports -import Polysemy - -interpretServiceRpcToRpc :: - forall service r a. - Member RPC r => - LT.Text -> - Request -> - Sem (ServiceRPC service ': r) a -> - Sem r a -interpretServiceRpcToRpc lt r = interpret $ \case - Request sm f -> serviceRequest lt r sm f diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 1735cd65d5c..61dc0c3e272 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -34,7 +34,6 @@ module Brig.IO.Intra -- * Clients rmClient, - lookupPushToken, -- * Account Deletion rmUser, @@ -49,7 +48,6 @@ where import Bilge hiding (head, options, requestId) import Bilge.RPC -import Bilge.Retry import Brig.API.Error (internalServerError) import Brig.API.Types import Brig.API.Util @@ -60,16 +58,13 @@ import Brig.Federation.Client (notifyUserDeleted) import Brig.IO.Journal qualified as Journal import Brig.RPC import Brig.Types.User.Event -import Brig.User.Search.Index (MonadIndexIO) import Brig.User.Search.Index qualified as Search import Cassandra (MonadClient) import Conduit (runConduit, (.|)) import Control.Error (ExceptT) -import Control.Error.Util import Control.Lens (view, (.~), (?~), (^.), (^?)) import Control.Monad.Catch -import Control.Monad.Trans.Except (runExceptT, throwE) -import Control.Retry +import Control.Monad.Trans.Except (throwE) import Data.Aeson hiding (json) import Data.Aeson.KeyMap qualified as KeyMap import Data.Aeson.Lens @@ -78,22 +73,23 @@ import Data.ByteString.Lazy qualified as BL import Data.Conduit.List qualified as C import Data.Id import Data.Json.Util ((#)) -import Data.List.Split (chunksOf) -import Data.List1 (List1, list1, singleton) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List1 (List1, singleton) import Data.Proxy import Data.Qualified import Data.Range -import Data.Set qualified as Set import GHC.TypeLits -import Gundeck.Types.Push.V2 -import Gundeck.Types.Push.V2 qualified as Push +import Gundeck.Types.Push.V2 (RecipientClients (RecipientClientsAll)) +import Gundeck.Types.Push.V2 qualified as V2 import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status -import System.Logger.Class as Log hiding (name, (.=)) -import System.Logger.Extended qualified as ExLog +import Polysemy +import Polysemy.TinyLog (TinyLog) +import System.Logger.Class (MonadLogger) +import System.Logger.Message hiding ((.=)) import Wire.API.Connection -import Wire.API.Conversation +import Wire.API.Conversation hiding (Member) import Wire.API.Event.Conversation (Connect (Connect)) import Wire.API.Federation.API.Brig import Wire.API.Federation.Error @@ -104,95 +100,85 @@ import Wire.API.Team.LegalHold (LegalholdProtectee) import Wire.API.Team.Member qualified as Team import Wire.API.User import Wire.API.User.Client +import Wire.NotificationSubsystem +import Wire.Rpc +import Wire.Sem.Logger qualified as Log ----------------------------------------------------------------------------- -- Event Handlers onUserEvent :: - ( MonadLogger m, - MonadIndexIO m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - MonadClient m + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r ) => UserId -> Maybe ConnId -> UserEvent -> - m () + Sem r () onUserEvent orig conn e = updateSearchIndex orig e *> dispatchNotifications orig conn e - *> journalEvent orig e + *> embed (journalEvent orig e) onConnectionEvent :: + (Member NotificationSubsystem r) => -- | Originator of the event. UserId -> -- | Client connection ID, if any. Maybe ConnId -> -- | The event. ConnectionEvent -> - (AppT r) () + Sem r () onConnectionEvent orig conn evt = do let from = ucFrom (ucConn evt) - wrapHttp $ - notify - (singleton $ ConnectionEvent evt) - orig - Push.RouteAny - conn - (pure $ list1 from []) + notify + (singleton $ ConnectionEvent evt) + orig + V2.RouteAny + conn + (pure $ from :| []) onPropertyEvent :: + (Member NotificationSubsystem r) => -- | Originator of the event. UserId -> -- | Client connection ID. ConnId -> PropertyEvent -> - (AppT r) () + Sem r () onPropertyEvent orig conn e = - wrapHttp $ - notify - (singleton $ PropertyEvent e) - orig - Push.RouteDirect - (Just conn) - (pure $ list1 orig []) + notify + (singleton $ PropertyEvent e) + orig + V2.RouteDirect + (Just conn) + (pure $ orig :| []) onClientEvent :: - ( MonadIO m, - Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + (Member NotificationSubsystem r) => -- | Originator of the event. UserId -> -- | Client connection ID. Maybe ConnId -> -- | The event. ClientEvent -> - m () + Sem r () onClientEvent orig conn e = do - let events = singleton (ClientEvent e) - let rcps = list1 orig [] - -- Synchronous push for better delivery guarantees of these - -- events and to make sure new clients have a first notification - -- in the stream. - push events rcps orig Push.RouteAny conn + let event = ClientEvent e + let rcps = Recipient orig V2.RecipientClientsAll :| [] + pushNotifications + [ newPush1 (Just orig) (toPushFormat event) rcps + & pushConn .~ conn + & pushApsData .~ toApsData event + ] updateSearchIndex :: - ( MonadClient m, - MonadLogger m, - MonadIndexIO m - ) => + Member (Embed HttpClientIO) r => UserId -> UserEvent -> - m () -updateSearchIndex orig e = case e of + Sem r () +updateSearchIndex orig e = embed $ case e of -- no-ops UserCreated {} -> pure () UserIdentityUpdated UserIdentityUpdatedData {..} -> do @@ -240,56 +226,47 @@ journalEvent orig e = case e of -- as well as his other clients about a change to his user account -- or profile. dispatchNotifications :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - MonadClient m + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r ) => UserId -> Maybe ConnId -> UserEvent -> - m () + Sem r () dispatchNotifications orig conn e = case e of UserCreated {} -> pure () UserSuspended {} -> pure () UserResumed {} -> pure () - LegalHoldClientRequested {} -> notifyContacts event orig Push.RouteAny conn - UserLegalHoldDisabled {} -> notifyContacts event orig Push.RouteAny conn - UserLegalHoldEnabled {} -> notifyContacts event orig Push.RouteAny conn + LegalHoldClientRequested {} -> notifyContacts event orig V2.RouteAny conn + UserLegalHoldDisabled {} -> notifyContacts event orig V2.RouteAny conn + UserLegalHoldEnabled {} -> notifyContacts event orig V2.RouteAny conn UserUpdated UserUpdatedData {..} -- This relies on the fact that we never change the locale AND something else. - | isJust eupLocale -> notifySelf event orig Push.RouteDirect conn - | otherwise -> notifyContacts event orig Push.RouteDirect conn - UserActivated {} -> notifySelf event orig Push.RouteAny conn - UserIdentityUpdated {} -> notifySelf event orig Push.RouteDirect conn - UserIdentityRemoved {} -> notifySelf event orig Push.RouteDirect conn + | isJust eupLocale -> notifySelf event orig V2.RouteDirect conn + | otherwise -> notifyContacts event orig V2.RouteDirect conn + UserActivated {} -> notifySelf event orig V2.RouteAny conn + UserIdentityUpdated {} -> notifySelf event orig V2.RouteDirect conn + UserIdentityRemoved {} -> notifySelf event orig V2.RouteDirect conn UserDeleted {} -> do -- n.b. Synchronously fetch the contact list on the current thread. -- If done asynchronously, the connections may already have been deleted. notifyUserDeletionLocals orig conn event - notifyUserDeletionRemotes orig + embed $ notifyUserDeletionRemotes orig where event = singleton $ UserEvent e notifyUserDeletionLocals :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - MonadClient m + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r ) => UserId -> Maybe ConnId -> List1 Event -> - m () + Sem r () notifyUserDeletionLocals deleted conn event = do - recipients <- list1 deleted <$> lookupContactList deleted - notify event deleted Push.RouteDirect conn (pure recipients) + recipients <- (:|) deleted <$> embed (lookupContactList deleted) + notify event deleted V2.RouteDirect conn (pure recipients) notifyUserDeletionRemotes :: forall m. @@ -319,175 +296,63 @@ notifyUserDeletionRemotes deleted = do luidDeleted <- qualifyLocal deleted notifyUserDeleted luidDeleted (qualifyAs uids rangedUids) --- | Push events to other users. -push :: - ( MonadIO m, - Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => - -- | The events to push. - List1 Event -> - -- | The users to push to. - List1 UserId -> - -- | The originator of the events. - UserId -> - -- | The push routing strategy. - Push.Route -> - -- | The originating device connection. - Maybe ConnId -> - m () -push (toList -> events) usrs orig route conn = - case mapMaybe toPushData events of - [] -> pure () - x : xs -> rawPush (list1 x xs) usrs orig route conn - where - toPushData :: Event -> Maybe (Builder, (Object, Maybe ApsData)) - toPushData e = case toPushFormat e of - Just o -> Just (Log.bytes e, (o, toApsData e)) - Nothing -> Nothing - --- | Push encoded events to other users. Useful if you want to push --- something that's not defined in Brig. -rawPush :: - ( MonadIO m, - Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => - -- | The events to push. - List1 (Builder, (Object, Maybe ApsData)) -> - -- | The users to push to. - List1 UserId -> - -- | The originator of the events. - UserId -> - -- | The push routing strategy. - Push.Route -> - -- | The originating device connection. - Maybe ConnId -> - m () --- TODO: if we decide to have service whitelist events in Brig instead of --- Galley, let's merge 'push' and 'rawPush' back. See Note [whitelist events]. -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 -- FUTUREWORK: Remove, because gundeck handler ignores this. - . 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 - mkPush :: Range 1 1024 (Set.Set Recipient) -> (Object, Maybe ApsData) -> Push - mkPush rcps (o, aps) = - newPush - (Just orig) - rcps - (singletonPayload o) - & pushOriginConnection .~ conn - & pushNativeAps .~ aps - -- | (Asynchronously) notifies other users of events. notify :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m - ) => + (Member NotificationSubsystem r) => List1 Event -> -- | Origin user, TODO: Delete UserId -> -- | Push routing strategy. - Push.Route -> + V2.Route -> -- | Origin device connection, if any. Maybe ConnId -> -- | Users to notify. - m (List1 UserId) -> - m () -notify events orig route conn recipients = fork (Just orig) $ do - rs <- recipients - push events rs orig route conn - -fork :: - (MonadUnliftIO m, MonadReader Env m) => - Maybe UserId -> - m a -> - m () -fork u ma = do - g <- view applog - r <- view requestId - let logErr e = ExLog.err g $ request r ~~ user u ~~ msg (show e) - withRunInIO $ \lower -> - void . liftIO . forkIO $ - either logErr (const $ pure ()) - =<< runExceptT (syncIO $ lower ma) - where - request = field "request" . unRequestId - user = maybe id (field "user" . toByteString) + Sem r (NonEmpty UserId) -> + Sem r () +notify (toList -> events) orig route conn recipients = do + rs <- (\u -> Recipient u RecipientClientsAll) <$$> recipients + let pushes = flip map events $ \event -> + newPush1 (Just orig) (toPushFormat event) rs + & pushConn .~ conn + & pushRoute .~ route + & pushApsData .~ toApsData event + void $ pushNotificationsAsync pushes notifySelf :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m - ) => + (Member NotificationSubsystem r) => List1 Event -> -- | Origin user. UserId -> -- | Push routing strategy. - Push.Route -> + V2.Route -> -- | Origin device connection, if any. Maybe ConnId -> - m () + Sem r () notifySelf events orig route conn = - notify events orig route conn (pure (singleton orig)) + notify events orig route conn (pure (orig :| [])) notifyContacts :: - forall m. - ( MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m, - MonadClient m, - MonadUnliftIO m + forall r. + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r ) => List1 Event -> -- | Origin user. UserId -> -- | Push routing strategy. - Push.Route -> + V2.Route -> -- | Origin device connection, if any. Maybe ConnId -> - m () + Sem r () notifyContacts events orig route conn = do notify events orig route conn $ - list1 orig <$> liftA2 (++) contacts teamContacts + (:|) orig <$> liftA2 (++) contacts teamContacts where - contacts :: m [UserId] - contacts = lookupContactList orig + contacts :: Sem r [UserId] + contacts = embed $ lookupContactList orig - teamContacts :: m [UserId] + teamContacts :: Sem r [UserId] teamContacts = screenMemberList <$> getTeamContacts orig -- If we have a truncated team, we just ignore it all together to avoid very large fanouts -- @@ -499,144 +364,127 @@ notifyContacts events orig route conn = do -- Event Serialisation: -toPushFormat :: Event -> Maybe Object +toPushFormat :: Event -> Object toPushFormat (UserEvent (UserCreated u)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.new" :: Text), - "user" .= SelfProfile (u {userIdentity = Nothing}) - ] + KeyMap.fromList + [ "type" .= ("user.new" :: Text), + "user" .= SelfProfile (u {userIdentity = Nothing}) + ] toPushFormat (UserEvent (UserActivated u)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.activate" :: Text), - "user" .= SelfProfile u - ] + KeyMap.fromList + [ "type" .= ("user.activate" :: Text), + "user" .= SelfProfile u + ] toPushFormat (UserEvent (UserUpdated (UserUpdatedData i n pic acc ass hdl loc mb ssoId ssoIdDel prots))) = - Just $ - KeyMap.fromList - [ "type" .= ("user.update" :: Text), - "user" - .= object - ( "id" .= i - # "name" .= n - # "picture" .= pic -- DEPRECATED - # "accent_id" .= acc - # "assets" .= ass - # "handle" .= hdl - # "locale" .= loc - # "managed_by" .= mb - # "sso_id" .= ssoId - # "sso_id_deleted" .= ssoIdDel - # "supported_protocols" .= prots - # [] - ) - ] + KeyMap.fromList + [ "type" .= ("user.update" :: Text), + "user" + .= object + ( "id" .= i + # "name" .= n + # "picture" .= pic -- DEPRECATED + # "accent_id" .= acc + # "assets" .= ass + # "handle" .= hdl + # "locale" .= loc + # "managed_by" .= mb + # "sso_id" .= ssoId + # "sso_id_deleted" .= ssoIdDel + # "supported_protocols" .= prots + # [] + ) + ] toPushFormat (UserEvent (UserIdentityUpdated UserIdentityUpdatedData {..})) = - Just $ - KeyMap.fromList - [ "type" .= ("user.update" :: Text), - "user" - .= object - ( "id" .= eiuId - # "email" .= eiuEmail - # "phone" .= eiuPhone - # [] - ) - ] + KeyMap.fromList + [ "type" .= ("user.update" :: Text), + "user" + .= object + ( "id" .= eiuId + # "email" .= eiuEmail + # "phone" .= eiuPhone + # [] + ) + ] toPushFormat (UserEvent (UserIdentityRemoved (UserIdentityRemovedData i e p))) = - Just $ - KeyMap.fromList - [ "type" .= ("user.identity-remove" :: Text), - "user" - .= object - ( "id" .= i - # "email" .= e - # "phone" .= p - # [] - ) - ] + KeyMap.fromList + [ "type" .= ("user.identity-remove" :: Text), + "user" + .= object + ( "id" .= i + # "email" .= e + # "phone" .= p + # [] + ) + ] toPushFormat (ConnectionEvent (ConnectionUpdated uc _ name)) = - Just $ - KeyMap.fromList $ - "type" .= ("user.connection" :: Text) - # "connection" .= uc - # "user" .= case name of - Just n -> Just $ object ["name" .= n] - Nothing -> Nothing - # [] + KeyMap.fromList $ + "type" .= ("user.connection" :: Text) + # "connection" .= uc + # "user" .= case name of + Just n -> Just $ object ["name" .= n] + Nothing -> Nothing + # [] toPushFormat (UserEvent (UserSuspended i)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.suspend" :: Text), - "id" .= i - ] + KeyMap.fromList + [ "type" .= ("user.suspend" :: Text), + "id" .= i + ] toPushFormat (UserEvent (UserResumed i)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.resume" :: Text), - "id" .= i - ] + KeyMap.fromList + [ "type" .= ("user.resume" :: Text), + "id" .= i + ] toPushFormat (UserEvent (UserDeleted qid)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.delete" :: Text), - "id" .= qUnqualified qid, - "qualified_id" .= qid - ] + KeyMap.fromList + [ "type" .= ("user.delete" :: Text), + "id" .= qUnqualified qid, + "qualified_id" .= qid + ] toPushFormat (UserEvent (UserLegalHoldDisabled i)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.legalhold-disable" :: Text), - "id" .= i - ] + KeyMap.fromList + [ "type" .= ("user.legalhold-disable" :: Text), + "id" .= i + ] toPushFormat (UserEvent (UserLegalHoldEnabled i)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.legalhold-enable" :: Text), - "id" .= i - ] + KeyMap.fromList + [ "type" .= ("user.legalhold-enable" :: Text), + "id" .= i + ] toPushFormat (PropertyEvent (PropertySet _ k v)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.properties-set" :: Text), - "key" .= k, - "value" .= propertyValue v - ] + KeyMap.fromList + [ "type" .= ("user.properties-set" :: Text), + "key" .= k, + "value" .= propertyValue v + ] toPushFormat (PropertyEvent (PropertyDeleted _ k)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.properties-delete" :: Text), - "key" .= k - ] + KeyMap.fromList + [ "type" .= ("user.properties-delete" :: Text), + "key" .= k + ] toPushFormat (PropertyEvent (PropertiesCleared _)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.properties-clear" :: Text) - ] + KeyMap.fromList + [ "type" .= ("user.properties-clear" :: Text) + ] toPushFormat (ClientEvent (ClientAdded _ c)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.client-add" :: Text), - "client" .= c - ] + KeyMap.fromList + [ "type" .= ("user.client-add" :: Text), + "client" .= c + ] toPushFormat (ClientEvent (ClientRemoved _ clientId)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.client-remove" :: Text), - "client" .= IdObject clientId - ] + KeyMap.fromList + [ "type" .= ("user.client-remove" :: Text), + "client" .= IdObject clientId + ] toPushFormat (UserEvent (LegalHoldClientRequested payload)) = let LegalHoldClientRequestedData targetUser lastPrekey' clientId = payload - in Just $ - KeyMap.fromList - [ "type" .= ("user.legalhold-request" :: Text), - "id" .= targetUser, - "last_prekey" .= lastPrekey', - "client" .= IdObject clientId - ] - -toApsData :: Event -> Maybe ApsData + in KeyMap.fromList + [ "type" .= ("user.legalhold-request" :: Text), + "id" .= targetUser, + "last_prekey" .= lastPrekey', + "client" .= IdObject clientId + ] + +toApsData :: Event -> Maybe V2.ApsData toApsData (ConnectionEvent (ConnectionUpdated uc _ name)) = case (ucStatus uc, name) of (MissingLegalholdConsent, _) -> Nothing @@ -648,11 +496,11 @@ toApsData (ConnectionEvent (ConnectionUpdated uc _ name)) = (Cancelled, _) -> Nothing where apsConnRequest n = - apsData (ApsLocKey "push.notification.connection.request") [fromName n] - & apsSound ?~ ApsSound "new_message_apns.caf" + V2.apsData (V2.ApsLocKey "push.notification.connection.request") [fromName n] + & V2.apsSound ?~ V2.ApsSound "new_message_apns.caf" apsConnAccept n = - apsData (ApsLocKey "push.notification.connection.accepted") [fromName n] - & apsSound ?~ ApsSound "new_message_apns.caf" + V2.apsData (V2.ApsLocKey "push.notification.connection.accepted") [fromName n] + & V2.apsSound ?~ V2.ApsSound "new_message_apns.caf" toApsData _ = Nothing ------------------------------------------------------------------------------- @@ -660,20 +508,16 @@ toApsData _ = Nothing -- | Calls 'Galley.API.Create.createConnectConversation'. createLocalConnectConv :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m + ( Member (Embed HttpClientIO) r, + Member TinyLog r ) => Local UserId -> Local UserId -> Maybe Text -> Maybe ConnId -> - m ConvId + Sem r ConvId createLocalConnectConv from to cname conn = do - debug $ + Log.debug $ logConnection (tUnqualified from) (tUntagged to) . remote "galley" . msg (val "Creating connect conversation") @@ -684,12 +528,15 @@ createLocalConnectConv from to cname conn = do . contentJson . lbytes (encode $ Connect (tUntagged to) Nothing cname Nothing) . expect2xx - r <- galleyRequest POST req + r <- embed $ galleyRequest POST req maybe (error "invalid conv id") pure $ fromByteString $ getHeader' "Location" r createConnectConv :: + ( Member (Embed HttpClientIO) r, + Member TinyLog r + ) => Qualified UserId -> Qualified UserId -> Maybe Text -> @@ -699,27 +546,21 @@ createConnectConv from to cname conn = do lfrom <- ensureLocal from lto <- ensureLocal to tUntagged . qualifyAs lfrom - <$> wrapHttp (createLocalConnectConv lfrom lto cname conn) + <$> liftSem (createLocalConnectConv lfrom lto cname conn) -- | Calls 'Galley.API.acceptConvH'. acceptLocalConnectConv :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + (Member (Embed HttpClientIO) r, Member TinyLog r) => Local UserId -> Maybe ConnId -> ConvId -> - m Conversation + Sem r Conversation acceptLocalConnectConv from conn cnv = do - debug $ + Log.debug $ remote "galley" . field "conv" (toByteString cnv) . msg (val "Accepting connect conversation") - galleyRequest PUT req >>= decodeBody "galley" + embed $ galleyRequest PUT req >>= decodeBody "galley" where req = paths ["/i/conversations", toByteString' cnv, "accept", "v2"] @@ -727,32 +568,35 @@ acceptLocalConnectConv from conn cnv = do . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx -acceptConnectConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppT r Conversation +acceptConnectConv :: + ( Member (Embed HttpClientIO) r, + Member TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + Qualified ConvId -> + AppT r Conversation acceptConnectConv from conn = foldQualified from - (wrapHttp . acceptLocalConnectConv from conn . tUnqualified) + (liftSem . acceptLocalConnectConv from conn . tUnqualified) (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.blockConvH'. blockLocalConv :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m + ( Member (Embed HttpClientIO) r, + Member TinyLog r ) => Local UserId -> Maybe ConnId -> ConvId -> - m () + Sem r () blockLocalConv lusr conn cnv = do - debug $ + Log.debug $ remote "galley" . field "conv" (toByteString cnv) . msg (val "Blocking conversation") - void $ galleyRequest PUT req + embed $ void $ galleyRequest PUT req where req = paths ["/i/conversations", toByteString' cnv, "block"] @@ -761,42 +605,34 @@ blockLocalConv lusr conn cnv = do . expect2xx blockConv :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m + ( Member (Embed HttpClientIO) r, + Member TinyLog r ) => Local UserId -> Maybe ConnId -> Qualified ConvId -> - m () + AppT r () blockConv lusr conn = foldQualified lusr - (blockLocalConv lusr conn . tUnqualified) + (liftSem . blockLocalConv lusr conn . tUnqualified) (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.unblockConvH'. unblockLocalConv :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m + ( Member (Embed HttpClientIO) r, + Member TinyLog r ) => Local UserId -> Maybe ConnId -> ConvId -> - m Conversation + Sem r Conversation unblockLocalConv lusr conn cnv = do - debug $ + Log.debug $ remote "galley" . field "conv" (toByteString cnv) . msg (val "Unblocking conversation") - galleyRequest PUT req >>= decodeBody "galley" + embed $ galleyRequest PUT req >>= decodeBody "galley" where req = paths ["/i/conversations", toByteString' cnv, "unblock"] @@ -805,21 +641,17 @@ unblockLocalConv lusr conn cnv = do . expect2xx unblockConv :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m + ( Member (Embed HttpClientIO) r, + Member TinyLog r ) => Local UserId -> Maybe ConnId -> Qualified ConvId -> - m Conversation + AppT r Conversation unblockConv luid conn = foldQualified luid - (unblockLocalConv luid conn . tUnqualified) + (liftSem . unblockLocalConv luid conn . tUnqualified) (const (throwM federationNotImplemented)) upsertOne2OneConversation :: @@ -848,35 +680,32 @@ upsertOne2OneConversation urequest = do -- | Calls Galley's endpoint with the internal route ID "delete-user", as well -- as gundeck and cargohold. rmUser :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m + ( Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r ) => UserId -> [Asset] -> - m () + Sem r () rmUser usr asts = do - debug $ + Log.debug $ remote "gundeck" . field "user" (toByteString usr) . msg (val "remove user") - void $ gundeckRequest DELETE (path "/i/user" . zUser usr . expect2xx) - debug $ + cleanupUser usr + Log.debug $ remote "galley" . field "user" (toByteString usr) . msg (val "remove user") - void $ galleyRequest DELETE (path "/i/user" . zUser usr . expect2xx) - debug $ + embed $ void $ galleyRequest DELETE (path "/i/user" . zUser usr . expect2xx) + Log.debug $ remote "cargohold" . field "user" (toByteString usr) . msg (val "remove profile assets") -- Note that we _may_ not get a 2xx response code from cargohold (e.g., client has -- deleted the asset "directly" with cargohold; on our side, we just do our best to -- delete it in case it is still there - forM_ asts $ \ast -> + embed $ forM_ asts $ \ast -> cargoholdRequest DELETE (paths ["assets/v3", toByteString' $ assetKey ast] . zUser usr) ------------------------------------------------------------------------------- @@ -884,67 +713,32 @@ rmUser usr asts = do -- | Calls 'Galley.API.rmClientH', as well as gundeck. rmClient :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m + ( Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r ) => UserId -> ClientId -> - m () + Sem r () rmClient u c = do let cid = toByteString' c - debug $ + Log.debug $ remote "galley" . field "user" (toByteString u) . field "client" (BL.fromStrict cid) . msg (val "remove client") let p = paths ["i", "clients", cid] - void $ galleyRequest DELETE (p . zUser u . expect expected) + embed $ void $ galleyRequest DELETE (p . zUser u . expect expected) -- for_ clabel rmClientCookie - debug $ + Log.debug $ remote "gundeck" . field "user" (toByteString u) . 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 - ) + unregisterPushClient u c where expected = [status200, status204, status404] -lookupPushToken :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => - UserId -> - m [Push.PushToken] -lookupPushToken uid = do - g <- view gundeck - rsp <- - rpc' - "gundeck" - (g :: Request) - ( method GET - . paths ["i", "push-tokens", toByteString' uid] - . zUser uid - . expect2xx - ) - responseJsonMaybe rsp & maybe (pure []) (pure . pushTokens) - ------------------------------------------------------------------------------- -- Team Management @@ -952,19 +746,15 @@ lookupPushToken uid = do -- -- Calls 'Galley.API.getBindingTeamMembersH'. getTeamContacts :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m + ( Member TinyLog r, + Member (Embed HttpClientIO) r ) => UserId -> - m (Maybe Team.TeamMemberList) + Sem r (Maybe Team.TeamMemberList) getTeamContacts u = do - debug $ remote "galley" . msg (val "Get team contacts") - rs <- galleyRequest GET req - case Bilge.statusCode rs of + Log.debug $ remote "galley" . msg (val "Get team contacts") + rs <- embed $ galleyRequest GET req + embed $ case Bilge.statusCode rs of 200 -> Just <$> decodeBody "galley" rs _ -> pure Nothing where diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index 431d1cdb5a1..9c04f5c3083 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -20,8 +20,6 @@ module Brig.InternalEvent.Process ) where -import Bilge.IO (MonadHttp) -import Bilge.RPC (HasRequestId) import Brig.API.User qualified as API import Brig.App import Brig.IO.Intra (rmClient) @@ -30,31 +28,30 @@ import Brig.InternalEvent.Types import Brig.Options (defDeleteThrottleMillis, setDeleteThrottleMillis) import Brig.Provider.API qualified as API import Brig.Types.User.Event -import Brig.User.Search.Index (MonadIndexIO) -import Cassandra (MonadClient) import Control.Lens (view) import Control.Monad.Catch import Data.ByteString.Conversion import Imports +import Polysemy +import Polysemy.Conc +import Polysemy.Time +import Polysemy.TinyLog as Log import System.Logger.Class (field, msg, val, (~~)) -import System.Logger.Class qualified as Log -import UnliftIO (timeout) +import Wire.NotificationSubsystem +import Wire.Sem.Delay -- | Handle an internal event. -- -- Has a one-minute timeout that should be enough for anything that it does. onEvent :: - ( Log.MonadLogger m, - MonadIndexIO m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - MonadClient m + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r, + Member Delay r, + Member Race r ) => InternalNotification -> - m () + Sem r () onEvent n = handleTimeout $ case n of DeleteClient clientId uid mcon -> do rmClient uid clientId @@ -63,23 +60,23 @@ onEvent n = handleTimeout $ case n of Log.info $ msg (val "Processing user delete event") ~~ field "user" (toByteString uid) - API.lookupAccount uid >>= mapM_ API.deleteAccount + embed (API.lookupAccount uid) >>= mapM_ API.deleteAccount -- As user deletions are expensive resource-wise in the context of -- bulk user deletions (e.g. during team deletions), -- wait 'delay' ms before processing the next event - delay <- fromMaybe defDeleteThrottleMillis . setDeleteThrottleMillis <$> view settings - liftIO $ threadDelay (1000 * delay) + deleteThrottleMillis <- embed $ fromMaybe defDeleteThrottleMillis . setDeleteThrottleMillis <$> view settings + delay (1000 * deleteThrottleMillis) DeleteService pid sid -> do Log.info $ msg (val "Processing service delete event") ~~ field "provider" (toByteString pid) ~~ field "service" (toByteString sid) - API.finishDeleteService pid sid + embed $ API.finishDeleteService pid sid where handleTimeout act = - timeout 60000000 act >>= \case - Just x -> pure x - Nothing -> throwM (InternalEventTimeout n) + timeout (pure ()) (Seconds 60) act >>= \case + Right x -> pure x + Left _ -> embed $ throwM (InternalEventTimeout n) newtype InternalEventException = -- | 'onEvent' has timed out diff --git a/services/brig/src/Brig/Provider/RPC.hs b/services/brig/src/Brig/Provider/RPC.hs index fd91cac91bb..bdb00994d4d 100644 --- a/services/brig/src/Brig/Provider/RPC.hs +++ b/services/brig/src/Brig/Provider/RPC.hs @@ -57,6 +57,7 @@ import Wire.API.Event.Conversation qualified as Conv import Wire.API.Provider (httpsUrl) import Wire.API.Provider.External import Wire.API.Provider.Service qualified as Galley +import Wire.Rpc -------------------------------------------------------------------------------- -- External RPC diff --git a/services/brig/src/Brig/RPC.hs b/services/brig/src/Brig/RPC.hs index 2aac7baa915..9ab6d97c660 100644 --- a/services/brig/src/Brig/RPC.hs +++ b/services/brig/src/Brig/RPC.hs @@ -26,22 +26,13 @@ import Control.Lens import Control.Monad.Catch import Control.Retry import Data.Aeson -import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as BL -import Data.Id import Data.Text qualified as Text import Data.Text.Lazy qualified as LT import Imports -import Network.HTTP.Client (HttpExceptionContent (..), checkResponse) import Network.HTTP.Types.Method -import Network.HTTP.Types.Status import System.Logger.Class hiding (name, (.=)) - -x3 :: RetryPolicy -x3 = limitRetries 3 <> exponentialBackoff 100000 - -zUser :: UserId -> Request -> Request -zUser = header "Z-User" . toByteString' +import Wire.Rpc (x3) remote :: ByteString -> Msg -> Msg remote = field "remote" @@ -49,16 +40,6 @@ remote = field "remote" decodeBody :: (Typeable a, FromJSON a, MonadThrow m) => Text -> Response (Maybe BL.ByteString) -> m a decodeBody ctx = responseJsonThrow (ParseException ctx) -expect :: [Status] -> Request -> Request -expect ss rq = rq {checkResponse = check} - where - check rq' rs = do - let s = responseStatus rs - rs' = rs {responseBody = ()} - when (statusIsServerError s || s `notElem` ss) $ - throwM $ - HttpExceptionRequest rq' (StatusCodeException rs' mempty) - cargoholdRequest :: (MonadReader Env m, MonadIO m, MonadMask m, MonadHttp m, HasRequestId m) => StdMethod -> @@ -73,13 +54,6 @@ galleyRequest :: m (Response (Maybe BL.ByteString)) galleyRequest = serviceRequest "galley" galley -gundeckRequest :: - (MonadReader Env m, MonadIO m, MonadMask m, MonadHttp m, HasRequestId m) => - StdMethod -> - (Request -> Request) -> - m (Response (Maybe BL.ByteString)) -gundeckRequest = serviceRequest "gundeck" gundeck - serviceRequest :: (MonadReader Env m, MonadIO m, MonadMask m, MonadHttp m, HasRequestId m) => LT.Text -> diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 1920db1a85d..553a773366f 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -71,7 +71,6 @@ import System.Logger (Logger, msg, val, (.=), (~~)) import System.Logger qualified as Log import System.Logger.Class (MonadLogger, err) import Util.Options -import Wire.API.Federation.API import Wire.API.Routes.API import Wire.API.Routes.Public.Brig import Wire.API.Routes.Version @@ -92,7 +91,7 @@ run o = do runBrigToIO e $ wrapHttpClient $ Queue.listen (e ^. internalEvents) $ - unsafeCallsFed @'Brig @"on-user-deleted-connections" Internal.onEvent + liftIO . runBrigToIO e . liftSem . Internal.onEvent let throttleMillis = fromMaybe defSqsThrottleMillis $ setSqsThrottleMillis (optSettings o) emailListener <- for (e ^. awsEnv . sesQueue) $ \q -> Async.async $ diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 60125f9bf46..ac70c9623a1 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -57,7 +57,8 @@ import Data.Range import Galley.Types.Teams qualified as Team import Imports hiding (head) import Network.Wai.Utilities hiding (code, message) -import Polysemy (Member) +import Polysemy +import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader) import System.Logger.Class qualified as Log import System.Logger.Message as Log @@ -78,6 +79,8 @@ import Wire.API.Team.Role import Wire.API.Team.Role qualified as Public import Wire.API.User hiding (fromEmail) import Wire.API.User qualified as Public +import Wire.NotificationSubsystem +import Wire.Sem.Concurrency servantAPI :: ( Member BlacklistStore r, @@ -158,7 +161,8 @@ createInvitationPublic uid tid body = do createInvitationViaScim :: ( Member BlacklistStore r, Member GalleyProvider r, - Member (UserPendingActivationStore p) r + Member (UserPendingActivationStore p) r, + Member TinyLog r ) => TeamId -> NewUserScimInvitation -> @@ -303,7 +307,15 @@ getInvitationByEmail email = do inv <- lift $ wrapClient $ DB.lookupInvitationByEmail HideInvitationUrl email maybe (throwStd (notFound "Invitation not found")) pure inv -suspendTeam :: (Member GalleyProvider r) => TeamId -> (Handler r) NoContent +suspendTeam :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member (Concurrency 'Unsafe) r, + Member GalleyProvider r, + Member TinyLog r + ) => + TeamId -> + (Handler r) NoContent suspendTeam tid = do Log.info $ Log.msg (Log.val "Team suspended") ~~ Log.field "team" (toByteString tid) changeTeamAccountStatuses tid Suspended @@ -312,7 +324,12 @@ suspendTeam tid = do pure NoContent unsuspendTeam :: - (Member GalleyProvider r) => + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member (Concurrency 'Unsafe) r, + Member GalleyProvider r, + Member TinyLog r + ) => TeamId -> (Handler r) NoContent unsuspendTeam tid = do @@ -324,7 +341,12 @@ unsuspendTeam tid = do -- Internal changeTeamAccountStatuses :: - (Member GalleyProvider r) => + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member (Concurrency 'Unsafe) r, + Member GalleyProvider r, + Member TinyLog r + ) => TeamId -> AccountStatus -> (Handler r) () @@ -333,7 +355,7 @@ changeTeamAccountStatuses tid s = do unless (team ^. teamBinding == Binding) $ throwStd noBindingTeam uids <- toList1 =<< lift (fmap (view Teams.userId) . view teamMembers <$> liftSem (GalleyProvider.getTeamMembers tid)) - wrapHttpClientE (API.changeAccountStatus uids s) !>> accountStatusError + API.changeAccountStatus uids s !>> accountStatusError where toList1 (x : xs) = pure $ List1.list1 x xs toList1 [] = throwStd (notFound "Team not found or no members") diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index c9f232888bc..fece7d7c22c 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -36,8 +36,6 @@ module Brig.User.Auth ) where -import Bilge.IO -import Bilge.RPC import Brig.API.Types import Brig.API.User (changeSingleAccountStatus) import Brig.App @@ -58,12 +56,10 @@ import Brig.Types.Intra import Brig.User.Auth.Cookie import Brig.User.Handle import Brig.User.Phone -import Brig.User.Search.Index import Brig.ZAuth qualified as ZAuth import Cassandra import Control.Error hiding (bool) import Control.Lens (to, view) -import Control.Monad.Catch import Control.Monad.Except import Data.ByteString.Conversion (toByteString) import Data.Handle (Handle) @@ -76,40 +72,38 @@ import Data.ZAuth.Token qualified as ZAuth import Imports import Network.Wai.Utilities.Error ((!>>)) import Polysemy +import Polysemy.TinyLog (TinyLog) +import Polysemy.TinyLog qualified as Log import System.Logger (field, msg, val, (~~)) -import System.Logger.Class qualified as Log import Wire.API.Team.Feature import Wire.API.Team.Feature qualified as Public import Wire.API.User import Wire.API.User.Auth import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.Sso +import Wire.NotificationSubsystem sendLoginCode :: - ( MonadClient m, - MonadReader Env m, - MonadCatch m, - Log.MonadLogger m - ) => + (Member TinyLog r) => Phone -> Bool -> Bool -> - ExceptT SendLoginCodeError m PendingLoginCode + ExceptT SendLoginCodeError (AppT r) PendingLoginCode sendLoginCode phone call force = do pk <- maybe (throwE $ SendLoginInvalidPhone phone) (pure . userPhoneKey) - =<< lift (validatePhone phone) - user <- lift $ Data.lookupKey pk + =<< lift (wrapHttpClient $ validatePhone phone) + user <- lift $ wrapHttpClient $ Data.lookupKey pk case user of Nothing -> throwE $ SendLoginInvalidPhone phone Just u -> do - lift . Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.sendLoginCode") - pw <- lift $ Data.lookupPassword u + lift . liftSem . Log.debug $ field "user" (toByteString u) . field "action" (val "User.sendLoginCode") + pw <- lift $ wrapClient $ Data.lookupPassword u unless (isNothing pw || force) $ throwE SendLoginPasswordExists - lift $ do + lift $ wrapHttpClient $ do l <- Data.lookupLocale u c <- Data.createLoginCode u void . forPhoneKey pk $ \ph -> @@ -119,28 +113,29 @@ sendLoginCode phone call force = do pure c lookupLoginCode :: - ( MonadClient m, - Log.MonadLogger m, - MonadReader Env m - ) => + Member TinyLog r => Phone -> - m (Maybe PendingLoginCode) + AppT r (Maybe PendingLoginCode) lookupLoginCode phone = - Data.lookupKey (userPhoneKey phone) >>= \case + wrapClient (Data.lookupKey (userPhoneKey phone)) >>= \case Nothing -> pure Nothing Just u -> do - Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.lookupLoginCode") - Data.lookupLoginCode u + liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.lookupLoginCode") + wrapHttpClient $ Data.lookupLoginCode u login :: forall r. - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r + ) => Login -> CookieType -> ExceptT LoginError (AppT r) (Access ZAuth.User) login (PasswordLogin (PasswordLoginData li pw label code)) typ = do uid <- wrapHttpClientE $ resolveLoginId li - lift . Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.login") + lift . liftSem . Log.debug $ field "user" (toByteString uid) . field "action" (val "User.login") wrapHttpClientE $ checkRetryLimit uid wrapHttpClientE $ Data.authenticate uid pw `catchE` \case @@ -150,7 +145,7 @@ login (PasswordLogin (PasswordLoginData li pw label code)) typ = do AuthEphemeral -> throwE LoginEphemeral AuthPendingInvitation -> throwE LoginPendingActivation verifyLoginCode code uid - wrapHttpClientE $ newAccess @ZAuth.User @ZAuth.Access uid Nothing typ label + newAccess @ZAuth.User @ZAuth.Access uid Nothing typ label where verifyLoginCode :: Maybe Code.Value -> UserId -> ExceptT LoginError (AppT r) () verifyLoginCode mbCode uid = @@ -161,13 +156,13 @@ login (PasswordLogin (PasswordLoginData li pw label code)) typ = do VerificationCodeNoEmail -> wrapHttpClientE $ loginFailed uid login (SmsLogin (SmsLoginData phone code label)) typ = do uid <- wrapHttpClientE $ resolveLoginId (LoginByPhone phone) - lift . Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.login") + lift . liftSem . Log.debug $ field "user" (toByteString uid) . field "action" (val "User.login") wrapHttpClientE $ checkRetryLimit uid ok <- wrapHttpClientE $ Data.verifyLoginCode uid code unless ok $ wrapHttpClientE $ loginFailed uid - wrapHttpClientE $ newAccess @ZAuth.User @ZAuth.Access uid Nothing typ label + newAccess @ZAuth.User @ZAuth.Access uid Nothing typ label verifyCode :: forall r. @@ -229,75 +224,61 @@ withRetryLimit action uid = do BudgetedValue () _ -> pure () logout :: - ( ZAuth.TokenPair u a, - ZAuth.MonadZAuth m, - MonadClient m - ) => + (ZAuth.TokenPair u a) => List1 (ZAuth.Token u) -> ZAuth.Token a -> - ExceptT ZAuth.Failure m () + ExceptT ZAuth.Failure (AppT r) () logout uts at = do (u, ck) <- validateTokens uts (Just at) - lift $ revokeCookies u [cookieId ck] [] + lift $ wrapClient $ revokeCookies u [cookieId ck] [] renewAccess :: - forall m u a. + forall r u a. ( ZAuth.TokenPair u a, - MonadClient m, - ZAuth.MonadZAuth m, - Log.MonadLogger m, - MonadReader Env m, - MonadIndexIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r ) => List1 (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> Maybe ClientId -> - ExceptT ZAuth.Failure m (Access u) + ExceptT ZAuth.Failure (AppT r) (Access u) renewAccess uts at mcid = do (uid, ck) <- validateTokens uts at - traverse_ (checkClientId uid) mcid - lift . Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.renewAccess") + wrapClientE $ traverse_ (checkClientId uid) mcid + lift . liftSem . Log.debug $ field "user" (toByteString uid) . field "action" (val "User.renewAccess") catchSuspendInactiveUser uid ZAuth.Expired - ck' <- nextCookie ck mcid + ck' <- wrapHttpClientE $ nextCookie ck mcid at' <- lift $ newAccessToken (fromMaybe ck ck') at pure $ Access at' ck' revokeAccess :: - (MonadClient m, Log.MonadLogger m, MonadReader Env m) => + (Member TinyLog r) => UserId -> PlainTextPassword6 -> [CookieId] -> [CookieLabel] -> - ExceptT AuthError m () + ExceptT AuthError (AppT r) () revokeAccess u pw cc ll = do - lift $ Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.revokeAccess") - unlessM (Data.isSamlUser u) $ Data.authenticate u pw - lift $ revokeCookies u cc ll + lift . liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.revokeAccess") + wrapHttpClientE $ unlessM (Data.isSamlUser u) $ Data.authenticate u pw + lift $ wrapHttpClient $ revokeCookies u cc ll -------------------------------------------------------------------------------- -- Internal catchSuspendInactiveUser :: - ( MonadClient m, - MonadIndexIO m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - Log.MonadLogger m + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r ) => UserId -> e -> - ExceptT e m () + ExceptT e (AppT r) () catchSuspendInactiveUser uid errval = do - mustsuspend <- lift $ mustSuspendInactiveUser uid + mustsuspend <- lift $ wrapHttpClient $ mustSuspendInactiveUser uid when mustsuspend $ do - lift . Log.warn $ + lift . liftSem . Log.warn $ msg (val "Suspending user due to inactivity") ~~ field "user" (toByteString uid) ~~ field "action" ("user.suspend" :: String) @@ -311,26 +292,20 @@ catchSuspendInactiveUser uid errval = do Right () -> pure () newAccess :: - forall u a m. + forall u a r. ( ZAuth.TokenPair u a, - MonadReader Env m, - MonadClient m, - ZAuth.MonadZAuth m, - Log.MonadLogger m, - MonadIndexIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r ) => UserId -> Maybe ClientId -> CookieType -> Maybe CookieLabel -> - ExceptT LoginError m (Access u) + ExceptT LoginError (AppT r) (Access u) newAccess uid cid ct cl = do catchSuspendInactiveUser uid LoginSuspended - r <- lift $ newCookieLimited uid cid ct cl + r <- lift $ wrapHttpClient $ newCookieLimited uid cid ct cl case r of Left delay -> throwE $ LoginThrottled delay Right ck -> do @@ -394,10 +369,10 @@ isPendingActivation ident = case ident of -- given, we perform the usual checks. -- If multiple cookies are given and several are valid, we return the first valid one. validateTokens :: - (ZAuth.TokenPair u a, ZAuth.MonadZAuth m, MonadClient m) => + (ZAuth.TokenPair u a) => List1 (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> - ExceptT ZAuth.Failure m (UserId, Cookie (ZAuth.Token u)) + ExceptT ZAuth.Failure (AppT r) (UserId, Cookie (ZAuth.Token u)) validateTokens uts at = do tokens <- forM uts $ \ut -> lift $ runExceptT (validateToken ut at) getFirstSuccessOrFirstFail tokens @@ -413,13 +388,10 @@ validateTokens uts at = do _ -> throwE ZAuth.Invalid -- Impossible validateToken :: - ( ZAuth.TokenPair u a, - ZAuth.MonadZAuth m, - MonadClient m - ) => + (ZAuth.TokenPair u a) => ZAuth.Token u -> Maybe (ZAuth.Token a) -> - ExceptT ZAuth.Failure m (UserId, Cookie (ZAuth.Token u)) + ExceptT ZAuth.Failure (AppT r) (UserId, Cookie (ZAuth.Token u)) validateToken ut at = do unless (maybe True ((ZAuth.userTokenOf ut ==) . ZAuth.accessTokenOf) at) $ throwE ZAuth.Invalid @@ -428,26 +400,20 @@ validateToken ut at = do ExceptT (ZAuth.validateToken token) `catchE` \e -> unless (e == ZAuth.Expired) (throwE e) - ck <- lift (lookupCookie ut) >>= maybe (throwE ZAuth.Invalid) pure + ck <- lift (wrapClient $ lookupCookie ut) >>= maybe (throwE ZAuth.Invalid) pure pure (ZAuth.userTokenOf ut, ck) -- | Allow to login as any user without having the credentials. ssoLogin :: - ( MonadClient m, - MonadReader Env m, - ZAuth.MonadZAuth m, - Log.MonadLogger m, - MonadIndexIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m + ( Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r ) => SsoLogin -> CookieType -> - ExceptT LoginError m (Access ZAuth.User) + ExceptT LoginError (AppT r) (Access ZAuth.User) ssoLogin (SsoLogin uid label) typ = do - Data.reauthenticate uid Nothing `catchE` \case + wrapHttpClientE (Data.reauthenticate uid Nothing) `catchE` \case ReAuthMissingPassword -> pure () ReAuthCodeVerificationRequired -> pure () ReAuthCodeVerificationNoPendingCode -> pure () @@ -462,7 +428,11 @@ ssoLogin (SsoLogin uid label) typ = do -- | Log in as a LegalHold service, getting LegalHoldUser/Access Tokens. legalHoldLogin :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member TinyLog r + ) => LegalHoldLogin -> CookieType -> ExceptT LegalHoldLoginError (AppT r) (Access ZAuth.LegalHoldUser) @@ -476,7 +446,7 @@ legalHoldLogin (LegalHoldLogin uid pw label) typ = do Nothing -> throwE LegalHoldLoginNoBindingTeam Just tid -> assertLegalHoldEnabled tid -- create access token and cookie - wrapHttpClientE (newAccess @ZAuth.LegalHoldUser @ZAuth.LegalHoldAccess uid Nothing typ label) + newAccess @ZAuth.LegalHoldUser @ZAuth.LegalHoldAccess uid Nothing typ label !>> LegalHoldLoginError assertLegalHoldEnabled :: diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index fea8e51a37a..ae7538b6b5f 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -22,12 +22,11 @@ module Brig.User.EJPD (ejpdRequest) where import Brig.API.Handler import Brig.API.User (lookupHandle) -import Brig.App (AppT, liftSem, wrapClient, wrapHttp) +import Brig.App import Brig.Data.Connection qualified as Conn import Brig.Data.User (lookupUser) import Brig.Effects.GalleyProvider (GalleyProvider) import Brig.Effects.GalleyProvider qualified as GalleyProvider -import Brig.IO.Intra qualified as Intra import Brig.Types.User (HavePendingInvitations (NoPendingInvitations)) import Control.Error hiding (bool) import Control.Lens (view, (^.)) @@ -35,15 +34,23 @@ import Data.Handle (Handle) import Data.Id (UserId) import Data.Set qualified as Set import Imports hiding (head) -import Polysemy (Member) +import Polysemy import Servant.OpenApi.Internal.Orphans () import Wire.API.Connection (Relation, RelationWithHistory (..), relationDropHistory) import Wire.API.Push.Token qualified as PushTok import Wire.API.Routes.Internal.Brig.EJPD (EJPDRequestBody (EJPDRequestBody), EJPDResponseBody (EJPDResponseBody), EJPDResponseItem (EJPDResponseItem)) import Wire.API.Team.Member qualified as Team import Wire.API.User (User, userDisplayName, userEmail, userHandle, userId, userPhone, userTeam) +import Wire.NotificationSubsystem -ejpdRequest :: forall r. Member GalleyProvider r => Maybe Bool -> EJPDRequestBody -> (Handler r) EJPDResponseBody +ejpdRequest :: + forall r. + ( Member GalleyProvider r, + Member NotificationSubsystem r + ) => + Maybe Bool -> + EJPDRequestBody -> + Handler r EJPDResponseBody ejpdRequest includeContacts (EJPDRequestBody handles) = do ExceptT $ Right . EJPDResponseBody . catMaybes <$> forM handles (go1 (fromMaybe False includeContacts)) where @@ -60,7 +67,7 @@ ejpdRequest includeContacts (EJPDRequestBody handles) = do let uid = userId target ptoks <- - PushTok.tokenText . view PushTok.token <$$> wrapHttp (Intra.lookupPushToken uid) + PushTok.tokenText . view PushTok.token <$$> liftSem (getPushTokens uid) mbContacts <- if includeContacts' diff --git a/services/brig/test/unit/Test/Brig/Calling.hs b/services/brig/test/unit/Test/Brig/Calling.hs index 13897b00aab..044c289f9d1 100644 --- a/services/brig/test/unit/Test/Brig/Calling.hs +++ b/services/brig/test/unit/Test/Brig/Calling.hs @@ -43,7 +43,6 @@ import OpenSSL.EVP.Digest (getDigestByName) import Polysemy import Polysemy.Error import Polysemy.TinyLog -import System.Logger qualified as Log import Test.Brig.Effects.Delay import Test.Tasty import Test.Tasty.HUnit @@ -71,15 +70,6 @@ runFakeDNSLookup FakeDNSEnv {..} = interpret $ modifyIORef' fakeLookupSrvCalls (++ [domain]) pure $ fakeLookupSrv domain -newtype LogRecorder = LogRecorder {recordedLogs :: IORef [(Level, LByteString)]} - -newLogRecorder :: IO LogRecorder -newLogRecorder = LogRecorder <$> newIORef [] - -recordLogs :: Member (Embed IO) r => LogRecorder -> Sem (TinyLog ': r) a -> Sem r a -recordLogs LogRecorder {..} = interpret $ \(Log lvl msg) -> - modifyIORef' recordedLogs (++ [(lvl, Log.render (Log.renderDefault ", ") msg)]) - ignoreLogs :: Sem (TinyLog ': r) a -> Sem r a ignoreLogs = discardTinyLogs diff --git a/services/brig/test/unit/Test/Brig/Effects/Delay.hs b/services/brig/test/unit/Test/Brig/Effects/Delay.hs index 9e5e9fe43e1..55109f712e3 100644 --- a/services/brig/test/unit/Test/Brig/Effects/Delay.hs +++ b/services/brig/test/unit/Test/Brig/Effects/Delay.hs @@ -1,8 +1,8 @@ module Test.Brig.Effects.Delay where -import Brig.Effects.Delay import Imports import Polysemy +import Wire.Sem.Delay -- | Ignores the delay time and only progresses when the 'MVar' is empty using -- 'putMVar'. This way a test using this interpreter can know when the delay diff --git a/services/galley/default.nix b/services/galley/default.nix index 12b1d54aa86..279ee871813 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -122,6 +122,7 @@ , warp-tls , wire-api , wire-api-federation +, wire-subsystems , yaml }: mkDerivation { @@ -214,6 +215,7 @@ mkDerivation { wai-utilities wire-api wire-api-federation + wire-subsystems ]; executableHaskellDepends = [ aeson diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index e646ea232c3..4088a64b453 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -166,7 +166,6 @@ library Galley.Effects.ExternalAccess Galley.Effects.FederatorAccess Galley.Effects.FireAndForget - Galley.Effects.GundeckAccess Galley.Effects.LegalHoldStore Galley.Effects.ListItems Galley.Effects.MemberStore @@ -192,8 +191,6 @@ library Galley.Intra.Effects Galley.Intra.Federator Galley.Intra.Journal - Galley.Intra.Push - Galley.Intra.Push.Internal Galley.Intra.Spar Galley.Intra.Team Galley.Intra.User @@ -368,6 +365,7 @@ library , wai-utilities >=0.16 , wire-api , wire-api-federation + , wire-subsystems executable galley import: common-all @@ -613,7 +611,6 @@ test-suite galley-tests Test.Galley.API.Action Test.Galley.API.Message Test.Galley.API.One2One - Test.Galley.Intra.Push Test.Galley.Intra.User Test.Galley.Mapping diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index c3a3448f77d..0b373dc9574 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -51,6 +51,7 @@ import Control.Lens import Data.ByteString.Conversion (toByteString') import Data.Domain (Domain (..)) import Data.Id +import Data.Json.Util import Data.Kind import Data.List qualified as List import Data.List.Extra (nubOrd) @@ -82,18 +83,17 @@ import Galley.Effects.CodeStore qualified as E import Galley.Effects.ConversationStore qualified as E import Galley.Effects.FederatorAccess qualified as E import Galley.Effects.FireAndForget qualified as E -import Galley.Effects.GundeckAccess import Galley.Effects.MemberStore qualified as E import Galley.Effects.ProposalStore qualified as E import Galley.Effects.SubConversationStore qualified as E import Galley.Effects.TeamStore qualified as E import Galley.Env (Env) -import Galley.Intra.Push import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.Teams (IsPerm (hasPermission)) import Galley.Types.UserList import Galley.Validation +import Gundeck.Types.Push.V2 qualified as PushV2 import Imports hiding ((\\)) import Network.AMQP qualified as Q import Polysemy @@ -125,6 +125,7 @@ import Wire.API.Team.LegalHold import Wire.API.Team.Member import Wire.API.Team.Permission (Perm (AddRemoveConvMember, ModifyConvName)) import Wire.API.User qualified as User +import Wire.NotificationSubsystem data NoChanges = NoChanges @@ -146,7 +147,7 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con Member (Error UnreachableBackends) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -165,7 +166,7 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con Member (Error NoChanges) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member (Input Env) r, Member ProposalStore r, @@ -181,7 +182,7 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con Member (Input UTCTime) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Error InternalError) r, Member TinyLog r, Member (Error NoChanges) r @@ -220,7 +221,7 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con Member ExternalAccess r, Member FederatorAccess r, Member FireAndForget r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member MemberStore r, Member ProposalStore r, @@ -249,7 +250,7 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con Member BrigAccess r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -717,7 +718,7 @@ updateLocalConversation :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member (Logger (Log.Msg -> Log.Msg)) r, HasConversationActionEffects tag r, @@ -757,7 +758,7 @@ updateLocalConversationUnchecked :: Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member (Logger (Log.Msg -> Log.Msg)) r, HasConversationActionEffects tag r @@ -860,7 +861,7 @@ notifyConversationAction :: forall tag r. ( Member BackendNotificationQueueAccess r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member (Logger (Log.Msg -> Log.Msg)) r ) => @@ -911,7 +912,7 @@ notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do -- or leaving. Finally, push out notifications to local users. updateLocalStateOfRemoteConv :: ( Member BrigAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member ExternalAccess r, Member (Input (Local ())) r, Member MemberStore r, @@ -1038,7 +1039,7 @@ kickMember :: Member (Error InternalError) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member ProposalStore r, Member (Input UTCTime) r, Member (Input Env) r, @@ -1070,7 +1071,7 @@ kickMember qusr lconv targets victim = void . runError @NoChanges $ do notifyTypingIndicator :: ( Member (Input UTCTime) r, Member (Input (Local ())) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member FederatorAccess r ) => Conversation -> @@ -1101,7 +1102,7 @@ notifyTypingIndicator conv qusr mcon ts = do pure (tdu (fmap (tUnqualified . rmId) remoteMemsOrig)) pushTypingIndicatorEvents :: - (Member GundeckAccess r) => + (Member NotificationSubsystem r) => Qualified UserId -> UTCTime -> [UserId] -> @@ -1111,9 +1112,10 @@ pushTypingIndicatorEvents :: Sem r () pushTypingIndicatorEvents qusr tEvent users mcon qcnv ts = do let e = Event qcnv Nothing qusr tEvent (EdTyping ts) - for_ (newPushLocal ListComplete (qUnqualified qusr) (ConvEvent e) (userRecipient <$> users)) $ \p -> - push1 $ - p - & pushConn .~ mcon - & pushRoute .~ RouteDirect - & pushTransient .~ True + for_ (newPushLocal (qUnqualified qusr) (toJSONObject e) (userRecipient <$> users)) $ \p -> + pushNotifications + [ p + & pushConn .~ mcon + & pushRoute .~ PushV2.RouteDirect + & pushTransient .~ True + ] diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 044447c488d..9ae38817dc8 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -51,6 +51,7 @@ import Wire.API.Conversation hiding (Member) import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Routes.MultiTablePaging +import Wire.NotificationSubsystem import Wire.Sem.Paging.Cassandra (CassandraPaging) getClientsH :: @@ -95,7 +96,7 @@ rmClientH :: Member ExternalAccess r, Member BackendNotificationQueueAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input (Local ())) r, Member (Input UTCTime) r, diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 182e96fbc5b..f255c0d9658 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -34,7 +34,8 @@ where import Control.Error (headMay) import Control.Lens hiding ((??)) import Data.Id -import Data.List1 (list1) +import Data.Json.Util +import Data.List.NonEmpty qualified as NonEmpty import Data.Misc (FutureWork (FutureWork)) import Data.Qualified import Data.Range @@ -55,16 +56,15 @@ import Galley.Effects import Galley.Effects.BrigAccess import Galley.Effects.ConversationStore qualified as E import Galley.Effects.FederatorAccess qualified as E -import Galley.Effects.GundeckAccess qualified as E import Galley.Effects.MemberStore qualified as E import Galley.Effects.TeamStore qualified as E -import Galley.Intra.Push import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.Teams (notTeamMember) import Galley.Types.ToUserRole import Galley.Types.UserList import Galley.Validation +import Gundeck.Types.Push.V2 qualified as PushV2 import Imports hiding ((\\)) import Polysemy import Polysemy.Error @@ -83,6 +83,7 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotIm import Wire.API.Team.Member import Wire.API.Team.Permission hiding (self) import Wire.API.User +import Wire.NotificationSubsystem ---------------------------------------------------------------------------- -- Group conversations @@ -104,7 +105,7 @@ createGroupConversationUpToV3 :: Member (ErrorS 'MissingLegalholdConsent) r, Member (Error UnreachableBackendsLegacy) r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -143,7 +144,7 @@ createGroupConversation :: Member (ErrorS 'MissingLegalholdConsent) r, Member (Error UnreachableBackends) r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -182,7 +183,7 @@ createGroupConversationGeneric :: Member (ErrorS 'MissingLegalholdConsent) r, Member (Error UnreachableBackends) r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -322,7 +323,7 @@ createOne2OneConversation :: Member (ErrorS 'NotConnected) r, Member (Error UnreachableBackendsLegacy) r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member TeamStore r, Member P.TinyLog r @@ -390,7 +391,7 @@ createLegacyOne2OneConversationUnchecked :: Member (Error InternalError) r, Member (Error InvalidInput) r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member P.TinyLog r ) => @@ -432,7 +433,7 @@ createOne2OneConversationUnchecked :: Member (Error InternalError) r, Member (Error UnreachableBackends) r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member P.TinyLog r ) => @@ -456,7 +457,7 @@ createOne2OneConversationLocally :: Member (Error InternalError) r, Member (Error UnreachableBackends) r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member P.TinyLog r ) => @@ -509,7 +510,7 @@ createConnectConversation :: Member (ErrorS 'InvalidOperation) r, Member (Error UnreachableBackends) r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member MemberStore r, Member P.TinyLog r @@ -543,11 +544,12 @@ createConnectConversation lusr conn j = do now <- input let e = Event (tUntagged lcnv) Nothing (tUntagged lusr) now (EdConnect j) notifyCreatedConversation lusr conn c - for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers c)) $ \p -> - E.push1 $ - p - & pushRoute .~ RouteDirect - & pushConn .~ conn + for_ (newPushLocal (tUnqualified lusr) (toJSONObject e) (localMemberToRecipient <$> Data.convLocalMembers c)) $ \p -> + pushNotifications + [ p + & pushRoute .~ PushV2.RouteDirect + & pushConn .~ conn + ] conversationCreated lusr c update n conv = do let mems = Data.convLocalMembers conv @@ -582,11 +584,12 @@ createConnectConversation lusr conn j = do Nothing -> pure $ Data.convName conv t <- input let e = Event (tUntagged lcnv) Nothing (tUntagged lusr) t (EdConnect j) - for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers conv)) $ \p -> - E.push1 $ - p - & pushRoute .~ RouteDirect - & pushConn .~ conn + for_ (newPushLocal (tUnqualified lusr) (toJSONObject e) (localMemberToRecipient <$> Data.convLocalMembers conv)) $ \p -> + pushNotifications + [ p + & pushRoute .~ PushV2.RouteDirect + & pushConn .~ conn + ] pure $ Data.convSetName n' conv | otherwise = pure conv @@ -650,7 +653,7 @@ notifyCreatedConversation :: Member (Error InternalError) r, Member (Error UnreachableBackends) r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member P.TinyLog r ) => @@ -668,11 +671,11 @@ notifyCreatedConversation lusr conn c = do throw FederationNotConfigured -- Notify local users - E.push =<< mapM (toPush now) (Data.convLocalMembers c) + pushNotifications =<< mapM (toPush now) (Data.convLocalMembers c) where route - | Data.convType c == RegularConv = RouteAny - | otherwise = RouteDirect + | Data.convType c == RegularConv = PushV2.RouteAny + | otherwise = PushV2.RouteDirect toPush t m = do let remoteOthers = remoteMemberToOther <$> Data.convRemoteMembers c localOthers = map (localMemberToOther (tDomain lusr)) $ Data.convLocalMembers c @@ -680,7 +683,7 @@ notifyCreatedConversation lusr conn c = do c' <- conversationViewWithCachedOthers remoteOthers localOthers c (qualifyAs lusr (lmId m)) let e = Event (tUntagged lconv) Nothing (tUntagged lusr) t (EdConversation c') pure $ - newPushLocal1 ListComplete (tUnqualified lusr) (ConvEvent e) (list1 (recipient m) []) + newPushLocal1 (tUnqualified lusr) (toJSONObject e) (NonEmpty.singleton (localMemberToRecipient m)) & pushConn .~ conn & pushRoute .~ route diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 68af385e8d5..7e292c55aab 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -58,7 +58,6 @@ import Galley.Effects import Galley.Effects.ConversationStore qualified as E import Galley.Effects.FireAndForget qualified as E import Galley.Effects.MemberStore qualified as E -import Galley.Intra.Push.Internal hiding (push) import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.Conversations.One2One @@ -94,6 +93,7 @@ import Wire.API.Message import Wire.API.Routes.Named import Wire.API.ServantProto import Wire.API.User (BaseProtocolTag (..)) +import Wire.NotificationSubsystem type FederationAPI = "federation" :> FedApi 'Galley @@ -126,7 +126,7 @@ onClientRemoved :: ( Member BackendNotificationQueueAccess r, Member ConversationStore r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -150,7 +150,7 @@ onClientRemoved domain req = do onConversationCreated :: ( Member BrigAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member ExternalAccess r, Member (Input (Local ())) r, Member MemberStore r, @@ -211,7 +211,7 @@ getConversations domain (GetConversationsRequest uid cids) = do -- or leaving. Finally, push out notifications to local users. onConversationUpdated :: ( Member BrigAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member ExternalAccess r, Member (Input (Local ())) r, Member MemberStore r, @@ -232,7 +232,7 @@ leaveConversation :: Member (Error InternalError) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -301,7 +301,7 @@ leaveConversation requestingDomain lc = do -- FUTUREWORK: error handling for missing / mismatched clients -- FUTUREWORK: support bots onMessageSent :: - ( Member GundeckAccess r, + ( Member NotificationSubsystem r, Member ExternalAccess r, Member MemberStore r, Member (Input (Local ())) r, @@ -315,7 +315,7 @@ onMessageSent domain rmUnqualified = do convId = tUntagged rm.conversation msgMetadata = MessageMetadata - { mmNativePush = push rm, + { mmNativePush = rm.push, mmTransient = transient rm, mmNativePriority = priority rm, mmData = _data rm @@ -355,7 +355,7 @@ sendMessage :: Member (Error InvalidInput) r, Member FederatorAccess r, Member BackendNotificationQueueAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -379,7 +379,7 @@ onUserDeleted :: Member ConversationStore r, Member FireAndForget r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member (Input Env) r, @@ -442,7 +442,7 @@ updateConversation :: Member ExternalAccess r, Member FederatorAccess r, Member (Error InternalError) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -561,7 +561,7 @@ sendMLSCommitBundle :: Member (Error FederationError) r, Member (Error InternalError) r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input Env) r, Member (Input Opts) r, @@ -606,7 +606,7 @@ sendMLSMessage :: Member (Error FederationError) r, Member (Error InternalError) r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input Env) r, Member (Input Opts) r, @@ -767,7 +767,7 @@ instance onMLSMessageSent :: ( Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input Env) r, Member MemberStore r, @@ -821,7 +821,7 @@ onMLSMessageSent domain rmm = mlsSendWelcome :: ( Member (Error InternalError) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member ExternalAccess r, Member P.TinyLog r, Member (Input Env) r, @@ -873,7 +873,7 @@ queryGroupInfo origDomain req = $ state updateTypingIndicator :: - ( Member GundeckAccess r, + ( Member NotificationSubsystem r, Member FederatorAccess r, Member ConversationStore r, Member (Input UTCTime) r, @@ -895,7 +895,7 @@ updateTypingIndicator origDomain TypingDataUpdateRequest {..} = do pure (either TypingDataUpdateError TypingDataUpdateSuccess ret) onTypingIndicatorUpdated :: - ( Member GundeckAccess r + ( Member NotificationSubsystem r ) => Domain -> TypingDataUpdated -> diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 18b2df3cad8..edd2d4a14d0 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -27,7 +27,7 @@ where import Control.Exception.Safe (catchAny) import Control.Lens hiding (Getter, Setter, (.=)) import Data.Id as Id -import Data.List1 (maybeList1) +import Data.Json.Util (ToJSONObject (toJSONObject)) import Data.Map qualified as Map import Data.Qualified import Data.Range @@ -57,12 +57,10 @@ import Galley.Effects.BackendNotificationQueueAccess import Galley.Effects.ClientStore import Galley.Effects.ConversationStore import Galley.Effects.FederatorAccess -import Galley.Effects.GundeckAccess import Galley.Effects.LegalHoldStore as LegalHoldStore import Galley.Effects.MemberStore qualified as E import Galley.Effects.TeamStore import Galley.Effects.TeamStore qualified as E -import Galley.Intra.Push qualified as Intra import Galley.Monad import Galley.Options hiding (brig) import Galley.Queue qualified as Q @@ -70,6 +68,7 @@ import Galley.Types.Bot (AddBot, RemoveBot) import Galley.Types.Bot.Service import Galley.Types.Conversations.Members (RemoteMember (rmId)) import Galley.Types.UserList +import Gundeck.Types.Push.V2 qualified as PushV2 import Imports hiding (head) import Network.AMQP qualified as Q import Network.Wai.Predicate hiding (Error, err, result, setStatus) @@ -99,8 +98,8 @@ import Wire.API.Routes.Internal.Galley import Wire.API.Routes.Internal.Galley.TeamsIntra import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Team.Feature hiding (setStatus) -import Wire.API.Team.Member import Wire.API.User.Client +import Wire.NotificationSubsystem import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra @@ -305,7 +304,7 @@ rmUser :: Member (Error InternalError) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -395,14 +394,12 @@ rmUser lusr conn = do (EdMembersLeave EdReasonDeleted (QualifiedUserIdList [qUser])) for_ (bucketRemote (fmap rmId (Data.convRemoteMembers c))) $ notifyRemoteMembers now qUser (Data.convId c) pure $ - Intra.newPushLocal ListComplete (tUnqualified lusr) (Intra.ConvEvent e) (Intra.recipient <$> Data.convLocalMembers c) - <&> set Intra.pushConn conn - . set Intra.pushRoute Intra.RouteDirect + newPushLocal (tUnqualified lusr) (toJSONObject e) (localMemberToRecipient <$> Data.convLocalMembers c) + <&> set pushConn conn + . set pushRoute PushV2.RouteDirect | otherwise -> pure Nothing - for_ - (maybeList1 (catMaybes pp)) - Galley.Effects.GundeckAccess.push + pushNotifications (catMaybes pp) -- FUTUREWORK: This could be optimized to reduce the number of RPCs -- made. When a team is deleted the burst of RPCs created here could diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 5c23f29b89d..16d8ece876f 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -79,6 +79,7 @@ import Wire.API.Team.LegalHold qualified as Public import Wire.API.Team.LegalHold.External hiding (userId) import Wire.API.Team.Member import Wire.API.User.Client.Prekey +import Wire.NotificationSubsystem import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra @@ -155,7 +156,7 @@ removeSettingsInternalPaging :: Member ExternalAccess r, Member FederatorAccess r, Member FireAndForget r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -199,7 +200,7 @@ removeSettings :: Member ExternalAccess r, Member FederatorAccess r, Member FireAndForget r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -251,7 +252,7 @@ removeSettings' :: Member ExternalAccess r, Member FederatorAccess r, Member FireAndForget r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member (Input (Local ())) r, Member (Input Env) r, @@ -339,7 +340,7 @@ grantConsent :: Member (ErrorS 'UserLegalHoldIllegalOperation) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input UTCTime) r, Member LegalHoldStore r, @@ -385,7 +386,7 @@ requestDevice :: Member (ErrorS 'UserLegalHoldIllegalOperation) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input Env) r, Member (Input UTCTime) r, @@ -465,7 +466,7 @@ approveDevice :: Member (ErrorS 'UserLegalHoldNotPending) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input Env) r, Member (Input UTCTime) r, @@ -541,7 +542,7 @@ disableForUser :: Member (ErrorS 'UserLegalHoldIllegalOperation) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -596,7 +597,7 @@ changeLegalholdStatus :: Member (ErrorS 'UserLegalHoldIllegalOperation) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input UTCTime) r, Member LegalHoldStore r, @@ -712,7 +713,7 @@ handleGroupConvPolicyConflicts :: Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input UTCTime) r, Member (ListItems LegacyPaging ConvId) r, diff --git a/services/galley/src/Galley/API/MLS/Commit/Core.hs b/services/galley/src/Galley/API/MLS/Commit/Core.hs index 59b3e7cd394..7aef8d86e06 100644 --- a/services/galley/src/Galley/API/MLS/Commit/Core.hs +++ b/services/galley/src/Galley/API/MLS/Commit/Core.hs @@ -61,6 +61,7 @@ import Wire.API.MLS.Commit import Wire.API.MLS.Credential import Wire.API.MLS.SubConversation import Wire.API.User.Client +import Wire.NotificationSubsystem type HasProposalActionEffects r = ( Member BackendNotificationQueueAccess r, @@ -78,7 +79,6 @@ type HasProposalActionEffects r = Member (ErrorS 'MLSSelfRemovalNotAllowed) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, Member (Input Env) r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -87,7 +87,8 @@ type HasProposalActionEffects r = Member ProposalStore r, Member SubConversationStore r, Member TeamStore r, - Member TinyLog r + Member TinyLog r, + Member NotificationSubsystem r ) getCommitData :: diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index dda5576a5d9..3afffb4d0a3 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -81,6 +81,7 @@ import Wire.API.MLS.GroupInfo import Wire.API.MLS.Message import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation +import Wire.NotificationSubsystem -- FUTUREWORK -- - Check that the capabilities of a leaf node in an add proposal contains all @@ -274,7 +275,7 @@ postMLSCommitBundleToRemoteConv :: Member (Error UnreachableBackends) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member MemberStore r, Member TinyLog r ) => diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index 6b17a3a8a62..53efadec2dc 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -31,7 +31,6 @@ import Galley.API.Util import Galley.Data.Services import Galley.Effects import Galley.Effects.BackendNotificationQueueAccess -import Galley.Intra.Push.Internal import Galley.Types.Conversations.Members import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports @@ -47,6 +46,7 @@ import Wire.API.MLS.Message import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation import Wire.API.Message +import Wire.NotificationSubsystem -- | Propagate a message. -- The message will not be propagated to the sender client if provided. This is @@ -54,9 +54,9 @@ import Wire.API.Message propagateMessage :: ( Member BackendNotificationQueueAccess r, Member ExternalAccess r, - Member GundeckAccess r, Member (Input UTCTime) r, - Member TinyLog r + Member TinyLog r, + Member NotificationSubsystem r ) => Qualified UserId -> Maybe ClientId -> diff --git a/services/galley/src/Galley/API/MLS/Proposal.hs b/services/galley/src/Galley/API/MLS/Proposal.hs index 90875ecf585..39d56406b4c 100644 --- a/services/galley/src/Galley/API/MLS/Proposal.hs +++ b/services/galley/src/Galley/API/MLS/Proposal.hs @@ -67,6 +67,7 @@ import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation import Wire.API.MLS.Validation import Wire.API.Message +import Wire.NotificationSubsystem data ProposalAction = ProposalAction { paAdd :: ClientMap, @@ -113,6 +114,7 @@ type HasProposalEffects r = ( Member BackendNotificationQueueAccess r, Member BrigAccess r, Member ConversationStore r, + Member NotificationSubsystem r, Member (Error InternalError) r, Member (Error MLSProposalFailure) r, Member (Error MLSProtocolError) r, @@ -123,7 +125,6 @@ type HasProposalEffects r = Member (Error UnreachableBackends) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, Member (Input Env) r, Member (Input (Local ())) r, Member (Input Opts) r, diff --git a/services/galley/src/Galley/API/MLS/Removal.hs b/services/galley/src/Galley/API/MLS/Removal.hs index deb21228e55..f48631e7d23 100644 --- a/services/galley/src/Galley/API/MLS/Removal.hs +++ b/services/galley/src/Galley/API/MLS/Removal.hs @@ -55,6 +55,7 @@ import Wire.API.MLS.Message import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation +import Wire.NotificationSubsystem -- | Send remove proposals for a set of clients to clients in the ClientMap. createAndSendRemoveProposals :: @@ -62,7 +63,7 @@ createAndSendRemoveProposals :: Member TinyLog r, Member BackendNotificationQueueAccess r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member ProposalStore r, Member (Input Env) r, Foldable t @@ -109,7 +110,7 @@ removeClientsWithClientMapRecursively :: Member TinyLog r, Member BackendNotificationQueueAccess r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member MemberStore r, Member ProposalStore r, Member SubConversationStore r, @@ -141,7 +142,7 @@ removeClientsFromSubConvs :: Member TinyLog r, Member BackendNotificationQueueAccess r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member MemberStore r, Member ProposalStore r, Member SubConversationStore r, @@ -177,7 +178,7 @@ removeClientsFromSubConvs lMlsConv getClients qusr = do removeClient :: ( Member BackendNotificationQueueAccess r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input UTCTime) r, Member MemberStore r, @@ -212,7 +213,7 @@ data RemoveUserIncludeMain removeUser :: ( Member BackendNotificationQueueAccess r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input UTCTime) r, Member MemberStore r, @@ -257,7 +258,7 @@ listSubConversations' cid = do removeExtraneousClients :: ( Member BackendNotificationQueueAccess r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input UTCTime) r, Member MemberStore r, diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/services/galley/src/Galley/API/MLS/SubConversation.hs index 9b5ed34274d..7841a718396 100644 --- a/services/galley/src/Galley/API/MLS/SubConversation.hs +++ b/services/galley/src/Galley/API/MLS/SubConversation.hs @@ -67,6 +67,7 @@ import Wire.API.MLS.Credential import Wire.API.MLS.Group.Serialisation import Wire.API.MLS.GroupInfo import Wire.API.MLS.SubConversation +import Wire.NotificationSubsystem type MLSGetSubConvStaticErrors = '[ ErrorS 'ConvNotFound, @@ -329,7 +330,7 @@ type HasLeaveSubConversationEffects r = ConversationStore, ExternalAccess, FederatorAccess, - GundeckAccess, + NotificationSubsystem, Input Env, Input UTCTime, MemberStore, diff --git a/services/galley/src/Galley/API/MLS/Welcome.hs b/services/galley/src/Galley/API/MLS/Welcome.hs index 5ee163ea4f7..02f336562a1 100644 --- a/services/galley/src/Galley/API/MLS/Welcome.hs +++ b/services/galley/src/Galley/API/MLS/Welcome.hs @@ -31,7 +31,6 @@ import Data.Time import Galley.API.Push import Galley.Effects.ExternalAccess import Galley.Effects.FederatorAccess -import Galley.Effects.GundeckAccess import Imports import Network.Wai.Utilities.JSONResponse import Polysemy @@ -50,13 +49,14 @@ import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation import Wire.API.MLS.Welcome import Wire.API.Message +import Wire.NotificationSubsystem (NotificationSubsystem) sendWelcomes :: ( Member FederatorAccess r, - Member GundeckAccess r, Member ExternalAccess r, Member P.TinyLog r, - Member (Input UTCTime) r + Member (Input UTCTime) r, + Member NotificationSubsystem r ) => Local ConvOrSubConvId -> Qualified UserId -> @@ -76,9 +76,10 @@ sendWelcomes loc qusr con cids welcome = do convFrom (SubConv c _) = c sendLocalWelcomes :: - Member GundeckAccess r => - Member P.TinyLog r => - Member ExternalAccess r => + ( Member P.TinyLog r, + Member ExternalAccess r, + Member NotificationSubsystem r + ) => Qualified ConvId -> Qualified UserId -> Maybe ConnId -> diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 47822ff3521..355fccd7942 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -86,6 +86,7 @@ import Wire.API.Team.LegalHold import Wire.API.Team.Member import Wire.API.User.Client import Wire.API.UserMap (UserMap (..)) +import Wire.NotificationSubsystem (NotificationSubsystem) data UserType = User | Bot @@ -253,12 +254,12 @@ postBroadcast :: Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NonBindingTeam) r, Member (ErrorS 'BroadcastLimitExceeded) r, - Member GundeckAccess r, Member ExternalAccess r, Member (Input Opts) r, Member (Input UTCTime) r, Member TeamStore r, - Member P.TinyLog r + Member P.TinyLog r, + Member NotificationSubsystem r ) => Local UserId -> Maybe ConnId -> @@ -366,12 +367,12 @@ postQualifiedOtrMessage :: Member ConversationStore r, Member FederatorAccess r, Member BackendNotificationQueueAccess r, - Member GundeckAccess r, Member ExternalAccess r, Member (Input Opts) r, Member (Input UTCTime) r, Member TeamStore r, - Member P.TinyLog r + Member P.TinyLog r, + Member NotificationSubsystem r ) => UserType -> Qualified UserId -> @@ -581,10 +582,10 @@ makeUserMap keys = (<> Map.fromSet (const mempty) keys) -- sending has failed. sendMessages :: forall r. - ( Member GundeckAccess r, - Member ExternalAccess r, + ( Member ExternalAccess r, Member BackendNotificationQueueAccess r, - Member P.TinyLog r + Member P.TinyLog r, + Member NotificationSubsystem r ) => UTCTime -> Qualified UserId -> @@ -606,9 +607,9 @@ sendMessages now sender senderClient mconn lcnv botMap metadata messages = do mkQualifiedUserClientsByDomain <$> Map.traverseWithKey send messageMap sendBroadcastMessages :: - ( Member GundeckAccess r, - Member ExternalAccess r, - Member P.TinyLog r + ( Member ExternalAccess r, + Member P.TinyLog r, + Member NotificationSubsystem r ) => Local x -> UTCTime -> @@ -633,8 +634,8 @@ byDomain = sendLocalMessages :: forall r x. ( Member ExternalAccess r, - Member GundeckAccess r, - Member P.TinyLog r + Member P.TinyLog r, + Member NotificationSubsystem r ) => Local x -> UTCTime -> diff --git a/services/galley/src/Galley/API/Push.hs b/services/galley/src/Galley/API/Push.hs index 786a805a293..b501c804009 100644 --- a/services/galley/src/Galley/API/Push.hs +++ b/services/galley/src/Galley/API/Push.hs @@ -31,22 +31,20 @@ where import Control.Lens (set) import Data.Id +import Data.Json.Util import Data.List1 qualified as List1 import Data.Map qualified as Map import Data.Qualified import Galley.Data.Services import Galley.Effects.ExternalAccess -import Galley.Effects.GundeckAccess hiding (Push) -import Galley.Intra.Push -import Galley.Intra.Push.Internal hiding (push) -import Gundeck.Types.Push (RecipientClients (RecipientClientsSome)) +import Gundeck.Types.Push (RecipientClients (RecipientClientsSome), Route (..)) import Imports import Polysemy import Polysemy.TinyLog import System.Logger.Class qualified as Log import Wire.API.Event.Conversation import Wire.API.Message -import Wire.API.Team.Member +import Wire.NotificationSubsystem data MessagePush = MessagePush (Maybe ConnId) MessageMetadata [Recipient] [BotMember] Event @@ -80,15 +78,15 @@ newMessagePush botMap mconn mm userOrBots event = runMessagePush :: forall x r. ( Member ExternalAccess r, - Member GundeckAccess r, - Member TinyLog r + Member TinyLog r, + Member NotificationSubsystem r ) => Local x -> Maybe (Qualified ConvId) -> MessagePush -> Sem r () runMessagePush loc mqcnv mp@(MessagePush _ _ _ botMembers event) = do - push (toPush mp) + pushNotifications $ maybeToList $ toPush mp for_ mqcnv $ \qcnv -> if tDomain loc /= qDomain qcnv then unless (null botMembers) $ do @@ -98,7 +96,7 @@ runMessagePush loc mqcnv mp@(MessagePush _ _ _ botMembers event) = do toPush :: MessagePush -> Maybe Push toPush (MessagePush mconn mm rs _ event) = let usr = qUnqualified (evtFrom event) - in newPush ListComplete (Just usr) (ConvEvent event) rs + in newPush (Just usr) (toJSONObject event) rs <&> set pushConn mconn . set pushNativePriority (mmNativePriority mm) . set pushRoute (bool RouteDirect RouteAny (mmNativePush mm)) diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index de6d4486506..95272e6a832 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -71,8 +71,10 @@ import Data.CaseInsensitive qualified as CI import Data.Csv (EncodeOptions (..), Quoting (QuoteAll), encodeDefaultOrderedByNameWith) import Data.Handle qualified as Handle import Data.Id +import Data.Json.Util import Data.LegalHold qualified as LH import Data.List.Extra qualified as List +import Data.List.NonEmpty (NonEmpty (..)) import Data.List1 (list1) import Data.Map qualified as Map import Data.Map.Strict qualified as M @@ -97,7 +99,6 @@ import Galley.Effects import Galley.Effects.BrigAccess qualified as E import Galley.Effects.ConversationStore qualified as E import Galley.Effects.ExternalAccess qualified as E -import Galley.Effects.GundeckAccess qualified as E import Galley.Effects.LegalHoldStore qualified as Data import Galley.Effects.ListItems qualified as E import Galley.Effects.MemberStore qualified as E @@ -107,7 +108,6 @@ import Galley.Effects.SparAccess qualified as Spar import Galley.Effects.TeamMemberStore qualified as E import Galley.Effects.TeamStore qualified as E import Galley.Intra.Journal qualified as Journal -import Galley.Intra.Push import Galley.Options import Galley.Types.Conversations.Members qualified as Conv import Galley.Types.Teams @@ -154,6 +154,7 @@ import Wire.API.User (ScimUserInfo (..), User, UserIdList, UserSSOId (UserScimEx import Wire.API.User qualified as U import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) +import Wire.NotificationSubsystem import Wire.Sem.Paging qualified as E import Wire.Sem.Paging.Cassandra @@ -234,7 +235,7 @@ createNonBindingTeamH :: ( Member BrigAccess r, Member (ErrorS 'UserBindingExists) r, Member (ErrorS 'NotConnected) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member P.TinyLog r, Member TeamStore r @@ -267,7 +268,7 @@ createNonBindingTeamH zusr zcon (Public.NonBindingNewTeam body) = do pure (team ^. teamId) createBindingTeam :: - ( Member GundeckAccess r, + ( Member NotificationSubsystem r, Member (Input UTCTime) r, Member TeamStore r ) => @@ -324,7 +325,7 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do updateTeamH :: ( Member (ErrorS 'NotATeamMember) r, Member (ErrorS ('MissingPermission ('Just 'SetTeamData))) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member TeamStore r ) => @@ -340,8 +341,8 @@ updateTeamH zusr zcon tid updateData = do now <- input admins <- E.getTeamAdmins tid let e = newEvent tid now (EdTeamUpdate updateData) - let r = list1 (userRecipient zusr) (map userRecipient (filter (/= zusr) admins)) - E.push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) r & pushConn ?~ zcon & pushTransient .~ True + let r = userRecipient zusr :| map userRecipient (filter (/= zusr) admins) + pushNotifications [newPushLocal1 zusr (toJSONObject e) r & pushConn ?~ zcon & pushTransient .~ True] deleteTeam :: forall r. @@ -404,7 +405,7 @@ uncheckedDeleteTeam :: forall r. ( Member BrigAccess r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Opts) r, Member (Input UTCTime) r, Member LegalHoldStore r, @@ -452,9 +453,9 @@ uncheckedDeleteTeam lusr zcon tid = do [] -> pure () -- push TeamDelete events. Note that despite having a complete list, we are guaranteed in the -- push module to never fan this out to more than the limit - x : xs -> E.push1 (newPushLocal1 ListComplete (tUnqualified lusr) (TeamEvent e) (list1 x xs) & pushConn .~ zcon) + x : xs -> pushNotifications [newPushLocal1 (tUnqualified lusr) (toJSONObject e) (x :| xs) & pushConn .~ zcon] -- To avoid DoS on gundeck, send conversation deletion events slowly - E.pushSlowly ue + pushNotificationsSlowly ue createConvDeleteEvents :: UTCTime -> [TeamMember] -> @@ -470,7 +471,7 @@ uncheckedDeleteTeam lusr zcon tid = do let mm = nonTeamMembers convMembs teamMembs let e = Conv.Event qconvId Nothing (tUntagged lusr) now Conv.EdConvDelete -- This event always contains all the required recipients - let p = newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (map recipient mm) + let p = newPushLocal (tUnqualified lusr) (toJSONObject e) (map localMemberToRecipient mm) let ee' = map (,e) bots let pp' = maybe pp (\x -> (x & pushConn .~ zcon) : pp) p pure (pp', ee' ++ ee) @@ -710,7 +711,7 @@ uncheckedGetTeamMembers = E.getTeamMembersWithLimit addTeamMember :: forall r. ( Member BrigAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (ErrorS 'InvalidPermissions) r, Member (ErrorS 'NoAddToBinding) r, Member (ErrorS 'NotATeamMember) r, @@ -757,7 +758,7 @@ addTeamMember lzusr zcon tid nmem = do uncheckedAddTeamMember :: forall r. ( Member BrigAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (ErrorS 'TooManyTeamMembers) r, Member (ErrorS 'TooManyTeamAdmins) r, Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r, @@ -785,7 +786,7 @@ uncheckedUpdateTeamMember :: Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TooManyTeamAdmins) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member P.TinyLog r, Member TeamStore r @@ -823,8 +824,8 @@ uncheckedUpdateTeamMember mlzusr mZcon tid newMember = do now <- input let event = newEvent tid now (EdMemberUpdate targetId (Just targetPermissions)) - let pushPriv = newPush ListComplete mZusr (TeamEvent event) (map userRecipient admins') - for_ pushPriv (\p -> E.push1 (p & pushConn .~ mZcon & pushTransient .~ True)) + let pushPriv = newPush mZusr (toJSONObject event) (map userRecipient admins') + for_ pushPriv (\p -> pushNotifications [p & pushConn .~ mZcon & pushTransient .~ True]) updateTeamMember :: forall r. @@ -836,7 +837,7 @@ updateTeamMember :: Member (ErrorS 'TooManyTeamAdmins) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member P.TinyLog r, Member TeamStore r @@ -893,7 +894,7 @@ deleteTeamMember :: Member ExternalAccess r, Member (Input Opts) r, Member (Input UTCTime) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member MemberStore r, Member TeamFeatureStore r, Member TeamStore r, @@ -921,7 +922,7 @@ deleteNonBindingTeamMember :: Member ExternalAccess r, Member (Input Opts) r, Member (Input UTCTime) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member MemberStore r, Member TeamFeatureStore r, Member TeamStore r, @@ -949,7 +950,7 @@ deleteTeamMember' :: Member ExternalAccess r, Member (Input Opts) r, Member (Input UTCTime) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member MemberStore r, Member TeamFeatureStore r, Member TeamStore r, @@ -1007,7 +1008,7 @@ uncheckedDeleteTeamMember :: forall r. ( Member BackendNotificationQueueAccess r, Member ConversationStore r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member ExternalAccess r, Member (Input UTCTime) r, Member (P.Logger (Log.Msg -> Log.Msg)) r, @@ -1033,11 +1034,9 @@ uncheckedDeleteTeamMember lusr zcon tid remove (Left admins) = do let e = newEvent tid now (EdMemberLeave remove) let r = userRecipient - <$> list1 - (tUnqualified lusr) - (filter (/= (tUnqualified lusr)) admins) - E.push1 $ - newPushLocal1 ListComplete (tUnqualified lusr) (TeamEvent e) r & pushConn .~ zcon & pushTransient .~ True + <$> (tUnqualified lusr :| filter (/= (tUnqualified lusr)) admins) + pushNotifications + [newPushLocal1 (tUnqualified lusr) (toJSONObject e) r & pushConn .~ zcon & pushTransient .~ True] uncheckedDeleteTeamMember lusr zcon tid remove (Right mems) = do now <- input pushMemberLeaveEventToAll now @@ -1051,19 +1050,17 @@ uncheckedDeleteTeamMember lusr zcon tid remove (Right mems) = do pushMemberLeaveEventToAll :: UTCTime -> Sem r () pushMemberLeaveEventToAll now = do let e = newEvent tid now (EdMemberLeave remove) - let r = - list1 - (userRecipient (tUnqualified lusr)) - (membersToRecipients (Just (tUnqualified lusr)) (mems ^. teamMembers)) - E.push1 $ - newPushLocal1 (mems ^. teamMemberListType) (tUnqualified lusr) (TeamEvent e) r & pushTransient .~ True + let r = userRecipient (tUnqualified lusr) :| membersToRecipients (Just (tUnqualified lusr)) (mems ^. teamMembers) + when (mems ^. teamMemberListType == ListComplete) $ do + pushNotifications + [newPushLocal1 (tUnqualified lusr) (toJSONObject e) r & pushTransient .~ True] removeFromConvsAndPushConvLeaveEvent :: forall r. ( Member BackendNotificationQueueAccess r, Member ConversationStore r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member (P.Logger (Log.Msg -> Log.Msg)) r, Member MemberStore r, @@ -1149,7 +1146,7 @@ deleteTeamConversation :: Member MemberStore r, Member ProposalStore r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member SubConversationStore r, Member TeamStore r, @@ -1307,7 +1304,7 @@ addTeamMemberInternal :: ( Member BrigAccess r, Member (ErrorS 'TooManyTeamMembers) r, Member (ErrorS 'TooManyTeamAdmins) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Opts) r, Member (Input UTCTime) r, Member TeamNotificationStore r, @@ -1334,16 +1331,19 @@ addTeamMemberInternal tid origin originConn (ntmNewTeamMember -> new) = do now <- input let e = newEvent tid now (EdMemberJoin (new ^. userId)) let rs = case origin of - Just o -> userRecipient <$> list1 o (filter (/= o) ((new ^. userId) : admins')) - Nothing -> userRecipient <$> list1 (new ^. userId) (admins') - E.push1 $ - newPushLocal1 ListComplete (new ^. userId) (TeamEvent e) rs & pushConn .~ originConn & pushTransient .~ True + Just o -> userRecipient <$> o :| filter (/= o) ((new ^. userId) : admins') + Nothing -> userRecipient <$> new ^. userId :| admins' + pushNotifications + [ newPushLocal1 (new ^. userId) (toJSONObject e) rs + & pushConn .~ originConn + & pushTransient .~ True + ] APITeamQueue.pushTeamEvent tid e pure sizeBeforeAdd finishCreateTeam :: - ( Member GundeckAccess r, + ( Member NotificationSubsystem r, Member (Input UTCTime) r, Member TeamStore r ) => @@ -1359,7 +1359,10 @@ finishCreateTeam team owner others zcon = do now <- input let e = newEvent (team ^. teamId) now (EdTeamCreate team) let r = membersToRecipients Nothing others - E.push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon + pushNotifications + [ newPushLocal1 zusr (toJSONObject e) (userRecipient zusr :| r) + & pushConn .~ zcon + ] getBindingTeamIdH :: ( Member (ErrorS 'TeamNotFound) r, diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index f18b1fe6c59..e9085fca925 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -39,6 +39,7 @@ where import Control.Lens import Data.ByteString.Conversion (toByteString') import Data.Id +import Data.Json.Util import Data.Kind import Data.Qualified (Local) import Data.Schema @@ -52,12 +53,10 @@ import Galley.API.Util (assertTeamExists, getTeamMembersForFanout, membersToReci import Galley.App import Galley.Effects import Galley.Effects.BrigAccess (updateSearchVisibilityInbound) -import Galley.Effects.GundeckAccess import Galley.Effects.SearchVisibilityStore qualified as SearchVisibilityData import Galley.Effects.TeamFeatureStore import Galley.Effects.TeamFeatureStore qualified as TeamFeatures import Galley.Effects.TeamStore (getLegalHoldFlag, getTeamMember) -import Galley.Intra.Push (PushEvent (FeatureConfigEvent), newPush) import Galley.Types.Teams import Imports import Polysemy @@ -72,6 +71,7 @@ import Wire.API.Event.FeatureConfig qualified as Event import Wire.API.Federation.Error import Wire.API.Team.Feature import Wire.API.Team.Member +import Wire.NotificationSubsystem import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra @@ -85,7 +85,7 @@ patchFeatureStatusInternal :: Member TeamStore r, Member TeamFeatureStore r, Member (P.Logger (Log.Msg -> Log.Msg)) r, - Member GundeckAccess r + Member NotificationSubsystem r ) => TeamId -> WithStatusPatch cfg -> @@ -119,7 +119,7 @@ setFeatureStatus :: Member TeamStore r, Member TeamFeatureStore r, Member (P.Logger (Log.Msg -> Log.Msg)) r, - Member GundeckAccess r + Member NotificationSubsystem r ) => DoAuth -> TeamId -> @@ -147,7 +147,7 @@ setFeatureStatusInternal :: Member TeamStore r, Member TeamFeatureStore r, Member (P.Logger (Log.Msg -> Log.Msg)) r, - Member GundeckAccess r + Member NotificationSubsystem r ) => TeamId -> WithStatusNoLock cfg -> @@ -177,7 +177,7 @@ persistAndPushEvent :: GetConfigForTeamConstraints cfg r, Member TeamFeatureStore r, Member (P.Logger (Log.Msg -> Log.Msg)) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member TeamStore r ) => TeamId -> @@ -190,7 +190,7 @@ persistAndPushEvent tid wsnl = do pure fs pushFeatureConfigEvent :: - ( Member GundeckAccess r, + ( Member NotificationSubsystem r, Member TeamStore r, Member P.TinyLog r ) => @@ -199,16 +199,18 @@ pushFeatureConfigEvent :: Sem r () pushFeatureConfigEvent tid event = do memList <- getTeamMembersForFanout tid - when ((memList ^. teamMemberListType) == ListTruncated) $ do - P.warn $ - Log.field "action" (Log.val "Features.pushFeatureConfigEvent") - . Log.field "feature" (Log.val (toByteString' . Event._eventFeatureName $ event)) - . Log.field "team" (Log.val (cs . show $ tid)) - . Log.msg @Text "Fanout limit exceeded. Some events will not be sent." - let recipients = membersToRecipients Nothing (memList ^. teamMembers) - for_ - (newPush (memList ^. teamMemberListType) Nothing (FeatureConfigEvent event) recipients) - push1 + if ((memList ^. teamMemberListType) == ListTruncated) + then do + P.warn $ + Log.field "action" (Log.val "Features.pushFeatureConfigEvent") + . Log.field "feature" (Log.val (toByteString' . Event._eventFeatureName $ event)) + . Log.field "team" (Log.val (cs . show $ tid)) + . Log.msg @Text "Fanout limit exceeded. Events will not be sent." + else do + let recipients = membersToRecipients Nothing (memList ^. teamMembers) + pushNotifications $ + maybeToList $ + (newPush Nothing (toJSONObject event) recipients) guardLockStatus :: forall r. @@ -235,7 +237,7 @@ class GetFeatureConfig cfg => SetFeatureConfig cfg where GetConfigForTeamConstraints cfg r, ( Member TeamFeatureStore r, Member (P.Logger (Log.Msg -> Log.Msg)) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member TeamStore r ) ) => @@ -249,7 +251,7 @@ class GetFeatureConfig cfg => SetFeatureConfig cfg where Members '[ TeamFeatureStore, P.Logger (Log.Msg -> Log.Msg), - GundeckAccess, + NotificationSubsystem, TeamStore ] r @@ -305,7 +307,7 @@ instance SetFeatureConfig LegalholdConfig where Member ExternalAccess r, Member FederatorAccess r, Member FireAndForget r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input Env) r, Member (Input UTCTime) r, diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index bd860ef86b0..c6195576758 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -102,11 +102,9 @@ import Galley.Effects.CodeStore qualified as E import Galley.Effects.ConversationStore qualified as E import Galley.Effects.ExternalAccess qualified as E import Galley.Effects.FederatorAccess qualified as E -import Galley.Effects.GundeckAccess qualified as E import Galley.Effects.MemberStore qualified as E import Galley.Effects.ServiceStore qualified as E import Galley.Effects.WaiRoutes -import Galley.Intra.Push import Galley.Options import Galley.Types.Bot hiding (addBot) import Galley.Types.Bot.Service (Service) @@ -142,15 +140,15 @@ import Wire.API.Routes.Public (ZHostValue) import Wire.API.Routes.Public.Galley.Messaging import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.ServantProto (RawProto (..)) -import Wire.API.Team.Member import Wire.API.User.Client +import Wire.NotificationSubsystem acceptConv :: ( Member ConversationStore r, Member (Error InternalError) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member MemberStore r, Member TinyLog r @@ -187,7 +185,7 @@ unblockConv :: Member (Error InternalError) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member MemberStore r, Member TinyLog r @@ -228,7 +226,7 @@ type UpdateConversationAccessEffects = ExternalAccess, FederatorAccess, FireAndForget, - GundeckAccess, + NotificationSubsystem, Input Env, Input UTCTime, MemberStore, @@ -278,7 +276,7 @@ updateConversationReceiptMode :: Member (ErrorS 'InvalidOperation) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member MemberStore r, @@ -311,7 +309,7 @@ updateRemoteConversation :: ( Member BrigAccess r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member MemberStore r, Member TinyLog r, @@ -352,7 +350,7 @@ updateConversationReceiptModeUnqualified :: Member (ErrorS 'InvalidOperation) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member MemberStore r, @@ -373,7 +371,7 @@ updateConversationMessageTimer :: Member (ErrorS 'InvalidOperation) r, Member (Error FederationError) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member (Logger (Msg -> Msg)) r ) => @@ -406,7 +404,7 @@ updateConversationMessageTimerUnqualified :: Member (ErrorS 'InvalidOperation) r, Member (Error FederationError) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member (Logger (Msg -> Msg)) r ) => @@ -429,7 +427,7 @@ deleteLocalConversation :: Member (ErrorS 'InvalidOperation) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member SubConversationStore r, Member MemberStore r, Member ProposalStore r, @@ -457,7 +455,7 @@ addCodeUnqualifiedWithReqBody :: Member (ErrorS 'GuestLinksDisabled) r, Member (ErrorS 'CreateConversationCodeConflict) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member (Embed IO) r, @@ -481,7 +479,7 @@ addCodeUnqualified :: Member (ErrorS 'GuestLinksDisabled) r, Member (ErrorS 'CreateConversationCodeConflict) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member (Input Opts) r, @@ -508,7 +506,7 @@ addCode :: Member (ErrorS 'GuestLinksDisabled) r, Member (ErrorS 'CreateConversationCodeConflict) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member (Input Opts) r, Member TeamFeatureStore r, @@ -558,7 +556,7 @@ rmCodeUnqualified :: Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'ConvAccessDenied) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r ) => @@ -576,7 +574,7 @@ rmCode :: Member (ErrorS 'ConvAccessDenied) r, Member (ErrorS 'ConvNotFound) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r ) => Local UserId -> @@ -661,7 +659,7 @@ updateConversationProtocolWithLocalUser :: Member ConversationStore r, Member MemberStore r, Member TinyLog r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member ExternalAccess r, Member FederatorAccess r, Member ProposalStore r, @@ -706,7 +704,7 @@ joinConversationByReusableCode :: Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TooManyMembers) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Opts) r, Member (Input UTCTime) r, Member MemberStore r, @@ -735,7 +733,7 @@ joinConversationById :: Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TooManyMembers) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Opts) r, Member (Input UTCTime) r, Member MemberStore r, @@ -759,7 +757,7 @@ joinConversation :: Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TooManyMembers) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Opts) r, Member (Input UTCTime) r, Member MemberStore r, @@ -813,7 +811,7 @@ addMembers :: Member (Error UnreachableBackends) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -854,7 +852,7 @@ addMembersUnqualifiedV2 :: Member (Error UnreachableBackends) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -895,7 +893,7 @@ addMembersUnqualified :: Member (Error UnreachableBackends) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -919,7 +917,7 @@ updateSelfMember :: ( Member ConversationStore r, Member (ErrorS 'ConvNotFound) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member MemberStore r ) => @@ -966,7 +964,7 @@ updateUnqualifiedSelfMember :: ( Member ConversationStore r, Member (ErrorS 'ConvNotFound) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member MemberStore r ) => @@ -989,7 +987,7 @@ updateOtherMemberLocalConv :: Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'ConvMemberNotFound) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member MemberStore r, Member (Logger (Msg -> Msg)) r @@ -1016,7 +1014,7 @@ updateOtherMemberUnqualified :: Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'ConvMemberNotFound) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member MemberStore r, Member (Logger (Msg -> Msg)) r @@ -1042,7 +1040,7 @@ updateOtherMember :: Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'ConvMemberNotFound) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member MemberStore r, Member (Logger (Msg -> Msg)) r @@ -1077,7 +1075,7 @@ removeMemberUnqualified :: Member (ErrorS 'InvalidOperation) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input UTCTime) r, Member MemberStore r, @@ -1105,7 +1103,7 @@ removeMemberQualified :: Member (ErrorS 'InvalidOperation) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input UTCTime) r, Member MemberStore r, @@ -1180,7 +1178,7 @@ removeMemberFromLocalConv :: Member (ErrorS 'InvalidOperation) r, Member ExternalAccess r, Member FederatorAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Env) r, Member (Input UTCTime) r, Member MemberStore r, @@ -1216,7 +1214,7 @@ postProteusMessage :: Member ConversationStore r, Member FederatorAccess r, Member BackendNotificationQueueAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member ExternalAccess r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -1241,7 +1239,7 @@ postProteusBroadcast :: Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NonBindingTeam) r, Member (ErrorS 'BroadcastLimitExceeded) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member ExternalAccess r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -1292,7 +1290,7 @@ postBotMessageUnqualified :: Member ExternalAccess r, Member FederatorAccess r, Member BackendNotificationQueueAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input Opts) r, Member TeamStore r, @@ -1321,7 +1319,7 @@ postOtrBroadcastUnqualified :: Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NonBindingTeam) r, Member (ErrorS 'BroadcastLimitExceeded) r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member ExternalAccess r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -1346,7 +1344,7 @@ postOtrMessageUnqualified :: Member FederatorAccess r, Member BackendNotificationQueueAccess r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Opts) r, Member (Input UTCTime) r, Member TeamStore r, @@ -1374,7 +1372,7 @@ updateConversationName :: Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member (Logger (Msg -> Msg)) r, Member TeamStore r @@ -1401,7 +1399,7 @@ updateUnqualifiedConversationName :: Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member (Logger (Msg -> Msg)) r, Member TeamStore r @@ -1424,7 +1422,7 @@ updateLocalConversationName :: Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member (Logger (Msg -> Msg)) r, Member TeamStore r @@ -1439,7 +1437,7 @@ updateLocalConversationName lusr zcon lcnv rename = updateLocalConversation @'ConversationRenameTag lcnv (tUntagged lusr) (Just zcon) rename memberTyping :: - ( Member GundeckAccess r, + ( Member NotificationSubsystem r, Member (ErrorS 'ConvNotFound) r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -1477,7 +1475,7 @@ memberTyping lusr zcon qcnv ts = do qcnv memberTypingUnqualified :: - ( Member GundeckAccess r, + ( Member NotificationSubsystem r, Member (ErrorS 'ConvNotFound) r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -1522,7 +1520,7 @@ addBotH :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'TooManyMembers) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input Opts) r, Member (Input UTCTime) r, @@ -1545,7 +1543,7 @@ addBot :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'TooManyMembers) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input Opts) r, Member (Input UTCTime) r, Member MemberStore r @@ -1576,8 +1574,8 @@ addBot lusr zcon b = do ] ) ) - for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> users)) $ \p -> - E.push1 $ p & pushConn ?~ zcon + for_ (newPushLocal (tUnqualified lusr) (toJSONObject e) (localMemberToRecipient <$> users)) $ \p -> + pushNotifications [p & pushConn ?~ zcon] E.deliverAsync (map (,e) (bm : bots)) pure e where @@ -1599,7 +1597,7 @@ rmBotH :: Member ConversationStore r, Member (ErrorS 'ConvNotFound) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member MemberStore r, @@ -1618,7 +1616,7 @@ rmBot :: Member ConversationStore r, Member (ErrorS 'ConvNotFound) r, Member ExternalAccess r, - Member GundeckAccess r, + Member NotificationSubsystem r, Member (Input UTCTime) r, Member MemberStore r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r @@ -1648,8 +1646,8 @@ rmBot lusr zcon b = do do let evd = EdMembersLeaveRemoved (QualifiedUserIdList [tUntagged (qualifyAs lusr (botUserId (b ^. rmBotId)))]) let e = Event (tUntagged lcnv) Nothing (tUntagged lusr) t evd - for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> users)) $ \p -> - E.push1 $ p & pushConn .~ zcon + for_ (newPushLocal (tUnqualified lusr) (toJSONObject e) (localMemberToRecipient <$> users)) $ \p -> + pushNotifications [p & pushConn .~ zcon] E.deleteMembers (Data.convId c) (UserList [botUserId (b ^. rmBotId)] []) E.deleteClients (botUserId (b ^. rmBotId)) E.deliverAsync (map (,e) bots) diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 8519477fc28..b4759ef59e2 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -26,6 +26,7 @@ import Data.ByteString.Conversion import Data.Code qualified as Code import Data.Domain (Domain) import Data.Id as Id +import Data.Json.Util import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Extra (chunksOf, nubOrd) import Data.List.NonEmpty (NonEmpty) @@ -49,16 +50,15 @@ import Galley.Effects.CodeStore import Galley.Effects.ConversationStore import Galley.Effects.ExternalAccess import Galley.Effects.FederatorAccess -import Galley.Effects.GundeckAccess import Galley.Effects.LegalHoldStore import Galley.Effects.MemberStore import Galley.Effects.TeamStore -import Galley.Intra.Push import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.Conversations.Roles import Galley.Types.Teams import Galley.Types.UserList +import Gundeck.Types.Push.V2 qualified as PushV2 import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai @@ -89,6 +89,7 @@ import Wire.API.Team.Member qualified as Mem import Wire.API.Team.Role import Wire.API.User hiding (userId) import Wire.API.User.Auth.ReAuth +import Wire.NotificationSubsystem type JSON = Media "application" "json" @@ -315,9 +316,9 @@ acceptOne2One :: Member (ErrorS 'ConvNotFound) r, Member (Error InternalError) r, Member (ErrorS 'InvalidOperation) r, - Member GundeckAccess r, Member (Input UTCTime) r, - Member MemberStore r + Member MemberStore r, + Member NotificationSubsystem r ) => Local UserId -> Data.Conversation -> @@ -344,8 +345,8 @@ acceptOne2One lusr conv conn = do let e = memberJoinEvent lusr (tUntagged lcid) now mm [] conv' <- if isJust (find ((tUnqualified lusr /=) . lmId) mems) then promote else pure conv let mems' = mems <> toList mm - for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> mems')) $ \p -> - push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect + for_ (newPushLocal (tUnqualified lusr) (toJSONObject e) (localMemberToRecipient <$> mems')) $ \p -> + pushNotifications [p & pushConn .~ conn & pushRoute .~ PushV2.RouteDirect] pure conv' {Data.convLocalMembers = mems'} _ -> throwS @'InvalidOperation where @@ -355,6 +356,12 @@ acceptOne2One lusr conv conn = do acceptConnectConversation cid pure $ Data.convSetType One2OneConv conv +localMemberToRecipient :: LocalMember -> Recipient +localMemberToRecipient = userRecipient . lmId + +userRecipient :: UserId -> Recipient +userRecipient u = Recipient u PushV2.RecipientClientsAll + memberJoinEvent :: Local UserId -> Qualified ConvId -> @@ -630,8 +637,8 @@ canDeleteMember deleter deletee -- | Send an event to local users and bots pushConversationEvent :: - ( Member GundeckAccess r, - Member ExternalAccess r, + ( Member ExternalAccess r, + Member NotificationSubsystem r, Foldable f ) => Maybe ConnId -> @@ -641,9 +648,14 @@ pushConversationEvent :: Sem r () pushConversationEvent conn e lusers bots = do for_ (newConversationEventPush e (fmap toList lusers)) $ \p -> - push1 $ p & set pushConn conn + pushNotifications [p & set pushConn conn] deliverAsync (map (,e) (toList bots)) +newConversationEventPush :: Event -> Local [UserId] -> Maybe Push +newConversationEventPush e users = + let musr = guard (tDomain users == qDomain (evtFrom e)) $> qUnqualified (evtFrom e) + in newPush musr (toJSONObject e) (map userRecipient (tUnqualified users)) + verifyReusableCode :: ( Member CodeStore r, Member (ErrorS 'CodeNotFound) r, diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 14873001deb..a4f780bdb78 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -92,6 +92,7 @@ import Network.HTTP.Client.OpenSSL import Network.Wai.Utilities.JSONResponse import OpenSSL.Session as Ssl import Polysemy +import Polysemy.Async import Polysemy.Error import Polysemy.Input import Polysemy.Internal (Append) @@ -107,6 +108,10 @@ import Wire.API.Conversation.Protocol import Wire.API.Error import Wire.API.Federation.Error import Wire.API.Team.Feature +import Wire.GundeckAPIAccess (runGundeckAPIAccess) +import Wire.NotificationSubsystem.Interpreter (runNotificationSubsystemGundeck) +import Wire.Rpc +import Wire.Sem.Delay import Wire.Sem.Logger qualified import Wire.Sem.Random.IO @@ -119,6 +124,8 @@ type GalleyEffects0 = -- federation errors can be thrown by almost every endpoint, so we avoid -- having to declare it every single time, and simply handle it here Error FederationError, + Async, + Delay, Embed IO, Error JSONResponse, Resource, @@ -238,6 +245,8 @@ evalGalley e = . resourceToIOFinal . runError . embedToFinal @IO + . runDelay + . asyncToIOFinal . mapError toResponse . mapError toResponse . mapError toResponse @@ -276,7 +285,9 @@ evalGalley e = . interpretBackendNotificationQueueAccess . interpretFederatorAccess . interpretExternalAccess - . interpretGundeckAccess + . runRpcWithHttp (e ^. manager) (e ^. reqId) + . runGundeckAPIAccess (e ^. options . gundeck) + . runNotificationSubsystemGundeck (notificationSubssystemConfig e) . interpretSparAccess . interpretBrigAccess where diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 12c7c31df5f..fbca2a7e3a3 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -23,7 +23,6 @@ module Galley.Effects BotAccess, BrigAccess, FederatorAccess, - GundeckAccess, SparAccess, -- * External services @@ -77,7 +76,6 @@ import Galley.Effects.CustomBackendStore import Galley.Effects.ExternalAccess import Galley.Effects.FederatorAccess import Galley.Effects.FireAndForget -import Galley.Effects.GundeckAccess import Galley.Effects.LegalHoldStore import Galley.Effects.ListItems import Galley.Effects.MemberStore @@ -99,6 +97,9 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog import Wire.API.Error +import Wire.GundeckAPIAccess +import Wire.NotificationSubsystem +import Wire.Rpc import Wire.Sem.Paging.Cassandra import Wire.Sem.Random @@ -106,7 +107,9 @@ import Wire.Sem.Random type GalleyEffects1 = '[ BrigAccess, SparAccess, - GundeckAccess, + NotificationSubsystem, + GundeckAPIAccess, + Rpc, ExternalAccess, FederatorAccess, BackendNotificationQueueAccess, diff --git a/services/galley/src/Galley/Effects/GundeckAccess.hs b/services/galley/src/Galley/Effects/GundeckAccess.hs deleted file mode 100644 index c0ab484bf7b..00000000000 --- a/services/galley/src/Galley/Effects/GundeckAccess.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.Effects.GundeckAccess - ( -- * Gundeck access effect - GundeckAccess (..), - push, - push1, - pushSlowly, - ) -where - -import Galley.Intra.Push qualified as G -import Imports -import Polysemy - -data GundeckAccess m a where - Push :: Foldable f => f G.Push -> GundeckAccess m () - PushSlowly :: Foldable f => f G.Push -> GundeckAccess m () - -makeSem ''GundeckAccess - --- | Asynchronously send a single push, chunking it into multiple --- requests if there are more than 128 recipients. -push1 :: Member GundeckAccess r => G.Push -> Sem r () -push1 x = push [x] diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 2bdb38c27ff..ca8f4212f9d 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -27,6 +27,7 @@ import Data.Id import Data.Metrics.Middleware import Data.Misc (Fingerprint, HttpsUrl, Rsa) import Data.Range +import Data.Time.Clock.DiffTime (millisecondsToDiffTime) import Galley.Aws qualified as Aws import Galley.Options import Galley.Options qualified as O @@ -44,6 +45,7 @@ import Util.Options import Wire.API.MLS.Credential import Wire.API.MLS.Keys import Wire.API.Team.Member +import Wire.NotificationSubsystem.Interpreter data DeleteItem = TeamItem TeamId UserId (Maybe ConnId) deriving (Eq, Ord, Show) @@ -106,6 +108,19 @@ reqIdMsg = ("request" .=) . unRequestId currentFanoutLimit :: Opts -> Range 1 HardTruncationLimit Int32 currentFanoutLimit o = do - let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defFanoutLimit (o ^. (O.settings . maxFanoutSize)) + let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defaultFanoutLimit (o ^. (O.settings . maxFanoutSize)) let maxSize = fromIntegral (o ^. (O.settings . maxTeamSize)) unsafeRange (min maxSize optFanoutLimit) + +notificationSubssystemConfig :: Env -> NotificationSubsystemConfig +notificationSubssystemConfig env = + NotificationSubsystemConfig + { chunkSize = defaultChunkSize, + fanoutLimit = currentFanoutLimit env._options, + slowPushDelay = + maybe + defaultSlowPushDelay + (millisecondsToDiffTime . toInteger) + (env ^. options . O.settings . deleteConvThrottleMillis), + requestId = env ^. reqId + } diff --git a/services/galley/src/Galley/Intra/Effects.hs b/services/galley/src/Galley/Intra/Effects.hs index 51909889e85..70a78b982a4 100644 --- a/services/galley/src/Galley/Intra/Effects.hs +++ b/services/galley/src/Galley/Intra/Effects.hs @@ -19,18 +19,15 @@ module Galley.Intra.Effects ( interpretBrigAccess, interpretSparAccess, interpretBotAccess, - interpretGundeckAccess, ) where import Galley.API.Error import Galley.Effects.BotAccess (BotAccess (..)) import Galley.Effects.BrigAccess (BrigAccess (..)) -import Galley.Effects.GundeckAccess (GundeckAccess (..)) import Galley.Effects.SparAccess (SparAccess (..)) import Galley.Env import Galley.Intra.Client -import Galley.Intra.Push.Internal qualified as G import Galley.Intra.Spar import Galley.Intra.Team import Galley.Intra.User @@ -102,13 +99,3 @@ interpretBotAccess :: Sem r a interpretBotAccess = interpret $ \case DeleteBot cid bid -> embedApp $ deleteBot cid bid - -interpretGundeckAccess :: - ( Member (Embed IO) r, - Member (Input Env) r - ) => - Sem (GundeckAccess ': r) a -> - Sem r a -interpretGundeckAccess = interpret $ \case - Push ps -> embedApp $ G.push ps - PushSlowly ps -> embedApp $ G.pushSlowly ps diff --git a/services/galley/src/Galley/Intra/Push.hs b/services/galley/src/Galley/Intra/Push.hs deleted file mode 100644 index 848b3cc28d9..00000000000 --- a/services/galley/src/Galley/Intra/Push.hs +++ /dev/null @@ -1,50 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.Intra.Push - ( -- * Push - Push, - newPush, - newPushLocal, - newConversationEventPush, - newPush1, - newPushLocal1, - PushEvent (..), - - -- * Push Configuration - pushConn, - pushTransient, - pushRoute, - pushNativePriority, - pushAsync, - pushRecipients, - - -- * Push Recipients - Recipient, - recipient, - userRecipient, - recipientUserId, - recipientClients, - - -- * Re-Exports - Gundeck.Route (..), - Gundeck.Priority (..), - ) -where - -import Galley.Intra.Push.Internal -import Gundeck.Types.Push.V2 qualified as Gundeck diff --git a/services/galley/src/Galley/Intra/Push/Internal.hs b/services/galley/src/Galley/Intra/Push/Internal.hs deleted file mode 100644 index 4adcf716f73..00000000000 --- a/services/galley/src/Galley/Intra/Push/Internal.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.Intra.Push.Internal where - -import Bilge hiding (options) -import Control.Lens (makeLenses, set, view, (.~)) -import Data.Aeson (Object) -import Data.Id (ConnId, UserId) -import Data.Json.Util -import Data.List.Extra -import Data.List.NonEmpty (NonEmpty, nonEmpty) -import Data.List1 -import Data.Qualified -import Data.Range -import Data.Set qualified as Set -import Galley.Env -import Galley.Intra.Util -import Galley.Monad -import Galley.Options -import Galley.Types.Conversations.Members -import Gundeck.Types.Push.V2 (RecipientClients (..)) -import Gundeck.Types.Push.V2 qualified as Gundeck -import Imports hiding (forkIO) -import UnliftIO.Async (mapConcurrently_) -import Wire.API.Event.Conversation (Event (evtFrom)) -import Wire.API.Event.FeatureConfig qualified as FeatureConfig -import Wire.API.Event.Federation qualified as Federation -import Wire.API.Event.Team qualified as Teams -import Wire.API.Team.Member -import Wire.Arbitrary - -data PushEvent - = ConvEvent Event - | TeamEvent Teams.Event - | FeatureConfigEvent FeatureConfig.Event - | FederationEvent Federation.Event - -pushEventJson :: PushEvent -> Object -pushEventJson (ConvEvent e) = toJSONObject e -pushEventJson (TeamEvent e) = toJSONObject e -pushEventJson (FeatureConfigEvent e) = toJSONObject e -pushEventJson (FederationEvent e) = toJSONObject e - -data RecipientBy user = Recipient - { _recipientUserId :: user, - _recipientClients :: RecipientClients - } - deriving stock (Functor, Foldable, Traversable, Show, Ord, Eq, Generic) - deriving (Arbitrary) via GenericUniform (RecipientBy user) - -makeLenses ''RecipientBy - -type Recipient = RecipientBy UserId - -data PushTo user = Push - { _pushConn :: Maybe ConnId, - _pushTransient :: Bool, - _pushRoute :: Gundeck.Route, - _pushNativePriority :: Maybe Gundeck.Priority, - _pushAsync :: Bool, - pushOrigin :: Maybe UserId, - _pushRecipients :: List1 (RecipientBy user), - pushJson :: Object, - pushRecipientListType :: ListType - } - deriving stock (Eq, Generic, Functor, Foldable, Traversable, Show) - deriving (Arbitrary) via GenericUniform (PushTo user) - -makeLenses ''PushTo - -type Push = PushTo UserId - -push :: Foldable f => f Push -> App () -push ps = do - let pushes = foldMap (toList . mkPushTo) ps - traverse_ pushLocal (nonEmpty pushes) - where - mkPushTo :: PushTo a -> Maybe (PushTo a) - mkPushTo p = - nonEmpty (toList (_pushRecipients p)) <&> \nonEmptyRecipients -> - p {_pushRecipients = List1 nonEmptyRecipients} - --- | Split a list of pushes into chunks with the given maximum number of --- recipients. maxRecipients must be strictly positive. Note that the order of --- pushes within a chunk is reversed compared to the order of the input list. -chunkPushes :: Int -> [PushTo a] -> [[PushTo a]] -chunkPushes maxRecipients | maxRecipients <= 0 = error "maxRecipients must be positive" -chunkPushes maxRecipients = go 0 [] - where - go _ [] [] = [] - go _ acc [] = [acc] - go n acc (y : ys) - | n >= maxRecipients = acc : go 0 [] (y : ys) - | otherwise = - let totalLength = (n + length (_pushRecipients y)) - in if totalLength > maxRecipients - then - let (y1, y2) = splitPush (maxRecipients - n) y - in go maxRecipients (y1 : acc) (y2 : ys) - else go totalLength (y : acc) ys - - -- n must be strictly > 0 and < length (_pushRecipients p) - splitPush :: Int -> PushTo a -> (PushTo a, PushTo a) - splitPush n p = - let (r1, r2) = splitAt n (toList (_pushRecipients p)) - in (p {_pushRecipients = fromJust $ maybeList1 r1}, p {_pushRecipients = fromJust $ maybeList1 r2}) - --- | Asynchronously send multiple pushes, aggregating them into as --- few requests as possible, such that no single request targets --- more than 128 recipients. -pushLocal :: NonEmpty (PushTo UserId) -> App () -pushLocal ps = do - opts <- view options - let limit = currentFanoutLimit opts - -- Do not fan out for very large teams - let (asyncs, syncs) = partition _pushAsync (removeIfLargeFanout limit $ toList ps) - traverse_ (asyncCall Gundeck <=< jsonChunkedIO) (pushes asyncs) - mapConcurrently_ (call Gundeck <=< jsonChunkedIO) (pushes syncs) - where - pushes :: [PushTo UserId] -> [[Gundeck.Push]] - pushes = map (map (\p -> toPush p (recipientList p))) . chunkPushes 128 - - recipientList :: PushTo UserId -> [Gundeck.Recipient] - recipientList p = map (toRecipient p) . toList $ _pushRecipients p - - toPush :: PushTo user -> [Gundeck.Recipient] -> Gundeck.Push - toPush p r = - let pload = Gundeck.singletonPayload (pushJson p) - in Gundeck.newPush (pushOrigin p) (unsafeRange (Set.fromList r)) pload - & Gundeck.pushOriginConnection .~ _pushConn p - & Gundeck.pushTransient .~ _pushTransient p - & maybe id (set Gundeck.pushNativePriority) (_pushNativePriority p) - - toRecipient :: PushTo user -> RecipientBy UserId -> Gundeck.Recipient - toRecipient p r = - Gundeck.recipient (_recipientUserId r) (_pushRoute p) - & Gundeck.recipientClients .~ _recipientClients r - - -- Ensure that under no circumstances we exceed the threshold - removeIfLargeFanout :: Integral a => Range n m a -> [PushTo user] -> [PushTo user] - removeIfLargeFanout limit = - filter - ( \p -> - (pushRecipientListType p == ListComplete) - && (length (_pushRecipients p) <= fromIntegral (fromRange limit)) - ) - -recipient :: LocalMember -> Recipient -recipient = userRecipient . lmId - -userRecipient :: user -> RecipientBy user -userRecipient u = Recipient u RecipientClientsAll - -newPush1 :: ListType -> Maybe UserId -> PushEvent -> List1 Recipient -> Push -newPush1 recipientListType from e rr = - Push - { _pushConn = Nothing, - _pushTransient = False, - _pushRoute = Gundeck.RouteAny, - _pushNativePriority = Nothing, - _pushAsync = False, - pushRecipientListType = recipientListType, - pushJson = pushEventJson e, - pushOrigin = from, - _pushRecipients = rr - } - -newPushLocal1 :: ListType -> UserId -> PushEvent -> List1 Recipient -> Push -newPushLocal1 lt uid = newPush1 lt (Just uid) - -newPush :: ListType -> Maybe UserId -> PushEvent -> [Recipient] -> Maybe Push -newPush _ _ _ [] = Nothing -newPush t u e (r : rr) = Just $ newPush1 t u e (list1 r rr) - -newPushLocal :: ListType -> UserId -> PushEvent -> [Recipient] -> Maybe Push -newPushLocal lt uid = newPush lt (Just uid) - -newConversationEventPush :: Event -> Local [UserId] -> Maybe Push -newConversationEventPush e users = - let musr = guard (tDomain users == qDomain (evtFrom e)) $> qUnqualified (evtFrom e) - in newPush ListComplete musr (ConvEvent e) (map userRecipient (tUnqualified users)) - -pushSlowly :: Foldable f => f Push -> App () -pushSlowly ps = do - mmillis <- view (options . settings . deleteConvThrottleMillis) - let delay = 1000 * fromMaybe defDeleteConvThrottleMillis mmillis - forM_ ps $ \p -> do - push [p] - threadDelay delay diff --git a/services/galley/src/Galley/Options.hs b/services/galley/src/Galley/Options.hs index 30a10f4102e..499b85949e6 100644 --- a/services/galley/src/Galley/Options.hs +++ b/services/galley/src/Galley/Options.hs @@ -34,8 +34,6 @@ module Galley.Options mlsPrivateKeyPaths, featureFlags, defConcurrentDeletionEvents, - defDeleteConvThrottleMillis, - defFanoutLimit, JournalOpts (JournalOpts), queueName, endpoint, @@ -159,12 +157,6 @@ makeLenses ''Settings defConcurrentDeletionEvents :: Int defConcurrentDeletionEvents = 128 -defDeleteConvThrottleMillis :: Int -defDeleteConvThrottleMillis = 20 - -defFanoutLimit :: Range 1 HardTruncationLimit Int32 -defFanoutLimit = unsafeRange hardTruncationLimit - -- | Default guest link TTL in days. 365 days if not set. defGuestLinkTTLSeconds :: GuestLinkTTLSeconds defGuestLinkTTLSeconds = GuestLinkTTLSeconds $ 60 * 60 * 24 * 365 -- 1 year diff --git a/services/galley/test/unit/Run.hs b/services/galley/test/unit/Run.hs index 4f28468fadc..bcf3593c74c 100644 --- a/services/galley/test/unit/Run.hs +++ b/services/galley/test/unit/Run.hs @@ -24,7 +24,6 @@ import Imports import Test.Galley.API.Action qualified import Test.Galley.API.Message qualified import Test.Galley.API.One2One qualified -import Test.Galley.Intra.Push qualified import Test.Galley.Intra.User qualified import Test.Galley.Mapping qualified import Test.Tasty @@ -37,7 +36,6 @@ main = [ Test.Galley.API.Message.tests, Test.Galley.API.One2One.tests, Test.Galley.Intra.User.tests, - Test.Galley.Intra.Push.tests, Test.Galley.Mapping.tests, Test.Galley.API.Action.tests ] diff --git a/services/galley/test/unit/Test/Galley/Intra/Push.hs b/services/galley/test/unit/Test/Galley/Intra/Push.hs deleted file mode 100644 index daf35389e63..00000000000 --- a/services/galley/test/unit/Test/Galley/Intra/Push.hs +++ /dev/null @@ -1,50 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2023 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.Galley.Intra.Push where - -import Data.List1 qualified as List1 -import Data.Monoid -import Galley.Intra.Push.Internal -import Imports -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.QuickCheck - -normalisePush :: PushTo a -> [PushTo a] -normalisePush p = - map - (\r -> p {_pushRecipients = List1.singleton r}) - (toList (_pushRecipients p)) - -chunkSize :: [PushTo a] -> Int -chunkSize = getSum . foldMap (Sum . length . _pushRecipients) - -tests :: TestTree -tests = - testGroup - "chunkPushes" - [ testProperty "empty push" $ \(Positive limit) -> - chunkPushes limit [] === ([] :: [[PushTo ()]]), - testProperty "no empty chunk" $ \(Positive limit) (pushes :: [PushTo Int]) -> - not (any null (chunkPushes limit pushes)), - testProperty "concatenation" $ \(Positive limit) (pushes :: [PushTo Int]) -> - (chunkPushes limit pushes >>= reverse >>= normalisePush) - === (pushes >>= normalisePush), - testProperty "small chunks" $ \(Positive limit) (pushes :: [PushTo Int]) -> - all ((<= limit) . chunkSize) (chunkPushes limit pushes) - ]