From 3992d9a772209e66b6c57542425cc053e6924e64 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 18 Dec 2023 14:03:11 +0100 Subject: [PATCH 01/43] libs/wire-subsystems: Introduce --- cabal.project | 3 + libs/wire-subsystems/LICENSE | 661 ++++++++++++++++++ libs/wire-subsystems/default.nix | 11 + libs/wire-subsystems/src/Wire/Notification.hs | 1 + libs/wire-subsystems/wire-subsystems.cabal | 75 ++ nix/local-haskell-packages.nix | 1 + 6 files changed, 752 insertions(+) create mode 100644 libs/wire-subsystems/LICENSE create mode 100644 libs/wire-subsystems/default.nix create mode 100644 libs/wire-subsystems/src/Wire/Notification.hs create mode 100644 libs/wire-subsystems/wire-subsystems.cabal 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/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..df0128fe36b --- /dev/null +++ b/libs/wire-subsystems/default.nix @@ -0,0 +1,11 @@ +# 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, gitignoreSource, lib }: +mkDerivation { + pname = "wire-subsystems"; + version = "0.1.0"; + src = gitignoreSource ./.; + license = lib.licenses.agpl3Only; +} diff --git a/libs/wire-subsystems/src/Wire/Notification.hs b/libs/wire-subsystems/src/Wire/Notification.hs new file mode 100644 index 00000000000..d5e5bfbab2b --- /dev/null +++ b/libs/wire-subsystems/src/Wire/Notification.hs @@ -0,0 +1 @@ +module Wire.Notification where diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal new file mode 100644 index 00000000000..55d594e699a --- /dev/null +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -0,0 +1,75 @@ +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 + 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.Notification + hs-source-dirs: src + build-depends: + , base + , imports + + default-language: GHC2021 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; }; From 7240673431b321f42a8fe329424cc114333c927c Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 18 Dec 2023 15:27:55 +0100 Subject: [PATCH 02/43] WIP --- libs/wire-subsystems/src/Wire/Notification.hs | 93 +++++++++++++++++++ libs/wire-subsystems/wire-subsystems.cabal | 11 +++ .../galley/src/Galley/API/Teams/Features.hs | 2 + .../galley/src/Galley/Intra/Push/Internal.hs | 8 +- 4 files changed, 107 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/Notification.hs b/libs/wire-subsystems/src/Wire/Notification.hs index d5e5bfbab2b..9ebcda7fb5b 100644 --- a/libs/wire-subsystems/src/Wire/Notification.hs +++ b/libs/wire-subsystems/src/Wire/Notification.hs @@ -1 +1,94 @@ +{-# LANGUAGE TemplateHaskell #-} + module Wire.Notification where + +import Bilge as B +import Control.Lens +import Data.Aeson +import Data.Id +import Data.List.NonEmpty (NonEmpty) +import Data.Text.Encoding (encodeUtf8) +import Gundeck.Types hiding (Push) +import Gundeck.Types.Push.V2 qualified as V2 +import Imports +import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Types +import Polysemy +import Util.Options +import Wire.API.Team.Member +import Wire.Arbitrary + +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 = PushTo + { _pushConn :: Maybe ConnId, + _pushTransient :: Bool, + _pushRoute :: Route, + _pushNativePriority :: Maybe Priority, + _pushAsync :: Bool, + pushOrigin :: Maybe UserId, + _pushRecipients :: NonEmpty (RecipientBy user), + pushJson :: Object, + pushRecipientListType :: ListType + } + deriving stock (Eq, Generic, Functor, Foldable, Traversable, Show) + deriving (Arbitrary) via GenericUniform (PushTo user) + +makeLenses ''PushTo + +type PushToUser = PushTo UserId + +data NotificationSubsystem m a where + Push :: [PushToUser] -> NotificationSubsystem m () + PushSlowly :: [PushToUser] -> NotificationSubsystem m () + +makeSem ''NotificationSubsystem + +data GundeckAccessDetails = GundeckAccessDetails + { endpoint :: Endpoint, + httpManager :: HTTP.Manager + } + +data GundeckAPIAccess m a where + PushV2 :: [V2.Push] -> GundeckAPIAccess m () + +makeSem ''GundeckAPIAccess + +-- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. +runNotificationSubsystemGundeck :: Member (GundeckAPIAccess) r => Sem (NotificationSubsystem : r) a -> Sem r a +runNotificationSubsystemGundeck = interpret $ \case + Push _ -> + pushV2 [] + PushSlowly _ -> + pushV2 [] + +-- TODO: write a test which says all listed notification are sent +-- TODO: write a test which tests the chunking of notifications +-- TODO: write a test for listtype and maximum fanout limit thing +pushImpl :: Member (GundeckAPIAccess) r => [PushToUser] -> Sem r () +pushImpl _ = pushV2 [] + +-- TODO: Test manually if this even works. +runGundeckAPIAccess :: Member (Embed IO) r => GundeckAccessDetails -> Sem (GundeckAPIAccess : r) a -> Sem r a +runGundeckAPIAccess accessDetails = interpret $ \case + PushV2 pushes -> do + chunkedReq <- jsonChunkedIO pushes + let req = + B.host (encodeUtf8 accessDetails.endpoint._host) + . B.port accessDetails.endpoint._port + . path "/i/push/v2" + . expect2xx + . chunkedReq + B.runHttpT accessDetails.httpManager $ + -- Because of 'expect2xx' we don't actually need to check the response + void $ + B.post req diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 55d594e699a..852afaff5aa 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -69,7 +69,18 @@ library exposed-modules: Wire.Notification hs-source-dirs: src build-depends: + , aeson , base + , gundeck-types , imports + , lens + , QuickCheck + , types-common + , wire-api + , polysemy + , http-client + , bilge + , text + , http-types default-language: GHC2021 diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index f18b1fe6c59..9c8b836a461 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -189,6 +189,8 @@ persistAndPushEvent tid wsnl = do pushFeatureConfigEvent tid (Event.mkUpdateEvent fs) pure fs +-- TODO: This looks like a bug. These notifications are actually never sent. +-- If it is a bug we probably don't need the list type field in the PushTo type. pushFeatureConfigEvent :: ( Member GundeckAccess r, Member TeamStore r, diff --git a/services/galley/src/Galley/Intra/Push/Internal.hs b/services/galley/src/Galley/Intra/Push/Internal.hs index 4adcf716f73..bc5fa7db2f8 100644 --- a/services/galley/src/Galley/Intra/Push/Internal.hs +++ b/services/galley/src/Galley/Intra/Push/Internal.hs @@ -89,13 +89,7 @@ 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} + traverse_ pushLocal (nonEmpty $ toList ps) -- | Split a list of pushes into chunks with the given maximum number of -- recipients. maxRecipients must be strictly positive. Note that the order of From 31dbdb0468c46ca5fb97ceca82c8c07d264fcef8 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 19 Dec 2023 11:25:15 +0100 Subject: [PATCH 03/43] [wip] fill some more holes --- libs/wire-subsystems/src/Wire/Notification.hs | 111 ++++++++++++++++-- libs/wire-subsystems/test/Main.hs | 4 + libs/wire-subsystems/wire-subsystems.cabal | 14 +++ 3 files changed, 116 insertions(+), 13 deletions(-) create mode 100644 libs/wire-subsystems/test/Main.hs diff --git a/libs/wire-subsystems/src/Wire/Notification.hs b/libs/wire-subsystems/src/Wire/Notification.hs index 9ebcda7fb5b..5430b767e1c 100644 --- a/libs/wire-subsystems/src/Wire/Notification.hs +++ b/libs/wire-subsystems/src/Wire/Notification.hs @@ -6,17 +6,22 @@ import Bilge as B import Control.Lens import Data.Aeson import Data.Id -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.List1 (List1) +import Data.List1 qualified as List1 +import Data.Range (Range, fromRange, unsafeRange) +import Data.Set qualified as Set import Data.Text.Encoding (encodeUtf8) -import Gundeck.Types hiding (Push) +import Gundeck.Types hiding (Push (..)) import Gundeck.Types.Push.V2 qualified as V2 import Imports import Network.HTTP.Client qualified as HTTP -import Network.HTTP.Types +import Numeric.Natural (Natural) import Polysemy import Util.Options import Wire.API.Team.Member import Wire.Arbitrary +import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Safe), pooledMapConcurrentlyN_) data RecipientBy user = Recipient { _recipientUserId :: user, @@ -34,11 +39,13 @@ data PushTo user = PushTo _pushTransient :: Bool, _pushRoute :: Route, _pushNativePriority :: Maybe Priority, - _pushAsync :: Bool, + -- we never push asynchronounsly + -- _pushAsync :: Bool, pushOrigin :: Maybe UserId, _pushRecipients :: NonEmpty (RecipientBy user), - pushJson :: Object, - pushRecipientListType :: ListType + pushJson :: Object + -- we probably don't rely on the list type + -- pushRecipientListType :: ListType } deriving stock (Eq, Generic, Functor, Foldable, Traversable, Show) deriving (Arbitrary) via GenericUniform (PushTo user) @@ -64,18 +71,96 @@ data GundeckAPIAccess m a where makeSem ''GundeckAPIAccess -- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. -runNotificationSubsystemGundeck :: Member (GundeckAPIAccess) r => Sem (NotificationSubsystem : r) a -> Sem r a +runNotificationSubsystemGundeck :: + ( Member (GundeckAPIAccess) r, + Member (Concurrency 'Safe) r, + Member (Final IO) r + ) => + Sem (NotificationSubsystem : r) a -> + Sem r a runNotificationSubsystemGundeck = interpret $ \case - Push _ -> - pushV2 [] - PushSlowly _ -> - pushV2 [] + Push ps -> pushImpl ps + PushSlowly ps -> pushSlowlyImpl ps -- TODO: write a test which says all listed notification are sent -- TODO: write a test which tests the chunking of notifications -- TODO: write a test for listtype and maximum fanout limit thing -pushImpl :: Member (GundeckAPIAccess) r => [PushToUser] -> Sem r () -pushImpl _ = pushV2 [] +pushImpl :: + forall r. + ( Member (GundeckAPIAccess) r, + Member (Concurrency Safe) r, + Member (Final IO) r + ) => + [PushToUser] -> + Sem r () +pushImpl ps = do + -- TODO: where from do we get the configuration + let currentFanoutLimit :: Range 1 HardTruncationLimit Int32 = undefined + -- should probably be a type reflecting the number of capabilities + -- of the RTS + maxThreads :: Int = undefined + pushChunkSize :: Natural = 128 + + pushes :: [[V2.Push]] = + mkPushes pushChunkSize $ + removeIfLargeFanout currentFanoutLimit ps + + pooledMapConcurrentlyN_ maxThreads (undefined . pushV2 @r) pushes + +removeIfLargeFanout :: Range n m Int32 -> [PushTo user] -> [PushTo user] +removeIfLargeFanout limit = filter \PushTo {_pushRecipients} -> length _pushRecipients <= fromIntegral (fromRange limit) + +mkPushes :: Natural -> [PushToUser] -> [[V2.Push]] +mkPushes chunkSize = map (map fromV2Push) . chunkPushes chunkSize + +{-# INLINE fromV2Push #-} +fromV2Push :: PushToUser -> V2.Push +fromV2Push p = + (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 :: RecipientBy UserId -> V2.Recipient + toRecipient r = + (recipient r._recipientUserId p._pushRoute) + { V2._recipientClients = r._recipientClients + } + +{-# INLINE chunkPushes #-} +chunkPushes :: Natural -> [PushTo a] -> [[PushTo a]] +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 + 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 -> PushTo a -> (PushTo a, PushTo a) + 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 GundeckAPIAccess r, + Member (Concurrency 'Safe) r, + Member (Final IO) r + ) => + [PushToUser] -> + Sem r () +pushSlowlyImpl _ = pushImpl [] -- TODO: Test manually if this even works. runGundeckAPIAccess :: Member (Embed IO) r => GundeckAccessDetails -> Sem (GundeckAPIAccess : r) a -> Sem r a diff --git a/libs/wire-subsystems/test/Main.hs b/libs/wire-subsystems/test/Main.hs new file mode 100644 index 00000000000..f1109b59458 --- /dev/null +++ b/libs/wire-subsystems/test/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "not implemented" diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 852afaff5aa..bc9b73064da 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -20,6 +20,7 @@ common common-all default-extensions: AllowAmbiguousTypes BangPatterns + BlockArguments ConstraintKinds DataKinds DefaultSignatures @@ -71,6 +72,7 @@ library build-depends: , aeson , base + , containers , gundeck-types , imports , lens @@ -78,9 +80,21 @@ library , types-common , wire-api , polysemy + , polysemy-wire-zoo , http-client , bilge , text , http-types default-language: GHC2021 + +test-suite wire-subsystems-tests + import: common-all + type: exitcode-stdio-1.0 + main-is: Main.hs + + other-modules: + hs-source-dirs: test + build-depends: + , wire-subsystems + , base From bb2263f17c606799dd982cfb176d73f7aa6a0106 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 19 Dec 2023 15:55:52 +0100 Subject: [PATCH 04/43] [feat] first tests for Notification subsystem - port notification chunking tests - test maximum fanout limit respected - check that all notifications are sent --- libs/types-common/src/Data/Range.hs | 3 + libs/wire-subsystems/src/Wire/Notification.hs | 6 +- libs/wire-subsystems/test/Main.hs | 7 +- .../test/Test/Wire/Notification.hs | 65 +++++++++++++++++++ libs/wire-subsystems/wire-subsystems.cabal | 15 ++++- .../test/unit/Test/Galley/Intra/Push.hs | 50 -------------- 6 files changed, 92 insertions(+), 54 deletions(-) create mode 100644 libs/wire-subsystems/test/Test/Wire/Notification.hs delete mode 100644 services/galley/test/unit/Test/Galley/Intra/Push.hs 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/src/Wire/Notification.hs b/libs/wire-subsystems/src/Wire/Notification.hs index 5430b767e1c..14304f94ade 100644 --- a/libs/wire-subsystems/src/Wire/Notification.hs +++ b/libs/wire-subsystems/src/Wire/Notification.hs @@ -47,7 +47,7 @@ data PushTo user = PushTo -- we probably don't rely on the list type -- pushRecipientListType :: ListType } - deriving stock (Eq, Generic, Functor, Foldable, Traversable, Show) + deriving stock (Eq, Ord, Generic, Functor, Foldable, Traversable, Show) deriving (Arbitrary) via GenericUniform (PushTo user) makeLenses ''PushTo @@ -133,7 +133,9 @@ fromV2Push p = {-# INLINE chunkPushes #-} chunkPushes :: Natural -> [PushTo a] -> [[PushTo a]] -chunkPushes maxRecipients = go 0 [] +chunkPushes maxRecipients + | maxRecipients > 0 = go 0 [] + | otherwise = const [] where go _ [] [] = [] go _ acc [] = [acc] diff --git a/libs/wire-subsystems/test/Main.hs b/libs/wire-subsystems/test/Main.hs index f1109b59458..03eddfc02b7 100644 --- a/libs/wire-subsystems/test/Main.hs +++ b/libs/wire-subsystems/test/Main.hs @@ -1,4 +1,9 @@ module Main where +import Imports +import Test.Hspec +import Test.Wire.Notification qualified as Notification + main :: IO () -main = putStrLn "not implemented" +main = hspec do + Notification.spec diff --git a/libs/wire-subsystems/test/Test/Wire/Notification.hs b/libs/wire-subsystems/test/Test/Wire/Notification.hs new file mode 100644 index 00000000000..3a64ed17cb0 --- /dev/null +++ b/libs/wire-subsystems/test/Test/Wire/Notification.hs @@ -0,0 +1,65 @@ +module Test.Wire.Notification (spec) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Range (Range, fromRange) +import Gundeck.Types.Push.V2 qualified as V2 +import Imports +import Numeric.Natural (Natural) +import Polysemy +import Polysemy.Writer (Writer, runWriter, tell) +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Wire.API.Team.Member (HardTruncationLimit) +import Wire.Notification (GundeckAPIAccess (PushV2), PushTo (..), PushToUser, chunkPushes, pushImpl, removeIfLargeFanout, _pushRecipients) +import Wire.Sem.Concurrency.IO (performConcurrency) +import Data.Containers.ListUtils (nubOrdOn) + +spec :: Spec +spec = describe "notification subsystem behaves correctly" do + it "sends all notifications" allNotificationsSent + it "respects maximum fanout limit" maximumFanoutlimitRespected + describe "chunks notficiations correctly" notificationsCorrectlyChunked + +runGundeckAPIAccessMock :: Member (Writer [V2.Push]) r => Sem (GundeckAPIAccess : r) a -> Sem r a +runGundeckAPIAccessMock = interpret \case + PushV2 pushes -> tell pushes + +allNotificationsSent :: Expectation +allNotificationsSent = do + pushes :: [PushToUser] <- generate (arbitrary `suchThat` \l -> nubOrdOn pushJson l == l) + + mockPushes :: ([V2.Push], ()) <- + runFinal + . performConcurrency + . runWriter + . runGundeckAPIAccessMock + $ pushImpl pushes + print mockPushes + length (nubOrdOn V2._pushPayload (fst mockPushes)) `shouldBe` length pushes + +-- TODO: this doesn't really make sense; it is similar to the actual implementation and is basically testing filter +maximumFanoutlimitRespected :: Property +maximumFanoutlimitRespected = property \(range :: Range 1 HardTruncationLimit Int32) (pushes :: [PushTo Int]) -> + all (\PushTo {_pushRecipients} -> length _pushRecipients <= fromIntegral (fromRange range)) (removeIfLargeFanout range pushes) + +normalisePush :: PushTo a -> [PushTo a] +normalisePush p = + map + (\r -> p {_pushRecipients = r :| []}) + (toList (_pushRecipients p)) + +chunkSize :: [PushTo a] -> Natural +chunkSize = getSum . foldMap (Sum . fromIntegral . length . _pushRecipients) + +notificationsCorrectlyChunked :: Spec +notificationsCorrectlyChunked = do + it "allows empty push" $ property \limit -> + chunkPushes limit [] === ([] :: [[PushTo ()]]) + it "produces no empty chunks" $ property \limit (pushes :: [PushTo Int]) -> + not (any null (chunkPushes limit pushes)) + it "allows concatenation if number was non-zero" $ property \(Positive limit) (pushes :: [PushTo Int]) -> + (chunkPushes limit pushes >>= reverse >>= normalisePush) + === (pushes >>= normalisePush) + it "respects the chunkSize limit" $ property \limit (pushes :: [PushTo Int]) -> + all ((<= limit) . chunkSize) (chunkPushes limit pushes) diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index bc9b73064da..13805e6a0df 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -92,9 +92,22 @@ test-suite wire-subsystems-tests import: common-all type: exitcode-stdio-1.0 main-is: Main.hs + default-language: GHC2021 - other-modules: + other-modules: Test.Wire.Notification hs-source-dirs: test build-depends: , wire-subsystems , base + , bytestring + , aeson + , containers + , imports + , hspec + , QuickCheck + , quickcheck-instances + , wire-api + , types-common + , polysemy + , polysemy-wire-zoo + , gundeck-types 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) - ] From 52027f299ed30d5c18faa61ac4b57f6e571169fb Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 19 Dec 2023 16:48:14 +0100 Subject: [PATCH 05/43] [fix] fix interpretation into async --- libs/wire-subsystems/src/Wire/Notification.hs | 31 +++++++++++-------- .../test/Test/Wire/Notification.hs | 23 +++++++------- 2 files changed, 30 insertions(+), 24 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/Notification.hs b/libs/wire-subsystems/src/Wire/Notification.hs index 14304f94ade..7ffe82161f5 100644 --- a/libs/wire-subsystems/src/Wire/Notification.hs +++ b/libs/wire-subsystems/src/Wire/Notification.hs @@ -9,19 +9,21 @@ import Data.Id import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.List1 (List1) import Data.List1 qualified as List1 -import Data.Range (Range, fromRange, unsafeRange) +import Data.Proxy (Proxy (..)) +import Data.Range (Range, fromRange, toRange, unsafeRange) import Data.Set qualified as Set import Data.Text.Encoding (encodeUtf8) +import Debug.Trace import Gundeck.Types hiding (Push (..)) import Gundeck.Types.Push.V2 qualified as V2 import Imports import Network.HTTP.Client qualified as HTTP import Numeric.Natural (Natural) import Polysemy +import Polysemy.Async (Async, sequenceConcurrently) import Util.Options import Wire.API.Team.Member import Wire.Arbitrary -import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Safe), pooledMapConcurrentlyN_) data RecipientBy user = Recipient { _recipientUserId :: user, @@ -73,8 +75,7 @@ makeSem ''GundeckAPIAccess -- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. runNotificationSubsystemGundeck :: ( Member (GundeckAPIAccess) r, - Member (Concurrency 'Safe) r, - Member (Final IO) r + Member Async r ) => Sem (NotificationSubsystem : r) a -> Sem r a @@ -88,24 +89,29 @@ runNotificationSubsystemGundeck = interpret $ \case pushImpl :: forall r. ( Member (GundeckAPIAccess) r, - Member (Concurrency Safe) r, - Member (Final IO) r + Member (Async) r ) => [PushToUser] -> Sem r () pushImpl ps = do -- TODO: where from do we get the configuration - let currentFanoutLimit :: Range 1 HardTruncationLimit Int32 = undefined - -- should probably be a type reflecting the number of capabilities - -- of the RTS - maxThreads :: Int = undefined + let currentFanoutLimit :: Range 1 HardTruncationLimit Int32 = toRange (Proxy @16) -- undefined pushChunkSize :: Natural = 128 pushes :: [[V2.Push]] = mkPushes pushChunkSize $ removeIfLargeFanout currentFanoutLimit ps - pooledMapConcurrentlyN_ maxThreads (undefined . pushV2 @r) pushes + traceShowM pushes + + void $ + sequenceConcurrently $ + pushV2 <$> pushes + +-- TODO: something about this is odd; we cannot really interpret anything that +-- is asynchronounsly run; everything would have to be in IO having to provide an +-- interpreter for the effect; Async seems so much easier; almost too easy +-- pooledMapConcurrentlyN_ maxThreads (_ . pushV2 @r) pushes removeIfLargeFanout :: Range n m Int32 -> [PushTo user] -> [PushTo user] removeIfLargeFanout limit = filter \PushTo {_pushRecipients} -> length _pushRecipients <= fromIntegral (fromRange limit) @@ -157,8 +163,7 @@ chunkPushes maxRecipients pushSlowlyImpl :: ( Member GundeckAPIAccess r, - Member (Concurrency 'Safe) r, - Member (Final IO) r + Member Async r ) => [PushToUser] -> Sem r () diff --git a/libs/wire-subsystems/test/Test/Wire/Notification.hs b/libs/wire-subsystems/test/Test/Wire/Notification.hs index 3a64ed17cb0..a912bd42afe 100644 --- a/libs/wire-subsystems/test/Test/Wire/Notification.hs +++ b/libs/wire-subsystems/test/Test/Wire/Notification.hs @@ -1,19 +1,19 @@ module Test.Wire.Notification (spec) where +import Data.Containers.ListUtils (nubOrdOn) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Range (Range, fromRange) import Gundeck.Types.Push.V2 qualified as V2 import Imports import Numeric.Natural (Natural) import Polysemy -import Polysemy.Writer (Writer, runWriter, tell) +import Polysemy.Async (asyncToIOFinal) +import Polysemy.Writer (Writer, tell, writerToIOFinal) import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Instances () import Wire.API.Team.Member (HardTruncationLimit) import Wire.Notification (GundeckAPIAccess (PushV2), PushTo (..), PushToUser, chunkPushes, pushImpl, removeIfLargeFanout, _pushRecipients) -import Wire.Sem.Concurrency.IO (performConcurrency) -import Data.Containers.ListUtils (nubOrdOn) spec :: Spec spec = describe "notification subsystem behaves correctly" do @@ -29,14 +29,15 @@ allNotificationsSent :: Expectation allNotificationsSent = do pushes :: [PushToUser] <- generate (arbitrary `suchThat` \l -> nubOrdOn pushJson l == l) - mockPushes :: ([V2.Push], ()) <- - runFinal - . performConcurrency - . runWriter - . runGundeckAPIAccessMock - $ pushImpl pushes - print mockPushes - length (nubOrdOn V2._pushPayload (fst mockPushes)) `shouldBe` length pushes + mockPushes :: [V2.Push] <- + fst <$> do + runFinal + . asyncToIOFinal + . writerToIOFinal + . runGundeckAPIAccessMock + $ pushImpl pushes + + length (nubOrdOn V2._pushPayload mockPushes) `shouldBe` length pushes -- TODO: this doesn't really make sense; it is similar to the actual implementation and is basically testing filter maximumFanoutlimitRespected :: Property From f835c1b0fb71068992b071ebb004608fc0bcb1e3 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 19 Dec 2023 17:49:27 +0100 Subject: [PATCH 06/43] [fix] proper property test --- libs/wire-subsystems/src/Wire/Notification.hs | 14 +++---- .../test/Test/Wire/Notification.hs | 40 +++++++++++++------ 2 files changed, 33 insertions(+), 21 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/Notification.hs b/libs/wire-subsystems/src/Wire/Notification.hs index 7ffe82161f5..4f82b8a7d47 100644 --- a/libs/wire-subsystems/src/Wire/Notification.hs +++ b/libs/wire-subsystems/src/Wire/Notification.hs @@ -13,7 +13,6 @@ import Data.Proxy (Proxy (..)) import Data.Range (Range, fromRange, toRange, unsafeRange) import Data.Set qualified as Set import Data.Text.Encoding (encodeUtf8) -import Debug.Trace import Gundeck.Types hiding (Push (..)) import Gundeck.Types.Push.V2 qualified as V2 import Imports @@ -83,9 +82,7 @@ runNotificationSubsystemGundeck = interpret $ \case Push ps -> pushImpl ps PushSlowly ps -> pushSlowlyImpl ps --- TODO: write a test which says all listed notification are sent --- TODO: write a test which tests the chunking of notifications --- TODO: write a test for listtype and maximum fanout limit thing +-- TODO: write a test for listtype pushImpl :: forall r. ( Member (GundeckAPIAccess) r, @@ -95,15 +92,12 @@ pushImpl :: Sem r () pushImpl ps = do -- TODO: where from do we get the configuration - let currentFanoutLimit :: Range 1 HardTruncationLimit Int32 = toRange (Proxy @16) -- undefined + let currentFanoutLimit :: Range 1 HardTruncationLimit Int32 = toRange (Proxy @16) pushChunkSize :: Natural = 128 pushes :: [[V2.Push]] = mkPushes pushChunkSize $ removeIfLargeFanout currentFanoutLimit ps - - traceShowM pushes - void $ sequenceConcurrently $ pushV2 <$> pushes @@ -167,7 +161,9 @@ pushSlowlyImpl :: ) => [PushToUser] -> Sem r () -pushSlowlyImpl _ = pushImpl [] +pushSlowlyImpl ps = do + -- mmillis <- view + pushImpl ps -- TODO: Test manually if this even works. runGundeckAPIAccess :: Member (Embed IO) r => GundeckAccessDetails -> Sem (GundeckAPIAccess : r) a -> Sem r a diff --git a/libs/wire-subsystems/test/Test/Wire/Notification.hs b/libs/wire-subsystems/test/Test/Wire/Notification.hs index a912bd42afe..f0f3777329a 100644 --- a/libs/wire-subsystems/test/Test/Wire/Notification.hs +++ b/libs/wire-subsystems/test/Test/Wire/Notification.hs @@ -8,12 +8,14 @@ import Imports import Numeric.Natural (Natural) import Polysemy import Polysemy.Async (asyncToIOFinal) -import Polysemy.Writer (Writer, tell, writerToIOFinal) +import Polysemy.Writer (tell, writerToIOFinal) import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Instances () +import Test.QuickCheck.Monadic (assertWith, monadicIO, pre) +import Test.QuickCheck.Monadic qualified as QC import Wire.API.Team.Member (HardTruncationLimit) -import Wire.Notification (GundeckAPIAccess (PushV2), PushTo (..), PushToUser, chunkPushes, pushImpl, removeIfLargeFanout, _pushRecipients) +import Wire.Notification (GundeckAPIAccess (PushV2), PushTo (..), chunkPushes, pushImpl, removeIfLargeFanout, _pushRecipients) spec :: Spec spec = describe "notification subsystem behaves correctly" do @@ -21,23 +23,37 @@ spec = describe "notification subsystem behaves correctly" do it "respects maximum fanout limit" maximumFanoutlimitRespected describe "chunks notficiations correctly" notificationsCorrectlyChunked -runGundeckAPIAccessMock :: Member (Writer [V2.Push]) r => Sem (GundeckAPIAccess : r) a -> Sem r a -runGundeckAPIAccessMock = interpret \case - PushV2 pushes -> tell pushes +runGundeckAPIAccessMock :: Member (Final IO) r => Sem (GundeckAPIAccess : r) a -> Sem r [V2.Push] +runGundeckAPIAccessMock = + fmap fst . writerToIOFinal . reinterpret \case + PushV2 pushes -> tell pushes -allNotificationsSent :: Expectation -allNotificationsSent = do - pushes :: [PushToUser] <- generate (arbitrary `suchThat` \l -> nubOrdOn pushJson l == l) +allNotificationsSent :: Property +allNotificationsSent = property \(NonEmpty pushes) -> monadicIO do + pre (nubOrdOn pushJson pushes == pushes) + pre (nubOrdOn id pushes == pushes) + -- FIXME: the 16 should be reflecting the actual fanout limit + pre (all (\p -> length p._pushRecipients <= 16) pushes) - mockPushes :: [V2.Push] <- - fst <$> do + mockPushes <- + nubOrdOn V2._pushPayload <$> QC.run do runFinal . asyncToIOFinal - . writerToIOFinal . runGundeckAPIAccessMock $ pushImpl pushes - length (nubOrdOn V2._pushPayload mockPushes) `shouldBe` length pushes + let c = + unlines + [ "Expected:", + show pushes, + "\nwith length:", + show (length pushes), + "\nBut got:", + show mockPushes, + "\nwith length:", + show (length mockPushes) + ] + assertWith (length pushes == length mockPushes) c -- TODO: this doesn't really make sense; it is similar to the actual implementation and is basically testing filter maximumFanoutlimitRespected :: Property From 5e02be7bfdb48ea15831f34d421a6d546089c787 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 19 Dec 2023 18:30:50 +0100 Subject: [PATCH 07/43] [feat] implement pushSlowly - implement pushSlowImpl - move Delay to polysemy-wire-zoo --- .../polysemy-wire-zoo/polysemy-wire-zoo.cabal | 2 + .../polysemy-wire-zoo/src/Wire/Sem}/Delay.hs | 2 +- libs/wire-subsystems/src/Wire/Notification.hs | 15 ++++++-- libs/wire-subsystems/wire-subsystems.cabal | 37 +++++++++---------- services/brig/brig.cabal | 1 - services/brig/src/Brig/Calling.hs | 2 +- .../brig/test/unit/Test/Brig/Effects/Delay.hs | 2 +- 7 files changed, 34 insertions(+), 27 deletions(-) rename {services/brig/src/Brig/Effects => libs/polysemy-wire-zoo/src/Wire/Sem}/Delay.hs (88%) diff --git a/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal b/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal index 5e346eb0ea2..aee7d7ef1ce 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 @@ -108,6 +109,7 @@ test-suite spec main-is: Spec.hs other-modules: Paths_polysemy_wire_zoo + Test.DelaySpec Test.IntersperseSpec hs-source-dirs: test diff --git a/services/brig/src/Brig/Effects/Delay.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs similarity index 88% rename from services/brig/src/Brig/Effects/Delay.hs rename to libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs index 8a3b9dc6e91..86e90e6b189 100644 --- a/services/brig/src/Brig/Effects/Delay.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} -module Brig.Effects.Delay where +module Wire.Sem.Delay where import Imports import Polysemy diff --git a/libs/wire-subsystems/src/Wire/Notification.hs b/libs/wire-subsystems/src/Wire/Notification.hs index 4f82b8a7d47..8c43aef8fd2 100644 --- a/libs/wire-subsystems/src/Wire/Notification.hs +++ b/libs/wire-subsystems/src/Wire/Notification.hs @@ -23,6 +23,7 @@ import Polysemy.Async (Async, sequenceConcurrently) import Util.Options import Wire.API.Team.Member import Wire.Arbitrary +import Wire.Sem.Delay (Delay, delay) data RecipientBy user = Recipient { _recipientUserId :: user, @@ -74,7 +75,8 @@ makeSem ''GundeckAPIAccess -- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. runNotificationSubsystemGundeck :: ( Member (GundeckAPIAccess) r, - Member Async r + Member Async r, + Member Delay r ) => Sem (NotificationSubsystem : r) a -> Sem r a @@ -157,13 +159,18 @@ chunkPushes maxRecipients pushSlowlyImpl :: ( Member GundeckAPIAccess r, - Member Async r + Member Async r, + Member Delay r ) => [PushToUser] -> Sem r () pushSlowlyImpl ps = do - -- mmillis <- view - pushImpl ps + -- TODO this comes from the Reader TM + let mmillies = 10000 + d = 1000 * mmillies + for_ ps \p -> do + delay d + pushImpl [p] -- TODO: Test manually if this even works. runGundeckAPIAccess :: Member (Embed IO) r => GundeckAccessDetails -> Sem (GundeckAPIAccess : r) a -> Sem r a diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 13805e6a0df..2d9f7e8b4dc 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -72,42 +72,41 @@ library build-depends: , aeson , base + , bilge , containers , gundeck-types + , http-client + , http-types , imports , lens - , QuickCheck - , types-common - , wire-api , polysemy , polysemy-wire-zoo - , http-client - , bilge + , QuickCheck , text - , http-types + , types-common + , wire-api default-language: GHC2021 test-suite wire-subsystems-tests - import: common-all - type: exitcode-stdio-1.0 - main-is: Main.hs + import: common-all + type: exitcode-stdio-1.0 + main-is: Main.hs default-language: GHC2021 - - other-modules: Test.Wire.Notification - hs-source-dirs: test + other-modules: Test.Wire.Notification + hs-source-dirs: test build-depends: - , wire-subsystems + , aeson , base , bytestring - , aeson , containers - , imports + , gundeck-types , hspec + , imports + , polysemy + , polysemy-wire-zoo , QuickCheck , quickcheck-instances - , wire-api , types-common - , polysemy - , polysemy-wire-zoo - , gundeck-types + , wire-api + , wire-subsystems diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 0d0487355ef..ba1a112efef 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 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/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 From 039f53f06adff8e1e5f69bb8db54f0329ef85de2 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Wed, 20 Dec 2023 12:28:38 +0100 Subject: [PATCH 08/43] [chore] more testing --- .../src/Gundeck/Types/Push/V2.hs | 10 ++-- libs/wire-subsystems/src/Wire/Notification.hs | 27 +++++----- .../test/Test/Wire/Notification.hs | 54 ++++++++++++------- 3 files changed, 53 insertions(+), 38 deletions(-) diff --git a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs index f38723fe9e8..53b2f2f94d1 100644 --- a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs +++ b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs @@ -171,14 +171,14 @@ instance ToJSON RecipientClients where -- ApsData newtype ApsSound = ApsSound {fromSound :: Text} - deriving (Eq, Show, ToJSON, FromJSON) + deriving (Eq, Ord, Show, ToJSON, FromJSON) newtype ApsLocKey = ApsLocKey {fromLocKey :: Text} - deriving (Eq, Show, ToJSON, FromJSON) + deriving (Eq, Ord, Show, ToJSON, FromJSON) data ApsPreference = ApsStdPreference - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance ToJSON ApsPreference where toJSON ApsStdPreference = "std" @@ -195,7 +195,7 @@ data ApsData = ApsData _apsPreference :: !(Maybe ApsPreference), _apsBadge :: !Bool } - deriving (Eq, Show) + deriving (Eq, Ord, Show) makeLenses ''ApsData @@ -263,7 +263,7 @@ data Push = Push -- | Opaque payload _pushPayload :: !(List1 Object) } - deriving (Eq, Show) + deriving (Eq, Ord, Show) makeLenses ''Push diff --git a/libs/wire-subsystems/src/Wire/Notification.hs b/libs/wire-subsystems/src/Wire/Notification.hs index 8c43aef8fd2..5222ad5b812 100644 --- a/libs/wire-subsystems/src/Wire/Notification.hs +++ b/libs/wire-subsystems/src/Wire/Notification.hs @@ -58,7 +58,6 @@ type PushToUser = PushTo UserId data NotificationSubsystem m a where Push :: [PushToUser] -> NotificationSubsystem m () - PushSlowly :: [PushToUser] -> NotificationSubsystem m () makeSem ''NotificationSubsystem @@ -75,14 +74,12 @@ makeSem ''GundeckAPIAccess -- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. runNotificationSubsystemGundeck :: ( Member (GundeckAPIAccess) r, - Member Async r, - Member Delay r + Member Async r ) => Sem (NotificationSubsystem : r) a -> Sem r a runNotificationSubsystemGundeck = interpret $ \case Push ps -> pushImpl ps - PushSlowly ps -> pushSlowlyImpl ps -- TODO: write a test for listtype pushImpl :: @@ -113,11 +110,11 @@ removeIfLargeFanout :: Range n m Int32 -> [PushTo user] -> [PushTo user] removeIfLargeFanout limit = filter \PushTo {_pushRecipients} -> length _pushRecipients <= fromIntegral (fromRange limit) mkPushes :: Natural -> [PushToUser] -> [[V2.Push]] -mkPushes chunkSize = map (map fromV2Push) . chunkPushes chunkSize +mkPushes chunkSize = map (map toV2Push) . chunkPushes chunkSize -{-# INLINE fromV2Push #-} -fromV2Push :: PushToUser -> V2.Push -fromV2Push p = +{-# INLINE [1] toV2Push #-} +toV2Push :: PushToUser -> V2.Push +toV2Push p = (newPush p.pushOrigin (unsafeRange (Set.fromList recipients)) pload) & V2.pushOriginConnection .~ _pushConn p & V2.pushTransient .~ _pushTransient p @@ -133,7 +130,7 @@ fromV2Push p = { V2._recipientClients = r._recipientClients } -{-# INLINE chunkPushes #-} +{-# INLINE [1] chunkPushes #-} chunkPushes :: Natural -> [PushTo a] -> [[PushTo a]] chunkPushes maxRecipients | maxRecipients > 0 = go 0 [] @@ -157,20 +154,20 @@ chunkPushes maxRecipients let (r1, r2) = splitAt (fromIntegral n) (toList p._pushRecipients) in (p {_pushRecipients = fromJust $ nonEmpty r1}, p {_pushRecipients = fromJust $ nonEmpty r2}) -pushSlowlyImpl :: - ( Member GundeckAPIAccess r, - Member Async r, +-- TODO: Test +pushSlowly :: + ( Member NotificationSubsystem r, Member Delay r ) => [PushToUser] -> Sem r () -pushSlowlyImpl ps = do - -- TODO this comes from the Reader TM +pushSlowly ps = do + -- TODO this comes from the app configuration let mmillies = 10000 d = 1000 * mmillies for_ ps \p -> do delay d - pushImpl [p] + push [p] -- TODO: Test manually if this even works. runGundeckAPIAccess :: Member (Embed IO) r => GundeckAccessDetails -> Sem (GundeckAPIAccess : r) a -> Sem r a diff --git a/libs/wire-subsystems/test/Test/Wire/Notification.hs b/libs/wire-subsystems/test/Test/Wire/Notification.hs index f0f3777329a..fb38ae20a2e 100644 --- a/libs/wire-subsystems/test/Test/Wire/Notification.hs +++ b/libs/wire-subsystems/test/Test/Wire/Notification.hs @@ -2,7 +2,9 @@ module Test.Wire.Notification (spec) where import Data.Containers.ListUtils (nubOrdOn) import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List1 qualified as List1 import Data.Range (Range, fromRange) +import Data.Set qualified as Set import Gundeck.Types.Push.V2 qualified as V2 import Imports import Numeric.Natural (Natural) @@ -14,14 +16,42 @@ import Test.QuickCheck import Test.QuickCheck.Instances () import Test.QuickCheck.Monadic (assertWith, monadicIO, pre) import Test.QuickCheck.Monadic qualified as QC -import Wire.API.Team.Member (HardTruncationLimit) -import Wire.Notification (GundeckAPIAccess (PushV2), PushTo (..), chunkPushes, pushImpl, removeIfLargeFanout, _pushRecipients) +import Wire.API.Team.Member +import Wire.Notification spec :: Spec -spec = describe "notification subsystem behaves correctly" do - it "sends all notifications" allNotificationsSent - it "respects maximum fanout limit" maximumFanoutlimitRespected - describe "chunks notficiations correctly" notificationsCorrectlyChunked +spec = describe "NotificationSubsystem" do + describe "pushImpl" do + it "sends all notifications" allNotificationsSent + it "respects maximum fanout limit" maximumFanoutlimitRespected + describe "toV2Push" do + it "does the transformation correctly" $ property \(pushToUser :: PushToUser) -> + 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 [] === ([] :: [[PushTo ()]]) + it "produces no empty chunks" $ property \limit (pushes :: [PushTo Int]) -> + not (any null (chunkPushes limit pushes)) + it "allows concatenation if number was non-zero" $ property \(Positive limit) (pushes :: [PushTo Int]) -> + (chunkPushes limit pushes >>= reverse >>= normalisePush) + === (pushes >>= normalisePush) + it "respects the chunkSize limit" $ property \limit (pushes :: [PushTo Int]) -> + all ((<= limit) . chunkSize) (chunkPushes limit pushes) runGundeckAPIAccessMock :: Member (Final IO) r => Sem (GundeckAPIAccess : r) a -> Sem r [V2.Push] runGundeckAPIAccessMock = @@ -68,15 +98,3 @@ normalisePush p = chunkSize :: [PushTo a] -> Natural chunkSize = getSum . foldMap (Sum . fromIntegral . length . _pushRecipients) - -notificationsCorrectlyChunked :: Spec -notificationsCorrectlyChunked = do - it "allows empty push" $ property \limit -> - chunkPushes limit [] === ([] :: [[PushTo ()]]) - it "produces no empty chunks" $ property \limit (pushes :: [PushTo Int]) -> - not (any null (chunkPushes limit pushes)) - it "allows concatenation if number was non-zero" $ property \(Positive limit) (pushes :: [PushTo Int]) -> - (chunkPushes limit pushes >>= reverse >>= normalisePush) - === (pushes >>= normalisePush) - it "respects the chunkSize limit" $ property \limit (pushes :: [PushTo Int]) -> - all ((<= limit) . chunkSize) (chunkPushes limit pushes) From 7d6dc856931d079fae74a26b4212737636fde5fa Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Wed, 20 Dec 2023 16:49:18 +0100 Subject: [PATCH 09/43] [chore] Add more tests for NotificationSubsystem --- libs/wire-subsystems/src/Wire/Notification.hs | 25 +-- .../test/Test/Wire/Notification.hs | 171 +++++++++++++----- 2 files changed, 139 insertions(+), 57 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/Notification.hs b/libs/wire-subsystems/src/Wire/Notification.hs index 5222ad5b812..111e5db4159 100644 --- a/libs/wire-subsystems/src/Wire/Notification.hs +++ b/libs/wire-subsystems/src/Wire/Notification.hs @@ -9,8 +9,7 @@ import Data.Id import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.List1 (List1) import Data.List1 qualified as List1 -import Data.Proxy (Proxy (..)) -import Data.Range (Range, fromRange, toRange, unsafeRange) +import Data.Range (Range, fromRange, unsafeRange) import Data.Set qualified as Set import Data.Text.Encoding (encodeUtf8) import Gundeck.Types hiding (Push (..)) @@ -20,6 +19,7 @@ import Network.HTTP.Client qualified as HTTP import Numeric.Natural (Natural) import Polysemy import Polysemy.Async (Async, sequenceConcurrently) +import Polysemy.Input import Util.Options import Wire.API.Team.Member import Wire.Arbitrary @@ -74,38 +74,39 @@ makeSem ''GundeckAPIAccess -- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. runNotificationSubsystemGundeck :: ( Member (GundeckAPIAccess) r, - Member Async r + Member Async r, + Member (Input NotificationSubsystemConfig) r ) => Sem (NotificationSubsystem : r) a -> Sem r a runNotificationSubsystemGundeck = interpret $ \case Push ps -> pushImpl ps +data NotificationSubsystemConfig = NotificationSubsystemConfig + { fanoutLimit :: Range 1 HardTruncationLimit Int32, + chunkSize :: Natural + } + -- TODO: write a test for listtype pushImpl :: forall r. ( Member (GundeckAPIAccess) r, + Member (Input NotificationSubsystemConfig) r, Member (Async) r ) => [PushToUser] -> Sem r () pushImpl ps = do - -- TODO: where from do we get the configuration - let currentFanoutLimit :: Range 1 HardTruncationLimit Int32 = toRange (Proxy @16) - pushChunkSize :: Natural = 128 + currentFanoutLimit <- inputs fanoutLimit + pushChunkSize <- inputs chunkSize - pushes :: [[V2.Push]] = + let pushes :: [[V2.Push]] = mkPushes pushChunkSize $ removeIfLargeFanout currentFanoutLimit ps void $ sequenceConcurrently $ pushV2 <$> pushes --- TODO: something about this is odd; we cannot really interpret anything that --- is asynchronounsly run; everything would have to be in IO having to provide an --- interpreter for the effect; Async seems so much easier; almost too easy --- pooledMapConcurrentlyN_ maxThreads (_ . pushV2 @r) pushes - removeIfLargeFanout :: Range n m Int32 -> [PushTo user] -> [PushTo user] removeIfLargeFanout limit = filter \PushTo {_pushRecipients} -> length _pushRecipients <= fromIntegral (fromRange limit) diff --git a/libs/wire-subsystems/test/Test/Wire/Notification.hs b/libs/wire-subsystems/test/Test/Wire/Notification.hs index fb38ae20a2e..42e2f85a432 100644 --- a/libs/wire-subsystems/test/Test/Wire/Notification.hs +++ b/libs/wire-subsystems/test/Test/Wire/Notification.hs @@ -1,29 +1,142 @@ module Test.Wire.Notification (spec) where -import Data.Containers.ListUtils (nubOrdOn) -import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Data (Proxy (Proxy)) +import Data.List.NonEmpty (NonEmpty ((:|)), fromList) import Data.List1 qualified as List1 -import Data.Range (Range, fromRange) +import Data.Range (fromRange, toRange) import Data.Set qualified as Set import Gundeck.Types.Push.V2 qualified as V2 import Imports import Numeric.Natural (Natural) import Polysemy import Polysemy.Async (asyncToIOFinal) +import Polysemy.Input import Polysemy.Writer (tell, writerToIOFinal) import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Instances () -import Test.QuickCheck.Monadic (assertWith, monadicIO, pre) -import Test.QuickCheck.Monadic qualified as QC -import Wire.API.Team.Member import Wire.Notification spec :: Spec spec = describe "NotificationSubsystem" do describe "pushImpl" do - it "sends all notifications" allNotificationsSent - it "respects maximum fanout limit" maximumFanoutlimitRespected + it "chunks and sends all notifications" do + let mockConfig = + NotificationSubsystemConfig + { fanoutLimit = toRange $ Proxy @30, + chunkSize = 12 + } + + 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 + let push1 = + PushTo + { _pushConn = Nothing, + _pushTransient = True, + _pushRoute = V2.RouteDirect, + _pushNativePriority = Nothing, + pushOrigin = Nothing, + _pushRecipients = Recipient user1 (V2.RecipientClientsSome clients1) :| [], + pushJson = payload1 + } + push2 = + PushTo + { _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 + } + duplicatePush = push2 + duplicatePushWithPush1Recipients = push2 {_pushRecipients = _pushRecipients push1} + largePush = push2 {_pushRecipients = lotOfRecipients} + pushes :: [PushToUser] = + [ push1, + push2, + duplicatePush, + duplicatePushWithPush1Recipients, + largePush + ] + + actualPushes <- + runFinal + . asyncToIOFinal + . runGundeckAPIAccessMock + . runInputConst mockConfig + $ pushImpl pushes + + let expectedPushes = + Set.fromList $ + map toV2Push + <$> + -- It's ok to use chunkPushes here because we're testing + -- that separately + chunkPushes mockConfig.chunkSize pushes + Set.fromList actualPushes `shouldBe` expectedPushes + + it "respects maximum fanout limit" do + let mockConfig = + NotificationSubsystemConfig + { fanoutLimit = toRange $ Proxy @30, + chunkSize = 12 + } + + connId2 <- generate arbitrary + origin2 <- generate arbitrary + (user21, user22) <- generate arbitrary + (payload1, payload2) <- generate $ resize 1 arbitrary + lotOfRecipients <- fromList <$> replicateM 31 (generate arbitrary) + let pushBiggerThanFanoutLimit = + PushTo + { _pushConn = Nothing, + _pushTransient = True, + _pushRoute = V2.RouteDirect, + _pushNativePriority = Nothing, + pushOrigin = Nothing, + _pushRecipients = lotOfRecipients, + pushJson = payload1 + } + pushSmallerThanFanoutLimit = + PushTo + { _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 + } + pushes :: [PushToUser] = + [ pushBiggerThanFanoutLimit, + pushSmallerThanFanoutLimit + ] + + actualPushes <- + runFinal + . asyncToIOFinal + . runGundeckAPIAccessMock + . runInputConst mockConfig + $ pushImpl pushes + + let expectedPushes = + Set.fromList $ + map toV2Push + <$> + -- It's ok to use chunkPushes here because we're testing + -- that separately + chunkPushes mockConfig.chunkSize [pushSmallerThanFanoutLimit] + Set.fromList actualPushes `shouldBe` expectedPushes + describe "toV2Push" do it "does the transformation correctly" $ property \(pushToUser :: PushToUser) -> let v2Push = toV2Push pushToUser @@ -51,44 +164,12 @@ spec = describe "NotificationSubsystem" do (chunkPushes limit pushes >>= reverse >>= normalisePush) === (pushes >>= normalisePush) it "respects the chunkSize limit" $ property \limit (pushes :: [PushTo Int]) -> - all ((<= limit) . chunkSize) (chunkPushes limit pushes) + all ((<= limit) . sizeOfChunks) (chunkPushes limit pushes) -runGundeckAPIAccessMock :: Member (Final IO) r => Sem (GundeckAPIAccess : r) a -> Sem r [V2.Push] +runGundeckAPIAccessMock :: Member (Final IO) r => Sem (GundeckAPIAccess : r) a -> Sem r [[V2.Push]] runGundeckAPIAccessMock = fmap fst . writerToIOFinal . reinterpret \case - PushV2 pushes -> tell pushes - -allNotificationsSent :: Property -allNotificationsSent = property \(NonEmpty pushes) -> monadicIO do - pre (nubOrdOn pushJson pushes == pushes) - pre (nubOrdOn id pushes == pushes) - -- FIXME: the 16 should be reflecting the actual fanout limit - pre (all (\p -> length p._pushRecipients <= 16) pushes) - - mockPushes <- - nubOrdOn V2._pushPayload <$> QC.run do - runFinal - . asyncToIOFinal - . runGundeckAPIAccessMock - $ pushImpl pushes - - let c = - unlines - [ "Expected:", - show pushes, - "\nwith length:", - show (length pushes), - "\nBut got:", - show mockPushes, - "\nwith length:", - show (length mockPushes) - ] - assertWith (length pushes == length mockPushes) c - --- TODO: this doesn't really make sense; it is similar to the actual implementation and is basically testing filter -maximumFanoutlimitRespected :: Property -maximumFanoutlimitRespected = property \(range :: Range 1 HardTruncationLimit Int32) (pushes :: [PushTo Int]) -> - all (\PushTo {_pushRecipients} -> length _pushRecipients <= fromIntegral (fromRange range)) (removeIfLargeFanout range pushes) + PushV2 pushes -> tell [pushes] normalisePush :: PushTo a -> [PushTo a] normalisePush p = @@ -96,5 +177,5 @@ normalisePush p = (\r -> p {_pushRecipients = r :| []}) (toList (_pushRecipients p)) -chunkSize :: [PushTo a] -> Natural -chunkSize = getSum . foldMap (Sum . fromIntegral . length . _pushRecipients) +sizeOfChunks :: [PushTo a] -> Natural +sizeOfChunks = fromIntegral . sum . map (length . _pushRecipients) From f68d9a6f532cf2ca5d320ed8d7af4705a351e180 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Wed, 20 Dec 2023 16:52:25 +0100 Subject: [PATCH 10/43] [chore] nix package for notificatio-subsystem --- libs/wire-subsystems/default.nix | 55 +++++++++++++++++++++++++++++++- 1 file changed, 54 insertions(+), 1 deletion(-) diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index df0128fe36b..e746db3be19 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -2,10 +2,63 @@ # 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, gitignoreSource, lib }: +{ mkDerivation +, aeson +, base +, bilge +, bytestring +, containers +, gitignoreSource +, gundeck-types +, hspec +, http-client +, http-types +, imports +, lens +, lib +, polysemy +, polysemy-wire-zoo +, QuickCheck +, quickcheck-instances +, text +, types-common +, wire-api +}: mkDerivation { pname = "wire-subsystems"; version = "0.1.0"; src = gitignoreSource ./.; + libraryHaskellDepends = [ + aeson + base + bilge + containers + gundeck-types + http-client + http-types + imports + lens + polysemy + polysemy-wire-zoo + QuickCheck + text + types-common + wire-api + ]; + testHaskellDepends = [ + aeson + base + bytestring + containers + gundeck-types + hspec + imports + polysemy + polysemy-wire-zoo + QuickCheck + quickcheck-instances + types-common + wire-api + ]; license = lib.licenses.agpl3Only; } From a41e73edfb5a5278f8b3a340d5647262e1b3b153 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 21 Dec 2023 12:20:28 +0100 Subject: [PATCH 11/43] wire-subsystem: Move things around and use hspec-discover * Wire.Notification -> Wire.NotificationSubsystem This way imports make more sense. * Add some helper constructor for PushTo in Wire.NotificationSubsystem Introduce Wire.GundeckAPIAccess * Declutters the NotificationSubsystem --- .../src/Wire/GundeckAPIAccess.hs | 36 ++++++++++ ...tification.hs => NotificationSubsystem.hs} | 67 +++++++++---------- libs/wire-subsystems/test/Main.hs | 5 +- libs/wire-subsystems/test/unit/Spec.hs | 1 + .../Wire/NotificationSubsystemSpec.hs} | 5 +- libs/wire-subsystems/wire-subsystems.cabal | 23 +++++-- 6 files changed, 90 insertions(+), 47 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs rename libs/wire-subsystems/src/Wire/{Notification.hs => NotificationSubsystem.hs} (77%) create mode 100644 libs/wire-subsystems/test/unit/Spec.hs rename libs/wire-subsystems/test/{Test/Wire/Notification.hs => unit/Wire/NotificationSubsystemSpec.hs} (98%) diff --git a/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs b/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs new file mode 100644 index 00000000000..c0a3d1cd1a8 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.GundeckAPIAccess where + +import Bilge as B +import Data.Text.Encoding +import Gundeck.Types.Push.V2 qualified as V2 +import Imports +import Network.HTTP.Client qualified as HTTP +import Polysemy +import Util.Options + +data GundeckAPIAccess m a where + PushV2 :: [V2.Push] -> GundeckAPIAccess m () + +makeSem ''GundeckAPIAccess + +data GundeckAccessDetails = GundeckAccessDetails + { endpoint :: Endpoint, + httpManager :: HTTP.Manager + } + +runGundeckAPIAccess :: Member (Embed IO) r => GundeckAccessDetails -> Sem (GundeckAPIAccess : r) a -> Sem r a +runGundeckAPIAccess accessDetails = interpret $ \case + PushV2 pushes -> do + chunkedReq <- jsonChunkedIO pushes + let req = + B.host (encodeUtf8 accessDetails.endpoint._host) + . B.port accessDetails.endpoint._port + . path "/i/push/v2" + . expect2xx + . chunkedReq + B.runHttpT accessDetails.httpManager $ + -- Because of 'expect2xx' we don't actually need to check the response + void $ + B.post req diff --git a/libs/wire-subsystems/src/Wire/Notification.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs similarity index 77% rename from libs/wire-subsystems/src/Wire/Notification.hs rename to libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index 111e5db4159..b014e48f98b 100644 --- a/libs/wire-subsystems/src/Wire/Notification.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -1,28 +1,25 @@ {-# LANGUAGE TemplateHaskell #-} -module Wire.Notification where +module Wire.NotificationSubsystem where -import Bilge as B -import Control.Lens +import Control.Lens (makeLenses, set, (.~)) import Data.Aeson import Data.Id -import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) import Data.List1 (List1) import Data.List1 qualified as List1 import Data.Range (Range, fromRange, unsafeRange) import Data.Set qualified as Set -import Data.Text.Encoding (encodeUtf8) -import Gundeck.Types hiding (Push (..)) +import Gundeck.Types hiding (Push (..), Recipient, newPush) import Gundeck.Types.Push.V2 qualified as V2 import Imports -import Network.HTTP.Client qualified as HTTP import Numeric.Natural (Natural) import Polysemy import Polysemy.Async (Async, sequenceConcurrently) import Polysemy.Input -import Util.Options import Wire.API.Team.Member import Wire.Arbitrary +import Wire.GundeckAPIAccess import Wire.Sem.Delay (Delay, delay) data RecipientBy user = Recipient @@ -61,16 +58,6 @@ data NotificationSubsystem m a where makeSem ''NotificationSubsystem -data GundeckAccessDetails = GundeckAccessDetails - { endpoint :: Endpoint, - httpManager :: HTTP.Manager - } - -data GundeckAPIAccess m a where - PushV2 :: [V2.Push] -> GundeckAPIAccess m () - -makeSem ''GundeckAPIAccess - -- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. runNotificationSubsystemGundeck :: ( Member (GundeckAPIAccess) r, @@ -108,7 +95,9 @@ pushImpl ps = do pushV2 <$> pushes removeIfLargeFanout :: Range n m Int32 -> [PushTo user] -> [PushTo user] -removeIfLargeFanout limit = filter \PushTo {_pushRecipients} -> length _pushRecipients <= fromIntegral (fromRange limit) +removeIfLargeFanout limit = + filter \PushTo {_pushRecipients} -> + length _pushRecipients <= fromIntegral (fromRange limit) mkPushes :: Natural -> [PushToUser] -> [[V2.Push]] mkPushes chunkSize = map (map toV2Push) . chunkPushes chunkSize @@ -116,7 +105,7 @@ mkPushes chunkSize = map (map toV2Push) . chunkPushes chunkSize {-# INLINE [1] toV2Push #-} toV2Push :: PushToUser -> V2.Push toV2Push p = - (newPush p.pushOrigin (unsafeRange (Set.fromList recipients)) pload) + (V2.newPush p.pushOrigin (unsafeRange (Set.fromList recipients)) pload) & V2.pushOriginConnection .~ _pushConn p & V2.pushTransient .~ _pushTransient p & maybe id (set V2.pushNativePriority) p._pushNativePriority @@ -170,18 +159,26 @@ pushSlowly ps = do delay d push [p] --- TODO: Test manually if this even works. -runGundeckAPIAccess :: Member (Embed IO) r => GundeckAccessDetails -> Sem (GundeckAPIAccess : r) a -> Sem r a -runGundeckAPIAccess accessDetails = interpret $ \case - PushV2 pushes -> do - chunkedReq <- jsonChunkedIO pushes - let req = - B.host (encodeUtf8 accessDetails.endpoint._host) - . B.port accessDetails.endpoint._port - . path "/i/push/v2" - . expect2xx - . chunkedReq - B.runHttpT accessDetails.httpManager $ - -- Because of 'expect2xx' we don't actually need to check the response - void $ - B.post req +newPush1 :: Maybe UserId -> Object -> NonEmpty Recipient -> PushToUser +newPush1 from e rr = + PushTo + { _pushConn = Nothing, + _pushTransient = False, + _pushRoute = RouteAny, + _pushNativePriority = Nothing, + -- _pushAsync = False, + -- pushRecipientListType = recipientListType, + pushJson = e, + pushOrigin = from, + _pushRecipients = rr + } + +newPush :: Maybe UserId -> Object -> [Recipient] -> Maybe PushToUser +newPush _ _ [] = Nothing +newPush u e (r : rr) = Just $ newPush1 u e (r :| rr) + +newPushLocal :: UserId -> Object -> [Recipient] -> Maybe PushToUser +newPushLocal uid = newPush (Just uid) + +newPushLocal1 :: UserId -> Object -> NonEmpty Recipient -> PushToUser +newPushLocal1 uid = newPush1 (Just uid) diff --git a/libs/wire-subsystems/test/Main.hs b/libs/wire-subsystems/test/Main.hs index 03eddfc02b7..96392ca769d 100644 --- a/libs/wire-subsystems/test/Main.hs +++ b/libs/wire-subsystems/test/Main.hs @@ -1,9 +1,8 @@ module Main where import Imports +import Spec import Test.Hspec -import Test.Wire.Notification qualified as Notification main :: IO () -main = hspec do - Notification.spec +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/Test/Wire/Notification.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystemSpec.hs similarity index 98% rename from libs/wire-subsystems/test/Test/Wire/Notification.hs rename to libs/wire-subsystems/test/unit/Wire/NotificationSubsystemSpec.hs index 42e2f85a432..2e441d254ac 100644 --- a/libs/wire-subsystems/test/Test/Wire/Notification.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystemSpec.hs @@ -1,4 +1,4 @@ -module Test.Wire.Notification (spec) where +module Wire.NotificationSubsystemSpec (spec) where import Data.Data (Proxy (Proxy)) import Data.List.NonEmpty (NonEmpty ((:|)), fromList) @@ -15,7 +15,8 @@ import Polysemy.Writer (tell, writerToIOFinal) import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Instances () -import Wire.Notification +import Wire.GundeckAPIAccess +import Wire.NotificationSubsystem spec :: Spec spec = describe "NotificationSubsystem" do diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 2d9f7e8b4dc..dcc3ad65213 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -67,7 +67,10 @@ library import: common-all -- cabal-fmt: expand src - exposed-modules: Wire.Notification + exposed-modules: + Wire.GundeckAPIAccess + Wire.NotificationSubsystem + hs-source-dirs: src build-depends: , aeson @@ -89,12 +92,18 @@ library default-language: GHC2021 test-suite wire-subsystems-tests - import: common-all - type: exitcode-stdio-1.0 - main-is: Main.hs - default-language: GHC2021 - other-modules: Test.Wire.Notification - hs-source-dirs: test + 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.NotificationSubsystemSpec + + build-tool-depends: hspec-discover:hspec-discover build-depends: , aeson , base From dc6564db2329fc4bd886e7a717e03f6ae33ca670 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 21 Dec 2023 12:38:38 +0100 Subject: [PATCH 12/43] wire-subsystem: Extract the interpreter out of NotificationSubsystem Imports are nicer this way --- .../src/Wire/NotificationSubsystem.hs | 100 +---------------- .../Wire/NotificationSubsystem/Interpreter.hs | 106 ++++++++++++++++++ .../InterpreterSpec.hs} | 5 +- libs/wire-subsystems/wire-subsystems.cabal | 3 +- 4 files changed, 113 insertions(+), 101 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs rename libs/wire-subsystems/test/unit/Wire/{NotificationSubsystemSpec.hs => NotificationSubsystem/InterpreterSpec.hs} (97%) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index b014e48f98b..ce9db2a0d07 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -2,24 +2,14 @@ module Wire.NotificationSubsystem where -import Control.Lens (makeLenses, set, (.~)) +import Control.Lens (makeLenses) import Data.Aeson import Data.Id -import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) -import Data.List1 (List1) -import Data.List1 qualified as List1 -import Data.Range (Range, fromRange, unsafeRange) -import Data.Set qualified as Set +import Data.List.NonEmpty (NonEmpty ((:|))) 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.Input -import Wire.API.Team.Member import Wire.Arbitrary -import Wire.GundeckAPIAccess import Wire.Sem.Delay (Delay, delay) data RecipientBy user = Recipient @@ -58,92 +48,6 @@ data NotificationSubsystem m a where makeSem ''NotificationSubsystem --- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. -runNotificationSubsystemGundeck :: - ( Member (GundeckAPIAccess) r, - Member Async r, - Member (Input NotificationSubsystemConfig) r - ) => - Sem (NotificationSubsystem : r) a -> - Sem r a -runNotificationSubsystemGundeck = interpret $ \case - Push ps -> pushImpl ps - -data NotificationSubsystemConfig = NotificationSubsystemConfig - { fanoutLimit :: Range 1 HardTruncationLimit Int32, - chunkSize :: Natural - } - --- TODO: write a test for listtype -pushImpl :: - forall r. - ( Member (GundeckAPIAccess) r, - Member (Input NotificationSubsystemConfig) r, - Member (Async) r - ) => - [PushToUser] -> - Sem r () -pushImpl ps = do - currentFanoutLimit <- inputs fanoutLimit - pushChunkSize <- inputs chunkSize - - let pushes :: [[V2.Push]] = - mkPushes pushChunkSize $ - removeIfLargeFanout currentFanoutLimit ps - void $ - sequenceConcurrently $ - pushV2 <$> pushes - -removeIfLargeFanout :: Range n m Int32 -> [PushTo user] -> [PushTo user] -removeIfLargeFanout limit = - filter \PushTo {_pushRecipients} -> - length _pushRecipients <= fromIntegral (fromRange limit) - -mkPushes :: Natural -> [PushToUser] -> [[V2.Push]] -mkPushes chunkSize = map (map toV2Push) . chunkPushes chunkSize - -{-# INLINE [1] toV2Push #-} -toV2Push :: PushToUser -> 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 :: RecipientBy UserId -> V2.Recipient - toRecipient r = - (recipient r._recipientUserId p._pushRoute) - { V2._recipientClients = r._recipientClients - } - -{-# INLINE [1] chunkPushes #-} -chunkPushes :: Natural -> [PushTo a] -> [[PushTo a]] -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 -> PushTo a -> (PushTo a, PushTo a) - splitPush n p = - let (r1, r2) = splitAt (fromIntegral n) (toList p._pushRecipients) - in (p {_pushRecipients = fromJust $ nonEmpty r1}, p {_pushRecipients = fromJust $ nonEmpty r2}) - -- TODO: Test pushSlowly :: ( Member NotificationSubsystem r, 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..642b66c052b --- /dev/null +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -0,0 +1,106 @@ +module Wire.NotificationSubsystem.Interpreter where + +import Control.Lens (set, (.~)) +import Data.Aeson +import Data.Id +import Data.List.NonEmpty (nonEmpty) +import Data.List1 (List1) +import Data.List1 qualified as List1 +import Data.Range (Range, fromRange, unsafeRange) +import Data.Set qualified as Set +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.Input +import Wire.API.Team.Member +import Wire.GundeckAPIAccess +import Wire.NotificationSubsystem + +-- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. +runNotificationSubsystemGundeck :: + ( Member (GundeckAPIAccess) r, + Member Async r, + Member (Input NotificationSubsystemConfig) r + ) => + Sem (NotificationSubsystem : r) a -> + Sem r a +runNotificationSubsystemGundeck = interpret $ \case + Push ps -> pushImpl ps + +data NotificationSubsystemConfig = NotificationSubsystemConfig + { fanoutLimit :: Range 1 HardTruncationLimit Int32, + chunkSize :: Natural + } + +-- TODO: write a test for listtype +pushImpl :: + forall r. + ( Member (GundeckAPIAccess) r, + Member (Input NotificationSubsystemConfig) r, + Member (Async) r + ) => + [PushToUser] -> + Sem r () +pushImpl ps = do + currentFanoutLimit <- inputs fanoutLimit + pushChunkSize <- inputs chunkSize + + let pushes :: [[V2.Push]] = + mkPushes pushChunkSize $ + removeIfLargeFanout currentFanoutLimit ps + void $ + sequenceConcurrently $ + pushV2 <$> pushes + +removeIfLargeFanout :: Range n m Int32 -> [PushTo user] -> [PushTo user] +removeIfLargeFanout limit = + filter \PushTo {_pushRecipients} -> + length _pushRecipients <= fromIntegral (fromRange limit) + +mkPushes :: Natural -> [PushToUser] -> [[V2.Push]] +mkPushes chunkSize = map (map toV2Push) . chunkPushes chunkSize + +{-# INLINE [1] toV2Push #-} +toV2Push :: PushToUser -> 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 :: RecipientBy UserId -> V2.Recipient + toRecipient r = + (recipient r._recipientUserId p._pushRoute) + { V2._recipientClients = r._recipientClients + } + +{-# INLINE [1] chunkPushes #-} +chunkPushes :: Natural -> [PushTo a] -> [[PushTo a]] +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 -> PushTo a -> (PushTo a, PushTo a) + splitPush n p = + let (r1, r2) = splitAt (fromIntegral n) (toList p._pushRecipients) + in (p {_pushRecipients = fromJust $ nonEmpty r1}, p {_pushRecipients = fromJust $ nonEmpty r2}) diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystemSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs similarity index 97% rename from libs/wire-subsystems/test/unit/Wire/NotificationSubsystemSpec.hs rename to libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index 2e441d254ac..40f7818d386 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystemSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -1,4 +1,4 @@ -module Wire.NotificationSubsystemSpec (spec) where +module Wire.NotificationSubsystem.InterpreterSpec (spec) where import Data.Data (Proxy (Proxy)) import Data.List.NonEmpty (NonEmpty ((:|)), fromList) @@ -17,9 +17,10 @@ import Test.QuickCheck import Test.QuickCheck.Instances () import Wire.GundeckAPIAccess import Wire.NotificationSubsystem +import Wire.NotificationSubsystem.Interpreter spec :: Spec -spec = describe "NotificationSubsystem" do +spec = describe "NotificationSubsystem.Interpreter" do describe "pushImpl" do it "chunks and sends all notifications" do let mockConfig = diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index dcc3ad65213..1bd6d41ab84 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -70,6 +70,7 @@ library exposed-modules: Wire.GundeckAPIAccess Wire.NotificationSubsystem + Wire.NotificationSubsystem.Interpreter hs-source-dirs: src build-depends: @@ -101,7 +102,7 @@ test-suite wire-subsystems-tests -- cabal-fmt: expand test/unit other-modules: Spec - Wire.NotificationSubsystemSpec + Wire.NotificationSubsystem.InterpreterSpec build-tool-depends: hspec-discover:hspec-discover build-depends: From bde026b29c554bdddc69cf39851c392950dfbb47 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 21 Dec 2023 10:09:26 +0100 Subject: [PATCH 13/43] galley: Delete code ported to wire-subsystems --- services/galley/galley.cabal | 3 - .../src/Galley/Effects/GundeckAccess.hs | 42 ---- services/galley/src/Galley/Intra/Push.hs | 50 ----- .../galley/src/Galley/Intra/Push/Internal.hs | 200 ------------------ 4 files changed, 295 deletions(-) delete mode 100644 services/galley/src/Galley/Effects/GundeckAccess.hs delete mode 100644 services/galley/src/Galley/Intra/Push.hs delete mode 100644 services/galley/src/Galley/Intra/Push/Internal.hs diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index e646ea232c3..a49c0cb703f 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 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/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 bc5fa7db2f8..00000000000 --- a/services/galley/src/Galley/Intra/Push/Internal.hs +++ /dev/null @@ -1,200 +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 - traverse_ pushLocal (nonEmpty $ toList ps) - --- | 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 From aaa2713f944f2aaa6d766ad5fbb40f5c2f956d13 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 21 Dec 2023 15:20:33 +0100 Subject: [PATCH 14/43] galley: Use the new NotificationSubsystem --- .../polysemy-wire-zoo/polysemy-wire-zoo.cabal | 1 - .../Wire/NotificationSubsystem/Interpreter.hs | 8 +- services/galley/galley.cabal | 2 +- services/galley/src/Galley/API/Action.hs | 43 ++++---- services/galley/src/Galley/API/Clients.hs | 3 +- services/galley/src/Galley/API/Create.hs | 56 ++++++----- services/galley/src/Galley/API/Federation.hs | 32 +++--- services/galley/src/Galley/API/Internal.hs | 20 ++-- services/galley/src/Galley/API/LegalHold.hs | 19 ++-- .../galley/src/Galley/API/MLS/Commit/Core.hs | 5 +- services/galley/src/Galley/API/MLS/Message.hs | 3 +- .../galley/src/Galley/API/MLS/Propagate.hs | 6 +- .../galley/src/Galley/API/MLS/Proposal.hs | 3 +- services/galley/src/Galley/API/MLS/Removal.hs | 13 +-- .../src/Galley/API/MLS/SubConversation.hs | 3 +- services/galley/src/Galley/API/MLS/Welcome.hs | 13 +-- services/galley/src/Galley/API/Message.hs | 25 ++--- services/galley/src/Galley/API/Push.hs | 18 ++-- services/galley/src/Galley/API/Teams.hs | 96 +++++++++--------- .../galley/src/Galley/API/Teams/Features.hs | 44 ++++----- services/galley/src/Galley/API/Update.hs | 99 +++++++++---------- services/galley/src/Galley/API/Util.hs | 30 ++++-- services/galley/src/Galley/App.hs | 11 ++- services/galley/src/Galley/Effects.hs | 7 +- services/galley/src/Galley/Env.hs | 16 +++ services/galley/src/Galley/Intra/Effects.hs | 13 --- services/galley/test/unit/Run.hs | 2 - 27 files changed, 315 insertions(+), 276 deletions(-) diff --git a/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal b/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal index aee7d7ef1ce..c6c363632e9 100644 --- a/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal +++ b/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal @@ -109,7 +109,6 @@ test-suite spec main-is: Spec.hs other-modules: Paths_polysemy_wire_zoo - Test.DelaySpec Test.IntersperseSpec hs-source-dirs: test diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index 642b66c052b..32e47f3838d 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -22,13 +22,13 @@ import Wire.NotificationSubsystem -- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. runNotificationSubsystemGundeck :: ( Member (GundeckAPIAccess) r, - Member Async r, - Member (Input NotificationSubsystemConfig) r + Member Async r ) => + NotificationSubsystemConfig -> Sem (NotificationSubsystem : r) a -> Sem r a -runNotificationSubsystemGundeck = interpret $ \case - Push ps -> pushImpl ps +runNotificationSubsystemGundeck cfg = interpret $ \case + Push ps -> runInputConst cfg $ pushImpl ps data NotificationSubsystemConfig = NotificationSubsystemConfig { fanoutLimit :: Range 1 HardTruncationLimit Int32, diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index a49c0cb703f..4088a64b453 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -365,6 +365,7 @@ library , wai-utilities >=0.16 , wire-api , wire-api-federation + , wire-subsystems executable galley import: common-all @@ -610,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..f1e806935b1 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,8 @@ 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 +import Wire.NotificationSubsystem qualified as NotificationSubsystem data NoChanges = NoChanges @@ -146,7 +148,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 +167,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 +183,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 +222,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 +251,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 +719,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 +759,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 +862,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 +913,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 +1040,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 +1072,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 +1103,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 +1113,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 -> + NotificationSubsystem.push + [ 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..01923b2403d 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,8 @@ 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 +import Wire.NotificationSubsystem qualified as NotificationSubsystem ---------------------------------------------------------------------------- -- Group conversations @@ -104,7 +106,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 +145,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 +184,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 +324,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 +392,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 +434,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 +458,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 +511,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 +545,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 -> + NotificationSubsystem.push + [ p + & pushRoute .~ PushV2.RouteDirect + & pushConn .~ conn + ] conversationCreated lusr c update n conv = do let mems = Data.convLocalMembers conv @@ -582,11 +585,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 -> + NotificationSubsystem.push + [ p + & pushRoute .~ PushV2.RouteDirect + & pushConn .~ conn + ] pure $ Data.convSetName n' conv | otherwise = pure conv @@ -650,7 +654,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 +672,11 @@ notifyCreatedConversation lusr conn c = do throw FederationNotConfigured -- Notify local users - E.push =<< mapM (toPush now) (Data.convLocalMembers c) + NotificationSubsystem.push =<< 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 +684,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..0ff3f9fcb82 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,9 @@ 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.NotificationSubsystem qualified as NotificationSubsystem import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra @@ -305,7 +305,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 +395,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 + NotificationSubsystem.push (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..32635056347 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,25 +78,25 @@ 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) + push $ maybeToList $ toPush mp for_ mqcnv $ \qcnv -> if tDomain loc /= qDomain qcnv then unless (null botMembers) $ do warn $ Log.msg ("Ignoring messages for local bots in a remote conversation" :: ByteString) . Log.field "conversation" (show qcnv) else deliverAndDeleteAsync (qUnqualified qcnv) (map (,event) botMembers) -toPush :: MessagePush -> Maybe Push +toPush :: MessagePush -> Maybe PushToUser 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..8e73b8ac6e8 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,9 @@ 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.NotificationSubsystem qualified as NotificationSubsystem +import Wire.Sem.Delay import Wire.Sem.Paging qualified as E import Wire.Sem.Paging.Cassandra @@ -234,7 +237,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 +270,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 +327,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 +343,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) + NotificationSubsystem.push [newPushLocal1 zusr (toJSONObject e) r & pushConn ?~ zcon & pushTransient .~ True] deleteTeam :: forall r. @@ -404,13 +407,14 @@ 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, Member MemberStore r, Member SparAccess r, - Member TeamStore r + Member TeamStore r, + Member Delay r ) => Local UserId -> Maybe ConnId -> @@ -441,7 +445,7 @@ uncheckedDeleteTeam lusr zcon tid = do Data.unsetTeamLegalholdWhitelisted tid E.deleteTeam tid where - pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Sem r () + pushDeleteEvents :: [TeamMember] -> Event -> [PushToUser] -> Sem r () pushDeleteEvents membs e ue = do o <- inputs (view settings) let r = list1 (userRecipient (tUnqualified lusr)) (membersToRecipients (Just (tUnqualified lusr)) membs) @@ -452,15 +456,15 @@ 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 -> NotificationSubsystem.push [newPushLocal1 (tUnqualified lusr) (toJSONObject e) (x :| xs) & pushConn .~ zcon] -- To avoid DoS on gundeck, send conversation deletion events slowly - E.pushSlowly ue + NotificationSubsystem.pushSlowly ue createConvDeleteEvents :: UTCTime -> [TeamMember] -> TeamConversation -> - ([Push], [(BotMember, Conv.Event)]) -> - Sem r ([Push], [(BotMember, Conv.Event)]) + ([PushToUser], [(BotMember, Conv.Event)]) -> + Sem r ([PushToUser], [(BotMember, Conv.Event)]) createConvDeleteEvents now teamMembs c (pp, ee) = do let qconvId = tUntagged $ qualifyAs lusr (c ^. conversationId) (bots, convMembs) <- localBotsAndUsers <$> E.getLocalMembers (c ^. conversationId) @@ -470,7 +474,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 +714,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 +761,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 +789,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 +827,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 -> NotificationSubsystem.push [p & pushConn .~ mZcon & pushTransient .~ True]) updateTeamMember :: forall r. @@ -836,7 +840,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 +897,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 +925,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 +953,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 +1011,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 +1037,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) + NotificationSubsystem.push + [newPushLocal1 (tUnqualified lusr) (toJSONObject e) r & pushConn .~ zcon & pushTransient .~ True] uncheckedDeleteTeamMember lusr zcon tid remove (Right mems) = do now <- input pushMemberLeaveEventToAll now @@ -1051,19 +1053,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 + NotificationSubsystem.push + [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 +1149,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 +1307,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 +1334,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' + NotificationSubsystem.push + [ 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 +1362,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 + NotificationSubsystem.push + [ 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 9c8b836a461..bca9725b87e 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 -> @@ -189,10 +189,8 @@ persistAndPushEvent tid wsnl = do pushFeatureConfigEvent tid (Event.mkUpdateEvent fs) pure fs --- TODO: This looks like a bug. These notifications are actually never sent. --- If it is a bug we probably don't need the list type field in the PushTo type. pushFeatureConfigEvent :: - ( Member GundeckAccess r, + ( Member NotificationSubsystem r, Member TeamStore r, Member P.TinyLog r ) => @@ -201,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) + push $ + maybeToList $ + (newPush Nothing (toJSONObject event) recipients) guardLockStatus :: forall r. @@ -237,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 ) ) => @@ -251,7 +251,7 @@ class GetFeatureConfig cfg => SetFeatureConfig cfg where Members '[ TeamFeatureStore, P.Logger (Log.Msg -> Log.Msg), - GundeckAccess, + NotificationSubsystem, TeamStore ] r @@ -307,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..69d5a611a22 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,16 @@ 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 +import Wire.NotificationSubsystem qualified as 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 +186,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 +227,7 @@ type UpdateConversationAccessEffects = ExternalAccess, FederatorAccess, FireAndForget, - GundeckAccess, + NotificationSubsystem, Input Env, Input UTCTime, MemberStore, @@ -278,7 +277,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 +310,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 +351,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 +372,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 +405,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 +428,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 +456,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 +480,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 +507,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 +557,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 +575,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 +660,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 +705,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 +734,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 +758,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 +812,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 +853,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 +894,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 +918,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 +965,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 +988,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 +1015,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 +1041,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 +1076,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 +1104,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 +1179,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 +1215,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 +1240,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 +1291,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 +1320,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 +1345,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 +1373,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 +1400,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 +1423,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 +1438,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 +1476,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 +1521,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 +1544,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 +1575,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 -> + NotificationSubsystem.push [p & pushConn ?~ zcon] E.deliverAsync (map (,e) (bm : bots)) pure e where @@ -1599,7 +1598,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 +1617,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 +1647,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 -> + NotificationSubsystem.push [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..6227bc0663f 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 as 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 -> + NotificationSubsystem.push [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 :: user -> RecipientBy user +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 + NotificationSubsystem.push [p & set pushConn conn] deliverAsync (map (,e) (toList bots)) +newConversationEventPush :: Event -> Local [UserId] -> Maybe PushToUser +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..55000a0787d 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,9 @@ 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.Sem.Delay import Wire.Sem.Logger qualified import Wire.Sem.Random.IO @@ -119,6 +123,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 +244,8 @@ evalGalley e = . resourceToIOFinal . runError . embedToFinal @IO + . runDelay + . asyncToIOFinal . mapError toResponse . mapError toResponse . mapError toResponse @@ -276,7 +284,8 @@ evalGalley e = . interpretBackendNotificationQueueAccess . interpretFederatorAccess . interpretExternalAccess - . interpretGundeckAccess + . runGundeckAPIAccess (gundeckAccessDetails e) + . runNotificationSubsystemGundeck (notificationSubssystemConfig e) . interpretSparAccess . interpretBrigAccess where diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 12c7c31df5f..d34849009c4 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,8 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog import Wire.API.Error +import Wire.GundeckAPIAccess +import Wire.NotificationSubsystem import Wire.Sem.Paging.Cassandra import Wire.Sem.Random @@ -106,7 +106,8 @@ import Wire.Sem.Random type GalleyEffects1 = '[ BrigAccess, SparAccess, - GundeckAccess, + NotificationSubsystem, + GundeckAPIAccess, ExternalAccess, FederatorAccess, BackendNotificationQueueAccess, diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 2bdb38c27ff..feba157b45a 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -44,6 +44,8 @@ import Util.Options import Wire.API.MLS.Credential import Wire.API.MLS.Keys import Wire.API.Team.Member +import Wire.GundeckAPIAccess +import Wire.NotificationSubsystem.Interpreter data DeleteItem = TeamItem TeamId UserId (Maybe ConnId) deriving (Eq, Ord, Show) @@ -109,3 +111,17 @@ currentFanoutLimit o = do let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defFanoutLimit (o ^. (O.settings . maxFanoutSize)) let maxSize = fromIntegral (o ^. (O.settings . maxTeamSize)) unsafeRange (min maxSize optFanoutLimit) + +gundeckAccessDetails :: Env -> GundeckAccessDetails +gundeckAccessDetails env = + GundeckAccessDetails + { endpoint = env ^. options . gundeck, + httpManager = env._manager + } + +notificationSubssystemConfig :: Env -> NotificationSubsystemConfig +notificationSubssystemConfig env = + NotificationSubsystemConfig + { chunkSize = 128, + fanoutLimit = currentFanoutLimit env._options + } 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/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 ] From 78c819b1f69f68da9444778cb10c9b0c61009169 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 21 Dec 2023 15:48:33 +0100 Subject: [PATCH 15/43] Regen nix files --- libs/wire-subsystems/default.nix | 2 ++ services/galley/default.nix | 2 ++ 2 files changed, 4 insertions(+) diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index e746db3be19..f3ac12102a1 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -11,6 +11,7 @@ , gitignoreSource , gundeck-types , hspec +, hspec-discover , http-client , http-types , imports @@ -60,5 +61,6 @@ mkDerivation { types-common wire-api ]; + testToolDepends = [ hspec-discover ]; license = lib.licenses.agpl3Only; } 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 From 6d8c39a2f8e9255c00d559d50866279779fcbe7c Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 21 Dec 2023 15:55:03 +0100 Subject: [PATCH 16/43] wire-subsystems/test: Remove unnecessary use of Set --- .../src/Gundeck/Types/Push/V2.hs | 10 +++---- .../NotificationSubsystem/InterpreterSpec.hs | 26 +++++++++---------- 2 files changed, 17 insertions(+), 19 deletions(-) diff --git a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs index 53b2f2f94d1..f38723fe9e8 100644 --- a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs +++ b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs @@ -171,14 +171,14 @@ instance ToJSON RecipientClients where -- ApsData newtype ApsSound = ApsSound {fromSound :: Text} - deriving (Eq, Ord, Show, ToJSON, FromJSON) + deriving (Eq, Show, ToJSON, FromJSON) newtype ApsLocKey = ApsLocKey {fromLocKey :: Text} - deriving (Eq, Ord, Show, ToJSON, FromJSON) + deriving (Eq, Show, ToJSON, FromJSON) data ApsPreference = ApsStdPreference - deriving (Eq, Ord, Show) + deriving (Eq, Show) instance ToJSON ApsPreference where toJSON ApsStdPreference = "std" @@ -195,7 +195,7 @@ data ApsData = ApsData _apsPreference :: !(Maybe ApsPreference), _apsBadge :: !Bool } - deriving (Eq, Ord, Show) + deriving (Eq, Show) makeLenses ''ApsData @@ -263,7 +263,7 @@ data Push = Push -- | Opaque payload _pushPayload :: !(List1 Object) } - deriving (Eq, Ord, Show) + deriving (Eq, Show) makeLenses ''Push diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index 40f7818d386..3c371fe97c2 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -76,13 +76,12 @@ spec = describe "NotificationSubsystem.Interpreter" do $ pushImpl pushes let expectedPushes = - Set.fromList $ - map toV2Push - <$> - -- It's ok to use chunkPushes here because we're testing - -- that separately - chunkPushes mockConfig.chunkSize pushes - Set.fromList actualPushes `shouldBe` 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 = @@ -131,13 +130,12 @@ spec = describe "NotificationSubsystem.Interpreter" do $ pushImpl pushes let expectedPushes = - Set.fromList $ - map toV2Push - <$> - -- It's ok to use chunkPushes here because we're testing - -- that separately - chunkPushes mockConfig.chunkSize [pushSmallerThanFanoutLimit] - Set.fromList actualPushes `shouldBe` expectedPushes + map toV2Push + <$> + -- It's ok to use chunkPushes here because we're testing + -- that separately + chunkPushes mockConfig.chunkSize [pushSmallerThanFanoutLimit] + actualPushes `shouldBe` expectedPushes describe "toV2Push" do it "does the transformation correctly" $ property \(pushToUser :: PushToUser) -> From 8b0c44cbd761f60a846cfaf8445f102de7d576d5 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 21 Dec 2023 16:00:16 +0100 Subject: [PATCH 17/43] Delete commented out code --- libs/wire-subsystems/src/Wire/NotificationSubsystem.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index ce9db2a0d07..acdf227f209 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -28,13 +28,9 @@ data PushTo user = PushTo _pushTransient :: Bool, _pushRoute :: Route, _pushNativePriority :: Maybe Priority, - -- we never push asynchronounsly - -- _pushAsync :: Bool, pushOrigin :: Maybe UserId, _pushRecipients :: NonEmpty (RecipientBy user), pushJson :: Object - -- we probably don't rely on the list type - -- pushRecipientListType :: ListType } deriving stock (Eq, Ord, Generic, Functor, Foldable, Traversable, Show) deriving (Arbitrary) via GenericUniform (PushTo user) @@ -70,8 +66,6 @@ newPush1 from e rr = _pushTransient = False, _pushRoute = RouteAny, _pushNativePriority = Nothing, - -- _pushAsync = False, - -- pushRecipientListType = recipientListType, pushJson = e, pushOrigin = from, _pushRecipients = rr From b283fcc68214ba2cf5e1098ff87c4d88c1eefca6 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 21 Dec 2023 17:40:20 +0100 Subject: [PATCH 18/43] wire-subsystems: Make PushSlowly a NotificationSubsystem action This makes it easier to get the delay interval from the config --- libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs | 17 +++ .../src/Wire/NotificationSubsystem.hs | 17 +-- .../Wire/NotificationSubsystem/Interpreter.hs | 22 +++- .../NotificationSubsystem/InterpreterSpec.hs | 123 +++++++++++++++--- libs/wire-subsystems/wire-subsystems.cabal | 1 + services/galley/src/Galley/API/Teams.hs | 4 +- services/galley/src/Galley/Env.hs | 3 +- 7 files changed, 145 insertions(+), 42 deletions(-) diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs index 86e90e6b189..7b1395b8ed0 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Delay.hs @@ -13,3 +13,20 @@ 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/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index acdf227f209..29b25b41cc8 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -10,7 +10,6 @@ import Gundeck.Types hiding (Push (..), Recipient, newPush) import Imports import Polysemy import Wire.Arbitrary -import Wire.Sem.Delay (Delay, delay) data RecipientBy user = Recipient { _recipientUserId :: user, @@ -41,24 +40,10 @@ type PushToUser = PushTo UserId data NotificationSubsystem m a where Push :: [PushToUser] -> NotificationSubsystem m () + PushSlowly :: [PushToUser] -> NotificationSubsystem m () makeSem ''NotificationSubsystem --- TODO: Test -pushSlowly :: - ( Member NotificationSubsystem r, - Member Delay r - ) => - [PushToUser] -> - Sem r () -pushSlowly ps = do - -- TODO this comes from the app configuration - let mmillies = 10000 - d = 1000 * mmillies - for_ ps \p -> do - delay d - push [p] - newPush1 :: Maybe UserId -> Object -> NonEmpty Recipient -> PushToUser newPush1 from e rr = PushTo diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index 32e47f3838d..fbaf608df09 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -18,21 +18,26 @@ import Polysemy.Input import Wire.API.Team.Member import Wire.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 Async r + Member Async r, + Member Delay r ) => NotificationSubsystemConfig -> Sem (NotificationSubsystem : r) a -> Sem r a runNotificationSubsystemGundeck cfg = interpret $ \case Push ps -> runInputConst cfg $ pushImpl ps + PushSlowly ps -> runInputConst cfg $ pushSlowlyImpl ps data NotificationSubsystemConfig = NotificationSubsystemConfig { fanoutLimit :: Range 1 HardTruncationLimit Int32, - chunkSize :: Natural + chunkSize :: Natural, + -- | Microseconds + slowPushDelay :: Int } -- TODO: write a test for listtype @@ -104,3 +109,16 @@ chunkPushes maxRecipients 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 Async r + ) => + [PushToUser] -> + Sem r () +pushSlowlyImpl ps = + for_ ps \p -> do + delay =<< inputs slowPushDelay + pushImpl [p] diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index 3c371fe97c2..8fccb59d1c2 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -1,5 +1,6 @@ module Wire.NotificationSubsystem.InterpreterSpec (spec) where +import Control.Concurrent.Async (async, wait) import Data.Data (Proxy (Proxy)) import Data.List.NonEmpty (NonEmpty ((:|)), fromList) import Data.List1 qualified as List1 @@ -9,15 +10,16 @@ import Gundeck.Types.Push.V2 qualified as V2 import Imports import Numeric.Natural (Natural) import Polysemy -import Polysemy.Async (asyncToIOFinal) +import Polysemy.Async (Async, asyncToIOFinal) import Polysemy.Input -import Polysemy.Writer (tell, writerToIOFinal) +import System.Timeout (timeout) import Test.Hspec import Test.QuickCheck import Test.QuickCheck.Instances () import Wire.GundeckAPIAccess import Wire.NotificationSubsystem import Wire.NotificationSubsystem.Interpreter +import Wire.Sem.Delay spec :: Spec spec = describe "NotificationSubsystem.Interpreter" do @@ -26,7 +28,8 @@ spec = describe "NotificationSubsystem.Interpreter" do let mockConfig = NotificationSubsystemConfig { fanoutLimit = toRange $ Proxy @30, - chunkSize = 12 + chunkSize = 12, + slowPushDelay = 0 } connId2 <- generate arbitrary @@ -68,12 +71,7 @@ spec = describe "NotificationSubsystem.Interpreter" do largePush ] - actualPushes <- - runFinal - . asyncToIOFinal - . runGundeckAPIAccessMock - . runInputConst mockConfig - $ pushImpl pushes + (_, actualPushes) <- runMockStack mockConfig $ pushImpl pushes let expectedPushes = map toV2Push @@ -87,7 +85,8 @@ spec = describe "NotificationSubsystem.Interpreter" do let mockConfig = NotificationSubsystemConfig { fanoutLimit = toRange $ Proxy @30, - chunkSize = 12 + chunkSize = 12, + slowPushDelay = 0 } connId2 <- generate arbitrary @@ -122,12 +121,7 @@ spec = describe "NotificationSubsystem.Interpreter" do pushSmallerThanFanoutLimit ] - actualPushes <- - runFinal - . asyncToIOFinal - . runGundeckAPIAccessMock - . runInputConst mockConfig - $ pushImpl pushes + (_, actualPushes) <- runMockStack mockConfig $ pushImpl pushes let expectedPushes = map toV2Push @@ -137,6 +131,61 @@ spec = describe "NotificationSubsystem.Interpreter" do 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 + } + + connId2 <- generate arbitrary + origin2 <- generate arbitrary + (user1, user21, user22) <- generate arbitrary + (payload1, payload2) <- generate $ resize 1 arbitrary + clients1 <- generate $ resize 3 arbitrary + let push1 = + PushTo + { _pushConn = Nothing, + _pushTransient = True, + _pushRoute = V2.RouteDirect, + _pushNativePriority = Nothing, + pushOrigin = Nothing, + _pushRecipients = Recipient user1 (V2.RecipientClientsSome clients1) :| [], + pushJson = payload1 + } + push2 = + PushTo + { _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 + } + pushes = [push1, push2] + + actualPushesRef <- newIORef [] + delayControl <- newEmptyMVar + slowPushThread <- + async $ + runMockStackWithControlledDelay mockConfig delayControl actualPushesRef $ + pushSlowlyImpl pushes + + putMVar delayControl mockConfig.slowPushDelay + actualPushes1 <- timeout 100_000 $ (waitUntilPushes actualPushesRef 1) + actualPushes1 `shouldBe` Just [[toV2Push push1]] + + putMVar delayControl mockConfig.slowPushDelay + actualPushes2 <- timeout 100_000 $ (waitUntilPushes actualPushesRef 2) + actualPushes2 `shouldBe` Just [[toV2Push push1], [toV2Push push2]] + + timeout 100_000 (wait slowPushThread) `shouldReturn` Just () + describe "toV2Push" do it "does the transformation correctly" $ property \(pushToUser :: PushToUser) -> let v2Push = toV2Push pushToUser @@ -166,10 +215,44 @@ spec = describe "NotificationSubsystem.Interpreter" do it "respects the chunkSize limit" $ property \limit (pushes :: [PushTo Int]) -> all ((<= limit) . sizeOfChunks) (chunkPushes limit pushes) -runGundeckAPIAccessMock :: Member (Final IO) r => Sem (GundeckAPIAccess : r) a -> Sem r [[V2.Push]] -runGundeckAPIAccessMock = - fmap fst . writerToIOFinal . reinterpret \case - PushV2 pushes -> tell [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 + +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 + +runGundeckAPIAccessIORef :: Member (Embed IO) r => IORef [[V2.Push]] -> Sem (GundeckAPIAccess : r) a -> Sem r a +runGundeckAPIAccessIORef pushesRef = + interpret \case + PushV2 pushes -> modifyIORef pushesRef (<> [pushes]) + +waitUntilPushes :: IORef [a] -> Int -> IO [a] +waitUntilPushes pushesRef n = do + ps <- readIORef pushesRef + if length ps >= n + then pure ps + else threadDelay 1000 >> waitUntilPushes pushesRef n normalisePush :: PushTo a -> [PushTo a] normalisePush p = diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 1bd6d41ab84..cb9af5b639b 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -107,6 +107,7 @@ test-suite wire-subsystems-tests build-tool-depends: hspec-discover:hspec-discover build-depends: , aeson + , async , base , bytestring , containers diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 8e73b8ac6e8..9e28856cd22 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -156,7 +156,6 @@ import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) import Wire.NotificationSubsystem import Wire.NotificationSubsystem qualified as NotificationSubsystem -import Wire.Sem.Delay import Wire.Sem.Paging qualified as E import Wire.Sem.Paging.Cassandra @@ -413,8 +412,7 @@ uncheckedDeleteTeam :: Member LegalHoldStore r, Member MemberStore r, Member SparAccess r, - Member TeamStore r, - Member Delay r + Member TeamStore r ) => Local UserId -> Maybe ConnId -> diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index feba157b45a..3dd6bef4043 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -123,5 +123,6 @@ notificationSubssystemConfig :: Env -> NotificationSubsystemConfig notificationSubssystemConfig env = NotificationSubsystemConfig { chunkSize = 128, - fanoutLimit = currentFanoutLimit env._options + fanoutLimit = currentFanoutLimit env._options, + slowPushDelay = 1000 * fromMaybe defDeleteConvThrottleMillis (env ^. options . O.settings . deleteConvThrottleMillis) } From 79b13a1d15454ae676e3ee45a571e0bdd90406e9 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 8 Jan 2024 13:57:20 +0100 Subject: [PATCH 19/43] wire-subsystems: Update nix --- libs/wire-subsystems/default.nix | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index f3ac12102a1..96d892b5d89 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -4,6 +4,7 @@ # dependencies are added or removed. { mkDerivation , aeson +, async , base , bilge , bytestring @@ -48,6 +49,7 @@ mkDerivation { ]; testHaskellDepends = [ aeson + async base bytestring containers From 550bba5b1ceab0478bedabffd3af7699588712e7 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 8 Jan 2024 14:41:56 +0100 Subject: [PATCH 20/43] Remove unnecessary polymorphism --- .../src/Wire/NotificationSubsystem.hs | 22 +++++++++---------- .../Wire/NotificationSubsystem/Interpreter.hs | 3 +-- services/galley/src/Galley/API/Util.hs | 2 +- 3 files changed, 12 insertions(+), 15 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index 29b25b41cc8..34daa7ca3cd 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -11,32 +11,30 @@ import Imports import Polysemy import Wire.Arbitrary -data RecipientBy user = Recipient - { _recipientUserId :: user, +data Recipient = Recipient + { _recipientUserId :: UserId, _recipientClients :: RecipientClients } - deriving stock (Functor, Foldable, Traversable, Show, Ord, Eq, Generic) - deriving (Arbitrary) via GenericUniform (RecipientBy user) + deriving stock (Show, Ord, Eq, Generic) + deriving (Arbitrary) via GenericUniform Recipient -makeLenses ''RecipientBy +makeLenses ''Recipient -type Recipient = RecipientBy UserId - -data PushTo user = PushTo +data PushTo = PushTo { _pushConn :: Maybe ConnId, _pushTransient :: Bool, _pushRoute :: Route, _pushNativePriority :: Maybe Priority, pushOrigin :: Maybe UserId, - _pushRecipients :: NonEmpty (RecipientBy user), + _pushRecipients :: NonEmpty Recipient, pushJson :: Object } - deriving stock (Eq, Ord, Generic, Functor, Foldable, Traversable, Show) - deriving (Arbitrary) via GenericUniform (PushTo user) + deriving stock (Eq, Ord, Generic, Show) + deriving (Arbitrary) via GenericUniform PushTo makeLenses ''PushTo -type PushToUser = PushTo UserId +type PushToUser = PushTo data NotificationSubsystem m a where Push :: [PushToUser] -> NotificationSubsystem m () diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index fbaf608df09..660f3ac7b92 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -2,7 +2,6 @@ module Wire.NotificationSubsystem.Interpreter where import Control.Lens (set, (.~)) import Data.Aeson -import Data.Id import Data.List.NonEmpty (nonEmpty) import Data.List1 (List1) import Data.List1 qualified as List1 @@ -80,7 +79,7 @@ toV2Push p = pload = List1.singleton (pushJson p) recipients :: [V2.Recipient] recipients = map toRecipient $ toList p._pushRecipients - toRecipient :: RecipientBy UserId -> V2.Recipient + toRecipient :: Recipient -> V2.Recipient toRecipient r = (recipient r._recipientUserId p._pushRoute) { V2._recipientClients = r._recipientClients diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 6227bc0663f..490538a7388 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -359,7 +359,7 @@ acceptOne2One lusr conv conn = do localMemberToRecipient :: LocalMember -> Recipient localMemberToRecipient = userRecipient . lmId -userRecipient :: user -> RecipientBy user +userRecipient :: UserId -> Recipient userRecipient u = Recipient u PushV2.RecipientClientsAll memberJoinEvent :: From f6b3b6e4aaa93d4f0414d47ade50a609973653cb Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 8 Jan 2024 15:26:07 +0100 Subject: [PATCH 21/43] NotificationSubsystem: Rename things for clarity --- .../src/Wire/NotificationSubsystem.hs | 22 +++++++------- .../Wire/NotificationSubsystem/Interpreter.hs | 20 ++++++------- .../NotificationSubsystem/InterpreterSpec.hs | 30 +++++++++---------- services/galley/src/Galley/API/Action.hs | 3 +- services/galley/src/Galley/API/Create.hs | 7 ++--- services/galley/src/Galley/API/Internal.hs | 3 +- services/galley/src/Galley/API/Push.hs | 4 +-- services/galley/src/Galley/API/Teams.hs | 21 +++++++------ .../galley/src/Galley/API/Teams/Features.hs | 2 +- services/galley/src/Galley/API/Update.hs | 5 ++-- services/galley/src/Galley/API/Util.hs | 8 ++--- 11 files changed, 59 insertions(+), 66 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index 34daa7ca3cd..ccf037cdf1d 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -20,7 +20,7 @@ data Recipient = Recipient makeLenses ''Recipient -data PushTo = PushTo +data Push = Push { _pushConn :: Maybe ConnId, _pushTransient :: Bool, _pushRoute :: Route, @@ -30,21 +30,19 @@ data PushTo = PushTo pushJson :: Object } deriving stock (Eq, Ord, Generic, Show) - deriving (Arbitrary) via GenericUniform PushTo + deriving (Arbitrary) via GenericUniform Push -makeLenses ''PushTo - -type PushToUser = PushTo +makeLenses ''Push data NotificationSubsystem m a where - Push :: [PushToUser] -> NotificationSubsystem m () - PushSlowly :: [PushToUser] -> NotificationSubsystem m () + PushNotifications :: [Push] -> NotificationSubsystem m () + PushNotificationsSlowly :: [Push] -> NotificationSubsystem m () makeSem ''NotificationSubsystem -newPush1 :: Maybe UserId -> Object -> NonEmpty Recipient -> PushToUser +newPush1 :: Maybe UserId -> Object -> NonEmpty Recipient -> Push newPush1 from e rr = - PushTo + Push { _pushConn = Nothing, _pushTransient = False, _pushRoute = RouteAny, @@ -54,12 +52,12 @@ newPush1 from e rr = _pushRecipients = rr } -newPush :: Maybe UserId -> Object -> [Recipient] -> Maybe PushToUser +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 PushToUser +newPushLocal :: UserId -> Object -> [Recipient] -> Maybe Push newPushLocal uid = newPush (Just uid) -newPushLocal1 :: UserId -> Object -> NonEmpty Recipient -> PushToUser +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 index 660f3ac7b92..5fc0798611c 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -29,8 +29,8 @@ runNotificationSubsystemGundeck :: Sem (NotificationSubsystem : r) a -> Sem r a runNotificationSubsystemGundeck cfg = interpret $ \case - Push ps -> runInputConst cfg $ pushImpl ps - PushSlowly ps -> runInputConst cfg $ pushSlowlyImpl ps + PushNotifications ps -> runInputConst cfg $ pushImpl ps + PushNotificationsSlowly ps -> runInputConst cfg $ pushSlowlyImpl ps data NotificationSubsystemConfig = NotificationSubsystemConfig { fanoutLimit :: Range 1 HardTruncationLimit Int32, @@ -46,7 +46,7 @@ pushImpl :: Member (Input NotificationSubsystemConfig) r, Member (Async) r ) => - [PushToUser] -> + [Push] -> Sem r () pushImpl ps = do currentFanoutLimit <- inputs fanoutLimit @@ -59,16 +59,16 @@ pushImpl ps = do sequenceConcurrently $ pushV2 <$> pushes -removeIfLargeFanout :: Range n m Int32 -> [PushTo user] -> [PushTo user] +removeIfLargeFanout :: Range n m Int32 -> [Push] -> [Push] removeIfLargeFanout limit = - filter \PushTo {_pushRecipients} -> + filter \Push {_pushRecipients} -> length _pushRecipients <= fromIntegral (fromRange limit) -mkPushes :: Natural -> [PushToUser] -> [[V2.Push]] +mkPushes :: Natural -> [Push] -> [[V2.Push]] mkPushes chunkSize = map (map toV2Push) . chunkPushes chunkSize {-# INLINE [1] toV2Push #-} -toV2Push :: PushToUser -> V2.Push +toV2Push :: Push -> V2.Push toV2Push p = (V2.newPush p.pushOrigin (unsafeRange (Set.fromList recipients)) pload) & V2.pushOriginConnection .~ _pushConn p @@ -86,7 +86,7 @@ toV2Push p = } {-# INLINE [1] chunkPushes #-} -chunkPushes :: Natural -> [PushTo a] -> [[PushTo a]] +chunkPushes :: Natural -> [Push] -> [[Push]] chunkPushes maxRecipients | maxRecipients > 0 = go 0 [] | otherwise = const [] @@ -104,7 +104,7 @@ chunkPushes maxRecipients else go totalLength (y : acc) ys -- n must be strictly > 0 and < length (_pushRecipients p) - splitPush :: Natural -> PushTo a -> (PushTo a, PushTo a) + 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}) @@ -115,7 +115,7 @@ pushSlowlyImpl :: Member GundeckAPIAccess r, Member Async r ) => - [PushToUser] -> + [Push] -> Sem r () pushSlowlyImpl ps = for_ ps \p -> do diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index 8fccb59d1c2..80ea2d25fde 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -39,7 +39,7 @@ spec = describe "NotificationSubsystem.Interpreter" do clients1 <- generate $ resize 3 arbitrary lotOfRecipients <- generate $ resize 24 arbitrary let push1 = - PushTo + Push { _pushConn = Nothing, _pushTransient = True, _pushRoute = V2.RouteDirect, @@ -49,7 +49,7 @@ spec = describe "NotificationSubsystem.Interpreter" do pushJson = payload1 } push2 = - PushTo + Push { _pushConn = Just connId2, _pushTransient = True, _pushRoute = V2.RouteAny, @@ -63,7 +63,7 @@ spec = describe "NotificationSubsystem.Interpreter" do duplicatePush = push2 duplicatePushWithPush1Recipients = push2 {_pushRecipients = _pushRecipients push1} largePush = push2 {_pushRecipients = lotOfRecipients} - pushes :: [PushToUser] = + pushes :: [Push] = [ push1, push2, duplicatePush, @@ -95,7 +95,7 @@ spec = describe "NotificationSubsystem.Interpreter" do (payload1, payload2) <- generate $ resize 1 arbitrary lotOfRecipients <- fromList <$> replicateM 31 (generate arbitrary) let pushBiggerThanFanoutLimit = - PushTo + Push { _pushConn = Nothing, _pushTransient = True, _pushRoute = V2.RouteDirect, @@ -105,7 +105,7 @@ spec = describe "NotificationSubsystem.Interpreter" do pushJson = payload1 } pushSmallerThanFanoutLimit = - PushTo + Push { _pushConn = Just connId2, _pushTransient = True, _pushRoute = V2.RouteAny, @@ -116,7 +116,7 @@ spec = describe "NotificationSubsystem.Interpreter" do :| [Recipient user22 V2.RecipientClientsAll], pushJson = payload2 } - pushes :: [PushToUser] = + pushes = [ pushBiggerThanFanoutLimit, pushSmallerThanFanoutLimit ] @@ -146,7 +146,7 @@ spec = describe "NotificationSubsystem.Interpreter" do (payload1, payload2) <- generate $ resize 1 arbitrary clients1 <- generate $ resize 3 arbitrary let push1 = - PushTo + Push { _pushConn = Nothing, _pushTransient = True, _pushRoute = V2.RouteDirect, @@ -156,7 +156,7 @@ spec = describe "NotificationSubsystem.Interpreter" do pushJson = payload1 } push2 = - PushTo + Push { _pushConn = Just connId2, _pushTransient = True, _pushRoute = V2.RouteAny, @@ -187,7 +187,7 @@ spec = describe "NotificationSubsystem.Interpreter" do timeout 100_000 (wait slowPushThread) `shouldReturn` Just () describe "toV2Push" do - it "does the transformation correctly" $ property \(pushToUser :: PushToUser) -> + it "does the transformation correctly" $ property \(pushToUser :: Push) -> let v2Push = toV2Push pushToUser in -- Statically determined v2Push._pushConnections === mempty @@ -206,13 +206,13 @@ spec = describe "NotificationSubsystem.Interpreter" do describe "chunkPushes" do it "allows empty push" $ property \limit -> - chunkPushes limit [] === ([] :: [[PushTo ()]]) - it "produces no empty chunks" $ property \limit (pushes :: [PushTo Int]) -> + 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 :: [PushTo Int]) -> + 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 :: [PushTo Int]) -> + 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]]) @@ -254,11 +254,11 @@ waitUntilPushes pushesRef n = do then pure ps else threadDelay 1000 >> waitUntilPushes pushesRef n -normalisePush :: PushTo a -> [PushTo a] +normalisePush :: Push -> [Push] normalisePush p = map (\r -> p {_pushRecipients = r :| []}) (toList (_pushRecipients p)) -sizeOfChunks :: [PushTo a] -> Natural +sizeOfChunks :: [Push] -> Natural sizeOfChunks = fromIntegral . sum . map (length . _pushRecipients) diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index f1e806935b1..0b373dc9574 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -126,7 +126,6 @@ import Wire.API.Team.Member import Wire.API.Team.Permission (Perm (AddRemoveConvMember, ModifyConvName)) import Wire.API.User qualified as User import Wire.NotificationSubsystem -import Wire.NotificationSubsystem qualified as NotificationSubsystem data NoChanges = NoChanges @@ -1114,7 +1113,7 @@ pushTypingIndicatorEvents :: pushTypingIndicatorEvents qusr tEvent users mcon qcnv ts = do let e = Event qcnv Nothing qusr tEvent (EdTyping ts) for_ (newPushLocal (qUnqualified qusr) (toJSONObject e) (userRecipient <$> users)) $ \p -> - NotificationSubsystem.push + pushNotifications [ p & pushConn .~ mcon & pushRoute .~ PushV2.RouteDirect diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 01923b2403d..f255c0d9658 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -84,7 +84,6 @@ import Wire.API.Team.Member import Wire.API.Team.Permission hiding (self) import Wire.API.User import Wire.NotificationSubsystem -import Wire.NotificationSubsystem qualified as NotificationSubsystem ---------------------------------------------------------------------------- -- Group conversations @@ -546,7 +545,7 @@ createConnectConversation lusr conn j = do let e = Event (tUntagged lcnv) Nothing (tUntagged lusr) now (EdConnect j) notifyCreatedConversation lusr conn c for_ (newPushLocal (tUnqualified lusr) (toJSONObject e) (localMemberToRecipient <$> Data.convLocalMembers c)) $ \p -> - NotificationSubsystem.push + pushNotifications [ p & pushRoute .~ PushV2.RouteDirect & pushConn .~ conn @@ -586,7 +585,7 @@ createConnectConversation lusr conn j = do t <- input let e = Event (tUntagged lcnv) Nothing (tUntagged lusr) t (EdConnect j) for_ (newPushLocal (tUnqualified lusr) (toJSONObject e) (localMemberToRecipient <$> Data.convLocalMembers conv)) $ \p -> - NotificationSubsystem.push + pushNotifications [ p & pushRoute .~ PushV2.RouteDirect & pushConn .~ conn @@ -672,7 +671,7 @@ notifyCreatedConversation lusr conn c = do throw FederationNotConfigured -- Notify local users - NotificationSubsystem.push =<< mapM (toPush now) (Data.convLocalMembers c) + pushNotifications =<< mapM (toPush now) (Data.convLocalMembers c) where route | Data.convType c == RegularConv = PushV2.RouteAny diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 0ff3f9fcb82..edd2d4a14d0 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -100,7 +100,6 @@ import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Team.Feature hiding (setStatus) import Wire.API.User.Client import Wire.NotificationSubsystem -import Wire.NotificationSubsystem qualified as NotificationSubsystem import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra @@ -400,7 +399,7 @@ rmUser lusr conn = do . set pushRoute PushV2.RouteDirect | otherwise -> pure Nothing - NotificationSubsystem.push (catMaybes pp) + 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/Push.hs b/services/galley/src/Galley/API/Push.hs index 32635056347..b501c804009 100644 --- a/services/galley/src/Galley/API/Push.hs +++ b/services/galley/src/Galley/API/Push.hs @@ -86,14 +86,14 @@ runMessagePush :: MessagePush -> Sem r () runMessagePush loc mqcnv mp@(MessagePush _ _ _ botMembers event) = do - push $ maybeToList $ toPush mp + pushNotifications $ maybeToList $ toPush mp for_ mqcnv $ \qcnv -> if tDomain loc /= qDomain qcnv then unless (null botMembers) $ do warn $ Log.msg ("Ignoring messages for local bots in a remote conversation" :: ByteString) . Log.field "conversation" (show qcnv) else deliverAndDeleteAsync (qUnqualified qcnv) (map (,event) botMembers) -toPush :: MessagePush -> Maybe PushToUser +toPush :: MessagePush -> Maybe Push toPush (MessagePush mconn mm rs _ event) = let usr = qUnqualified (evtFrom event) in newPush (Just usr) (toJSONObject event) rs diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 9e28856cd22..5b935dc9cb3 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -155,7 +155,6 @@ 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.NotificationSubsystem qualified as NotificationSubsystem import Wire.Sem.Paging qualified as E import Wire.Sem.Paging.Cassandra @@ -343,7 +342,7 @@ updateTeamH zusr zcon tid updateData = do admins <- E.getTeamAdmins tid let e = newEvent tid now (EdTeamUpdate updateData) let r = userRecipient zusr :| map userRecipient (filter (/= zusr) admins) - NotificationSubsystem.push [newPushLocal1 zusr (toJSONObject e) r & pushConn ?~ zcon & pushTransient .~ True] + pushNotifications [newPushLocal1 zusr (toJSONObject e) r & pushConn ?~ zcon & pushTransient .~ True] deleteTeam :: forall r. @@ -443,7 +442,7 @@ uncheckedDeleteTeam lusr zcon tid = do Data.unsetTeamLegalholdWhitelisted tid E.deleteTeam tid where - pushDeleteEvents :: [TeamMember] -> Event -> [PushToUser] -> Sem r () + pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Sem r () pushDeleteEvents membs e ue = do o <- inputs (view settings) let r = list1 (userRecipient (tUnqualified lusr)) (membersToRecipients (Just (tUnqualified lusr)) membs) @@ -454,15 +453,15 @@ 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 -> NotificationSubsystem.push [newPushLocal1 (tUnqualified lusr) (toJSONObject e) (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 - NotificationSubsystem.pushSlowly ue + pushNotificationsSlowly ue createConvDeleteEvents :: UTCTime -> [TeamMember] -> TeamConversation -> - ([PushToUser], [(BotMember, Conv.Event)]) -> - Sem r ([PushToUser], [(BotMember, Conv.Event)]) + ([Push], [(BotMember, Conv.Event)]) -> + Sem r ([Push], [(BotMember, Conv.Event)]) createConvDeleteEvents now teamMembs c (pp, ee) = do let qconvId = tUntagged $ qualifyAs lusr (c ^. conversationId) (bots, convMembs) <- localBotsAndUsers <$> E.getLocalMembers (c ^. conversationId) @@ -826,7 +825,7 @@ uncheckedUpdateTeamMember mlzusr mZcon tid newMember = do now <- input let event = newEvent tid now (EdMemberUpdate targetId (Just targetPermissions)) let pushPriv = newPush mZusr (toJSONObject event) (map userRecipient admins') - for_ pushPriv (\p -> NotificationSubsystem.push [p & pushConn .~ mZcon & pushTransient .~ True]) + for_ pushPriv (\p -> pushNotifications [p & pushConn .~ mZcon & pushTransient .~ True]) updateTeamMember :: forall r. @@ -1036,7 +1035,7 @@ uncheckedDeleteTeamMember lusr zcon tid remove (Left admins) = do let r = userRecipient <$> (tUnqualified lusr :| filter (/= (tUnqualified lusr)) admins) - NotificationSubsystem.push + pushNotifications [newPushLocal1 (tUnqualified lusr) (toJSONObject e) r & pushConn .~ zcon & pushTransient .~ True] uncheckedDeleteTeamMember lusr zcon tid remove (Right mems) = do now <- input @@ -1334,7 +1333,7 @@ addTeamMemberInternal tid origin originConn (ntmNewTeamMember -> new) = do let rs = case origin of Just o -> userRecipient <$> o :| filter (/= o) ((new ^. userId) : admins') Nothing -> userRecipient <$> new ^. userId :| admins' - NotificationSubsystem.push + pushNotifications [ newPushLocal1 (new ^. userId) (toJSONObject e) rs & pushConn .~ originConn & pushTransient .~ True @@ -1360,7 +1359,7 @@ finishCreateTeam team owner others zcon = do now <- input let e = newEvent (team ^. teamId) now (EdTeamCreate team) let r = membersToRecipients Nothing others - NotificationSubsystem.push + pushNotifications [ newPushLocal1 zusr (toJSONObject e) (userRecipient zusr :| r) & pushConn .~ zcon ] diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index bca9725b87e..e9085fca925 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -208,7 +208,7 @@ pushFeatureConfigEvent tid event = do . Log.msg @Text "Fanout limit exceeded. Events will not be sent." else do let recipients = membersToRecipients Nothing (memList ^. teamMembers) - push $ + pushNotifications $ maybeToList $ (newPush Nothing (toJSONObject event) recipients) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 69d5a611a22..c6195576758 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -142,7 +142,6 @@ import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.ServantProto (RawProto (..)) import Wire.API.User.Client import Wire.NotificationSubsystem -import Wire.NotificationSubsystem qualified as NotificationSubsystem acceptConv :: ( Member ConversationStore r, @@ -1576,7 +1575,7 @@ addBot lusr zcon b = do ) ) for_ (newPushLocal (tUnqualified lusr) (toJSONObject e) (localMemberToRecipient <$> users)) $ \p -> - NotificationSubsystem.push [p & pushConn ?~ zcon] + pushNotifications [p & pushConn ?~ zcon] E.deliverAsync (map (,e) (bm : bots)) pure e where @@ -1648,7 +1647,7 @@ rmBot lusr zcon b = do let evd = EdMembersLeaveRemoved (QualifiedUserIdList [tUntagged (qualifyAs lusr (botUserId (b ^. rmBotId)))]) let e = Event (tUntagged lcnv) Nothing (tUntagged lusr) t evd for_ (newPushLocal (tUnqualified lusr) (toJSONObject e) (localMemberToRecipient <$> users)) $ \p -> - NotificationSubsystem.push [p & pushConn .~ zcon] + 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 490538a7388..b4759ef59e2 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -89,7 +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 as NotificationSubsystem +import Wire.NotificationSubsystem type JSON = Media "application" "json" @@ -346,7 +346,7 @@ acceptOne2One lusr conv conn = do conv' <- if isJust (find ((tUnqualified lusr /=) . lmId) mems) then promote else pure conv let mems' = mems <> toList mm for_ (newPushLocal (tUnqualified lusr) (toJSONObject e) (localMemberToRecipient <$> mems')) $ \p -> - NotificationSubsystem.push [p & pushConn .~ conn & pushRoute .~ PushV2.RouteDirect] + pushNotifications [p & pushConn .~ conn & pushRoute .~ PushV2.RouteDirect] pure conv' {Data.convLocalMembers = mems'} _ -> throwS @'InvalidOperation where @@ -648,10 +648,10 @@ pushConversationEvent :: Sem r () pushConversationEvent conn e lusers bots = do for_ (newConversationEventPush e (fmap toList lusers)) $ \p -> - NotificationSubsystem.push [p & set pushConn conn] + pushNotifications [p & set pushConn conn] deliverAsync (map (,e) (toList bots)) -newConversationEventPush :: Event -> Local [UserId] -> Maybe PushToUser +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)) From d541e3ca8764165ba690d5a8f2cdb40631657feb Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 9 Jan 2024 13:29:46 +0100 Subject: [PATCH 22/43] NotificationSubsystem: Allow setting ApsData on pushes --- .../src/Gundeck/Types/Push/V2.hs | 10 ++++++---- .../src/Wire/NotificationSubsystem.hs | 6 ++++-- .../NotificationSubsystem/InterpreterSpec.hs | 20 +++++++++++++------ 3 files changed, 24 insertions(+), 12 deletions(-) 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/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index ccf037cdf1d..dccd5d9c2dd 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -27,9 +27,10 @@ data Push = Push _pushNativePriority :: Maybe Priority, pushOrigin :: Maybe UserId, _pushRecipients :: NonEmpty Recipient, - pushJson :: Object + pushJson :: Object, + _pushApsData :: Maybe ApsData } - deriving stock (Eq, Ord, Generic, Show) + deriving stock (Eq, Generic, Show) deriving (Arbitrary) via GenericUniform Push makeLenses ''Push @@ -47,6 +48,7 @@ newPush1 from e rr = _pushTransient = False, _pushRoute = RouteAny, _pushNativePriority = Nothing, + _pushApsData = Nothing, pushJson = e, pushOrigin = from, _pushRecipients = rr diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index 80ea2d25fde..3cfa57da5fb 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -38,6 +38,7 @@ spec = describe "NotificationSubsystem.Interpreter" do (payload1, payload2) <- generate $ resize 1 arbitrary clients1 <- generate $ resize 3 arbitrary lotOfRecipients <- generate $ resize 24 arbitrary + apsData <- generate arbitrary let push1 = Push { _pushConn = Nothing, @@ -46,7 +47,8 @@ spec = describe "NotificationSubsystem.Interpreter" do _pushNativePriority = Nothing, pushOrigin = Nothing, _pushRecipients = Recipient user1 (V2.RecipientClientsSome clients1) :| [], - pushJson = payload1 + pushJson = payload1, + _pushApsData = Nothing } push2 = Push @@ -58,7 +60,8 @@ spec = describe "NotificationSubsystem.Interpreter" do _pushRecipients = Recipient user21 V2.RecipientClientsAll :| [Recipient user22 V2.RecipientClientsAll], - pushJson = payload2 + pushJson = payload2, + _pushApsData = Just apsData } duplicatePush = push2 duplicatePushWithPush1Recipients = push2 {_pushRecipients = _pushRecipients push1} @@ -94,6 +97,7 @@ spec = describe "NotificationSubsystem.Interpreter" do (user21, user22) <- generate arbitrary (payload1, payload2) <- generate $ resize 1 arbitrary lotOfRecipients <- fromList <$> replicateM 31 (generate arbitrary) + apsData <- generate arbitrary let pushBiggerThanFanoutLimit = Push { _pushConn = Nothing, @@ -102,7 +106,8 @@ spec = describe "NotificationSubsystem.Interpreter" do _pushNativePriority = Nothing, pushOrigin = Nothing, _pushRecipients = lotOfRecipients, - pushJson = payload1 + pushJson = payload1, + _pushApsData = Nothing } pushSmallerThanFanoutLimit = Push @@ -114,7 +119,8 @@ spec = describe "NotificationSubsystem.Interpreter" do _pushRecipients = Recipient user21 V2.RecipientClientsAll :| [Recipient user22 V2.RecipientClientsAll], - pushJson = payload2 + pushJson = payload2, + _pushApsData = Just apsData } pushes = [ pushBiggerThanFanoutLimit, @@ -153,7 +159,8 @@ spec = describe "NotificationSubsystem.Interpreter" do _pushNativePriority = Nothing, pushOrigin = Nothing, _pushRecipients = Recipient user1 (V2.RecipientClientsSome clients1) :| [], - pushJson = payload1 + pushJson = payload1, + _pushApsData = Nothing } push2 = Push @@ -165,7 +172,8 @@ spec = describe "NotificationSubsystem.Interpreter" do _pushRecipients = Recipient user21 V2.RecipientClientsAll :| [Recipient user22 V2.RecipientClientsAll], - pushJson = payload2 + pushJson = payload2, + _pushApsData = Nothing } pushes = [push1, push2] From 56dfa4a024dd39c2c721ca3cc7aca4de736d5e1a Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 10 Jan 2024 12:36:09 +0100 Subject: [PATCH 23/43] Move notification subsystem defaults in the subsystem module --- .../Wire/NotificationSubsystem/Interpreter.hs | 16 +++++++++++++++- services/galley/src/Galley/Env.hs | 6 +++--- services/galley/src/Galley/Options.hs | 8 -------- 3 files changed, 18 insertions(+), 12 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index 5fc0798611c..6f3fe32a2b0 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -5,7 +5,8 @@ import Data.Aeson import Data.List.NonEmpty (nonEmpty) import Data.List1 (List1) import Data.List1 qualified as List1 -import Data.Range (Range, fromRange, unsafeRange) +import Data.Proxy +import Data.Range import Data.Set qualified as Set import Gundeck.Types hiding (Push (..), Recipient, newPush) import Gundeck.Types.Push.V2 qualified as V2 @@ -39,6 +40,19 @@ data NotificationSubsystemConfig = NotificationSubsystemConfig slowPushDelay :: Int } +defaultNotificationSubsystemConfig :: NotificationSubsystemConfig +defaultNotificationSubsystemConfig = + NotificationSubsystemConfig defaultFanoutLimit defaultChunkSize defaultSlowPushDelay + +defaultFanoutLimit :: Range 1 HardTruncationLimit Int32 +defaultFanoutLimit = toRange (Proxy @HardTruncationLimit) + +defaultChunkSize :: Natural +defaultChunkSize = 128 + +defaultSlowPushDelay :: Int +defaultSlowPushDelay = 20_000 + -- TODO: write a test for listtype pushImpl :: forall r. diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 3dd6bef4043..bc49c588a01 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -108,7 +108,7 @@ 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) @@ -122,7 +122,7 @@ gundeckAccessDetails env = notificationSubssystemConfig :: Env -> NotificationSubsystemConfig notificationSubssystemConfig env = NotificationSubsystemConfig - { chunkSize = 128, + { chunkSize = defaultChunkSize, fanoutLimit = currentFanoutLimit env._options, - slowPushDelay = 1000 * fromMaybe defDeleteConvThrottleMillis (env ^. options . O.settings . deleteConvThrottleMillis) + slowPushDelay = 1000 * fromMaybe defaultSlowPushDelay (env ^. options . O.settings . deleteConvThrottleMillis) } 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 From 270c5472d2bae3ebd6da0da7129ae1a82e02c18b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 29 Jan 2024 16:20:02 +0100 Subject: [PATCH 24/43] galley: Fix wrong merge --- services/galley/src/Galley/API/Teams.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 5b935dc9cb3..95272e6a832 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -1052,7 +1052,7 @@ uncheckedDeleteTeamMember lusr zcon tid remove (Right mems) = do let e = newEvent tid now (EdMemberLeave remove) let r = userRecipient (tUnqualified lusr) :| membersToRecipients (Just (tUnqualified lusr)) (mems ^. teamMembers) when (mems ^. teamMemberListType == ListComplete) $ do - NotificationSubsystem.push + pushNotifications [newPushLocal1 (tUnqualified lusr) (toJSONObject e) r & pushTransient .~ True] removeFromConvsAndPushConvLeaveEvent :: From 883041fb04572474798ccf8acd9684b711d99b58 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 9 Jan 2024 17:00:18 +0100 Subject: [PATCH 25/43] brig: Use NotificationSubsystem --- .../src/Wire/Sem/Concurrency.hs | 58 ++ nix/manual-overrides.nix | 1 + services/brig/brig.cabal | 3 + services/brig/default.nix | 6 + services/brig/src/Brig/API/Auth.hs | 66 ++- services/brig/src/Brig/API/Client.hs | 41 +- services/brig/src/Brig/API/Connection.hs | 40 +- .../brig/src/Brig/API/Connection/Remote.hs | 32 +- services/brig/src/Brig/API/Federation.hs | 26 +- services/brig/src/Brig/API/Internal.hs | 155 ++++- services/brig/src/Brig/API/Properties.hs | 15 +- services/brig/src/Brig/API/Public.hs | 142 ++++- services/brig/src/Brig/API/User.hs | 359 +++++++----- services/brig/src/Brig/App.hs | 19 +- .../brig/src/Brig/CanonicalInterpreter.hs | 21 +- services/brig/src/Brig/IO/Intra.hs | 549 +++++++----------- .../brig/src/Brig/InternalEvent/Process.hs | 45 +- services/brig/src/Brig/Run.hs | 3 +- services/brig/src/Brig/Team/API.hs | 35 +- services/brig/src/Brig/User/Auth.hs | 173 +++--- 20 files changed, 1077 insertions(+), 712 deletions(-) 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/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 ba1a112efef..df39e33d1e3 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -314,7 +314,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 @@ -362,6 +364,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..c8a9d6a4a58 100644 --- a/services/brig/src/Brig/API/Auth.hs +++ b/services/brig/src/Brig/API/Auth.hs @@ -43,13 +43,21 @@ import Network.HTTP.Types import Network.Wai.Utilities ((!>>)) import Network.Wai.Utilities.Error qualified as Wai import Polysemy +import Polysemy.Async +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, + Member Async r + ) => Maybe ClientId -> [Either Text SomeUserToken] -> Maybe (Either Text SomeAccessToken) -> @@ -61,22 +69,36 @@ 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, + Member Async 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, + Member Async 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 +116,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 +139,48 @@ 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 Async 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, + Member Async 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..540cbef4753 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.Async 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 Async 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 Async 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 Async 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 Async 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..fb30bcf06ea 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -57,6 +57,7 @@ import Data.Range import Data.UUID.V4 qualified as UUID import Imports import Polysemy (Member) +import Polysemy.Async (Async) 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,9 @@ ensureNotSameTeam self target = do createConnection :: ( Member FederationConfigStore r, - Member GalleyProvider r + Member GalleyProvider r, + Member NotificationSubsystem r, + Member Async r ) => Local UserId -> ConnId -> @@ -89,7 +93,11 @@ createConnection self con target = do target createConnectionToLocalUser :: - Member GalleyProvider r => + forall r. + ( Member GalleyProvider r, + Member NotificationSubsystem r, + Member Async r + ) => Local UserId -> ConnId -> Local UserId -> @@ -121,7 +129,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 +166,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 +213,10 @@ checkLegalholdPolicyConflict uid1 uid2 = do oneway status2 status1 updateConnection :: - Member FederationConfigStore r => + ( Member FederationConfigStore r, + Member NotificationSubsystem r, + Member Async r + ) => Local UserId -> Qualified UserId -> Relation -> @@ -225,6 +236,10 @@ 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 Async r + ) => -- | From Local UserId -> -- | To @@ -279,7 +294,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 +319,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) @@ -335,7 +350,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) @@ -347,7 +362,7 @@ updateConnectionToLocalUser self other newStatus conn = do lift $ traverse_ (wrapHttp . 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 +398,9 @@ mkRelationWithHistory oldRel = \case updateConnectionInternal :: forall r. + ( Member NotificationSubsystem r, + Member Async r + ) => UpdateConnectionsInternal -> ExceptT ConnectionError (AppT r) () updateConnectionInternal = \case @@ -414,7 +432,7 @@ updateConnectionInternal = \case traverse_ (wrapHttp . 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 = @@ -456,7 +474,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..32e3edc16cb 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -40,6 +40,7 @@ import Data.Qualified import Imports import Network.Wai.Utilities.Error import Polysemy +import Polysemy.Async import Wire.API.Connection import Wire.API.Federation.API.Brig ( NewConnectionResponse (..), @@ -48,6 +49,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 +147,9 @@ updateOne2OneConv lUsr _mbConn remoteUser mbConvId rel actor = do -- -- Returns the connection, and whether it was updated or not. transitionTo :: + ( Member NotificationSubsystem r, + Member Async r + ) => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -185,12 +190,22 @@ 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, + Member Async 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, + Member Async r + ) => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -246,6 +261,9 @@ performLocalAction self mzcon other mconnection action = do -- B connects & A reacts: Accepted Accepted -- @ performRemoteAction :: + ( Member NotificationSubsystem r, + Member Async r + ) => Local UserId -> Remote UserId -> Maybe UserConnection -> @@ -263,7 +281,10 @@ performRemoteAction self other mconnection action = do reaction _ = Nothing createConnectionToRemoteUser :: - Member FederationConfigStore r => + ( Member FederationConfigStore r, + Member NotificationSubsystem r, + Member Async r + ) => Local UserId -> ConnId -> Remote UserId -> @@ -275,7 +296,10 @@ createConnectionToRemoteUser self zcon other = do fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect updateConnectionToRemoteUser :: - Member FederationConfigStore r => + ( Member NotificationSubsystem r, + Member Async 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..3dbdf667573 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, (\\)) @@ -54,9 +53,9 @@ import Gundeck.Types.Push qualified as Push import Imports hiding ((\\)) import Network.Wai.Utilities.Error ((!>>)) import Polysemy +import Polysemy.Async 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 +71,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 +79,9 @@ type FederationAPI = "federation" :> BrigApi federationSitemap :: ( Member GalleyProvider r, Member (Concurrency 'Unsafe) r, - Member FederationConfigStore r + Member FederationConfigStore r, + Member NotificationSubsystem r, + Member Async r ) => ServerT FederationAPI (Handler r) federationSitemap = @@ -110,7 +112,10 @@ getFederationStatus _ request = do pure $ NonConnectedBackends (request.domains \\ fedDomains) sendConnectionAction :: - Member FederationConfigStore r => + ( Member FederationConfigStore r, + Member NotificationSubsystem r, + Member Async r + ) => Domain -> NewConnectionRequest -> Handler r NewConnectionResponse @@ -254,7 +259,14 @@ 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, + Member Async r + ) => + Domain -> + UserDeletedConnectionsNotification -> + (Handler r) EmptyResponse onUserDeleted origDomain udcn = lift $ do let deletedUser = toRemoteUnsafe origDomain udcn.user connections = udcn.connections @@ -263,8 +275,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..f97c332842f 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -76,11 +76,12 @@ import Imports hiding (head) import Network.Wai.Routing hiding (toList) import Network.Wai.Utilities as Utilities import Polysemy +import Polysemy.Async +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 +97,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 +111,12 @@ 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 Async r, + Member TinyLog r, + Member (Concurrency 'Unsafe) r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -148,7 +156,11 @@ 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 Async r, + Member TinyLog r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -188,7 +200,12 @@ accountAPI = teamsAPI :: ( Member GalleyProvider r, Member (UserPendingActivationStore p) r, - Member BlacklistStore r + Member BlacklistStore r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member Async r, + Member (Concurrency 'Unsafe) r, + Member TinyLog r ) => ServerT BrigIRoutes.TeamsAPI (Handler r) teamsAPI = @@ -209,7 +226,14 @@ 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, + Member Async r + ) => + ServerT BrigIRoutes.AuthAPI (Handler r) authAPI = Named @"legalhold-login" (callsFed (exposeAnnotations legalHoldLogin)) :<|> Named @"sso-login" (callsFed (exposeAnnotations ssoLogin)) @@ -304,7 +328,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 +372,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 Async r + ) => UserId -> Maybe Bool -> NewClient -> @@ -360,11 +388,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 Async 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 Async r + ) => + UserId -> + (Handler r) NoContent removeLegalHoldClientH uid = do lift $ NoContent <$ API.removeLegalHoldClient uid @@ -380,7 +421,11 @@ 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, + Member Async r ) => NewUser -> (Handler r) (Either RegisterError SelfProfile) @@ -398,7 +443,12 @@ createUserNoVerify uData = lift . runExceptT $ do pure . SelfProfile $ usr createUserNoVerifySpar :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member Async r, + Member TinyLog r + ) => NewUserSpar -> (Handler r) (Either CreateUserSparError SelfProfile) createUserNoVerifySpar uData = @@ -415,9 +465,16 @@ 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 Async 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 +582,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 Async 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 +627,24 @@ 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 Async 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 Async r + ) => + UpdateConnectionsInternal -> + (Handler r) NoContent updateConnectionInternalH updateConn = do API.updateConnectionInternal updateConn !>> connError pure NoContent @@ -613,21 +689,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 Async 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 Async 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 +769,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 Async r, + Member GalleyProvider 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 Async r, + Member GalleyProvider 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..9281347e43f 100644 --- a/services/brig/src/Brig/API/Properties.hs +++ b/services/brig/src/Brig/API/Properties.hs @@ -34,19 +34,22 @@ import Brig.Types.User.Event import Control.Error import Data.Id import Imports +import Polysemy +import Polysemy.Async import Wire.API.Properties +import Wire.NotificationSubsystem -setProperty :: UserId -> ConnId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError (AppT r) () +setProperty :: (Member NotificationSubsystem r, Member Async 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, Member Async 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, Member Async 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..c8cf53bbd4f 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -101,6 +101,8 @@ import Imports hiding (head) import Network.Socket (PortNumber) import Network.Wai.Utilities as Utilities import Polysemy +import Polysemy.Async +import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) import Servant qualified import Servant.OpenApi.Internal.Orphans () @@ -150,6 +152,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 +274,11 @@ 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 Async r, + Member TinyLog r ) => ServerT BrigAPI (Handler r) servantSitemap = @@ -437,7 +444,7 @@ servantSitemap = --------------------------------------------------------------------------- -- Handlers -setProperty :: UserId -> ConnId -> Public.PropertyKey -> Public.RawPropertyValue -> Handler r () +setProperty :: (Member NotificationSubsystem r, Member Async r) => UserId -> ConnId -> Public.PropertyKey -> Public.RawPropertyValue -> Handler r () setProperty u c key raw = do checkPropertyKey key val <- safeParsePropertyValue raw @@ -476,10 +483,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, Member Async 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, Member Async r) => UserId -> ConnId -> Handler r () clearProperties u c = lift (API.clearProperties u c) getProperty :: UserId -> Public.PropertyKey -> Handler r (Maybe Public.RawPropertyValue) @@ -555,7 +562,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 Async r + ) => UserId -> ConnId -> Public.NewClient -> @@ -674,7 +685,11 @@ 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, + Member Async r ) => Public.NewUserPublic -> (Handler r) (Either Public.RegisterError Public.RegisterSuccess) @@ -862,7 +877,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 Async r, + Member GalleyProvider 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 +905,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 Async 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 Async r + ) => + UserId -> + ConnId -> + (Handler r) (Maybe Public.RemoveIdentityError) removeEmail self conn = lift . exceptTToMaybe $ API.removeEmail self conn @@ -895,10 +933,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 Async 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 Async r + ) => + Local UserId -> + ConnId -> + Public.SupportedProtocolUpdate -> + Handler r () changeSupportedProtocols (tUnqualified -> u) conn (Public.SupportedProtocolUpdate prots) = lift $ API.changeSupportedProtocols u conn prots @@ -933,13 +987,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 Async r, + Member GalleyProvider 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 +1015,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 +1054,10 @@ customerExtensionCheckBlockedDomains email = do customerExtensionBlockedDomain domain createConnectionUnqualified :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member NotificationSubsystem r, + Member Async r + ) => UserId -> ConnId -> Public.ConnectionRequest -> @@ -1002,7 +1069,9 @@ createConnectionUnqualified self conn cr = do createConnection :: ( Member FederationConfigStore r, - Member GalleyProvider r + Member GalleyProvider r, + Member NotificationSubsystem r, + Member Async r ) => UserId -> ConnId -> @@ -1013,6 +1082,9 @@ createConnection self conn target = do API.createConnection lself conn target !>> connError updateLocalConnection :: + ( Member NotificationSubsystem r, + Member Async r + ) => UserId -> ConnId -> UserId -> @@ -1025,7 +1097,10 @@ 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 Async r + ) => UserId -> ConnId -> Qualified UserId -> @@ -1095,14 +1170,26 @@ 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, + Member Async 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 Async r, + Member TinyLog r + ) => + Public.VerifyDeleteUser -> + Handler r () verifyDeleteUser body = API.verifyDeleteUser body !>> deleteUserError updateUserEmail :: @@ -1137,7 +1224,12 @@ 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, + Member Async r + ) => Public.ActivationKey -> Public.ActivationCode -> (Handler r) ActivationRespWithStatus @@ -1147,7 +1239,12 @@ 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, + Member Async r + ) => Public.Activate -> (Handler r) ActivationRespWithStatus activateKey (Public.Activate tgt code dryrun) @@ -1226,7 +1323,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..e3ba8f5858f 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -1,4 +1,3 @@ --- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH -- @@ -93,8 +92,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 +136,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 +162,12 @@ import Galley.Types.Teams qualified as Team import Imports hiding (cs) import Network.Wai.Utilities import Polysemy +import Polysemy.Async +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,12 @@ verifyUniquenessAndCheckBlacklist uk = do createUserSpar :: forall r. - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member Async r, + Member TinyLog r + ) => NewUserSpar -> ExceptT CreateUserSparError (AppT r) CreateUserResult createUserSpar new = do @@ -250,7 +255,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 +287,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 +300,11 @@ 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, + Member Async r ) => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult @@ -346,12 +356,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 +475,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 +493,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 +508,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 +527,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 +547,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 +558,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 +590,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 Async r, + Member GalleyProvider 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 +617,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 Async 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 Async 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 Async 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 Async r, + Member GalleyProvider r + ) => + UserId -> + Maybe ConnId -> + Handle -> + AllowSCIMUpdates -> + ExceptT ChangeHandleError (AppT r) () changeHandle uid mconn hdl allowScim = do when (isBlacklistedHandle hdl) $ throwE ChangeHandleInvalid @@ -647,7 +705,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 +839,35 @@ changePhone u phone = do ------------------------------------------------------------------------------- -- Remove Email -removeEmail :: UserId -> ConnId -> ExceptT RemoveIdentityError (AppT r) () +removeEmail :: + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member Async 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 Async r + ) => + UserId -> + ConnId -> + ExceptT RemoveIdentityError (AppT r) () removePhone uid conn = do ident <- lift $ fetchUserIdentity uid case ident of @@ -806,14 +878,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 Async r + ) => + Either Email Phone -> + AppT r () revokeIdentity key = do let uk = either userEmailKey userPhoneKey key mu <- wrapClient $ Data.lookupKey uk @@ -838,7 +917,7 @@ revokeIdentity key = do (\(_ :: Email) -> Data.deleteEmail u) (\(_ :: Phone) -> Data.deletePhone u) uk - wrapHttpClient $ + liftSem $ Intra.onUserEvent u Nothing $ foldKey (emailRemoved u) @@ -849,57 +928,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 Async r, + Member (Concurrency 'Unsafe) 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 Async 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 +979,12 @@ mkUserEvent usrs status = -- Activation activate :: - (Member GalleyProvider r) => + ( Member GalleyProvider r, + Member TinyLog r, + Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member Async r + ) => ActivationTarget -> ActivationCode -> -- | The user for whom to activate the key. @@ -917,7 +993,12 @@ 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, + Member Async r + ) => ActivationTarget -> ActivationCode -> -- | The user for whom to activate the key. @@ -928,7 +1009,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 +1038,26 @@ 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, + Member Async 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 +1190,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 +1209,8 @@ beginPasswordReset target = do completePasswordReset :: ( Member CodeStore r, - Member PasswordResetStore r + Member PasswordResetStore r, + Member TinyLog r ) => PasswordResetIdentity -> PasswordResetCode -> @@ -1131,7 +1222,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 +1267,12 @@ 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, + Member Async r + ) => UserId -> Maybe PlainTextPassword6 -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) @@ -1210,9 +1306,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 +1318,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 +1349,46 @@ 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 Async 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 Async 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 +1396,7 @@ ensureAccountDeleted uid = do || conCount > 0 || notNull cookies then do - deleteAccount acc + liftSem $ deleteAccount acc pure AccountDeleted else pure AccountAlreadyDeleted @@ -1311,36 +1410,34 @@ 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 Async 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 - Intra.rmUser uid (userAssets user) - Data.lookupClients uid >>= mapM_ (Data.rmClient uid . clientId) - luid <- qualifyLocal uid + 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 <- 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..31d0830b793 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -36,6 +36,7 @@ module Brig.App cargohold, galley, gundeck, + gundeckEndpoint, federator, casClient, userTemplates, @@ -80,6 +81,7 @@ module Brig.App wrapHttpClientE, wrapHttp, HttpClientIO (..), + runHttpClientIO, liftSem, lowerAppT, temporaryGetEnv, @@ -159,6 +161,7 @@ data Env = Env { _cargohold :: RPC.Request, _galley :: RPC.Request, _gundeck :: RPC.Request, + _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, @@ -258,6 +261,7 @@ newEnv o = do { _cargohold = mkEndpoint $ Opt.cargohold o, _galley = mkEndpoint $ Opt.galley o, _gundeck = mkEndpoint $ Opt.gundeck o, + _gundeckEndpoint = Opt.gundeck o, _federator = Opt.federatorInternal o, _casClient = cas, _smtpEnv = emailSMTP, @@ -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/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 386033d74f4..f44d40aca8e 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -28,10 +28,17 @@ 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 hiding (httpManager) +import Wire.NotificationSubsystem +import Wire.NotificationSubsystem.Interpreter 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 +46,9 @@ import Wire.Sem.Now.IO (nowToIOAction) import Wire.Sem.Paging.Cassandra (InternalPaging) type BrigCanonicalEffects = - '[ FederationConfigStore, + '[ NotificationSubsystem, + GundeckAPIAccess, + FederationConfigStore, Jwk, PublicKeyBundle, JwtTools, @@ -48,6 +57,7 @@ type BrigCanonicalEffects = PasswordResetStore, UserPendingActivationStore InternalPaging, Now, + Delay, CodeStore, GalleyProvider, ServiceRPC 'Galley, @@ -56,7 +66,10 @@ type BrigCanonicalEffects = Error ParseException, Error SomeException, TinyLog, + Embed HttpClientIO, Embed IO, + Race, + Async, Concurrency 'Unsafe, Final IO ] @@ -66,7 +79,10 @@ runBrigToIO e (AppT ma) = do ( either throwM pure <=< ( runFinal . unsafelyPerformConcurrency + . asyncToIOFinal + . interpretRace . embedToFinal + . runEmbedded (runHttpClientIO e) . loggerToTinyLog (e ^. applog) . runError @SomeException . mapError @ParseException SomeException @@ -75,6 +91,7 @@ runBrigToIO e (AppT ma) = do . interpretServiceRpcToRpc @'Galley "galley" (e ^. galley) . interpretGalleyProviderToRPC (e ^. disabledVersions) . codeStoreToCassandra @Cas.Client + . runDelay . nowToIOAction (e ^. currentTime) . userPendingActivationStoreToCassandra . passwordResetStoreToCodeStore @@ -84,6 +101,8 @@ runBrigToIO e (AppT ma) = do . interpretPublicKeyBundle . interpretJwk . interpretFederationDomainConfig (e ^. settings . federationStrategy) (foldMap (remotesMapFromCfgFile . fmap (.federationDomainConfig)) (e ^. settings . federationDomainConfigs)) + . runGundeckAPIAccess (GundeckAccessDetails (e ^. gundeckEndpoint) (e ^. httpManager)) + . runNotificationSubsystemGundeck defaultNotificationSubsystemConfig ) ) $ runReaderT ma e diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 1735cd65d5c..e14f8813c1e 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -60,15 +60,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.Monad.Trans.Except (throwE) import Control.Retry import Data.Aeson hiding (json) import Data.Aeson.KeyMap qualified as KeyMap @@ -78,22 +76,22 @@ 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 Polysemy +import Polysemy.Async import System.Logger.Class as Log hiding (name, (.=)) -import System.Logger.Extended qualified as ExLog 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 +102,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 ----------------------------------------------------------------------------- -- 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 Async 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, + Member Async 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, Member Async 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 +228,48 @@ 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 Async 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, + Member Async 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,176 +299,66 @@ 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, Member Async 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 = + -- TODO: This async doesn't log errors if the push fails. Make it do so. + void . async $ 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 + pushNotifications pushes notifySelf :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m - ) => + (Member NotificationSubsystem r, Member Async 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 Async 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 = screenMemberList <$> getTeamContacts orig + teamContacts :: Sem r [UserId] + teamContacts = embed $ screenMemberList <$> getTeamContacts orig -- If we have a truncated team, we just ignore it all together to avoid very large fanouts -- screenMemberList :: Maybe Team.TeamMemberList -> [UserId] @@ -499,144 +369,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 +501,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 ------------------------------------------------------------------------------- @@ -931,7 +784,7 @@ lookupPushToken :: HasRequestId m ) => UserId -> - m [Push.PushToken] + m [V2.PushToken] lookupPushToken uid = do g <- view gundeck rsp <- @@ -943,7 +796,7 @@ lookupPushToken uid = do . zUser uid . expect2xx ) - responseJsonMaybe rsp & maybe (pure []) (pure . pushTokens) + responseJsonMaybe rsp & maybe (pure []) (pure . V2.pushTokens) ------------------------------------------------------------------------------- -- Team Management diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index 431d1cdb5a1..92a20205ae4 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,56 +28,57 @@ 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.Async +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, + Member Async r ) => InternalNotification -> - m () + Sem r () onEvent n = handleTimeout $ case n of DeleteClient clientId uid mcon -> do - rmClient uid clientId + embed $ rmClient uid clientId Intra.onClientEvent uid mcon (ClientRemoved uid clientId) DeleteUser uid -> do 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/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..522797b4cd4 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -57,7 +57,9 @@ 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.Async +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 +80,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 +162,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 +308,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 Async r, + Member (Concurrency 'Unsafe) r, + Member GalleyProvider 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 +325,12 @@ suspendTeam tid = do pure NoContent unsuspendTeam :: - (Member GalleyProvider r) => + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member Async r, + Member (Concurrency 'Unsafe) r, + Member GalleyProvider r + ) => TeamId -> (Handler r) NoContent unsuspendTeam tid = do @@ -324,7 +342,12 @@ unsuspendTeam tid = do -- Internal changeTeamAccountStatuses :: - (Member GalleyProvider r) => + ( Member (Embed HttpClientIO) r, + Member NotificationSubsystem r, + Member Async r, + Member (Concurrency 'Unsafe) r, + Member GalleyProvider r + ) => TeamId -> AccountStatus -> (Handler r) () @@ -333,7 +356,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..4a795c805fb 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,39 @@ import Data.ZAuth.Token qualified as ZAuth import Imports import Network.Wai.Utilities.Error ((!>>)) import Polysemy +import Polysemy.Async +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 +114,30 @@ 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, + Member Async 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 +147,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 +158,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 +226,63 @@ 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, + Member Async 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 Async 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 +296,21 @@ 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, + Member Async 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 +374,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 +393,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 +405,21 @@ 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, + Member Async 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 +434,12 @@ 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 Async r, + Member TinyLog r + ) => LegalHoldLogin -> CookieType -> ExceptT LegalHoldLoginError (AppT r) (Access ZAuth.LegalHoldUser) @@ -476,7 +453,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 :: From 80800b67c828f762f7d48d8c7d6a109c16b10e84 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 10 Jan 2024 13:40:27 +0100 Subject: [PATCH 26/43] Remove stale TODO --- .../src/Wire/NotificationSubsystem/Interpreter.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index 6f3fe32a2b0..1cd1a912404 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -53,7 +53,6 @@ defaultChunkSize = 128 defaultSlowPushDelay :: Int defaultSlowPushDelay = 20_000 --- TODO: write a test for listtype pushImpl :: forall r. ( Member (GundeckAPIAccess) r, From 25e37ad717190f27c3f677880a30011d6048ff70 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 11 Jan 2024 17:32:25 +0100 Subject: [PATCH 27/43] brig: Move more calls to gundeck into NotificationSubsystem --- libs/wire-subsystems/default.nix | 6 + .../src/Wire/GundeckAPIAccess.hs | 56 +++-- .../src/Wire/NotificationSubsystem.hs | 49 ++--- .../Wire/NotificationSubsystem/Internal.hs | 45 ++++ .../Wire/NotificationSubsystem/Interpreter.hs | 9 +- libs/wire-subsystems/src/Wire/Rpc.hs | 101 +++++++++ .../NotificationSubsystem/InterpreterSpec.hs | 8 + libs/wire-subsystems/wire-subsystems.cabal | 5 + services/brig/src/Brig/API/Client.hs | 13 +- services/brig/src/Brig/API/Connection.hs | 33 ++- services/brig/src/Brig/API/Internal.hs | 33 ++- services/brig/src/Brig/API/Public.hs | 37 +++- services/brig/src/Brig/API/User.hs | 34 ++- .../brig/src/Brig/CanonicalInterpreter.hs | 7 +- services/brig/src/Brig/IO/Intra.hs | 207 +++++++----------- .../brig/src/Brig/InternalEvent/Process.hs | 2 +- services/brig/src/Brig/Team/API.hs | 9 +- services/brig/src/Brig/User/EJPD.hs | 17 +- services/galley/src/Galley/App.hs | 4 +- services/galley/src/Galley/Effects.hs | 2 + services/galley/src/Galley/Env.hs | 8 - 21 files changed, 427 insertions(+), 258 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/NotificationSubsystem/Internal.hs create mode 100644 libs/wire-subsystems/src/Wire/Rpc.hs diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index 96d892b5d89..da155085ec1 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -8,7 +8,9 @@ , base , bilge , bytestring +, bytestring-conversion , containers +, exceptions , gitignoreSource , gundeck-types , hspec @@ -22,6 +24,7 @@ , polysemy-wire-zoo , QuickCheck , quickcheck-instances +, retry , text , types-common , wire-api @@ -34,7 +37,9 @@ mkDerivation { aeson base bilge + bytestring-conversion containers + exceptions gundeck-types http-client http-types @@ -43,6 +48,7 @@ mkDerivation { polysemy polysemy-wire-zoo QuickCheck + retry text types-common wire-api diff --git a/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs b/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs index c0a3d1cd1a8..a74a894f223 100644 --- a/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs @@ -2,35 +2,51 @@ module Wire.GundeckAPIAccess where -import Bilge as B -import Data.Text.Encoding +import Bilge +import Data.ByteString.Conversion +import Data.Id import Gundeck.Types.Push.V2 qualified as V2 import Imports -import Network.HTTP.Client qualified as HTTP +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 -data GundeckAccessDetails = GundeckAccessDetails - { endpoint :: Endpoint, - httpManager :: HTTP.Manager - } - -runGundeckAPIAccess :: Member (Embed IO) r => GundeckAccessDetails -> Sem (GundeckAPIAccess : r) a -> Sem r a -runGundeckAPIAccess accessDetails = interpret $ \case +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 - let req = - B.host (encodeUtf8 accessDetails.endpoint._host) - . B.port accessDetails.endpoint._port - . path "/i/push/v2" - . expect2xx - . chunkedReq - B.runHttpT accessDetails.httpManager $ - -- Because of 'expect2xx' we don't actually need to check the response - void $ - B.post req + -- No retries because the chunked request body cannot be replayed. + void . rpc "gundeck" ep $ + method DELETE + . 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 index dccd5d9c2dd..8d2af39678e 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -1,45 +1,22 @@ -{-# LANGUAGE TemplateHaskell #-} +module Wire.NotificationSubsystem + ( module Wire.NotificationSubsystem.Internal, + newPush1, + newPush, + newPushLocal, + newPushLocal1, + ) +where -module Wire.NotificationSubsystem where - -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 - -data NotificationSubsystem m a where - PushNotifications :: [Push] -> NotificationSubsystem m () - PushNotificationsSlowly :: [Push] -> NotificationSubsystem m () - -makeSem ''NotificationSubsystem +-- Importing like this hides only the constructors for NotificationSubsystem, +-- which are not very useful but have names which conflict with other +-- constructors +import Wire.NotificationSubsystem.Internal (NotificationSubsystem) +import Wire.NotificationSubsystem.Internal hiding (NotificationSubsystem (..)) newPush1 :: Maybe UserId -> Object -> NonEmpty Recipient -> Push newPush1 from e rr = diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Internal.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Internal.hs new file mode 100644 index 00000000000..5525def6723 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Internal.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.NotificationSubsystem.Internal where + +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 + +data NotificationSubsystem m a where + PushNotifications :: [Push] -> NotificationSubsystem m () + PushNotificationsSlowly :: [Push] -> NotificationSubsystem m () + UserDeleted :: UserId -> NotificationSubsystem m () + UnregisterPushClient :: UserId -> ClientId -> NotificationSubsystem m () + GetPushTokens :: UserId -> NotificationSubsystem m [PushToken] + +makeSem ''NotificationSubsystem diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index 1cd1a912404..adc38919ad8 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -16,8 +16,10 @@ import Polysemy import Polysemy.Async (Async, sequenceConcurrently) import Polysemy.Input import Wire.API.Team.Member -import Wire.GundeckAPIAccess +import Wire.GundeckAPIAccess (GundeckAPIAccess) +import Wire.GundeckAPIAccess qualified as GundeckAPIAccess import Wire.NotificationSubsystem +import Wire.NotificationSubsystem.Internal import Wire.Sem.Delay -- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. @@ -32,6 +34,9 @@ runNotificationSubsystemGundeck :: runNotificationSubsystemGundeck cfg = interpret $ \case PushNotifications ps -> runInputConst cfg $ pushImpl ps PushNotificationsSlowly ps -> runInputConst cfg $ pushSlowlyImpl ps + UserDeleted uid -> GundeckAPIAccess.userDeleted uid + UnregisterPushClient uid cid -> GundeckAPIAccess.unregisterPushClient uid cid + GetPushTokens uid -> GundeckAPIAccess.getPushTokens uid data NotificationSubsystemConfig = NotificationSubsystemConfig { fanoutLimit :: Range 1 HardTruncationLimit Int32, @@ -70,7 +75,7 @@ pushImpl ps = do removeIfLargeFanout currentFanoutLimit ps void $ sequenceConcurrently $ - pushV2 <$> pushes + GundeckAPIAccess.pushV2 <$> pushes removeIfLargeFanout :: Range n m Int32 -> [Push] -> [Push] removeIfLargeFanout limit = 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/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index 3cfa57da5fb..abcbe2ca57a 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -17,6 +17,7 @@ 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 @@ -254,6 +255,13 @@ runGundeckAPIAccessIORef :: Member (Embed IO) r => IORef [[V2.Push]] -> Sem (Gun 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 diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index cb9af5b639b..eea39f3e01c 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -70,14 +70,18 @@ library exposed-modules: Wire.GundeckAPIAccess Wire.NotificationSubsystem + Wire.NotificationSubsystem.Internal Wire.NotificationSubsystem.Interpreter + Wire.Rpc hs-source-dirs: src build-depends: , aeson , base , bilge + , bytestring-conversion , containers + , exceptions , gundeck-types , http-client , http-types @@ -86,6 +90,7 @@ library , polysemy , polysemy-wire-zoo , QuickCheck + , retry , text , types-common , wire-api diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 540cbef4753..161db97a6db 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -91,6 +91,7 @@ import Network.HTTP.Types.Method (StdMethod) import Network.Wai.Utilities import Polysemy import Polysemy.Async +import Polysemy.TinyLog import Servant (Link, ToHttpApiData (toUrlPiece)) import System.Logger.Class (field, msg, val, (~~)) import System.Logger.Class qualified as Log @@ -158,7 +159,8 @@ addClient :: ( Member GalleyProvider r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> Maybe ConnId -> @@ -173,7 +175,8 @@ addClientWithReAuthPolicy :: ( Member GalleyProvider r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => Data.ReAuthPolicy -> UserId -> @@ -475,7 +478,8 @@ pubClient c = legalHoldClientRequested :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> LegalHoldClientRequest -> @@ -493,7 +497,8 @@ legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPreke removeLegalHoldClient :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> AppT r () diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index fb30bcf06ea..6ef54055e89 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -56,8 +56,9 @@ import Data.Qualified import Data.Range import Data.UUID.V4 qualified as UUID import Imports -import Polysemy (Member) +import Polysemy import Polysemy.Async (Async) +import Polysemy.TinyLog import System.Logger.Class qualified as Log import System.Logger.Message import Wire.API.Connection hiding (relationWithHistory) @@ -78,7 +79,9 @@ createConnection :: ( Member FederationConfigStore r, Member GalleyProvider r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r, + Member (Embed HttpClientIO) r ) => Local UserId -> ConnId -> @@ -96,7 +99,9 @@ createConnectionToLocalUser :: forall r. ( Member GalleyProvider r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r, + Member (Embed HttpClientIO) r ) => Local UserId -> ConnId -> @@ -215,7 +220,9 @@ checkLegalholdPolicyConflict uid1 uid2 = do updateConnection :: ( Member FederationConfigStore r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r, + Member (Embed HttpClientIO) r ) => Local UserId -> Qualified UserId -> @@ -238,7 +245,9 @@ updateConnection self other newStatus conn = updateConnectionToLocalUser :: forall r. ( Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r, + Member (Embed HttpClientIO) r ) => -- | From Local UserId -> @@ -327,7 +336,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) @@ -338,7 +347,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 $ @@ -359,7 +368,7 @@ 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 $ liftSem $ Intra.onConnectionEvent (tUnqualified self) conn e2o @@ -399,7 +408,9 @@ mkRelationWithHistory oldRel = \case updateConnectionInternal :: forall r. ( Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r, + Member (Embed HttpClientIO) r ) => UpdateConnectionsInternal -> ExceptT ConnectionError (AppT r) () @@ -429,7 +440,7 @@ 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 liftSem $ Intra.onConnectionEvent (tUnqualified self) Nothing ev @@ -464,7 +475,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) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index f97c332842f..06bbac89fb3 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -137,7 +137,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 @@ -375,7 +375,8 @@ addClientInternalH :: ( Member GalleyProvider r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> Maybe Bool -> @@ -391,7 +392,8 @@ addClientInternalH usr mSkipReAuth new connId = do legalHoldClientRequestedH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> LegalHoldClientRequest -> @@ -402,7 +404,8 @@ legalHoldClientRequestedH targetUser clientRequest = do removeLegalHoldClientH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> (Handler r) NoContent @@ -585,7 +588,8 @@ getPasswordResetCode emailOrPhone = changeAccountStatusH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> AccountStatusUpdate -> @@ -630,7 +634,8 @@ getConnectionsStatus (ConnectionsStatusRequestV2 froms mtos mrel) = do revokeIdentityH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => Maybe Email -> Maybe Phone -> @@ -641,7 +646,9 @@ revokeIdentityH bade badp = throwStd (badRequest ("need exactly one of email, ph updateConnectionInternalH :: ( Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r, + Member (Embed HttpClientIO) r ) => UpdateConnectionsInternal -> (Handler r) NoContent @@ -692,7 +699,8 @@ addPhonePrefixH prefix = lift $ NoContent <$ API.phonePrefixInsert prefix updateSSOIdH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> UserSSOId -> @@ -708,7 +716,8 @@ updateSSOIdH uid ssoid = do deleteSSOIdH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> (Handler r) UpdateSSOIdResponse @@ -773,7 +782,8 @@ updateHandleH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member Async r, - Member GalleyProvider r + Member GalleyProvider r, + Member TinyLog r ) => UserId -> HandleUpdate -> @@ -787,7 +797,8 @@ updateUserNameH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member Async r, - Member GalleyProvider r + Member GalleyProvider r, + Member TinyLog r ) => UserId -> NameUpdate -> diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index c8cf53bbd4f..05833987ac7 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -565,7 +565,8 @@ addClient :: ( Member GalleyProvider r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> ConnId -> @@ -881,7 +882,8 @@ updateUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member Async r, - Member GalleyProvider r + Member GalleyProvider r, + Member TinyLog r ) => UserId -> ConnId -> @@ -908,7 +910,8 @@ changePhone u _ (Public.puPhone -> phone) = lift . exceptTToMaybe $ do removePhone :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> ConnId -> @@ -919,7 +922,8 @@ removePhone self conn = removeEmail :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> ConnId -> @@ -936,7 +940,8 @@ changePassword u cp = lift . exceptTToMaybe $ API.changePassword u cp changeLocale :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> ConnId -> @@ -947,7 +952,8 @@ changeLocale u conn l = lift $ API.changeLocale u conn l changeSupportedProtocols :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => Local UserId -> ConnId -> @@ -991,7 +997,8 @@ changeHandle :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member Async r, - Member GalleyProvider r + Member GalleyProvider r, + Member TinyLog r ) => UserId -> ConnId -> @@ -1056,7 +1063,9 @@ customerExtensionCheckBlockedDomains email = do createConnectionUnqualified :: ( Member GalleyProvider r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r, + Member (Embed HttpClientIO) r ) => UserId -> ConnId -> @@ -1071,7 +1080,9 @@ createConnection :: ( Member FederationConfigStore r, Member GalleyProvider r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r, + Member (Embed HttpClientIO) r ) => UserId -> ConnId -> @@ -1083,7 +1094,9 @@ createConnection self conn target = do updateLocalConnection :: ( Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r, + Member (Embed HttpClientIO) r ) => UserId -> ConnId -> @@ -1099,7 +1112,9 @@ updateLocalConnection self conn other (Public.cuStatus -> newStatus) = do updateConnection :: ( Member FederationConfigStore r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r, + Member (Embed HttpClientIO) r ) => UserId -> ConnId -> diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index e3ba8f5858f..619e994c1d4 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -594,7 +594,8 @@ updateUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member Async r, - Member GalleyProvider r + Member GalleyProvider r, + Member TinyLog r ) => UserId -> Maybe ConnId -> @@ -625,7 +626,8 @@ updateUser uid mconn uu allowScim = do changeLocale :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> ConnId -> @@ -641,7 +643,8 @@ changeLocale uid conn (LocaleUpdate loc) = do changeManagedBy :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> ConnId -> @@ -657,7 +660,8 @@ changeManagedBy uid conn (ManagedByUpdate mb) = do changeSupportedProtocols :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> ConnId -> @@ -674,7 +678,8 @@ changeHandle :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member Async r, - Member GalleyProvider r + Member GalleyProvider r, + Member TinyLog r ) => UserId -> Maybe ConnId -> @@ -842,7 +847,8 @@ changePhone u phone = do removeEmail :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> ConnId -> @@ -863,7 +869,8 @@ removeEmail uid conn = do removePhone :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> ConnId -> @@ -889,7 +896,8 @@ revokeIdentity :: forall r. ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => Either Email Phone -> AppT r () @@ -932,7 +940,8 @@ changeAccountStatus :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member Async r, - Member (Concurrency 'Unsafe) r + Member (Concurrency 'Unsafe) r, + Member TinyLog r ) => List1 UserId -> AccountStatus -> @@ -952,7 +961,8 @@ changeAccountStatus usrs status = do changeSingleAccountStatus :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> AccountStatus -> @@ -1429,8 +1439,8 @@ deleteAccount account@(accountUser -> user) = do Data.clearProperties uid tombstone <- mkTombstone Data.insertAccount tombstone Nothing Nothing False - Intra.rmUser uid (userAssets user) - Data.lookupClients uid >>= mapM_ (Data.rmClient uid . clientId) + Intra.rmUser uid (userAssets user) + embed $ Data.lookupClients uid >>= mapM_ (Data.rmClient uid . clientId) luid <- embed $ qualifyLocal uid Intra.onUserEvent uid Nothing (UserDeleted (tUntagged luid)) embed $ do diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index f44d40aca8e..1224bee3fc3 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -33,9 +33,10 @@ import Polysemy.Conc import Polysemy.Embed (runEmbedded) import Polysemy.Error (Error, mapError, runError) import Polysemy.TinyLog (TinyLog) -import Wire.GundeckAPIAccess hiding (httpManager) +import Wire.GundeckAPIAccess import Wire.NotificationSubsystem import Wire.NotificationSubsystem.Interpreter +import Wire.Rpc import Wire.Sem.Concurrency import Wire.Sem.Concurrency.IO import Wire.Sem.Delay @@ -48,6 +49,7 @@ import Wire.Sem.Paging.Cassandra (InternalPaging) type BrigCanonicalEffects = '[ NotificationSubsystem, GundeckAPIAccess, + Rpc, FederationConfigStore, Jwk, PublicKeyBundle, @@ -101,7 +103,8 @@ runBrigToIO e (AppT ma) = do . interpretPublicKeyBundle . interpretJwk . interpretFederationDomainConfig (e ^. settings . federationStrategy) (foldMap (remotesMapFromCfgFile . fmap (.federationDomainConfig)) (e ^. settings . federationDomainConfigs)) - . runGundeckAPIAccess (GundeckAccessDetails (e ^. gundeckEndpoint) (e ^. httpManager)) + . runRpcWithHttp (e ^. httpManager) (e ^. requestId) + . runGundeckAPIAccess (e ^. gundeckEndpoint) . runNotificationSubsystemGundeck defaultNotificationSubsystemConfig ) ) diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index e14f8813c1e..3de83aaf8b1 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 @@ -67,7 +65,6 @@ import Control.Error (ExceptT) import Control.Lens (view, (.~), (?~), (^.), (^?)) import Control.Monad.Catch import Control.Monad.Trans.Except (throwE) -import Control.Retry import Data.Aeson hiding (json) import Data.Aeson.KeyMap qualified as KeyMap import Data.Aeson.Lens @@ -89,7 +86,9 @@ import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Polysemy import Polysemy.Async -import System.Logger.Class as Log hiding (name, (.=)) +import Polysemy.TinyLog (TinyLog) +import System.Logger.Class (MonadLogger) +import System.Logger.Message hiding ((.=)) import Wire.API.Connection import Wire.API.Conversation hiding (Member) import Wire.API.Event.Conversation (Connect (Connect)) @@ -102,7 +101,8 @@ 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.NotificationSubsystem as NotificationSubsystem +import Wire.Sem.Logger qualified as Log ----------------------------------------------------------------------------- -- Event Handlers @@ -110,7 +110,8 @@ import Wire.NotificationSubsystem onUserEvent :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> Maybe ConnId -> @@ -230,7 +231,8 @@ journalEvent orig e = case e of dispatchNotifications :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => UserId -> Maybe ConnId -> @@ -340,7 +342,8 @@ notifyContacts :: forall r. ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r + Member Async r, + Member TinyLog r ) => List1 Event -> -- | Origin user. @@ -358,7 +361,7 @@ notifyContacts events orig route conn = do contacts = embed $ lookupContactList orig teamContacts :: Sem r [UserId] - teamContacts = embed $ screenMemberList <$> getTeamContacts orig + teamContacts = screenMemberList <$> getTeamContacts orig -- If we have a truncated team, we just ignore it all together to avoid very large fanouts -- screenMemberList :: Maybe Team.TeamMemberList -> [UserId] @@ -513,20 +516,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") @@ -537,12 +536,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 -> @@ -552,27 +554,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"] @@ -580,32 +576,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"] @@ -614,42 +613,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"] @@ -658,21 +649,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 :: @@ -701,35 +688,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 $ + NotificationSubsystem.userDeleted 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) ------------------------------------------------------------------------------- @@ -737,67 +721,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 [V2.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 . V2.pushTokens) - ------------------------------------------------------------------------------- -- Team Management @@ -805,19 +754,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 92a20205ae4..7a1cca0cf19 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -56,7 +56,7 @@ onEvent :: Sem r () onEvent n = handleTimeout $ case n of DeleteClient clientId uid mcon -> do - embed $ rmClient uid clientId + rmClient uid clientId Intra.onClientEvent uid mcon (ClientRemoved uid clientId) DeleteUser uid -> do Log.info $ diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 522797b4cd4..d3277ea8026 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -313,7 +313,8 @@ suspendTeam :: Member NotificationSubsystem r, Member Async r, Member (Concurrency 'Unsafe) r, - Member GalleyProvider r + Member GalleyProvider r, + Member TinyLog r ) => TeamId -> (Handler r) NoContent @@ -329,7 +330,8 @@ unsuspendTeam :: Member NotificationSubsystem r, Member Async r, Member (Concurrency 'Unsafe) r, - Member GalleyProvider r + Member GalleyProvider r, + Member TinyLog r ) => TeamId -> (Handler r) NoContent @@ -346,7 +348,8 @@ changeTeamAccountStatuses :: Member NotificationSubsystem r, Member Async r, Member (Concurrency 'Unsafe) r, - Member GalleyProvider r + Member GalleyProvider r, + Member TinyLog r ) => TeamId -> AccountStatus -> diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index fea8e51a37a..e555583a2b3 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 as 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 (NotificationSubsystem.getPushTokens uid) mbContacts <- if includeContacts' diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 55000a0787d..a4f780bdb78 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -110,6 +110,7 @@ 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 @@ -284,7 +285,8 @@ evalGalley e = . interpretBackendNotificationQueueAccess . interpretFederatorAccess . interpretExternalAccess - . runGundeckAPIAccess (gundeckAccessDetails e) + . runRpcWithHttp (e ^. manager) (e ^. reqId) + . runGundeckAPIAccess (e ^. options . gundeck) . runNotificationSubsystemGundeck (notificationSubssystemConfig e) . interpretSparAccess . interpretBrigAccess diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index d34849009c4..fbca2a7e3a3 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -99,6 +99,7 @@ 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 @@ -108,6 +109,7 @@ type GalleyEffects1 = SparAccess, NotificationSubsystem, GundeckAPIAccess, + Rpc, ExternalAccess, FederatorAccess, BackendNotificationQueueAccess, diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index bc49c588a01..ef183df8665 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -44,7 +44,6 @@ import Util.Options import Wire.API.MLS.Credential import Wire.API.MLS.Keys import Wire.API.Team.Member -import Wire.GundeckAPIAccess import Wire.NotificationSubsystem.Interpreter data DeleteItem = TeamItem TeamId UserId (Maybe ConnId) @@ -112,13 +111,6 @@ currentFanoutLimit o = do let maxSize = fromIntegral (o ^. (O.settings . maxTeamSize)) unsafeRange (min maxSize optFanoutLimit) -gundeckAccessDetails :: Env -> GundeckAccessDetails -gundeckAccessDetails env = - GundeckAccessDetails - { endpoint = env ^. options . gundeck, - httpManager = env._manager - } - notificationSubssystemConfig :: Env -> NotificationSubsystemConfig notificationSubssystemConfig env = NotificationSubsystemConfig From 8703a31d66f16c8f204caac08ee24dc89bfe9351 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 11 Jan 2024 17:43:48 +0100 Subject: [PATCH 28/43] brig: Remove unused gundeck stuff --- services/brig/src/Brig/App.hs | 3 --- services/brig/src/Brig/RPC.hs | 7 ------- 2 files changed, 10 deletions(-) diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 31d0830b793..a4204846bd0 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -35,7 +35,6 @@ module Brig.App stompEnv, cargohold, galley, - gundeck, gundeckEndpoint, federator, casClient, @@ -160,7 +159,6 @@ schemaVersion = Migrations.lastSchemaVersion data Env = Env { _cargohold :: RPC.Request, _galley :: RPC.Request, - _gundeck :: RPC.Request, _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, @@ -260,7 +258,6 @@ newEnv o = do Env { _cargohold = mkEndpoint $ Opt.cargohold o, _galley = mkEndpoint $ Opt.galley o, - _gundeck = mkEndpoint $ Opt.gundeck o, _gundeckEndpoint = Opt.gundeck o, _federator = Opt.federatorInternal o, _casClient = cas, diff --git a/services/brig/src/Brig/RPC.hs b/services/brig/src/Brig/RPC.hs index 2aac7baa915..c5ed46304b5 100644 --- a/services/brig/src/Brig/RPC.hs +++ b/services/brig/src/Brig/RPC.hs @@ -73,13 +73,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 -> From f7b66d44e26d2a07c95a127c55236e9dd67fe9d9 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 11 Jan 2024 19:04:47 +0100 Subject: [PATCH 29/43] brig: Use Wire.Rpc instead of brig's RPC effect --- services/brig/brig.cabal | 4 - services/brig/src/Brig/App.hs | 7 +- .../brig/src/Brig/CanonicalInterpreter.hs | 16 +- .../src/Brig/Effects/GalleyProvider/RPC.hs | 279 ++++++++++-------- services/brig/src/Brig/Effects/RPC.hs | 20 -- services/brig/src/Brig/Effects/RPC/IO.hs | 38 --- services/brig/src/Brig/Effects/ServiceRPC.hs | 20 -- .../brig/src/Brig/Effects/ServiceRPC/IO.hs | 18 -- services/brig/src/Brig/IO/Intra.hs | 1 + services/brig/src/Brig/Provider/RPC.hs | 1 + services/brig/src/Brig/RPC.hs | 21 +- 11 files changed, 173 insertions(+), 252 deletions(-) delete mode 100644 services/brig/src/Brig/Effects/RPC.hs delete mode 100644 services/brig/src/Brig/Effects/RPC/IO.hs delete mode 100644 services/brig/src/Brig/Effects/ServiceRPC.hs delete mode 100644 services/brig/src/Brig/Effects/ServiceRPC/IO.hs diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index df39e33d1e3..5c86b737589 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -133,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 diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index a4204846bd0..80c938c5d06 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -35,6 +35,7 @@ module Brig.App stompEnv, cargohold, galley, + galleyEndpoint, gundeckEndpoint, federator, casClient, @@ -159,6 +160,7 @@ schemaVersion = Migrations.lastSchemaVersion data Env = Env { _cargohold :: RPC.Request, _galley :: 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, @@ -258,6 +260,7 @@ newEnv o = do Env { _cargohold = mkEndpoint $ Opt.cargohold o, _galley = mkEndpoint $ Opt.galley o, + _galleyEndpoint = Opt.galley o, _gundeckEndpoint = Opt.gundeck o, _federator = Opt.federatorInternal o, _casClient = cas, @@ -306,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 diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 1224bee3fc3..5a5cab91349 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) @@ -49,7 +45,6 @@ import Wire.Sem.Paging.Cassandra (InternalPaging) type BrigCanonicalEffects = '[ NotificationSubsystem, GundeckAPIAccess, - Rpc, FederationConfigStore, Jwk, PublicKeyBundle, @@ -62,8 +57,7 @@ type BrigCanonicalEffects = Delay, CodeStore, GalleyProvider, - ServiceRPC 'Galley, - RPC, + Rpc, Embed Cas.Client, Error ParseException, Error SomeException, @@ -89,9 +83,8 @@ runBrigToIO e (AppT ma) = do . 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) @@ -103,7 +96,6 @@ runBrigToIO e (AppT ma) = do . interpretPublicKeyBundle . interpretJwk . interpretFederationDomainConfig (e ^. settings . federationStrategy) (foldMap (remotesMapFromCfgFile . fmap (.federationDomainConfig)) (e ^. settings . federationDomainConfigs)) - . runRpcWithHttp (e ^. httpManager) (e ^. requestId) . runGundeckAPIAccess (e ^. gundeckEndpoint) . runNotificationSubsystemGundeck defaultNotificationSubsystemConfig ) 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 3de83aaf8b1..36bd431486c 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -102,6 +102,7 @@ import Wire.API.Team.Member qualified as Team import Wire.API.User import Wire.API.User.Client import Wire.NotificationSubsystem as NotificationSubsystem +import Wire.Rpc import Wire.Sem.Logger qualified as Log ----------------------------------------------------------------------------- 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 c5ed46304b5..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 -> From 9ca2265f0c87d03989715b7343cf42ce2f534faf Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 11 Jan 2024 19:13:57 +0100 Subject: [PATCH 30/43] Changelog --- changelog.d/5-internal/notification-subsystem | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/notification-subsystem 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 From 6f7752f2d7beb20476fdf848bf8395c1860e537b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 29 Jan 2024 16:38:28 +0100 Subject: [PATCH 31/43] Comments and better names --- .../src/Wire/NotificationSubsystem/Internal.hs | 6 +++++- .../src/Wire/NotificationSubsystem/Interpreter.hs | 2 +- services/brig/src/Brig/IO/Intra.hs | 2 +- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Internal.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Internal.hs index 5525def6723..5a71bd3de65 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Internal.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Internal.hs @@ -35,10 +35,14 @@ data Push = 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 () - UserDeleted :: UserId -> NotificationSubsystem m () + CleanupUser :: UserId -> NotificationSubsystem m () UnregisterPushClient :: UserId -> ClientId -> NotificationSubsystem m () GetPushTokens :: UserId -> NotificationSubsystem m [PushToken] diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index adc38919ad8..8cf1f055052 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -34,7 +34,7 @@ runNotificationSubsystemGundeck :: runNotificationSubsystemGundeck cfg = interpret $ \case PushNotifications ps -> runInputConst cfg $ pushImpl ps PushNotificationsSlowly ps -> runInputConst cfg $ pushSlowlyImpl ps - UserDeleted uid -> GundeckAPIAccess.userDeleted uid + CleanupUser uid -> GundeckAPIAccess.userDeleted uid UnregisterPushClient uid cid -> GundeckAPIAccess.unregisterPushClient uid cid GetPushTokens uid -> GundeckAPIAccess.getPushTokens uid diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 36bd431486c..7a4c0e19c79 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -701,7 +701,7 @@ rmUser usr asts = do remote "gundeck" . field "user" (toByteString usr) . msg (val "remove user") - NotificationSubsystem.userDeleted usr + NotificationSubsystem.cleanupUser usr Log.debug $ remote "galley" . field "user" (toByteString usr) From 139cbd5c800c24646a2085d7caa6a34ddac7839e Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 6 Feb 2024 10:54:38 +0100 Subject: [PATCH 32/43] NotificationSubsystem: Remove internal module, export everything --- .../src/Wire/NotificationSubsystem.hs | 56 ++++++++++++++----- .../Wire/NotificationSubsystem/Internal.hs | 49 ---------------- .../Wire/NotificationSubsystem/Interpreter.hs | 1 - libs/wire-subsystems/wire-subsystems.cabal | 1 - 4 files changed, 43 insertions(+), 64 deletions(-) delete mode 100644 libs/wire-subsystems/src/Wire/NotificationSubsystem/Internal.hs diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index 8d2af39678e..a2a381d7d01 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -1,22 +1,52 @@ -module Wire.NotificationSubsystem - ( module Wire.NotificationSubsystem.Internal, - newPush1, - newPush, - newPushLocal, - newPushLocal1, - ) -where +{-# LANGUAGE TemplateHaskell #-} +module Wire.NotificationSubsystem where + +import Control.Lens (makeLenses) import Data.Aeson import Data.Id import Data.List.NonEmpty (NonEmpty ((:|))) import Gundeck.Types hiding (Push (..), Recipient, newPush) import Imports --- Importing like this hides only the constructors for NotificationSubsystem, --- which are not very useful but have names which conflict with other --- constructors -import Wire.NotificationSubsystem.Internal (NotificationSubsystem) -import Wire.NotificationSubsystem.Internal hiding (NotificationSubsystem (..)) +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 () + 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 = diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Internal.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Internal.hs deleted file mode 100644 index 5a71bd3de65..00000000000 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Internal.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Wire.NotificationSubsystem.Internal where - -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 () - CleanupUser :: UserId -> NotificationSubsystem m () - UnregisterPushClient :: UserId -> ClientId -> NotificationSubsystem m () - GetPushTokens :: UserId -> NotificationSubsystem m [PushToken] - -makeSem ''NotificationSubsystem diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index 8cf1f055052..e0ce3ea85a6 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -19,7 +19,6 @@ import Wire.API.Team.Member import Wire.GundeckAPIAccess (GundeckAPIAccess) import Wire.GundeckAPIAccess qualified as GundeckAPIAccess import Wire.NotificationSubsystem -import Wire.NotificationSubsystem.Internal import Wire.Sem.Delay -- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index eea39f3e01c..9ca624388d5 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -70,7 +70,6 @@ library exposed-modules: Wire.GundeckAPIAccess Wire.NotificationSubsystem - Wire.NotificationSubsystem.Internal Wire.NotificationSubsystem.Interpreter Wire.Rpc From a93e7f5aba4448086e99fbbfbd7e9f5d66ef44b4 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 6 Feb 2024 11:00:00 +0100 Subject: [PATCH 33/43] Remove unnecessary qualification --- services/brig/src/Brig/IO/Intra.hs | 4 ++-- services/brig/src/Brig/User/EJPD.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 7a4c0e19c79..3ce9929646a 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -101,7 +101,7 @@ 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 as NotificationSubsystem +import Wire.NotificationSubsystem import Wire.Rpc import Wire.Sem.Logger qualified as Log @@ -701,7 +701,7 @@ rmUser usr asts = do remote "gundeck" . field "user" (toByteString usr) . msg (val "remove user") - NotificationSubsystem.cleanupUser usr + cleanupUser usr Log.debug $ remote "galley" . field "user" (toByteString usr) diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index e555583a2b3..ae7538b6b5f 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -41,7 +41,7 @@ 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 as NotificationSubsystem +import Wire.NotificationSubsystem ejpdRequest :: forall r. @@ -67,7 +67,7 @@ ejpdRequest includeContacts (EJPDRequestBody handles) = do let uid = userId target ptoks <- - PushTok.tokenText . view PushTok.token <$$> liftSem (NotificationSubsystem.getPushTokens uid) + PushTok.tokenText . view PushTok.token <$$> liftSem (getPushTokens uid) mbContacts <- if includeContacts' From 7c738757a65f70d95f4b03d90d1e2219ce59a78b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 6 Feb 2024 11:12:20 +0100 Subject: [PATCH 34/43] NotificationSubsystem.Interpreter: make slowPushDelay a Natural --- .../src/Wire/NotificationSubsystem/Interpreter.hs | 6 +++--- .../test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs | 4 ++-- services/galley/src/Galley/Options.hs | 3 ++- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index e0ce3ea85a6..ecfa9ac30ba 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -41,7 +41,7 @@ data NotificationSubsystemConfig = NotificationSubsystemConfig { fanoutLimit :: Range 1 HardTruncationLimit Int32, chunkSize :: Natural, -- | Microseconds - slowPushDelay :: Int + slowPushDelay :: Natural } defaultNotificationSubsystemConfig :: NotificationSubsystemConfig @@ -54,7 +54,7 @@ defaultFanoutLimit = toRange (Proxy @HardTruncationLimit) defaultChunkSize :: Natural defaultChunkSize = 128 -defaultSlowPushDelay :: Int +defaultSlowPushDelay :: Natural defaultSlowPushDelay = 20_000 pushImpl :: @@ -136,5 +136,5 @@ pushSlowlyImpl :: Sem r () pushSlowlyImpl ps = for_ ps \p -> do - delay =<< inputs slowPushDelay + delay =<< inputs (fromIntegral . slowPushDelay) pushImpl [p] diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index abcbe2ca57a..fbce0edcb2a 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -185,11 +185,11 @@ spec = describe "NotificationSubsystem.Interpreter" do runMockStackWithControlledDelay mockConfig delayControl actualPushesRef $ pushSlowlyImpl pushes - putMVar delayControl mockConfig.slowPushDelay + putMVar delayControl (fromIntegral mockConfig.slowPushDelay) actualPushes1 <- timeout 100_000 $ (waitUntilPushes actualPushesRef 1) actualPushes1 `shouldBe` Just [[toV2Push push1]] - putMVar delayControl mockConfig.slowPushDelay + putMVar delayControl (fromIntegral mockConfig.slowPushDelay) actualPushes2 <- timeout 100_000 $ (waitUntilPushes actualPushesRef 2) actualPushes2 `shouldBe` Just [[toV2Push push1], [toV2Push push2]] diff --git a/services/galley/src/Galley/Options.hs b/services/galley/src/Galley/Options.hs index 499b85949e6..c14514b9c61 100644 --- a/services/galley/src/Galley/Options.hs +++ b/services/galley/src/Galley/Options.hs @@ -68,6 +68,7 @@ import Galley.Keys import Galley.Types.Teams import Imports import Network.AMQP.Extended +import Numeric.Natural import System.Logger.Extended (Level, LogFormat) import Util.Options hiding (endpoint) import Util.Options.Common @@ -121,7 +122,7 @@ data Settings = Settings -- | Throttling: limits to concurrent deletion events _concurrentDeletionEvents :: !(Maybe Int), -- | Throttling: delay between sending events upon team deletion - _deleteConvThrottleMillis :: !(Maybe Int), + _deleteConvThrottleMillis :: !(Maybe Natural), -- | FederationDomain is required, even when not wanting to federate with other backends -- (in that case the 'allowedDomains' can be set to empty in Federator) -- Federation domain is used to qualify local IDs and handles, From e4ea64003d0730bd0cc9d63f1f5a6ee649a21572 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 6 Feb 2024 11:18:17 +0100 Subject: [PATCH 35/43] Explain threadDelay --- .../test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index fbce0edcb2a..9f219e785d3 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -266,6 +266,8 @@ runGundeckAPIAccessIORef pushesRef = 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 From 5a14339448ed31ee7fbeda4dff17c6c62613eca4 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 6 Feb 2024 12:15:25 +0100 Subject: [PATCH 36/43] NotificationSubsystem: Abstract pushing notifications asynchronously --- .../src/Wire/NotificationSubsystem.hs | 3 ++ .../Wire/NotificationSubsystem/Interpreter.hs | 14 +++++++- services/brig/src/Brig/API/Auth.hs | 14 +++----- services/brig/src/Brig/API/Client.hs | 5 --- services/brig/src/Brig/API/Connection.hs | 6 ---- .../brig/src/Brig/API/Connection/Remote.hs | 21 +++-------- services/brig/src/Brig/API/Federation.hs | 10 ++---- services/brig/src/Brig/API/Internal.hs | 22 ++---------- services/brig/src/Brig/API/Properties.hs | 7 ++-- services/brig/src/Brig/API/Public.hs | 32 ++++------------- services/brig/src/Brig/API/User.hs | 30 +++------------- services/brig/src/Brig/IO/Intra.hs | 35 +++++++------------ .../brig/src/Brig/InternalEvent/Process.hs | 4 +-- services/brig/src/Brig/Team/API.hs | 4 --- services/brig/src/Brig/User/Auth.hs | 15 +++----- 15 files changed, 63 insertions(+), 159 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index a2a381d7d01..3d7a657e309 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -42,6 +42,9 @@ data NotificationSubsystem m a where -- | 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. + PushNotificationsAsync :: [Push] -> NotificationSubsystem m () CleanupUser :: UserId -> NotificationSubsystem m () UnregisterPushClient :: UserId -> ClientId -> NotificationSubsystem m () GetPushTokens :: UserId -> NotificationSubsystem m [PushToken] diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index ecfa9ac30ba..87a418b607c 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -13,7 +13,7 @@ import Gundeck.Types.Push.V2 qualified as V2 import Imports import Numeric.Natural (Natural) import Polysemy -import Polysemy.Async (Async, sequenceConcurrently) +import Polysemy.Async (Async, async, sequenceConcurrently) import Polysemy.Input import Wire.API.Team.Member import Wire.GundeckAPIAccess (GundeckAPIAccess) @@ -33,6 +33,7 @@ runNotificationSubsystemGundeck :: 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 @@ -57,6 +58,17 @@ defaultChunkSize = 128 defaultSlowPushDelay :: Natural defaultSlowPushDelay = 20_000 +-- TODO: This async doesn't log errors if the push fails. Make it do so. +pushAsyncImpl :: + forall r. + ( Member (GundeckAPIAccess) r, + Member (Input NotificationSubsystemConfig) r, + Member (Async) r + ) => + [Push] -> + Sem r () +pushAsyncImpl ps = void $ async $ pushImpl ps + pushImpl :: forall r. ( Member (GundeckAPIAccess) r, diff --git a/services/brig/src/Brig/API/Auth.hs b/services/brig/src/Brig/API/Auth.hs index c8a9d6a4a58..6b0d93aa56e 100644 --- a/services/brig/src/Brig/API/Auth.hs +++ b/services/brig/src/Brig/API/Auth.hs @@ -43,7 +43,6 @@ import Network.HTTP.Types import Network.Wai.Utilities ((!>>)) import Network.Wai.Utilities.Error qualified as Wai import Polysemy -import Polysemy.Async import Polysemy.TinyLog (TinyLog) import Wire.API.User import Wire.API.User.Auth hiding (access) @@ -55,8 +54,7 @@ import Wire.NotificationSubsystem accessH :: ( Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => Maybe ClientId -> [Either Text SomeUserToken] -> @@ -72,8 +70,7 @@ access :: ( TokenPair u a, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => Maybe ClientId -> NonEmpty (Token u) -> @@ -93,8 +90,7 @@ login :: ( Member GalleyProvider r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => Login -> Maybe Bool -> @@ -154,7 +150,6 @@ legalHoldLogin :: ( Member GalleyProvider r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => LegalHoldLogin -> @@ -167,8 +162,7 @@ legalHoldLogin lhl = do ssoLogin :: ( Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => SsoLogin -> Maybe Bool -> diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 161db97a6db..529b81ad0e9 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -90,7 +90,6 @@ import Imports import Network.HTTP.Types.Method (StdMethod) import Network.Wai.Utilities import Polysemy -import Polysemy.Async import Polysemy.TinyLog import Servant (Link, ToHttpApiData (toUrlPiece)) import System.Logger.Class (field, msg, val, (~~)) @@ -159,7 +158,6 @@ addClient :: ( Member GalleyProvider r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -175,7 +173,6 @@ addClientWithReAuthPolicy :: ( Member GalleyProvider r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => Data.ReAuthPolicy -> @@ -478,7 +475,6 @@ pubClient c = legalHoldClientRequested :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -497,7 +493,6 @@ legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPreke removeLegalHoldClient :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 6ef54055e89..7debfb2ed6e 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -57,7 +57,6 @@ import Data.Range import Data.UUID.V4 qualified as UUID import Imports import Polysemy -import Polysemy.Async (Async) import Polysemy.TinyLog import System.Logger.Class qualified as Log import System.Logger.Message @@ -79,7 +78,6 @@ createConnection :: ( Member FederationConfigStore r, Member GalleyProvider r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r, Member (Embed HttpClientIO) r ) => @@ -99,7 +97,6 @@ createConnectionToLocalUser :: forall r. ( Member GalleyProvider r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r, Member (Embed HttpClientIO) r ) => @@ -220,7 +217,6 @@ checkLegalholdPolicyConflict uid1 uid2 = do updateConnection :: ( Member FederationConfigStore r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r, Member (Embed HttpClientIO) r ) => @@ -245,7 +241,6 @@ updateConnection self other newStatus conn = updateConnectionToLocalUser :: forall r. ( Member NotificationSubsystem r, - Member Async r, Member TinyLog r, Member (Embed HttpClientIO) r ) => @@ -408,7 +403,6 @@ mkRelationWithHistory oldRel = \case updateConnectionInternal :: forall r. ( Member NotificationSubsystem r, - Member Async r, Member TinyLog r, Member (Embed HttpClientIO) r ) => diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 32e3edc16cb..96c446d603a 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -40,7 +40,6 @@ import Data.Qualified import Imports import Network.Wai.Utilities.Error import Polysemy -import Polysemy.Async import Wire.API.Connection import Wire.API.Federation.API.Brig ( NewConnectionResponse (..), @@ -147,9 +146,7 @@ updateOne2OneConv lUsr _mbConn remoteUser mbConvId rel actor = do -- -- Returns the connection, and whether it was updated or not. transitionTo :: - ( Member NotificationSubsystem r, - Member Async r - ) => + (Member NotificationSubsystem r) => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -191,9 +188,7 @@ transitionTo self mzcon other (Just connection) (Just rel) actor = lift $ do -- | Send an event to the local user when the state of a connection changes. pushEvent :: - ( Member NotificationSubsystem r, - Member Async r - ) => + (Member NotificationSubsystem r) => Local UserId -> Maybe ConnId -> UserConnection -> @@ -203,9 +198,7 @@ pushEvent self mzcon connection = do liftSem $ Intra.onConnectionEvent (tUnqualified self) mzcon event performLocalAction :: - ( Member NotificationSubsystem r, - Member Async r - ) => + (Member NotificationSubsystem r) => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -261,9 +254,7 @@ performLocalAction self mzcon other mconnection action = do -- B connects & A reacts: Accepted Accepted -- @ performRemoteAction :: - ( Member NotificationSubsystem r, - Member Async r - ) => + (Member NotificationSubsystem r) => Local UserId -> Remote UserId -> Maybe UserConnection -> @@ -282,8 +273,7 @@ performRemoteAction self other mconnection action = do createConnectionToRemoteUser :: ( Member FederationConfigStore r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => Local UserId -> ConnId -> @@ -297,7 +287,6 @@ createConnectionToRemoteUser self zcon other = do updateConnectionToRemoteUser :: ( Member NotificationSubsystem r, - Member Async r, Member FederationConfigStore r ) => Local UserId -> diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 3dbdf667573..7515577d073 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -53,7 +53,6 @@ import Gundeck.Types.Push qualified as Push import Imports hiding ((\\)) import Network.Wai.Utilities.Error ((!>>)) import Polysemy -import Polysemy.Async import Servant (ServerT) import Servant.API import Wire.API.Connection @@ -80,8 +79,7 @@ federationSitemap :: ( Member GalleyProvider r, Member (Concurrency 'Unsafe) r, Member FederationConfigStore r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => ServerT FederationAPI (Handler r) federationSitemap = @@ -113,8 +111,7 @@ getFederationStatus _ request = do sendConnectionAction :: ( Member FederationConfigStore r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => Domain -> NewConnectionRequest -> @@ -261,8 +258,7 @@ getMLSClientsV0 domain mcr0 = getMLSClients domain (mlsClientsRequestFromV0 mcr0 onUserDeleted :: ( Member (Concurrency 'Unsafe) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => Domain -> UserDeletedConnectionsNotification -> diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 06bbac89fb3..f811894c335 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -76,7 +76,6 @@ import Imports hiding (head) import Network.Wai.Routing hiding (toList) import Network.Wai.Utilities as Utilities import Polysemy -import Polysemy.Async import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) import Servant.OpenApi.Internal.Orphans () @@ -114,7 +113,6 @@ servantSitemap :: Member FederationConfigStore r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r, Member (Concurrency 'Unsafe) r ) => @@ -159,7 +157,6 @@ accountAPI :: Member (UserPendingActivationStore p) r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => ServerT BrigIRoutes.AccountAPI (Handler r) @@ -203,7 +200,6 @@ teamsAPI :: Member BlacklistStore r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member (Concurrency 'Unsafe) r, Member TinyLog r ) => @@ -230,8 +226,7 @@ authAPI :: ( Member GalleyProvider r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => ServerT BrigIRoutes.AuthAPI (Handler r) authAPI = @@ -375,7 +370,6 @@ addClientInternalH :: ( Member GalleyProvider r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -392,7 +386,6 @@ addClientInternalH usr mSkipReAuth new connId = do legalHoldClientRequestedH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -404,7 +397,6 @@ legalHoldClientRequestedH targetUser clientRequest = do removeLegalHoldClientH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -427,8 +419,7 @@ createUserNoVerify :: Member (UserPendingActivationStore p) r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => NewUser -> (Handler r) (Either RegisterError SelfProfile) @@ -449,7 +440,6 @@ createUserNoVerifySpar :: ( Member GalleyProvider r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => NewUserSpar -> @@ -471,7 +461,6 @@ createUserNoVerifySpar uData = deleteUserNoAuthH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -588,7 +577,6 @@ getPasswordResetCode emailOrPhone = changeAccountStatusH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -634,7 +622,6 @@ getConnectionsStatus (ConnectionsStatusRequestV2 froms mtos mrel) = do revokeIdentityH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => Maybe Email -> @@ -646,7 +633,6 @@ revokeIdentityH bade badp = throwStd (badRequest ("need exactly one of email, ph updateConnectionInternalH :: ( Member NotificationSubsystem r, - Member Async r, Member TinyLog r, Member (Embed HttpClientIO) r ) => @@ -699,7 +685,6 @@ addPhonePrefixH prefix = lift $ NoContent <$ API.phonePrefixInsert prefix updateSSOIdH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -716,7 +701,6 @@ updateSSOIdH uid ssoid = do deleteSSOIdH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -781,7 +765,6 @@ getRichInfoMultiH (maybe [] fromCommaSeparatedList -> uids) = updateHandleH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member GalleyProvider r, Member TinyLog r ) => @@ -796,7 +779,6 @@ updateHandleH uid (HandleUpdate handleUpd) = updateUserNameH :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member GalleyProvider r, Member TinyLog r ) => diff --git a/services/brig/src/Brig/API/Properties.hs b/services/brig/src/Brig/API/Properties.hs index 9281347e43f..3443ace2956 100644 --- a/services/brig/src/Brig/API/Properties.hs +++ b/services/brig/src/Brig/API/Properties.hs @@ -35,21 +35,20 @@ import Control.Error import Data.Id import Imports import Polysemy -import Polysemy.Async import Wire.API.Properties import Wire.NotificationSubsystem -setProperty :: (Member NotificationSubsystem r, Member Async r) => 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 $ liftSem $ Intra.onPropertyEvent u c (PropertySet u k v) -deleteProperty :: (Member NotificationSubsystem r, Member Async r) => UserId -> ConnId -> PropertyKey -> AppT r () +deleteProperty :: (Member NotificationSubsystem r) => UserId -> ConnId -> PropertyKey -> AppT r () deleteProperty u c k = do wrapClient $ Data.deleteProperty u k liftSem $ Intra.onPropertyEvent u c (PropertyDeleted u k) -clearProperties :: (Member NotificationSubsystem r, Member Async r) => UserId -> ConnId -> AppT r () +clearProperties :: (Member NotificationSubsystem r) => UserId -> ConnId -> AppT r () clearProperties u c = do wrapClient $ Data.clearProperties 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 05833987ac7..8beab24c7d3 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -101,7 +101,6 @@ import Imports hiding (head) import Network.Socket (PortNumber) import Network.Wai.Utilities as Utilities import Polysemy -import Polysemy.Async import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) import Servant qualified @@ -277,7 +276,6 @@ servantSitemap :: Member FederationConfigStore r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => ServerT BrigAPI (Handler r) @@ -444,7 +442,7 @@ servantSitemap = --------------------------------------------------------------------------- -- Handlers -setProperty :: (Member NotificationSubsystem r, Member Async r) => 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 @@ -483,10 +481,10 @@ parseStoredPropertyValue raw = case propertyValueFromRaw raw of . Log.field "parse_error" e throwStd internalServerError -deleteProperty :: (Member NotificationSubsystem r, Member Async r) => 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 :: (Member NotificationSubsystem r, Member Async r) => 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) @@ -565,7 +563,6 @@ addClient :: ( Member GalleyProvider r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -689,8 +686,7 @@ createUser :: Member (UserPendingActivationStore p) r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => Public.NewUserPublic -> (Handler r) (Either Public.RegisterError Public.RegisterSuccess) @@ -881,7 +877,6 @@ instance ToJSON GetActivationCodeResp where updateUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member GalleyProvider r, Member TinyLog r ) => @@ -910,7 +905,6 @@ changePhone u _ (Public.puPhone -> phone) = lift . exceptTToMaybe $ do removePhone :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -922,7 +916,6 @@ removePhone self conn = removeEmail :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -940,7 +933,6 @@ changePassword u cp = lift . exceptTToMaybe $ API.changePassword u cp changeLocale :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -952,7 +944,6 @@ changeLocale u conn l = lift $ API.changeLocale u conn l changeSupportedProtocols :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => Local UserId -> @@ -996,7 +987,6 @@ getHandleInfoUnqualifiedH self handle = do changeHandle :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member GalleyProvider r, Member TinyLog r ) => @@ -1063,7 +1053,6 @@ customerExtensionCheckBlockedDomains email = do createConnectionUnqualified :: ( Member GalleyProvider r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r, Member (Embed HttpClientIO) r ) => @@ -1080,7 +1069,6 @@ createConnection :: ( Member FederationConfigStore r, Member GalleyProvider r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r, Member (Embed HttpClientIO) r ) => @@ -1094,7 +1082,6 @@ createConnection self conn target = do updateLocalConnection :: ( Member NotificationSubsystem r, - Member Async r, Member TinyLog r, Member (Embed HttpClientIO) r ) => @@ -1112,7 +1099,6 @@ updateLocalConnection self conn other (Public.cuStatus -> newStatus) = do updateConnection :: ( Member FederationConfigStore r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r, Member (Embed HttpClientIO) r ) => @@ -1188,8 +1174,7 @@ deleteSelfUser :: ( Member GalleyProvider r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => UserId -> Public.DeleteUser -> @@ -1200,7 +1185,6 @@ deleteSelfUser u body = do verifyDeleteUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => Public.VerifyDeleteUser -> @@ -1242,8 +1226,7 @@ activate :: ( Member GalleyProvider r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => Public.ActivationKey -> Public.ActivationCode -> @@ -1257,8 +1240,7 @@ activateKey :: ( Member GalleyProvider r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => Public.Activate -> (Handler r) ActivationRespWithStatus diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 619e994c1d4..7816216bb22 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -162,7 +162,6 @@ import Galley.Types.Teams qualified as Team import Imports hiding (cs) import Network.Wai.Utilities import Polysemy -import Polysemy.Async import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import System.Logger.Class (MonadLogger) @@ -232,7 +231,6 @@ createUserSpar :: ( Member GalleyProvider r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => NewUserSpar -> @@ -303,8 +301,7 @@ createUser :: Member (UserPendingActivationStore p) r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult @@ -593,7 +590,6 @@ checkRestrictedUserCreation new = do updateUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member GalleyProvider r, Member TinyLog r ) => @@ -626,7 +622,6 @@ updateUser uid mconn uu allowScim = do changeLocale :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -643,7 +638,6 @@ changeLocale uid conn (LocaleUpdate loc) = do changeManagedBy :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -660,7 +654,6 @@ changeManagedBy uid conn (ManagedByUpdate mb) = do changeSupportedProtocols :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -677,7 +670,6 @@ changeSupportedProtocols uid conn prots = do changeHandle :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member GalleyProvider r, Member TinyLog r ) => @@ -847,7 +839,6 @@ changePhone u phone = do removeEmail :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -869,7 +860,6 @@ removeEmail uid conn = do removePhone :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -896,7 +886,6 @@ revokeIdentity :: forall r. ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => Either Email Phone -> @@ -939,7 +928,6 @@ changeAccountStatus :: forall r. ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member (Concurrency 'Unsafe) r, Member TinyLog r ) => @@ -961,7 +949,6 @@ changeAccountStatus usrs status = do changeSingleAccountStatus :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -992,8 +979,7 @@ activate :: ( Member GalleyProvider r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => ActivationTarget -> ActivationCode -> @@ -1006,8 +992,7 @@ activateWithCurrency :: ( Member GalleyProvider r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => ActivationTarget -> ActivationCode -> @@ -1051,8 +1036,7 @@ preverify tgt code = do onActivated :: ( Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => ActivationEvent -> (AppT r) (UserId, Maybe UserIdentity, Bool) @@ -1280,8 +1264,7 @@ deleteSelfUser :: ( Member GalleyProvider r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => UserId -> Maybe PlainTextPassword6 -> @@ -1362,7 +1345,6 @@ deleteSelfUser uid pwd = do verifyDeleteUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => VerifyDeleteUser -> @@ -1381,7 +1363,6 @@ verifyDeleteUser d = do ensureAccountDeleted :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -1422,7 +1403,6 @@ ensureAccountDeleted uid = do deleteAccount :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserAccount -> diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 3ce9929646a..30466bae373 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -85,7 +85,6 @@ import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Polysemy -import Polysemy.Async import Polysemy.TinyLog (TinyLog) import System.Logger.Class (MonadLogger) import System.Logger.Message hiding ((.=)) @@ -111,7 +110,6 @@ import Wire.Sem.Logger qualified as Log onUserEvent :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -124,9 +122,7 @@ onUserEvent orig conn e = *> embed (journalEvent orig e) onConnectionEvent :: - ( Member NotificationSubsystem r, - Member Async r - ) => + (Member NotificationSubsystem r) => -- | Originator of the event. UserId -> -- | Client connection ID, if any. @@ -144,7 +140,7 @@ onConnectionEvent orig conn evt = do (pure $ from :| []) onPropertyEvent :: - (Member NotificationSubsystem r, Member Async r) => + (Member NotificationSubsystem r) => -- | Originator of the event. UserId -> -- | Client connection ID. @@ -232,7 +228,6 @@ journalEvent orig e = case e of dispatchNotifications :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -263,8 +258,7 @@ dispatchNotifications orig conn e = case e of notifyUserDeletionLocals :: ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => UserId -> Maybe ConnId -> @@ -304,7 +298,7 @@ notifyUserDeletionRemotes deleted = do -- | (Asynchronously) notifies other users of events. notify :: - (Member NotificationSubsystem r, Member Async r) => + (Member NotificationSubsystem r) => List1 Event -> -- | Origin user, TODO: Delete UserId -> @@ -315,19 +309,17 @@ notify :: -- | Users to notify. Sem r (NonEmpty UserId) -> Sem r () -notify (toList -> events) orig route conn recipients = - -- TODO: This async doesn't log errors if the push fails. Make it do so. - void . async $ 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 - pushNotifications pushes +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 + pushNotificationsAsync pushes notifySelf :: - (Member NotificationSubsystem r, Member Async r) => + (Member NotificationSubsystem r) => List1 Event -> -- | Origin user. UserId -> @@ -343,7 +335,6 @@ notifyContacts :: forall r. ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => List1 Event -> diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index 7a1cca0cf19..9c04f5c3083 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -33,7 +33,6 @@ import Control.Monad.Catch import Data.ByteString.Conversion import Imports import Polysemy -import Polysemy.Async import Polysemy.Conc import Polysemy.Time import Polysemy.TinyLog as Log @@ -49,8 +48,7 @@ onEvent :: Member NotificationSubsystem r, Member TinyLog r, Member Delay r, - Member Race r, - Member Async r + Member Race r ) => InternalNotification -> Sem r () diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index d3277ea8026..ac70c9623a1 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -58,7 +58,6 @@ import Galley.Types.Teams qualified as Team import Imports hiding (head) import Network.Wai.Utilities hiding (code, message) import Polysemy -import Polysemy.Async import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader) import System.Logger.Class qualified as Log @@ -311,7 +310,6 @@ getInvitationByEmail email = do suspendTeam :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member (Concurrency 'Unsafe) r, Member GalleyProvider r, Member TinyLog r @@ -328,7 +326,6 @@ suspendTeam tid = do unsuspendTeam :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member (Concurrency 'Unsafe) r, Member GalleyProvider r, Member TinyLog r @@ -346,7 +343,6 @@ unsuspendTeam tid = do changeTeamAccountStatuses :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member (Concurrency 'Unsafe) r, Member GalleyProvider r, Member TinyLog r diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 4a795c805fb..fece7d7c22c 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -72,7 +72,6 @@ import Data.ZAuth.Token qualified as ZAuth import Imports import Network.Wai.Utilities.Error ((!>>)) import Polysemy -import Polysemy.Async import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import System.Logger (field, msg, val, (~~)) @@ -129,8 +128,7 @@ login :: ( Member GalleyProvider r, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => Login -> CookieType -> @@ -239,8 +237,7 @@ renewAccess :: ( ZAuth.TokenPair u a, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => List1 (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> @@ -273,7 +270,6 @@ revokeAccess u pw cc ll = do catchSuspendInactiveUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => UserId -> @@ -300,8 +296,7 @@ newAccess :: ( ZAuth.TokenPair u a, Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => UserId -> Maybe ClientId -> @@ -412,8 +407,7 @@ validateToken ut at = do ssoLogin :: ( Member TinyLog r, Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member Async r + Member NotificationSubsystem r ) => SsoLogin -> CookieType -> @@ -437,7 +431,6 @@ legalHoldLogin :: ( Member GalleyProvider r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, - Member Async r, Member TinyLog r ) => LegalHoldLogin -> From 3cc3529389cd0e97a6494d047335878824425095 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 6 Feb 2024 12:22:15 +0000 Subject: [PATCH 37/43] NotificationSubsystem: Log error when async push fails --- libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs | 1 + .../src/Wire/Sem/Logger/TinyLog.hs | 14 ++++ libs/wire-subsystems/default.nix | 2 + .../src/Wire/NotificationSubsystem.hs | 5 +- .../Wire/NotificationSubsystem/Interpreter.hs | 50 +++++++---- .../NotificationSubsystem/InterpreterSpec.hs | 83 ++++++++++++++++++- libs/wire-subsystems/wire-subsystems.cabal | 3 + .../brig/src/Brig/CanonicalInterpreter.hs | 4 +- services/brig/src/Brig/IO/Intra.hs | 2 +- services/brig/test/unit/Test/Brig/Calling.hs | 10 --- services/galley/src/Galley/Env.hs | 3 +- 11 files changed, 142 insertions(+), 35 deletions(-) diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs index 8a3f96560c6..6b7af708094 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs @@ -65,3 +65,4 @@ mapLogger f = interpret $ \case discardLogs :: Sem (Logger msg ': r) a -> Sem r a discardLogs = interpret $ \(Log _ _) -> 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..dbd36e4f06c 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,4 @@ +{-# LANGUAGE RecordWildCards #-} -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -21,6 +22,9 @@ module Wire.Sem.Logger.TinyLog stringLoggerToTinyLog, discardTinyLogs, module Wire.Sem.Logger.Level, + LogRecorder(..), + newLogRecorder, + recordLogs ) where @@ -30,6 +34,7 @@ import Polysemy import qualified System.Logger as Log import Wire.Sem.Logger import Wire.Sem.Logger.Level +import Polysemy.TinyLog (TinyLog) loggerToTinyLog :: Member (Embed IO) r => @@ -58,3 +63,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/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index da155085ec1..02a758de650 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -26,6 +26,7 @@ , quickcheck-instances , retry , text +, tinylog , types-common , wire-api }: @@ -50,6 +51,7 @@ mkDerivation { QuickCheck retry text + tinylog types-common wire-api ]; diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index 3d7a657e309..499b1eb12e4 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -2,6 +2,7 @@ module Wire.NotificationSubsystem where +import Control.Concurrent.Async (Async) import Control.Lens (makeLenses) import Data.Aeson import Data.Id @@ -44,7 +45,9 @@ data NotificationSubsystem m a where PushNotificationsSlowly :: [Push] -> NotificationSubsystem m () -- | Bulk push notifications, but async. This should be used when failure to -- send notifications is not critical. - PushNotificationsAsync :: [Push] -> NotificationSubsystem m () + -- + -- 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] diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index 87a418b607c..1b041ba4f45 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -1,5 +1,7 @@ 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) @@ -13,8 +15,12 @@ import Gundeck.Types.Push.V2 qualified as V2 import Imports import Numeric.Natural (Natural) import Polysemy -import Polysemy.Async (Async, async, sequenceConcurrently) +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 @@ -23,9 +29,11 @@ import Wire.Sem.Delay -- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. runNotificationSubsystemGundeck :: - ( Member (GundeckAPIAccess) r, - Member Async r, - Member Delay r + ( Member GundeckAPIAccess r, + Member P.Async r, + Member Delay r, + Member (Final IO) r, + Member P.TinyLog r ) => NotificationSubsystemConfig -> Sem (NotificationSubsystem : r) a -> @@ -42,12 +50,13 @@ data NotificationSubsystemConfig = NotificationSubsystemConfig { fanoutLimit :: Range 1 HardTruncationLimit Int32, chunkSize :: Natural, -- | Microseconds - slowPushDelay :: Natural + slowPushDelay :: Natural, + requestId :: RequestId } -defaultNotificationSubsystemConfig :: NotificationSubsystemConfig -defaultNotificationSubsystemConfig = - NotificationSubsystemConfig defaultFanoutLimit defaultChunkSize defaultSlowPushDelay +defaultNotificationSubsystemConfig :: RequestId -> NotificationSubsystemConfig +defaultNotificationSubsystemConfig reqId = + NotificationSubsystemConfig defaultFanoutLimit defaultChunkSize defaultSlowPushDelay reqId defaultFanoutLimit :: Range 1 HardTruncationLimit Int32 defaultFanoutLimit = toRange (Proxy @HardTruncationLimit) @@ -58,22 +67,31 @@ defaultChunkSize = 128 defaultSlowPushDelay :: Natural defaultSlowPushDelay = 20_000 --- TODO: This async doesn't log errors if the push fails. Make it do so. pushAsyncImpl :: forall r. - ( Member (GundeckAPIAccess) r, + ( Member GundeckAPIAccess r, Member (Input NotificationSubsystemConfig) r, - Member (Async) r + Member P.Async r, + Member (Final IO) r, + Member P.TinyLog r ) => [Push] -> - Sem r () -pushAsyncImpl ps = void $ async $ pushImpl ps + 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 GundeckAPIAccess r, Member (Input NotificationSubsystemConfig) r, - Member (Async) r + Member P.Async r ) => [Push] -> Sem r () @@ -142,7 +160,7 @@ pushSlowlyImpl :: ( Member Delay r, Member (Input NotificationSubsystemConfig) r, Member GundeckAPIAccess r, - Member Async r + Member P.Async r ) => [Push] -> Sem r () diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index 9f219e785d3..1cab035d719 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -1,6 +1,8 @@ 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 @@ -10,8 +12,9 @@ import Gundeck.Types.Push.V2 qualified as V2 import Imports import Numeric.Natural (Natural) import Polysemy -import Polysemy.Async (Async, asyncToIOFinal) +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 @@ -21,6 +24,7 @@ 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 @@ -30,7 +34,8 @@ spec = describe "NotificationSubsystem.Interpreter" do NotificationSubsystemConfig { fanoutLimit = toRange $ Proxy @30, chunkSize = 12, - slowPushDelay = 0 + slowPushDelay = 0, + requestId = RequestId "N/A" } connId2 <- generate arbitrary @@ -90,7 +95,8 @@ spec = describe "NotificationSubsystem.Interpreter" do NotificationSubsystemConfig { fanoutLimit = toRange $ Proxy @30, chunkSize = 12, - slowPushDelay = 0 + slowPushDelay = 0, + requestId = RequestId "N/A" } connId2 <- generate arbitrary @@ -144,7 +150,8 @@ spec = describe "NotificationSubsystem.Interpreter" do NotificationSubsystemConfig { fanoutLimit = toRange $ Proxy @30, chunkSize = 12, - slowPushDelay = 1 + slowPushDelay = 1, + requestId = RequestId "N/A" } connId2 <- generate arbitrary @@ -195,6 +202,39 @@ spec = describe "NotificationSubsystem.Interpreter" do 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 (map snd logs !! 0) `shouldContain` "error=TestException" + describe "toV2Push" do it "does the transformation correctly" $ property \(pushToUser :: Push) -> let v2Push = toV2Push pushToUser @@ -237,6 +277,21 @@ runMockStack mockConfig action = do $ 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 -> @@ -251,6 +306,26 @@ runMockStackWithControlledDelay mockConfig delayControl actualPushesRef = do . 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 diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 9ca624388d5..1c55fa0c9d5 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -76,6 +76,7 @@ library hs-source-dirs: src build-depends: , aeson + , async , base , bilge , bytestring-conversion @@ -91,6 +92,7 @@ library , QuickCheck , retry , text + , tinylog , types-common , wire-api @@ -113,6 +115,7 @@ test-suite wire-subsystems-tests , aeson , async , base + , bilge , bytestring , containers , gundeck-types diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 5a5cab91349..c76802a40ae 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -31,7 +31,7 @@ import Polysemy.Error (Error, mapError, runError) import Polysemy.TinyLog (TinyLog) import Wire.GundeckAPIAccess import Wire.NotificationSubsystem -import Wire.NotificationSubsystem.Interpreter +import Wire.NotificationSubsystem.Interpreter (defaultNotificationSubsystemConfig, runNotificationSubsystemGundeck) import Wire.Rpc import Wire.Sem.Concurrency import Wire.Sem.Concurrency.IO @@ -97,7 +97,7 @@ runBrigToIO e (AppT ma) = do . interpretJwk . interpretFederationDomainConfig (e ^. settings . federationStrategy) (foldMap (remotesMapFromCfgFile . fmap (.federationDomainConfig)) (e ^. settings . federationDomainConfigs)) . runGundeckAPIAccess (e ^. gundeckEndpoint) - . runNotificationSubsystemGundeck defaultNotificationSubsystemConfig + . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig (e ^. requestId)) ) ) $ runReaderT ma e diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 30466bae373..61dc0c3e272 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -316,7 +316,7 @@ notify (toList -> events) orig route conn recipients = do & pushConn .~ conn & pushRoute .~ route & pushApsData .~ toApsData event - pushNotificationsAsync pushes + void $ pushNotificationsAsync pushes notifySelf :: (Member NotificationSubsystem r) => 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/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index ef183df8665..9fd764d767c 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -116,5 +116,6 @@ notificationSubssystemConfig env = NotificationSubsystemConfig { chunkSize = defaultChunkSize, fanoutLimit = currentFanoutLimit env._options, - slowPushDelay = 1000 * fromMaybe defaultSlowPushDelay (env ^. options . O.settings . deleteConvThrottleMillis) + slowPushDelay = 1000 * fromMaybe defaultSlowPushDelay (env ^. options . O.settings . deleteConvThrottleMillis), + requestId = env ^. reqId } From 0518aaf16a4e6c18dde9d8ca18331b6e12043776 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 7 Feb 2024 11:50:15 +0100 Subject: [PATCH 38/43] Add back wrongly deleted comment --- services/brig/src/Brig/API/User.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 7816216bb22..bd5c84d555c 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -1,3 +1,4 @@ +-- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH -- From e5776feebf9641a4376ebe5ec94d4d888c817ca3 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 7 Feb 2024 12:41:44 +0100 Subject: [PATCH 39/43] linters --- libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs | 1 - libs/polysemy-wire-zoo/src/Wire/Sem/Logger/TinyLog.hs | 7 ++++--- libs/wire-subsystems/default.nix | 2 ++ 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs index 6b7af708094..8a3f96560c6 100644 --- a/libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Logger.hs @@ -65,4 +65,3 @@ mapLogger f = interpret $ \case discardLogs :: Sem (Logger msg ': r) a -> Sem r a discardLogs = interpret $ \(Log _ _) -> 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 dbd36e4f06c..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,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -22,19 +23,19 @@ module Wire.Sem.Logger.TinyLog stringLoggerToTinyLog, discardTinyLogs, module Wire.Sem.Logger.Level, - LogRecorder(..), + LogRecorder (..), newLogRecorder, - recordLogs + 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 -import Polysemy.TinyLog (TinyLog) loggerToTinyLog :: Member (Embed IO) r => diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index 02a758de650..a16945bbdb4 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -36,6 +36,7 @@ mkDerivation { src = gitignoreSource ./.; libraryHaskellDepends = [ aeson + async base bilge bytestring-conversion @@ -59,6 +60,7 @@ mkDerivation { aeson async base + bilge bytestring containers gundeck-types From d34ed88d932b0c7b2da67a95df310456b001d414 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 7 Feb 2024 15:38:20 +0100 Subject: [PATCH 40/43] GundeckAPIAccess: Fix method --- libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs b/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs index a74a894f223..1d0666880cf 100644 --- a/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs @@ -26,7 +26,7 @@ runGundeckAPIAccess ep = interpret $ \case chunkedReq <- jsonChunkedIO pushes -- No retries because the chunked request body cannot be replayed. void . rpc "gundeck" ep $ - method DELETE + method POST . path "/i/push/v2" . expect2xx . chunkedReq From 648e3bb777fba574292d1d03cb5db0958e1c5e65 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 8 Feb 2024 13:43:23 +0100 Subject: [PATCH 41/43] hlint --- .../test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index 1cab035d719..ac241e5626f 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -233,7 +233,7 @@ spec = describe "NotificationSubsystem.Interpreter" do attemptedPushes `shouldBe` [[toV2Push push1]] map fst logs `shouldBe` [Error] - cs (map snd logs !! 0) `shouldContain` "error=TestException" + cs (head (map snd logs)) `shouldContain` "error=TestException" describe "toV2Push" do it "does the transformation correctly" $ property \(pushToUser :: Push) -> From 4c0cfad3a597439acca9212c91386e3eaebc05a0 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 8 Feb 2024 14:19:04 +0100 Subject: [PATCH 42/43] Use DiffTime to denote slowPushDelay --- libs/extended/default.nix | 2 + libs/extended/extended.cabal | 2 + libs/extended/src/Data/Time/Clock/DiffTime.hs | 43 +++++++++++++++++++ libs/wire-subsystems/default.nix | 3 ++ .../Wire/NotificationSubsystem/Interpreter.hs | 10 ++--- .../NotificationSubsystem/InterpreterSpec.hs | 5 ++- libs/wire-subsystems/wire-subsystems.cabal | 2 + services/galley/src/Galley/Env.hs | 3 +- services/galley/src/Galley/Options.hs | 3 +- 9 files changed, 63 insertions(+), 10 deletions(-) create mode 100644 libs/extended/src/Data/Time/Clock/DiffTime.hs 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/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index a16945bbdb4..bd3ef35a59c 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -11,6 +11,7 @@ , bytestring-conversion , containers , exceptions +, extended , gitignoreSource , gundeck-types , hspec @@ -42,6 +43,7 @@ mkDerivation { bytestring-conversion containers exceptions + extended gundeck-types http-client http-types @@ -63,6 +65,7 @@ mkDerivation { bilge bytestring containers + extended gundeck-types hspec imports diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index 1b041ba4f45..f59c79d0c2d 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -10,6 +10,7 @@ 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 @@ -49,8 +50,7 @@ runNotificationSubsystemGundeck cfg = interpret $ \case data NotificationSubsystemConfig = NotificationSubsystemConfig { fanoutLimit :: Range 1 HardTruncationLimit Int32, chunkSize :: Natural, - -- | Microseconds - slowPushDelay :: Natural, + slowPushDelay :: DiffTime, requestId :: RequestId } @@ -64,8 +64,8 @@ defaultFanoutLimit = toRange (Proxy @HardTruncationLimit) defaultChunkSize :: Natural defaultChunkSize = 128 -defaultSlowPushDelay :: Natural -defaultSlowPushDelay = 20_000 +defaultSlowPushDelay :: DiffTime +defaultSlowPushDelay = millisecondsToDiffTime 20 pushAsyncImpl :: forall r. @@ -166,5 +166,5 @@ pushSlowlyImpl :: Sem r () pushSlowlyImpl ps = for_ ps \p -> do - delay =<< inputs (fromIntegral . slowPushDelay) + delay =<< inputs (diffTimeToFullMicroseconds . slowPushDelay) pushImpl [p] diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index ac241e5626f..4677a0d1bfd 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -8,6 +8,7 @@ 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) @@ -192,11 +193,11 @@ spec = describe "NotificationSubsystem.Interpreter" do runMockStackWithControlledDelay mockConfig delayControl actualPushesRef $ pushSlowlyImpl pushes - putMVar delayControl (fromIntegral mockConfig.slowPushDelay) + putMVar delayControl (diffTimeToFullMicroseconds mockConfig.slowPushDelay) actualPushes1 <- timeout 100_000 $ (waitUntilPushes actualPushesRef 1) actualPushes1 `shouldBe` Just [[toV2Push push1]] - putMVar delayControl (fromIntegral mockConfig.slowPushDelay) + putMVar delayControl (diffTimeToFullMicroseconds mockConfig.slowPushDelay) actualPushes2 <- timeout 100_000 $ (waitUntilPushes actualPushesRef 2) actualPushes2 `shouldBe` Just [[toV2Push push1], [toV2Push push2]] diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 1c55fa0c9d5..a631c0e2737 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -82,6 +82,7 @@ library , bytestring-conversion , containers , exceptions + , extended , gundeck-types , http-client , http-types @@ -118,6 +119,7 @@ test-suite wire-subsystems-tests , bilge , bytestring , containers + , extended , gundeck-types , hspec , imports diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 9fd764d767c..05c53b61b45 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 @@ -116,6 +117,6 @@ notificationSubssystemConfig env = NotificationSubsystemConfig { chunkSize = defaultChunkSize, fanoutLimit = currentFanoutLimit env._options, - slowPushDelay = 1000 * fromMaybe defaultSlowPushDelay (env ^. options . O.settings . deleteConvThrottleMillis), + slowPushDelay = fromMaybe defaultSlowPushDelay (millisecondsToDiffTime . toInteger <$> env ^. options . O.settings . deleteConvThrottleMillis), requestId = env ^. reqId } diff --git a/services/galley/src/Galley/Options.hs b/services/galley/src/Galley/Options.hs index c14514b9c61..499b85949e6 100644 --- a/services/galley/src/Galley/Options.hs +++ b/services/galley/src/Galley/Options.hs @@ -68,7 +68,6 @@ import Galley.Keys import Galley.Types.Teams import Imports import Network.AMQP.Extended -import Numeric.Natural import System.Logger.Extended (Level, LogFormat) import Util.Options hiding (endpoint) import Util.Options.Common @@ -122,7 +121,7 @@ data Settings = Settings -- | Throttling: limits to concurrent deletion events _concurrentDeletionEvents :: !(Maybe Int), -- | Throttling: delay between sending events upon team deletion - _deleteConvThrottleMillis :: !(Maybe Natural), + _deleteConvThrottleMillis :: !(Maybe Int), -- | FederationDomain is required, even when not wanting to federate with other backends -- (in that case the 'allowedDomains' can be set to empty in Federator) -- Federation domain is used to qualify local IDs and handles, From 65b98ed9a2899886f324f93ab540ebb544608fc8 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 8 Feb 2024 14:33:20 +0100 Subject: [PATCH 43/43] hlint --- services/galley/src/Galley/Env.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 05c53b61b45..ca8f4212f9d 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -117,6 +117,10 @@ notificationSubssystemConfig env = NotificationSubsystemConfig { chunkSize = defaultChunkSize, fanoutLimit = currentFanoutLimit env._options, - slowPushDelay = fromMaybe defaultSlowPushDelay (millisecondsToDiffTime . toInteger <$> env ^. options . O.settings . deleteConvThrottleMillis), + slowPushDelay = + maybe + defaultSlowPushDelay + (millisecondsToDiffTime . toInteger) + (env ^. options . O.settings . deleteConvThrottleMillis), requestId = env ^. reqId }