From aafa344eb8b6172d9129617714caed09b09a8be1 Mon Sep 17 00:00:00 2001 From: Jon Elverkilde Date: Wed, 7 Mar 2018 11:44:42 +0100 Subject: [PATCH 01/64] First public release. --- .gitignore | 26 + LICENSE | 661 +++++++++++++++++++++++++ README.md | 27 + Setup.hs | 2 + hscim.cabal | 91 ++++ src/API/Group.hs | 125 +++++ src/Config/Schema.hs | 130 +++++ src/Config/Schema/Group.hs | 85 ++++ src/Config/Schema/ResourceType.hs | 113 +++++ src/Config/Schema/SPConfig.hs | 223 +++++++++ src/Config/Schema/Schema.hs | 355 ++++++++++++++ src/Config/Schema/User.hs | 786 ++++++++++++++++++++++++++++++ src/DB/User.hs | 33 ++ src/SCIM.hs | 137 ++++++ src/Schema/Common.hs | 77 +++ src/Schema/Error.hs | 85 ++++ src/Schema/ListResponse.hs | 30 ++ src/Schema/Meta.hs | 72 +++ src/Schema/Schema.hs | 24 + src/Schema/User.hs | 61 +++ src/Schema/User/Address.hs | 28 ++ src/Schema/User/Certificate.hs | 21 + src/Schema/User/Email.hs | 35 ++ src/Schema/User/IM.hs | 20 + src/Schema/User/Name.hs | 24 + src/Schema/User/Phone.hs | 19 + src/Schema/User/Photo.hs | 20 + stack.yaml | 74 +++ test/Spec.hs | 192 ++++++++ test/Test/API/Groups.hs | 139 ++++++ test/Test/Config/Schema.hs | 96 ++++ test/Util.hs | 183 +++++++ 32 files changed, 3994 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 hscim.cabal create mode 100644 src/API/Group.hs create mode 100644 src/Config/Schema.hs create mode 100644 src/Config/Schema/Group.hs create mode 100644 src/Config/Schema/ResourceType.hs create mode 100644 src/Config/Schema/SPConfig.hs create mode 100644 src/Config/Schema/Schema.hs create mode 100644 src/Config/Schema/User.hs create mode 100644 src/DB/User.hs create mode 100644 src/SCIM.hs create mode 100644 src/Schema/Common.hs create mode 100644 src/Schema/Error.hs create mode 100644 src/Schema/ListResponse.hs create mode 100644 src/Schema/Meta.hs create mode 100644 src/Schema/Schema.hs create mode 100644 src/Schema/User.hs create mode 100644 src/Schema/User/Address.hs create mode 100644 src/Schema/User/Certificate.hs create mode 100644 src/Schema/User/Email.hs create mode 100644 src/Schema/User/IM.hs create mode 100644 src/Schema/User/Name.hs create mode 100644 src/Schema/User/Phone.hs create mode 100644 src/Schema/User/Photo.hs create mode 100644 stack.yaml create mode 100644 test/Spec.hs create mode 100644 test/Test/API/Groups.hs create mode 100644 test/Test/Config/Schema.hs create mode 100644 test/Util.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000000..5812f1890fa --- /dev/null +++ b/.gitignore @@ -0,0 +1,26 @@ +dist +dist-* +cabal-dev +*.o +*.hi +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* + +*~ +*.el +\#* \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000000..be3f7b28e56 --- /dev/null +++ b/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/README.md b/README.md new file mode 100644 index 00000000000..61cf731d013 --- /dev/null +++ b/README.md @@ -0,0 +1,27 @@ +# System for Cross-domain Identity Management (SCIM) + +This implements part of the [SCIM standard](http://www.simplecloud.info) +for identity management. The parts that are currently supported are: + + * User schema version 2.0 + +## Building + +This project uses stack. You can install the sample executable with + +```sh +stack install +``` + +## Developing and testing + +This library only implements the schemas and endpoints defined by the +SCIM standard. You will need to implement the actual storage by giving +an instance for the `Persistence` class. + +There's a simple in-memory implementation of this class, which is used +for tests. You can run the tests with the standard stack interface: + +```sh +stack test +``` \ No newline at end of file diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 00000000000..9a994af677b --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hscim.cabal b/hscim.cabal new file mode 100644 index 00000000000..7b43469c52b --- /dev/null +++ b/hscim.cabal @@ -0,0 +1,91 @@ +name: hscim +version: 0.1.0.0 +-- synopsis: +-- description: +homepage: https://github.com/githubuser/hscim#readme +license: AGPL-3 +license-file: LICENSE +author: Wire Swiss GmbH +maintainer: Wire Swiss GmbH +copyright: (c) 2018 Wire Swiss GmbH +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: SCIM + API.Group + Config.Schema + Config.Schema.Schema + Config.Schema.User + Config.Schema.Group + Config.Schema.SPConfig + Config.Schema.ResourceType + DB.User + Schema.Common + Schema.Error + Schema.Schema + Schema.User + Schema.User.Address + Schema.User.Certificate + Schema.User.Email + Schema.User.IM + Schema.User.Name + Schema.User.Phone + Schema.User.Photo + + build-depends: base >= 4.7 && < 5 + , aeson + , aeson-qq + , mtl + , servant-server + , servant-generic + , text + , time + , wai + , network-uri + , unordered-containers + , email-validate + , errors + default-language: Haskell2010 + +test-suite hscim-test + type: exitcode-stdio-1.0 + other-modules: Util + Test.Config.Schema + Test.API.Groups + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , bytestring + , hscim + , hspec + , hspec-expectations + , hspec-wai + , hspec-wai-json + , aeson + , http-types + , stm-containers + , text + , bytestring + , wai-extra + , stm + , stm-containers + , mtl + , list-t + , time + , servant-server + , servant-generic + , vector + , unordered-containers + , warp + , wai-logger + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/githubuser/hscim diff --git a/src/API/Group.hs b/src/API/Group.hs new file mode 100644 index 00000000000..2adbd0ce329 --- /dev/null +++ b/src/API/Group.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} + +module API.Group ( GroupSite (..) + , GroupDB (..) + , StoredGroup + , Group (..) + , GroupId + , groupServer + , app + ) where + +import Config.Schema (ConfigAPI, Configuration, configServer) +import Control.Applicative ((<|>), Alternative) +import Control.Monad.Except +import Control.Error.Util (note) +import Data.Text +import Data.Aeson +import DB.User (StoredUser, UserDB) +import qualified DB.User as User +import GHC.Generics (Generic) +import Network.Wai +import Schema.User hiding (schemas) +import Schema.Common +import Schema.Error +import Schema.Meta +import Servant +import Servant.Generic + + +type SCIMHandler m = (MonadError ServantErr m, GroupDB m) +type GroupAPI = ToServant (GroupSite AsApi) + +type GroupId = Text + +type Schema = Text + +-- TODO +data Member = Member + { value :: Text + , typ :: Text + , ref :: Text + } deriving (Show, Eq, Generic) + +instance FromJSON Member where + parseJSON = genericParseJSON parseOptions . jsonLower + +instance ToJSON Member where + toJSON = genericToJSON serializeOptions + +data Group = Group + { schemas :: [Schema] + , displayName :: Text + , members :: [Member] + } + deriving (Show, Eq, Generic) + +instance FromJSON Group +instance ToJSON Group + +type StoredGroup = WithMeta (WithId Group) + +class GroupDB m where + list :: m [StoredGroup] + get :: GroupId -> m (Maybe StoredGroup) + create :: Group -> m StoredGroup + update :: GroupId -> Group -> m (Either ServantErr StoredGroup) + -- ^ + -- TODO: should be UpdateError / + delete :: GroupId -> m Bool + getGroupMeta :: m Meta + +data GroupSite route = GroupSite + { getGroups :: route :- + Get '[JSON] [StoredGroup] + , getGroup :: route :- + Capture "id" Text :> Get '[JSON] StoredGroup + , postGroup :: route :- + ReqBody '[JSON] Group :> PostCreated '[JSON] StoredGroup + , putGroup :: route :- + Capture "id" Text :> ReqBody '[JSON] Group :> Put '[JSON] StoredGroup + , patchGroup :: route :- + Capture "id" Text :> Patch '[JSON] StoredGroup + , deleteGroup :: route :- + Capture "id" Text :> DeleteNoContent '[JSON] NoContent + } deriving (Generic) + +api :: Proxy GroupAPI +api = Proxy + +app :: SCIMHandler m => + (forall a. m a -> Handler a) -> Application +app t = serve api $ hoistServer api t (toServant $ groupServer) + +groupServer :: SCIMHandler m => GroupSite (AsServerT m) +groupServer = GroupSite + { getGroups = list + , getGroup = getGroup' + , postGroup = create + , putGroup = putGroup' + , patchGroup = undefined + , deleteGroup = deleteGroup' + } + +getGroup' :: SCIMHandler m => GroupId -> m StoredGroup +getGroup' gid = do + maybeGroup <- get gid + liftEither $ note (notFound gid) maybeGroup + +putGroup' :: SCIMHandler m => GroupId -> Group -> m StoredGroup +putGroup' gid grp = do + updated <- update gid grp + liftEither updated + +deleteGroup' :: SCIMHandler m => GroupId -> m NoContent +deleteGroup' gid = do + deleted <- delete gid + if deleted then return NoContent else throwError err404 diff --git a/src/Config/Schema.hs b/src/Config/Schema.hs new file mode 100644 index 00000000000..df5737d14b1 --- /dev/null +++ b/src/Config/Schema.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} + +module Config.Schema ( ConfigAPI + , configServer + , Supported (..) + , BulkConfig (..) + , FilterConfig (..) + , AuthenticationScheme (..) + , Configuration (..) + , empty + ) where + +import Config.Schema.User +import Config.Schema.SPConfig +import Config.Schema.Group +import Config.Schema.Schema +import Config.Schema.ResourceType +import Control.Monad.Except +import Control.Error.Util (note) +import Data.Aeson +import qualified Data.HashMap.Lazy as HML +import Data.Text (Text) +import GHC.Generics (Generic) +import Servant +import Servant.Generic + +import Prelude hiding (filter) + +data Supported a = Supported + { supported :: Bool + , subConfig :: a + } deriving (Show, Eq, Generic) + +instance ToJSON a => ToJSON (Supported a) where + toJSON (Supported b v) = case toJSON v of + (Object o) -> Object $ HML.insert "supported" (Bool b) o + _ -> Object $ HML.fromList [("supported", Bool b)] + + +data BulkConfig = BulkConfig + { maxOperations :: Int + , maxPayloadSize :: Int + } deriving (Show, Eq, Generic) + +instance ToJSON BulkConfig + +data FilterConfig = FilterConfig + { maxResults :: Int + } deriving (Show, Eq, Generic) + +instance ToJSON FilterConfig + +-- TODO +data AuthenticationScheme = AuthenticationScheme + { typ :: Text + , name :: Text + , description :: Text + , specUri :: Text -- TODO: URI + -- , documentationUri :: URI + } deriving (Show, Eq, Generic) + +instance ToJSON AuthenticationScheme + +data Configuration = Configuration + { documentationUri :: Maybe Text -- TODO: URI + , patch :: Supported () + , bulk :: Supported BulkConfig + , filter :: Supported FilterConfig + , changePassword :: Supported () + , sort :: Supported () + , etag :: Supported () + , authenticationSchemes :: [AuthenticationScheme] + } deriving (Show, Eq, Generic) + +instance ToJSON Configuration + +empty :: Configuration +empty = Configuration + { documentationUri = Nothing + , patch = Supported False () + , bulk = Supported False $ BulkConfig 0 0 + , filter = Supported False $ FilterConfig 0 + , changePassword = Supported False () + , sort = Supported False () + , etag = Supported False () + , authenticationSchemes = [] + } + +configServer :: MonadError ServantErr m => + Configuration -> ConfigAPI (AsServerT m) +configServer config = ConfigAPI + { spConfig = pure config + , schemas = pure [ userSchema + , spConfigSchema + , groupSchema + , metaSchema + , resourceSchema + ] + , schema = liftEither . note err404 . getSchema + , resourceTypes = pure "" + } + +getSchema :: Text -> Maybe Value +getSchema "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig" = + pure spConfigSchema +getSchema "urn:ietf:params:scim:schemas:core:2.0:User" = + pure userSchema +getSchema "urn:ietf:params:scim:schemas:core:2.0:Group" = + pure groupSchema +getSchema "urn:ietf:params:scim:schemas:core:2.0:Schema" = + pure metaSchema +getSchema "urn:ietf:params:scim:schemas:core:2.0:ResourceType" = + pure resourceSchema +getSchema _ = Nothing + +data ConfigAPI route = ConfigAPI + { spConfig :: route :- "ServiceProviderConfig" :> Get '[JSON] Configuration + , schemas :: route :- "Schemas" :> Get '[JSON] [Value] + , schema :: route :- "Schemas" :> Capture "id" Text :> Get '[JSON] Value + , resourceTypes :: route :- "ResourceTypes" :> Get '[JSON] Text + } deriving (Generic) + diff --git a/src/Config/Schema/Group.hs b/src/Config/Schema/Group.hs new file mode 100644 index 00000000000..e1a46379ba0 --- /dev/null +++ b/src/Config/Schema/Group.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Config.Schema.Group (groupSchema) where + +import Data.Aeson (Value) +import Data.Aeson.QQ + +groupSchema :: Value +groupSchema = [aesonQQ| +{ + "id": "urn:ietf:params:scim:schemas:core:2.0:Group", + "name": "Group", + "description": "Group", + "attributes": [ + { + "name": "displayName", + "type": "string", + "multiValued": false, + "description": "A human-readable name for the Group. REQUIRED.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "members", + "type": "complex", + "multiValued": true, + "description": "A list of members of the Group.", + "required": false, + "subAttributes": [ + { + "name": "value", + "type": "string", + "multiValued": false, + "description": "Identifier of the member of this Group.", + "required": false, + "caseExact": false, + "mutability": "immutable", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "$ref", + "type": "reference", + "referenceTypes": [ + "User", + "Group" + ], + "multiValued": false, + "description": "The URI corresponding to a SCIM resource that is a member of this Group.", + "required": false, + "caseExact": false, + "mutability": "immutable", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "type", + "type": "string", + "multiValued": false, + "description": "A label indicating the type of resource, e.g., 'User' or 'Group'.", + "required": false, + "caseExact": false, + "canonicalValues": [ + "User", + "Group" + ], + "mutability": "immutable", + "returned": "default", + "uniqueness": "none" + } + ], + "mutability": "readWrite", + "returned": "default" + } + ], + "meta": { + "resourceType": "Schema", + "location": "/v2/Schemas/urn:ietf:params:scim:schemas:core:2.0:Group" + } +} +|] diff --git a/src/Config/Schema/ResourceType.hs b/src/Config/Schema/ResourceType.hs new file mode 100644 index 00000000000..c46abea6012 --- /dev/null +++ b/src/Config/Schema/ResourceType.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Config.Schema.ResourceType (resourceSchema) where + +import Data.Aeson (Value) +import Data.Aeson.QQ + +resourceSchema :: Value +resourceSchema = [aesonQQ| +{ + "id": "urn:ietf:params:scim:schemas:core:2.0:ResourceType", + "name": "ResourceType", + "description": "Specifies the schema that describes a SCIM resource type", + "attributes": [ + { + "name": "id", + "type": "string", + "multiValued": false, + "description": "The resource type's server unique id. May be the same as the 'name' attribute.", + "required": false, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "name", + "type": "string", + "multiValued": false, + "description": "The resource type name. When applicable, service providers MUST specify the name, e.g., 'User'.", + "required": true, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "description", + "type": "string", + "multiValued": false, + "description": "The resource type's human-readable description. When applicable, service providers MUST specify the description.", + "required": false, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "endpoint", + "type": "reference", + "referenceTypes": [ + "uri" + ], + "multiValued": false, + "description": "The resource type's HTTP-addressable endpoint relative to the Base URL, e.g., '\/Users'.", + "required": true, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "schema", + "type": "reference", + "referenceTypes": [ + "uri" + ], + "multiValued": false, + "description": "The resource type's primary\/base schema URI.", + "required": true, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "schemaExtensions", + "type": "complex", + "multiValued": false, + "description": "A list of URIs of the resource type's schema extensions.", + "required": true, + "mutability": "readOnly", + "returned": "default", + "subAttributes": [ + { + "name": "schema", + "type": "reference", + "referenceTypes": [ + "uri" + ], + "multiValued": false, + "description": "The URI of a schema extension.", + "required": true, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "required", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value that specifies whether or not the schema extension is required for the resource type. If true, a resource of this type MUST include this schema extension and also include any attributes declared as required in this schema extension. If false, a resource of this type MAY omit this schema extension.", + "required": true, + "mutability": "readOnly", + "returned": "default" + } + ] + } + ] +} +|] diff --git a/src/Config/Schema/SPConfig.hs b/src/Config/Schema/SPConfig.hs new file mode 100644 index 00000000000..4c1bb38c7fc --- /dev/null +++ b/src/Config/Schema/SPConfig.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Config.Schema.SPConfig (spConfigSchema) where + +import Data.Aeson (Value) +import Data.Aeson.QQ + +spConfigSchema :: Value +spConfigSchema = [aesonQQ| +{ + "id": "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig", + "name": "Service Provider Configuration", + "description": "Schema for representing the service provider's configuration", + "attributes": [ + { + "name": "documentationUri", + "type": "reference", + "referenceTypes": [ + "external" + ], + "multiValued": false, + "description": "An HTTP-addressable URL pointing to the service provider's human-consumable help documentation.", + "required": false, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "patch", + "type": "complex", + "multiValued": false, + "description": "A complex type that specifies PATCH configuration options.", + "required": true, + "returned": "default", + "mutability": "readOnly", + "subAttributes": [ + { + "name": "supported", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value specifying whether or not the operation is supported.", + "required": true, + "mutability": "readOnly", + "returned": "default" + } + ] + }, + { + "name": "bulk", + "type": "complex", + "multiValued": false, + "description": "A complex type that specifies bulk configuration options.", + "required": true, + "returned": "default", + "mutability": "readOnly", + "subAttributes": [ + { + "name": "supported", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value specifying whether or not the operation is supported.", + "required": true, + "mutability": "readOnly", + "returned": "default" + }, + { + "name": "maxOperations", + "type": "integer", + "multiValued": false, + "description": "An integer value specifying the maximum number of operations.", + "required": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "maxPayloadSize", + "type": "integer", + "multiValued": false, + "description": "An integer value specifying the maximum payload size in bytes.", + "required": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + } + ] + }, + { + "name": "filter", + "type": "complex", + "multiValued": false, + "description": "A complex type that specifies FILTER options.", + "required": true, + "returned": "default", + "mutability": "readOnly", + "subAttributes": [ + { + "name": "supported", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value specifying whether or not the operation is supported.", + "required": true, + "mutability": "readOnly", + "returned": "default" + }, + { + "name": "maxResults", + "type": "integer", + "multiValued": false, + "description": "An integer value specifying the maximum number of resources returned in a response.", + "required": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + } + ] + }, + { + "name": "changePassword", + "type": "complex", + "multiValued": false, + "description": "A complex type that specifies configuration options related to changing a password.", + "required": true, + "returned": "default", + "mutability": "readOnly", + "subAttributes": [ + { + "name": "supported", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value specifying whether or not the operation is supported.", + "required": true, + "mutability": "readOnly", + "returned": "default" + } + ] + }, + { + "name": "sort", + "type": "complex", + "multiValued": false, + "description": "A complex type that specifies sort result options.", + "required": true, + "returned": "default", + "mutability": "readOnly", + "subAttributes": [ + { + "name": "supported", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value specifying whether or not the operation is supported.", + "required": true, + "mutability": "readOnly", + "returned": "default" + } + ] + }, + { + "name": "authenticationSchemes", + "type": "complex", + "multiValued": true, + "description": "A complex type that specifies supported authentication scheme properties.", + "required": true, + "returned": "default", + "mutability": "readOnly", + "subAttributes": [ + { + "name": "name", + "type": "string", + "multiValued": false, + "description": "The common authentication scheme name, e.g., HTTP Basic.", + "required": true, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "description", + "type": "string", + "multiValued": false, + "description": "A description of the authentication scheme.", + "required": true, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "specUri", + "type": "reference", + "referenceTypes": [ + "external" + ], + "multiValued": false, + "description": "An HTTP-addressable URL pointing to the authentication scheme's specification.", + "required": false, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "documentationUri", + "type": "reference", + "referenceTypes": [ + "external" + ], + "multiValued": false, + "description": "An HTTP-addressable URL pointing to the authentication scheme's usage documentation.", + "required": false, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + } + ] + } + ] +} +|] diff --git a/src/Config/Schema/Schema.hs b/src/Config/Schema/Schema.hs new file mode 100644 index 00000000000..aa46e184794 --- /dev/null +++ b/src/Config/Schema/Schema.hs @@ -0,0 +1,355 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Config.Schema.Schema (metaSchema) where + +import Data.Aeson (Value) +import Data.Aeson.QQ + +metaSchema :: Value +metaSchema = [aesonQQ| +{ + "id": "urn:ietf:params:scim:schemas:core:2.0:Schema", + "name": "Schema", + "description": "Specifies the schema that describes a SCIM schema", + "attributes": [ + { + "name": "id", + "type": "string", + "multiValued": false, + "description": "The unique URI of the schema. When applicable, service providers MUST specify the URI.", + "required": true, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "name", + "type": "string", + "multiValued": false, + "description": "The schema's human-readable name. When applicable, service providers MUST specify the name, e.g., 'User'.", + "required": true, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "description", + "type": "string", + "multiValued": false, + "description": "The schema's human-readable name. When applicable, service providers MUST specify the name, e.g., 'User'.", + "required": false, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "attributes", + "type": "complex", + "multiValued": true, + "description": "A complex attribute that includes the attributes of a schema.", + "required": true, + "mutability": "readOnly", + "returned": "default", + "subAttributes": [ + { + "name": "name", + "type": "string", + "multiValued": false, + "description": "The attribute's name.", + "required": true, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "type", + "type": "string", + "multiValued": false, + "description": "The attribute's data type. Valid values include 'string', 'complex', 'boolean', 'decimal', 'integer', 'dateTime', 'reference'.", + "required": true, + "canonicalValues": [ + "string", + "complex", + "boolean", + "decimal", + "integer", + "dateTime", + "reference" + ], + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "multiValued", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value indicating an attribute's plurality.", + "required": true, + "mutability": "readOnly", + "returned": "default" + }, + { + "name": "description", + "type": "string", + "multiValued": false, + "description": "A human-readable description of the attribute.", + "required": false, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "required", + "type": "boolean", + "multiValued": false, + "description": "A boolean value indicating whether or not the attribute is required.", + "required": false, + "mutability": "readOnly", + "returned": "default" + }, + { + "name": "canonicalValues", + "type": "string", + "multiValued": true, + "description": "A collection of canonical values. When applicable, service providers MUST specify the canonical types, e.g., 'work', 'home'.", + "required": false, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "caseExact", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value indicating whether or not a string attribute is case sensitive.", + "required": false, + "mutability": "readOnly", + "returned": "default" + }, + { + "name": "mutability", + "type": "string", + "multiValued": false, + "description": "Indicates whether or not an attribute is modifiable.", + "required": false, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none", + "canonicalValues": [ + "readOnly", + "readWrite", + "immutable", + "writeOnly" + ] + }, + { + "name": "returned", + "type": "string", + "multiValued": false, + "description": "Indicates when an attribute is returned in a response (e.g., to a query).", + "required": false, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none", + "canonicalValues": [ + "always", + "never", + "default", + "request" + ] + }, + { + "name": "uniqueness", + "type": "string", + "multiValued": false, + "description": "Indicates how unique a value must be.", + "required": false, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none", + "canonicalValues": [ + "none", + "server", + "global" + ] + }, + { + "name": "referenceTypes", + "type": "string", + "multiValued": true, + "description": "Used only with an attribute of type 'reference'. Specifies a SCIM resourceType that a reference attribute MAY refer to, e.g., 'User'.", + "required": false, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "subAttributes", + "type": "complex", + "multiValued": true, + "description": "Used to define the sub-attributes of a complex attribute.", + "required": false, + "mutability": "readOnly", + "returned": "default", + "subAttributes": [ + { + "name": "name", + "type": "string", + "multiValued": false, + "description": "The attribute's name.", + "required": true, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "type", + "type": "string", + "multiValued": false, + "description": "The attribute's data type. Valid values include 'string', 'complex', 'boolean', 'decimal', 'integer', 'dateTime', 'reference'.", + "required": true, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none", + "canonicalValues": [ + "string", + "complex", + "boolean", + "decimal", + "integer", + "dateTime", + "reference" + ] + }, + { + "name": "multiValued", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value indicating an attribute's plurality.", + "required": true, + "mutability": "readOnly", + "returned": "default" + }, + { + "name": "description", + "type": "string", + "multiValued": false, + "description": "A human-readable description of the attribute.", + "required": false, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "required", + "type": "boolean", + "multiValued": false, + "description": "A boolean value indicating whether or not the attribute is required.", + "required": false, + "mutability": "readOnly", + "returned": "default" + }, + { + "name": "canonicalValues", + "type": "string", + "multiValued": true, + "description": "A collection of canonical values. When applicable, service providers MUST specify the canonical types, e.g., 'work', 'home'.", + "required": false, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "caseExact", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value indicating whether or not a string attribute is case sensitive.", + "required": false, + "mutability": "readOnly", + "returned": "default" + }, + { + "name": "mutability", + "type": "string", + "multiValued": false, + "description": "Indicates whether or not an attribute is modifiable.", + "required": false, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none", + "canonicalValues": [ + "readOnly", + "readWrite", + "immutable", + "writeOnly" + ] + }, + { + "name": "returned", + "type": "string", + "multiValued": false, + "description": "Indicates when an attribute is returned in a response (e.g., to a query).", + "required": false, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none", + "canonicalValues": [ + "always", + "never", + "default", + "request" + ] + }, + { + "name": "uniqueness", + "type": "string", + "multiValued": false, + "description": "Indicates how unique a value must be.", + "required": false, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none", + "canonicalValues": [ + "none", + "server", + "global" + ] + }, + { + "name": "referenceTypes", + "type": "string", + "multiValued": false, + "description": "Used only with an attribute of type 'reference'. Specifies a SCIM resourceType that a reference attribute MAY refer to, e.g., 'User'.", + "required": false, + "caseExact": true, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + } + ] + } + ] + } + ] +} +|] diff --git a/src/Config/Schema/User.hs b/src/Config/Schema/User.hs new file mode 100644 index 00000000000..4d30aa4f8d9 --- /dev/null +++ b/src/Config/Schema/User.hs @@ -0,0 +1,786 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Config.Schema.User (userSchema) where + +import Data.Aeson (Value) +import Data.Aeson.QQ + +userSchema :: Value +userSchema = [aesonQQ| +{ + "id": "urn:ietf:params:scim:schemas:core:2.0:User", + "name": "User", + "description": "User Account", + "attributes": [ + { + "name": "userName", + "type": "string", + "multiValued": false, + "description": "Unique identifier for the User, typically used by the user to directly authenticate to the service provider. Each User MUST include a non-empty userName value. This identifier MUST be unique across the service provider's entire set of Users. REQUIRED.", + "required": true, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "server" + }, + { + "name": "name", + "type": "complex", + "multiValued": false, + "description": "The components of the user's real name. Providers MAY return just the full name as a single string in the formatted sub-attribute, or they MAY return just the individual component attributes using the other sub-attributes, or they MAY return both. If both variants are returned, they SHOULD be describing the same name, with the formatted name indicating how the component attributes should be combined.", + "required": false, + "subAttributes": [ + { + "name": "formatted", + "type": "string", + "multiValued": false, + "description": "The full name, including all middle names, titles, and suffixes as appropriate, formatted for display (e.g., 'Ms. Barbara J Jensen, III').", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "familyName", + "type": "string", + "multiValued": false, + "description": "The family name of the User, or last name in most Western languages (e.g., 'Jensen' given the full name 'Ms. Barbara J Jensen, III').", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "givenName", + "type": "string", + "multiValued": false, + "description": "The given name of the User, or first name in most Western languages (e.g., 'Barbara' given the full name 'Ms. Barbara J Jensen, III').", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "middleName", + "type": "string", + "multiValued": false, + "description": "The middle name(s) of the User (e.g., 'Jane' given the full name 'Ms. Barbara J Jensen, III').", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "honorificPrefix", + "type": "string", + "multiValued": false, + "description": "The honorific prefix(es) of the User, or title in most Western languages (e.g., 'Ms.' given the full name 'Ms. Barbara J Jensen, III').", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "honorificSuffix", + "type": "string", + "multiValued": false, + "description": "The honorific suffix(es) of the User, or suffix in most Western languages (e.g., 'III' given the full name 'Ms. Barbara J Jensen, III').", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + } + ], + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "displayName", + "type": "string", + "multiValued": false, + "description": "The name of the User, suitable for display to end-users. The name SHOULD be the full name of the User being described, if known.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "nickName", + "type": "string", + "multiValued": false, + "description": "The casual way to address the user in real life, e.g., 'Bob' or 'Bobby' instead of 'Robert'. This attribute SHOULD NOT be used to represent a User's username (e.g., 'bjensen' or 'mpepperidge').", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "profileUrl", + "type": "reference", + "referenceTypes": [ + "external" + ], + "multiValued": false, + "description": "A fully qualified URL pointing to a page representing the User's online profile.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "title", + "type": "string", + "multiValued": false, + "description": "The user's title, such as \"Vice President.\"", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "userType", + "type": "string", + "multiValued": false, + "description": "Used to identify the relationship between the organization and the user. Typical values used might be 'Contractor', 'Employee', 'Intern', 'Temp', 'External', and 'Unknown', but any value may be used.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "preferredLanguage", + "type": "string", + "multiValued": false, + "description": "Indicates the User's preferred written or spoken language. Generally used for selecting a localized user interface; e.g., 'en_US' specifies the language English and country US.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "locale", + "type": "string", + "multiValued": false, + "description": "Used to indicate the User's default location for purposes of localizing items such as currency, date time format, or numerical representations.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "timezone", + "type": "string", + "multiValued": false, + "description": "The User's time zone in the 'Olson' time zone database format, e.g., 'America\/Los_Angeles'.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "active", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value indicating the User's administrative status.", + "required": false, + "mutability": "readWrite", + "returned": "default" + }, + { + "name": "password", + "type": "string", + "multiValued": false, + "description": "The User's cleartext password. This attribute is intended to be used as a means to specify an initial password when creating a new User or to reset an existing User's password.", + "required": false, + "caseExact": false, + "mutability": "writeOnly", + "returned": "never", + "uniqueness": "none" + }, + { + "name": "emails", + "type": "complex", + "multiValued": true, + "description": "Email addresses for the user. The value SHOULD be canonicalized by the service provider, e.g., 'bjensen@example.com' instead of 'bjensen@EXAMPLE.COM'. Canonical type values of 'work', 'home', and 'other'.", + "required": false, + "subAttributes": [ + { + "name": "value", + "type": "string", + "multiValued": false, + "description": "Email addresses for the user. The value SHOULD be canonicalized by the service provider, e.g., 'bjensen@example.com' instead of 'bjensen@EXAMPLE.COM'. Canonical type values of 'work', 'home', and 'other'.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "display", + "type": "string", + "multiValued": false, + "description": "A human-readable name, primarily used for display purposes. READ-ONLY.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "type", + "type": "string", + "multiValued": false, + "description": "A label indicating the attribute's function, e.g., 'work' or 'home'.", + "required": false, + "caseExact": false, + "canonicalValues": [ + "work", + "home", + "other" + ], + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "primary", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value indicating the 'primary' or preferred attribute value for this attribute, e.g., the preferred mailing address or primary email address. The primary attribute value 'true' MUST appear no more than once.", + "required": false, + "mutability": "readWrite", + "returned": "default" + } + ], + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "phoneNumbers", + "type": "complex", + "multiValued": true, + "description": "Phone numbers for the User. The value SHOULD be canonicalized by the service provider according to the format specified in RFC 3966, e.g., 'tel:+1-201-555-0123'. Canonical type values of 'work', 'home', 'mobile', 'fax', 'pager', and 'other'.", + "required": false, + "subAttributes": [ + { + "name": "value", + "type": "string", + "multiValued": false, + "description": "Phone number of the User.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "display", + "type": "string", + "multiValued": false, + "description": "A human-readable name, primarily used for display purposes. READ-ONLY.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "type", + "type": "string", + "multiValued": false, + "description": "A label indicating the attribute's function, e.g., 'work', 'home', 'mobile'.", + "required": false, + "caseExact": false, + "canonicalValues": [ + "work", + "home", + "mobile", + "fax", + "pager", + "other" + ], + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "primary", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value indicating the 'primary' or preferred attribute value for this attribute, e.g., the preferred phone number or primary phone number. The primary attribute value 'true' MUST appear no more than once.", + "required": false, + "mutability": "readWrite", + "returned": "default" + } + ], + "mutability": "readWrite", + "returned": "default" + }, + { + "name": "ims", + "type": "complex", + "multiValued": true, + "description": "Instant messaging addresses for the User.", + "required": false, + "subAttributes": [ + { + "name": "value", + "type": "string", + "multiValued": false, + "description": "Instant messaging address for the User.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "display", + "type": "string", + "multiValued": false, + "description": "A human-readable name, primarily used for display purposes. READ-ONLY.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "type", + "type": "string", + "multiValued": false, + "description": "A label indicating the attribute's function, e.g., 'aim', 'gtalk', 'xmpp'.", + "required": false, + "caseExact": false, + "canonicalValues": [ + "aim", + "gtalk", + "icq", + "xmpp", + "msn", + "skype", + "qq", + "yahoo" + ], + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "primary", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value indicating the 'primary' or preferred attribute value for this attribute, e.g., the preferred messenger or primary messenger. The primary attribute value 'true' MUST appear no more than once.", + "required": false, + "mutability": "readWrite", + "returned": "default" + } + ], + "mutability": "readWrite", + "returned": "default" + }, + { + "name": "photos", + "type": "complex", + "multiValued": true, + "description": "URLs of photos of the User.", + "required": false, + "subAttributes": [ + { + "name": "value", + "type": "reference", + "referenceTypes": [ + "external" + ], + "multiValued": false, + "description": "URL of a photo of the User.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "display", + "type": "string", + "multiValued": false, + "description": "A human-readable name, primarily used for display purposes. READ-ONLY.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "type", + "type": "string", + "multiValued": false, + "description": "A label indicating the attribute's function, i.e., 'photo' or 'thumbnail'.", + "required": false, + "caseExact": false, + "canonicalValues": [ + "photo", + "thumbnail" + ], + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "primary", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value indicating the 'primary' or preferred attribute value for this attribute, e.g., the preferred photo or thumbnail. The primary attribute value 'true' MUST appear no more than once.", + "required": false, + "mutability": "readWrite", + "returned": "default" + } + ], + "mutability": "readWrite", + "returned": "default" + }, + { + "name": "addresses", + "type": "complex", + "multiValued": true, + "description": "A physical mailing address for this User. Canonical type values of 'work', 'home', and 'other'. This attribute is a complex type with the following sub-attributes.", + "required": false, + "subAttributes": [ + { + "name": "formatted", + "type": "string", + "multiValued": false, + "description": "The full mailing address, formatted for display or use with a mailing label. This attribute MAY contain newlines.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "streetAddress", + "type": "string", + "multiValued": false, + "description": "The full street address component, which may include house number, street name, P.O. box, and multi-line extended street address information. This attribute MAY contain newlines.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "locality", + "type": "string", + "multiValued": false, + "description": "The city or locality component.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "region", + "type": "string", + "multiValued": false, + "description": "The state or region component.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "postalCode", + "type": "string", + "multiValued": false, + "description": "The zip code or postal code component.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "country", + "type": "string", + "multiValued": false, + "description": "The country name component.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "type", + "type": "string", + "multiValued": false, + "description": "A label indicating the attribute's function, e.g., 'work' or 'home'.", + "required": false, + "caseExact": false, + "canonicalValues": [ + "work", + "home", + "other" + ], + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + } + ], + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "groups", + "type": "complex", + "multiValued": true, + "description": "A list of groups to which the user belongs, either through direct membership, through nested groups, or dynamically calculated.", + "required": false, + "subAttributes": [ + { + "name": "value", + "type": "string", + "multiValued": false, + "description": "The identifier of the User's group.", + "required": false, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "$ref", + "type": "reference", + "referenceTypes": [ + "User", + "Group" + ], + "multiValued": false, + "description": "The URI of the corresponding 'Group' resource to which the user belongs.", + "required": false, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "display", + "type": "string", + "multiValued": false, + "description": "A human-readable name, primarily used for display purposes. READ-ONLY.", + "required": false, + "caseExact": false, + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "type", + "type": "string", + "multiValued": false, + "description": "A label indicating the attribute's function, e.g., 'direct' or 'indirect'.", + "required": false, + "caseExact": false, + "canonicalValues": [ + "direct", + "indirect" + ], + "mutability": "readOnly", + "returned": "default", + "uniqueness": "none" + } + ], + "mutability": "readOnly", + "returned": "default" + }, + { + "name": "entitlements", + "type": "complex", + "multiValued": true, + "description": "A list of entitlements for the User that represent a thing the User has.", + "required": false, + "subAttributes": [ + { + "name": "value", + "type": "string", + "multiValued": false, + "description": "The value of an entitlement.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "display", + "type": "string", + "multiValued": false, + "description": "A human-readable name, primarily used for display purposes. READ-ONLY.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "type", + "type": "string", + "multiValued": false, + "description": "A label indicating the attribute's function.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "primary", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value indicating the 'primary' or preferred attribute value for this attribute. The primary attribute value 'true' MUST appear no more than once.", + "required": false, + "mutability": "readWrite", + "returned": "default" + } + ], + "mutability": "readWrite", + "returned": "default" + }, + { + "name": "roles", + "type": "complex", + "multiValued": true, + "description": "A list of roles for the User that collectively represent who the User is, e.g., 'Student', 'Faculty'.", + "required": false, + "subAttributes": [ + { + "name": "value", + "type": "string", + "multiValued": false, + "description": "The value of a role.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "display", + "type": "string", + "multiValued": false, + "description": "A human-readable name, primarily used for display purposes. READ-ONLY.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "type", + "type": "string", + "multiValued": false, + "description": "A label indicating the attribute's function.", + "required": false, + "caseExact": false, + "canonicalValues": [ + + ], + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "primary", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value indicating the 'primary' or preferred attribute value for this attribute. The primary attribute value 'true' MUST appear no more than once.", + "required": false, + "mutability": "readWrite", + "returned": "default" + } + ], + "mutability": "readWrite", + "returned": "default" + }, + { + "name": "x509Certificates", + "type": "complex", + "multiValued": true, + "description": "A list of certificates issued to the User.", + "required": false, + "caseExact": false, + "subAttributes": [ + { + "name": "value", + "type": "binary", + "multiValued": false, + "description": "The value of an X.509 certificate.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "display", + "type": "string", + "multiValued": false, + "description": "A human-readable name, primarily used for display purposes. READ-ONLY.", + "required": false, + "caseExact": false, + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "type", + "type": "string", + "multiValued": false, + "description": "A label indicating the attribute's function.", + "required": false, + "caseExact": false, + "canonicalValues": [], + "mutability": "readWrite", + "returned": "default", + "uniqueness": "none" + }, + { + "name": "primary", + "type": "boolean", + "multiValued": false, + "description": "A Boolean value indicating the 'primary' or preferred attribute value for this attribute. The primary attribute value 'true' MUST appear no more than once.", + "required": false, + "mutability": "readWrite", + "returned": "default" + } + ], + "mutability": "readWrite", + "returned": "default" + } + ], + "meta": { + "resourceType": "Schema", + "location": "/v2/Schemas/urn:ietf:params:scim:schemas:core:2.0:User" + } +} +|] diff --git a/src/DB/User.hs b/src/DB/User.hs new file mode 100644 index 00000000000..56b6095dde0 --- /dev/null +++ b/src/DB/User.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} + +module DB.User + ( UserDB (..) + , StoredUser + , UpdateError (..) + ) where + +import Schema.User +import Schema.Meta +import Schema.ListResponse + +type StoredUser = WithMeta (WithId User) + +data UpdateError = NonExisting + | Mutability + +class UserDB m where + list :: m (ListResponse StoredUser) + get :: UserId -> m (Maybe StoredUser) + create :: User -> m StoredUser + update :: UserId -> User -> m (Either UpdateError StoredUser) + patch :: UserId -> m StoredUser + delete :: UserId -> m Bool + getMeta :: m Meta diff --git a/src/SCIM.hs b/src/SCIM.hs new file mode 100644 index 00000000000..2e1bd04070e --- /dev/null +++ b/src/SCIM.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} + +module SCIM + ( app + , SiteAPI + ) where + +import API.Group (GroupSite (..), GroupDB, groupServer) +import Config.Schema (ConfigAPI, Configuration, configServer) +import Control.Applicative ((<|>), Alternative) +import Control.Monad.Except +import Control.Error.Util (note) +import Data.Text +import DB.User (StoredUser, UserDB) +import qualified DB.User as User +import GHC.Generics (Generic) +import Network.Wai +import Schema.User hiding (schemas) +import Schema.Meta +import Schema.Error +import Schema.ListResponse +import Servant +import Servant.Generic + + +type SCIMHandler m = (MonadError ServantErr m, UserDB m, GroupDB m) +type SiteAPI = ToServant (Site AsApi) + +data Site route = Site + { config :: route :- ToServant (ConfigAPI AsApi) + , users :: route :- "Users" :> ToServant (UserSite AsApi) + , groups :: route :- "Groups" :> ToServant (GroupSite AsApi) + } deriving (Generic) + +data UserSite route = UserSite + { getUsers :: route :- + Get '[JSON] (ListResponse StoredUser) + , getUser :: route :- + Capture "id" Text :> Get '[JSON] StoredUser + , postUser :: route :- + ReqBody '[JSON] User :> PostCreated '[JSON] StoredUser + , putUser :: route :- + Capture "id" Text :> ReqBody '[JSON] User :> Put '[JSON] StoredUser + , patchUser :: route :- + Capture "id" Text :> Patch '[JSON] StoredUser + , deleteUser :: route :- + Capture "id" Text :> DeleteNoContent '[JSON] NoContent + } deriving (Generic) + + +siteServer :: SCIMHandler m => UserSite (AsServerT m) +siteServer = UserSite + { getUsers = User.list + , getUser = getUser' + , postUser = User.create + , putUser = updateUser' + , patchUser = User.patch + , deleteUser = deleteUser' + } + +superServer :: Configuration -> SCIMHandler m => Site (AsServerT m) +superServer conf = Site + { config = toServant $ configServer conf + , users = toServant siteServer + , groups = toServant groupServer + } + +updateUser' :: SCIMHandler m => UserId -> User -> m StoredUser +updateUser' uid update = do + -- TODO: don't fetch here, let User.update do it + stored <- User.get uid + case stored of + Just (WithMeta _meta (WithId _ existing)) -> + let newUser = existing `overwriteWith` update + in do + t <- User.update uid newUser + case t of + Left _err -> throwError err400 + Right newStored -> pure newStored + Nothing -> throwError err400 + +getUser' :: SCIMHandler m => UserId -> m StoredUser +getUser' uid = do + maybeUser <- User.get uid + liftEither $ note (notFound uid) maybeUser + +deleteUser' :: SCIMHandler m => UserId -> m NoContent +deleteUser' uid = do + deleted <- User.delete uid + if deleted then return NoContent else throwError err404 + +api :: Proxy SiteAPI +api = Proxy + +app :: SCIMHandler m => Configuration -> (forall a. m a -> Handler a) -> Application +app c t = serve (Proxy :: Proxy SiteAPI) $ hoistServer api t (toServant $ superServer c) + + +-- TODO: move to User.hs +overwriteWith :: User -> User -> User +overwriteWith old new = old + { --externalId :: Unsettable Text + name = merge name + , displayName = merge displayName + , nickName = merge nickName + , profileUrl = merge profileUrl + , title = merge title + , userType = merge userType + , preferredLanguage = merge preferredLanguage + , locale = merge locale + , active = merge active + , password = merge password + , emails = mergeList emails + , phoneNumbers = mergeList phoneNumbers + , ims = mergeList ims + , photos = mergeList photos + , addresses = mergeList addresses + , entitlements = mergeList entitlements + , roles = mergeList roles + , x509Certificates = mergeList x509Certificates + } + where + merge :: (Alternative f) => (User -> f a) -> f a + merge accessor = (accessor new) <|> (accessor old) + + mergeList :: (User -> Maybe [a]) -> Maybe [a] + mergeList accessor = case accessor new of + Just [] -> accessor old + _ -> (accessor new) <|> (accessor old) diff --git a/src/Schema/Common.hs b/src/Schema/Common.hs new file mode 100644 index 00000000000..65f36cd581a --- /dev/null +++ b/src/Schema/Common.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} + +module Schema.Common where + +import Data.Text hiding (dropWhile) +import Data.Aeson +import qualified Data.Char as Char +import qualified Data.HashMap.Strict as HM +import Data.String (IsString) +import qualified Network.URI as Network + + + +newtype URI = URI { unURI :: Network.URI } + deriving (Show, Eq) + +instance FromJSON URI where + parseJSON = withText "URI" $ \uri -> case Network.parseURI (unpack uri) of + Nothing -> fail "Invalid URI" + Just some -> pure $ URI some + +instance ToJSON URI where + toJSON (URI uri) = String $ pack $ show uri + +toKeyword :: (IsString p, Eq p) => p -> p +toKeyword "typ" = "type" +toKeyword "ref" = "$ref" +toKeyword other = other + +serializeOptions :: Options +serializeOptions = defaultOptions + { omitNothingFields = True + , fieldLabelModifier = toKeyword + } + +-- | Turn all keys in a JSON object to lowercase. +jsonLower :: Value -> Value +jsonLower (Object o) = Object . HM.fromList . fmap lowerPair . HM.toList $ o + where lowerPair (key, val) = (fromKeyword . toLower $ key, val) +jsonLower x = x + +fromKeyword :: (IsString p, Eq p) => p -> p +fromKeyword "type" = "typ" +fromKeyword "$ref" = "ref" +fromKeyword other = other + +parseOptions :: Options +parseOptions = defaultOptions + { fieldLabelModifier = fmap Char.toLower + } + +data Unsettable a = Unset | Omitted | Some a + deriving (Show, Eq) + +instance Functor Unsettable where + fmap f (Some a) = Some $ f a + fmap _ Unset = Unset + fmap _ Omitted = Omitted + +instance (FromJSON a) => FromJSON (Unsettable a) where + parseJSON Null = pure Unset + parseJSON v = do + res <- parseJSON v + case res of + Nothing -> pure Omitted + Just some -> pure $ Some some + +toMaybe :: Unsettable a -> Maybe a +toMaybe Unset = Nothing +toMaybe Omitted = Nothing +toMaybe (Some a) = Just a + +instance (ToJSON a) => ToJSON (Unsettable a) where + toJSON Unset = Null + toJSON v = toJSON . toMaybe $ v diff --git a/src/Schema/Error.hs b/src/Schema/Error.hs new file mode 100644 index 00000000000..a71be9c0410 --- /dev/null +++ b/src/Schema/Error.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Schema.Error (notFound, fromErrorType) where + +import Data.Text (Text, pack) +import Data.Aeson hiding (Error) +import Data.Monoid ((<>)) +import Schema.Common +import Servant (ServantErr (..), err404, err400) + +import GHC.Generics (Generic) + +data ErrorType = InvalidFilter + | TooMany + | Uniqueness + | Mutability + | InvalidSyntax + | InvalidPath + | NoTarget + | InvalidValue + | InvalidVers + | Sensitive + deriving (Show, Eq, Generic) + +instance ToJSON ErrorType where + toJSON InvalidFilter = "invalidFilter" + toJSON TooMany = "tooMany" + toJSON Uniqueness = "uniqueness" + toJSON Mutability = "mutability" + toJSON InvalidSyntax = "invalidSyntax" + toJSON InvalidPath = "invalidPath" + toJSON NoTarget = "noTarget" + toJSON InvalidValue = "invalidValue" + toJSON InvalidVers = "invalidVers" + toJSON Sensitive = "sensitive" + + +fromErrorType :: ErrorType -> ServantErr +fromErrorType typ = + let body = Error + { schemas = [Error2_0] + , status = Status 400 + , scimType = pure typ + , detail = Nothing + } + in err400 { errBody = encode body + , errHeaders = [("Content-Type", "application/json")] + } + +notFound :: Text -> ServantErr +notFound rid = + let body = Error + { schemas = [Error2_0] + , status = Status 404 + , scimType = Nothing + , detail = pure $ "Resource " <> rid <> " not found" + } + in err404 { errBody = encode body + , errHeaders = [("Content-Type", "application/json")] + } + +-- wrapped in a newtype because SCIM wants strings for status codes +newtype Status = Status Int + deriving (Show, Eq, Generic) + +instance ToJSON Status where + toJSON (Status stat) = String . pack . show $ stat + +-- TODO: move to common schema datatype +data Schema = Error2_0 + deriving (Show, Eq) + +instance ToJSON Schema where + toJSON Error2_0 = String "urn:ietf:params:scim:api:messages:2.0:Error" + +data Error = Error + { schemas :: [Schema] + , status :: Status + , scimType :: Maybe ErrorType + , detail :: Maybe Text + } deriving (Show, Eq, Generic) + +instance ToJSON Error where + toJSON = genericToJSON serializeOptions diff --git a/src/Schema/ListResponse.hs b/src/Schema/ListResponse.hs new file mode 100644 index 00000000000..14e3b4e767e --- /dev/null +++ b/src/Schema/ListResponse.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} + +module Schema.ListResponse (ListResponse, fromList) where + +import Data.Aeson +import GHC.Generics (Generic) +import Schema.Common +import Schema.Schema + +data ListResponse a = ListResponse + { schemas :: [Schema] + , totalResults :: Int + , resources :: [a] + } deriving (Show, Eq, Generic) + +fromList :: [a] -> ListResponse a +fromList list = ListResponse + { schemas = [ListResponse2_0] + , totalResults = length list + , resources = list + } + +instance FromJSON a => FromJSON (ListResponse a) where + parseJSON = genericParseJSON parseOptions . jsonLower + +instance ToJSON a => ToJSON (ListResponse a) where + toJSON = genericToJSON serializeOptions + diff --git a/src/Schema/Meta.hs b/src/Schema/Meta.hs new file mode 100644 index 00000000000..15d7355b5ff --- /dev/null +++ b/src/Schema/Meta.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Schema.Meta where + +import Prelude hiding (map) + +import Data.Text (Text) +import Data.Aeson + +import Schema.Common +import Schema.Schema (Schema) +import Schema.User.Address (Address) +import Schema.User.Certificate (Certificate) +import Schema.User.Email (Email) +import Schema.User.IM (IM) +import Schema.User.Name (Name) +import Schema.User.Phone (Phone) +import Schema.User.Photo (Photo) + +import GHC.Generics (Generic) + +-- TODO: move to Meta.hs +import qualified Data.HashMap.Lazy as HML +import Data.Time.Clock +import qualified Network.URI as Network + +-- TODO: Move to Common/Meta +data WithId a = WithId + { id :: Text + , value :: a + } deriving (Eq, Show) + +instance (ToJSON a) => ToJSON (WithId a) where + toJSON (WithId i v) = case toJSON v of + (Object o) -> Object (HML.insert "id" (String i) o) + other -> other + +data ResourceType = UserResource + | GroupResource + deriving (Eq, Show) + +instance ToJSON ResourceType where + toJSON UserResource = "User" + toJSON GroupResource = "Group" + +data ETag = Weak Text | Strong Text + deriving (Eq, Show) + +instance ToJSON ETag where + toJSON (Weak tag) = String $ "W/\"" `mappend` tag `mappend` "\"" + toJSON (Strong tag) = String $ "\"" `mappend` tag `mappend` "\"" + +data Meta = Meta + { resourceType :: ResourceType + , created :: UTCTime + , lastModified :: UTCTime + , version :: ETag + , location :: URI + } deriving (Eq, Show, Generic) + +instance ToJSON Meta + +data WithMeta a = WithMeta + { meta :: Meta + , thing :: a + } deriving (Eq, Show, Generic) + +instance (ToJSON a) => ToJSON (WithMeta a) where + toJSON (WithMeta m v) = case toJSON v of + (Object o) -> Object (HML.insert "meta" (toJSON m) o) + other -> other diff --git a/src/Schema/Schema.hs b/src/Schema/Schema.hs new file mode 100644 index 00000000000..919a62993aa --- /dev/null +++ b/src/Schema/Schema.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Schema.Schema where + +import Data.Aeson + +data Schema = User20 + | ListResponse2_0 + deriving (Show, Eq) + +instance FromJSON Schema where + parseJSON = withText "schema" $ \s -> case s of + "urn:ietf:params:scim:schemas:core:2.0:User" -> + pure User20 + "urn:ietf:params:scim:api:messages:2.0:ListResponse" -> + pure ListResponse2_0 + _ -> + fail "unsupported schema" + +instance ToJSON Schema where + toJSON User20 = + "urn:ietf:params:scim:schemas:core:2.0:User" + toJSON ListResponse2_0 = + "urn:ietf:params:scim:api:messages:2.0:ListResponse" diff --git a/src/Schema/User.hs b/src/Schema/User.hs new file mode 100644 index 00000000000..df624678a1b --- /dev/null +++ b/src/Schema/User.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Schema.User where + +import Prelude hiding (map) + +import Data.Text (Text) +import Data.Aeson + +import Schema.Common +import Schema.Schema (Schema) +import Schema.User.Address (Address) +import Schema.User.Certificate (Certificate) +import Schema.User.Email (Email) +import Schema.User.IM (IM) +import Schema.User.Name (Name) +import Schema.User.Phone (Phone) +import Schema.User.Photo (Photo) + +import GHC.Generics (Generic) + +import Schema.Meta +-- TODO: move to Meta.hs +import qualified Data.HashMap.Lazy as HML +import Data.Time.Clock +import qualified Network.URI as Network + +data User = User + { schemas :: [Schema] + , userName :: Text + , externalId :: Maybe Text + , name :: Maybe Name + , displayName :: Maybe Text + , nickName :: Maybe Text + , profileUrl :: Maybe URI + , title :: Maybe Text + , userType :: Maybe Text + , preferredLanguage :: Maybe Text + , locale :: Maybe Text + , active :: Maybe Bool + , password :: Maybe Text + , emails :: Maybe [Email] + , phoneNumbers :: Maybe [Phone] + , ims :: Maybe [IM] + , photos :: Maybe [Photo] + , addresses :: Maybe [Address] + , entitlements :: Maybe [Text] + , roles :: Maybe [Text] + , x509Certificates :: Maybe [Certificate] + } deriving (Show, Eq, Generic) + +instance FromJSON User where + parseJSON = genericParseJSON parseOptions . jsonLower + +instance ToJSON User where + toJSON = genericToJSON serializeOptions + +-- TODO: type parameter? +type UserId = Text + diff --git a/src/Schema/User/Address.hs b/src/Schema/User/Address.hs new file mode 100644 index 00000000000..43b7831077e --- /dev/null +++ b/src/Schema/User/Address.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} + +module Schema.User.Address where + +import Data.Text hiding (dropWhile) +import Data.Aeson +import GHC.Generics (Generic) +import Schema.Common + +data Address = Address + { formatted :: Maybe Text + , streetAddress :: Maybe Text + , locality :: Maybe Text + , region :: Maybe Text + , postalCode :: Maybe Text + -- TODO: country is specified as ISO3166, but example uses "USA" + , country :: Maybe Text + , typ :: Maybe Text + , primary :: Maybe Bool + } deriving (Show, Eq, Generic) + +instance FromJSON Address where + parseJSON = genericParseJSON parseOptions . jsonLower + +instance ToJSON Address where + toJSON = genericToJSON serializeOptions diff --git a/src/Schema/User/Certificate.hs b/src/Schema/User/Certificate.hs new file mode 100644 index 00000000000..33361b52d04 --- /dev/null +++ b/src/Schema/User/Certificate.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Schema.User.Certificate where + +import Data.Text (Text) +import Data.Aeson +import GHC.Generics + +import Schema.Common + + +data Certificate = Certificate + { typ :: Maybe Text + , value :: Maybe Text + } deriving (Show, Eq, Generic) + +instance FromJSON Certificate where + parseJSON = genericParseJSON parseOptions . jsonLower + +instance ToJSON Certificate where + toJSON = genericToJSON serializeOptions diff --git a/src/Schema/User/Email.hs b/src/Schema/User/Email.hs new file mode 100644 index 00000000000..81dae5b4e27 --- /dev/null +++ b/src/Schema/User/Email.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Schema.User.Email where + +import Data.Text hiding (dropWhile) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Aeson +import GHC.Generics (Generic) +import Schema.Common +import Text.Email.Validate + +newtype EmailAddress2 = EmailAddress2 + { unEmailAddress :: EmailAddress } + deriving (Show, Eq) + +instance FromJSON EmailAddress2 where + parseJSON = withText "Email" $ \e -> case emailAddress (encodeUtf8 e) of + Nothing -> fail "Invalid email" + Just some -> pure $ EmailAddress2 some + +instance ToJSON EmailAddress2 where + toJSON (EmailAddress2 e) = String $ decodeUtf8 . toByteString $ e + +data Email = Email + { typ :: Maybe Text + , value :: EmailAddress2 + , primary :: Maybe Bool + } deriving (Show, Eq, Generic) + +instance FromJSON Email where + parseJSON = genericParseJSON parseOptions . jsonLower + +instance ToJSON Email where + toJSON = genericToJSON serializeOptions diff --git a/src/Schema/User/IM.hs b/src/Schema/User/IM.hs new file mode 100644 index 00000000000..99392a0bcdc --- /dev/null +++ b/src/Schema/User/IM.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Schema.User.IM where + +import Data.Text (Text) +import Data.Aeson +import GHC.Generics + +import Schema.Common + +data IM = IM + { typ :: Maybe Text + , value :: Maybe Text + } deriving (Show, Eq, Generic) + +instance FromJSON IM where + parseJSON = genericParseJSON parseOptions . jsonLower + +instance ToJSON IM where + toJSON = genericToJSON serializeOptions diff --git a/src/Schema/User/Name.hs b/src/Schema/User/Name.hs new file mode 100644 index 00000000000..84df03892a1 --- /dev/null +++ b/src/Schema/User/Name.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Schema.User.Name where + +import Data.Text (Text) +import Data.Aeson +import GHC.Generics + +import Schema.Common + +data Name = Name + { formatted :: Maybe Text + , familyName :: Maybe Text + , givenName :: Maybe Text + , middleName :: Maybe Text + , honorificPrefix :: Maybe Text + , honorificSuffix :: Maybe Text + } deriving (Show, Eq, Generic) + +instance FromJSON Name where + parseJSON = genericParseJSON parseOptions . jsonLower + +instance ToJSON Name where + toJSON = genericToJSON serializeOptions diff --git a/src/Schema/User/Phone.hs b/src/Schema/User/Phone.hs new file mode 100644 index 00000000000..22f2801e85e --- /dev/null +++ b/src/Schema/User/Phone.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Schema.User.Phone where + +import Data.Text hiding (dropWhile) +import Data.Aeson +import GHC.Generics (Generic) +import Schema.Common + +data Phone = Phone + { typ :: Maybe Text + , value :: Maybe Text + } deriving (Show, Eq, Generic) + +instance FromJSON Phone where + parseJSON = genericParseJSON parseOptions . jsonLower + +instance ToJSON Phone where + toJSON = genericToJSON serializeOptions diff --git a/src/Schema/User/Photo.hs b/src/Schema/User/Photo.hs new file mode 100644 index 00000000000..a46f62ce4d3 --- /dev/null +++ b/src/Schema/User/Photo.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Schema.User.Photo where + +import Data.Text (Text) +import Data.Aeson +import GHC.Generics + +import Schema.Common + +data Photo = Photo + { typ :: Maybe Text + , value :: Maybe URI + } deriving (Show, Eq, Generic) + +instance FromJSON Photo where + parseJSON = genericParseJSON parseOptions . jsonLower + +instance ToJSON Photo where + toJSON = genericToJSON serializeOptions diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 00000000000..4bb069a1b34 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,74 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-10.8 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) + +# TODO: since we are using hoisting, we need servant 0.12+ +extra-deps: + - http-types-0.12.1 + - servant-0.13 + - servant-server-0.13 + - text-1.2.3.0 + +allow-newer: true + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.6" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 00000000000..37fc7ae1774 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main, startApp) where + +import Network.Wai.Handler.Warp +import Network.Wai.Logger +import Config.Schema (empty) +import qualified Test.Config.Schema as Config +import qualified Test.API.Groups as Groups +import SCIM +import qualified STMContainers.Map as Map +import Test.Hspec +import Test.Hspec.Wai hiding (post, put, patch) +import Test.Hspec.Wai.JSON +import Util +import Data.ByteString.Lazy (ByteString) + +main :: IO () +main = do + emptyState <- TestStorage <$> Map.newIO <*> Map.newIO + hspec $ describe "/Users" (spec emptyState) + hspec $ describe "/Groups" (Groups.spec emptyState) +-- hspec $ describe "Configuration" (Config.spec emptyState) + +startApp :: Int -> IO () +startApp port = do + emptyState <- TestStorage <$> Map.newIO <*> Map.newIO + withStdoutLogger $ \aplogger -> do + let settings = setPort port $ setLogger aplogger defaultSettings + runSettings settings $ app empty $ nt emptyState + +spec :: TestStorage -> Spec +spec s = with (return (app empty (nt s))) $ do + describe "GET & POST /Users" $ do + it "responds with [] in empty environment" $ do + get "/Users" `shouldRespondWith` emptyList + + it "can insert then retrieve stored Users" $ do + post "/Users" newBarbara `shouldRespondWith` 201 + get "/Users" `shouldRespondWith` users + + describe "GET /Users/:id" $ do + it "responds with 404 for unknown user" $ do + get "/Users/unknown" `shouldRespondWith` unknown + + it "retrieves stored user" $ do + -- the test implementation stores users with uid [0,1..n-1] + get "/Users/0" `shouldRespondWith` barbara + + describe "PUT /Users/:id" $ do + it "updates mutable fields" $ do + put "/Users/0" barbUpdate0 `shouldRespondWith` updatedBarb0 + + it "does not create new user " $ do + put "/Users/nonexisting" newBarbara `shouldRespondWith` 400 + + describe "DELETE /Users/:id" $ do + it "responds with 404 for unknown user" $ do + delete "/Users/unknown" `shouldRespondWith` 404 + + it "deletes a stored user" $ do + delete "/Users/0" `shouldRespondWith` 204 + -- user should be gone + get "/Users/0" `shouldRespondWith` 404 + delete "/Users/0" `shouldRespondWith` 404 + + +newBarbara :: ByteString +newBarbara = [json| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "userName":"bjensen", + "externalId":"bjensen", + "name":{ + "formatted":"Ms. Barbara J Jensen III", + "familyName":"Jensen", + "givenName":"Barbara" + } + }|] + + +barbara :: ResponseMatcher +barbara = [json| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "userName":"bjensen", + "name": { + "givenName":"Barbara", + "formatted":"Ms. Barbara J Jensen III", + "familyName":"Jensen" + }, + "id":"0", + "externalId":"bjensen", + "meta":{ + "resourceType":"User", + "location":"todo", + "created":"2018-01-01T00:00:00Z", + "version":"W/\"testVersion\"", + "lastModified":"2018-01-01T00:00:00Z" + } + }|] + +users :: ResponseMatcher +users = [json| + { "schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], + "totalResults": 1, + "resources": + [{ "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "userName":"bjensen", + "externalId":"bjensen", + "id" : "0", + "name":{ + "formatted":"Ms. Barbara J Jensen III", + "familyName":"Jensen", + "givenName":"Barbara" + }, + "meta":{ + "resourceType":"User", + "location":"todo", + "created":"2018-01-01T00:00:00Z", + "version":"W/\"testVersion\"", + "lastModified":"2018-01-01T00:00:00Z" + } + }] + }|] + +-- source: https://tools.ietf.org/html/rfc7644#section-3.5.1 (p. 30) +barbUpdate0 :: ByteString +barbUpdate0 = [json| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "id":"0", + "userName":"bjensen", + "externalId":"bjensen", + "name":{ + "formatted":"Ms. Barbara J Jensen III", + "familyName":"Jensen", + "givenName":"Barbara", + "middleName":"Jane" + }, + "roles":[], + "emails":[ + { + "value":"bjensen@example.com" + }, + { + "value":"babs@jensen.org" + } + ] + }|] + + +updatedBarb0 :: ResponseMatcher +updatedBarb0 = [json| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "id":"0", + "userName":"bjensen", + "externalId":"bjensen", + "name":{ + "formatted":"Ms. Barbara J Jensen III", + "familyName":"Jensen", + "givenName":"Barbara", + "middleName":"Jane" + }, + "emails":[ + { + "value":"bjensen@example.com" + }, + { + "value":"babs@jensen.org" + } + ], + "meta":{ + "resourceType":"User", + "location":"todo", + "created":"2018-01-01T00:00:00Z", + "version":"W/\"testVersion\"", + "lastModified":"2018-01-01T00:00:00Z" + } + }|] + +emptyList :: ResponseMatcher +emptyList = [json| + { "schemas": ["urn:ietf:params:scim:api:messages:2.0:ListResponse"], + "resources":[], + "totalResults":0 + }|] + +unknown :: ResponseMatcher +unknown = [json| + { "schemas": ["urn:ietf:params:scim:api:messages:2.0:Error"], + "status": "404", + "detail": "Resource unknown not found" + }|] { matchStatus = 404 } diff --git a/test/Test/API/Groups.hs b/test/Test/API/Groups.hs new file mode 100644 index 00000000000..e592e3b38a8 --- /dev/null +++ b/test/Test/API/Groups.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.API.Groups (spec) where + +import API.Group (GroupSite (..), GroupDB, groupServer, app) +import Data.Aeson hiding (json) +import Data.ByteString.Lazy (ByteString) +import qualified Data.HashMap.Strict as SMap +import Data.Maybe (catMaybes) +import qualified Data.Vector as Vector +import Config.Schema +import Network.Wai.Test (SResponse (..)) +import Servant +import Servant.Generic +import Test.Hspec hiding (shouldSatisfy) +import qualified Test.Hspec.Expectations as Expect +import Test.Hspec.Wai hiding (post, put, patch) +import Test.Hspec.Wai.JSON +import Util + + +spec :: TestStorage -> Spec +spec s = with (pure (app (nt s))) $ do + describe "GET & POST /" $ do + it "responds with [] in empty environment" $ do + get "/" `shouldRespondWith` [json|[]|] + + it "can insert then retrieve stored group" $ do + post "/" adminGroup `shouldRespondWith` 201 + get "/" `shouldRespondWith` groups + + describe "GET /:id" $ do + it "responds with 404 for unknown group" $ do + get "/unknown" `shouldRespondWith` unknown + + it "retrieves stored user" $ do + -- the test implementation stores users with uid [0,1..n-1] + get "/0" `shouldRespondWith` admins + + describe "PUT /:id" $ do + it "adds member to existing group" $ do + put "/0" adminUpdate0 `shouldRespondWith` updatedAdmins0 + + it "does not create new group" $ do + put "/nonexisting" adminGroup `shouldRespondWith` 400 + + describe "DELETE /:id" $ do + it "responds with 404 for unknown group" $ do + delete "/Users/unknown" `shouldRespondWith` 404 + + it "deletes a stored group" $ do + delete "/0" `shouldRespondWith` 204 + -- user should be gone + get "/0" `shouldRespondWith` 404 + delete "/0" `shouldRespondWith` 404 + + + +adminGroup :: ByteString +adminGroup = [json| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], + "displayName":"Admin", + "members":[] + }|] + + +groups :: ResponseMatcher +groups = [json| + [{ "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], + "displayName":"Admin", + "members":[], + "id":"0", + "meta":{ + "resourceType":"Group", + "location":"todo", + "created":"2018-01-01T00:00:00Z", + "version":"W/\"testVersion\"", + "lastModified":"2018-01-01T00:00:00Z" + } + }]|] + +admins :: ResponseMatcher +admins = [json| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], + "displayName":"Admin", + "members":[], + "id":"0", + "meta":{ + "resourceType":"Group", + "location":"todo", + "created":"2018-01-01T00:00:00Z", + "version":"W/\"testVersion\"", + "lastModified":"2018-01-01T00:00:00Z" + } + }|] + +adminUpdate0 :: ByteString +adminUpdate0 = [json| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], + "displayName":"Admin", + "members":[ + { "value": "0", + "$ref": "https://example.com/Users/0", + "type": "User" + } + ] + }|] + +updatedAdmins0 :: ResponseMatcher +updatedAdmins0 = [json| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], + "displayName":"Admin", + "members":[ + { "value": "0", + "$ref": "https://example.com/Users/0", + "type": "User" + }], + "id":"0", + "meta":{ + "resourceType":"Group", + "location":"todo", + "created":"2018-01-01T00:00:00Z", + "version":"W/\"testVersion\"", + "lastModified":"2018-01-01T00:00:00Z" + } + }|] + + +unknown :: ResponseMatcher +unknown = [json| + { "schemas": ["urn:ietf:params:scim:api:messages:2.0:Error"], + "status": "404", + "detail": "Resource unknown not found" + }|] { matchStatus = 404 } diff --git a/test/Test/Config/Schema.hs b/test/Test/Config/Schema.hs new file mode 100644 index 00000000000..2a82328b4ad --- /dev/null +++ b/test/Test/Config/Schema.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.Config.Schema (spec) where + +import Data.Aeson hiding (json) +import qualified Data.HashMap.Strict as SMap +import Data.Maybe (catMaybes) +import qualified Data.Vector as Vector +import Config.Schema +import Network.Wai.Test (SResponse (..)) +import Servant +import Servant.Generic +import Test.Hspec hiding (shouldSatisfy) +import qualified Test.Hspec.Expectations as Expect +import Test.Hspec.Wai hiding (post, put, patch) +import Test.Hspec.Wai.JSON + +server :: Proxy (ToServant (ConfigAPI AsApi)) +server = Proxy + +app :: Application +app = serve server $ toServant $ configServer empty + +shouldSatisfy :: (Show a, FromJSON a) => + WaiSession SResponse -> (a -> Bool) -> WaiExpectation +shouldSatisfy resp predicate = do + maybeDecoded <- decode . simpleBody <$> resp + case maybeDecoded of + Nothing -> liftIO $ Expect.expectationFailure "decode error" + (Just decoded) -> liftIO $ Expect.shouldSatisfy decoded predicate + + +coreSchemas :: [Value] +coreSchemas = String <$> + [ "urn:ietf:params:scim:schemas:core:2.0:User" + , "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig" + , "urn:ietf:params:scim:schemas:core:2.0:Group" + , "urn:ietf:params:scim:schemas:core:2.0:Schema" + , "urn:ietf:params:scim:schemas:core:2.0:ResourceType" + ] + +hasSchemas :: Value -> Bool +-- TODO: these needs to be sorted, but there's no Ord on Value +-- (and I'm lazy) +hasSchemas (Array arr) = coreSchemas == getSchemaIds arr +hasSchemas _ = False + +getSchemaIds :: Array -> [Value] +getSchemaIds arr = catMaybes . Vector.toList $ getSchemaId <$> arr + +getSchemaId :: Value -> Maybe Value +getSchemaId (Object o) = SMap.lookup "id" o +getSchemaId _ = Nothing + +spec :: Spec +spec = with (pure app) $ do + describe "GET /Schemas" $ do + it "lists schemas" $ do + get "/Schemas" `shouldRespondWith` 200 + get "/Schemas" `shouldSatisfy` hasSchemas + + describe "GET /Schemas/:id" $ do + it "returns valid schema" $ do + -- TODO: (partially) verify content + get "/Schemas/urn:ietf:params:scim:schemas:core:2.0:User" + `shouldRespondWith` 200 + it "returns 404 on unknown schemaId" $ do + get "/Schemas/unknown" `shouldRespondWith` 404 + + describe "GET /ServiceProviderConfig" $ do + it "returns configuration" $ do + get "/ServiceProviderConfig" `shouldRespondWith` spConfig + + +-- FIXME: missing some "supported" fields and URI should not be null +spConfig :: ResponseMatcher +spConfig = [json| +{"documentationUri":null, + "etag":{"supported":false}, + "bulk":{"maxOperations":0, + "maxPayloadSize":0, + "supported":false + }, + "patch":{"supported":false}, + "authenticationSchemes":[], + "changePassword":{"supported":false}, + "sort":{"supported":false}, + "filter":{"maxResults":0, + "supported":false + } +} +|] diff --git a/test/Util.hs b/test/Util.hs new file mode 100644 index 00000000000..df9fbf41d17 --- /dev/null +++ b/test/Util.hs @@ -0,0 +1,183 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Util where + + +import API.Group +import Control.Monad.STM +import Control.Monad.Reader +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Text +import Data.Time.Clock +import Data.Time.Calendar +import DB.User +import ListT +import Network.HTTP.Types +import Network.Wai.Test (SResponse) +import qualified STMContainers.Map as Map +import STMContainers.Map (Map) +import Schema.User +import Schema.Meta +import Schema.ListResponse +import qualified Schema.Common as Common +import Servant +import Test.Hspec.Wai hiding (post, put, patch) + +import Prelude hiding (id) + +type UserStorage = Map Text StoredUser +type GroupStorage = Map Text StoredGroup + +data TestStorage = TestStorage + { userDB :: UserStorage + , groupDB :: GroupStorage + } + +-- in-memory implementation of the API for tests +type TestServer = ReaderT TestStorage Handler + +liftAtomic :: STM a -> ReaderT TestStorage Handler a +liftAtomic = liftIO . atomically + +instance UserDB TestServer where + list = do + m <- userDB <$> ask + l <- liftIO . atomically $ ListT.toList $ Map.stream m + return $ fromList $ snd <$> l + get i = do + m <- userDB <$> ask + liftIO . atomically $ Map.lookup i m + create user = do + m <- userDB <$> ask + met <- getMeta + newUser <- liftIO . atomically $ insertUser user met m + return newUser + update uid user = do + storage <- userDB <$> ask + liftAtomic $ updateUser uid user storage + delete uid = do + m <- userDB <$> ask + liftIO . atomically $ delUser uid m + getMeta = createMeta UserResource + +instance GroupDB TestServer where + list = do + m <- groupDB <$> ask + l <- liftIO . atomically $ ListT.toList $ Map.stream m + return $ snd <$> l + get i = do + m <- groupDB <$> ask + liftIO . atomically $ Map.lookup i m + create = \grp -> do + storage <- groupDB <$> ask + met <- getGroupMeta + newGroup <- liftIO . atomically $ insertGroup grp met storage + pure newGroup + update i g = do + m <- groupDB <$> ask + liftAtomic $ updateGroup i g m + delete gid = do + m <- groupDB <$> ask + liftIO . atomically $ delGroup gid m + getGroupMeta = createMeta GroupResource + +insertGroup :: Group -> Meta -> GroupStorage -> STM StoredGroup +insertGroup grp met storage = do + size <- Map.size storage + let gid = pack . show $ size + newGroup = WithMeta met $ WithId gid grp + Map.insert newGroup gid storage + return newGroup + +updateGroup :: GroupId -> Group -> GroupStorage -> STM (Either ServantErr StoredGroup) +updateGroup gid grp storage = do + existing <- Map.lookup gid storage + case existing of + Nothing -> pure $ Left err400 + Just stored -> do + let newMeta = meta stored + newGroup = WithMeta newMeta $ WithId gid grp + Map.insert newGroup gid storage + pure $ Right newGroup + +updateUser :: UserId -> User -> UserStorage -> STM (Either UpdateError StoredUser) +updateUser uid user storage = do + existing <- Map.lookup uid storage + case existing of + Nothing -> pure $ Left NonExisting + Just stored -> do + let newMeta = meta stored + newUser = WithMeta newMeta $ WithId uid user + Map.insert newUser uid storage + pure $ Right newUser + +-- TODO: what needs checking here? +-- (there seems to be no readOnly fields in User) +assertMutability :: User -> StoredUser -> Bool +assertMutability _newUser _stored = True + +delGroup :: GroupId -> GroupStorage -> STM Bool +delGroup gid storage = do + g <- Map.lookup gid storage + case g of + Nothing -> return False + Just _ -> Map.delete gid storage >> return True + +delUser :: UserId -> UserStorage -> STM Bool +delUser uid storage = do + u <- Map.lookup uid storage + case u of + Nothing -> return False + Just _ -> Map.delete uid storage >> return True + +-- 2018-01-01 00:00 +testDate :: UTCTime +testDate = UTCTime + { utctDay = ModifiedJulianDay 58119 + , utctDayTime = 0 + } + +-- static meta for testing +createMeta :: ResourceType -> ReaderT TestStorage Handler Meta +createMeta typ = return $ Meta + { resourceType = typ + , created = testDate + , lastModified = testDate + , version = Weak "testVersion" + , location = Common.URI $ URI "todo" Nothing "" "" "" + } + +-- insert with a simple incrementing integer id (good for testing) +insertUser :: User -> Meta -> UserStorage -> STM StoredUser +insertUser user met storage = do + size <- Map.size storage + let uid = pack . show $ size + newUser = WithMeta met $ WithId uid user + Map.insert newUser uid storage + return newUser + +-- Natural transformation from our transformer stack to the Servant +-- stack +-- this takes the initial environment and returns the transformation +nt :: r -> ReaderT r m a -> m a +nt = flip runReaderT + +-- Redefine wai test helpers to include json content type +post :: ByteString -> L.ByteString -> WaiSession SResponse +post path = request methodPost path [(hContentType, "application/json")] + +put :: ByteString -> L.ByteString -> WaiSession SResponse +put path = request methodPut path [(hContentType, "application/json")] + +patch :: ByteString -> L.ByteString -> WaiSession SResponse +patch path = request methodPatch path [(hContentType, "application/json")] + From 5d88e84369ab48cc0c20fdd08e2a85db454eabb6 Mon Sep 17 00:00:00 2001 From: Jon Elverkilde Date: Thu, 26 Apr 2018 14:53:56 +0200 Subject: [PATCH 02/64] Remove redundant imports --- src/API/Group.hs | 6 +----- src/Schema/Meta.hs | 10 ---------- src/Schema/User.hs | 5 ----- test/Spec.hs | 1 - test/Test/API/Groups.hs | 11 +---------- 5 files changed, 2 insertions(+), 31 deletions(-) diff --git a/src/API/Group.hs b/src/API/Group.hs index 2adbd0ce329..48d59525809 100644 --- a/src/API/Group.hs +++ b/src/API/Group.hs @@ -13,21 +13,17 @@ module API.Group ( GroupSite (..) , StoredGroup , Group (..) , GroupId + , Member (..) , groupServer , app ) where -import Config.Schema (ConfigAPI, Configuration, configServer) -import Control.Applicative ((<|>), Alternative) import Control.Monad.Except import Control.Error.Util (note) import Data.Text import Data.Aeson -import DB.User (StoredUser, UserDB) -import qualified DB.User as User import GHC.Generics (Generic) import Network.Wai -import Schema.User hiding (schemas) import Schema.Common import Schema.Error import Schema.Meta diff --git a/src/Schema/Meta.hs b/src/Schema/Meta.hs index 15d7355b5ff..2ed98cf9ff3 100644 --- a/src/Schema/Meta.hs +++ b/src/Schema/Meta.hs @@ -9,21 +9,11 @@ import Data.Text (Text) import Data.Aeson import Schema.Common -import Schema.Schema (Schema) -import Schema.User.Address (Address) -import Schema.User.Certificate (Certificate) -import Schema.User.Email (Email) -import Schema.User.IM (IM) -import Schema.User.Name (Name) -import Schema.User.Phone (Phone) -import Schema.User.Photo (Photo) - import GHC.Generics (Generic) -- TODO: move to Meta.hs import qualified Data.HashMap.Lazy as HML import Data.Time.Clock -import qualified Network.URI as Network -- TODO: Move to Common/Meta data WithId a = WithId diff --git a/src/Schema/User.hs b/src/Schema/User.hs index df624678a1b..fc1a9605d31 100644 --- a/src/Schema/User.hs +++ b/src/Schema/User.hs @@ -20,11 +20,6 @@ import Schema.User.Photo (Photo) import GHC.Generics (Generic) -import Schema.Meta --- TODO: move to Meta.hs -import qualified Data.HashMap.Lazy as HML -import Data.Time.Clock -import qualified Network.URI as Network data User = User { schemas :: [Schema] diff --git a/test/Spec.hs b/test/Spec.hs index 37fc7ae1774..839470bc1e1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -6,7 +6,6 @@ module Main (main, startApp) where import Network.Wai.Handler.Warp import Network.Wai.Logger import Config.Schema (empty) -import qualified Test.Config.Schema as Config import qualified Test.API.Groups as Groups import SCIM import qualified STMContainers.Map as Map diff --git a/test/Test/API/Groups.hs b/test/Test/API/Groups.hs index e592e3b38a8..aee3b7ec26d 100644 --- a/test/Test/API/Groups.hs +++ b/test/Test/API/Groups.hs @@ -7,18 +7,9 @@ module Test.API.Groups (spec) where -import API.Group (GroupSite (..), GroupDB, groupServer, app) -import Data.Aeson hiding (json) +import API.Group (app) import Data.ByteString.Lazy (ByteString) -import qualified Data.HashMap.Strict as SMap -import Data.Maybe (catMaybes) -import qualified Data.Vector as Vector -import Config.Schema -import Network.Wai.Test (SResponse (..)) -import Servant -import Servant.Generic import Test.Hspec hiding (shouldSatisfy) -import qualified Test.Hspec.Expectations as Expect import Test.Hspec.Wai hiding (post, put, patch) import Test.Hspec.Wai.JSON import Util From 3842d6528853fc6cff8ce72c60b6d8cf839b99a4 Mon Sep 17 00:00:00 2001 From: Jon Elverkilde Date: Thu, 26 Apr 2018 15:42:54 +0200 Subject: [PATCH 03/64] Fix warnings --- test/Util.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/Util.hs b/test/Util.hs index df9fbf41d17..934f793d6b5 100644 --- a/test/Util.hs +++ b/test/Util.hs @@ -68,6 +68,7 @@ instance UserDB TestServer where m <- userDB <$> ask liftIO . atomically $ delUser uid m getMeta = createMeta UserResource + patch = undefined instance GroupDB TestServer where list = do @@ -148,8 +149,8 @@ testDate = UTCTime -- static meta for testing createMeta :: ResourceType -> ReaderT TestStorage Handler Meta -createMeta typ = return $ Meta - { resourceType = typ +createMeta rType = return $ Meta + { resourceType = rType , created = testDate , lastModified = testDate , version = Weak "testVersion" From 7a92cb625691491574446049b5ef6e08d2cce5ac Mon Sep 17 00:00:00 2001 From: jschaul Date: Thu, 26 Apr 2018 18:42:13 +0200 Subject: [PATCH 04/64] fix cabal, add TODO --- hscim.cabal | 2 ++ src/DB/User.hs | 2 ++ 2 files changed, 4 insertions(+) diff --git a/hscim.cabal b/hscim.cabal index 7b43469c52b..06a488ea31f 100644 --- a/hscim.cabal +++ b/hscim.cabal @@ -36,6 +36,8 @@ library Schema.User.Name Schema.User.Phone Schema.User.Photo + Schema.ListResponse + Schema.Meta build-depends: base >= 4.7 && < 5 , aeson diff --git a/src/DB/User.hs b/src/DB/User.hs index 56b6095dde0..2117887c928 100644 --- a/src/DB/User.hs +++ b/src/DB/User.hs @@ -23,6 +23,8 @@ type StoredUser = WithMeta (WithId User) data UpdateError = NonExisting | Mutability + +-- TODO: parameterize UserId class UserDB m where list :: m (ListResponse StoredUser) get :: UserId -> m (Maybe StoredUser) From b41a15ff97c27cd71877a86722c553a2c8ea9e3a Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 27 Apr 2018 10:30:21 +0200 Subject: [PATCH 05/64] hpack --- hscim.cabal | 202 ++++++++++++++++++++++++++++++--------------------- package.yaml | 62 ++++++++++++++++ 2 files changed, 183 insertions(+), 81 deletions(-) create mode 100644 package.yaml diff --git a/hscim.cabal b/hscim.cabal index 06a488ea31f..8bc161016ff 100644 --- a/hscim.cabal +++ b/hscim.cabal @@ -1,93 +1,133 @@ +-- This file has been generated from package.yaml by hpack version 0.17.0. +-- +-- see: https://github.com/sol/hpack + name: hscim version: 0.1.0.0 --- synopsis: --- description: -homepage: https://github.com/githubuser/hscim#readme -license: AGPL-3 +synopsis: ... +description: ... +homepage: https://github.com/wireapp/hscim/README.md +bug-reports: https://github.com/wireapp/hscim/issues +license: APGL-3 license-file: LICENSE author: Wire Swiss GmbH maintainer: Wire Swiss GmbH copyright: (c) 2018 Wire Swiss GmbH category: Web build-type: Simple -extra-source-files: README.md -cabal-version: >=1.10 +cabal-version: >= 1.10 -library - hs-source-dirs: src - ghc-options: -Wall - exposed-modules: SCIM - API.Group - Config.Schema - Config.Schema.Schema - Config.Schema.User - Config.Schema.Group - Config.Schema.SPConfig - Config.Schema.ResourceType - DB.User - Schema.Common - Schema.Error - Schema.Schema - Schema.User - Schema.User.Address - Schema.User.Certificate - Schema.User.Email - Schema.User.IM - Schema.User.Name - Schema.User.Phone - Schema.User.Photo - Schema.ListResponse - Schema.Meta +extra-source-files: + README.md - build-depends: base >= 4.7 && < 5 - , aeson - , aeson-qq - , mtl - , servant-server - , servant-generic - , text - , time - , wai - , network-uri - , unordered-containers - , email-validate - , errors - default-language: Haskell2010 +source-repository head + type: git + location: https://github.com/wireapp/hscim -test-suite hscim-test - type: exitcode-stdio-1.0 - other-modules: Util - Test.Config.Schema - Test.API.Groups - hs-source-dirs: test - main-is: Spec.hs - build-depends: base - , bytestring - , hscim - , hspec - , hspec-expectations - , hspec-wai - , hspec-wai-json - , aeson - , http-types - , stm-containers - , text - , bytestring - , wai-extra - , stm - , stm-containers - , mtl - , list-t - , time - , servant-server - , servant-generic - , vector - , unordered-containers - , warp - , wai-logger - ghc-options: -threaded -rtsopts -with-rtsopts=-N - default-language: Haskell2010 +library + hs-source-dirs: + src + ghc-options: -Wall + exposed-modules: + API.Group + Config.Schema + Config.Schema.Group + Config.Schema.ResourceType + Config.Schema.Schema + Config.Schema.SPConfig + Config.Schema.User + DB.User + Schema.Common + Schema.Error + Schema.ListResponse + Schema.Meta + Schema.Schema + Schema.User + Schema.User.Address + Schema.User.Certificate + Schema.User.Email + Schema.User.IM + Schema.User.Name + Schema.User.Phone + Schema.User.Photo + SCIM + build-depends: + base >= 4.7 && < 5 + , aeson + , mtl + , servant-server + , servant-generic + , text + , time + , wai + , network-uri + , unordered-containers + , email-validate + , errors + default-language: Haskell2010 -source-repository head - type: git - location: https://github.com/githubuser/hscim +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + src + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >= 4.7 && < 5 + , aeson + , mtl + , servant-server + , servant-generic + , text + , time + , wai + , network-uri + , unordered-containers + , email-validate + , errors + , base + , bytestring + , hscim + , hspec + , hspec-wai + , hspec-wai-json + , aeson + , http-types + , stm-containers + , text + , bytestring + , wai-extra + , stm + , stm-containers + , mtl + , list-t + , time + , servant-server + other-modules: + Test.API.Groups + Test.Config.Schema + Util + API.Group + Config.Schema + Config.Schema.Group + Config.Schema.ResourceType + Config.Schema.Schema + Config.Schema.SPConfig + Config.Schema.User + DB.User + Schema.Common + Schema.Error + Schema.ListResponse + Schema.Meta + Schema.Schema + Schema.User + Schema.User.Address + Schema.User.Certificate + Schema.User.Email + Schema.User.IM + Schema.User.Name + Schema.User.Phone + Schema.User.Photo + SCIM + default-language: Haskell2010 diff --git a/package.yaml b/package.yaml new file mode 100644 index 00000000000..a6b762f0224 --- /dev/null +++ b/package.yaml @@ -0,0 +1,62 @@ +name: hscim +version: 0.1.0.0 +synopsis: ... +description: ... +homepage: https://github.com/wireapp/hscim/README.md +license: APGL-3 +license-file: LICENSE +author: Wire Swiss GmbH +maintainer: Wire Swiss GmbH +copyright: (c) 2018 Wire Swiss GmbH +category: Web +build-type: Simple +github: wireapp/hscim + +extra-source-files: + - README.md + +dependencies: + - base >= 4.7 && < 5 + - aeson + - mtl + - servant-server + - servant-generic + - text + - time + - wai + - network-uri + - unordered-containers + - email-validate + - errors + +ghc-options: -Wall + +library: + source-dirs: src + +tests: + spec: + main: Spec.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + source-dirs: + - test + - src + dependencies: + - base + - bytestring + - hscim + - hspec + - hspec-wai + - hspec-wai-json + - aeson + - http-types + - stm-containers + - text + - bytestring + - wai-extra + - stm + - stm-containers + - mtl + - list-t + - time + - servant-server From 40953ded9ccb1190e02a73242c03f21bc70e9664 Mon Sep 17 00:00:00 2001 From: Jon Elverkilde Date: Fri, 27 Apr 2018 10:36:07 +0200 Subject: [PATCH 06/64] Fix directory structure. --- hscim.cabal | 154 +++++++++--------- package.yaml | 7 +- .../SCIM/Capabilities/MetaSchema.hs} | 31 ++-- .../SCIM/Capabilities/MetaSchema}/Group.hs | 2 +- .../Capabilities/MetaSchema}/ResourceType.hs | 2 +- .../SCIM/Capabilities/MetaSchema}/SPConfig.hs | 2 +- .../SCIM/Capabilities/MetaSchema}/Schema.hs | 2 +- .../SCIM/Capabilities/MetaSchema}/User.hs | 2 +- src/{API => Web/SCIM/Class}/Group.hs | 25 +-- src/{DB => Web/SCIM/Class}/User.hs | 8 +- src/{ => Web/SCIM}/Schema/Common.hs | 2 +- src/{ => Web/SCIM}/Schema/Error.hs | 4 +- src/{ => Web/SCIM}/Schema/ListResponse.hs | 6 +- src/{ => Web/SCIM}/Schema/Meta.hs | 4 +- src/{ => Web/SCIM}/Schema/Schema.hs | 2 +- src/{ => Web/SCIM}/Schema/User.hs | 20 +-- src/{ => Web/SCIM}/Schema/User/Address.hs | 4 +- src/{ => Web/SCIM}/Schema/User/Certificate.hs | 4 +- src/{ => Web/SCIM}/Schema/User/Email.hs | 4 +- src/{ => Web/SCIM}/Schema/User/IM.hs | 4 +- src/{ => Web/SCIM}/Schema/User/Name.hs | 4 +- src/{ => Web/SCIM}/Schema/User/Phone.hs | 4 +- src/{ => Web/SCIM}/Schema/User/Photo.hs | 5 +- src/{SCIM.hs => Web/SCIM/Server.hs} | 18 +- test/{Util.hs => Mock.hs} | 14 +- test/Spec.hs | 8 +- .../Schema.hs => Capabilities/MetaSchema.hs} | 4 +- test/Test/{API => Class}/Groups.hs | 6 +- 28 files changed, 180 insertions(+), 172 deletions(-) rename src/{Config/Schema.hs => Web/SCIM/Capabilities/MetaSchema.hs} (86%) rename src/{Config/Schema => Web/SCIM/Capabilities/MetaSchema}/Group.hs (97%) rename src/{Config/Schema => Web/SCIM/Capabilities/MetaSchema}/ResourceType.hs (97%) rename src/{Config/Schema => Web/SCIM/Capabilities/MetaSchema}/SPConfig.hs (98%) rename src/{Config/Schema => Web/SCIM/Capabilities/MetaSchema}/Schema.hs (99%) rename src/{Config/Schema => Web/SCIM/Capabilities/MetaSchema}/User.hs (99%) rename src/{API => Web/SCIM/Class}/Group.hs (89%) rename src/{DB => Web/SCIM/Class}/User.hs (87%) rename src/{ => Web/SCIM}/Schema/Common.hs (98%) rename src/{ => Web/SCIM}/Schema/Error.hs (96%) rename src/{ => Web/SCIM}/Schema/ListResponse.hs (83%) rename src/{ => Web/SCIM}/Schema/Meta.hs (95%) rename src/{ => Web/SCIM}/Schema/Schema.hs (94%) rename src/{ => Web/SCIM}/Schema/User.hs (71%) rename src/{ => Web/SCIM}/Schema/User/Address.hs (90%) rename src/{ => Web/SCIM}/Schema/User/Certificate.hs (83%) rename src/{ => Web/SCIM}/Schema/User/Email.hs (92%) rename src/{ => Web/SCIM}/Schema/User/IM.hs (83%) rename src/{ => Web/SCIM}/Schema/User/Name.hs (87%) rename src/{ => Web/SCIM}/Schema/User/Phone.hs (84%) rename src/{ => Web/SCIM}/Schema/User/Photo.hs (83%) rename src/{SCIM.hs => Web/SCIM/Server.hs} (89%) rename test/{Util.hs => Mock.hs} (95%) rename test/Test/{Config/Schema.hs => Capabilities/MetaSchema.hs} (96%) rename test/Test/{API => Class}/Groups.hs (97%) diff --git a/hscim.cabal b/hscim.cabal index 8bc161016ff..e30e5ce366d 100644 --- a/hscim.cabal +++ b/hscim.cabal @@ -1,6 +1,8 @@ --- This file has been generated from package.yaml by hpack version 0.17.0. +-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: 13dbc78d452e4b6133bef53cdb89f7cf92493b3eed2cbbb28b4f7eb65483589f name: hscim version: 0.1.0.0 @@ -8,7 +10,7 @@ synopsis: ... description: ... homepage: https://github.com/wireapp/hscim/README.md bug-reports: https://github.com/wireapp/hscim/issues -license: APGL-3 +license: AGPL-3 license-file: LICENSE author: Wire Swiss GmbH maintainer: Wire Swiss GmbH @@ -29,41 +31,43 @@ library src ghc-options: -Wall exposed-modules: - API.Group - Config.Schema - Config.Schema.Group - Config.Schema.ResourceType - Config.Schema.Schema - Config.Schema.SPConfig - Config.Schema.User - DB.User - Schema.Common - Schema.Error - Schema.ListResponse - Schema.Meta - Schema.Schema - Schema.User - Schema.User.Address - Schema.User.Certificate - Schema.User.Email - Schema.User.IM - Schema.User.Name - Schema.User.Phone - Schema.User.Photo - SCIM + Web.SCIM.Capabilities.MetaSchema + Web.SCIM.Capabilities.MetaSchema.Group + Web.SCIM.Capabilities.MetaSchema.ResourceType + Web.SCIM.Capabilities.MetaSchema.Schema + Web.SCIM.Capabilities.MetaSchema.SPConfig + Web.SCIM.Capabilities.MetaSchema.User + Web.SCIM.Class.Group + Web.SCIM.Class.User + Web.SCIM.Schema.Common + Web.SCIM.Schema.Error + Web.SCIM.Schema.ListResponse + Web.SCIM.Schema.Meta + Web.SCIM.Schema.Schema + Web.SCIM.Schema.User + Web.SCIM.Schema.User.Address + Web.SCIM.Schema.User.Certificate + Web.SCIM.Schema.User.Email + Web.SCIM.Schema.User.IM + Web.SCIM.Schema.User.Name + Web.SCIM.Schema.User.Phone + Web.SCIM.Schema.User.Photo + Web.SCIM.Server + other-modules: + Paths_hscim build-depends: - base >= 4.7 && < 5 - , aeson + aeson + , base >=4.7 && <5 + , email-validate + , errors , mtl - , servant-server + , network-uri , servant-generic + , servant-server , text , time - , wai - , network-uri , unordered-containers - , email-validate - , errors + , wai default-language: Haskell2010 test-suite spec @@ -74,60 +78,58 @@ test-suite spec src ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: - base >= 4.7 && < 5 - , aeson - , mtl - , servant-server - , servant-generic - , text - , time - , wai - , network-uri - , unordered-containers - , email-validate - , errors + aeson + , aeson-qq , base , bytestring + , email-validate + , errors , hscim , hspec + , hspec-expectations , hspec-wai , hspec-wai-json - , aeson , http-types - , stm-containers - , text - , bytestring - , wai-extra + , list-t + , mtl + , network-uri + , servant-generic + , servant-server , stm , stm-containers - , mtl - , list-t + , text , time - , servant-server + , unordered-containers + , vector + , wai + , wai-extra + , wai-logger + , warp other-modules: - Test.API.Groups - Test.Config.Schema - Util - API.Group - Config.Schema - Config.Schema.Group - Config.Schema.ResourceType - Config.Schema.Schema - Config.Schema.SPConfig - Config.Schema.User - DB.User - Schema.Common - Schema.Error - Schema.ListResponse - Schema.Meta - Schema.Schema - Schema.User - Schema.User.Address - Schema.User.Certificate - Schema.User.Email - Schema.User.IM - Schema.User.Name - Schema.User.Phone - Schema.User.Photo - SCIM + Mock + Test.Capabilities.MetaSchema + Test.Class.Groups + Web.SCIM.Capabilities.MetaSchema + Web.SCIM.Capabilities.MetaSchema.Group + Web.SCIM.Capabilities.MetaSchema.ResourceType + Web.SCIM.Capabilities.MetaSchema.Schema + Web.SCIM.Capabilities.MetaSchema.SPConfig + Web.SCIM.Capabilities.MetaSchema.User + Web.SCIM.Class.Group + Web.SCIM.Class.User + Web.SCIM.Schema.Common + Web.SCIM.Schema.Error + Web.SCIM.Schema.ListResponse + Web.SCIM.Schema.Meta + Web.SCIM.Schema.Schema + Web.SCIM.Schema.User + Web.SCIM.Schema.User.Address + Web.SCIM.Schema.User.Certificate + Web.SCIM.Schema.User.Email + Web.SCIM.Schema.User.IM + Web.SCIM.Schema.User.Name + Web.SCIM.Schema.User.Phone + Web.SCIM.Schema.User.Photo + Web.SCIM.Server + Paths_hscim default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index a6b762f0224..60921268165 100644 --- a/package.yaml +++ b/package.yaml @@ -3,7 +3,7 @@ version: 0.1.0.0 synopsis: ... description: ... homepage: https://github.com/wireapp/hscim/README.md -license: APGL-3 +license: AGPL-3 license-file: LICENSE author: Wire Swiss GmbH maintainer: Wire Swiss GmbH @@ -49,6 +49,7 @@ tests: - hspec-wai - hspec-wai-json - aeson + - aeson-qq - http-types - stm-containers - text @@ -60,3 +61,7 @@ tests: - list-t - time - servant-server + - vector + - hspec-expectations + - warp + - wai-logger \ No newline at end of file diff --git a/src/Config/Schema.hs b/src/Web/SCIM/Capabilities/MetaSchema.hs similarity index 86% rename from src/Config/Schema.hs rename to src/Web/SCIM/Capabilities/MetaSchema.hs index df5737d14b1..537313b22d7 100644 --- a/src/Config/Schema.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema.hs @@ -8,21 +8,22 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} -module Config.Schema ( ConfigAPI - , configServer - , Supported (..) - , BulkConfig (..) - , FilterConfig (..) - , AuthenticationScheme (..) - , Configuration (..) - , empty - ) where - -import Config.Schema.User -import Config.Schema.SPConfig -import Config.Schema.Group -import Config.Schema.Schema -import Config.Schema.ResourceType +module Web.SCIM.Capabilities.MetaSchema ( + ConfigAPI + , configServer + , Supported (..) + , BulkConfig (..) + , FilterConfig (..) + , AuthenticationScheme (..) + , Configuration (..) + , empty + ) where + +import Web.SCIM.Capabilities.MetaSchema.User +import Web.SCIM.Capabilities.MetaSchema.SPConfig +import Web.SCIM.Capabilities.MetaSchema.Group +import Web.SCIM.Capabilities.MetaSchema.Schema +import Web.SCIM.Capabilities.MetaSchema.ResourceType import Control.Monad.Except import Control.Error.Util (note) import Data.Aeson diff --git a/src/Config/Schema/Group.hs b/src/Web/SCIM/Capabilities/MetaSchema/Group.hs similarity index 97% rename from src/Config/Schema/Group.hs rename to src/Web/SCIM/Capabilities/MetaSchema/Group.hs index e1a46379ba0..26f0501240a 100644 --- a/src/Config/Schema/Group.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema/Group.hs @@ -1,7 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} -module Config.Schema.Group (groupSchema) where +module Web.SCIM.Capabilities.MetaSchema.Group (groupSchema) where import Data.Aeson (Value) import Data.Aeson.QQ diff --git a/src/Config/Schema/ResourceType.hs b/src/Web/SCIM/Capabilities/MetaSchema/ResourceType.hs similarity index 97% rename from src/Config/Schema/ResourceType.hs rename to src/Web/SCIM/Capabilities/MetaSchema/ResourceType.hs index c46abea6012..8a3d79d2e5a 100644 --- a/src/Config/Schema/ResourceType.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema/ResourceType.hs @@ -1,7 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} -module Config.Schema.ResourceType (resourceSchema) where +module Web.SCIM.Capabilities.MetaSchema.ResourceType (resourceSchema) where import Data.Aeson (Value) import Data.Aeson.QQ diff --git a/src/Config/Schema/SPConfig.hs b/src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs similarity index 98% rename from src/Config/Schema/SPConfig.hs rename to src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs index 4c1bb38c7fc..0ed8d5be589 100644 --- a/src/Config/Schema/SPConfig.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs @@ -1,7 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} -module Config.Schema.SPConfig (spConfigSchema) where +module Web.SCIM.Capabilities.MetaSchema.SPConfig (spConfigSchema) where import Data.Aeson (Value) import Data.Aeson.QQ diff --git a/src/Config/Schema/Schema.hs b/src/Web/SCIM/Capabilities/MetaSchema/Schema.hs similarity index 99% rename from src/Config/Schema/Schema.hs rename to src/Web/SCIM/Capabilities/MetaSchema/Schema.hs index aa46e184794..2f1af55940f 100644 --- a/src/Config/Schema/Schema.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema/Schema.hs @@ -1,7 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} -module Config.Schema.Schema (metaSchema) where +module Web.SCIM.Capabilities.MetaSchema.Schema (metaSchema) where import Data.Aeson (Value) import Data.Aeson.QQ diff --git a/src/Config/Schema/User.hs b/src/Web/SCIM/Capabilities/MetaSchema/User.hs similarity index 99% rename from src/Config/Schema/User.hs rename to src/Web/SCIM/Capabilities/MetaSchema/User.hs index 4d30aa4f8d9..d0a588ab035 100644 --- a/src/Config/Schema/User.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema/User.hs @@ -1,7 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} -module Config.Schema.User (userSchema) where +module Web.SCIM.Capabilities.MetaSchema.User (userSchema) where import Data.Aeson (Value) import Data.Aeson.QQ diff --git a/src/API/Group.hs b/src/Web/SCIM/Class/Group.hs similarity index 89% rename from src/API/Group.hs rename to src/Web/SCIM/Class/Group.hs index 48d59525809..9e478c22068 100644 --- a/src/API/Group.hs +++ b/src/Web/SCIM/Class/Group.hs @@ -8,15 +8,16 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} -module API.Group ( GroupSite (..) - , GroupDB (..) - , StoredGroup - , Group (..) - , GroupId - , Member (..) - , groupServer - , app - ) where +module Web.SCIM.Class.Group ( + GroupSite (..) + , GroupDB (..) + , StoredGroup + , Group (..) + , GroupId + , Member (..) + , groupServer + , app + ) where import Control.Monad.Except import Control.Error.Util (note) @@ -24,9 +25,9 @@ import Data.Text import Data.Aeson import GHC.Generics (Generic) import Network.Wai -import Schema.Common -import Schema.Error -import Schema.Meta +import Web.SCIM.Schema.Common +import Web.SCIM.Schema.Error +import Web.SCIM.Schema.Meta import Servant import Servant.Generic diff --git a/src/DB/User.hs b/src/Web/SCIM/Class/User.hs similarity index 87% rename from src/DB/User.hs rename to src/Web/SCIM/Class/User.hs index 2117887c928..b9d99d817c8 100644 --- a/src/DB/User.hs +++ b/src/Web/SCIM/Class/User.hs @@ -8,15 +8,15 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} -module DB.User +module Web.SCIM.Class.User ( UserDB (..) , StoredUser , UpdateError (..) ) where -import Schema.User -import Schema.Meta -import Schema.ListResponse +import Web.SCIM.Schema.User +import Web.SCIM.Schema.Meta +import Web.SCIM.Schema.ListResponse type StoredUser = WithMeta (WithId User) diff --git a/src/Schema/Common.hs b/src/Web/SCIM/Schema/Common.hs similarity index 98% rename from src/Schema/Common.hs rename to src/Web/SCIM/Schema/Common.hs index 65f36cd581a..4b754dc711f 100644 --- a/src/Schema/Common.hs +++ b/src/Web/SCIM/Schema/Common.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -module Schema.Common where +module Web.SCIM.Schema.Common where import Data.Text hiding (dropWhile) import Data.Aeson diff --git a/src/Schema/Error.hs b/src/Web/SCIM/Schema/Error.hs similarity index 96% rename from src/Schema/Error.hs rename to src/Web/SCIM/Schema/Error.hs index a71be9c0410..c0fb21adeb8 100644 --- a/src/Schema/Error.hs +++ b/src/Web/SCIM/Schema/Error.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -module Schema.Error (notFound, fromErrorType) where +module Web.SCIM.Schema.Error (notFound, fromErrorType) where import Data.Text (Text, pack) import Data.Aeson hiding (Error) import Data.Monoid ((<>)) -import Schema.Common +import Web.SCIM.Schema.Common import Servant (ServantErr (..), err404, err400) import GHC.Generics (Generic) diff --git a/src/Schema/ListResponse.hs b/src/Web/SCIM/Schema/ListResponse.hs similarity index 83% rename from src/Schema/ListResponse.hs rename to src/Web/SCIM/Schema/ListResponse.hs index 14e3b4e767e..cae87ecef8a 100644 --- a/src/Schema/ListResponse.hs +++ b/src/Web/SCIM/Schema/ListResponse.hs @@ -2,12 +2,12 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -module Schema.ListResponse (ListResponse, fromList) where +module Web.SCIM.Schema.ListResponse (ListResponse, fromList) where import Data.Aeson import GHC.Generics (Generic) -import Schema.Common -import Schema.Schema +import Web.SCIM.Schema.Common +import Web.SCIM.Schema.Schema data ListResponse a = ListResponse { schemas :: [Schema] diff --git a/src/Schema/Meta.hs b/src/Web/SCIM/Schema/Meta.hs similarity index 95% rename from src/Schema/Meta.hs rename to src/Web/SCIM/Schema/Meta.hs index 2ed98cf9ff3..630b808b1a0 100644 --- a/src/Schema/Meta.hs +++ b/src/Web/SCIM/Schema/Meta.hs @@ -1,14 +1,14 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -module Schema.Meta where +module Web.SCIM.Schema.Meta where import Prelude hiding (map) import Data.Text (Text) import Data.Aeson -import Schema.Common +import Web.SCIM.Schema.Common import GHC.Generics (Generic) -- TODO: move to Meta.hs diff --git a/src/Schema/Schema.hs b/src/Web/SCIM/Schema/Schema.hs similarity index 94% rename from src/Schema/Schema.hs rename to src/Web/SCIM/Schema/Schema.hs index 919a62993aa..387f6120c61 100644 --- a/src/Schema/Schema.hs +++ b/src/Web/SCIM/Schema/Schema.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Schema.Schema where +module Web.SCIM.Schema.Schema where import Data.Aeson diff --git a/src/Schema/User.hs b/src/Web/SCIM/Schema/User.hs similarity index 71% rename from src/Schema/User.hs rename to src/Web/SCIM/Schema/User.hs index fc1a9605d31..806a0e411c9 100644 --- a/src/Schema/User.hs +++ b/src/Web/SCIM/Schema/User.hs @@ -1,22 +1,22 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -module Schema.User where +module Web.SCIM.Schema.User where import Prelude hiding (map) import Data.Text (Text) import Data.Aeson -import Schema.Common -import Schema.Schema (Schema) -import Schema.User.Address (Address) -import Schema.User.Certificate (Certificate) -import Schema.User.Email (Email) -import Schema.User.IM (IM) -import Schema.User.Name (Name) -import Schema.User.Phone (Phone) -import Schema.User.Photo (Photo) +import Web.SCIM.Schema.Common +import Web.SCIM.Schema.Schema (Schema) +import Web.SCIM.Schema.User.Address (Address) +import Web.SCIM.Schema.User.Certificate (Certificate) +import Web.SCIM.Schema.User.Email (Email) +import Web.SCIM.Schema.User.IM (IM) +import Web.SCIM.Schema.User.Name (Name) +import Web.SCIM.Schema.User.Phone (Phone) +import Web.SCIM.Schema.User.Photo (Photo) import GHC.Generics (Generic) diff --git a/src/Schema/User/Address.hs b/src/Web/SCIM/Schema/User/Address.hs similarity index 90% rename from src/Schema/User/Address.hs rename to src/Web/SCIM/Schema/User/Address.hs index 43b7831077e..a471d98cc70 100644 --- a/src/Schema/User/Address.hs +++ b/src/Web/SCIM/Schema/User/Address.hs @@ -2,12 +2,12 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -module Schema.User.Address where +module Web.SCIM.Schema.User.Address where import Data.Text hiding (dropWhile) import Data.Aeson import GHC.Generics (Generic) -import Schema.Common +import Web.SCIM.Schema.Common data Address = Address { formatted :: Maybe Text diff --git a/src/Schema/User/Certificate.hs b/src/Web/SCIM/Schema/User/Certificate.hs similarity index 83% rename from src/Schema/User/Certificate.hs rename to src/Web/SCIM/Schema/User/Certificate.hs index 33361b52d04..cec2e269bb3 100644 --- a/src/Schema/User/Certificate.hs +++ b/src/Web/SCIM/Schema/User/Certificate.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} -module Schema.User.Certificate where +module Web.SCIM.Schema.User.Certificate where import Data.Text (Text) import Data.Aeson import GHC.Generics -import Schema.Common +import Web.SCIM.Schema.Common data Certificate = Certificate diff --git a/src/Schema/User/Email.hs b/src/Web/SCIM/Schema/User/Email.hs similarity index 92% rename from src/Schema/User/Email.hs rename to src/Web/SCIM/Schema/User/Email.hs index 81dae5b4e27..03d5661a1ca 100644 --- a/src/Schema/User/Email.hs +++ b/src/Web/SCIM/Schema/User/Email.hs @@ -1,13 +1,13 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -module Schema.User.Email where +module Web.SCIM.Schema.User.Email where import Data.Text hiding (dropWhile) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Aeson import GHC.Generics (Generic) -import Schema.Common +import Web.SCIM.Schema.Common import Text.Email.Validate newtype EmailAddress2 = EmailAddress2 diff --git a/src/Schema/User/IM.hs b/src/Web/SCIM/Schema/User/IM.hs similarity index 83% rename from src/Schema/User/IM.hs rename to src/Web/SCIM/Schema/User/IM.hs index 99392a0bcdc..4acf34e46c9 100644 --- a/src/Schema/User/IM.hs +++ b/src/Web/SCIM/Schema/User/IM.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} -module Schema.User.IM where +module Web.SCIM.Schema.User.IM where import Data.Text (Text) import Data.Aeson import GHC.Generics -import Schema.Common +import Web.SCIM.Schema.Common data IM = IM { typ :: Maybe Text diff --git a/src/Schema/User/Name.hs b/src/Web/SCIM/Schema/User/Name.hs similarity index 87% rename from src/Schema/User/Name.hs rename to src/Web/SCIM/Schema/User/Name.hs index 84df03892a1..e57af2360ae 100644 --- a/src/Schema/User/Name.hs +++ b/src/Web/SCIM/Schema/User/Name.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} -module Schema.User.Name where +module Web.SCIM.Schema.User.Name where import Data.Text (Text) import Data.Aeson import GHC.Generics -import Schema.Common +import Web.SCIM.Schema.Common data Name = Name { formatted :: Maybe Text diff --git a/src/Schema/User/Phone.hs b/src/Web/SCIM/Schema/User/Phone.hs similarity index 84% rename from src/Schema/User/Phone.hs rename to src/Web/SCIM/Schema/User/Phone.hs index 22f2801e85e..fc1373ae74f 100644 --- a/src/Schema/User/Phone.hs +++ b/src/Web/SCIM/Schema/User/Phone.hs @@ -1,11 +1,11 @@ {-# LANGUAGE DeriveGeneric #-} -module Schema.User.Phone where +module Web.SCIM.Schema.User.Phone where import Data.Text hiding (dropWhile) import Data.Aeson import GHC.Generics (Generic) -import Schema.Common +import Web.SCIM.Schema.Common data Phone = Phone { typ :: Maybe Text diff --git a/src/Schema/User/Photo.hs b/src/Web/SCIM/Schema/User/Photo.hs similarity index 83% rename from src/Schema/User/Photo.hs rename to src/Web/SCIM/Schema/User/Photo.hs index a46f62ce4d3..0f62bea9908 100644 --- a/src/Schema/User/Photo.hs +++ b/src/Web/SCIM/Schema/User/Photo.hs @@ -1,12 +1,11 @@ {-# LANGUAGE DeriveGeneric #-} -module Schema.User.Photo where +module Web.SCIM.Schema.User.Photo where import Data.Text (Text) import Data.Aeson import GHC.Generics - -import Schema.Common +import Web.SCIM.Schema.Common data Photo = Photo { typ :: Maybe Text diff --git a/src/SCIM.hs b/src/Web/SCIM/Server.hs similarity index 89% rename from src/SCIM.hs rename to src/Web/SCIM/Server.hs index 2e1bd04070e..345d0ee8ded 100644 --- a/src/SCIM.hs +++ b/src/Web/SCIM/Server.hs @@ -8,25 +8,25 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} -module SCIM +module Web.SCIM.Server ( app , SiteAPI ) where -import API.Group (GroupSite (..), GroupDB, groupServer) -import Config.Schema (ConfigAPI, Configuration, configServer) +import Web.SCIM.Class.Group (GroupSite (..), GroupDB, groupServer) +import Web.SCIM.Capabilities.MetaSchema (ConfigAPI, Configuration, configServer) import Control.Applicative ((<|>), Alternative) import Control.Monad.Except import Control.Error.Util (note) import Data.Text -import DB.User (StoredUser, UserDB) -import qualified DB.User as User +import Web.SCIM.Class.User (StoredUser, UserDB) +import qualified Web.SCIM.Class.User as User import GHC.Generics (Generic) import Network.Wai -import Schema.User hiding (schemas) -import Schema.Meta -import Schema.Error -import Schema.ListResponse +import Web.SCIM.Schema.User hiding (schemas) +import Web.SCIM.Schema.Meta +import Web.SCIM.Schema.Error +import Web.SCIM.Schema.ListResponse import Servant import Servant.Generic diff --git a/test/Util.hs b/test/Mock.hs similarity index 95% rename from test/Util.hs rename to test/Mock.hs index 934f793d6b5..cc0e7f60be1 100644 --- a/test/Util.hs +++ b/test/Mock.hs @@ -8,10 +8,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} -module Util where +module Mock where -import API.Group +import Web.SCIM.Class.Group +import Web.SCIM.Class.User import Control.Monad.STM import Control.Monad.Reader import Data.ByteString (ByteString) @@ -19,16 +20,15 @@ import qualified Data.ByteString.Lazy as L import Data.Text import Data.Time.Clock import Data.Time.Calendar -import DB.User import ListT import Network.HTTP.Types import Network.Wai.Test (SResponse) import qualified STMContainers.Map as Map import STMContainers.Map (Map) -import Schema.User -import Schema.Meta -import Schema.ListResponse -import qualified Schema.Common as Common +import Web.SCIM.Schema.User +import Web.SCIM.Schema.Meta +import Web.SCIM.Schema.ListResponse +import qualified Web.SCIM.Schema.Common as Common import Servant import Test.Hspec.Wai hiding (post, put, patch) diff --git a/test/Spec.hs b/test/Spec.hs index 839470bc1e1..a07ac57d076 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,14 +5,14 @@ module Main (main, startApp) where import Network.Wai.Handler.Warp import Network.Wai.Logger -import Config.Schema (empty) -import qualified Test.API.Groups as Groups -import SCIM +import Web.SCIM.Capabilities.MetaSchema (empty) +import qualified Test.Class.Groups as Groups +import Web.SCIM.Server import qualified STMContainers.Map as Map import Test.Hspec import Test.Hspec.Wai hiding (post, put, patch) import Test.Hspec.Wai.JSON -import Util +import Mock import Data.ByteString.Lazy (ByteString) main :: IO () diff --git a/test/Test/Config/Schema.hs b/test/Test/Capabilities/MetaSchema.hs similarity index 96% rename from test/Test/Config/Schema.hs rename to test/Test/Capabilities/MetaSchema.hs index 2a82328b4ad..8cbddd3b455 100644 --- a/test/Test/Config/Schema.hs +++ b/test/Test/Capabilities/MetaSchema.hs @@ -4,13 +4,13 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE QuasiQuotes #-} -module Test.Config.Schema (spec) where +module Test.Capabilities.MetaSchema (spec) where import Data.Aeson hiding (json) import qualified Data.HashMap.Strict as SMap import Data.Maybe (catMaybes) import qualified Data.Vector as Vector -import Config.Schema +import Web.SCIM.Capabilities.MetaSchema import Network.Wai.Test (SResponse (..)) import Servant import Servant.Generic diff --git a/test/Test/API/Groups.hs b/test/Test/Class/Groups.hs similarity index 97% rename from test/Test/API/Groups.hs rename to test/Test/Class/Groups.hs index aee3b7ec26d..0ac9c149e92 100644 --- a/test/Test/API/Groups.hs +++ b/test/Test/Class/Groups.hs @@ -5,14 +5,14 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE QuasiQuotes #-} -module Test.API.Groups (spec) where +module Test.Class.Groups (spec) where -import API.Group (app) +import Web.SCIM.Class.Group (app) import Data.ByteString.Lazy (ByteString) import Test.Hspec hiding (shouldSatisfy) import Test.Hspec.Wai hiding (post, put, patch) import Test.Hspec.Wai.JSON -import Util +import Mock spec :: TestStorage -> Spec From 9809794afa75656850dd292332d0aafa43f6498a Mon Sep 17 00:00:00 2001 From: Jon Elverkilde Date: Fri, 27 Apr 2018 14:59:09 +0200 Subject: [PATCH 07/64] Add default extensions --- hscim.cabal | 4 +++- package.yaml | 7 +++++++ src/Web/SCIM/Capabilities/MetaSchema.hs | 5 ----- src/Web/SCIM/Capabilities/MetaSchema/Group.hs | 1 - src/Web/SCIM/Capabilities/MetaSchema/ResourceType.hs | 1 - src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs | 1 - src/Web/SCIM/Capabilities/MetaSchema/Schema.hs | 1 - src/Web/SCIM/Capabilities/MetaSchema/User.hs | 1 - src/Web/SCIM/Class/Group.hs | 5 ----- src/Web/SCIM/Class/User.hs | 5 ----- src/Web/SCIM/Schema/Common.hs | 3 --- src/Web/SCIM/Schema/Error.hs | 2 -- src/Web/SCIM/Schema/ListResponse.hs | 3 --- src/Web/SCIM/Schema/Meta.hs | 2 -- src/Web/SCIM/Schema/Schema.hs | 1 - src/Web/SCIM/Schema/User.hs | 2 -- src/Web/SCIM/Schema/User/Address.hs | 3 --- src/Web/SCIM/Schema/User/Certificate.hs | 1 - src/Web/SCIM/Schema/User/Email.hs | 2 -- src/Web/SCIM/Schema/User/IM.hs | 1 - src/Web/SCIM/Schema/User/Name.hs | 1 - src/Web/SCIM/Schema/User/Phone.hs | 1 - src/Web/SCIM/Schema/User/Photo.hs | 1 - src/Web/SCIM/Server.hs | 5 ----- test/Mock.hs | 5 ----- test/Spec.hs | 1 - test/Test/Capabilities/MetaSchema.hs | 2 -- test/Test/Class/Groups.hs | 2 -- 28 files changed, 10 insertions(+), 59 deletions(-) diff --git a/hscim.cabal b/hscim.cabal index e30e5ce366d..e31ce3101fc 100644 --- a/hscim.cabal +++ b/hscim.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 13dbc78d452e4b6133bef53cdb89f7cf92493b3eed2cbbb28b4f7eb65483589f +-- hash: 05bfff85af42288cbbae179b4d77778bc567ca54569773655266efafa477035b name: hscim version: 0.1.0.0 @@ -29,6 +29,7 @@ source-repository head library hs-source-dirs: src + default-extensions: OverloadedStrings FlexibleContexts FlexibleInstances TypeSynonymInstances DeriveGeneric ghc-options: -Wall exposed-modules: Web.SCIM.Capabilities.MetaSchema @@ -76,6 +77,7 @@ test-suite spec hs-source-dirs: test src + default-extensions: OverloadedStrings FlexibleContexts FlexibleInstances TypeSynonymInstances DeriveGeneric ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: aeson diff --git a/package.yaml b/package.yaml index 60921268165..5ca333817e6 100644 --- a/package.yaml +++ b/package.yaml @@ -12,6 +12,13 @@ category: Web build-type: Simple github: wireapp/hscim +default-extensions: + - OverloadedStrings + - FlexibleContexts + - FlexibleInstances + - TypeSynonymInstances + - DeriveGeneric + extra-source-files: - README.md diff --git a/src/Web/SCIM/Capabilities/MetaSchema.hs b/src/Web/SCIM/Capabilities/MetaSchema.hs index 537313b22d7..8079f516e6f 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema.hs @@ -1,10 +1,5 @@ {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} diff --git a/src/Web/SCIM/Capabilities/MetaSchema/Group.hs b/src/Web/SCIM/Capabilities/MetaSchema/Group.hs index 26f0501240a..8b879995828 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema/Group.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema/Group.hs @@ -1,5 +1,4 @@ {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} module Web.SCIM.Capabilities.MetaSchema.Group (groupSchema) where diff --git a/src/Web/SCIM/Capabilities/MetaSchema/ResourceType.hs b/src/Web/SCIM/Capabilities/MetaSchema/ResourceType.hs index 8a3d79d2e5a..3a1b0b5bbde 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema/ResourceType.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema/ResourceType.hs @@ -1,5 +1,4 @@ {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} module Web.SCIM.Capabilities.MetaSchema.ResourceType (resourceSchema) where diff --git a/src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs b/src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs index 0ed8d5be589..2569d8822e1 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs @@ -1,5 +1,4 @@ {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} module Web.SCIM.Capabilities.MetaSchema.SPConfig (spConfigSchema) where diff --git a/src/Web/SCIM/Capabilities/MetaSchema/Schema.hs b/src/Web/SCIM/Capabilities/MetaSchema/Schema.hs index 2f1af55940f..ab04ae38b2a 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema/Schema.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema/Schema.hs @@ -1,5 +1,4 @@ {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} module Web.SCIM.Capabilities.MetaSchema.Schema (metaSchema) where diff --git a/src/Web/SCIM/Capabilities/MetaSchema/User.hs b/src/Web/SCIM/Capabilities/MetaSchema/User.hs index d0a588ab035..6ad9bc7eaa5 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema/User.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema/User.hs @@ -1,5 +1,4 @@ {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} module Web.SCIM.Capabilities.MetaSchema.User (userSchema) where diff --git a/src/Web/SCIM/Class/Group.hs b/src/Web/SCIM/Class/Group.hs index 9e478c22068..1e696aba246 100644 --- a/src/Web/SCIM/Class/Group.hs +++ b/src/Web/SCIM/Class/Group.hs @@ -1,10 +1,5 @@ {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} diff --git a/src/Web/SCIM/Class/User.hs b/src/Web/SCIM/Class/User.hs index b9d99d817c8..479f1fe80a2 100644 --- a/src/Web/SCIM/Class/User.hs +++ b/src/Web/SCIM/Class/User.hs @@ -1,10 +1,5 @@ {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} diff --git a/src/Web/SCIM/Schema/Common.hs b/src/Web/SCIM/Schema/Common.hs index 4b754dc711f..1c6782bc993 100644 --- a/src/Web/SCIM/Schema/Common.hs +++ b/src/Web/SCIM/Schema/Common.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedStrings #-} module Web.SCIM.Schema.Common where diff --git a/src/Web/SCIM/Schema/Error.hs b/src/Web/SCIM/Schema/Error.hs index c0fb21adeb8..9384b410560 100644 --- a/src/Web/SCIM/Schema/Error.hs +++ b/src/Web/SCIM/Schema/Error.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} module Web.SCIM.Schema.Error (notFound, fromErrorType) where diff --git a/src/Web/SCIM/Schema/ListResponse.hs b/src/Web/SCIM/Schema/ListResponse.hs index cae87ecef8a..f33e1adbbf2 100644 --- a/src/Web/SCIM/Schema/ListResponse.hs +++ b/src/Web/SCIM/Schema/ListResponse.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedStrings #-} module Web.SCIM.Schema.ListResponse (ListResponse, fromList) where diff --git a/src/Web/SCIM/Schema/Meta.hs b/src/Web/SCIM/Schema/Meta.hs index 630b808b1a0..74592f201bc 100644 --- a/src/Web/SCIM/Schema/Meta.hs +++ b/src/Web/SCIM/Schema/Meta.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} module Web.SCIM.Schema.Meta where diff --git a/src/Web/SCIM/Schema/Schema.hs b/src/Web/SCIM/Schema/Schema.hs index 387f6120c61..7dbc98be127 100644 --- a/src/Web/SCIM/Schema/Schema.hs +++ b/src/Web/SCIM/Schema/Schema.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module Web.SCIM.Schema.Schema where diff --git a/src/Web/SCIM/Schema/User.hs b/src/Web/SCIM/Schema/User.hs index 806a0e411c9..a4f22a2e698 100644 --- a/src/Web/SCIM/Schema/User.hs +++ b/src/Web/SCIM/Schema/User.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} module Web.SCIM.Schema.User where diff --git a/src/Web/SCIM/Schema/User/Address.hs b/src/Web/SCIM/Schema/User/Address.hs index a471d98cc70..002fc6bcca5 100644 --- a/src/Web/SCIM/Schema/User/Address.hs +++ b/src/Web/SCIM/Schema/User/Address.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedStrings #-} module Web.SCIM.Schema.User.Address where diff --git a/src/Web/SCIM/Schema/User/Certificate.hs b/src/Web/SCIM/Schema/User/Certificate.hs index cec2e269bb3..f76bb4edbbf 100644 --- a/src/Web/SCIM/Schema/User/Certificate.hs +++ b/src/Web/SCIM/Schema/User/Certificate.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} module Web.SCIM.Schema.User.Certificate where diff --git a/src/Web/SCIM/Schema/User/Email.hs b/src/Web/SCIM/Schema/User/Email.hs index 03d5661a1ca..d51e27a1d1a 100644 --- a/src/Web/SCIM/Schema/User/Email.hs +++ b/src/Web/SCIM/Schema/User/Email.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} module Web.SCIM.Schema.User.Email where diff --git a/src/Web/SCIM/Schema/User/IM.hs b/src/Web/SCIM/Schema/User/IM.hs index 4acf34e46c9..b83250dbe99 100644 --- a/src/Web/SCIM/Schema/User/IM.hs +++ b/src/Web/SCIM/Schema/User/IM.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} module Web.SCIM.Schema.User.IM where diff --git a/src/Web/SCIM/Schema/User/Name.hs b/src/Web/SCIM/Schema/User/Name.hs index e57af2360ae..2a5ce72805f 100644 --- a/src/Web/SCIM/Schema/User/Name.hs +++ b/src/Web/SCIM/Schema/User/Name.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} module Web.SCIM.Schema.User.Name where diff --git a/src/Web/SCIM/Schema/User/Phone.hs b/src/Web/SCIM/Schema/User/Phone.hs index fc1373ae74f..1c4375f634e 100644 --- a/src/Web/SCIM/Schema/User/Phone.hs +++ b/src/Web/SCIM/Schema/User/Phone.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} module Web.SCIM.Schema.User.Phone where diff --git a/src/Web/SCIM/Schema/User/Photo.hs b/src/Web/SCIM/Schema/User/Photo.hs index 0f62bea9908..c6e501f0744 100644 --- a/src/Web/SCIM/Schema/User/Photo.hs +++ b/src/Web/SCIM/Schema/User/Photo.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} module Web.SCIM.Schema.User.Photo where diff --git a/src/Web/SCIM/Server.hs b/src/Web/SCIM/Server.hs index 345d0ee8ded..65f5d1c1206 100644 --- a/src/Web/SCIM/Server.hs +++ b/src/Web/SCIM/Server.hs @@ -1,10 +1,5 @@ {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} diff --git a/test/Mock.hs b/test/Mock.hs index cc0e7f60be1..71fb1064d8c 100644 --- a/test/Mock.hs +++ b/test/Mock.hs @@ -1,11 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Mock where diff --git a/test/Spec.hs b/test/Spec.hs index a07ac57d076..b4dfbf22ebc 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,5 +1,4 @@ {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} module Main (main, startApp) where diff --git a/test/Test/Capabilities/MetaSchema.hs b/test/Test/Capabilities/MetaSchema.hs index 8cbddd3b455..280e2a45b52 100644 --- a/test/Test/Capabilities/MetaSchema.hs +++ b/test/Test/Capabilities/MetaSchema.hs @@ -1,6 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE QuasiQuotes #-} diff --git a/test/Test/Class/Groups.hs b/test/Test/Class/Groups.hs index 0ac9c149e92..1670ad998fe 100644 --- a/test/Test/Class/Groups.hs +++ b/test/Test/Class/Groups.hs @@ -1,7 +1,5 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE QuasiQuotes #-} From 900405e620c6d2c0c3e5ed08e546f955ee3d7b14 Mon Sep 17 00:00:00 2001 From: jschaul Date: Tue, 21 Aug 2018 18:05:55 +0200 Subject: [PATCH 08/64] add aeson-qq --- package.yaml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 5ca333817e6..db2900cbde6 100644 --- a/package.yaml +++ b/package.yaml @@ -25,6 +25,7 @@ extra-source-files: dependencies: - base >= 4.7 && < 5 - aeson + - aeson-qq - mtl - servant-server - servant-generic @@ -71,4 +72,4 @@ tests: - vector - hspec-expectations - warp - - wai-logger \ No newline at end of file + - wai-logger From 224827c8ad418d14abbcd781948a8b7584e109e8 Mon Sep 17 00:00:00 2001 From: jschaul Date: Tue, 21 Aug 2018 18:12:28 +0200 Subject: [PATCH 09/64] gitignore cabal file --- .gitignore | 1 + hscim.cabal | 137 ---------------------------------------------------- 2 files changed, 1 insertion(+), 137 deletions(-) delete mode 100644 hscim.cabal diff --git a/.gitignore b/.gitignore index 5812f1890fa..31e945c3a97 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ dist dist-* cabal-dev +*.cabal *.o *.hi *.chi diff --git a/hscim.cabal b/hscim.cabal deleted file mode 100644 index e31ce3101fc..00000000000 --- a/hscim.cabal +++ /dev/null @@ -1,137 +0,0 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. --- --- see: https://github.com/sol/hpack --- --- hash: 05bfff85af42288cbbae179b4d77778bc567ca54569773655266efafa477035b - -name: hscim -version: 0.1.0.0 -synopsis: ... -description: ... -homepage: https://github.com/wireapp/hscim/README.md -bug-reports: https://github.com/wireapp/hscim/issues -license: AGPL-3 -license-file: LICENSE -author: Wire Swiss GmbH -maintainer: Wire Swiss GmbH -copyright: (c) 2018 Wire Swiss GmbH -category: Web -build-type: Simple -cabal-version: >= 1.10 - -extra-source-files: - README.md - -source-repository head - type: git - location: https://github.com/wireapp/hscim - -library - hs-source-dirs: - src - default-extensions: OverloadedStrings FlexibleContexts FlexibleInstances TypeSynonymInstances DeriveGeneric - ghc-options: -Wall - exposed-modules: - Web.SCIM.Capabilities.MetaSchema - Web.SCIM.Capabilities.MetaSchema.Group - Web.SCIM.Capabilities.MetaSchema.ResourceType - Web.SCIM.Capabilities.MetaSchema.Schema - Web.SCIM.Capabilities.MetaSchema.SPConfig - Web.SCIM.Capabilities.MetaSchema.User - Web.SCIM.Class.Group - Web.SCIM.Class.User - Web.SCIM.Schema.Common - Web.SCIM.Schema.Error - Web.SCIM.Schema.ListResponse - Web.SCIM.Schema.Meta - Web.SCIM.Schema.Schema - Web.SCIM.Schema.User - Web.SCIM.Schema.User.Address - Web.SCIM.Schema.User.Certificate - Web.SCIM.Schema.User.Email - Web.SCIM.Schema.User.IM - Web.SCIM.Schema.User.Name - Web.SCIM.Schema.User.Phone - Web.SCIM.Schema.User.Photo - Web.SCIM.Server - other-modules: - Paths_hscim - build-depends: - aeson - , base >=4.7 && <5 - , email-validate - , errors - , mtl - , network-uri - , servant-generic - , servant-server - , text - , time - , unordered-containers - , wai - default-language: Haskell2010 - -test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: - test - src - default-extensions: OverloadedStrings FlexibleContexts FlexibleInstances TypeSynonymInstances DeriveGeneric - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - build-depends: - aeson - , aeson-qq - , base - , bytestring - , email-validate - , errors - , hscim - , hspec - , hspec-expectations - , hspec-wai - , hspec-wai-json - , http-types - , list-t - , mtl - , network-uri - , servant-generic - , servant-server - , stm - , stm-containers - , text - , time - , unordered-containers - , vector - , wai - , wai-extra - , wai-logger - , warp - other-modules: - Mock - Test.Capabilities.MetaSchema - Test.Class.Groups - Web.SCIM.Capabilities.MetaSchema - Web.SCIM.Capabilities.MetaSchema.Group - Web.SCIM.Capabilities.MetaSchema.ResourceType - Web.SCIM.Capabilities.MetaSchema.Schema - Web.SCIM.Capabilities.MetaSchema.SPConfig - Web.SCIM.Capabilities.MetaSchema.User - Web.SCIM.Class.Group - Web.SCIM.Class.User - Web.SCIM.Schema.Common - Web.SCIM.Schema.Error - Web.SCIM.Schema.ListResponse - Web.SCIM.Schema.Meta - Web.SCIM.Schema.Schema - Web.SCIM.Schema.User - Web.SCIM.Schema.User.Address - Web.SCIM.Schema.User.Certificate - Web.SCIM.Schema.User.Email - Web.SCIM.Schema.User.IM - Web.SCIM.Schema.User.Name - Web.SCIM.Schema.User.Phone - Web.SCIM.Schema.User.Photo - Web.SCIM.Server - Paths_hscim - default-language: Haskell2010 From 6cfd669f83e9db596db72a4e823e5b5251d085cb Mon Sep 17 00:00:00 2001 From: fisx Date: Fri, 24 Aug 2018 11:45:13 +0200 Subject: [PATCH 10/64] Tweaks (#7) * Remove redundant cabal file from version control. * Set stack resolver to match https://github.com/wireapp/wire-server/. * Eliminate servant dependency exception. (this will be helpful if we link this against the same executable as saml2-web-sso and don't want to run two servants at the same time.) * Cleanup * Enable travis ci. * Add missing test cases to Spec.hs. * Use hspec-discover --- .gitignore | 3 +- .travis.yml | 31 +++ package.yaml | 2 + src/Web/SCIM/Capabilities/MetaSchema.hs | 7 +- src/Web/SCIM/Capabilities/MetaSchema/User.hs | 2 +- src/Web/SCIM/Class/Group.hs | 24 +-- src/Web/SCIM/Class/User.hs | 102 +++++++++- src/Web/SCIM/Schema/Common.hs | 13 +- src/Web/SCIM/Schema/Meta.hs | 14 -- src/Web/SCIM/Schema/Schema.hs | 2 +- src/Web/SCIM/Schema/User.hs | 2 - src/Web/SCIM/Server.hs | 128 +++--------- stack.yaml | 70 +------ test/Mock.hs | 7 +- test/Spec.hs | 191 +----------------- .../{MetaSchema.hs => MetaSchemaSpec.hs} | 2 +- test/Test/Class/{Groups.hs => GroupSpec.hs} | 19 +- test/Test/Class/UserSpec.hs | 174 ++++++++++++++++ 18 files changed, 381 insertions(+), 412 deletions(-) create mode 100644 .travis.yml rename test/Test/Capabilities/{MetaSchema.hs => MetaSchemaSpec.hs} (98%) rename test/Test/Class/{Groups.hs => GroupSpec.hs} (86%) create mode 100644 test/Test/Class/UserSpec.hs diff --git a/.gitignore b/.gitignore index 31e945c3a97..c04fa9f5d2b 100644 --- a/.gitignore +++ b/.gitignore @@ -24,4 +24,5 @@ cabal.project.local~ *~ *.el -\#* \ No newline at end of file +\#* +hscim.cabal diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000000..989488d2be9 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,31 @@ +# this is a clone of https://docs.haskellstack.org/en/stable/travis_ci/ +# alternative: https://github.com/harendra-kumar/packcheck + +sudo: false +language: generic +cache: + directories: + - $HOME/.stack + +addons: + apt: + packages: + - libgmp-dev + +env: +- RESOLVER=lts-10.3 +- RESOLVER=lts-11.13 + +before_install: +- mkdir -p ~/.local/bin +- export PATH=$HOME/.local/bin:$PATH +- travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' + +install: +- stack --resolver=$RESOLVER --no-terminal --install-ghc test --fast --only-dependencies + +script: +- stack --resolver=$RESOLVER --no-terminal test --fast --haddock --no-haddock-deps + +notifications: # see https://docs.travis-ci.com/user/notifications + email: false diff --git a/package.yaml b/package.yaml index db2900cbde6..d3aba350c34 100644 --- a/package.yaml +++ b/package.yaml @@ -27,6 +27,7 @@ dependencies: - aeson - aeson-qq - mtl + - servant - servant-server - servant-generic - text @@ -71,5 +72,6 @@ tests: - servant-server - vector - hspec-expectations + - hspec-discover - warp - wai-logger diff --git a/src/Web/SCIM/Capabilities/MetaSchema.hs b/src/Web/SCIM/Capabilities/MetaSchema.hs index 8079f516e6f..8fd3aa31f0a 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema.hs @@ -88,7 +88,7 @@ empty = Configuration , sort = Supported False () , etag = Supported False () , authenticationSchemes = [] - } + } configServer :: MonadError ServantErr m => Configuration -> ConfigAPI (AsServerT m) @@ -100,7 +100,7 @@ configServer config = ConfigAPI , metaSchema , resourceSchema ] - , schema = liftEither . note err404 . getSchema + , schema = either throwError pure . note err404 . getSchema , resourceTypes = pure "" } @@ -115,7 +115,7 @@ getSchema "urn:ietf:params:scim:schemas:core:2.0:Schema" = pure metaSchema getSchema "urn:ietf:params:scim:schemas:core:2.0:ResourceType" = pure resourceSchema -getSchema _ = Nothing +getSchema _ = Nothing data ConfigAPI route = ConfigAPI { spConfig :: route :- "ServiceProviderConfig" :> Get '[JSON] Configuration @@ -123,4 +123,3 @@ data ConfigAPI route = ConfigAPI , schema :: route :- "Schemas" :> Capture "id" Text :> Get '[JSON] Value , resourceTypes :: route :- "ResourceTypes" :> Get '[JSON] Text } deriving (Generic) - diff --git a/src/Web/SCIM/Capabilities/MetaSchema/User.hs b/src/Web/SCIM/Capabilities/MetaSchema/User.hs index 6ad9bc7eaa5..71efccd7a86 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema/User.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema/User.hs @@ -702,7 +702,7 @@ userSchema = [aesonQQ| "required": false, "caseExact": false, "canonicalValues": [ - + ], "mutability": "readWrite", "returned": "default", diff --git a/src/Web/SCIM/Class/Group.hs b/src/Web/SCIM/Class/Group.hs index 1e696aba246..a5073c13965 100644 --- a/src/Web/SCIM/Class/Group.hs +++ b/src/Web/SCIM/Class/Group.hs @@ -11,7 +11,7 @@ module Web.SCIM.Class.Group ( , GroupId , Member (..) , groupServer - , app + , GroupAPI ) where import Control.Monad.Except @@ -19,7 +19,6 @@ import Control.Error.Util (note) import Data.Text import Data.Aeson import GHC.Generics (Generic) -import Network.Wai import Web.SCIM.Schema.Common import Web.SCIM.Schema.Error import Web.SCIM.Schema.Meta @@ -27,7 +26,7 @@ import Servant import Servant.Generic -type SCIMHandler m = (MonadError ServantErr m, GroupDB m) +type GroupHandler m = (MonadError ServantErr m, GroupDB m) type GroupAPI = ToServant (GroupSite AsApi) type GroupId = Text @@ -84,14 +83,7 @@ data GroupSite route = GroupSite Capture "id" Text :> DeleteNoContent '[JSON] NoContent } deriving (Generic) -api :: Proxy GroupAPI -api = Proxy - -app :: SCIMHandler m => - (forall a. m a -> Handler a) -> Application -app t = serve api $ hoistServer api t (toServant $ groupServer) - -groupServer :: SCIMHandler m => GroupSite (AsServerT m) +groupServer :: GroupHandler m => GroupSite (AsServerT m) groupServer = GroupSite { getGroups = list , getGroup = getGroup' @@ -101,17 +93,17 @@ groupServer = GroupSite , deleteGroup = deleteGroup' } -getGroup' :: SCIMHandler m => GroupId -> m StoredGroup +getGroup' :: GroupHandler m => GroupId -> m StoredGroup getGroup' gid = do maybeGroup <- get gid - liftEither $ note (notFound gid) maybeGroup + either throwError pure $ note (notFound gid) maybeGroup -putGroup' :: SCIMHandler m => GroupId -> Group -> m StoredGroup +putGroup' :: GroupHandler m => GroupId -> Group -> m StoredGroup putGroup' gid grp = do updated <- update gid grp - liftEither updated + either throwError pure updated -deleteGroup' :: SCIMHandler m => GroupId -> m NoContent +deleteGroup' :: GroupHandler m => GroupId -> m NoContent deleteGroup' gid = do deleted <- delete gid if deleted then return NoContent else throwError err404 diff --git a/src/Web/SCIM/Class/User.hs b/src/Web/SCIM/Class/User.hs index 479f1fe80a2..d11d2115f54 100644 --- a/src/Web/SCIM/Class/User.hs +++ b/src/Web/SCIM/Class/User.hs @@ -7,11 +7,25 @@ module Web.SCIM.Class.User ( UserDB (..) , StoredUser , UpdateError (..) + , UserSite (..) + , userServer ) where -import Web.SCIM.Schema.User -import Web.SCIM.Schema.Meta -import Web.SCIM.Schema.ListResponse +import Control.Applicative ((<|>), Alternative) +import Control.Monad.Except +import Control.Error.Util (note) +import Data.Text +import GHC.Generics (Generic) +import Web.SCIM.Schema.User hiding (schemas) +import Web.SCIM.Schema.Meta +import Web.SCIM.Schema.Common +import Web.SCIM.Schema.Error +import Web.SCIM.Schema.ListResponse +import Servant +import Servant.Generic + + +type UserHandler m = (MonadError ServantErr m, UserDB m) type StoredUser = WithMeta (WithId User) @@ -28,3 +42,85 @@ class UserDB m where patch :: UserId -> m StoredUser delete :: UserId -> m Bool getMeta :: m Meta + + +data UserSite route = UserSite + { getUsers :: route :- + Get '[JSON] (ListResponse StoredUser) + , getUser :: route :- + Capture "id" Text :> Get '[JSON] StoredUser + , postUser :: route :- + ReqBody '[JSON] User :> PostCreated '[JSON] StoredUser + , putUser :: route :- + Capture "id" Text :> ReqBody '[JSON] User :> Put '[JSON] StoredUser + , patchUser :: route :- + Capture "id" Text :> Patch '[JSON] StoredUser + , deleteUser :: route :- + Capture "id" Text :> DeleteNoContent '[JSON] NoContent + } deriving (Generic) + +userServer :: UserHandler m => UserSite (AsServerT m) +userServer = UserSite + { getUsers = list + , getUser = getUser' + , postUser = create + , putUser = updateUser' + , patchUser = patch + , deleteUser = deleteUser' + } + + +updateUser' :: UserHandler m => UserId -> User -> m StoredUser +updateUser' uid updatedUser = do + -- TODO: don't fetch here, let User.update do it + stored <- get uid + case stored of + Just (WithMeta _meta (WithId _ existing)) -> + let newUser = existing `overwriteWith` updatedUser + in do + t <- update uid newUser + case t of + Left _err -> throwError err400 + Right newStored -> pure newStored + Nothing -> throwError err400 + +getUser' :: UserHandler m => UserId -> m StoredUser +getUser' uid = do + maybeUser <- get uid + either throwError pure $ note (notFound uid) maybeUser + +deleteUser' :: UserHandler m => UserId -> m NoContent +deleteUser' uid = do + deleted <- delete uid + if deleted then return NoContent else throwError err404 + +overwriteWith :: User -> User -> User +overwriteWith old new = old + { --externalId :: Unsettable Text + name = merge name + , displayName = merge displayName + , nickName = merge nickName + , profileUrl = merge profileUrl + , title = merge title + , userType = merge userType + , preferredLanguage = merge preferredLanguage + , locale = merge locale + , active = merge active + , password = merge password + , emails = mergeList emails + , phoneNumbers = mergeList phoneNumbers + , ims = mergeList ims + , photos = mergeList photos + , addresses = mergeList addresses + , entitlements = mergeList entitlements + , roles = mergeList roles + , x509Certificates = mergeList x509Certificates + } + where + merge :: (Alternative f) => (User -> f a) -> f a + merge accessor = (accessor new) <|> (accessor old) + + mergeList :: (User -> Maybe [a]) -> Maybe [a] + mergeList accessor = case accessor new of + Just [] -> accessor old + _ -> (accessor new) <|> (accessor old) diff --git a/src/Web/SCIM/Schema/Common.hs b/src/Web/SCIM/Schema/Common.hs index 1c6782bc993..59ef1417441 100644 --- a/src/Web/SCIM/Schema/Common.hs +++ b/src/Web/SCIM/Schema/Common.hs @@ -7,8 +7,19 @@ import qualified Data.Char as Char import qualified Data.HashMap.Strict as HM import Data.String (IsString) import qualified Network.URI as Network +import qualified Data.HashMap.Lazy as HML +data WithId a = WithId + { id :: Text + , value :: a + } deriving (Eq, Show) + +instance (ToJSON a) => ToJSON (WithId a) where + toJSON (WithId i v) = case toJSON v of + (Object o) -> Object (HML.insert "id" (String i) o) + other -> other + newtype URI = URI { unURI :: Network.URI } deriving (Show, Eq) @@ -54,7 +65,7 @@ data Unsettable a = Unset | Omitted | Some a instance Functor Unsettable where fmap f (Some a) = Some $ f a fmap _ Unset = Unset - fmap _ Omitted = Omitted + fmap _ Omitted = Omitted instance (FromJSON a) => FromJSON (Unsettable a) where parseJSON Null = pure Unset diff --git a/src/Web/SCIM/Schema/Meta.hs b/src/Web/SCIM/Schema/Meta.hs index 74592f201bc..794e72c8c07 100644 --- a/src/Web/SCIM/Schema/Meta.hs +++ b/src/Web/SCIM/Schema/Meta.hs @@ -5,25 +5,11 @@ import Prelude hiding (map) import Data.Text (Text) import Data.Aeson - import Web.SCIM.Schema.Common import GHC.Generics (Generic) - --- TODO: move to Meta.hs import qualified Data.HashMap.Lazy as HML import Data.Time.Clock --- TODO: Move to Common/Meta -data WithId a = WithId - { id :: Text - , value :: a - } deriving (Eq, Show) - -instance (ToJSON a) => ToJSON (WithId a) where - toJSON (WithId i v) = case toJSON v of - (Object o) -> Object (HML.insert "id" (String i) o) - other -> other - data ResourceType = UserResource | GroupResource deriving (Eq, Show) diff --git a/src/Web/SCIM/Schema/Schema.hs b/src/Web/SCIM/Schema/Schema.hs index 7dbc98be127..6aba1d08ffd 100644 --- a/src/Web/SCIM/Schema/Schema.hs +++ b/src/Web/SCIM/Schema/Schema.hs @@ -14,7 +14,7 @@ instance FromJSON Schema where "urn:ietf:params:scim:api:messages:2.0:ListResponse" -> pure ListResponse2_0 _ -> - fail "unsupported schema" + fail "unsupported schema" instance ToJSON Schema where toJSON User20 = diff --git a/src/Web/SCIM/Schema/User.hs b/src/Web/SCIM/Schema/User.hs index a4f22a2e698..51bb97db415 100644 --- a/src/Web/SCIM/Schema/User.hs +++ b/src/Web/SCIM/Schema/User.hs @@ -49,6 +49,4 @@ instance FromJSON User where instance ToJSON User where toJSON = genericToJSON serializeOptions --- TODO: type parameter? type UserId = Text - diff --git a/src/Web/SCIM/Server.hs b/src/Web/SCIM/Server.hs index 65f5d1c1206..cf574ec5c67 100644 --- a/src/Web/SCIM/Server.hs +++ b/src/Web/SCIM/Server.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} @@ -6,24 +7,20 @@ module Web.SCIM.Server ( app , SiteAPI + , mkapp, App ) where +import Web.SCIM.Class.User (UserSite (..), UserDB, userServer) import Web.SCIM.Class.Group (GroupSite (..), GroupDB, groupServer) import Web.SCIM.Capabilities.MetaSchema (ConfigAPI, Configuration, configServer) -import Control.Applicative ((<|>), Alternative) import Control.Monad.Except -import Control.Error.Util (note) -import Data.Text -import Web.SCIM.Class.User (StoredUser, UserDB) -import qualified Web.SCIM.Class.User as User import GHC.Generics (Generic) import Network.Wai -import Web.SCIM.Schema.User hiding (schemas) -import Web.SCIM.Schema.Meta -import Web.SCIM.Schema.Error -import Web.SCIM.Schema.ListResponse import Servant import Servant.Generic +#if !MIN_VERSION_servant_server(0,12,0) +import Servant.Utils.Enter +#endif type SCIMHandler m = (MonadError ServantErr m, UserDB m, GroupDB m) @@ -35,98 +32,29 @@ data Site route = Site , groups :: route :- "Groups" :> ToServant (GroupSite AsApi) } deriving (Generic) -data UserSite route = UserSite - { getUsers :: route :- - Get '[JSON] (ListResponse StoredUser) - , getUser :: route :- - Capture "id" Text :> Get '[JSON] StoredUser - , postUser :: route :- - ReqBody '[JSON] User :> PostCreated '[JSON] StoredUser - , putUser :: route :- - Capture "id" Text :> ReqBody '[JSON] User :> Put '[JSON] StoredUser - , patchUser :: route :- - Capture "id" Text :> Patch '[JSON] StoredUser - , deleteUser :: route :- - Capture "id" Text :> DeleteNoContent '[JSON] NoContent - } deriving (Generic) - - -siteServer :: SCIMHandler m => UserSite (AsServerT m) -siteServer = UserSite - { getUsers = User.list - , getUser = getUser' - , postUser = User.create - , putUser = updateUser' - , patchUser = User.patch - , deleteUser = deleteUser' - } - -superServer :: Configuration -> SCIMHandler m => Site (AsServerT m) -superServer conf = Site +siteServer :: Configuration -> SCIMHandler m => Site (AsServerT m) +siteServer conf = Site { config = toServant $ configServer conf - , users = toServant siteServer + , users = toServant userServer , groups = toServant groupServer } -updateUser' :: SCIMHandler m => UserId -> User -> m StoredUser -updateUser' uid update = do - -- TODO: don't fetch here, let User.update do it - stored <- User.get uid - case stored of - Just (WithMeta _meta (WithId _ existing)) -> - let newUser = existing `overwriteWith` update - in do - t <- User.update uid newUser - case t of - Left _err -> throwError err400 - Right newStored -> pure newStored - Nothing -> throwError err400 - -getUser' :: SCIMHandler m => UserId -> m StoredUser -getUser' uid = do - maybeUser <- User.get uid - liftEither $ note (notFound uid) maybeUser - -deleteUser' :: SCIMHandler m => UserId -> m NoContent -deleteUser' uid = do - deleted <- User.delete uid - if deleted then return NoContent else throwError err404 - -api :: Proxy SiteAPI -api = Proxy - -app :: SCIMHandler m => Configuration -> (forall a. m a -> Handler a) -> Application -app c t = serve (Proxy :: Proxy SiteAPI) $ hoistServer api t (toServant $ superServer c) - - --- TODO: move to User.hs -overwriteWith :: User -> User -> User -overwriteWith old new = old - { --externalId :: Unsettable Text - name = merge name - , displayName = merge displayName - , nickName = merge nickName - , profileUrl = merge profileUrl - , title = merge title - , userType = merge userType - , preferredLanguage = merge preferredLanguage - , locale = merge locale - , active = merge active - , password = merge password - , emails = mergeList emails - , phoneNumbers = mergeList phoneNumbers - , ims = mergeList ims - , photos = mergeList photos - , addresses = mergeList addresses - , entitlements = mergeList entitlements - , roles = mergeList roles - , x509Certificates = mergeList x509Certificates - } - where - merge :: (Alternative f) => (User -> f a) -> f a - merge accessor = (accessor new) <|> (accessor old) - - mergeList :: (User -> Maybe [a]) -> Maybe [a] - mergeList accessor = case accessor new of - Just [] -> accessor old - _ -> (accessor new) <|> (accessor old) +type App m api = ( SCIMHandler m + , HasServer api '[] +#if !MIN_VERSION_servant_server(0,12,0) + , Enter (ServerT api m) m Handler (Server api) +#endif + ) + +mkapp :: forall m api. (App m api) + => Proxy api -> ServerT api m -> (forall a. m a -> Handler a) -> Application +mkapp proxy api nt = serve proxy $ +#if MIN_VERSION_servant_server(0,12,0) + hoistServer proxy nt +#else + enter (NT nt) +#endif + api + +app :: forall m. App m SiteAPI => Configuration -> (forall a. m a -> Handler a) -> Application +app c = mkapp (Proxy :: Proxy SiteAPI) (toServant $ siteServer c) diff --git a/stack.yaml b/stack.yaml index 4bb069a1b34..4d182aa88e6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,74 +1,6 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ +resolver: lts-10.3 -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-10.8 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. packages: - . -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) - -# TODO: since we are using hoisting, we need servant 0.12+ -extra-deps: - - http-types-0.12.1 - - servant-0.13 - - servant-server-0.13 - - text-1.2.3.0 allow-newer: true - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.6" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/test/Mock.hs b/test/Mock.hs index 71fb1064d8c..497d2f97398 100644 --- a/test/Mock.hs +++ b/test/Mock.hs @@ -23,6 +23,7 @@ import STMContainers.Map (Map) import Web.SCIM.Schema.User import Web.SCIM.Schema.Meta import Web.SCIM.Schema.ListResponse +import Web.SCIM.Schema.Common (WithId(WithId)) import qualified Web.SCIM.Schema.Common as Common import Servant import Test.Hspec.Wai hiding (post, put, patch) @@ -72,7 +73,7 @@ instance GroupDB TestServer where return $ snd <$> l get i = do m <- groupDB <$> ask - liftIO . atomically $ Map.lookup i m + liftIO . atomically $ Map.lookup i m create = \grp -> do storage <- groupDB <$> ask met <- getGroupMeta @@ -83,7 +84,7 @@ instance GroupDB TestServer where liftAtomic $ updateGroup i g m delete gid = do m <- groupDB <$> ask - liftIO . atomically $ delGroup gid m + liftIO . atomically $ delGroup gid m getGroupMeta = createMeta GroupResource insertGroup :: Group -> Meta -> GroupStorage -> STM StoredGroup @@ -116,7 +117,6 @@ updateUser uid user storage = do Map.insert newUser uid storage pure $ Right newUser --- TODO: what needs checking here? -- (there seems to be no readOnly fields in User) assertMutability :: User -> StoredUser -> Bool assertMutability _newUser _stored = True @@ -176,4 +176,3 @@ put path = request methodPut path [(hContentType, "application/json")] patch :: ByteString -> L.ByteString -> WaiSession SResponse patch path = request methodPatch path [(hContentType, "application/json")] - diff --git a/test/Spec.hs b/test/Spec.hs index b4dfbf22ebc..a824f8c30c8 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,190 +1 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Main (main, startApp) where - -import Network.Wai.Handler.Warp -import Network.Wai.Logger -import Web.SCIM.Capabilities.MetaSchema (empty) -import qualified Test.Class.Groups as Groups -import Web.SCIM.Server -import qualified STMContainers.Map as Map -import Test.Hspec -import Test.Hspec.Wai hiding (post, put, patch) -import Test.Hspec.Wai.JSON -import Mock -import Data.ByteString.Lazy (ByteString) - -main :: IO () -main = do - emptyState <- TestStorage <$> Map.newIO <*> Map.newIO - hspec $ describe "/Users" (spec emptyState) - hspec $ describe "/Groups" (Groups.spec emptyState) --- hspec $ describe "Configuration" (Config.spec emptyState) - -startApp :: Int -> IO () -startApp port = do - emptyState <- TestStorage <$> Map.newIO <*> Map.newIO - withStdoutLogger $ \aplogger -> do - let settings = setPort port $ setLogger aplogger defaultSettings - runSettings settings $ app empty $ nt emptyState - -spec :: TestStorage -> Spec -spec s = with (return (app empty (nt s))) $ do - describe "GET & POST /Users" $ do - it "responds with [] in empty environment" $ do - get "/Users" `shouldRespondWith` emptyList - - it "can insert then retrieve stored Users" $ do - post "/Users" newBarbara `shouldRespondWith` 201 - get "/Users" `shouldRespondWith` users - - describe "GET /Users/:id" $ do - it "responds with 404 for unknown user" $ do - get "/Users/unknown" `shouldRespondWith` unknown - - it "retrieves stored user" $ do - -- the test implementation stores users with uid [0,1..n-1] - get "/Users/0" `shouldRespondWith` barbara - - describe "PUT /Users/:id" $ do - it "updates mutable fields" $ do - put "/Users/0" barbUpdate0 `shouldRespondWith` updatedBarb0 - - it "does not create new user " $ do - put "/Users/nonexisting" newBarbara `shouldRespondWith` 400 - - describe "DELETE /Users/:id" $ do - it "responds with 404 for unknown user" $ do - delete "/Users/unknown" `shouldRespondWith` 404 - - it "deletes a stored user" $ do - delete "/Users/0" `shouldRespondWith` 204 - -- user should be gone - get "/Users/0" `shouldRespondWith` 404 - delete "/Users/0" `shouldRespondWith` 404 - - -newBarbara :: ByteString -newBarbara = [json| - { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], - "userName":"bjensen", - "externalId":"bjensen", - "name":{ - "formatted":"Ms. Barbara J Jensen III", - "familyName":"Jensen", - "givenName":"Barbara" - } - }|] - - -barbara :: ResponseMatcher -barbara = [json| - { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], - "userName":"bjensen", - "name": { - "givenName":"Barbara", - "formatted":"Ms. Barbara J Jensen III", - "familyName":"Jensen" - }, - "id":"0", - "externalId":"bjensen", - "meta":{ - "resourceType":"User", - "location":"todo", - "created":"2018-01-01T00:00:00Z", - "version":"W/\"testVersion\"", - "lastModified":"2018-01-01T00:00:00Z" - } - }|] - -users :: ResponseMatcher -users = [json| - { "schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], - "totalResults": 1, - "resources": - [{ "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], - "userName":"bjensen", - "externalId":"bjensen", - "id" : "0", - "name":{ - "formatted":"Ms. Barbara J Jensen III", - "familyName":"Jensen", - "givenName":"Barbara" - }, - "meta":{ - "resourceType":"User", - "location":"todo", - "created":"2018-01-01T00:00:00Z", - "version":"W/\"testVersion\"", - "lastModified":"2018-01-01T00:00:00Z" - } - }] - }|] - --- source: https://tools.ietf.org/html/rfc7644#section-3.5.1 (p. 30) -barbUpdate0 :: ByteString -barbUpdate0 = [json| - { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], - "id":"0", - "userName":"bjensen", - "externalId":"bjensen", - "name":{ - "formatted":"Ms. Barbara J Jensen III", - "familyName":"Jensen", - "givenName":"Barbara", - "middleName":"Jane" - }, - "roles":[], - "emails":[ - { - "value":"bjensen@example.com" - }, - { - "value":"babs@jensen.org" - } - ] - }|] - - -updatedBarb0 :: ResponseMatcher -updatedBarb0 = [json| - { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], - "id":"0", - "userName":"bjensen", - "externalId":"bjensen", - "name":{ - "formatted":"Ms. Barbara J Jensen III", - "familyName":"Jensen", - "givenName":"Barbara", - "middleName":"Jane" - }, - "emails":[ - { - "value":"bjensen@example.com" - }, - { - "value":"babs@jensen.org" - } - ], - "meta":{ - "resourceType":"User", - "location":"todo", - "created":"2018-01-01T00:00:00Z", - "version":"W/\"testVersion\"", - "lastModified":"2018-01-01T00:00:00Z" - } - }|] - -emptyList :: ResponseMatcher -emptyList = [json| - { "schemas": ["urn:ietf:params:scim:api:messages:2.0:ListResponse"], - "resources":[], - "totalResults":0 - }|] - -unknown :: ResponseMatcher -unknown = [json| - { "schemas": ["urn:ietf:params:scim:api:messages:2.0:Error"], - "status": "404", - "detail": "Resource unknown not found" - }|] { matchStatus = 404 } +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Test/Capabilities/MetaSchema.hs b/test/Test/Capabilities/MetaSchemaSpec.hs similarity index 98% rename from test/Test/Capabilities/MetaSchema.hs rename to test/Test/Capabilities/MetaSchemaSpec.hs index 280e2a45b52..0e3d3b96526 100644 --- a/test/Test/Capabilities/MetaSchema.hs +++ b/test/Test/Capabilities/MetaSchemaSpec.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE QuasiQuotes #-} -module Test.Capabilities.MetaSchema (spec) where +module Test.Capabilities.MetaSchemaSpec (spec) where import Data.Aeson hiding (json) import qualified Data.HashMap.Strict as SMap diff --git a/test/Test/Class/Groups.hs b/test/Test/Class/GroupSpec.hs similarity index 86% rename from test/Test/Class/Groups.hs rename to test/Test/Class/GroupSpec.hs index 1670ad998fe..3270c9cf5bb 100644 --- a/test/Test/Class/Groups.hs +++ b/test/Test/Class/GroupSpec.hs @@ -3,18 +3,27 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE QuasiQuotes #-} -module Test.Class.Groups (spec) where +module Test.Class.GroupSpec (spec) where -import Web.SCIM.Class.Group (app) +import Network.Wai (Application) +import Servant.Generic +import Servant (Proxy(Proxy), Handler) +import Web.SCIM.Class.Group (GroupAPI, GroupDB, groupServer) +import Web.SCIM.Server (mkapp, App) import Data.ByteString.Lazy (ByteString) import Test.Hspec hiding (shouldSatisfy) import Test.Hspec.Wai hiding (post, put, patch) import Test.Hspec.Wai.JSON import Mock +import qualified STMContainers.Map as Map -spec :: TestStorage -> Spec -spec s = with (pure (app (nt s))) $ do +app :: (GroupDB m, App m GroupAPI) => (forall a. m a -> Handler a) -> Application +app = mkapp (Proxy :: Proxy GroupAPI) (toServant groupServer) + + +spec :: Spec +spec = beforeAll ((\s -> app (nt s)) <$> (TestStorage <$> Map.newIO <*> Map.newIO)) $ do describe "GET & POST /" $ do it "responds with [] in empty environment" $ do get "/" `shouldRespondWith` [json|[]|] @@ -119,7 +128,7 @@ updatedAdmins0 = [json| } }|] - + unknown :: ResponseMatcher unknown = [json| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:Error"], diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs new file mode 100644 index 00000000000..3e61b8f1ceb --- /dev/null +++ b/test/Test/Class/UserSpec.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Test.Class.UserSpec (spec) where + +import Web.SCIM.Capabilities.MetaSchema (empty) +import Web.SCIM.Server +import Test.Hspec +import Test.Hspec.Wai hiding (post, put, patch) +import Test.Hspec.Wai.JSON +import Mock +import Data.ByteString.Lazy (ByteString) +import qualified STMContainers.Map as Map + + +spec :: Spec +spec = beforeAll ((\s -> app empty (nt s)) <$> (TestStorage <$> Map.newIO <*> Map.newIO)) $ do + describe "GET & POST /Users" $ do + it "responds with [] in empty environment" $ do + get "/Users" `shouldRespondWith` emptyList + + it "can insert then retrieve stored Users" $ do + post "/Users" newBarbara `shouldRespondWith` 201 + get "/Users" `shouldRespondWith` users + + describe "GET /Users/:id" $ do + it "responds with 404 for unknown user" $ do + get "/Users/unknown" `shouldRespondWith` unknown + + it "retrieves stored user" $ do + -- the test implementation stores users with uid [0,1..n-1] + get "/Users/0" `shouldRespondWith` barbara + + describe "PUT /Users/:id" $ do + it "updates mutable fields" $ do + put "/Users/0" barbUpdate0 `shouldRespondWith` updatedBarb0 + + it "does not create new user " $ do + put "/Users/nonexisting" newBarbara `shouldRespondWith` 400 + + describe "DELETE /Users/:id" $ do + it "responds with 404 for unknown user" $ do + delete "/Users/unknown" `shouldRespondWith` 404 + + it "deletes a stored user" $ do + delete "/Users/0" `shouldRespondWith` 204 + -- user should be gone + get "/Users/0" `shouldRespondWith` 404 + delete "/Users/0" `shouldRespondWith` 404 + + +newBarbara :: ByteString +newBarbara = [json| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "userName":"bjensen", + "externalId":"bjensen", + "name":{ + "formatted":"Ms. Barbara J Jensen III", + "familyName":"Jensen", + "givenName":"Barbara" + } + }|] + + +barbara :: ResponseMatcher +barbara = [json| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "userName":"bjensen", + "name": { + "givenName":"Barbara", + "formatted":"Ms. Barbara J Jensen III", + "familyName":"Jensen" + }, + "id":"0", + "externalId":"bjensen", + "meta":{ + "resourceType":"User", + "location":"todo", + "created":"2018-01-01T00:00:00Z", + "version":"W/\"testVersion\"", + "lastModified":"2018-01-01T00:00:00Z" + } + }|] + +users :: ResponseMatcher +users = [json| + { "schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], + "totalResults": 1, + "resources": + [{ "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "userName":"bjensen", + "externalId":"bjensen", + "id" : "0", + "name":{ + "formatted":"Ms. Barbara J Jensen III", + "familyName":"Jensen", + "givenName":"Barbara" + }, + "meta":{ + "resourceType":"User", + "location":"todo", + "created":"2018-01-01T00:00:00Z", + "version":"W/\"testVersion\"", + "lastModified":"2018-01-01T00:00:00Z" + } + }] + }|] + +-- source: https://tools.ietf.org/html/rfc7644#section-3.5.1 (p. 30) +barbUpdate0 :: ByteString +barbUpdate0 = [json| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "id":"0", + "userName":"bjensen", + "externalId":"bjensen", + "name":{ + "formatted":"Ms. Barbara J Jensen III", + "familyName":"Jensen", + "givenName":"Barbara", + "middleName":"Jane" + }, + "roles":[], + "emails":[ + { + "value":"bjensen@example.com" + }, + { + "value":"babs@jensen.org" + } + ] + }|] + + +updatedBarb0 :: ResponseMatcher +updatedBarb0 = [json| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "id":"0", + "userName":"bjensen", + "externalId":"bjensen", + "name":{ + "formatted":"Ms. Barbara J Jensen III", + "familyName":"Jensen", + "givenName":"Barbara", + "middleName":"Jane" + }, + "emails":[ + { + "value":"bjensen@example.com" + }, + { + "value":"babs@jensen.org" + } + ], + "meta":{ + "resourceType":"User", + "location":"todo", + "created":"2018-01-01T00:00:00Z", + "version":"W/\"testVersion\"", + "lastModified":"2018-01-01T00:00:00Z" + } + }|] + +emptyList :: ResponseMatcher +emptyList = [json| + { "schemas": ["urn:ietf:params:scim:api:messages:2.0:ListResponse"], + "resources":[], + "totalResults":0 + }|] + +unknown :: ResponseMatcher +unknown = [json| + { "schemas": ["urn:ietf:params:scim:api:messages:2.0:Error"], + "status": "404", + "detail": "Resource unknown not found" + }|] { matchStatus = 404 } From 319933fcbde857d1c7451f828fff137b38e356cb Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Mon, 27 Aug 2018 12:46:30 +0200 Subject: [PATCH 11/64] Okta compliance, part 1 (#8) --- README.md | 2 +- package.yaml | 20 ++++- server/Main.hs | 13 +++ src/Web/SCIM/Capabilities/MetaSchema.hs | 46 +++++----- src/Web/SCIM/Class/Group.hs | 13 +-- src/Web/SCIM/Class/User.hs | 13 +-- src/Web/SCIM/ContentType.hs | 34 ++++++++ src/Web/SCIM/Schema/Error.hs | 4 +- src/Web/SCIM/Schema/ListResponse.hs | 7 +- src/Web/SCIM/Schema/Schema.hs | 78 ++++++++++++++--- {test => src/Web/SCIM/Server}/Mock.hs | 20 +---- stack.yaml | 2 - test/Test/Capabilities/MetaSchemaSpec.hs | 51 +++++------ test/Test/Class/GroupSpec.hs | 19 ++-- test/Test/Class/UserSpec.hs | 23 ++--- test/Test/Util.hs | 105 +++++++++++++++++++++++ 16 files changed, 331 insertions(+), 119 deletions(-) create mode 100644 server/Main.hs create mode 100644 src/Web/SCIM/ContentType.hs rename {test => src/Web/SCIM/Server}/Mock.hs (87%) create mode 100644 test/Test/Util.hs diff --git a/README.md b/README.md index 61cf731d013..f83eaaec306 100644 --- a/README.md +++ b/README.md @@ -24,4 +24,4 @@ for tests. You can run the tests with the standard stack interface: ```sh stack test -``` \ No newline at end of file +``` diff --git a/package.yaml b/package.yaml index d3aba350c34..f1943094e19 100644 --- a/package.yaml +++ b/package.yaml @@ -37,12 +37,26 @@ dependencies: - unordered-containers - email-validate - errors + - stm + - list-t + - http-types + - stm-containers + - http-media ghc-options: -Wall library: source-dirs: src +executables: + hscim-server: + main: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + source-dirs: server + dependencies: + - hscim + - warp + tests: spec: main: Spec.hs @@ -56,22 +70,20 @@ tests: - hscim - hspec - hspec-wai - - hspec-wai-json - aeson - aeson-qq - http-types - - stm-containers - text - bytestring - wai-extra - - stm - stm-containers - mtl - - list-t - time - servant-server - vector - hspec-expectations - hspec-discover - warp + - template-haskell + - aeson-qq - wai-logger diff --git a/server/Main.hs b/server/Main.hs new file mode 100644 index 00000000000..517f954f6cf --- /dev/null +++ b/server/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import Web.SCIM.Server +import Web.SCIM.Server.Mock +import Web.SCIM.Capabilities.MetaSchema (empty) + +import Network.Wai.Handler.Warp +import qualified STMContainers.Map as Map + +main :: IO () +main = do + storage <- TestStorage <$> Map.newIO <*> Map.newIO + run 9000 $ app empty (nt storage) diff --git a/src/Web/SCIM/Capabilities/MetaSchema.hs b/src/Web/SCIM/Capabilities/MetaSchema.hs index 8fd3aa31f0a..8efda876579 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema.hs @@ -14,11 +14,14 @@ module Web.SCIM.Capabilities.MetaSchema ( , empty ) where +import Web.SCIM.Schema.Schema +import Web.SCIM.Schema.ListResponse as ListResponse import Web.SCIM.Capabilities.MetaSchema.User import Web.SCIM.Capabilities.MetaSchema.SPConfig import Web.SCIM.Capabilities.MetaSchema.Group import Web.SCIM.Capabilities.MetaSchema.Schema import Web.SCIM.Capabilities.MetaSchema.ResourceType +import Web.SCIM.ContentType import Control.Monad.Except import Control.Error.Util (note) import Data.Aeson @@ -67,6 +70,7 @@ instance ToJSON AuthenticationScheme data Configuration = Configuration { documentationUri :: Maybe Text -- TODO: URI + , schemas :: [Schema] , patch :: Supported () , bulk :: Supported BulkConfig , filter :: Supported FilterConfig @@ -81,6 +85,12 @@ instance ToJSON Configuration empty :: Configuration empty = Configuration { documentationUri = Nothing + , schemas = [ User20 + , ServiceProviderConfig20 + , Group20 + , Schema20 + , ResourceType20 + ] , patch = Supported False () , bulk = Supported False $ BulkConfig 0 0 , filter = Supported False $ FilterConfig 0 @@ -94,32 +104,20 @@ configServer :: MonadError ServantErr m => Configuration -> ConfigAPI (AsServerT m) configServer config = ConfigAPI { spConfig = pure config - , schemas = pure [ userSchema - , spConfigSchema - , groupSchema - , metaSchema - , resourceSchema - ] - , schema = either throwError pure . note err404 . getSchema + , getSchemas = pure $ + ListResponse.fromList [ userSchema + , spConfigSchema + , groupSchema + , metaSchema + , resourceSchema + ] + , schema = either throwError pure . note err404 . (getSchema <=< fromSchemaUri) , resourceTypes = pure "" } -getSchema :: Text -> Maybe Value -getSchema "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig" = - pure spConfigSchema -getSchema "urn:ietf:params:scim:schemas:core:2.0:User" = - pure userSchema -getSchema "urn:ietf:params:scim:schemas:core:2.0:Group" = - pure groupSchema -getSchema "urn:ietf:params:scim:schemas:core:2.0:Schema" = - pure metaSchema -getSchema "urn:ietf:params:scim:schemas:core:2.0:ResourceType" = - pure resourceSchema -getSchema _ = Nothing - data ConfigAPI route = ConfigAPI - { spConfig :: route :- "ServiceProviderConfig" :> Get '[JSON] Configuration - , schemas :: route :- "Schemas" :> Get '[JSON] [Value] - , schema :: route :- "Schemas" :> Capture "id" Text :> Get '[JSON] Value - , resourceTypes :: route :- "ResourceTypes" :> Get '[JSON] Text + { spConfig :: route :- "ServiceProviderConfig" :> Get '[SCIM] Configuration + , getSchemas :: route :- "Schemas" :> Get '[SCIM] (ListResponse Value) + , schema :: route :- "Schemas" :> Capture "id" Text :> Get '[SCIM] Value + , resourceTypes :: route :- "ResourceTypes" :> Get '[SCIM] Text } deriving (Generic) diff --git a/src/Web/SCIM/Class/Group.hs b/src/Web/SCIM/Class/Group.hs index a5073c13965..8c6a6dd7089 100644 --- a/src/Web/SCIM/Class/Group.hs +++ b/src/Web/SCIM/Class/Group.hs @@ -22,6 +22,7 @@ import GHC.Generics (Generic) import Web.SCIM.Schema.Common import Web.SCIM.Schema.Error import Web.SCIM.Schema.Meta +import Web.SCIM.ContentType import Servant import Servant.Generic @@ -70,17 +71,17 @@ class GroupDB m where data GroupSite route = GroupSite { getGroups :: route :- - Get '[JSON] [StoredGroup] + Get '[SCIM] [StoredGroup] , getGroup :: route :- - Capture "id" Text :> Get '[JSON] StoredGroup + Capture "id" Text :> Get '[SCIM] StoredGroup , postGroup :: route :- - ReqBody '[JSON] Group :> PostCreated '[JSON] StoredGroup + ReqBody '[SCIM] Group :> PostCreated '[SCIM] StoredGroup , putGroup :: route :- - Capture "id" Text :> ReqBody '[JSON] Group :> Put '[JSON] StoredGroup + Capture "id" Text :> ReqBody '[SCIM] Group :> Put '[SCIM] StoredGroup , patchGroup :: route :- - Capture "id" Text :> Patch '[JSON] StoredGroup + Capture "id" Text :> Patch '[SCIM] StoredGroup , deleteGroup :: route :- - Capture "id" Text :> DeleteNoContent '[JSON] NoContent + Capture "id" Text :> DeleteNoContent '[SCIM] NoContent } deriving (Generic) groupServer :: GroupHandler m => GroupSite (AsServerT m) diff --git a/src/Web/SCIM/Class/User.hs b/src/Web/SCIM/Class/User.hs index d11d2115f54..ec7fb6567dd 100644 --- a/src/Web/SCIM/Class/User.hs +++ b/src/Web/SCIM/Class/User.hs @@ -21,6 +21,7 @@ import Web.SCIM.Schema.Meta import Web.SCIM.Schema.Common import Web.SCIM.Schema.Error import Web.SCIM.Schema.ListResponse +import Web.SCIM.ContentType import Servant import Servant.Generic @@ -46,17 +47,17 @@ class UserDB m where data UserSite route = UserSite { getUsers :: route :- - Get '[JSON] (ListResponse StoredUser) + Get '[SCIM] (ListResponse StoredUser) , getUser :: route :- - Capture "id" Text :> Get '[JSON] StoredUser + Capture "id" Text :> Get '[SCIM] StoredUser , postUser :: route :- - ReqBody '[JSON] User :> PostCreated '[JSON] StoredUser + ReqBody '[SCIM] User :> PostCreated '[SCIM] StoredUser , putUser :: route :- - Capture "id" Text :> ReqBody '[JSON] User :> Put '[JSON] StoredUser + Capture "id" Text :> ReqBody '[SCIM] User :> Put '[SCIM] StoredUser , patchUser :: route :- - Capture "id" Text :> Patch '[JSON] StoredUser + Capture "id" Text :> Patch '[SCIM] StoredUser , deleteUser :: route :- - Capture "id" Text :> DeleteNoContent '[JSON] NoContent + Capture "id" Text :> DeleteNoContent '[SCIM] NoContent } deriving (Generic) userServer :: UserHandler m => UserSite (AsServerT m) diff --git a/src/Web/SCIM/ContentType.hs b/src/Web/SCIM/ContentType.hs new file mode 100644 index 00000000000..d28bd0b71ef --- /dev/null +++ b/src/Web/SCIM/ContentType.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} + +-- | SCIM defines its own content type (application/scim+json). It's +-- intended to be used for all requests and responses; see the first +-- paragraph in the SCIM specification at +-- . +-- +-- This module contains helpers for handling it. Basically, just write +-- 'SCIM' instead of 'JSON' in all Servant routes. + +module Web.SCIM.ContentType (SCIM) where + +import Data.Proxy +import Data.List.NonEmpty +import Data.Aeson +import Network.HTTP.Media hiding (Accept) +import Servant.API.ContentTypes + +data SCIM + +instance Accept SCIM where + contentTypes _ = + "application" // "scim+json" /: ("charset", "utf-8") :| + "application" // "scim+json" : + "application" // "json" /: ("charset", "utf-8") : + "application" // "json" : + [] + +instance ToJSON a => MimeRender SCIM a where + mimeRender _ = mimeRender (Proxy @JSON) + +instance FromJSON a => MimeUnrender SCIM a where + mimeUnrender _ = mimeUnrender (Proxy @JSON) diff --git a/src/Web/SCIM/Schema/Error.hs b/src/Web/SCIM/Schema/Error.hs index 9384b410560..49204220718 100644 --- a/src/Web/SCIM/Schema/Error.hs +++ b/src/Web/SCIM/Schema/Error.hs @@ -43,7 +43,7 @@ fromErrorType typ = , detail = Nothing } in err400 { errBody = encode body - , errHeaders = [("Content-Type", "application/json")] + , errHeaders = [("Content-Type", "application/scim+json;charset=utf-8")] } notFound :: Text -> ServantErr @@ -55,7 +55,7 @@ notFound rid = , detail = pure $ "Resource " <> rid <> " not found" } in err404 { errBody = encode body - , errHeaders = [("Content-Type", "application/json")] + , errHeaders = [("Content-Type", "application/scim+json;charset=utf-8")] } -- wrapped in a newtype because SCIM wants strings for status codes diff --git a/src/Web/SCIM/Schema/ListResponse.hs b/src/Web/SCIM/Schema/ListResponse.hs index f33e1adbbf2..152e2699038 100644 --- a/src/Web/SCIM/Schema/ListResponse.hs +++ b/src/Web/SCIM/Schema/ListResponse.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} module Web.SCIM.Schema.ListResponse (ListResponse, fromList) where @@ -23,5 +24,9 @@ instance FromJSON a => FromJSON (ListResponse a) where parseJSON = genericParseJSON parseOptions . jsonLower instance ToJSON a => ToJSON (ListResponse a) where - toJSON = genericToJSON serializeOptions + toJSON ListResponse{..} = + object [ "Resources" .= resources + , "schemas" .= schemas + , "totalResults" .= totalResults + ] diff --git a/src/Web/SCIM/Schema/Schema.hs b/src/Web/SCIM/Schema/Schema.hs index 6aba1d08ffd..f4af91f2044 100644 --- a/src/Web/SCIM/Schema/Schema.hs +++ b/src/Web/SCIM/Schema/Schema.hs @@ -1,23 +1,77 @@ module Web.SCIM.Schema.Schema where -import Data.Aeson +import Web.SCIM.Capabilities.MetaSchema.User +import Web.SCIM.Capabilities.MetaSchema.SPConfig +import Web.SCIM.Capabilities.MetaSchema.Group +import Web.SCIM.Capabilities.MetaSchema.Schema +import Web.SCIM.Capabilities.MetaSchema.ResourceType +import Data.Text +import Data.Aeson + +-- | All schemas that we support. data Schema = User20 + | ServiceProviderConfig20 + | Group20 + | Schema20 + | ResourceType20 | ListResponse2_0 deriving (Show, Eq) instance FromJSON Schema where - parseJSON = withText "schema" $ \s -> case s of - "urn:ietf:params:scim:schemas:core:2.0:User" -> - pure User20 - "urn:ietf:params:scim:api:messages:2.0:ListResponse" -> - pure ListResponse2_0 - _ -> - fail "unsupported schema" + parseJSON = withText "schema" $ \t -> case fromSchemaUri t of + Just s -> pure s + Nothing -> fail "unsupported schema" instance ToJSON Schema where - toJSON User20 = - "urn:ietf:params:scim:schemas:core:2.0:User" - toJSON ListResponse2_0 = - "urn:ietf:params:scim:api:messages:2.0:ListResponse" + toJSON = toJSON . getSchemaUri + +-- | Get schema URI (e.g. @urn:ietf:params:scim:schemas:core:2.0:User@). +getSchemaUri :: Schema -> Text +getSchemaUri User20 = + "urn:ietf:params:scim:schemas:core:2.0:User" +getSchemaUri ServiceProviderConfig20 = + "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig" +getSchemaUri Group20 = + "urn:ietf:params:scim:schemas:core:2.0:Group" +getSchemaUri Schema20 = + "urn:ietf:params:scim:schemas:core:2.0:Schema" +getSchemaUri ResourceType20 = + "urn:ietf:params:scim:schemas:core:2.0:ResourceType" +getSchemaUri ListResponse2_0 = + "urn:ietf:params:scim:api:messages:2.0:ListResponse" + +-- | Get a schema by its URI. +fromSchemaUri :: Text -> Maybe Schema +fromSchemaUri s = case s of + "urn:ietf:params:scim:schemas:core:2.0:User" -> + pure User20 + "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig" -> + pure ServiceProviderConfig20 + "urn:ietf:params:scim:schemas:core:2.0:Group" -> + pure Group20 + "urn:ietf:params:scim:schemas:core:2.0:Schema" -> + pure Schema20 + "urn:ietf:params:scim:schemas:core:2.0:ResourceType" -> + pure ResourceType20 + "urn:ietf:params:scim:api:messages:2.0:ListResponse" -> + pure ListResponse2_0 + _ -> + Nothing + +-- | Get schema description as JSON. +getSchema :: Schema -> Maybe Value +getSchema ServiceProviderConfig20 = + pure spConfigSchema +getSchema User20 = + pure userSchema +getSchema Group20 = + pure groupSchema +getSchema Schema20 = + pure metaSchema +getSchema ResourceType20 = + pure resourceSchema +getSchema ListResponse2_0 = + Nothing -- it's possible that a schema for ListResponse exists, but I + -- haven't found it diff --git a/test/Mock.hs b/src/Web/SCIM/Server/Mock.hs similarity index 87% rename from test/Mock.hs rename to src/Web/SCIM/Server/Mock.hs index 497d2f97398..d7c3f4ea97e 100644 --- a/test/Mock.hs +++ b/src/Web/SCIM/Server/Mock.hs @@ -3,21 +3,20 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} -module Mock where +-- | A mock server for use in our testsuite, as well as for automated +-- compliance testing (e.g. with Runscope – see +-- https://developer.okta.com/standards/SCIM/#step-2-test-your-scim-server). +module Web.SCIM.Server.Mock where import Web.SCIM.Class.Group import Web.SCIM.Class.User import Control.Monad.STM import Control.Monad.Reader -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as L import Data.Text import Data.Time.Clock import Data.Time.Calendar import ListT -import Network.HTTP.Types -import Network.Wai.Test (SResponse) import qualified STMContainers.Map as Map import STMContainers.Map (Map) import Web.SCIM.Schema.User @@ -26,7 +25,6 @@ import Web.SCIM.Schema.ListResponse import Web.SCIM.Schema.Common (WithId(WithId)) import qualified Web.SCIM.Schema.Common as Common import Servant -import Test.Hspec.Wai hiding (post, put, patch) import Prelude hiding (id) @@ -166,13 +164,3 @@ insertUser user met storage = do -- this takes the initial environment and returns the transformation nt :: r -> ReaderT r m a -> m a nt = flip runReaderT - --- Redefine wai test helpers to include json content type -post :: ByteString -> L.ByteString -> WaiSession SResponse -post path = request methodPost path [(hContentType, "application/json")] - -put :: ByteString -> L.ByteString -> WaiSession SResponse -put path = request methodPut path [(hContentType, "application/json")] - -patch :: ByteString -> L.ByteString -> WaiSession SResponse -patch path = request methodPatch path [(hContentType, "application/json")] diff --git a/stack.yaml b/stack.yaml index 4d182aa88e6..9f394505d1b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,5 +2,3 @@ resolver: lts-10.3 packages: - . - -allow-newer: true diff --git a/test/Test/Capabilities/MetaSchemaSpec.hs b/test/Test/Capabilities/MetaSchemaSpec.hs index 0e3d3b96526..50990c3a6e6 100644 --- a/test/Test/Capabilities/MetaSchemaSpec.hs +++ b/test/Test/Capabilities/MetaSchemaSpec.hs @@ -1,13 +1,17 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} module Test.Capabilities.MetaSchemaSpec (spec) where -import Data.Aeson hiding (json) -import qualified Data.HashMap.Strict as SMap -import Data.Maybe (catMaybes) -import qualified Data.Vector as Vector +import Test.Util + +import qualified Data.List as List +import Data.Aeson +import Data.Monoid +import Data.Text (Text) +import Data.Coerce import Web.SCIM.Capabilities.MetaSchema import Network.Wai.Test (SResponse (..)) import Servant @@ -15,7 +19,6 @@ import Servant.Generic import Test.Hspec hiding (shouldSatisfy) import qualified Test.Hspec.Expectations as Expect import Test.Hspec.Wai hiding (post, put, patch) -import Test.Hspec.Wai.JSON server :: Proxy (ToServant (ConfigAPI AsApi)) server = Proxy @@ -26,14 +29,19 @@ app = serve server $ toServant $ configServer empty shouldSatisfy :: (Show a, FromJSON a) => WaiSession SResponse -> (a -> Bool) -> WaiExpectation shouldSatisfy resp predicate = do - maybeDecoded <- decode . simpleBody <$> resp + maybeDecoded <- eitherDecode . simpleBody <$> resp case maybeDecoded of - Nothing -> liftIO $ Expect.expectationFailure "decode error" - (Just decoded) -> liftIO $ Expect.shouldSatisfy decoded predicate + Left err -> liftIO $ Expect.expectationFailure ("decode error: " <> err) + Right decoded -> liftIO $ Expect.shouldSatisfy decoded predicate +-- | A type that helps us parse out the pieces that we're interested in +-- (specifically, a list of schema URIs). The whole response is very big and +-- we don't want to print it out when the response parses correctly but the +-- sets of schemas don't match. +type SchemasResponse = Field "Resources" [Field "id" Text] -coreSchemas :: [Value] -coreSchemas = String <$> +coreSchemas :: [Text] +coreSchemas = [ "urn:ietf:params:scim:schemas:core:2.0:User" , "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig" , "urn:ietf:params:scim:schemas:core:2.0:Group" @@ -41,25 +49,13 @@ coreSchemas = String <$> , "urn:ietf:params:scim:schemas:core:2.0:ResourceType" ] -hasSchemas :: Value -> Bool --- TODO: these needs to be sorted, but there's no Ord on Value --- (and I'm lazy) -hasSchemas (Array arr) = coreSchemas == getSchemaIds arr -hasSchemas _ = False - -getSchemaIds :: Array -> [Value] -getSchemaIds arr = catMaybes . Vector.toList $ getSchemaId <$> arr - -getSchemaId :: Value -> Maybe Value -getSchemaId (Object o) = SMap.lookup "id" o -getSchemaId _ = Nothing - spec :: Spec spec = with (pure app) $ do describe "GET /Schemas" $ do it "lists schemas" $ do get "/Schemas" `shouldRespondWith` 200 - get "/Schemas" `shouldSatisfy` hasSchemas + get "/Schemas" `shouldSatisfy` \(resp :: SchemasResponse) -> + List.sort (coerce resp) == List.sort coreSchemas describe "GET /Schemas/:id" $ do it "returns valid schema" $ do @@ -76,8 +72,13 @@ spec = with (pure app) $ do -- FIXME: missing some "supported" fields and URI should not be null spConfig :: ResponseMatcher -spConfig = [json| +spConfig = [scim| {"documentationUri":null, + "schemas":["urn:ietf:params:scim:schemas:core:2.0:User", + "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig", + "urn:ietf:params:scim:schemas:core:2.0:Group", + "urn:ietf:params:scim:schemas:core:2.0:Schema", + "urn:ietf:params:scim:schemas:core:2.0:ResourceType"], "etag":{"supported":false}, "bulk":{"maxOperations":0, "maxPayloadSize":0, diff --git a/test/Test/Class/GroupSpec.hs b/test/Test/Class/GroupSpec.hs index 3270c9cf5bb..eba8bff5420 100644 --- a/test/Test/Class/GroupSpec.hs +++ b/test/Test/Class/GroupSpec.hs @@ -5,16 +5,17 @@ module Test.Class.GroupSpec (spec) where +import Test.Util + import Network.Wai (Application) import Servant.Generic import Servant (Proxy(Proxy), Handler) import Web.SCIM.Class.Group (GroupAPI, GroupDB, groupServer) import Web.SCIM.Server (mkapp, App) +import Web.SCIM.Server.Mock import Data.ByteString.Lazy (ByteString) import Test.Hspec hiding (shouldSatisfy) import Test.Hspec.Wai hiding (post, put, patch) -import Test.Hspec.Wai.JSON -import Mock import qualified STMContainers.Map as Map @@ -26,7 +27,7 @@ spec :: Spec spec = beforeAll ((\s -> app (nt s)) <$> (TestStorage <$> Map.newIO <*> Map.newIO)) $ do describe "GET & POST /" $ do it "responds with [] in empty environment" $ do - get "/" `shouldRespondWith` [json|[]|] + get "/" `shouldRespondWith` [scim|[]|] it "can insert then retrieve stored group" $ do post "/" adminGroup `shouldRespondWith` 201 @@ -60,7 +61,7 @@ spec = beforeAll ((\s -> app (nt s)) <$> (TestStorage <$> Map.newIO <*> Map.newI adminGroup :: ByteString -adminGroup = [json| +adminGroup = [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], "displayName":"Admin", "members":[] @@ -68,7 +69,7 @@ adminGroup = [json| groups :: ResponseMatcher -groups = [json| +groups = [scim| [{ "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], "displayName":"Admin", "members":[], @@ -83,7 +84,7 @@ groups = [json| }]|] admins :: ResponseMatcher -admins = [json| +admins = [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], "displayName":"Admin", "members":[], @@ -98,7 +99,7 @@ admins = [json| }|] adminUpdate0 :: ByteString -adminUpdate0 = [json| +adminUpdate0 = [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], "displayName":"Admin", "members":[ @@ -110,7 +111,7 @@ adminUpdate0 = [json| }|] updatedAdmins0 :: ResponseMatcher -updatedAdmins0 = [json| +updatedAdmins0 = [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], "displayName":"Admin", "members":[ @@ -130,7 +131,7 @@ updatedAdmins0 = [json| unknown :: ResponseMatcher -unknown = [json| +unknown = [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:Error"], "status": "404", "detail": "Resource unknown not found" diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index 3e61b8f1ceb..e536bf4eb2e 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -2,12 +2,13 @@ module Test.Class.UserSpec (spec) where +import Test.Util + import Web.SCIM.Capabilities.MetaSchema (empty) import Web.SCIM.Server +import Web.SCIM.Server.Mock import Test.Hspec import Test.Hspec.Wai hiding (post, put, patch) -import Test.Hspec.Wai.JSON -import Mock import Data.ByteString.Lazy (ByteString) import qualified STMContainers.Map as Map @@ -49,7 +50,7 @@ spec = beforeAll ((\s -> app empty (nt s)) <$> (TestStorage <$> Map.newIO <*> Ma newBarbara :: ByteString -newBarbara = [json| +newBarbara = [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "userName":"bjensen", "externalId":"bjensen", @@ -62,7 +63,7 @@ newBarbara = [json| barbara :: ResponseMatcher -barbara = [json| +barbara = [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "userName":"bjensen", "name": { @@ -82,10 +83,10 @@ barbara = [json| }|] users :: ResponseMatcher -users = [json| +users = [scim| { "schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "totalResults": 1, - "resources": + "Resources": [{ "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "userName":"bjensen", "externalId":"bjensen", @@ -107,7 +108,7 @@ users = [json| -- source: https://tools.ietf.org/html/rfc7644#section-3.5.1 (p. 30) barbUpdate0 :: ByteString -barbUpdate0 = [json| +barbUpdate0 = [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "id":"0", "userName":"bjensen", @@ -131,7 +132,7 @@ barbUpdate0 = [json| updatedBarb0 :: ResponseMatcher -updatedBarb0 = [json| +updatedBarb0 = [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "id":"0", "userName":"bjensen", @@ -160,14 +161,14 @@ updatedBarb0 = [json| }|] emptyList :: ResponseMatcher -emptyList = [json| +emptyList = [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:ListResponse"], - "resources":[], + "Resources":[], "totalResults":0 }|] unknown :: ResponseMatcher -unknown = [json| +unknown = [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:Error"], "status": "404", "detail": "Resource unknown not found" diff --git a/test/Test/Util.hs b/test/Test/Util.hs new file mode 100644 index 00000000000..145b219089f --- /dev/null +++ b/test/Test/Util.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Util ( + -- * Making wai requests + post, put, patch + -- * Request/response quasiquoter + , scim + -- * JSON parsing + , Field(..) + , getField + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Aeson +import Data.Aeson.Internal (JSONPathElement (Key), ()) +import Data.Aeson.QQ +import Data.Monoid +import Data.Text +import Language.Haskell.TH.Quote +import Network.HTTP.Types +import Network.Wai.Test (SResponse) +import Test.Hspec.Wai hiding (post, put, patch) +import Test.Hspec.Wai.Matcher (bodyEquals) +import Data.Proxy +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import qualified Data.HashMap.Strict as SMap + +---------------------------------------------------------------------------- +-- Redefine wai test helpers to include scim+json content type + +post :: ByteString -> L.ByteString -> WaiSession SResponse +post path = request methodPost path [(hContentType, "application/scim+json")] + +put :: ByteString -> L.ByteString -> WaiSession SResponse +put path = request methodPut path [(hContentType, "application/scim+json")] + +patch :: ByteString -> L.ByteString -> WaiSession SResponse +patch path = request methodPatch path [(hContentType, "application/scim+json")] + +---------------------------------------------------------------------------- +-- Redefine wai quasiquoter +-- +-- This code was taken from Test.Hspec.Wai.JSON and modified to accept +-- @application/scim+json@. In order to keep the code simple, we also +-- require @charset=utf-8@, even though the original implementation +-- considers it optional. + +-- | A response matcher and quasiquoter that should be used instead of +-- 'Test.Hspec.Wai.JSON.json'. +scim :: QuasiQuoter +scim = QuasiQuoter + { quoteExp = \input -> [|fromValue $(quoteExp aesonQQ input)|] + , quotePat = const $ error "No quotePat defined for Test.Util.scim" + , quoteType = const $ error "No quoteType defined for Test.Util.scim" + , quoteDec = const $ error "No quoteDec defined for Test.Util.scim" + } + +class FromValue a where + fromValue :: Value -> a + +instance FromValue ResponseMatcher where + fromValue = ResponseMatcher 200 [matchHeader] . equalsJSON + where + matchHeader = "Content-Type" <:> "application/scim+json;charset=utf-8" + +equalsJSON :: Value -> MatchBody +equalsJSON expected = MatchBody matcher + where + matcher headers actualBody = case decode actualBody of + Just actual | actual == expected -> Nothing + _ -> let MatchBody m = bodyEquals (encode expected) in m headers actualBody + +instance FromValue L.ByteString where + fromValue = encode + +---------------------------------------------------------------------------- +-- Ad-hoc JSON parsing + +-- | A way to parse out a single value from a JSON object by specifying the +-- field as a type-level string. Very useful when you don't want to create +-- extra types. +newtype Field (s :: Symbol) a = Field a + deriving (Eq, Ord, Show, Read, Functor) + +getField :: Field s a -> a +getField (Field a) = a + +-- Copied from http://hackage.haskell.org/package/aeson-extra-0.4.1.1/docs/src/Data.Aeson.Extra.SingObject.html +instance (KnownSymbol s, FromJSON a) => FromJSON (Field s a) where + parseJSON = withObject ("Field " <> show key) $ \obj -> + case SMap.lookup key obj of + Nothing -> fail $ "key " ++ show key ++ " not present" + Just v -> Field <$> parseJSON v Key key + where + key = pack $ symbolVal (Proxy :: Proxy s) + +instance (KnownSymbol s, ToJSON a) => ToJSON (Field s a) where + toJSON (Field x) = object [ key .= x] + where + key = pack $ symbolVal (Proxy :: Proxy s) From 7b9bdb5883b081fb8c1ba0e221d86f9afa9602c7 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Mon, 3 Sep 2018 11:31:26 +0200 Subject: [PATCH 12/64] Support for basic HTTP authentication (#9) --- package.yaml | 5 + server/Main.hs | 10 +- src/Web/SCIM/Capabilities/MetaSchema.hs | 37 +++--- src/Web/SCIM/Capabilities/MetaSchema/Group.hs | 4 + .../SCIM/Capabilities/MetaSchema/SPConfig.hs | 2 + src/Web/SCIM/Class/Auth.hs | 41 +++++++ src/Web/SCIM/Class/Group.hs | 9 +- src/Web/SCIM/Schema/AuthenticationScheme.hs | 55 +++++++++ src/Web/SCIM/Schema/Meta.hs | 3 +- src/Web/SCIM/Server.hs | 109 ++++++++++++++---- src/Web/SCIM/Server/Mock.hs | 57 +++++---- stack.yaml | 5 + test/Test/Capabilities/MetaSchemaSpec.hs | 21 ++-- test/Test/Class/AuthSpec.hs | 55 +++++++++ test/Test/Class/GroupSpec.hs | 19 +-- test/Test/Class/UserSpec.hs | 39 ++++--- test/Test/Util.hs | 2 +- 17 files changed, 369 insertions(+), 104 deletions(-) create mode 100644 src/Web/SCIM/Class/Auth.hs create mode 100644 src/Web/SCIM/Schema/AuthenticationScheme.hs create mode 100644 test/Test/Class/AuthSpec.hs diff --git a/package.yaml b/package.yaml index f1943094e19..c7dd8255d10 100644 --- a/package.yaml +++ b/package.yaml @@ -24,16 +24,20 @@ extra-source-files: dependencies: - base >= 4.7 && < 5 + - bytestring - aeson - aeson-qq - mtl - servant - servant-server + - servant-auth + - servant-auth-server - servant-generic - text - time - wai - network-uri + - network-uri-static - unordered-containers - email-validate - errors @@ -87,3 +91,4 @@ tests: - template-haskell - aeson-qq - wai-logger + - base64-bytestring diff --git a/server/Main.hs b/server/Main.hs index 517f954f6cf..3773038c234 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -2,12 +2,16 @@ module Main where import Web.SCIM.Server import Web.SCIM.Server.Mock +import Web.SCIM.Class.Auth (Admin (..)) import Web.SCIM.Capabilities.MetaSchema (empty) import Network.Wai.Handler.Warp -import qualified STMContainers.Map as Map +import qualified STMContainers.Map as STMMap +import Control.Monad.STM (atomically) main :: IO () main = do - storage <- TestStorage <$> Map.newIO <*> Map.newIO - run 9000 $ app empty (nt storage) + auth <- STMMap.newIO + atomically $ STMMap.insert (Admin "admin", "password") "admin" auth + storage <- TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> pure auth + run 9000 =<< app empty (nt storage) diff --git a/src/Web/SCIM/Capabilities/MetaSchema.hs b/src/Web/SCIM/Capabilities/MetaSchema.hs index 8efda876579..3600b8a4267 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema.hs @@ -4,17 +4,18 @@ {-# LANGUAGE ConstraintKinds #-} module Web.SCIM.Capabilities.MetaSchema ( - ConfigAPI + ConfigSite , configServer , Supported (..) , BulkConfig (..) , FilterConfig (..) - , AuthenticationScheme (..) , Configuration (..) , empty ) where import Web.SCIM.Schema.Schema +import Web.SCIM.Schema.Common +import Web.SCIM.Schema.AuthenticationScheme import Web.SCIM.Schema.ListResponse as ListResponse import Web.SCIM.Capabilities.MetaSchema.User import Web.SCIM.Capabilities.MetaSchema.SPConfig @@ -28,7 +29,7 @@ import Data.Aeson import qualified Data.HashMap.Lazy as HML import Data.Text (Text) import GHC.Generics (Generic) -import Servant +import Servant hiding (URI) import Servant.Generic import Prelude hiding (filter) @@ -49,27 +50,18 @@ data BulkConfig = BulkConfig , maxPayloadSize :: Int } deriving (Show, Eq, Generic) -instance ToJSON BulkConfig +instance ToJSON BulkConfig where + toJSON = genericToJSON serializeOptions data FilterConfig = FilterConfig { maxResults :: Int } deriving (Show, Eq, Generic) -instance ToJSON FilterConfig - --- TODO -data AuthenticationScheme = AuthenticationScheme - { typ :: Text - , name :: Text - , description :: Text - , specUri :: Text -- TODO: URI - -- , documentationUri :: URI - } deriving (Show, Eq, Generic) - -instance ToJSON AuthenticationScheme +instance ToJSON FilterConfig where + toJSON = genericToJSON serializeOptions data Configuration = Configuration - { documentationUri :: Maybe Text -- TODO: URI + { documentationUri :: Maybe URI , schemas :: [Schema] , patch :: Supported () , bulk :: Supported BulkConfig @@ -80,7 +72,8 @@ data Configuration = Configuration , authenticationSchemes :: [AuthenticationScheme] } deriving (Show, Eq, Generic) -instance ToJSON Configuration +instance ToJSON Configuration where + toJSON = genericToJSON serializeOptions empty :: Configuration empty = Configuration @@ -97,12 +90,12 @@ empty = Configuration , changePassword = Supported False () , sort = Supported False () , etag = Supported False () - , authenticationSchemes = [] + , authenticationSchemes = [AuthHttpBasic] } configServer :: MonadError ServantErr m => - Configuration -> ConfigAPI (AsServerT m) -configServer config = ConfigAPI + Configuration -> ConfigSite (AsServerT m) +configServer config = ConfigSite { spConfig = pure config , getSchemas = pure $ ListResponse.fromList [ userSchema @@ -115,7 +108,7 @@ configServer config = ConfigAPI , resourceTypes = pure "" } -data ConfigAPI route = ConfigAPI +data ConfigSite route = ConfigSite { spConfig :: route :- "ServiceProviderConfig" :> Get '[SCIM] Configuration , getSchemas :: route :- "Schemas" :> Get '[SCIM] (ListResponse Value) , schema :: route :- "Schemas" :> Capture "id" Text :> Get '[SCIM] Value diff --git a/src/Web/SCIM/Capabilities/MetaSchema/Group.hs b/src/Web/SCIM/Capabilities/MetaSchema/Group.hs index 8b879995828..d6d6dfb97f7 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema/Group.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema/Group.hs @@ -5,6 +5,10 @@ module Web.SCIM.Capabilities.MetaSchema.Group (groupSchema) where import Data.Aeson (Value) import Data.Aeson.QQ +-- NB: errata for the SCIM RFC says that 'displayName' should have +-- 'required: true'. This makes sense but we're not going to change this for +-- now because nobody seems to care about these schemas anyway. +-- See https://www.rfc-editor.org/errata_search.php?rfc=7643 groupSchema :: Value groupSchema = [aesonQQ| { diff --git a/src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs b/src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs index 2569d8822e1..df85630afa3 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs @@ -5,6 +5,8 @@ module Web.SCIM.Capabilities.MetaSchema.SPConfig (spConfigSchema) where import Data.Aeson (Value) import Data.Aeson.QQ +-- NB: it looks like 'authenticationSchemes' should also have a 'type' +-- attribute. The sample schema from the RFC doesn't list it, though. spConfigSchema :: Value spConfigSchema = [aesonQQ| { diff --git a/src/Web/SCIM/Class/Auth.hs b/src/Web/SCIM/Class/Auth.hs new file mode 100644 index 00000000000..18cf09034cf --- /dev/null +++ b/src/Web/SCIM/Class/Auth.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Basic HTTP authentication support. See See +-- https://haskell-servant.readthedocs.io/en/stable/cookbook/jwt-and-basic-auth/JWTAndBasicAuth.html +module Web.SCIM.Class.Auth + ( Admin (..) + , AuthDB (..) + ) where + +import Data.Aeson +import Data.Text +import GHC.Generics +import Servant.Auth.Server + +-- | Someone who is allowed to provision users via SCIM. +data Admin = Admin + { name :: Text -- TODO: change to UUID + } deriving (Eq, Show, Read, Generic) + +instance ToJSON Admin +instance ToJWT Admin +instance FromJSON Admin +instance FromJWT Admin + +-- | Unfortunately, we have to pass an "authentication callback" to Servant +-- by instantiating a zero-argument type family. This can only be done once +-- per application. +type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult Admin) + +instance FromBasicAuthData Admin where + fromBasicAuthData auth check = check auth + +-- | An interface that has to be implemented for a server to provide +-- authentication. +class AuthDB m where + -- | Check whether a set of credentials (login and password) corresponds + -- to any 'Admin'. + -- + -- We can only do IO in 'fromBasicAuthData', so this has to return an IO + -- action. + mkAuthChecker :: m (BasicAuthData -> IO (AuthResult Admin)) diff --git a/src/Web/SCIM/Class/Group.hs b/src/Web/SCIM/Class/Group.hs index 8c6a6dd7089..d69f9398dbc 100644 --- a/src/Web/SCIM/Class/Group.hs +++ b/src/Web/SCIM/Class/Group.hs @@ -11,7 +11,6 @@ module Web.SCIM.Class.Group ( , GroupId , Member (..) , groupServer - , GroupAPI ) where import Control.Monad.Except @@ -28,7 +27,6 @@ import Servant.Generic type GroupHandler m = (MonadError ServantErr m, GroupDB m) -type GroupAPI = ToServant (GroupSite AsApi) type GroupId = Text @@ -54,8 +52,11 @@ data Group = Group } deriving (Show, Eq, Generic) -instance FromJSON Group -instance ToJSON Group +instance FromJSON Group where + parseJSON = genericParseJSON parseOptions . jsonLower + +instance ToJSON Group where + toJSON = genericToJSON serializeOptions type StoredGroup = WithMeta (WithId Group) diff --git a/src/Web/SCIM/Schema/AuthenticationScheme.hs b/src/Web/SCIM/Schema/AuthenticationScheme.hs new file mode 100644 index 00000000000..ec6b30c33ed --- /dev/null +++ b/src/Web/SCIM/Schema/AuthenticationScheme.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Web.SCIM.Schema.AuthenticationScheme + ( AuthenticationScheme(..) + ) where + +import Web.SCIM.Schema.Common + +import Data.Aeson +import Data.Text +import GHC.Generics +import Network.URI.Static + +-- | Possible authentication schemes. The specification defines the values +-- "oauth", "oauth2", "oauthbearertoken", "httpbasic", and "httpdigest". +data AuthenticationScheme + = AuthOAuth + | AuthOAuth2 + | AuthOAuthBearerToken + | AuthHttpBasic + | AuthHttpDigest + deriving (Eq, Show, Enum, Bounded, Ord) + +-- | The way authentication schemes are expected to be represented in the +-- configuration. Each 'AuthenticationScheme' corresponds to one of such +-- encodings. +data AuthenticationSchemeEncoding = AuthenticationSchemeEncoding + { + -- | The authentication scheme + typ :: Text + -- | The common authentication scheme name, e.g. HTTP Basic + , name :: Text + -- | A description of the authentication scheme + , description :: Text + -- | An HTTP-addressable URL pointing to the authentication scheme's + -- specification + , specUri :: Maybe URI + -- | An HTTP-addressable URL pointing to the authentication scheme's usage + -- documentation + , documentationUri :: Maybe URI + } deriving (Show, Eq, Generic) + +instance ToJSON AuthenticationSchemeEncoding where + toJSON = genericToJSON serializeOptions + -- NB: "typ" will be converted to "type" thanks to 'serializeOptions' + +instance ToJSON AuthenticationScheme where + toJSON AuthHttpBasic = toJSON AuthenticationSchemeEncoding + { typ = "httpbasic" + , name = "HTTP Basic" + , description = "Authentication via the HTTP Basic standard" + , specUri = Just $ URI [uri|https://tools.ietf.org/html/rfc7617|] + , documentationUri = Just $ URI [uri|https://en.wikipedia.org/wiki/Basic_access_authentication|] + } + toJSON x = error ("not implemented: toJSON " ++ show x) diff --git a/src/Web/SCIM/Schema/Meta.hs b/src/Web/SCIM/Schema/Meta.hs index 794e72c8c07..1df201bc806 100644 --- a/src/Web/SCIM/Schema/Meta.hs +++ b/src/Web/SCIM/Schema/Meta.hs @@ -33,7 +33,8 @@ data Meta = Meta , location :: URI } deriving (Eq, Show, Generic) -instance ToJSON Meta +instance ToJSON Meta where + toJSON = genericToJSON serializeOptions data WithMeta a = WithMeta { meta :: Meta diff --git a/src/Web/SCIM/Server.hs b/src/Web/SCIM/Server.hs index cf574ec5c67..c1305a42f67 100644 --- a/src/Web/SCIM/Server.hs +++ b/src/Web/SCIM/Server.hs @@ -1,60 +1,129 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Web.SCIM.Server ( app , SiteAPI , mkapp, App + + -- * API subtrees, useful for tests + , ConfigAPI, configServer + , UserAPI, userServer + , GroupAPI, groupServer ) where +import qualified Data.ByteString.Lazy.Char8 as BL import Web.SCIM.Class.User (UserSite (..), UserDB, userServer) import Web.SCIM.Class.Group (GroupSite (..), GroupDB, groupServer) -import Web.SCIM.Capabilities.MetaSchema (ConfigAPI, Configuration, configServer) +import Web.SCIM.Class.Auth (Admin, AuthDB (..)) +import Web.SCIM.Capabilities.MetaSchema (ConfigSite, Configuration, configServer) import Control.Monad.Except +import Control.Exception (throw) import GHC.Generics (Generic) import Network.Wai -import Servant +import Servant hiding (BasicAuth, NoSuchUser) import Servant.Generic +import Servant.Auth +import Servant.Auth.Server #if !MIN_VERSION_servant_server(0,12,0) import Servant.Utils.Enter #endif +---------------------------------------------------------------------------- +-- API specification + +type SCIMHandler m = (MonadError ServantErr m, UserDB m, GroupDB m, AuthDB m) -type SCIMHandler m = (MonadError ServantErr m, UserDB m, GroupDB m) -type SiteAPI = ToServant (Site AsApi) +type ConfigAPI = ToServant (ConfigSite AsApi) +type UserAPI = ToServant (UserSite AsApi) +type GroupAPI = ToServant (GroupSite AsApi) +type SiteAPI = ToServant (Site AsApi) data Site route = Site - { config :: route :- ToServant (ConfigAPI AsApi) - , users :: route :- "Users" :> ToServant (UserSite AsApi) - , groups :: route :- "Groups" :> ToServant (GroupSite AsApi) + { config :: route :- + ConfigAPI + , users :: route :- + Auth '[BasicAuth] Admin :> + "Users" :> UserAPI + , groups :: route :- + Auth '[BasicAuth] Admin :> + "Groups" :> GroupAPI } deriving (Generic) -siteServer :: Configuration -> SCIMHandler m => Site (AsServerT m) +---------------------------------------------------------------------------- +-- API implementation + +-- TODO: this is horrible, let's switch to servant-server-0.12 as soon as possible +#if MIN_VERSION_servant_server(0,12,0) +type EnterBoilerplate m = ( Functor m ) -- `()` is parsed as a type +#else +type EnterBoilerplate m = + ( Enter (ServerT UserAPI (Either ServantErr)) (Either ServantErr) m (ServerT UserAPI m) + , Enter (ServerT GroupAPI (Either ServantErr)) (Either ServantErr) m (ServerT GroupAPI m) + ) +#endif + +siteServer :: + forall m. (SCIMHandler m, EnterBoilerplate m) => + Configuration -> Site (AsServerT m) siteServer conf = Site { config = toServant $ configServer conf - , users = toServant userServer - , groups = toServant groupServer + , users = \authResult -> case authResult of + Authenticated _ -> toServant userServer +#if MIN_VERSION_servant_server(0,12,0) + _ -> hoistServer (Proxy @UserAPI) nt (noAuth authResult) +#else + _ -> enter (NT nt) (noAuth authResult) +#endif + , groups = \authResult -> case authResult of + Authenticated _ -> toServant groupServer +#if MIN_VERSION_servant_server(0,12,0) + _ -> hoistServer (Proxy @GroupAPI) nt (noAuth authResult) +#else + _ -> enter (NT nt) (noAuth authResult) +#endif } + where + noAuth res = throwAll $ err401 { errBody = BL.pack (show res) } + -- Due to overlapping instances, we can't just use 'throwAll' to get a + -- @ServerT ... m@. Instead we first generate a very simple @ServerT api + -- (Either ServantErr)@ and hoist it to become @ServerT api m@. + -- + -- @Either ServantErr@ is the simplest type that is supported by 'throwAll' + -- and that can be converted into a @MonadError ServantErr m@. + nt :: Either ServantErr a -> m a + nt = either throwError pure + +---------------------------------------------------------------------------- +-- Server-starting utilities type App m api = ( SCIMHandler m - , HasServer api '[] + , HasServer api '[JWTSettings, CookieSettings, BasicAuthCfg] + , EnterBoilerplate m #if !MIN_VERSION_servant_server(0,12,0) , Enter (ServerT api m) m Handler (Server api) #endif ) mkapp :: forall m api. (App m api) - => Proxy api -> ServerT api m -> (forall a. m a -> Handler a) -> Application -mkapp proxy api nt = serve proxy $ + => Proxy api -> ServerT api m -> (forall a. m a -> Handler a) -> IO Application +mkapp proxy api nt = do + jwtKey <- generateKey + authCfg <- either throw pure =<< runHandler (nt mkAuthChecker) + let jwtCfg = defaultJWTSettings jwtKey + cfg = jwtCfg :. defaultCookieSettings :. authCfg :. EmptyContext + pure $ serveWithContext proxy cfg $ #if MIN_VERSION_servant_server(0,12,0) - hoistServer proxy nt + hoistServerWithContext proxy (Proxy @[JWTSettings, CookieSettings, BasicAuthCfg]) nt api #else - enter (NT nt) + enter (NT nt) api #endif - api -app :: forall m. App m SiteAPI => Configuration -> (forall a. m a -> Handler a) -> Application +app :: forall m. App m SiteAPI => Configuration -> (forall a. m a -> Handler a) -> IO Application app c = mkapp (Proxy :: Proxy SiteAPI) (toServant $ siteServer c) diff --git a/src/Web/SCIM/Server/Mock.hs b/src/Web/SCIM/Server/Mock.hs index d7c3f4ea97e..bf5deb718bb 100644 --- a/src/Web/SCIM/Server/Mock.hs +++ b/src/Web/SCIM/Server/Mock.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE LambdaCase #-} -- | A mock server for use in our testsuite, as well as for automated -- compliance testing (e.g. with Runscope – see @@ -11,29 +12,33 @@ module Web.SCIM.Server.Mock where import Web.SCIM.Class.Group import Web.SCIM.Class.User +import Web.SCIM.Class.Auth import Control.Monad.STM import Control.Monad.Reader import Data.Text +import Data.Text.Encoding import Data.Time.Clock import Data.Time.Calendar import ListT -import qualified STMContainers.Map as Map -import STMContainers.Map (Map) +import qualified STMContainers.Map as STMMap import Web.SCIM.Schema.User import Web.SCIM.Schema.Meta import Web.SCIM.Schema.ListResponse import Web.SCIM.Schema.Common (WithId(WithId)) import qualified Web.SCIM.Schema.Common as Common -import Servant +import Servant hiding (BadPassword, NoSuchUser) +import Servant.Auth.Server import Prelude hiding (id) -type UserStorage = Map Text StoredUser -type GroupStorage = Map Text StoredGroup +type UserStorage = STMMap.Map Text StoredUser +type GroupStorage = STMMap.Map Text StoredGroup +type AdminStorage = STMMap.Map Text (Admin, Text) -- (Admin, Pass) data TestStorage = TestStorage { userDB :: UserStorage , groupDB :: GroupStorage + , authDB :: AdminStorage } -- in-memory implementation of the API for tests @@ -45,11 +50,11 @@ liftAtomic = liftIO . atomically instance UserDB TestServer where list = do m <- userDB <$> ask - l <- liftIO . atomically $ ListT.toList $ Map.stream m + l <- liftIO . atomically $ ListT.toList $ STMMap.stream m return $ fromList $ snd <$> l get i = do m <- userDB <$> ask - liftIO . atomically $ Map.lookup i m + liftIO . atomically $ STMMap.lookup i m create user = do m <- userDB <$> ask met <- getMeta @@ -67,11 +72,11 @@ instance UserDB TestServer where instance GroupDB TestServer where list = do m <- groupDB <$> ask - l <- liftIO . atomically $ ListT.toList $ Map.stream m + l <- liftIO . atomically $ ListT.toList $ STMMap.stream m return $ snd <$> l get i = do m <- groupDB <$> ask - liftIO . atomically $ Map.lookup i m + liftIO . atomically $ STMMap.lookup i m create = \grp -> do storage <- groupDB <$> ask met <- getGroupMeta @@ -85,34 +90,44 @@ instance GroupDB TestServer where liftIO . atomically $ delGroup gid m getGroupMeta = createMeta GroupResource +instance AuthDB TestServer where + mkAuthChecker = do + m <- authDB <$> ask + pure $ \(BasicAuthData login pass) -> + atomically (STMMap.lookup (decodeUtf8 login) m) >>= \case + Just (admin, adminPass) + | decodeUtf8 pass == adminPass -> pure (Authenticated admin) + | otherwise -> pure BadPassword + Nothing -> pure NoSuchUser + insertGroup :: Group -> Meta -> GroupStorage -> STM StoredGroup insertGroup grp met storage = do - size <- Map.size storage + size <- STMMap.size storage let gid = pack . show $ size newGroup = WithMeta met $ WithId gid grp - Map.insert newGroup gid storage + STMMap.insert newGroup gid storage return newGroup updateGroup :: GroupId -> Group -> GroupStorage -> STM (Either ServantErr StoredGroup) updateGroup gid grp storage = do - existing <- Map.lookup gid storage + existing <- STMMap.lookup gid storage case existing of Nothing -> pure $ Left err400 Just stored -> do let newMeta = meta stored newGroup = WithMeta newMeta $ WithId gid grp - Map.insert newGroup gid storage + STMMap.insert newGroup gid storage pure $ Right newGroup updateUser :: UserId -> User -> UserStorage -> STM (Either UpdateError StoredUser) updateUser uid user storage = do - existing <- Map.lookup uid storage + existing <- STMMap.lookup uid storage case existing of Nothing -> pure $ Left NonExisting Just stored -> do let newMeta = meta stored newUser = WithMeta newMeta $ WithId uid user - Map.insert newUser uid storage + STMMap.insert newUser uid storage pure $ Right newUser -- (there seems to be no readOnly fields in User) @@ -121,17 +136,17 @@ assertMutability _newUser _stored = True delGroup :: GroupId -> GroupStorage -> STM Bool delGroup gid storage = do - g <- Map.lookup gid storage + g <- STMMap.lookup gid storage case g of Nothing -> return False - Just _ -> Map.delete gid storage >> return True + Just _ -> STMMap.delete gid storage >> return True delUser :: UserId -> UserStorage -> STM Bool delUser uid storage = do - u <- Map.lookup uid storage + u <- STMMap.lookup uid storage case u of Nothing -> return False - Just _ -> Map.delete uid storage >> return True + Just _ -> STMMap.delete uid storage >> return True -- 2018-01-01 00:00 testDate :: UTCTime @@ -153,10 +168,10 @@ createMeta rType = return $ Meta -- insert with a simple incrementing integer id (good for testing) insertUser :: User -> Meta -> UserStorage -> STM StoredUser insertUser user met storage = do - size <- Map.size storage + size <- STMMap.size storage let uid = pack . show $ size newUser = WithMeta met $ WithId uid user - Map.insert newUser uid storage + STMMap.insert newUser uid storage return newUser -- Natural transformation from our transformer stack to the Servant diff --git a/stack.yaml b/stack.yaml index 9f394505d1b..bac72c45356 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,3 +2,8 @@ resolver: lts-10.3 packages: - . + +extra-deps: +- servant-auth-0.3.2.0 +- servant-auth-server-0.4.0.0 +- network-uri-static-0.1.0.0 diff --git a/test/Test/Capabilities/MetaSchemaSpec.hs b/test/Test/Capabilities/MetaSchemaSpec.hs index 50990c3a6e6..2cac596183a 100644 --- a/test/Test/Capabilities/MetaSchemaSpec.hs +++ b/test/Test/Capabilities/MetaSchemaSpec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} module Test.Capabilities.MetaSchemaSpec (spec) where @@ -13,6 +14,7 @@ import Data.Monoid import Data.Text (Text) import Data.Coerce import Web.SCIM.Capabilities.MetaSchema +import Web.SCIM.Server (ConfigAPI) import Network.Wai.Test (SResponse (..)) import Servant import Servant.Generic @@ -20,11 +22,8 @@ import Test.Hspec hiding (shouldSatisfy) import qualified Test.Hspec.Expectations as Expect import Test.Hspec.Wai hiding (post, put, patch) -server :: Proxy (ToServant (ConfigAPI AsApi)) -server = Proxy - app :: Application -app = serve server $ toServant $ configServer empty +app = serve (Proxy @ConfigAPI) $ toServant $ configServer empty shouldSatisfy :: (Show a, FromJSON a) => WaiSession SResponse -> (a -> Bool) -> WaiExpectation @@ -70,11 +69,10 @@ spec = with (pure app) $ do get "/ServiceProviderConfig" `shouldRespondWith` spConfig --- FIXME: missing some "supported" fields and URI should not be null +-- FIXME: missing some "supported" fields spConfig :: ResponseMatcher spConfig = [scim| -{"documentationUri":null, - "schemas":["urn:ietf:params:scim:schemas:core:2.0:User", +{"schemas":["urn:ietf:params:scim:schemas:core:2.0:User", "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig", "urn:ietf:params:scim:schemas:core:2.0:Group", "urn:ietf:params:scim:schemas:core:2.0:Schema", @@ -85,7 +83,14 @@ spConfig = [scim| "supported":false }, "patch":{"supported":false}, - "authenticationSchemes":[], + "authenticationSchemes":[ + {"type":"httpbasic", + "name":"HTTP Basic", + "description":"Authentication via the HTTP Basic standard", + "specUri":"https://tools.ietf.org/html/rfc7617", + "documentationUri":"https://en.wikipedia.org/wiki/Basic_access_authentication" + } + ], "changePassword":{"supported":false}, "sort":{"supported":false}, "filter":{"maxResults":0, diff --git a/test/Test/Class/AuthSpec.hs b/test/Test/Class/AuthSpec.hs new file mode 100644 index 00000000000..710f9840688 --- /dev/null +++ b/test/Test/Class/AuthSpec.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.Class.AuthSpec (spec) where + +import Web.SCIM.Server (app) +import Web.SCIM.Server.Mock +import Web.SCIM.Class.Auth (Admin (..)) +import Web.SCIM.Capabilities.MetaSchema (empty) +import Data.Text (Text) +import Data.Text.Encoding +import Data.Monoid +import Test.Hspec +import Test.Hspec.Wai hiding (post, put, patch) +import qualified Data.ByteString.Base64 as Base64 +import Network.HTTP.Types.Header +import Network.HTTP.Types.Method (methodGet) +import qualified STMContainers.Map as STMMap +import Control.Monad.STM + +storage :: IO TestStorage +storage = do + auth <- STMMap.newIO + atomically $ STMMap.insert (Admin "admin", "password") "admin" auth + TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> pure auth + +spec :: Spec +spec = beforeAll ((\s -> app empty (nt s)) =<< storage) $ do + describe "/ServiceProviderConfig" $ do + it "is accessible without authentication" $ do + get "/ServiceProviderConfig" `shouldRespondWith` 200 + + it "doesn't check auth credentials" $ do + request methodGet "/ServiceProviderConfig" [authHeader "foo" "bar"] "" + `shouldRespondWith` 200 + + describe "/Users" $ do + it "succeeds with authentication" $ do + request methodGet "/Users" [authHeader "admin" "password"] "" + `shouldRespondWith` 200 + + it "fails if the password is wrong" $ do + request methodGet "/Users" [authHeader "admin" "wrongpassword"] "" + `shouldRespondWith` 401 + + it "fails if the admin is not found" $ do + request methodGet "/Users" [authHeader "foo" "password"] "" + `shouldRespondWith` 401 + + it "fails if no authentication is provided" $ do + get "/Users" `shouldRespondWith` 401 + +authHeader :: Text -> Text -> Header +authHeader user pass = + (hAuthorization, "Basic " <> Base64.encode (encodeUtf8 user <> ":" <> encodeUtf8 pass)) diff --git a/test/Test/Class/GroupSpec.hs b/test/Test/Class/GroupSpec.hs index eba8bff5420..84301f0d2b2 100644 --- a/test/Test/Class/GroupSpec.hs +++ b/test/Test/Class/GroupSpec.hs @@ -10,22 +10,23 @@ import Test.Util import Network.Wai (Application) import Servant.Generic import Servant (Proxy(Proxy), Handler) -import Web.SCIM.Class.Group (GroupAPI, GroupDB, groupServer) -import Web.SCIM.Server (mkapp, App) +import Web.SCIM.Server (mkapp, App, GroupAPI, groupServer) import Web.SCIM.Server.Mock import Data.ByteString.Lazy (ByteString) import Test.Hspec hiding (shouldSatisfy) import Test.Hspec.Wai hiding (post, put, patch) -import qualified STMContainers.Map as Map +import qualified STMContainers.Map as STMMap -app :: (GroupDB m, App m GroupAPI) => (forall a. m a -> Handler a) -> Application +app :: App m GroupAPI => (forall a. m a -> Handler a) -> IO Application app = mkapp (Proxy :: Proxy GroupAPI) (toServant groupServer) +storage :: IO TestStorage +storage = TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> STMMap.newIO spec :: Spec -spec = beforeAll ((\s -> app (nt s)) <$> (TestStorage <$> Map.newIO <*> Map.newIO)) $ do - describe "GET & POST /" $ do +spec = beforeAll ((\s -> app (nt s)) =<< storage) $ do + describe "GET & POST /Groups" $ do it "responds with [] in empty environment" $ do get "/" `shouldRespondWith` [scim|[]|] @@ -33,7 +34,7 @@ spec = beforeAll ((\s -> app (nt s)) <$> (TestStorage <$> Map.newIO <*> Map.newI post "/" adminGroup `shouldRespondWith` 201 get "/" `shouldRespondWith` groups - describe "GET /:id" $ do + describe "GET /Groups/:id" $ do it "responds with 404 for unknown group" $ do get "/unknown" `shouldRespondWith` unknown @@ -41,14 +42,14 @@ spec = beforeAll ((\s -> app (nt s)) <$> (TestStorage <$> Map.newIO <*> Map.newI -- the test implementation stores users with uid [0,1..n-1] get "/0" `shouldRespondWith` admins - describe "PUT /:id" $ do + describe "PUT /Groups/:id" $ do it "adds member to existing group" $ do put "/0" adminUpdate0 `shouldRespondWith` updatedAdmins0 it "does not create new group" $ do put "/nonexisting" adminGroup `shouldRespondWith` 400 - describe "DELETE /:id" $ do + describe "DELETE /Groups/:id" $ do it "responds with 404 for unknown group" $ do delete "/Users/unknown" `shouldRespondWith` 404 diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index e536bf4eb2e..4fd32a3421f 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -1,52 +1,61 @@ +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE QuasiQuotes #-} module Test.Class.UserSpec (spec) where import Test.Util -import Web.SCIM.Capabilities.MetaSchema (empty) -import Web.SCIM.Server +import Web.SCIM.Server (mkapp, App, UserAPI, userServer) import Web.SCIM.Server.Mock import Test.Hspec import Test.Hspec.Wai hiding (post, put, patch) import Data.ByteString.Lazy (ByteString) -import qualified STMContainers.Map as Map +import Servant (Proxy(Proxy), Handler) +import Servant.Generic +import Network.Wai (Application) +import qualified STMContainers.Map as STMMap +app :: App m UserAPI => (forall a. m a -> Handler a) -> IO Application +app = mkapp (Proxy :: Proxy UserAPI) (toServant userServer) + +storage :: IO TestStorage +storage = TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> STMMap.newIO + spec :: Spec -spec = beforeAll ((\s -> app empty (nt s)) <$> (TestStorage <$> Map.newIO <*> Map.newIO)) $ do +spec = beforeAll ((\s -> app (nt s)) =<< storage) $ do describe "GET & POST /Users" $ do it "responds with [] in empty environment" $ do - get "/Users" `shouldRespondWith` emptyList + get "/" `shouldRespondWith` emptyList it "can insert then retrieve stored Users" $ do - post "/Users" newBarbara `shouldRespondWith` 201 - get "/Users" `shouldRespondWith` users + post "/" newBarbara `shouldRespondWith` 201 + get "/" `shouldRespondWith` users describe "GET /Users/:id" $ do it "responds with 404 for unknown user" $ do - get "/Users/unknown" `shouldRespondWith` unknown + get "/unknown" `shouldRespondWith` unknown it "retrieves stored user" $ do -- the test implementation stores users with uid [0,1..n-1] - get "/Users/0" `shouldRespondWith` barbara + get "/0" `shouldRespondWith` barbara describe "PUT /Users/:id" $ do it "updates mutable fields" $ do - put "/Users/0" barbUpdate0 `shouldRespondWith` updatedBarb0 + put "/0" barbUpdate0 `shouldRespondWith` updatedBarb0 it "does not create new user " $ do - put "/Users/nonexisting" newBarbara `shouldRespondWith` 400 + put "/nonexisting" newBarbara `shouldRespondWith` 400 describe "DELETE /Users/:id" $ do it "responds with 404 for unknown user" $ do - delete "/Users/unknown" `shouldRespondWith` 404 + delete "/unknown" `shouldRespondWith` 404 it "deletes a stored user" $ do - delete "/Users/0" `shouldRespondWith` 204 + delete "/0" `shouldRespondWith` 204 -- user should be gone - get "/Users/0" `shouldRespondWith` 404 - delete "/Users/0" `shouldRespondWith` 404 + get "/0" `shouldRespondWith` 404 + delete "/0" `shouldRespondWith` 404 newBarbara :: ByteString diff --git a/test/Test/Util.hs b/test/Test/Util.hs index 145b219089f..7c42165279c 100644 --- a/test/Test/Util.hs +++ b/test/Test/Util.hs @@ -90,7 +90,7 @@ newtype Field (s :: Symbol) a = Field a getField :: Field s a -> a getField (Field a) = a --- Copied from http://hackage.haskell.org/package/aeson-extra-0.4.1.1/docs/src/Data.Aeson.Extra.SingObject.html +-- Copied from https://hackage.haskell.org/package/aeson-extra-0.4.1.1/docs/src/Data.Aeson.Extra.SingObject.html instance (KnownSymbol s, FromJSON a) => FromJSON (Field s a) where parseJSON = withObject ("Field " <> show key) $ \obj -> case SMap.lookup key obj of From 5a402d302af725b98930ce17e4380cee18f9b429 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Mon, 10 Sep 2018 17:34:28 +0200 Subject: [PATCH 13/64] More Okta work (#10) * Use UUIDs * Add a comment * Add missing fields to 'ListResponse' * Serve a single user * Give the user an email * Resource types * Address comments --- package.yaml | 2 + server/Main.hs | 82 +++++++++++++++++++-- src/Web/SCIM/Capabilities/MetaSchema.hs | 12 ++- src/Web/SCIM/Class/Auth.hs | 6 +- src/Web/SCIM/Schema/AuthenticationScheme.hs | 26 ++++--- src/Web/SCIM/Schema/ListResponse.hs | 19 ++++- src/Web/SCIM/Schema/Meta.hs | 9 +-- src/Web/SCIM/Schema/ResourceType.hs | 52 +++++++++++++ src/Web/SCIM/Schema/User.hs | 29 +++++++- src/Web/SCIM/Server/Mock.hs | 18 +++-- src/Web/SCIM/Util.hs | 23 ++++++ test/Test/Capabilities/MetaSchemaSpec.hs | 20 +++++ test/Test/Class/AuthSpec.hs | 34 ++++++--- test/Test/Class/UserSpec.hs | 6 +- 14 files changed, 287 insertions(+), 51 deletions(-) create mode 100644 src/Web/SCIM/Schema/ResourceType.hs create mode 100644 src/Web/SCIM/Util.hs diff --git a/package.yaml b/package.yaml index c7dd8255d10..22d0035909f 100644 --- a/package.yaml +++ b/package.yaml @@ -46,6 +46,8 @@ dependencies: - http-types - stm-containers - http-media + - uuid + - template-haskell ghc-options: -Wall diff --git a/server/Main.hs b/server/Main.hs index 3773038c234..00f31e0d01d 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -1,17 +1,87 @@ +{-# LANGUAGE QuasiQuotes #-} + module Main where +import Web.SCIM.Util import Web.SCIM.Server import Web.SCIM.Server.Mock -import Web.SCIM.Class.Auth (Admin (..)) -import Web.SCIM.Capabilities.MetaSchema (empty) +import Web.SCIM.Schema.Meta hiding (meta) +import Web.SCIM.Schema.Common as Common +import Web.SCIM.Schema.ResourceType hiding (name) +import Web.SCIM.Schema.User as User +import Web.SCIM.Schema.User.Name +import Web.SCIM.Schema.User.Email as E +import Web.SCIM.Class.Auth +import Web.SCIM.Capabilities.MetaSchema as MetaSchema +import Data.Time import Network.Wai.Handler.Warp import qualified STMContainers.Map as STMMap import Control.Monad.STM (atomically) +import Data.UUID as UUID +import Text.Email.Validate main :: IO () main = do - auth <- STMMap.newIO - atomically $ STMMap.insert (Admin "admin", "password") "admin" auth - storage <- TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> pure auth - run 9000 =<< app empty (nt storage) + storage <- TestStorage <$> mkUserDB <*> STMMap.newIO <*> mkAuthDB + run 9000 =<< app MetaSchema.empty (nt storage) + +-- | Create a UserDB with a single user: +-- +-- @ +-- UserID: sample-user +-- @ +mkUserDB :: IO UserStorage +mkUserDB = do + db <- STMMap.newIO + now <- getCurrentTime + let meta = Meta + { resourceType = UserResource + , created = now + , lastModified = now + , version = Weak "0" -- we don't support etags + , location = Common.URI [relativeUri|/Users/sample-user|] + } + -- Note: Okta required at least one email, 'active', 'name.familyName', + -- and 'name.givenName'. We might want to be able to express these + -- constraints in code (and in the schema we serve) without turning this + -- library into something that is Okta-specific. + let email = Email + { E.typ = Just "work" + , E.value = maybe (error "couldn't parse email") EmailAddress2 + (emailAddress "elton@wire.com") + , E.primary = Nothing + } + let user = User.empty + { userName = "elton" + , name = Just Name + { formatted = Just "Elton John" + , familyName = Just "John" + , givenName = Just "Elton" + , middleName = Nothing + , honorificPrefix = Nothing + , honorificSuffix = Nothing + } + , active = Just True + , emails = Just [email] + } + atomically $ STMMap.insert (WithMeta meta (WithId "elton" user)) "elton" db + pure db + +-- | Create an AuthDB with a single admin: +-- +-- @ +-- UUID: 00000500-0000-0000-0000-000000000001 +-- pass: password +-- @ +-- +-- The authorization header for this admin (which you can regenerate by +-- following the logic in 'authHeader'): +-- +-- @Basic MDAwMDA1MDAtMDAwMC0wMDAwLTAwMDAtMDAwMDAwMDAwMDAxOnBhc3N3b3Jk@ +mkAuthDB :: IO AdminStorage +mkAuthDB = do + db <- STMMap.newIO + let uuid = UUID.fromWords 0x500 0 0 1 + atomically $ STMMap.insert (Admin uuid, "password") uuid db + pure db diff --git a/src/Web/SCIM/Capabilities/MetaSchema.hs b/src/Web/SCIM/Capabilities/MetaSchema.hs index 3600b8a4267..58c0dc7258a 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema.hs @@ -15,6 +15,7 @@ module Web.SCIM.Capabilities.MetaSchema ( import Web.SCIM.Schema.Schema import Web.SCIM.Schema.Common +import Web.SCIM.Schema.ResourceType hiding (schema) import Web.SCIM.Schema.AuthenticationScheme import Web.SCIM.Schema.ListResponse as ListResponse import Web.SCIM.Capabilities.MetaSchema.User @@ -69,7 +70,7 @@ data Configuration = Configuration , changePassword :: Supported () , sort :: Supported () , etag :: Supported () - , authenticationSchemes :: [AuthenticationScheme] + , authenticationSchemes :: [AuthenticationSchemeEncoding] } deriving (Show, Eq, Generic) instance ToJSON Configuration where @@ -90,7 +91,7 @@ empty = Configuration , changePassword = Supported False () , sort = Supported False () , etag = Supported False () - , authenticationSchemes = [AuthHttpBasic] + , authenticationSchemes = [authHttpBasicEncoding] } configServer :: MonadError ServantErr m => @@ -105,12 +106,15 @@ configServer config = ConfigSite , resourceSchema ] , schema = either throwError pure . note err404 . (getSchema <=< fromSchemaUri) - , resourceTypes = pure "" + , resourceTypes = pure $ + ListResponse.fromList [ usersResource + , groupsResource + ] } data ConfigSite route = ConfigSite { spConfig :: route :- "ServiceProviderConfig" :> Get '[SCIM] Configuration , getSchemas :: route :- "Schemas" :> Get '[SCIM] (ListResponse Value) , schema :: route :- "Schemas" :> Capture "id" Text :> Get '[SCIM] Value - , resourceTypes :: route :- "ResourceTypes" :> Get '[SCIM] Text + , resourceTypes :: route :- "ResourceTypes" :> Get '[SCIM] (ListResponse Resource) } deriving (Generic) diff --git a/src/Web/SCIM/Class/Auth.hs b/src/Web/SCIM/Class/Auth.hs index 18cf09034cf..655961312bb 100644 --- a/src/Web/SCIM/Class/Auth.hs +++ b/src/Web/SCIM/Class/Auth.hs @@ -8,13 +8,13 @@ module Web.SCIM.Class.Auth ) where import Data.Aeson -import Data.Text import GHC.Generics import Servant.Auth.Server +import Data.UUID -- | Someone who is allowed to provision users via SCIM. data Admin = Admin - { name :: Text -- TODO: change to UUID + { adminId :: UUID } deriving (Eq, Show, Read, Generic) instance ToJSON Admin @@ -24,7 +24,7 @@ instance FromJWT Admin -- | Unfortunately, we have to pass an "authentication callback" to Servant -- by instantiating a zero-argument type family. This can only be done once --- per application. +-- per application, which is not the best possible design. type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult Admin) instance FromBasicAuthData Admin where diff --git a/src/Web/SCIM/Schema/AuthenticationScheme.hs b/src/Web/SCIM/Schema/AuthenticationScheme.hs index ec6b30c33ed..98b23737d08 100644 --- a/src/Web/SCIM/Schema/AuthenticationScheme.hs +++ b/src/Web/SCIM/Schema/AuthenticationScheme.hs @@ -2,6 +2,8 @@ module Web.SCIM.Schema.AuthenticationScheme ( AuthenticationScheme(..) + , AuthenticationSchemeEncoding + , authHttpBasicEncoding ) where import Web.SCIM.Schema.Common @@ -11,6 +13,9 @@ import Data.Text import GHC.Generics import Network.URI.Static +---------------------------------------------------------------------------- +-- Types + -- | Possible authentication schemes. The specification defines the values -- "oauth", "oauth2", "oauthbearertoken", "httpbasic", and "httpdigest". data AuthenticationScheme @@ -44,12 +49,15 @@ instance ToJSON AuthenticationSchemeEncoding where toJSON = genericToJSON serializeOptions -- NB: "typ" will be converted to "type" thanks to 'serializeOptions' -instance ToJSON AuthenticationScheme where - toJSON AuthHttpBasic = toJSON AuthenticationSchemeEncoding - { typ = "httpbasic" - , name = "HTTP Basic" - , description = "Authentication via the HTTP Basic standard" - , specUri = Just $ URI [uri|https://tools.ietf.org/html/rfc7617|] - , documentationUri = Just $ URI [uri|https://en.wikipedia.org/wiki/Basic_access_authentication|] - } - toJSON x = error ("not implemented: toJSON " ++ show x) +---------------------------------------------------------------------------- +-- Scheme encodings + +-- | The description of the 'AuthHttpBasic' scheme. +authHttpBasicEncoding :: AuthenticationSchemeEncoding +authHttpBasicEncoding = AuthenticationSchemeEncoding + { typ = "httpbasic" + , name = "HTTP Basic" + , description = "Authentication via the HTTP Basic standard" + , specUri = Just $ URI [uri|https://tools.ietf.org/html/rfc7617|] + , documentationUri = Just $ URI [uri|https://en.wikipedia.org/wiki/Basic_access_authentication|] + } diff --git a/src/Web/SCIM/Schema/ListResponse.hs b/src/Web/SCIM/Schema/ListResponse.hs index 152e2699038..3b6df37b957 100644 --- a/src/Web/SCIM/Schema/ListResponse.hs +++ b/src/Web/SCIM/Schema/ListResponse.hs @@ -7,18 +7,33 @@ import GHC.Generics (Generic) import Web.SCIM.Schema.Common import Web.SCIM.Schema.Schema +-- | A "pagination" type used as a wrapper whenever a SCIM endpoint has to +-- return a list. +-- +-- Pagination is not actually supported anywhere in the code yet; whenever +-- there are several results we always return them all as one page, and we +-- don't support different values of 'startIndex'. +-- +-- FUTUREWORK: Support for pagination might be added once we have to handle +-- organizations with lots of users. data ListResponse a = ListResponse { schemas :: [Schema] , totalResults :: Int + , itemsPerPage :: Int + , startIndex :: Int , resources :: [a] } deriving (Show, Eq, Generic) fromList :: [a] -> ListResponse a fromList list = ListResponse { schemas = [ListResponse2_0] - , totalResults = length list + , totalResults = len + , itemsPerPage = len + , startIndex = 0 , resources = list } + where + len = length list instance FromJSON a => FromJSON (ListResponse a) where parseJSON = genericParseJSON parseOptions . jsonLower @@ -28,5 +43,7 @@ instance ToJSON a => ToJSON (ListResponse a) where object [ "Resources" .= resources , "schemas" .= schemas , "totalResults" .= totalResults + , "itemsPerPage" .= itemsPerPage + , "startIndex" .= startIndex ] diff --git a/src/Web/SCIM/Schema/Meta.hs b/src/Web/SCIM/Schema/Meta.hs index 1df201bc806..d0592ccfc85 100644 --- a/src/Web/SCIM/Schema/Meta.hs +++ b/src/Web/SCIM/Schema/Meta.hs @@ -6,18 +6,11 @@ import Prelude hiding (map) import Data.Text (Text) import Data.Aeson import Web.SCIM.Schema.Common +import Web.SCIM.Schema.ResourceType import GHC.Generics (Generic) import qualified Data.HashMap.Lazy as HML import Data.Time.Clock -data ResourceType = UserResource - | GroupResource - deriving (Eq, Show) - -instance ToJSON ResourceType where - toJSON UserResource = "User" - toJSON GroupResource = "Group" - data ETag = Weak Text | Strong Text deriving (Eq, Show) diff --git a/src/Web/SCIM/Schema/ResourceType.hs b/src/Web/SCIM/Schema/ResourceType.hs new file mode 100644 index 00000000000..9730ea75444 --- /dev/null +++ b/src/Web/SCIM/Schema/ResourceType.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Web.SCIM.Schema.ResourceType where + +import Prelude hiding (map) + +import Data.Text (Text) +import Data.Aeson + +import Web.SCIM.Util +import Web.SCIM.Schema.Common +import Web.SCIM.Schema.Schema (Schema(..)) + +import GHC.Generics (Generic) + +-- | Supported resource types. Each resource type also corresponds to an +-- endpoint, described by 'ResourceTypeEndpoint'. +data ResourceType + = UserResource + | GroupResource + deriving (Show, Eq) + +instance ToJSON ResourceType where + toJSON UserResource = "User" + toJSON GroupResource = "Group" + +-- | Definitions of endpoints, returned by @/ResourceTypes@. +data Resource = Resource + { name :: Text + , endpoint :: URI + , schema :: Schema + } deriving (Show, Eq, Generic) + +instance ToJSON Resource where + toJSON = genericToJSON serializeOptions + +---------------------------------------------------------------------------- +-- Available resource endpoints + +usersResource :: Resource +usersResource = Resource + { name = "User" + , endpoint = URI [relativeUri|/Users|] + , schema = User20 + } + +groupsResource :: Resource +groupsResource = Resource + { name = "Group" + , endpoint = URI [relativeUri|/Groups|] + , schema = Group20 + } diff --git a/src/Web/SCIM/Schema/User.hs b/src/Web/SCIM/Schema/User.hs index 51bb97db415..8f05f556da2 100644 --- a/src/Web/SCIM/Schema/User.hs +++ b/src/Web/SCIM/Schema/User.hs @@ -7,7 +7,7 @@ import Data.Text (Text) import Data.Aeson import Web.SCIM.Schema.Common -import Web.SCIM.Schema.Schema (Schema) +import Web.SCIM.Schema.Schema (Schema(..)) import Web.SCIM.Schema.User.Address (Address) import Web.SCIM.Schema.User.Certificate (Certificate) import Web.SCIM.Schema.User.Email (Email) @@ -20,7 +20,7 @@ import GHC.Generics (Generic) data User = User - { schemas :: [Schema] + { schemas :: [Schema] -- TODO: not sure it should be a part of this type , userName :: Text , externalId :: Maybe Text , name :: Maybe Name @@ -43,6 +43,31 @@ data User = User , x509Certificates :: Maybe [Certificate] } deriving (Show, Eq, Generic) +empty :: User +empty = User + { schemas = [User20] + , userName = "" + , externalId = Nothing + , name = Nothing + , displayName = Nothing + , nickName = Nothing + , profileUrl = Nothing + , title = Nothing + , userType = Nothing + , preferredLanguage = Nothing + , locale = Nothing + , active = Nothing + , password = Nothing + , emails = Nothing + , phoneNumbers = Nothing + , ims = Nothing + , photos = Nothing + , addresses = Nothing + , entitlements = Nothing + , roles = Nothing + , x509Certificates = Nothing + } + instance FromJSON User where parseJSON = genericParseJSON parseOptions . jsonLower diff --git a/src/Web/SCIM/Server/Mock.hs b/src/Web/SCIM/Server/Mock.hs index bf5deb718bb..a0a76032a31 100644 --- a/src/Web/SCIM/Server/Mock.hs +++ b/src/Web/SCIM/Server/Mock.hs @@ -24,16 +24,18 @@ import qualified STMContainers.Map as STMMap import Web.SCIM.Schema.User import Web.SCIM.Schema.Meta import Web.SCIM.Schema.ListResponse +import Web.SCIM.Schema.ResourceType import Web.SCIM.Schema.Common (WithId(WithId)) import qualified Web.SCIM.Schema.Common as Common import Servant hiding (BadPassword, NoSuchUser) import Servant.Auth.Server +import Data.UUID as UUID import Prelude hiding (id) type UserStorage = STMMap.Map Text StoredUser type GroupStorage = STMMap.Map Text StoredGroup -type AdminStorage = STMMap.Map Text (Admin, Text) -- (Admin, Pass) +type AdminStorage = STMMap.Map UUID (Admin, Text) -- (Admin, Pass) data TestStorage = TestStorage { userDB :: UserStorage @@ -94,11 +96,17 @@ instance AuthDB TestServer where mkAuthChecker = do m <- authDB <$> ask pure $ \(BasicAuthData login pass) -> - atomically (STMMap.lookup (decodeUtf8 login) m) >>= \case - Just (admin, adminPass) - | decodeUtf8 pass == adminPass -> pure (Authenticated admin) - | otherwise -> pure BadPassword + case UUID.fromASCIIBytes login of Nothing -> pure NoSuchUser + Just loginUuid -> atomically (STMMap.lookup loginUuid m) >>= \case + Just (admin, adminPass) + | decodeUtf8 pass == adminPass -> pure (Authenticated admin) + -- Note: somebody can figure out if whether the given user + -- exists, but since the admin users are represented with UUIDs + -- (which are pretty hard to bruteforce), it's okay. It also + -- makes debugging easier. + | otherwise -> pure BadPassword + Nothing -> pure NoSuchUser insertGroup :: Group -> Meta -> GroupStorage -> STM StoredGroup insertGroup grp met storage = do diff --git a/src/Web/SCIM/Util.hs b/src/Web/SCIM/Util.hs new file mode 100644 index 00000000000..7dba5ac1ffe --- /dev/null +++ b/src/Web/SCIM/Util.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | A utility module for the library. +module Web.SCIM.Util + ( relativeUri + ) where + +import Language.Haskell.TH.Quote +import Network.URI +import Network.URI.Static () -- for the Lift URI instance + +-- | A quasiquoter for parsing relative URIs at compile time, similar to 'uri'. +-- +-- PR pending: +relativeUri :: QuasiQuoter +relativeUri = QuasiQuoter + { quoteExp = \uri -> case parseRelativeReference uri of + Nothing -> fail ("Invalid URI: " ++ uri) + Just x -> [| x |] + , quotePat = error "relativeUri: quotePat not implemented" + , quoteType = error "relativeUri: quoteType not implemented" + , quoteDec = error "relativeUri: quoteDec not implemented" + } diff --git a/test/Test/Capabilities/MetaSchemaSpec.hs b/test/Test/Capabilities/MetaSchemaSpec.hs index 2cac596183a..546454bc0ca 100644 --- a/test/Test/Capabilities/MetaSchemaSpec.hs +++ b/test/Test/Capabilities/MetaSchemaSpec.hs @@ -68,6 +68,10 @@ spec = with (pure app) $ do it "returns configuration" $ do get "/ServiceProviderConfig" `shouldRespondWith` spConfig + describe "GET /ResourceTypes" $ do + it "returns resource types" $ do + get "/ResourceTypes" `shouldRespondWith` resourceTypes + -- FIXME: missing some "supported" fields spConfig :: ResponseMatcher @@ -98,3 +102,19 @@ spConfig = [scim| } } |] + +resourceTypes :: ResponseMatcher +resourceTypes = [scim| +{"schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], + "Resources":[ + {"schema":"urn:ietf:params:scim:schemas:core:2.0:User", + "name":"User", + "endpoint":"/Users"}, + {"schema":"urn:ietf:params:scim:schemas:core:2.0:Group", + "name":"Group", + "endpoint":"/Groups"}], + "totalResults":2, + "startIndex":0, + "itemsPerPage":2 +} +|] diff --git a/test/Test/Class/AuthSpec.hs b/test/Test/Class/AuthSpec.hs index 710f9840688..893f69f2a48 100644 --- a/test/Test/Class/AuthSpec.hs +++ b/test/Test/Class/AuthSpec.hs @@ -17,39 +17,49 @@ import Network.HTTP.Types.Header import Network.HTTP.Types.Method (methodGet) import qualified STMContainers.Map as STMMap import Control.Monad.STM +import Data.UUID as UUID +import Data.UUID.V4 as UUID -storage :: IO TestStorage -storage = do - auth <- STMMap.newIO - atomically $ STMMap.insert (Admin "admin", "password") "admin" auth - TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> pure auth +-- | A hardcoded UUID of an admin existing in the 'TestStorage'. +-- +-- @00000500-0000-0000-0000-000000000001@ +testAdminUUID :: UUID +testAdminUUID = UUID.fromWords 0x500 0 0 1 + +testStorage :: IO TestStorage +testStorage = do + authMap <- STMMap.newIO + atomically $ STMMap.insert (Admin testAdminUUID, "password") testAdminUUID authMap + TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> pure authMap spec :: Spec -spec = beforeAll ((\s -> app empty (nt s)) =<< storage) $ do +spec = beforeAll ((\s -> app empty (nt s)) =<< testStorage) $ do describe "/ServiceProviderConfig" $ do it "is accessible without authentication" $ do get "/ServiceProviderConfig" `shouldRespondWith` 200 it "doesn't check auth credentials" $ do - request methodGet "/ServiceProviderConfig" [authHeader "foo" "bar"] "" + randomAdmin <- liftIO UUID.nextRandom + request methodGet "/ServiceProviderConfig" [authHeader randomAdmin "wrongpassword"] "" `shouldRespondWith` 200 describe "/Users" $ do it "succeeds with authentication" $ do - request methodGet "/Users" [authHeader "admin" "password"] "" + request methodGet "/Users" [authHeader testAdminUUID "password"] "" `shouldRespondWith` 200 it "fails if the password is wrong" $ do - request methodGet "/Users" [authHeader "admin" "wrongpassword"] "" + request methodGet "/Users" [authHeader testAdminUUID "wrongpassword"] "" `shouldRespondWith` 401 it "fails if the admin is not found" $ do - request methodGet "/Users" [authHeader "foo" "password"] "" + randomAdminUUID <- liftIO UUID.nextRandom + request methodGet "/Users" [authHeader randomAdminUUID "password"] "" `shouldRespondWith` 401 it "fails if no authentication is provided" $ do get "/Users" `shouldRespondWith` 401 -authHeader :: Text -> Text -> Header +authHeader :: UUID -> Text -> Header authHeader user pass = - (hAuthorization, "Basic " <> Base64.encode (encodeUtf8 user <> ":" <> encodeUtf8 pass)) + (hAuthorization, "Basic " <> Base64.encode (toASCIIBytes user <> ":" <> encodeUtf8 pass)) diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index 4fd32a3421f..fe277990b25 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -95,6 +95,8 @@ users :: ResponseMatcher users = [scim| { "schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "totalResults": 1, + "itemsPerPage": 1, + "startIndex": 0, "Resources": [{ "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "userName":"bjensen", @@ -173,7 +175,9 @@ emptyList :: ResponseMatcher emptyList = [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "Resources":[], - "totalResults":0 + "totalResults":0, + "itemsPerPage":0, + "startIndex":0 }|] unknown :: ResponseMatcher From 3011a68ff8a02c82bfb2e649b14f8463cf9f85ff Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Fri, 14 Sep 2018 14:56:14 +0200 Subject: [PATCH 14/64] Pass the Okta compliance test (final PR!) (#11) * A module for filtering users * Integrate filtering into the mock implementation * Don't allow users with duplicate usernames * Overhaul error handling; fix comments --- package.yaml | 7 + src/Web/SCIM/Capabilities/MetaSchema.hs | 12 +- src/Web/SCIM/Class/Group.hs | 29 ++-- src/Web/SCIM/Class/User.hs | 54 +++---- src/Web/SCIM/ContentType.hs | 1 - src/Web/SCIM/Filter.hs | 172 +++++++++++++++++++++++ src/Web/SCIM/Schema/Error.hs | 163 ++++++++++++++------- src/Web/SCIM/Schema/ListResponse.hs | 5 +- src/Web/SCIM/Schema/Schema.hs | 11 +- src/Web/SCIM/Server.hs | 34 +++-- src/Web/SCIM/Server/Mock.hs | 82 ++++++----- test/Test/Capabilities/MetaSchemaSpec.hs | 15 +- test/Test/Class/GroupSpec.hs | 12 +- test/Test/Class/UserSpec.hs | 115 +++++++++++++-- 14 files changed, 548 insertions(+), 164 deletions(-) create mode 100644 src/Web/SCIM/Filter.hs diff --git a/package.yaml b/package.yaml index 22d0035909f..e9fd0d2b9f6 100644 --- a/package.yaml +++ b/package.yaml @@ -18,6 +18,8 @@ default-extensions: - FlexibleInstances - TypeSynonymInstances - DeriveGeneric + - LambdaCase + - TypeApplications extra-source-files: - README.md @@ -48,6 +50,11 @@ dependencies: - http-media - uuid - template-haskell + - scientific + - attoparsec + - microlens + - http-api-data + - exceptions ghc-options: -Wall diff --git a/src/Web/SCIM/Capabilities/MetaSchema.hs b/src/Web/SCIM/Capabilities/MetaSchema.hs index 58c0dc7258a..49882ea469f 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema.hs @@ -15,17 +15,17 @@ module Web.SCIM.Capabilities.MetaSchema ( import Web.SCIM.Schema.Schema import Web.SCIM.Schema.Common +import Web.SCIM.Schema.Error hiding (schemas) import Web.SCIM.Schema.ResourceType hiding (schema) import Web.SCIM.Schema.AuthenticationScheme -import Web.SCIM.Schema.ListResponse as ListResponse +import Web.SCIM.Schema.ListResponse as ListResponse hiding (schemas) import Web.SCIM.Capabilities.MetaSchema.User import Web.SCIM.Capabilities.MetaSchema.SPConfig import Web.SCIM.Capabilities.MetaSchema.Group import Web.SCIM.Capabilities.MetaSchema.Schema import Web.SCIM.Capabilities.MetaSchema.ResourceType import Web.SCIM.ContentType -import Control.Monad.Except -import Control.Error.Util (note) +import Control.Monad.Catch import Data.Aeson import qualified Data.HashMap.Lazy as HML import Data.Text (Text) @@ -94,7 +94,7 @@ empty = Configuration , authenticationSchemes = [authHttpBasicEncoding] } -configServer :: MonadError ServantErr m => +configServer :: MonadThrow m => Configuration -> ConfigSite (AsServerT m) configServer config = ConfigSite { spConfig = pure config @@ -105,7 +105,9 @@ configServer config = ConfigSite , metaSchema , resourceSchema ] - , schema = either throwError pure . note err404 . (getSchema <=< fromSchemaUri) + , schema = \uri -> case getSchema =<< fromSchemaUri uri of + Nothing -> throwM (notFound "Schema" uri) + Just s -> pure s , resourceTypes = pure $ ListResponse.fromList [ usersResource , groupsResource diff --git a/src/Web/SCIM/Class/Group.hs b/src/Web/SCIM/Class/Group.hs index d69f9398dbc..69431cd19a5 100644 --- a/src/Web/SCIM/Class/Group.hs +++ b/src/Web/SCIM/Class/Group.hs @@ -13,8 +13,8 @@ module Web.SCIM.Class.Group ( , groupServer ) where -import Control.Monad.Except -import Control.Error.Util (note) +import Control.Monad.Catch +import Control.Monad import Data.Text import Data.Aeson import GHC.Generics (Generic) @@ -25,8 +25,7 @@ import Web.SCIM.ContentType import Servant import Servant.Generic - -type GroupHandler m = (MonadError ServantErr m, GroupDB m) +type GroupHandler m = (MonadThrow m, GroupDB m) type GroupId = Text @@ -64,10 +63,8 @@ class GroupDB m where list :: m [StoredGroup] get :: GroupId -> m (Maybe StoredGroup) create :: Group -> m StoredGroup - update :: GroupId -> Group -> m (Either ServantErr StoredGroup) - -- ^ - -- TODO: should be UpdateError / - delete :: GroupId -> m Bool + update :: GroupId -> Group -> m StoredGroup + delete :: GroupId -> m Bool -- ^ Return 'False' if the group didn't exist getGroupMeta :: m Meta data GroupSite route = GroupSite @@ -90,22 +87,18 @@ groupServer = GroupSite { getGroups = list , getGroup = getGroup' , postGroup = create - , putGroup = putGroup' - , patchGroup = undefined + , putGroup = update + , patchGroup = error "PATCH /Groups: not implemented" , deleteGroup = deleteGroup' } getGroup' :: GroupHandler m => GroupId -> m StoredGroup getGroup' gid = do maybeGroup <- get gid - either throwError pure $ note (notFound gid) maybeGroup - -putGroup' :: GroupHandler m => GroupId -> Group -> m StoredGroup -putGroup' gid grp = do - updated <- update gid grp - either throwError pure updated + maybe (throwM (notFound "Group" gid)) pure maybeGroup deleteGroup' :: GroupHandler m => GroupId -> m NoContent deleteGroup' gid = do - deleted <- delete gid - if deleted then return NoContent else throwError err404 + deleted <- delete gid + unless deleted $ throwM (notFound "Group" gid) + pure NoContent diff --git a/src/Web/SCIM/Class/User.hs b/src/Web/SCIM/Class/User.hs index ec7fb6567dd..07554dec2ac 100644 --- a/src/Web/SCIM/Class/User.hs +++ b/src/Web/SCIM/Class/User.hs @@ -6,48 +6,44 @@ module Web.SCIM.Class.User ( UserDB (..) , StoredUser - , UpdateError (..) , UserSite (..) , userServer ) where import Control.Applicative ((<|>), Alternative) -import Control.Monad.Except -import Control.Error.Util (note) +import Control.Monad +import Control.Monad.Catch import Data.Text import GHC.Generics (Generic) import Web.SCIM.Schema.User hiding (schemas) import Web.SCIM.Schema.Meta import Web.SCIM.Schema.Common import Web.SCIM.Schema.Error -import Web.SCIM.Schema.ListResponse +import Web.SCIM.Schema.ListResponse hiding (schemas) +import Web.SCIM.Filter import Web.SCIM.ContentType import Servant import Servant.Generic -type UserHandler m = (MonadError ServantErr m, UserDB m) +type UserHandler m = (MonadThrow m, UserDB m) type StoredUser = WithMeta (WithId User) -data UpdateError = NonExisting - | Mutability - - -- TODO: parameterize UserId class UserDB m where - list :: m (ListResponse StoredUser) + list :: Maybe Filter -> m (ListResponse StoredUser) get :: UserId -> m (Maybe StoredUser) create :: User -> m StoredUser - update :: UserId -> User -> m (Either UpdateError StoredUser) + update :: UserId -> User -> m StoredUser patch :: UserId -> m StoredUser - delete :: UserId -> m Bool + delete :: UserId -> m Bool -- ^ Return 'False' if the group didn't exist getMeta :: m Meta data UserSite route = UserSite { getUsers :: route :- - Get '[SCIM] (ListResponse StoredUser) + QueryParam "filter" Filter :> Get '[SCIM] (ListResponse StoredUser) , getUser :: route :- Capture "id" Text :> Get '[SCIM] StoredUser , postUser :: route :- @@ -64,36 +60,44 @@ userServer :: UserHandler m => UserSite (AsServerT m) userServer = UserSite { getUsers = list , getUser = getUser' - , postUser = create + , postUser = postUser' , putUser = updateUser' , patchUser = patch , deleteUser = deleteUser' } +postUser' :: UserHandler m => User -> m StoredUser +postUser' user = do + -- Find users with the same username (case-insensitive) + -- + -- TODO: it might be worth it to let 'create' handle conflicts if it can + -- do it in one pass instead of two passes. Same applies to 'updateUser'' + -- and similar functions. + let filter_ = FilterAttrCompare AttrUserName OpEq (ValString (userName user)) + stored <- list (Just filter_) + when (totalResults stored > 0) $ + throwM conflict + create user updateUser' :: UserHandler m => UserId -> User -> m StoredUser updateUser' uid updatedUser = do - -- TODO: don't fetch here, let User.update do it stored <- get uid case stored of - Just (WithMeta _meta (WithId _ existing)) -> + Just (WithMeta _meta (WithId _ existing)) -> do let newUser = existing `overwriteWith` updatedUser - in do - t <- update uid newUser - case t of - Left _err -> throwError err400 - Right newStored -> pure newStored - Nothing -> throwError err400 + update uid newUser + Nothing -> throwM (notFound "User" uid) getUser' :: UserHandler m => UserId -> m StoredUser getUser' uid = do maybeUser <- get uid - either throwError pure $ note (notFound uid) maybeUser + maybe (throwM (notFound "User" uid)) pure maybeUser deleteUser' :: UserHandler m => UserId -> m NoContent deleteUser' uid = do - deleted <- delete uid - if deleted then return NoContent else throwError err404 + deleted <- delete uid + unless deleted $ throwM (notFound "User" uid) + pure NoContent overwriteWith :: User -> User -> User overwriteWith old new = old diff --git a/src/Web/SCIM/ContentType.hs b/src/Web/SCIM/ContentType.hs index d28bd0b71ef..62ce215c12a 100644 --- a/src/Web/SCIM/ContentType.hs +++ b/src/Web/SCIM/ContentType.hs @@ -1,5 +1,4 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -- | SCIM defines its own content type (application/scim+json). It's -- intended to be used for all requests and responses; see the first diff --git a/src/Web/SCIM/Filter.hs b/src/Web/SCIM/Filter.hs new file mode 100644 index 00000000000..a83d6ea7f9e --- /dev/null +++ b/src/Web/SCIM/Filter.hs @@ -0,0 +1,172 @@ +-- | A query might specify a filter that should be applied to the results +-- before returning them. This module implements a very limited subset of +-- the specification: . +-- +-- Supported: +-- +-- * All comparison operators (@eq@, @le@, etc) +-- * The @userName@ attribute +-- +-- Not supported: +-- +-- * The @pr@ operator +-- * Boolean operators +-- * Combined filters +-- * Fully qualified attribute names (schema prefixes, attribute paths) + +module Web.SCIM.Filter + ( Filter(..) + , parseFilter + , filterUser + + -- * Constructing filters + , CompValue(..) + , CompareOp(..) + , Attribute(..) + ) where + +import Data.Scientific +import Data.Text +import Data.Text.Encoding +import Data.Attoparsec.ByteString.Char8 +import Data.Aeson.Parser as Aeson +import Lens.Micro +import Web.HttpApiData + +import Web.SCIM.Schema.User + +---------------------------------------------------------------------------- +-- Types + +-- | A value type. Attributes are compared against literal values. +data CompValue + = ValNull + | ValBool Bool + | ValNumber Scientific + | ValString Text + deriving (Eq, Ord, Show) + +-- | A comparison operator. +data CompareOp + = OpEq -- ^ Equal + | OpNe -- ^ Not equal + | OpCo -- ^ Contains + | OpSw -- ^ Starts with + | OpEw -- ^ Ends with + | OpGt -- ^ Greater than + | OpGe -- ^ Greater than or equal to + | OpLt -- ^ Less than + | OpLe -- ^ Less than or equal to + deriving (Eq, Ord, Show) + +-- | An attribute (e.g. username). +-- +-- Only usernames are supported as attributes. Paths are not supported. +data Attribute + = AttrUserName + deriving (Eq, Ord, Show) + +-- | A filter. +-- +-- Our representation of filters is lax and doesn't attempt to ensure +-- validity on the type level. If a filter does something silly (e.g. tries +-- to compare a username with a boolean), it will be caught during filtering +-- and an appropriate error message will be thrown (see 'filterUser'). +data Filter + -- | Compare the attribute value with a literal + = FilterAttrCompare Attribute CompareOp CompValue + +---------------------------------------------------------------------------- +-- Parsing + +-- Note: this parser is written with Attoparsec because I don't know how to +-- lift an Attoparsec parser (from Aeson) to Megaparsec + +-- | Parse a filter. Spaces surrounding the filter will be stripped. +-- +-- If parsing fails, returns a 'Left' with an error description. +parseFilter :: Text -> Either Text Filter +parseFilter = + over _Left pack . + parseOnly (skipSpace *> pFilter <* skipSpace <* endOfInput) . + encodeUtf8 + +-- parser pieces + +-- | Value literal parser. +pCompValue :: Parser CompValue +pCompValue = choice + [ ValNull <$ string "null" + , ValBool True <$ string "true" + , ValBool False <$ string "false" + , ValNumber <$> Aeson.scientific + , ValString <$> Aeson.jstring + ] + +-- | Comparison operator parser. +pCompareOp :: Parser CompareOp +pCompareOp = choice + [ OpEq <$ stringCI "eq" + , OpNe <$ stringCI "ne" + , OpCo <$ stringCI "co" + , OpSw <$ stringCI "sw" + , OpEw <$ stringCI "ew" + , OpGt <$ stringCI "gt" + , OpGe <$ stringCI "ge" + , OpLt <$ stringCI "lt" + , OpLe <$ stringCI "le" + ] + +-- | Attribute name parser. +pAttribute :: Parser Attribute +pAttribute = choice + [ AttrUserName <$ stringCI "username" + ] + +-- | Filter parser. +pFilter :: Parser Filter +pFilter = choice + [ FilterAttrCompare + <$> pAttribute + <*> (skipSpace1 *> pCompareOp) + <*> (skipSpace1 *> pCompValue) + ] + +-- | Utility parser for skipping one or more spaces. +skipSpace1 :: Parser () +skipSpace1 = space *> skipSpace + +---------------------------------------------------------------------------- +-- Applying + +-- | Check whether a user satisfies the filter. +-- +-- Returns 'Left' if the filter is constructed incorrectly (e.g. tries to +-- compare a username with a boolean). +filterUser :: Filter -> User -> Either Text Bool +filterUser filter_ user = case filter_ of + FilterAttrCompare AttrUserName op (ValString str) -> + -- Comparing usernames has to be case-insensitive; look at the + -- 'caseExact' parameter of the user schema + Right (compareStr op (toCaseFold (userName user)) (toCaseFold str)) + FilterAttrCompare AttrUserName _ _ -> + Left "usernames can only be compared with strings" + +-- | Execute a comparison operator. +compareStr :: CompareOp -> Text -> Text -> Bool +compareStr = \case + OpEq -> (==) -- equal + OpNe -> (/=) -- not equal + OpCo -> flip isInfixOf -- A contains B + OpSw -> flip isPrefixOf -- A starts with B + OpEw -> flip isSuffixOf -- A ends with B + OpGt -> (>) -- greater than + OpGe -> (>=) -- greater than or equal to + OpLt -> (<) -- less than + OpLe -> (<=) -- less than or equal to + +---------------------------------------------------------------------------- +-- Instances + +instance FromHttpApiData Filter where + parseUrlPiece = parseFilter diff --git a/src/Web/SCIM/Schema/Error.hs b/src/Web/SCIM/Schema/Error.hs index 49204220718..4b4bc228f59 100644 --- a/src/Web/SCIM/Schema/Error.hs +++ b/src/Web/SCIM/Schema/Error.hs @@ -1,27 +1,47 @@ +-- | SCIM errors +module Web.SCIM.Schema.Error + ( + -- * Types + SCIMErrorType(..) + , SCIMError(..) + , Status(..) -module Web.SCIM.Schema.Error (notFound, fromErrorType) where + -- * Constructors + , notFound + , badRequest + , conflict + + -- * Servant interoperability + , scimToServantErr + ) where import Data.Text (Text, pack) import Data.Aeson hiding (Error) import Data.Monoid ((<>)) +import Control.Exception import Web.SCIM.Schema.Common -import Servant (ServantErr (..), err404, err400) +import Web.SCIM.Schema.Schema +import Servant (ServantErr (..)) import GHC.Generics (Generic) -data ErrorType = InvalidFilter - | TooMany - | Uniqueness - | Mutability - | InvalidSyntax - | InvalidPath - | NoTarget - | InvalidValue - | InvalidVers - | Sensitive +---------------------------------------------------------------------------- +-- Types + +data SCIMErrorType + = InvalidFilter + | TooMany + | Uniqueness + | Mutability + | InvalidSyntax + | InvalidPath + | NoTarget + | InvalidValue + | InvalidVers + | Sensitive deriving (Show, Eq, Generic) -instance ToJSON ErrorType where +instance ToJSON SCIMErrorType where toJSON InvalidFilter = "invalidFilter" toJSON TooMany = "tooMany" toJSON Uniqueness = "uniqueness" @@ -33,51 +53,96 @@ instance ToJSON ErrorType where toJSON InvalidVers = "invalidVers" toJSON Sensitive = "sensitive" - -fromErrorType :: ErrorType -> ServantErr -fromErrorType typ = - let body = Error - { schemas = [Error2_0] - , status = Status 400 - , scimType = pure typ - , detail = Nothing - } - in err400 { errBody = encode body - , errHeaders = [("Content-Type", "application/scim+json;charset=utf-8")] - } - -notFound :: Text -> ServantErr -notFound rid = - let body = Error - { schemas = [Error2_0] - , status = Status 404 - , scimType = Nothing - , detail = pure $ "Resource " <> rid <> " not found" - } - in err404 { errBody = encode body - , errHeaders = [("Content-Type", "application/scim+json;charset=utf-8")] - } - -- wrapped in a newtype because SCIM wants strings for status codes -newtype Status = Status Int +newtype Status = Status {unStatus :: Int} deriving (Show, Eq, Generic) instance ToJSON Status where toJSON (Status stat) = String . pack . show $ stat --- TODO: move to common schema datatype -data Schema = Error2_0 - deriving (Show, Eq) - -instance ToJSON Schema where - toJSON Error2_0 = String "urn:ietf:params:scim:api:messages:2.0:Error" - -data Error = Error +data SCIMError = SCIMError { schemas :: [Schema] , status :: Status - , scimType :: Maybe ErrorType + , scimType :: Maybe SCIMErrorType , detail :: Maybe Text } deriving (Show, Eq, Generic) -instance ToJSON Error where +instance ToJSON SCIMError where toJSON = genericToJSON serializeOptions + +instance Exception SCIMError + +---------------------------------------------------------------------------- +-- Constructors + +badRequest + :: SCIMErrorType -- ^ Error type + -> Maybe Text -- ^ Error details + -> SCIMError +badRequest typ mbDetail = + SCIMError + { schemas = [Error2_0] + , status = Status 400 + , scimType = pure typ + , detail = mbDetail + } + +notFound + :: Text -- ^ Resource type + -> Text -- ^ Resource ID + -> SCIMError +notFound resourceType resourceId = + SCIMError + { schemas = [Error2_0] + , status = Status 404 + , scimType = Nothing + , detail = pure $ resourceType <> " '" <> resourceId <> "' not found" + } + +conflict :: SCIMError +conflict = + SCIMError + { schemas = [Error2_0] + , status = Status 409 + , scimType = Just Uniqueness + , detail = Nothing + } + +---------------------------------------------------------------------------- +-- Servant + +-- | Convert a SCIM 'Error' to a Servant one by encoding it with the +-- appropriate headers. +scimToServantErr :: SCIMError -> ServantErr +scimToServantErr err = + ServantErr + { errHTTPCode = unStatus (status err) + , errReasonPhrase = reasonPhrase (status err) + , errBody = encode err + , errHeaders = [("Content-Type", "application/scim+json;charset=utf-8")] + } + +-- | A mapping of error code "reason phrases" (e.g. "Method Not Allowed") +-- for all 4xx errors. +reasonPhrase :: Status -> String +reasonPhrase = \case + Status 400 -> "Bad Request" + Status 401 -> "Unauthorized" + Status 402 -> "Payment Required" + Status 403 -> "Forbidden" + Status 404 -> "Not Found" + Status 405 -> "Method Not Allowed" + Status 406 -> "Not Acceptable" + Status 407 -> "Proxy Authentication Required" + Status 408 -> "Request Time-out" + Status 409 -> "Conflict" + Status 410 -> "Gone" + Status 411 -> "Length Required" + Status 412 -> "Precondition Failed" + Status 413 -> "Request Entity Too Large" + Status 414 -> "Request-URI Too Large" + Status 415 -> "Unsupported Media Type" + Status 416 -> "Range Not Satisfiable" + Status 417 -> "Expectation Failed" + Status 422 -> "Unprocessable Entity" + other -> show other diff --git a/src/Web/SCIM/Schema/ListResponse.hs b/src/Web/SCIM/Schema/ListResponse.hs index 3b6df37b957..312664303e9 100644 --- a/src/Web/SCIM/Schema/ListResponse.hs +++ b/src/Web/SCIM/Schema/ListResponse.hs @@ -1,6 +1,9 @@ {-# LANGUAGE RecordWildCards #-} -module Web.SCIM.Schema.ListResponse (ListResponse, fromList) where +module Web.SCIM.Schema.ListResponse + ( ListResponse(..) + , fromList + ) where import Data.Aeson import GHC.Generics (Generic) diff --git a/src/Web/SCIM/Schema/Schema.hs b/src/Web/SCIM/Schema/Schema.hs index f4af91f2044..72a58ad423d 100644 --- a/src/Web/SCIM/Schema/Schema.hs +++ b/src/Web/SCIM/Schema/Schema.hs @@ -17,6 +17,7 @@ data Schema = User20 | Schema20 | ResourceType20 | ListResponse2_0 + | Error2_0 deriving (Show, Eq) instance FromJSON Schema where @@ -41,6 +42,8 @@ getSchemaUri ResourceType20 = "urn:ietf:params:scim:schemas:core:2.0:ResourceType" getSchemaUri ListResponse2_0 = "urn:ietf:params:scim:api:messages:2.0:ListResponse" +getSchemaUri Error2_0 = + "urn:ietf:params:scim:api:messages:2.0:Error" -- | Get a schema by its URI. fromSchemaUri :: Text -> Maybe Schema @@ -57,6 +60,8 @@ fromSchemaUri s = case s of pure ResourceType20 "urn:ietf:params:scim:api:messages:2.0:ListResponse" -> pure ListResponse2_0 + "urn:ietf:params:scim:api:messages:2.0:Error" -> + pure Error2_0 _ -> Nothing @@ -72,6 +77,8 @@ getSchema Schema20 = pure metaSchema getSchema ResourceType20 = pure resourceSchema +-- Schemas for these types are not in the SCIM standard getSchema ListResponse2_0 = - Nothing -- it's possible that a schema for ListResponse exists, but I - -- haven't found it + Nothing +getSchema Error2_0 = + Nothing diff --git a/src/Web/SCIM/Server.hs b/src/Web/SCIM/Server.hs index c1305a42f67..327b564f879 100644 --- a/src/Web/SCIM/Server.hs +++ b/src/Web/SCIM/Server.hs @@ -4,7 +4,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Web.SCIM.Server @@ -22,9 +21,10 @@ import qualified Data.ByteString.Lazy.Char8 as BL import Web.SCIM.Class.User (UserSite (..), UserDB, userServer) import Web.SCIM.Class.Group (GroupSite (..), GroupDB, groupServer) import Web.SCIM.Class.Auth (Admin, AuthDB (..)) +import Web.SCIM.Schema.Error import Web.SCIM.Capabilities.MetaSchema (ConfigSite, Configuration, configServer) +import Control.Monad.Catch hiding (Handler) import Control.Monad.Except -import Control.Exception (throw) import GHC.Generics (Generic) import Network.Wai import Servant hiding (BasicAuth, NoSuchUser) @@ -38,7 +38,7 @@ import Servant.Utils.Enter ---------------------------------------------------------------------------- -- API specification -type SCIMHandler m = (MonadError ServantErr m, UserDB m, GroupDB m, AuthDB m) +type SCIMHandler m = (MonadThrow m, UserDB m, GroupDB m, AuthDB m) type ConfigAPI = ToServant (ConfigSite AsApi) type UserAPI = ToServant (UserSite AsApi) @@ -96,9 +96,9 @@ siteServer conf = Site -- (Either ServantErr)@ and hoist it to become @ServerT api m@. -- -- @Either ServantErr@ is the simplest type that is supported by 'throwAll' - -- and that can be converted into a @MonadError ServantErr m@. + -- and that can be converted into a @MonadThrow m@. nt :: Either ServantErr a -> m a - nt = either throwError pure + nt = either throwM pure ---------------------------------------------------------------------------- -- Server-starting utilities @@ -112,10 +112,15 @@ type App m api = ( SCIMHandler m ) mkapp :: forall m api. (App m api) - => Proxy api -> ServerT api m -> (forall a. m a -> Handler a) -> IO Application -mkapp proxy api nt = do + => Proxy api + -> ServerT api m + -> (forall a. m a -> IO a) -- Usually the transformation is "m a -> Handler a", + -- but in this library we give up on Servant's + -- 'MonadError' and just throw things via IO + -> IO Application +mkapp proxy api toIO = do jwtKey <- generateKey - authCfg <- either throw pure =<< runHandler (nt mkAuthChecker) + authCfg <- either throwM pure =<< runHandler (nt mkAuthChecker) let jwtCfg = defaultJWTSettings jwtKey cfg = jwtCfg :. defaultCookieSettings :. authCfg :. EmptyContext pure $ serveWithContext proxy cfg $ @@ -124,6 +129,15 @@ mkapp proxy api nt = do #else enter (NT nt) api #endif + where + -- Our handlers can throw two kinds of exceptions that we care about: + -- ServantErr and SCIMError. We catch both and rethrow them via ExceptT + -- (which is how Servant expects to get them). + nt :: forall a. m a -> Handler a + nt act = Handler $ ExceptT $ + fmap Right (toIO act) + `catch` (\(e :: SCIMError) -> pure (Left (scimToServantErr e))) + `catch` (\(e :: ServantErr) -> pure (Left e)) -app :: forall m. App m SiteAPI => Configuration -> (forall a. m a -> Handler a) -> IO Application -app c = mkapp (Proxy :: Proxy SiteAPI) (toServant $ siteServer c) +app :: forall m. App m SiteAPI => Configuration -> (forall a. m a -> IO a) -> IO Application +app c = mkapp (Proxy @SiteAPI) (toServant $ siteServer c) diff --git a/src/Web/SCIM/Server/Mock.hs b/src/Web/SCIM/Server/Mock.hs index a0a76032a31..4eb9ddd17f8 100644 --- a/src/Web/SCIM/Server/Mock.hs +++ b/src/Web/SCIM/Server/Mock.hs @@ -2,7 +2,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE LambdaCase #-} -- | A mock server for use in our testsuite, as well as for automated -- compliance testing (e.g. with Runscope – see @@ -10,23 +9,28 @@ module Web.SCIM.Server.Mock where -import Web.SCIM.Class.Group +import Web.SCIM.Class.Group hiding (value) import Web.SCIM.Class.User import Web.SCIM.Class.Auth -import Control.Monad.STM +import Control.Monad.STM (STM, atomically) import Control.Monad.Reader -import Data.Text +import Control.Monad.Catch (throwM) +import Data.Maybe +import Data.Text (Text, pack) import Data.Text.Encoding import Data.Time.Clock import Data.Time.Calendar +import GHC.Exts (sortWith) import ListT import qualified STMContainers.Map as STMMap import Web.SCIM.Schema.User +import Web.SCIM.Schema.Error import Web.SCIM.Schema.Meta import Web.SCIM.Schema.ListResponse import Web.SCIM.Schema.ResourceType -import Web.SCIM.Schema.Common (WithId(WithId)) +import Web.SCIM.Schema.Common (WithId(WithId, value)) import qualified Web.SCIM.Schema.Common as Common +import Web.SCIM.Filter import Servant hiding (BadPassword, NoSuchUser) import Servant.Auth.Server import Data.UUID as UUID @@ -44,53 +48,67 @@ data TestStorage = TestStorage } -- in-memory implementation of the API for tests -type TestServer = ReaderT TestStorage Handler +type TestServer = ReaderT TestStorage IO -liftAtomic :: STM a -> ReaderT TestStorage Handler a -liftAtomic = liftIO . atomically +liftSTM :: MonadIO m => STM a -> m a +liftSTM = liftIO . atomically instance UserDB TestServer where - list = do + list mbFilter = do + -- Note: in production instances it would make sense to remove this code + -- and let the implementor of the 'UserDB' instance do filtering (e.g. + -- doing case-insensitive queries on common attributes can be done + -- faster if the underlying database has indices). However, it might + -- still be useful to provide a default implementation in @hscim@ and + -- let users of the library decide whether they want to use it or not. m <- userDB <$> ask - l <- liftIO . atomically $ ListT.toList $ STMMap.stream m - return $ fromList $ snd <$> l + users <- liftSTM $ ListT.toList $ STMMap.stream m + let check user = case mbFilter of + Nothing -> pure True + Just filter_ -> do + let user' = value (thing user) -- unwrap + case filterUser filter_ user' of + Right res -> pure res + Left err -> throwM (badRequest InvalidFilter (Just err)) + fromList . sortWith (Common.id . thing) <$> + filterM check (snd <$> users) get i = do m <- userDB <$> ask - liftIO . atomically $ STMMap.lookup i m + liftSTM $ STMMap.lookup i m create user = do m <- userDB <$> ask met <- getMeta - newUser <- liftIO . atomically $ insertUser user met m + newUser <- liftSTM $ insertUser user met m return newUser update uid user = do storage <- userDB <$> ask - liftAtomic $ updateUser uid user storage + liftSTM $ updateUser uid user storage delete uid = do m <- userDB <$> ask - liftIO . atomically $ delUser uid m - getMeta = createMeta UserResource - patch = undefined + liftSTM $ delUser uid m + getMeta = return (createMeta UserResource) + patch = error "PATCH /Users: not implemented" instance GroupDB TestServer where list = do m <- groupDB <$> ask - l <- liftIO . atomically $ ListT.toList $ STMMap.stream m - return $ snd <$> l + groups <- liftSTM $ ListT.toList $ STMMap.stream m + return $ sortWith (Common.id . thing) $ snd <$> groups get i = do m <- groupDB <$> ask - liftIO . atomically $ STMMap.lookup i m + liftSTM $ STMMap.lookup i m create = \grp -> do storage <- groupDB <$> ask met <- getGroupMeta - newGroup <- liftIO . atomically $ insertGroup grp met storage + newGroup <- liftSTM $ insertGroup grp met storage pure newGroup update i g = do m <- groupDB <$> ask - liftAtomic $ updateGroup i g m + liftSTM $ updateGroup i g m delete gid = do m <- groupDB <$> ask - liftIO . atomically $ delGroup gid m - getGroupMeta = createMeta GroupResource + liftSTM $ delGroup gid m + getGroupMeta = return (createMeta GroupResource) instance AuthDB TestServer where mkAuthChecker = do @@ -116,27 +134,27 @@ insertGroup grp met storage = do STMMap.insert newGroup gid storage return newGroup -updateGroup :: GroupId -> Group -> GroupStorage -> STM (Either ServantErr StoredGroup) +updateGroup :: GroupId -> Group -> GroupStorage -> STM StoredGroup updateGroup gid grp storage = do existing <- STMMap.lookup gid storage case existing of - Nothing -> pure $ Left err400 + Nothing -> throwM (notFound "Group" gid) Just stored -> do let newMeta = meta stored newGroup = WithMeta newMeta $ WithId gid grp STMMap.insert newGroup gid storage - pure $ Right newGroup + pure newGroup -updateUser :: UserId -> User -> UserStorage -> STM (Either UpdateError StoredUser) +updateUser :: UserId -> User -> UserStorage -> STM StoredUser updateUser uid user storage = do existing <- STMMap.lookup uid storage case existing of - Nothing -> pure $ Left NonExisting + Nothing -> throwM (notFound "User" uid) Just stored -> do let newMeta = meta stored newUser = WithMeta newMeta $ WithId uid user STMMap.insert newUser uid storage - pure $ Right newUser + pure newUser -- (there seems to be no readOnly fields in User) assertMutability :: User -> StoredUser -> Bool @@ -164,8 +182,8 @@ testDate = UTCTime } -- static meta for testing -createMeta :: ResourceType -> ReaderT TestStorage Handler Meta -createMeta rType = return $ Meta +createMeta :: ResourceType -> Meta +createMeta rType = Meta { resourceType = rType , created = testDate , lastModified = testDate diff --git a/test/Test/Capabilities/MetaSchemaSpec.hs b/test/Test/Capabilities/MetaSchemaSpec.hs index 546454bc0ca..c09ffa1e15f 100644 --- a/test/Test/Capabilities/MetaSchemaSpec.hs +++ b/test/Test/Capabilities/MetaSchemaSpec.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} module Test.Capabilities.MetaSchemaSpec (spec) where @@ -14,16 +14,21 @@ import Data.Monoid import Data.Text (Text) import Data.Coerce import Web.SCIM.Capabilities.MetaSchema -import Web.SCIM.Server (ConfigAPI) +import Web.SCIM.Server (ConfigAPI, mkapp, App) +import Web.SCIM.Server.Mock import Network.Wai.Test (SResponse (..)) import Servant import Servant.Generic import Test.Hspec hiding (shouldSatisfy) import qualified Test.Hspec.Expectations as Expect import Test.Hspec.Wai hiding (post, put, patch) +import qualified STMContainers.Map as STMMap -app :: Application -app = serve (Proxy @ConfigAPI) $ toServant $ configServer empty +app :: App m ConfigAPI => (forall a. m a -> IO a) -> IO Application +app = mkapp (Proxy @ConfigAPI) (toServant (configServer empty)) + +storage :: IO TestStorage +storage = TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> STMMap.newIO shouldSatisfy :: (Show a, FromJSON a) => WaiSession SResponse -> (a -> Bool) -> WaiExpectation @@ -49,7 +54,7 @@ coreSchemas = ] spec :: Spec -spec = with (pure app) $ do +spec = beforeAll ((\s -> app (nt s)) =<< storage) $ do describe "GET /Schemas" $ do it "lists schemas" $ do get "/Schemas" `shouldRespondWith` 200 diff --git a/test/Test/Class/GroupSpec.hs b/test/Test/Class/GroupSpec.hs index 84301f0d2b2..e86e12663d0 100644 --- a/test/Test/Class/GroupSpec.hs +++ b/test/Test/Class/GroupSpec.hs @@ -9,7 +9,7 @@ import Test.Util import Network.Wai (Application) import Servant.Generic -import Servant (Proxy(Proxy), Handler) +import Servant (Proxy(Proxy)) import Web.SCIM.Server (mkapp, App, GroupAPI, groupServer) import Web.SCIM.Server.Mock import Data.ByteString.Lazy (ByteString) @@ -18,8 +18,8 @@ import Test.Hspec.Wai hiding (post, put, patch) import qualified STMContainers.Map as STMMap -app :: App m GroupAPI => (forall a. m a -> Handler a) -> IO Application -app = mkapp (Proxy :: Proxy GroupAPI) (toServant groupServer) +app :: App m GroupAPI => (forall a. m a -> IO a) -> IO Application +app = mkapp (Proxy @GroupAPI) (toServant groupServer) storage :: IO TestStorage storage = TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> STMMap.newIO @@ -47,7 +47,7 @@ spec = beforeAll ((\s -> app (nt s)) =<< storage) $ do put "/0" adminUpdate0 `shouldRespondWith` updatedAdmins0 it "does not create new group" $ do - put "/nonexisting" adminGroup `shouldRespondWith` 400 + put "/nonexisting" adminGroup `shouldRespondWith` 404 describe "DELETE /Groups/:id" $ do it "responds with 404 for unknown group" $ do @@ -55,7 +55,7 @@ spec = beforeAll ((\s -> app (nt s)) =<< storage) $ do it "deletes a stored group" $ do delete "/0" `shouldRespondWith` 204 - -- user should be gone + -- group should be gone get "/0" `shouldRespondWith` 404 delete "/0" `shouldRespondWith` 404 @@ -135,5 +135,5 @@ unknown :: ResponseMatcher unknown = [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:Error"], "status": "404", - "detail": "Resource unknown not found" + "detail": "Group 'unknown' not found" }|] { matchStatus = 404 } diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index fe277990b25..e39910ce71a 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -10,14 +10,14 @@ import Web.SCIM.Server.Mock import Test.Hspec import Test.Hspec.Wai hiding (post, put, patch) import Data.ByteString.Lazy (ByteString) -import Servant (Proxy(Proxy), Handler) +import Servant (Proxy(Proxy)) import Servant.Generic import Network.Wai (Application) import qualified STMContainers.Map as STMMap -app :: App m UserAPI => (forall a. m a -> Handler a) -> IO Application -app = mkapp (Proxy :: Proxy UserAPI) (toServant userServer) +app :: App m UserAPI => (forall a. m a -> IO a) -> IO Application +app = mkapp (Proxy @UserAPI) (toServant userServer) storage :: IO TestStorage storage = TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> STMMap.newIO @@ -30,7 +30,28 @@ spec = beforeAll ((\s -> app (nt s)) =<< storage) $ do it "can insert then retrieve stored Users" $ do post "/" newBarbara `shouldRespondWith` 201 - get "/" `shouldRespondWith` users + post "/" newJim `shouldRespondWith` 201 + get "/" `shouldRespondWith` allUsers + + it "doesn't allow duplicate usernames" $ do + post "/" newBarbara' `shouldRespondWith` conflict + + describe "filtering" $ do + it "can filter by username" $ do + get "/?filter=userName eq \"bjensen\"" `shouldRespondWith` onlyBarbara + + it "is case-insensitive regarding syntax" $ do + get "/?filter=USERName EQ \"bjensen\"" `shouldRespondWith` onlyBarbara + + it "is case-insensitive regarding usernames" $ do + get "/?filter=userName eq \"BJensen\"" `shouldRespondWith` onlyBarbara + + it "handles malformed filter syntax" $ do + get "/?filter=userName eqq \"bjensen\"" `shouldRespondWith` 400 + -- TODO: would be nice to check the error message as well + + it "handles type errors in comparisons" $ do + get "/?filter=userName eq true" `shouldRespondWith` 400 describe "GET /Users/:id" $ do it "responds with 404 for unknown user" $ do @@ -44,8 +65,8 @@ spec = beforeAll ((\s -> app (nt s)) =<< storage) $ do it "updates mutable fields" $ do put "/0" barbUpdate0 `shouldRespondWith` updatedBarb0 - it "does not create new user " $ do - put "/nonexisting" newBarbara `shouldRespondWith` 400 + it "does not create new user" $ do + put "/nonexisting" newBarbara `shouldRespondWith` 404 describe "DELETE /Users/:id" $ do it "responds with 404 for unknown user" $ do @@ -66,10 +87,34 @@ newBarbara = [scim| "name":{ "formatted":"Ms. Barbara J Jensen III", "familyName":"Jensen", - "givenName":"Barbara" + "givenName":"Barbara" + } + }|] + +-- Same as 'newBarbara', but with a different userName (the names only differ in case) +newBarbara' :: ByteString +newBarbara' = [scim| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "userName":"BJensen", + "externalId":"bjensen", + "name":{ + "formatted":"Ms. Barbara J Jensen III", + "familyName":"Jensen", + "givenName":"Barbara" } }|] +newJim :: ByteString +newJim = [scim| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "userName":"jim", + "externalId":"jim", + "name":{ + "formatted":"Jim", + "familyName":"", + "givenName":"Jim" + } + }|] barbara :: ResponseMatcher barbara = [scim| @@ -91,8 +136,51 @@ barbara = [scim| } }|] -users :: ResponseMatcher -users = [scim| +allUsers :: ResponseMatcher +allUsers = [scim| + { "schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], + "totalResults": 2, + "itemsPerPage": 2, + "startIndex": 0, + "Resources": + [{ "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "userName":"bjensen", + "externalId":"bjensen", + "id" : "0", + "name":{ + "formatted":"Ms. Barbara J Jensen III", + "familyName":"Jensen", + "givenName":"Barbara" + }, + "meta":{ + "resourceType":"User", + "location":"todo", + "created":"2018-01-01T00:00:00Z", + "version":"W/\"testVersion\"", + "lastModified":"2018-01-01T00:00:00Z" + } + }, + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "userName":"jim", + "externalId":"jim", + "id" : "1", + "name":{ + "formatted":"Jim", + "familyName":"", + "givenName":"Jim" + }, + "meta":{ + "resourceType":"User", + "location":"todo", + "created":"2018-01-01T00:00:00Z", + "version":"W/\"testVersion\"", + "lastModified":"2018-01-01T00:00:00Z" + } + }] + }|] + +onlyBarbara :: ResponseMatcher +onlyBarbara = [scim| { "schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "totalResults": 1, "itemsPerPage": 1, @@ -184,5 +272,12 @@ unknown :: ResponseMatcher unknown = [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:Error"], "status": "404", - "detail": "Resource unknown not found" + "detail": "User 'unknown' not found" }|] { matchStatus = 404 } + +conflict :: ResponseMatcher +conflict = [scim| + { "schemas": ["urn:ietf:params:scim:api:messages:2.0:Error"], + "scimType": "uniqueness", + "status": "409" + }|] { matchStatus = 409 } From a33b475721ba7359a7726bd7b48ed6b6b07acf85 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Wed, 17 Oct 2018 23:47:22 +0200 Subject: [PATCH 15/64] Simplify the implementation and make it ready to use in wire-server (#12) * Implement basic auth in a simpler way (without contexts etc) * Throw errors via ExceptT * Cleanup CCP switch for servant compatibility. (#13) * Throw authorization errors as 'SCIMError's * Move language extensions to package.yaml * Export siteServer * Add 'serverError' * Make 'decodeAuth' more informative * Remove TestStorage duplication * Add all the necessary instances for FromJSON StoredUser --- package.yaml | 20 ++- server/Main.hs | 2 +- src/Web/SCIM/Capabilities/MetaSchema.hs | 14 +- src/Web/SCIM/Class/Auth.hs | 69 +++++++--- src/Web/SCIM/Class/Group.hs | 39 +++--- src/Web/SCIM/Class/User.hs | 43 +++--- src/Web/SCIM/ContentType.hs | 2 - src/Web/SCIM/Handler.hs | 30 +++++ src/Web/SCIM/Schema/Common.hs | 4 + src/Web/SCIM/Schema/Error.hs | 43 +++++- src/Web/SCIM/Schema/Meta.hs | 26 +++- src/Web/SCIM/Schema/ResourceType.hs | 9 ++ src/Web/SCIM/Server.hs | 164 +++++++++++------------ src/Web/SCIM/Server/Mock.hs | 110 +++++++-------- test/Test/Capabilities/MetaSchemaSpec.hs | 18 +-- test/Test/Class/AuthSpec.hs | 3 +- test/Test/Class/GroupSpec.hs | 17 +-- test/Test/Class/UserSpec.hs | 15 +-- test/Test/Util.hs | 4 - 19 files changed, 365 insertions(+), 267 deletions(-) create mode 100644 src/Web/SCIM/Handler.hs diff --git a/package.yaml b/package.yaml index e9fd0d2b9f6..5689e4672af 100644 --- a/package.yaml +++ b/package.yaml @@ -13,13 +13,22 @@ build-type: Simple github: wireapp/hscim default-extensions: - - OverloadedStrings + - ConstraintKinds + - DataKinds + - DeriveFunctor + - DeriveGeneric - FlexibleContexts - FlexibleInstances - - TypeSynonymInstances - - DeriveGeneric + - KindSignatures - LambdaCase + - MultiParamTypeClasses + - OverloadedStrings + - RankNTypes + - ScopedTypeVariables - TypeApplications + - TypeFamilies + - TypeOperators + - TypeSynonymInstances extra-source-files: - README.md @@ -27,13 +36,12 @@ extra-source-files: dependencies: - base >= 4.7 && < 5 - bytestring + - base64-bytestring - aeson - aeson-qq - mtl - servant - servant-server - - servant-auth - - servant-auth-server - servant-generic - text - time @@ -54,7 +62,7 @@ dependencies: - attoparsec - microlens - http-api-data - - exceptions + - mmorph ghc-options: -Wall diff --git a/server/Main.hs b/server/Main.hs index 00f31e0d01d..af62e70d677 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -24,7 +24,7 @@ import Text.Email.Validate main :: IO () main = do storage <- TestStorage <$> mkUserDB <*> STMMap.newIO <*> mkAuthDB - run 9000 =<< app MetaSchema.empty (nt storage) + run 9000 (app MetaSchema.empty (nt storage)) -- | Create a UserDB with a single user: -- diff --git a/src/Web/SCIM/Capabilities/MetaSchema.hs b/src/Web/SCIM/Capabilities/MetaSchema.hs index 49882ea469f..e1b4be37894 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ConstraintKinds #-} - module Web.SCIM.Capabilities.MetaSchema ( ConfigSite , configServer @@ -25,7 +20,7 @@ import Web.SCIM.Capabilities.MetaSchema.Group import Web.SCIM.Capabilities.MetaSchema.Schema import Web.SCIM.Capabilities.MetaSchema.ResourceType import Web.SCIM.ContentType -import Control.Monad.Catch +import Web.SCIM.Handler import Data.Aeson import qualified Data.HashMap.Lazy as HML import Data.Text (Text) @@ -94,8 +89,9 @@ empty = Configuration , authenticationSchemes = [authHttpBasicEncoding] } -configServer :: MonadThrow m => - Configuration -> ConfigSite (AsServerT m) +configServer + :: Monad m + => Configuration -> ConfigSite (AsServerT (SCIMHandler m)) configServer config = ConfigSite { spConfig = pure config , getSchemas = pure $ @@ -106,7 +102,7 @@ configServer config = ConfigSite , resourceSchema ] , schema = \uri -> case getSchema =<< fromSchemaUri uri of - Nothing -> throwM (notFound "Schema" uri) + Nothing -> throwSCIM (notFound "Schema" uri) Just s -> pure s , resourceTypes = pure $ ListResponse.fromList [ usersResource diff --git a/src/Web/SCIM/Class/Auth.hs b/src/Web/SCIM/Class/Auth.hs index 655961312bb..b5978981ef8 100644 --- a/src/Web/SCIM/Class/Auth.hs +++ b/src/Web/SCIM/Class/Auth.hs @@ -1,16 +1,24 @@ -{-# LANGUAGE TypeFamilies #-} - --- | Basic HTTP authentication support. See See --- https://haskell-servant.readthedocs.io/en/stable/cookbook/jwt-and-basic-auth/JWTAndBasicAuth.html +-- | Basic HTTP authentication support. We roll our own mechanism instead of +-- doing 'BasicAuthCheck' because we don't want to muck with Servant +-- contexts. module Web.SCIM.Class.Auth ( Admin (..) , AuthDB (..) + , SCIMAuthData (..) ) where import Data.Aeson import GHC.Generics -import Servant.Auth.Server -import Data.UUID +import Servant +import Data.UUID as UUID +import Data.Char +import Control.Monad +import Data.Text.Encoding +import Web.SCIM.Handler +import Data.Text (Text) + +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Base64 as Base64 -- | Someone who is allowed to provision users via SCIM. data Admin = Admin @@ -18,24 +26,43 @@ data Admin = Admin } deriving (Eq, Show, Read, Generic) instance ToJSON Admin -instance ToJWT Admin instance FromJSON Admin -instance FromJWT Admin - --- | Unfortunately, we have to pass an "authentication callback" to Servant --- by instantiating a zero-argument type family. This can only be done once --- per application, which is not the best possible design. -type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult Admin) - -instance FromBasicAuthData Admin where - fromBasicAuthData auth check = check auth -- | An interface that has to be implemented for a server to provide -- authentication. class AuthDB m where - -- | Check whether a set of credentials (login and password) corresponds + -- | Check whether a set of credentials (UUID and password) corresponds -- to any 'Admin'. - -- - -- We can only do IO in 'fromBasicAuthData', so this has to return an IO - -- action. - mkAuthChecker :: m (BasicAuthData -> IO (AuthResult Admin)) + authCheck :: Maybe SCIMAuthData -> SCIMHandler m (BasicAuthResult Admin) + +---------------------------------------------------------------------------- +-- Auth header + +-- | Data contained in the basic auth header. +-- +-- TODO: parametrize with 'Admin' +data SCIMAuthData = SCIMAuthData + { scimAdmin :: UUID + , scimPassword :: BS.ByteString + } deriving (Eq, Show) + +-- | Decode a basic auth header. +decodeAuth :: BS.ByteString -> Either Text SCIMAuthData +decodeAuth ah = do + -- This code was copied from http://hackage.haskell.org/package/servant-server-0.14.1/docs/src/Servant.Server.Internal.BasicAuth.html#decodeBAHdr + let (b, rest) = BS.break isSpace ah + when (BS.map toLower b /= "basic") $ + Left "expected \"basic\"" + let decoded = Base64.decodeLenient (BS.dropWhile isSpace rest) + let (username, passWithColonAtHead) = BS.break (== ':') decoded + admin <- + maybe (Left "couldn't decode the username as UUID") Right $ + UUID.fromASCIIBytes username + (_, password) <- + maybe (Left "expected username:password, but ':' was not found") Right $ + BS.uncons passWithColonAtHead + return (SCIMAuthData admin password) + +instance FromHttpApiData SCIMAuthData where + parseUrlPiece = decodeAuth . encodeUtf8 + parseHeader = decodeAuth diff --git a/src/Web/SCIM/Class/Group.hs b/src/Web/SCIM/Class/Group.hs index 69431cd19a5..67bd29ed86d 100644 --- a/src/Web/SCIM/Class/Group.hs +++ b/src/Web/SCIM/Class/Group.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ConstraintKinds #-} - module Web.SCIM.Class.Group ( GroupSite (..) , GroupDB (..) @@ -13,7 +8,6 @@ module Web.SCIM.Class.Group ( , groupServer ) where -import Control.Monad.Catch import Control.Monad import Data.Text import Data.Aeson @@ -22,11 +16,10 @@ import Web.SCIM.Schema.Common import Web.SCIM.Schema.Error import Web.SCIM.Schema.Meta import Web.SCIM.ContentType +import Web.SCIM.Handler import Servant import Servant.Generic -type GroupHandler m = (MonadThrow m, GroupDB m) - type GroupId = Text type Schema = Text @@ -59,21 +52,21 @@ instance ToJSON Group where type StoredGroup = WithMeta (WithId Group) -class GroupDB m where - list :: m [StoredGroup] - get :: GroupId -> m (Maybe StoredGroup) - create :: Group -> m StoredGroup - update :: GroupId -> Group -> m StoredGroup - delete :: GroupId -> m Bool -- ^ Return 'False' if the group didn't exist - getGroupMeta :: m Meta +class Monad m => GroupDB m where + list :: SCIMHandler m [StoredGroup] + get :: GroupId -> SCIMHandler m (Maybe StoredGroup) + create :: Group -> SCIMHandler m StoredGroup + update :: GroupId -> Group -> SCIMHandler m StoredGroup + delete :: GroupId -> SCIMHandler m Bool -- ^ Return 'False' if the group didn't exist + getGroupMeta :: SCIMHandler m Meta data GroupSite route = GroupSite { getGroups :: route :- - Get '[SCIM] [StoredGroup] + Get '[SCIM] [StoredGroup] , getGroup :: route :- - Capture "id" Text :> Get '[SCIM] StoredGroup + Capture "id" Text :> Get '[SCIM] StoredGroup , postGroup :: route :- - ReqBody '[SCIM] Group :> PostCreated '[SCIM] StoredGroup + ReqBody '[SCIM] Group :> PostCreated '[SCIM] StoredGroup , putGroup :: route :- Capture "id" Text :> ReqBody '[SCIM] Group :> Put '[SCIM] StoredGroup , patchGroup :: route :- @@ -82,7 +75,7 @@ data GroupSite route = GroupSite Capture "id" Text :> DeleteNoContent '[SCIM] NoContent } deriving (Generic) -groupServer :: GroupHandler m => GroupSite (AsServerT m) +groupServer :: GroupDB m => GroupSite (AsServerT (SCIMHandler m)) groupServer = GroupSite { getGroups = list , getGroup = getGroup' @@ -92,13 +85,13 @@ groupServer = GroupSite , deleteGroup = deleteGroup' } -getGroup' :: GroupHandler m => GroupId -> m StoredGroup +getGroup' :: GroupDB m => GroupId -> SCIMHandler m StoredGroup getGroup' gid = do maybeGroup <- get gid - maybe (throwM (notFound "Group" gid)) pure maybeGroup + maybe (throwSCIM (notFound "Group" gid)) pure maybeGroup -deleteGroup' :: GroupHandler m => GroupId -> m NoContent +deleteGroup' :: GroupDB m => GroupId -> SCIMHandler m NoContent deleteGroup' gid = do deleted <- delete gid - unless deleted $ throwM (notFound "Group" gid) + unless deleted $ throwSCIM (notFound "Group" gid) pure NoContent diff --git a/src/Web/SCIM/Class/User.hs b/src/Web/SCIM/Class/User.hs index 07554dec2ac..52fc70b670a 100644 --- a/src/Web/SCIM/Class/User.hs +++ b/src/Web/SCIM/Class/User.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ConstraintKinds #-} - module Web.SCIM.Class.User ( UserDB (..) , StoredUser @@ -12,7 +7,6 @@ module Web.SCIM.Class.User import Control.Applicative ((<|>), Alternative) import Control.Monad -import Control.Monad.Catch import Data.Text import GHC.Generics (Generic) import Web.SCIM.Schema.User hiding (schemas) @@ -20,25 +14,24 @@ import Web.SCIM.Schema.Meta import Web.SCIM.Schema.Common import Web.SCIM.Schema.Error import Web.SCIM.Schema.ListResponse hiding (schemas) +import Web.SCIM.Handler import Web.SCIM.Filter import Web.SCIM.ContentType import Servant import Servant.Generic -type UserHandler m = (MonadThrow m, UserDB m) - type StoredUser = WithMeta (WithId User) -- TODO: parameterize UserId -class UserDB m where - list :: Maybe Filter -> m (ListResponse StoredUser) - get :: UserId -> m (Maybe StoredUser) - create :: User -> m StoredUser - update :: UserId -> User -> m StoredUser - patch :: UserId -> m StoredUser - delete :: UserId -> m Bool -- ^ Return 'False' if the group didn't exist - getMeta :: m Meta +class Monad m => UserDB m where + list :: Maybe Filter -> SCIMHandler m (ListResponse StoredUser) + get :: UserId -> SCIMHandler m (Maybe StoredUser) + create :: User -> SCIMHandler m StoredUser + update :: UserId -> User -> SCIMHandler m StoredUser + patch :: UserId -> SCIMHandler m StoredUser + delete :: UserId -> SCIMHandler m Bool -- ^ Return 'False' if the user didn't exist + getMeta :: SCIMHandler m Meta data UserSite route = UserSite @@ -56,7 +49,7 @@ data UserSite route = UserSite Capture "id" Text :> DeleteNoContent '[SCIM] NoContent } deriving (Generic) -userServer :: UserHandler m => UserSite (AsServerT m) +userServer :: UserDB m => UserSite (AsServerT (SCIMHandler m)) userServer = UserSite { getUsers = list , getUser = getUser' @@ -66,7 +59,7 @@ userServer = UserSite , deleteUser = deleteUser' } -postUser' :: UserHandler m => User -> m StoredUser +postUser' :: UserDB m => User -> SCIMHandler m StoredUser postUser' user = do -- Find users with the same username (case-insensitive) -- @@ -76,27 +69,27 @@ postUser' user = do let filter_ = FilterAttrCompare AttrUserName OpEq (ValString (userName user)) stored <- list (Just filter_) when (totalResults stored > 0) $ - throwM conflict + throwSCIM conflict create user -updateUser' :: UserHandler m => UserId -> User -> m StoredUser +updateUser' :: UserDB m => UserId -> User -> SCIMHandler m StoredUser updateUser' uid updatedUser = do stored <- get uid case stored of Just (WithMeta _meta (WithId _ existing)) -> do let newUser = existing `overwriteWith` updatedUser update uid newUser - Nothing -> throwM (notFound "User" uid) + Nothing -> throwSCIM (notFound "User" uid) -getUser' :: UserHandler m => UserId -> m StoredUser +getUser' :: UserDB m => UserId -> SCIMHandler m StoredUser getUser' uid = do maybeUser <- get uid - maybe (throwM (notFound "User" uid)) pure maybeUser + maybe (throwSCIM (notFound "User" uid)) pure maybeUser -deleteUser' :: UserHandler m => UserId -> m NoContent +deleteUser' :: UserDB m => UserId -> SCIMHandler m NoContent deleteUser' uid = do deleted <- delete uid - unless deleted $ throwM (notFound "User" uid) + unless deleted $ throwSCIM (notFound "User" uid) pure NoContent overwriteWith :: User -> User -> User diff --git a/src/Web/SCIM/ContentType.hs b/src/Web/SCIM/ContentType.hs index 62ce215c12a..6ca10f11b0b 100644 --- a/src/Web/SCIM/ContentType.hs +++ b/src/Web/SCIM/ContentType.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -- | SCIM defines its own content type (application/scim+json). It's -- intended to be used for all requests and responses; see the first -- paragraph in the SCIM specification at diff --git a/src/Web/SCIM/Handler.hs b/src/Web/SCIM/Handler.hs new file mode 100644 index 00000000000..855e6a860a8 --- /dev/null +++ b/src/Web/SCIM/Handler.hs @@ -0,0 +1,30 @@ +module Web.SCIM.Handler + ( SCIMHandler + , throwSCIM + , fromSCIMHandler + ) where + +import Control.Monad.Except +import Web.SCIM.Schema.Error + +-- | Handler type for SCIM. All errors will be thrown via 'ExceptT'. +type SCIMHandler m = ExceptT SCIMError m + +-- | Throw a 'SCIMError'. +throwSCIM :: Monad m => SCIMError -> SCIMHandler m a +throwSCIM = throwError + +-- | A natural transformation for Servant handlers. To use it, you need to +-- provide a way to throw errors in the underlying @m@ monad. +-- +-- We can't use something like 'MonadError' to throw errors in @m@ because +-- 'MonadError' allows only one type of errors per monad and @m@ might have +-- one already. +-- +-- You can either do something custom for 'SCIMError', or use +-- 'scimToServantErr'. +fromSCIMHandler + :: Monad m + => (forall a. SCIMError -> m a) + -> (forall a. SCIMHandler m a -> m a) +fromSCIMHandler fromError = either fromError pure <=< runExceptT diff --git a/src/Web/SCIM/Schema/Common.hs b/src/Web/SCIM/Schema/Common.hs index 59ef1417441..e5518e77845 100644 --- a/src/Web/SCIM/Schema/Common.hs +++ b/src/Web/SCIM/Schema/Common.hs @@ -20,6 +20,10 @@ instance (ToJSON a) => ToJSON (WithId a) where (Object o) -> Object (HML.insert "id" (String i) o) other -> other +instance (FromJSON a) => FromJSON (WithId a) where + parseJSON = withObject "WithId" $ \o -> + WithId <$> o .: "id" <*> parseJSON (Object o) + newtype URI = URI { unURI :: Network.URI } deriving (Show, Eq) diff --git a/src/Web/SCIM/Schema/Error.hs b/src/Web/SCIM/Schema/Error.hs index 4b4bc228f59..b1d23a52dae 100644 --- a/src/Web/SCIM/Schema/Error.hs +++ b/src/Web/SCIM/Schema/Error.hs @@ -10,6 +10,8 @@ module Web.SCIM.Schema.Error , notFound , badRequest , conflict + , unauthorized + , serverError -- * Servant interoperability , scimToServantErr @@ -22,12 +24,18 @@ import Control.Exception import Web.SCIM.Schema.Common import Web.SCIM.Schema.Schema import Servant (ServantErr (..)) +import Data.UUID (UUID) import GHC.Generics (Generic) ---------------------------------------------------------------------------- -- Types +-- | An ADT for error types in the SCIM specification. Not all possible SCIM +-- errors have a corresponding 'SCIMErrorType' (for instance, authorization +-- is not covered by this type). +-- +-- See data SCIMErrorType = InvalidFilter | TooMany @@ -108,6 +116,33 @@ conflict = , detail = Nothing } +unauthorized + :: Maybe UUID -- ^ Admin ID + -> Text -- ^ Error details + -> SCIMError +unauthorized mbAdmin details = + SCIMError + { schemas = [Error2_0] + , status = Status 401 + , scimType = Nothing + , detail = pure $ + "authorization failed: " <> details <> + case mbAdmin of + Nothing -> " (no authorization provided)" + Just admin -> " (admin ID: " <> pack (show admin) <> ")" + } + +serverError + :: Text -- ^ Error details + -> SCIMError +serverError details = + SCIMError + { schemas = [Error2_0] + , status = Status 500 + , scimType = Nothing + , detail = pure details + } + ---------------------------------------------------------------------------- -- Servant @@ -123,7 +158,7 @@ scimToServantErr err = } -- | A mapping of error code "reason phrases" (e.g. "Method Not Allowed") --- for all 4xx errors. +-- for all 4xx and 5xx errors. reasonPhrase :: Status -> String reasonPhrase = \case Status 400 -> "Bad Request" @@ -145,4 +180,10 @@ reasonPhrase = \case Status 416 -> "Range Not Satisfiable" Status 417 -> "Expectation Failed" Status 422 -> "Unprocessable Entity" + Status 500 -> "Internal Server Error" + Status 501 -> "Not Implemented" + Status 502 -> "Bad Gateway" + Status 503 -> "Service Unavailable" + Status 504 -> "Gateway Time-out" + Status 505 -> "HTTP Version not supported" other -> show other diff --git a/src/Web/SCIM/Schema/Meta.hs b/src/Web/SCIM/Schema/Meta.hs index d0592ccfc85..f20cb58e0c7 100644 --- a/src/Web/SCIM/Schema/Meta.hs +++ b/src/Web/SCIM/Schema/Meta.hs @@ -3,7 +3,10 @@ module Web.SCIM.Schema.Meta where import Prelude hiding (map) -import Data.Text (Text) +import Data.Text (Text, unpack, pack) +import qualified Data.Text as Text +import Text.Read (readEither) +import Data.Monoid ((<>)) import Data.Aeson import Web.SCIM.Schema.Common import Web.SCIM.Schema.ResourceType @@ -15,8 +18,18 @@ data ETag = Weak Text | Strong Text deriving (Eq, Show) instance ToJSON ETag where - toJSON (Weak tag) = String $ "W/\"" `mappend` tag `mappend` "\"" - toJSON (Strong tag) = String $ "\"" `mappend` tag `mappend` "\"" + toJSON (Weak tag) = String $ "W/" <> pack (show tag) + toJSON (Strong tag) = String $ pack (show tag) + +instance FromJSON ETag where + parseJSON = withText "ETag" $ \s -> + case Text.stripPrefix "W/" s of + Nothing -> Strong <$> unquote s + Just s' -> Weak <$> unquote s' + where + unquote s = case readEither (unpack s) of + Right x -> pure x + Left e -> fail ("couldn't unquote the string: " <> e) data Meta = Meta { resourceType :: ResourceType @@ -29,6 +42,9 @@ data Meta = Meta instance ToJSON Meta where toJSON = genericToJSON serializeOptions +instance FromJSON Meta where + parseJSON = genericParseJSON parseOptions . jsonLower + data WithMeta a = WithMeta { meta :: Meta , thing :: a @@ -38,3 +54,7 @@ instance (ToJSON a) => ToJSON (WithMeta a) where toJSON (WithMeta m v) = case toJSON v of (Object o) -> Object (HML.insert "meta" (toJSON m) o) other -> other + +instance (FromJSON a) => FromJSON (WithMeta a) where + parseJSON = withObject "WithMeta" $ \o -> + WithMeta <$> o .: "meta" <*> parseJSON (Object o) diff --git a/src/Web/SCIM/Schema/ResourceType.hs b/src/Web/SCIM/Schema/ResourceType.hs index 9730ea75444..7e17f8a9e0e 100644 --- a/src/Web/SCIM/Schema/ResourceType.hs +++ b/src/Web/SCIM/Schema/ResourceType.hs @@ -24,6 +24,12 @@ instance ToJSON ResourceType where toJSON UserResource = "User" toJSON GroupResource = "Group" +instance FromJSON ResourceType where + parseJSON = withText "ResourceType" $ \case + "User" -> pure UserResource + "Group" -> pure GroupResource + other -> fail ("unknown ResourceType: " ++ show other) + -- | Definitions of endpoints, returned by @/ResourceTypes@. data Resource = Resource { name :: Text @@ -34,6 +40,9 @@ data Resource = Resource instance ToJSON Resource where toJSON = genericToJSON serializeOptions +instance FromJSON Resource where + parseJSON = genericParseJSON parseOptions . jsonLower + ---------------------------------------------------------------------------- -- Available resource endpoints diff --git a/src/Web/SCIM/Server.hs b/src/Web/SCIM/Server.hs index 327b564f879..4859590def5 100644 --- a/src/Web/SCIM/Server.hs +++ b/src/Web/SCIM/Server.hs @@ -1,44 +1,40 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} module Web.SCIM.Server - ( app - , SiteAPI - , mkapp, App + ( + -- * WAI application + app, mkapp, App - -- * API subtrees, useful for tests + -- * API tree + , SiteAPI, siteServer + -- ** API subtrees, useful for tests , ConfigAPI, configServer , UserAPI, userServer , GroupAPI, groupServer ) where -import qualified Data.ByteString.Lazy.Char8 as BL import Web.SCIM.Class.User (UserSite (..), UserDB, userServer) import Web.SCIM.Class.Group (GroupSite (..), GroupDB, groupServer) -import Web.SCIM.Class.Auth (Admin, AuthDB (..)) -import Web.SCIM.Schema.Error +import Web.SCIM.Class.Auth (AuthDB (..), SCIMAuthData (..)) import Web.SCIM.Capabilities.MetaSchema (ConfigSite, Configuration, configServer) -import Control.Monad.Catch hiding (Handler) -import Control.Monad.Except +import Web.SCIM.Handler +import Web.SCIM.Schema.Error import GHC.Generics (Generic) +import Data.Text import Network.Wai -import Servant hiding (BasicAuth, NoSuchUser) -import Servant.Generic -import Servant.Auth -import Servant.Auth.Server -#if !MIN_VERSION_servant_server(0,12,0) +import Servant.Generic hiding (fromServant) +#if MIN_VERSION_servant_server(0,12,0) +import Servant hiding (hoistServer) +import qualified Servant +#else +import Servant import Servant.Utils.Enter #endif ---------------------------------------------------------------------------- -- API specification -type SCIMHandler m = (MonadThrow m, UserDB m, GroupDB m, AuthDB m) +type DB m = (UserDB m, GroupDB m, AuthDB m) type ConfigAPI = ToServant (ConfigSite AsApi) type UserAPI = ToServant (UserSite AsApi) @@ -49,95 +45,97 @@ data Site route = Site { config :: route :- ConfigAPI , users :: route :- - Auth '[BasicAuth] Admin :> + Header "Authorization" SCIMAuthData :> "Users" :> UserAPI , groups :: route :- - Auth '[BasicAuth] Admin :> + Header "Authorization" SCIMAuthData :> "Groups" :> GroupAPI } deriving (Generic) ---------------------------------------------------------------------------- --- API implementation +-- Compatibility + +-- TODO: this is horrible, let's switch to servant-server-0.12 as soon as possible. if that has +-- happened, simply remove the CPP language extension and clean up after the errors. --- TODO: this is horrible, let's switch to servant-server-0.12 as soon as possible #if MIN_VERSION_servant_server(0,12,0) type EnterBoilerplate m = ( Functor m ) -- `()` is parsed as a type #else type EnterBoilerplate m = - ( Enter (ServerT UserAPI (Either ServantErr)) (Either ServantErr) m (ServerT UserAPI m) - , Enter (ServerT GroupAPI (Either ServantErr)) (Either ServantErr) m (ServerT GroupAPI m) + ( Enter (ServerT UserAPI m) m m (ServerT UserAPI m) + , Enter (ServerT GroupAPI m) m m (ServerT GroupAPI m) ) #endif -siteServer :: - forall m. (SCIMHandler m, EnterBoilerplate m) => - Configuration -> Site (AsServerT m) -siteServer conf = Site - { config = toServant $ configServer conf - , users = \authResult -> case authResult of - Authenticated _ -> toServant userServer +type MoreEnterBoilerplate (m :: * -> *) api = #if MIN_VERSION_servant_server(0,12,0) - _ -> hoistServer (Proxy @UserAPI) nt (noAuth authResult) + () ~ () #else - _ -> enter (NT nt) (noAuth authResult) + Enter (ServerT api (SCIMHandler m)) (SCIMHandler m) Handler (Server api) #endif - , groups = \authResult -> case authResult of - Authenticated _ -> toServant groupServer + +hoistServer :: forall api (m :: * -> *) (n :: * -> *). + ( HasServer api '[] +#if !MIN_VERSION_servant_server(0,12,0) + , Enter (ServerT api m) m Handler (ServerT api Handler) + , Enter (ServerT api m) m n (ServerT api n) +#endif + ) => + Proxy api -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n #if MIN_VERSION_servant_server(0,12,0) - _ -> hoistServer (Proxy @GroupAPI) nt (noAuth authResult) +hoistServer = Servant.hoistServer #else - _ -> enter (NT nt) (noAuth authResult) +hoistServer _ nt = enter (NT nt) #endif + + +---------------------------------------------------------------------------- +-- API implementation + +siteServer :: + forall m. (DB m, EnterBoilerplate (SCIMHandler m)) => + Configuration -> Site (AsServerT (SCIMHandler m)) +siteServer conf = Site + { config = toServant $ configServer conf + , users = \auth -> + hoistServer (Proxy @UserAPI) (addAuth auth) (toServant userServer) + , groups = \auth -> + hoistServer (Proxy @GroupAPI) (addAuth auth) (toServant groupServer) } where - noAuth res = throwAll $ err401 { errBody = BL.pack (show res) } - -- Due to overlapping instances, we can't just use 'throwAll' to get a - -- @ServerT ... m@. Instead we first generate a very simple @ServerT api - -- (Either ServantErr)@ and hoist it to become @ServerT api m@. - -- - -- @Either ServantErr@ is the simplest type that is supported by 'throwAll' - -- and that can be converted into a @MonadThrow m@. - nt :: Either ServantErr a -> m a - nt = either throwM pure + -- Perform authentication in a handler. This function will be applied to + -- all leaves of the API. + addAuth :: forall a. Maybe SCIMAuthData + -> SCIMHandler m a + -> SCIMHandler m a + addAuth auth handler = do + authResult <- authCheck auth + case authResult of + Authorized _ -> handler + _ -> throwSCIM (unauthorized (scimAdmin <$> auth) + (pack (show authResult))) ---------------------------------------------------------------------------- -- Server-starting utilities -type App m api = ( SCIMHandler m - , HasServer api '[JWTSettings, CookieSettings, BasicAuthCfg] - , EnterBoilerplate m -#if !MIN_VERSION_servant_server(0,12,0) - , Enter (ServerT api m) m Handler (Server api) -#endif - ) +type App m api = + ( DB m + , HasServer api '[] + , EnterBoilerplate m + , MoreEnterBoilerplate m api + ) mkapp :: forall m api. (App m api) => Proxy api - -> ServerT api m - -> (forall a. m a -> IO a) -- Usually the transformation is "m a -> Handler a", - -- but in this library we give up on Servant's - -- 'MonadError' and just throw things via IO - -> IO Application -mkapp proxy api toIO = do - jwtKey <- generateKey - authCfg <- either throwM pure =<< runHandler (nt mkAuthChecker) - let jwtCfg = defaultJWTSettings jwtKey - cfg = jwtCfg :. defaultCookieSettings :. authCfg :. EmptyContext - pure $ serveWithContext proxy cfg $ -#if MIN_VERSION_servant_server(0,12,0) - hoistServerWithContext proxy (Proxy @[JWTSettings, CookieSettings, BasicAuthCfg]) nt api -#else - enter (NT nt) api -#endif - where - -- Our handlers can throw two kinds of exceptions that we care about: - -- ServantErr and SCIMError. We catch both and rethrow them via ExceptT - -- (which is how Servant expects to get them). - nt :: forall a. m a -> Handler a - nt act = Handler $ ExceptT $ - fmap Right (toIO act) - `catch` (\(e :: SCIMError) -> pure (Left (scimToServantErr e))) - `catch` (\(e :: ServantErr) -> pure (Left e)) - -app :: forall m. App m SiteAPI => Configuration -> (forall a. m a -> IO a) -> IO Application + -> ServerT api (SCIMHandler m) + -> (forall a. SCIMHandler m a -> Handler a) + -> Application +mkapp proxy api nt = + serve proxy $ + hoistServer proxy nt api + +app :: forall m. App m SiteAPI + => Configuration + -> (forall a. SCIMHandler m a -> Handler a) + -> Application app c = mkapp (Proxy @SiteAPI) (toServant $ siteServer c) diff --git a/src/Web/SCIM/Server/Mock.hs b/src/Web/SCIM/Server/Mock.hs index 4eb9ddd17f8..80952c2ded4 100644 --- a/src/Web/SCIM/Server/Mock.hs +++ b/src/Web/SCIM/Server/Mock.hs @@ -1,11 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -- | A mock server for use in our testsuite, as well as for automated -- compliance testing (e.g. with Runscope – see --- https://developer.okta.com/standards/SCIM/#step-2-test-your-scim-server). +-- ). module Web.SCIM.Server.Mock where @@ -14,8 +11,7 @@ import Web.SCIM.Class.User import Web.SCIM.Class.Auth import Control.Monad.STM (STM, atomically) import Control.Monad.Reader -import Control.Monad.Catch (throwM) -import Data.Maybe +import Control.Monad.Morph import Data.Text (Text, pack) import Data.Text.Encoding import Data.Time.Clock @@ -31,12 +27,10 @@ import Web.SCIM.Schema.ResourceType import Web.SCIM.Schema.Common (WithId(WithId, value)) import qualified Web.SCIM.Schema.Common as Common import Web.SCIM.Filter -import Servant hiding (BadPassword, NoSuchUser) -import Servant.Auth.Server +import Web.SCIM.Handler +import Servant import Data.UUID as UUID -import Prelude hiding (id) - type UserStorage = STMMap.Map Text StoredUser type GroupStorage = STMMap.Map Text StoredGroup type AdminStorage = STMMap.Map UUID (Admin, Text) -- (Admin, Pass) @@ -47,12 +41,19 @@ data TestStorage = TestStorage , authDB :: AdminStorage } +emptyTestStorage :: IO TestStorage +emptyTestStorage = + TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> STMMap.newIO + -- in-memory implementation of the API for tests -type TestServer = ReaderT TestStorage IO +type TestServer = ReaderT TestStorage Handler liftSTM :: MonadIO m => STM a -> m a liftSTM = liftIO . atomically +hoistSTM :: (MFunctor t, MonadIO m) => t STM a -> t m a +hoistSTM = hoist liftSTM + instance UserDB TestServer where list mbFilter = do -- Note: in production instances it would make sense to remove this code @@ -69,7 +70,7 @@ instance UserDB TestServer where let user' = value (thing user) -- unwrap case filterUser filter_ user' of Right res -> pure res - Left err -> throwM (badRequest InvalidFilter (Just err)) + Left err -> throwSCIM (badRequest InvalidFilter (Just err)) fromList . sortWith (Common.id . thing) <$> filterM check (snd <$> users) get i = do @@ -78,14 +79,14 @@ instance UserDB TestServer where create user = do m <- userDB <$> ask met <- getMeta - newUser <- liftSTM $ insertUser user met m + newUser <- hoistSTM $ insertUser user met m return newUser update uid user = do storage <- userDB <$> ask - liftSTM $ updateUser uid user storage + hoistSTM $ updateUser uid user storage delete uid = do m <- userDB <$> ask - liftSTM $ delUser uid m + hoistSTM $ delUser uid m getMeta = return (createMeta UserResource) patch = error "PATCH /Users: not implemented" @@ -100,79 +101,77 @@ instance GroupDB TestServer where create = \grp -> do storage <- groupDB <$> ask met <- getGroupMeta - newGroup <- liftSTM $ insertGroup grp met storage + newGroup <- hoistSTM $ insertGroup grp met storage pure newGroup update i g = do m <- groupDB <$> ask - liftSTM $ updateGroup i g m + hoistSTM $ updateGroup i g m delete gid = do m <- groupDB <$> ask - liftSTM $ delGroup gid m + hoistSTM $ delGroup gid m getGroupMeta = return (createMeta GroupResource) instance AuthDB TestServer where - mkAuthChecker = do + authCheck Nothing = pure Unauthorized + authCheck (Just (SCIMAuthData uuid pass)) = do m <- authDB <$> ask - pure $ \(BasicAuthData login pass) -> - case UUID.fromASCIIBytes login of + liftIO (atomically (STMMap.lookup uuid m)) >>= \case + Just (admin, adminPass) + | decodeUtf8 pass == adminPass -> pure (Authorized admin) + -- Note: somebody can figure out if whether the given user + -- exists, but since the admin users are represented with UUIDs + -- (which are pretty hard to bruteforce), it's okay. It also + -- makes debugging easier. + | otherwise -> pure BadPassword Nothing -> pure NoSuchUser - Just loginUuid -> atomically (STMMap.lookup loginUuid m) >>= \case - Just (admin, adminPass) - | decodeUtf8 pass == adminPass -> pure (Authenticated admin) - -- Note: somebody can figure out if whether the given user - -- exists, but since the admin users are represented with UUIDs - -- (which are pretty hard to bruteforce), it's okay. It also - -- makes debugging easier. - | otherwise -> pure BadPassword - Nothing -> pure NoSuchUser - -insertGroup :: Group -> Meta -> GroupStorage -> STM StoredGroup + +insertGroup :: Group -> Meta -> GroupStorage -> SCIMHandler STM StoredGroup insertGroup grp met storage = do - size <- STMMap.size storage + size <- lift $ STMMap.size storage let gid = pack . show $ size newGroup = WithMeta met $ WithId gid grp - STMMap.insert newGroup gid storage + lift $ STMMap.insert newGroup gid storage return newGroup -updateGroup :: GroupId -> Group -> GroupStorage -> STM StoredGroup +updateGroup :: GroupId -> Group -> GroupStorage -> SCIMHandler STM StoredGroup updateGroup gid grp storage = do - existing <- STMMap.lookup gid storage + existing <- lift $ STMMap.lookup gid storage case existing of - Nothing -> throwM (notFound "Group" gid) + Nothing -> throwSCIM (notFound "Group" gid) Just stored -> do let newMeta = meta stored newGroup = WithMeta newMeta $ WithId gid grp - STMMap.insert newGroup gid storage + lift $ STMMap.insert newGroup gid storage pure newGroup -updateUser :: UserId -> User -> UserStorage -> STM StoredUser +updateUser :: UserId -> User -> UserStorage -> SCIMHandler STM StoredUser updateUser uid user storage = do - existing <- STMMap.lookup uid storage + existing <- lift $ STMMap.lookup uid storage case existing of - Nothing -> throwM (notFound "User" uid) + Nothing -> throwSCIM (notFound "User" uid) Just stored -> do let newMeta = meta stored newUser = WithMeta newMeta $ WithId uid user - STMMap.insert newUser uid storage + lift $ STMMap.insert newUser uid storage pure newUser -- (there seems to be no readOnly fields in User) assertMutability :: User -> StoredUser -> Bool assertMutability _newUser _stored = True -delGroup :: GroupId -> GroupStorage -> STM Bool +delGroup :: GroupId -> GroupStorage -> SCIMHandler STM Bool delGroup gid storage = do - g <- STMMap.lookup gid storage + g <- lift $ STMMap.lookup gid storage case g of Nothing -> return False - Just _ -> STMMap.delete gid storage >> return True + Just _ -> lift $ STMMap.delete gid storage >> return True -delUser :: UserId -> UserStorage -> STM Bool +delUser :: UserId -> UserStorage -> SCIMHandler STM Bool delUser uid storage = do - u <- STMMap.lookup uid storage + u <- lift $ STMMap.lookup uid storage case u of Nothing -> return False - Just _ -> STMMap.delete uid storage >> return True + Just _ -> lift $ STMMap.delete uid storage >> return True -- 2018-01-01 00:00 testDate :: UTCTime @@ -192,16 +191,17 @@ createMeta rType = Meta } -- insert with a simple incrementing integer id (good for testing) -insertUser :: User -> Meta -> UserStorage -> STM StoredUser +insertUser :: User -> Meta -> UserStorage -> SCIMHandler STM StoredUser insertUser user met storage = do - size <- STMMap.size storage + size <- lift $ STMMap.size storage let uid = pack . show $ size newUser = WithMeta met $ WithId uid user - STMMap.insert newUser uid storage + lift $ STMMap.insert newUser uid storage return newUser --- Natural transformation from our transformer stack to the Servant --- stack +-- Natural transformation from our transformer stack to the Servant stack -- this takes the initial environment and returns the transformation -nt :: r -> ReaderT r m a -> m a -nt = flip runReaderT +nt :: TestStorage -> SCIMHandler TestServer a -> Handler a +nt storage = + flip runReaderT storage . + fromSCIMHandler (lift . throwError . scimToServantErr) diff --git a/test/Test/Capabilities/MetaSchemaSpec.hs b/test/Test/Capabilities/MetaSchemaSpec.hs index c09ffa1e15f..43b07b5acdc 100644 --- a/test/Test/Capabilities/MetaSchemaSpec.hs +++ b/test/Test/Capabilities/MetaSchemaSpec.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} module Test.Capabilities.MetaSchemaSpec (spec) where @@ -14,7 +10,7 @@ import Data.Monoid import Data.Text (Text) import Data.Coerce import Web.SCIM.Capabilities.MetaSchema -import Web.SCIM.Server (ConfigAPI, mkapp, App) +import Web.SCIM.Server (ConfigAPI, mkapp) import Web.SCIM.Server.Mock import Network.Wai.Test (SResponse (..)) import Servant @@ -22,13 +18,11 @@ import Servant.Generic import Test.Hspec hiding (shouldSatisfy) import qualified Test.Hspec.Expectations as Expect import Test.Hspec.Wai hiding (post, put, patch) -import qualified STMContainers.Map as STMMap -app :: App m ConfigAPI => (forall a. m a -> IO a) -> IO Application -app = mkapp (Proxy @ConfigAPI) (toServant (configServer empty)) - -storage :: IO TestStorage -storage = TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> STMMap.newIO +app :: IO Application +app = do + storage <- emptyTestStorage + pure $ mkapp (Proxy @ConfigAPI) (toServant (configServer empty)) (nt storage) shouldSatisfy :: (Show a, FromJSON a) => WaiSession SResponse -> (a -> Bool) -> WaiExpectation @@ -54,7 +48,7 @@ coreSchemas = ] spec :: Spec -spec = beforeAll ((\s -> app (nt s)) =<< storage) $ do +spec = beforeAll app $ do describe "GET /Schemas" $ do it "lists schemas" $ do get "/Schemas" `shouldRespondWith` 200 diff --git a/test/Test/Class/AuthSpec.hs b/test/Test/Class/AuthSpec.hs index 893f69f2a48..ce7b8520937 100644 --- a/test/Test/Class/AuthSpec.hs +++ b/test/Test/Class/AuthSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE QuasiQuotes #-} module Test.Class.AuthSpec (spec) where @@ -33,7 +32,7 @@ testStorage = do TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> pure authMap spec :: Spec -spec = beforeAll ((\s -> app empty (nt s)) =<< testStorage) $ do +spec = beforeAll ((\s -> app empty (nt s)) <$> testStorage) $ do describe "/ServiceProviderConfig" $ do it "is accessible without authentication" $ do get "/ServiceProviderConfig" `shouldRespondWith` 200 diff --git a/test/Test/Class/GroupSpec.hs b/test/Test/Class/GroupSpec.hs index e86e12663d0..265892994fe 100644 --- a/test/Test/Class/GroupSpec.hs +++ b/test/Test/Class/GroupSpec.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE QuasiQuotes #-} module Test.Class.GroupSpec (spec) where @@ -10,22 +7,20 @@ import Test.Util import Network.Wai (Application) import Servant.Generic import Servant (Proxy(Proxy)) -import Web.SCIM.Server (mkapp, App, GroupAPI, groupServer) +import Web.SCIM.Server (mkapp, GroupAPI, groupServer) import Web.SCIM.Server.Mock import Data.ByteString.Lazy (ByteString) import Test.Hspec hiding (shouldSatisfy) import Test.Hspec.Wai hiding (post, put, patch) -import qualified STMContainers.Map as STMMap -app :: App m GroupAPI => (forall a. m a -> IO a) -> IO Application -app = mkapp (Proxy @GroupAPI) (toServant groupServer) - -storage :: IO TestStorage -storage = TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> STMMap.newIO +app :: IO Application +app = do + storage <- emptyTestStorage + pure $ mkapp (Proxy @GroupAPI) (toServant groupServer) (nt storage) spec :: Spec -spec = beforeAll ((\s -> app (nt s)) =<< storage) $ do +spec = beforeAll app $ do describe "GET & POST /Groups" $ do it "responds with [] in empty environment" $ do get "/" `shouldRespondWith` [scim|[]|] diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index e39910ce71a..cd5b0f55a71 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE QuasiQuotes #-} module Test.Class.UserSpec (spec) where import Test.Util -import Web.SCIM.Server (mkapp, App, UserAPI, userServer) +import Web.SCIM.Server (mkapp, UserAPI, userServer) import Web.SCIM.Server.Mock import Test.Hspec import Test.Hspec.Wai hiding (post, put, patch) @@ -13,17 +12,15 @@ import Data.ByteString.Lazy (ByteString) import Servant (Proxy(Proxy)) import Servant.Generic import Network.Wai (Application) -import qualified STMContainers.Map as STMMap -app :: App m UserAPI => (forall a. m a -> IO a) -> IO Application -app = mkapp (Proxy @UserAPI) (toServant userServer) - -storage :: IO TestStorage -storage = TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> STMMap.newIO +app :: IO Application +app = do + storage <- emptyTestStorage + pure $ mkapp (Proxy @UserAPI) (toServant userServer) (nt storage) spec :: Spec -spec = beforeAll ((\s -> app (nt s)) =<< storage) $ do +spec = beforeAll app $ do describe "GET & POST /Users" $ do it "responds with [] in empty environment" $ do get "/" `shouldRespondWith` emptyList diff --git a/test/Test/Util.hs b/test/Test/Util.hs index 7c42165279c..9dbe484661f 100644 --- a/test/Test/Util.hs +++ b/test/Test/Util.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} module Test.Util ( -- * Making wai requests From b92140a0ee5209b24a25f0c4a222c69771283744 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Fri, 19 Oct 2018 12:56:45 +0200 Subject: [PATCH 16/64] Add 'renderFilter' (#14) * Add 'renderFilter' * Add a roundtrip test --- package.yaml | 2 ++ src/Web/SCIM/Filter.hs | 53 ++++++++++++++++++++++++++++++++++++++++- test/Test/FilterSpec.hs | 45 ++++++++++++++++++++++++++++++++++ 3 files changed, 99 insertions(+), 1 deletion(-) create mode 100644 test/Test/FilterSpec.hs diff --git a/package.yaml b/package.yaml index 5689e4672af..89cca12aa23 100644 --- a/package.yaml +++ b/package.yaml @@ -109,3 +109,5 @@ tests: - aeson-qq - wai-logger - base64-bytestring + - hedgehog + - hw-hspec-hedgehog diff --git a/src/Web/SCIM/Filter.hs b/src/Web/SCIM/Filter.hs index a83d6ea7f9e..11b15cabe2a 100644 --- a/src/Web/SCIM/Filter.hs +++ b/src/Web/SCIM/Filter.hs @@ -15,8 +15,13 @@ -- * Fully qualified attribute names (schema prefixes, attribute paths) module Web.SCIM.Filter - ( Filter(..) + ( + -- * Filter type + Filter(..) , parseFilter + , renderFilter + + -- * Filtering logic , filterUser -- * Constructing filters @@ -28,8 +33,12 @@ module Web.SCIM.Filter import Data.Scientific import Data.Text import Data.Text.Encoding +import Data.Text.Lazy (toStrict) import Data.Attoparsec.ByteString.Char8 import Data.Aeson.Parser as Aeson +import Data.Aeson.Text as Aeson +import Data.Aeson as Aeson +import Data.Monoid import Lens.Micro import Web.HttpApiData @@ -38,6 +47,8 @@ import Web.SCIM.Schema.User ---------------------------------------------------------------------------- -- Types +-- NB: when extending these types, don't forget to update Test.FilterSpec + -- | A value type. Attributes are compared against literal values. data CompValue = ValNull @@ -75,6 +86,7 @@ data Attribute data Filter -- | Compare the attribute value with a literal = FilterAttrCompare Attribute CompareOp CompValue + deriving (Eq, Show) ---------------------------------------------------------------------------- -- Parsing @@ -136,6 +148,42 @@ pFilter = choice skipSpace1 :: Parser () skipSpace1 = space *> skipSpace +---------------------------------------------------------------------------- +-- Rendering + +-- | Render a filter according to the SCIM spec. +renderFilter :: Filter -> Text +renderFilter filter_ = case filter_ of + FilterAttrCompare attr op val -> + rAttribute attr <> " " <> rCompareOp op <> " " <> rCompValue val + +-- | Value literal renderer. +rCompValue :: CompValue -> Text +rCompValue = \case + ValNull -> "null" + ValBool True -> "true" + ValBool False -> "false" + ValNumber n -> toStrict $ Aeson.encodeToLazyText (Aeson.Number n) + ValString s -> toStrict $ Aeson.encodeToLazyText (Aeson.String s) + +-- | Comparison operator renderer. +rCompareOp :: CompareOp -> Text +rCompareOp = \case + OpEq -> "eq" + OpNe -> "ne" + OpCo -> "co" + OpSw -> "sw" + OpEw -> "ew" + OpGt -> "gt" + OpGe -> "ge" + OpLt -> "lt" + OpLe -> "le" + +-- | Attribute name renderer. +rAttribute :: Attribute -> Text +rAttribute = \case + AttrUserName -> "username" + ---------------------------------------------------------------------------- -- Applying @@ -170,3 +218,6 @@ compareStr = \case instance FromHttpApiData Filter where parseUrlPiece = parseFilter + +instance ToHttpApiData Filter where + toUrlPiece = renderFilter diff --git a/test/Test/FilterSpec.hs b/test/Test/FilterSpec.hs new file mode 100644 index 00000000000..62d53d2c053 --- /dev/null +++ b/test/Test/FilterSpec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Test.FilterSpec (spec) where + +import Web.SCIM.Filter + +import Test.Hspec +import HaskellWorks.Hspec.Hedgehog +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +spec :: Spec +spec = do + context "parsing:" $ do + it "parse . render === id" $ require $ property $ do + filter_ <- forAll genFilter + parseFilter (renderFilter filter_) === Right filter_ + +---------------------------------------------------------------------------- +-- Generators + +genCompValue :: Gen CompValue +genCompValue = Gen.choice + [ pure ValNull + , ValBool <$> Gen.bool + , ValNumber <$> Gen.choice + [ Gen.realFrac_ (Range.constantFrom 0 (-100) 100) + , fromInteger <$> Gen.integral (Range.constantFrom 0 (-100) 100) + ] + , ValString <$> Gen.text (Range.constant 0 1000) Gen.unicode + ] + +genCompareOp :: Gen CompareOp +genCompareOp = Gen.element + [ OpEq, OpNe, OpCo, OpSw, OpEw, OpGt, OpGe, OpLt, OpLe ] + +genAttribute :: Gen Attribute +genAttribute = Gen.element + [ AttrUserName ] + +genFilter :: Gen Filter +genFilter = Gen.choice + [ FilterAttrCompare <$> genAttribute <*> genCompareOp <*> genCompValue + ] From ff3f87db947fb6c6ae18592a4304288716b714e4 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Mon, 22 Oct 2018 14:42:52 +0200 Subject: [PATCH 17/64] Use newer network-uri-static (#15) --- package.yaml | 2 +- server/Main.hs | 4 ++-- src/Web/SCIM/Schema/ResourceType.hs | 6 +++--- src/Web/SCIM/Util.hs | 23 ----------------------- stack.yaml | 2 +- 5 files changed, 7 insertions(+), 30 deletions(-) delete mode 100644 src/Web/SCIM/Util.hs diff --git a/package.yaml b/package.yaml index 89cca12aa23..c3db25afa2c 100644 --- a/package.yaml +++ b/package.yaml @@ -47,7 +47,7 @@ dependencies: - time - wai - network-uri - - network-uri-static + - network-uri-static >= 0.1.1.0 - unordered-containers - email-validate - errors diff --git a/server/Main.hs b/server/Main.hs index af62e70d677..6f26144f849 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -2,7 +2,6 @@ module Main where -import Web.SCIM.Util import Web.SCIM.Server import Web.SCIM.Server.Mock import Web.SCIM.Schema.Meta hiding (meta) @@ -16,6 +15,7 @@ import Web.SCIM.Capabilities.MetaSchema as MetaSchema import Data.Time import Network.Wai.Handler.Warp +import Network.URI.Static import qualified STMContainers.Map as STMMap import Control.Monad.STM (atomically) import Data.UUID as UUID @@ -40,7 +40,7 @@ mkUserDB = do , created = now , lastModified = now , version = Weak "0" -- we don't support etags - , location = Common.URI [relativeUri|/Users/sample-user|] + , location = Common.URI [relativeReference|/Users/sample-user|] } -- Note: Okta required at least one email, 'active', 'name.familyName', -- and 'name.givenName'. We might want to be able to express these diff --git a/src/Web/SCIM/Schema/ResourceType.hs b/src/Web/SCIM/Schema/ResourceType.hs index 7e17f8a9e0e..c791fe2753e 100644 --- a/src/Web/SCIM/Schema/ResourceType.hs +++ b/src/Web/SCIM/Schema/ResourceType.hs @@ -6,8 +6,8 @@ import Prelude hiding (map) import Data.Text (Text) import Data.Aeson +import Network.URI.Static -import Web.SCIM.Util import Web.SCIM.Schema.Common import Web.SCIM.Schema.Schema (Schema(..)) @@ -49,13 +49,13 @@ instance FromJSON Resource where usersResource :: Resource usersResource = Resource { name = "User" - , endpoint = URI [relativeUri|/Users|] + , endpoint = URI [relativeReference|/Users|] , schema = User20 } groupsResource :: Resource groupsResource = Resource { name = "Group" - , endpoint = URI [relativeUri|/Groups|] + , endpoint = URI [relativeReference|/Groups|] , schema = Group20 } diff --git a/src/Web/SCIM/Util.hs b/src/Web/SCIM/Util.hs deleted file mode 100644 index 7dba5ac1ffe..00000000000 --- a/src/Web/SCIM/Util.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | A utility module for the library. -module Web.SCIM.Util - ( relativeUri - ) where - -import Language.Haskell.TH.Quote -import Network.URI -import Network.URI.Static () -- for the Lift URI instance - --- | A quasiquoter for parsing relative URIs at compile time, similar to 'uri'. --- --- PR pending: -relativeUri :: QuasiQuoter -relativeUri = QuasiQuoter - { quoteExp = \uri -> case parseRelativeReference uri of - Nothing -> fail ("Invalid URI: " ++ uri) - Just x -> [| x |] - , quotePat = error "relativeUri: quotePat not implemented" - , quoteType = error "relativeUri: quoteType not implemented" - , quoteDec = error "relativeUri: quoteDec not implemented" - } diff --git a/stack.yaml b/stack.yaml index bac72c45356..bbbfc7c1742 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,4 +6,4 @@ packages: extra-deps: - servant-auth-0.3.2.0 - servant-auth-server-0.4.0.0 -- network-uri-static-0.1.0.0 +- network-uri-static-0.1.1.0 From b56b4c533e04ea5d77f6b93cd4ef6a8d19e5d0f0 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Thu, 8 Nov 2018 14:14:44 +0100 Subject: [PATCH 18/64] Remove compatibility with servant-server < 0.12 (#17) --- .travis.yml | 1 - package.yaml | 2 +- src/Web/SCIM/Server.hs | 49 +----------------------------------------- stack.yaml | 2 +- 4 files changed, 3 insertions(+), 51 deletions(-) diff --git a/.travis.yml b/.travis.yml index 989488d2be9..f8249245069 100644 --- a/.travis.yml +++ b/.travis.yml @@ -13,7 +13,6 @@ addons: - libgmp-dev env: -- RESOLVER=lts-10.3 - RESOLVER=lts-11.13 before_install: diff --git a/package.yaml b/package.yaml index c3db25afa2c..fe13e39d478 100644 --- a/package.yaml +++ b/package.yaml @@ -41,7 +41,7 @@ dependencies: - aeson-qq - mtl - servant - - servant-server + - servant-server >= 0.12 - servant-generic - text - time diff --git a/src/Web/SCIM/Server.hs b/src/Web/SCIM/Server.hs index 4859590def5..f7c3233ee74 100644 --- a/src/Web/SCIM/Server.hs +++ b/src/Web/SCIM/Server.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - module Web.SCIM.Server ( -- * WAI application @@ -23,13 +21,7 @@ import GHC.Generics (Generic) import Data.Text import Network.Wai import Servant.Generic hiding (fromServant) -#if MIN_VERSION_servant_server(0,12,0) -import Servant hiding (hoistServer) -import qualified Servant -#else import Servant -import Servant.Utils.Enter -#endif ---------------------------------------------------------------------------- -- API specification @@ -52,48 +44,11 @@ data Site route = Site "Groups" :> GroupAPI } deriving (Generic) ----------------------------------------------------------------------------- --- Compatibility - --- TODO: this is horrible, let's switch to servant-server-0.12 as soon as possible. if that has --- happened, simply remove the CPP language extension and clean up after the errors. - -#if MIN_VERSION_servant_server(0,12,0) -type EnterBoilerplate m = ( Functor m ) -- `()` is parsed as a type -#else -type EnterBoilerplate m = - ( Enter (ServerT UserAPI m) m m (ServerT UserAPI m) - , Enter (ServerT GroupAPI m) m m (ServerT GroupAPI m) - ) -#endif - -type MoreEnterBoilerplate (m :: * -> *) api = -#if MIN_VERSION_servant_server(0,12,0) - () ~ () -#else - Enter (ServerT api (SCIMHandler m)) (SCIMHandler m) Handler (Server api) -#endif - -hoistServer :: forall api (m :: * -> *) (n :: * -> *). - ( HasServer api '[] -#if !MIN_VERSION_servant_server(0,12,0) - , Enter (ServerT api m) m Handler (ServerT api Handler) - , Enter (ServerT api m) m n (ServerT api n) -#endif - ) => - Proxy api -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n -#if MIN_VERSION_servant_server(0,12,0) -hoistServer = Servant.hoistServer -#else -hoistServer _ nt = enter (NT nt) -#endif - - ---------------------------------------------------------------------------- -- API implementation siteServer :: - forall m. (DB m, EnterBoilerplate (SCIMHandler m)) => + forall m. DB m => Configuration -> Site (AsServerT (SCIMHandler m)) siteServer conf = Site { config = toServant $ configServer conf @@ -121,8 +76,6 @@ siteServer conf = Site type App m api = ( DB m , HasServer api '[] - , EnterBoilerplate m - , MoreEnterBoilerplate m api ) mkapp :: forall m api. (App m api) diff --git a/stack.yaml b/stack.yaml index bbbfc7c1742..8a963df916c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-10.3 +resolver: lts-11.13 packages: - . From 9bcf39b182257e0c3d213e8cf330869718e6b871 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Fri, 9 Nov 2018 16:13:20 +0100 Subject: [PATCH 19/64] Redo authentication (#18) --- package.yaml | 2 - server/Main.hs | 22 +------- src/Web/SCIM/Class/Auth.hs | 83 ++++++++------------------- src/Web/SCIM/Class/Group.hs | 86 +++++++++++++++++++++------- src/Web/SCIM/Class/User.hs | 106 +++++++++++++++++++++++------------ src/Web/SCIM/Schema/Error.hs | 12 +--- src/Web/SCIM/Server.hs | 41 +++++--------- src/Web/SCIM/Server/Mock.hs | 52 +++++++---------- test/Test/Class/AuthSpec.hs | 36 +++--------- test/Test/Class/GroupSpec.hs | 3 +- test/Test/Class/UserSpec.hs | 3 +- 11 files changed, 207 insertions(+), 239 deletions(-) diff --git a/package.yaml b/package.yaml index fe13e39d478..b1f13d618e9 100644 --- a/package.yaml +++ b/package.yaml @@ -36,7 +36,6 @@ extra-source-files: dependencies: - base >= 4.7 && < 5 - bytestring - - base64-bytestring - aeson - aeson-qq - mtl @@ -108,6 +107,5 @@ tests: - template-haskell - aeson-qq - wai-logger - - base64-bytestring - hedgehog - hw-hspec-hedgehog diff --git a/server/Main.hs b/server/Main.hs index 6f26144f849..03021e79b25 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -10,7 +10,6 @@ import Web.SCIM.Schema.ResourceType hiding (name) import Web.SCIM.Schema.User as User import Web.SCIM.Schema.User.Name import Web.SCIM.Schema.User.Email as E -import Web.SCIM.Class.Auth import Web.SCIM.Capabilities.MetaSchema as MetaSchema import Data.Time @@ -18,12 +17,11 @@ import Network.Wai.Handler.Warp import Network.URI.Static import qualified STMContainers.Map as STMMap import Control.Monad.STM (atomically) -import Data.UUID as UUID import Text.Email.Validate main :: IO () main = do - storage <- TestStorage <$> mkUserDB <*> STMMap.newIO <*> mkAuthDB + storage <- TestStorage <$> mkUserDB <*> STMMap.newIO run 9000 (app MetaSchema.empty (nt storage)) -- | Create a UserDB with a single user: @@ -67,21 +65,3 @@ mkUserDB = do } atomically $ STMMap.insert (WithMeta meta (WithId "elton" user)) "elton" db pure db - --- | Create an AuthDB with a single admin: --- --- @ --- UUID: 00000500-0000-0000-0000-000000000001 --- pass: password --- @ --- --- The authorization header for this admin (which you can regenerate by --- following the logic in 'authHeader'): --- --- @Basic MDAwMDA1MDAtMDAwMC0wMDAwLTAwMDAtMDAwMDAwMDAwMDAxOnBhc3N3b3Jk@ -mkAuthDB :: IO AdminStorage -mkAuthDB = do - db <- STMMap.newIO - let uuid = UUID.fromWords 0x500 0 0 1 - atomically $ STMMap.insert (Admin uuid, "password") uuid db - pure db diff --git a/src/Web/SCIM/Class/Auth.hs b/src/Web/SCIM/Class/Auth.hs index b5978981ef8..b8f423a9221 100644 --- a/src/Web/SCIM/Class/Auth.hs +++ b/src/Web/SCIM/Class/Auth.hs @@ -1,68 +1,31 @@ --- | Basic HTTP authentication support. We roll our own mechanism instead of --- doing 'BasicAuthCheck' because we don't want to muck with Servant --- contexts. +-- | HTTP authentication support. Can be used with basic auth, token-based +-- auth, or something else (though OAuth is likely not implementable with +-- this API). module Web.SCIM.Class.Auth - ( Admin (..) - , AuthDB (..) - , SCIMAuthData (..) + ( AuthDB (..) ) where -import Data.Aeson -import GHC.Generics import Servant -import Data.UUID as UUID -import Data.Char -import Control.Monad -import Data.Text.Encoding import Web.SCIM.Handler -import Data.Text (Text) - -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Base64 as Base64 - --- | Someone who is allowed to provision users via SCIM. -data Admin = Admin - { adminId :: UUID - } deriving (Eq, Show, Read, Generic) - -instance ToJSON Admin -instance FromJSON Admin -- | An interface that has to be implemented for a server to provide -- authentication. -class AuthDB m where - -- | Check whether a set of credentials (UUID and password) corresponds - -- to any 'Admin'. - authCheck :: Maybe SCIMAuthData -> SCIMHandler m (BasicAuthResult Admin) - ----------------------------------------------------------------------------- --- Auth header - --- | Data contained in the basic auth header. --- --- TODO: parametrize with 'Admin' -data SCIMAuthData = SCIMAuthData - { scimAdmin :: UUID - , scimPassword :: BS.ByteString - } deriving (Eq, Show) - --- | Decode a basic auth header. -decodeAuth :: BS.ByteString -> Either Text SCIMAuthData -decodeAuth ah = do - -- This code was copied from http://hackage.haskell.org/package/servant-server-0.14.1/docs/src/Servant.Server.Internal.BasicAuth.html#decodeBAHdr - let (b, rest) = BS.break isSpace ah - when (BS.map toLower b /= "basic") $ - Left "expected \"basic\"" - let decoded = Base64.decodeLenient (BS.dropWhile isSpace rest) - let (username, passWithColonAtHead) = BS.break (== ':') decoded - admin <- - maybe (Left "couldn't decode the username as UUID") Right $ - UUID.fromASCIIBytes username - (_, password) <- - maybe (Left "expected username:password, but ':' was not found") Right $ - BS.uncons passWithColonAtHead - return (SCIMAuthData admin password) - -instance FromHttpApiData SCIMAuthData where - parseUrlPiece = decodeAuth . encodeUtf8 - parseHeader = decodeAuth +class FromHttpApiData (AuthData m) => AuthDB m where + -- | The type that the “Authorization” header will be parsed as. This info + -- will be given to 'AuthCheck'. + type AuthData m + + -- | The result of performing authentication. + -- + -- Can be '()' to handle just authorized/non-authorized, or something more + -- complex – for instance, if the auth header provides a token that may or + -- may not correspond to a particular organization, then the result could + -- be the ID of that organization). + type AuthInfo m + + -- | Do authentication or throw an error in `SCIMHandler` (e.g. + -- 'Web.SCIM.Schema.Error.unauthorized') if the provided credentials are + -- invalid or don't correspond to any user. + authCheck + :: Maybe (AuthData m) + -> SCIMHandler m (AuthInfo m) diff --git a/src/Web/SCIM/Class/Group.hs b/src/Web/SCIM/Class/Group.hs index 67bd29ed86d..c39d2b459b1 100644 --- a/src/Web/SCIM/Class/Group.hs +++ b/src/Web/SCIM/Class/Group.hs @@ -17,9 +17,13 @@ import Web.SCIM.Schema.Error import Web.SCIM.Schema.Meta import Web.SCIM.ContentType import Web.SCIM.Handler +import Web.SCIM.Class.Auth import Servant import Servant.Generic +---------------------------------------------------------------------------- +-- /Groups API + type GroupId = Text type Schema = Text @@ -52,14 +56,6 @@ instance ToJSON Group where type StoredGroup = WithMeta (WithId Group) -class Monad m => GroupDB m where - list :: SCIMHandler m [StoredGroup] - get :: GroupId -> SCIMHandler m (Maybe StoredGroup) - create :: Group -> SCIMHandler m StoredGroup - update :: GroupId -> Group -> SCIMHandler m StoredGroup - delete :: GroupId -> SCIMHandler m Bool -- ^ Return 'False' if the group didn't exist - getGroupMeta :: SCIMHandler m Meta - data GroupSite route = GroupSite { getGroups :: route :- Get '[SCIM] [StoredGroup] @@ -75,23 +71,71 @@ data GroupSite route = GroupSite Capture "id" Text :> DeleteNoContent '[SCIM] NoContent } deriving (Generic) -groupServer :: GroupDB m => GroupSite (AsServerT (SCIMHandler m)) -groupServer = GroupSite - { getGroups = list - , getGroup = getGroup' - , postGroup = create - , putGroup = update +---------------------------------------------------------------------------- +-- Methods used by the API + +class (Monad m, AuthDB m) => GroupDB m where + list :: AuthInfo m -> SCIMHandler m [StoredGroup] + get :: AuthInfo m -> GroupId -> SCIMHandler m (Maybe StoredGroup) + create :: AuthInfo m -> Group -> SCIMHandler m StoredGroup + update :: AuthInfo m -> GroupId -> Group -> SCIMHandler m StoredGroup + delete :: AuthInfo m -> GroupId -> SCIMHandler m Bool -- ^ Return 'False' if the group didn't exist + getGroupMeta :: AuthInfo m -> SCIMHandler m Meta + +---------------------------------------------------------------------------- +-- API handlers + +groupServer + :: GroupDB m + => Maybe (AuthData m) -> GroupSite (AsServerT (SCIMHandler m)) +groupServer authData = GroupSite + { getGroups = do + auth <- authCheck authData + getGroups' auth + , getGroup = \gid -> do + auth <- authCheck authData + getGroup' auth gid + , postGroup = \gr -> do + auth <- authCheck authData + postGroup' auth gr + , putGroup = \gid gr -> do + auth <- authCheck authData + putGroup' auth gid gr , patchGroup = error "PATCH /Groups: not implemented" - , deleteGroup = deleteGroup' + , deleteGroup = \gid -> do + auth <- authCheck authData + deleteGroup' auth gid } -getGroup' :: GroupDB m => GroupId -> SCIMHandler m StoredGroup -getGroup' gid = do - maybeGroup <- get gid +getGroups' + :: GroupDB m + => AuthInfo m -> SCIMHandler m [StoredGroup] +getGroups' auth = do + list auth + +getGroup' + :: GroupDB m + => AuthInfo m -> GroupId -> SCIMHandler m StoredGroup +getGroup' auth gid = do + maybeGroup <- get auth gid maybe (throwSCIM (notFound "Group" gid)) pure maybeGroup -deleteGroup' :: GroupDB m => GroupId -> SCIMHandler m NoContent -deleteGroup' gid = do - deleted <- delete gid +postGroup' + :: GroupDB m + => AuthInfo m -> Group -> SCIMHandler m StoredGroup +postGroup' auth gr = do + create auth gr + +putGroup' + :: GroupDB m + => AuthInfo m -> GroupId -> Group -> SCIMHandler m StoredGroup +putGroup' auth gid gr = do + update auth gid gr + +deleteGroup' + :: GroupDB m + => AuthInfo m -> GroupId -> SCIMHandler m NoContent +deleteGroup' auth gid = do + deleted <- delete auth gid unless deleted $ throwSCIM (notFound "Group" gid) pure NoContent diff --git a/src/Web/SCIM/Class/User.hs b/src/Web/SCIM/Class/User.hs index 52fc70b670a..1d53343178a 100644 --- a/src/Web/SCIM/Class/User.hs +++ b/src/Web/SCIM/Class/User.hs @@ -17,23 +17,15 @@ import Web.SCIM.Schema.ListResponse hiding (schemas) import Web.SCIM.Handler import Web.SCIM.Filter import Web.SCIM.ContentType +import Web.SCIM.Class.Auth import Servant import Servant.Generic +---------------------------------------------------------------------------- +-- /Users API type StoredUser = WithMeta (WithId User) --- TODO: parameterize UserId -class Monad m => UserDB m where - list :: Maybe Filter -> SCIMHandler m (ListResponse StoredUser) - get :: UserId -> SCIMHandler m (Maybe StoredUser) - create :: User -> SCIMHandler m StoredUser - update :: UserId -> User -> SCIMHandler m StoredUser - patch :: UserId -> SCIMHandler m StoredUser - delete :: UserId -> SCIMHandler m Bool -- ^ Return 'False' if the user didn't exist - getMeta :: SCIMHandler m Meta - - data UserSite route = UserSite { getUsers :: route :- QueryParam "filter" Filter :> Get '[SCIM] (ListResponse StoredUser) @@ -49,49 +41,93 @@ data UserSite route = UserSite Capture "id" Text :> DeleteNoContent '[SCIM] NoContent } deriving (Generic) -userServer :: UserDB m => UserSite (AsServerT (SCIMHandler m)) -userServer = UserSite - { getUsers = list - , getUser = getUser' - , postUser = postUser' - , putUser = updateUser' - , patchUser = patch - , deleteUser = deleteUser' +---------------------------------------------------------------------------- +-- Methods used by the API + +-- TODO: parameterize UserId +class (Monad m, AuthDB m) => UserDB m where + list :: AuthInfo m -> Maybe Filter -> SCIMHandler m (ListResponse StoredUser) + get :: AuthInfo m -> UserId -> SCIMHandler m (Maybe StoredUser) + create :: AuthInfo m -> User -> SCIMHandler m StoredUser + update :: AuthInfo m -> UserId -> User -> SCIMHandler m StoredUser + delete :: AuthInfo m -> UserId -> SCIMHandler m Bool -- ^ Return 'False' if the user didn't exist + getMeta :: AuthInfo m -> SCIMHandler m Meta + +---------------------------------------------------------------------------- +-- API handlers + +userServer + :: UserDB m + => Maybe (AuthData m) -> UserSite (AsServerT (SCIMHandler m)) +userServer authData = UserSite + { getUsers = \mbFilter -> do + auth <- authCheck authData + getUsers' auth mbFilter + , getUser = \uid -> do + auth <- authCheck authData + getUser' auth uid + , postUser = \user -> do + auth <- authCheck authData + postUser' auth user + , putUser = \uid user -> do + auth <- authCheck authData + putUser' auth uid user + , patchUser = error "PATCH /Users: not implemented" + , deleteUser = \uid -> do + auth <- authCheck authData + deleteUser' auth uid } -postUser' :: UserDB m => User -> SCIMHandler m StoredUser -postUser' user = do +getUsers' + :: UserDB m + => AuthInfo m -> Maybe Filter -> SCIMHandler m (ListResponse StoredUser) +getUsers' auth mbFilter = do + list auth mbFilter + +getUser' + :: UserDB m + => AuthInfo m -> UserId -> SCIMHandler m StoredUser +getUser' auth uid = do + maybeUser <- get auth uid + maybe (throwSCIM (notFound "User" uid)) pure maybeUser + +postUser' + :: UserDB m + => AuthInfo m -> User -> SCIMHandler m StoredUser +postUser' auth user = do -- Find users with the same username (case-insensitive) -- -- TODO: it might be worth it to let 'create' handle conflicts if it can -- do it in one pass instead of two passes. Same applies to 'updateUser'' -- and similar functions. let filter_ = FilterAttrCompare AttrUserName OpEq (ValString (userName user)) - stored <- list (Just filter_) + stored <- list auth (Just filter_) when (totalResults stored > 0) $ throwSCIM conflict - create user + create auth user -updateUser' :: UserDB m => UserId -> User -> SCIMHandler m StoredUser -updateUser' uid updatedUser = do - stored <- get uid +putUser' + :: UserDB m + => AuthInfo m -> UserId -> User -> SCIMHandler m StoredUser +putUser' auth uid updatedUser = do + stored <- get auth uid case stored of Just (WithMeta _meta (WithId _ existing)) -> do let newUser = existing `overwriteWith` updatedUser - update uid newUser + update auth uid newUser Nothing -> throwSCIM (notFound "User" uid) -getUser' :: UserDB m => UserId -> SCIMHandler m StoredUser -getUser' uid = do - maybeUser <- get uid - maybe (throwSCIM (notFound "User" uid)) pure maybeUser - -deleteUser' :: UserDB m => UserId -> SCIMHandler m NoContent -deleteUser' uid = do - deleted <- delete uid +deleteUser' + :: UserDB m + => AuthInfo m -> UserId -> SCIMHandler m NoContent +deleteUser' auth uid = do + deleted <- delete auth uid unless deleted $ throwSCIM (notFound "User" uid) pure NoContent +---------------------------------------------------------------------------- +-- Utilities + overwriteWith :: User -> User -> User overwriteWith old new = old { --externalId :: Unsettable Text diff --git a/src/Web/SCIM/Schema/Error.hs b/src/Web/SCIM/Schema/Error.hs index b1d23a52dae..23e411c2a03 100644 --- a/src/Web/SCIM/Schema/Error.hs +++ b/src/Web/SCIM/Schema/Error.hs @@ -24,7 +24,6 @@ import Control.Exception import Web.SCIM.Schema.Common import Web.SCIM.Schema.Schema import Servant (ServantErr (..)) -import Data.UUID (UUID) import GHC.Generics (Generic) @@ -117,19 +116,14 @@ conflict = } unauthorized - :: Maybe UUID -- ^ Admin ID - -> Text -- ^ Error details + :: Text -- ^ Error details -> SCIMError -unauthorized mbAdmin details = +unauthorized details = SCIMError { schemas = [Error2_0] , status = Status 401 , scimType = Nothing - , detail = pure $ - "authorization failed: " <> details <> - case mbAdmin of - Nothing -> " (no authorization provided)" - Just admin -> " (admin ID: " <> pack (show admin) <> ")" + , detail = pure $ "authorization failed: " <> details } serverError diff --git a/src/Web/SCIM/Server.hs b/src/Web/SCIM/Server.hs index f7c3233ee74..0054634aeea 100644 --- a/src/Web/SCIM/Server.hs +++ b/src/Web/SCIM/Server.hs @@ -13,12 +13,10 @@ module Web.SCIM.Server import Web.SCIM.Class.User (UserSite (..), UserDB, userServer) import Web.SCIM.Class.Group (GroupSite (..), GroupDB, groupServer) -import Web.SCIM.Class.Auth (AuthDB (..), SCIMAuthData (..)) +import Web.SCIM.Class.Auth (AuthDB (..)) import Web.SCIM.Capabilities.MetaSchema (ConfigSite, Configuration, configServer) import Web.SCIM.Handler -import Web.SCIM.Schema.Error import GHC.Generics (Generic) -import Data.Text import Network.Wai import Servant.Generic hiding (fromServant) import Servant @@ -28,19 +26,19 @@ import Servant type DB m = (UserDB m, GroupDB m, AuthDB m) -type ConfigAPI = ToServant (ConfigSite AsApi) -type UserAPI = ToServant (UserSite AsApi) -type GroupAPI = ToServant (GroupSite AsApi) -type SiteAPI = ToServant (Site AsApi) +type ConfigAPI = ToServant (ConfigSite AsApi) +type UserAPI = ToServant (UserSite AsApi) +type GroupAPI = ToServant (GroupSite AsApi) +type SiteAPI authData = ToServant (Site authData AsApi) -data Site route = Site +data Site authData route = Site { config :: route :- ConfigAPI , users :: route :- - Header "Authorization" SCIMAuthData :> + Header "Authorization" authData :> "Users" :> UserAPI , groups :: route :- - Header "Authorization" SCIMAuthData :> + Header "Authorization" authData :> "Groups" :> GroupAPI } deriving (Generic) @@ -49,26 +47,13 @@ data Site route = Site siteServer :: forall m. DB m => - Configuration -> Site (AsServerT (SCIMHandler m)) + Configuration -> Site (AuthData m) (AsServerT (SCIMHandler m)) siteServer conf = Site { config = toServant $ configServer conf - , users = \auth -> - hoistServer (Proxy @UserAPI) (addAuth auth) (toServant userServer) - , groups = \auth -> - hoistServer (Proxy @GroupAPI) (addAuth auth) (toServant groupServer) + , users = \authData -> toServant (userServer authData) + , groups = \authData -> toServant (groupServer authData) } where - -- Perform authentication in a handler. This function will be applied to - -- all leaves of the API. - addAuth :: forall a. Maybe SCIMAuthData - -> SCIMHandler m a - -> SCIMHandler m a - addAuth auth handler = do - authResult <- authCheck auth - case authResult of - Authorized _ -> handler - _ -> throwSCIM (unauthorized (scimAdmin <$> auth) - (pack (show authResult))) ---------------------------------------------------------------------------- -- Server-starting utilities @@ -87,8 +72,8 @@ mkapp proxy api nt = serve proxy $ hoistServer proxy nt api -app :: forall m. App m SiteAPI +app :: forall m. App m (SiteAPI (AuthData m)) => Configuration -> (forall a. SCIMHandler m a -> Handler a) -> Application -app c = mkapp (Proxy @SiteAPI) (toServant $ siteServer c) +app c = mkapp (Proxy @(SiteAPI (AuthData m))) (toServant $ siteServer c) diff --git a/src/Web/SCIM/Server/Mock.hs b/src/Web/SCIM/Server/Mock.hs index 80952c2ded4..1791000ae7b 100644 --- a/src/Web/SCIM/Server/Mock.hs +++ b/src/Web/SCIM/Server/Mock.hs @@ -13,7 +13,6 @@ import Control.Monad.STM (STM, atomically) import Control.Monad.Reader import Control.Monad.Morph import Data.Text (Text, pack) -import Data.Text.Encoding import Data.Time.Clock import Data.Time.Calendar import GHC.Exts (sortWith) @@ -29,21 +28,18 @@ import qualified Web.SCIM.Schema.Common as Common import Web.SCIM.Filter import Web.SCIM.Handler import Servant -import Data.UUID as UUID type UserStorage = STMMap.Map Text StoredUser type GroupStorage = STMMap.Map Text StoredGroup -type AdminStorage = STMMap.Map UUID (Admin, Text) -- (Admin, Pass) data TestStorage = TestStorage { userDB :: UserStorage , groupDB :: GroupStorage - , authDB :: AdminStorage } emptyTestStorage :: IO TestStorage emptyTestStorage = - TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> STMMap.newIO + TestStorage <$> STMMap.newIO <*> STMMap.newIO -- in-memory implementation of the API for tests type TestServer = ReaderT TestStorage Handler @@ -55,7 +51,7 @@ hoistSTM :: (MFunctor t, MonadIO m) => t STM a -> t m a hoistSTM = hoist liftSTM instance UserDB TestServer where - list mbFilter = do + list () mbFilter = do -- Note: in production instances it would make sense to remove this code -- and let the implementor of the 'UserDB' instance do filtering (e.g. -- doing case-insensitive queries on common attributes can be done @@ -73,57 +69,49 @@ instance UserDB TestServer where Left err -> throwSCIM (badRequest InvalidFilter (Just err)) fromList . sortWith (Common.id . thing) <$> filterM check (snd <$> users) - get i = do + get () i = do m <- userDB <$> ask liftSTM $ STMMap.lookup i m - create user = do + create auth user = do m <- userDB <$> ask - met <- getMeta + met <- getMeta auth newUser <- hoistSTM $ insertUser user met m return newUser - update uid user = do + update () uid user = do storage <- userDB <$> ask hoistSTM $ updateUser uid user storage - delete uid = do + delete () uid = do m <- userDB <$> ask hoistSTM $ delUser uid m - getMeta = return (createMeta UserResource) - patch = error "PATCH /Users: not implemented" + getMeta () = return (createMeta UserResource) instance GroupDB TestServer where - list = do + list () = do m <- groupDB <$> ask groups <- liftSTM $ ListT.toList $ STMMap.stream m return $ sortWith (Common.id . thing) $ snd <$> groups - get i = do + get () i = do m <- groupDB <$> ask liftSTM $ STMMap.lookup i m - create = \grp -> do + create auth grp = do storage <- groupDB <$> ask - met <- getGroupMeta + met <- getGroupMeta auth newGroup <- hoistSTM $ insertGroup grp met storage pure newGroup - update i g = do + update () i g = do m <- groupDB <$> ask hoistSTM $ updateGroup i g m - delete gid = do + delete () gid = do m <- groupDB <$> ask hoistSTM $ delGroup gid m - getGroupMeta = return (createMeta GroupResource) + getGroupMeta () = return (createMeta GroupResource) instance AuthDB TestServer where - authCheck Nothing = pure Unauthorized - authCheck (Just (SCIMAuthData uuid pass)) = do - m <- authDB <$> ask - liftIO (atomically (STMMap.lookup uuid m)) >>= \case - Just (admin, adminPass) - | decodeUtf8 pass == adminPass -> pure (Authorized admin) - -- Note: somebody can figure out if whether the given user - -- exists, but since the admin users are represented with UUIDs - -- (which are pretty hard to bruteforce), it's okay. It also - -- makes debugging easier. - | otherwise -> pure BadPassword - Nothing -> pure NoSuchUser + type AuthData TestServer = Text + type AuthInfo TestServer = () + authCheck = \case + Just "authorized" -> pure () + _ -> throwSCIM (unauthorized "expected 'authorized'") insertGroup :: Group -> Meta -> GroupStorage -> SCIMHandler STM StoredGroup insertGroup grp met storage = do diff --git a/test/Test/Class/AuthSpec.hs b/test/Test/Class/AuthSpec.hs index ce7b8520937..f644e608991 100644 --- a/test/Test/Class/AuthSpec.hs +++ b/test/Test/Class/AuthSpec.hs @@ -4,32 +4,17 @@ module Test.Class.AuthSpec (spec) where import Web.SCIM.Server (app) import Web.SCIM.Server.Mock -import Web.SCIM.Class.Auth (Admin (..)) import Web.SCIM.Capabilities.MetaSchema (empty) import Data.Text (Text) import Data.Text.Encoding -import Data.Monoid import Test.Hspec import Test.Hspec.Wai hiding (post, put, patch) -import qualified Data.ByteString.Base64 as Base64 import Network.HTTP.Types.Header import Network.HTTP.Types.Method (methodGet) import qualified STMContainers.Map as STMMap -import Control.Monad.STM -import Data.UUID as UUID -import Data.UUID.V4 as UUID - --- | A hardcoded UUID of an admin existing in the 'TestStorage'. --- --- @00000500-0000-0000-0000-000000000001@ -testAdminUUID :: UUID -testAdminUUID = UUID.fromWords 0x500 0 0 1 testStorage :: IO TestStorage -testStorage = do - authMap <- STMMap.newIO - atomically $ STMMap.insert (Admin testAdminUUID, "password") testAdminUUID authMap - TestStorage <$> STMMap.newIO <*> STMMap.newIO <*> pure authMap +testStorage = TestStorage <$> STMMap.newIO <*> STMMap.newIO spec :: Spec spec = beforeAll ((\s -> app empty (nt s)) <$> testStorage) $ do @@ -38,27 +23,20 @@ spec = beforeAll ((\s -> app empty (nt s)) <$> testStorage) $ do get "/ServiceProviderConfig" `shouldRespondWith` 200 it "doesn't check auth credentials" $ do - randomAdmin <- liftIO UUID.nextRandom - request methodGet "/ServiceProviderConfig" [authHeader randomAdmin "wrongpassword"] "" + request methodGet "/ServiceProviderConfig" [authHeader "blah"] "" `shouldRespondWith` 200 describe "/Users" $ do it "succeeds with authentication" $ do - request methodGet "/Users" [authHeader testAdminUUID "password"] "" + request methodGet "/Users" [authHeader "authorized"] "" `shouldRespondWith` 200 - it "fails if the password is wrong" $ do - request methodGet "/Users" [authHeader testAdminUUID "wrongpassword"] "" - `shouldRespondWith` 401 - - it "fails if the admin is not found" $ do - randomAdminUUID <- liftIO UUID.nextRandom - request methodGet "/Users" [authHeader randomAdminUUID "password"] "" + it "fails if the auth token is invalid" $ do + request methodGet "/Users" [authHeader "blah"] "" `shouldRespondWith` 401 it "fails if no authentication is provided" $ do get "/Users" `shouldRespondWith` 401 -authHeader :: UUID -> Text -> Header -authHeader user pass = - (hAuthorization, "Basic " <> Base64.encode (toASCIIBytes user <> ":" <> encodeUtf8 pass)) +authHeader :: Text -> Header +authHeader token = (hAuthorization, encodeUtf8 token) diff --git a/test/Test/Class/GroupSpec.hs b/test/Test/Class/GroupSpec.hs index 265892994fe..a3d67266af3 100644 --- a/test/Test/Class/GroupSpec.hs +++ b/test/Test/Class/GroupSpec.hs @@ -17,7 +17,8 @@ import Test.Hspec.Wai hiding (post, put, patch) app :: IO Application app = do storage <- emptyTestStorage - pure $ mkapp (Proxy @GroupAPI) (toServant groupServer) (nt storage) + let auth = Just "authorized" + pure $ mkapp (Proxy @GroupAPI) (toServant (groupServer auth)) (nt storage) spec :: Spec spec = beforeAll app $ do diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index cd5b0f55a71..cdbd13bde1c 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -17,7 +17,8 @@ import Network.Wai (Application) app :: IO Application app = do storage <- emptyTestStorage - pure $ mkapp (Proxy @UserAPI) (toServant userServer) (nt storage) + let auth = Just "authorized" + pure $ mkapp (Proxy @UserAPI) (toServant (userServer auth)) (nt storage) spec :: Spec spec = beforeAll app $ do From 9abf972d67dfec0cc1aad8ad0b61f600fe4f5476 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Tue, 20 Nov 2018 15:29:24 +0100 Subject: [PATCH 20/64] Migrate from servant-generic to Servant.API.Generic (#19) Needed for LTS-12 (servant-generic is deprecated). --- .travis.yml | 2 +- package.yaml | 5 ++--- src/Web/SCIM/Capabilities/MetaSchema.hs | 3 ++- src/Web/SCIM/Class/Group.hs | 3 ++- src/Web/SCIM/Class/User.hs | 3 ++- src/Web/SCIM/Filter.hs | 1 - src/Web/SCIM/Schema/Error.hs | 1 - src/Web/SCIM/Schema/Meta.hs | 1 - src/Web/SCIM/Server.hs | 11 ++++++----- stack.yaml | 4 +--- test/Test/Capabilities/MetaSchemaSpec.hs | 4 ++-- test/Test/Class/GroupSpec.hs | 2 +- test/Test/Class/UserSpec.hs | 2 +- test/Test/Util.hs | 1 - 14 files changed, 20 insertions(+), 23 deletions(-) diff --git a/.travis.yml b/.travis.yml index f8249245069..1cfd3d37254 100644 --- a/.travis.yml +++ b/.travis.yml @@ -13,7 +13,7 @@ addons: - libgmp-dev env: -- RESOLVER=lts-11.13 +- RESOLVER=lts-12.10 before_install: - mkdir -p ~/.local/bin diff --git a/package.yaml b/package.yaml index b1f13d618e9..3678c87153d 100644 --- a/package.yaml +++ b/package.yaml @@ -34,14 +34,13 @@ extra-source-files: - README.md dependencies: - - base >= 4.7 && < 5 + - base >= 4.11 && < 5 - bytestring - aeson - aeson-qq - mtl - servant - - servant-server >= 0.12 - - servant-generic + - servant-server >= 0.14.1 - text - time - wai diff --git a/src/Web/SCIM/Capabilities/MetaSchema.hs b/src/Web/SCIM/Capabilities/MetaSchema.hs index e1b4be37894..30ce80d9f71 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema.hs +++ b/src/Web/SCIM/Capabilities/MetaSchema.hs @@ -26,7 +26,8 @@ import qualified Data.HashMap.Lazy as HML import Data.Text (Text) import GHC.Generics (Generic) import Servant hiding (URI) -import Servant.Generic +import Servant.API.Generic +import Servant.Server.Generic import Prelude hiding (filter) diff --git a/src/Web/SCIM/Class/Group.hs b/src/Web/SCIM/Class/Group.hs index c39d2b459b1..8aaa1b7f94a 100644 --- a/src/Web/SCIM/Class/Group.hs +++ b/src/Web/SCIM/Class/Group.hs @@ -19,7 +19,8 @@ import Web.SCIM.ContentType import Web.SCIM.Handler import Web.SCIM.Class.Auth import Servant -import Servant.Generic +import Servant.API.Generic +import Servant.Server.Generic ---------------------------------------------------------------------------- -- /Groups API diff --git a/src/Web/SCIM/Class/User.hs b/src/Web/SCIM/Class/User.hs index 1d53343178a..6f93d9d8ac2 100644 --- a/src/Web/SCIM/Class/User.hs +++ b/src/Web/SCIM/Class/User.hs @@ -19,7 +19,8 @@ import Web.SCIM.Filter import Web.SCIM.ContentType import Web.SCIM.Class.Auth import Servant -import Servant.Generic +import Servant.API.Generic +import Servant.Server.Generic ---------------------------------------------------------------------------- -- /Users API diff --git a/src/Web/SCIM/Filter.hs b/src/Web/SCIM/Filter.hs index 11b15cabe2a..e3df4b23026 100644 --- a/src/Web/SCIM/Filter.hs +++ b/src/Web/SCIM/Filter.hs @@ -38,7 +38,6 @@ import Data.Attoparsec.ByteString.Char8 import Data.Aeson.Parser as Aeson import Data.Aeson.Text as Aeson import Data.Aeson as Aeson -import Data.Monoid import Lens.Micro import Web.HttpApiData diff --git a/src/Web/SCIM/Schema/Error.hs b/src/Web/SCIM/Schema/Error.hs index 23e411c2a03..2dbaac969ac 100644 --- a/src/Web/SCIM/Schema/Error.hs +++ b/src/Web/SCIM/Schema/Error.hs @@ -19,7 +19,6 @@ module Web.SCIM.Schema.Error import Data.Text (Text, pack) import Data.Aeson hiding (Error) -import Data.Monoid ((<>)) import Control.Exception import Web.SCIM.Schema.Common import Web.SCIM.Schema.Schema diff --git a/src/Web/SCIM/Schema/Meta.hs b/src/Web/SCIM/Schema/Meta.hs index f20cb58e0c7..98ac4423320 100644 --- a/src/Web/SCIM/Schema/Meta.hs +++ b/src/Web/SCIM/Schema/Meta.hs @@ -6,7 +6,6 @@ import Prelude hiding (map) import Data.Text (Text, unpack, pack) import qualified Data.Text as Text import Text.Read (readEither) -import Data.Monoid ((<>)) import Data.Aeson import Web.SCIM.Schema.Common import Web.SCIM.Schema.ResourceType diff --git a/src/Web/SCIM/Server.hs b/src/Web/SCIM/Server.hs index 0054634aeea..d84bad2926c 100644 --- a/src/Web/SCIM/Server.hs +++ b/src/Web/SCIM/Server.hs @@ -18,18 +18,19 @@ import Web.SCIM.Capabilities.MetaSchema (ConfigSite, Configuration, co import Web.SCIM.Handler import GHC.Generics (Generic) import Network.Wai -import Servant.Generic hiding (fromServant) import Servant +import Servant.API.Generic +import Servant.Server.Generic ---------------------------------------------------------------------------- -- API specification type DB m = (UserDB m, GroupDB m, AuthDB m) -type ConfigAPI = ToServant (ConfigSite AsApi) -type UserAPI = ToServant (UserSite AsApi) -type GroupAPI = ToServant (GroupSite AsApi) -type SiteAPI authData = ToServant (Site authData AsApi) +type ConfigAPI = ToServantApi ConfigSite +type UserAPI = ToServantApi UserSite +type GroupAPI = ToServantApi GroupSite +type SiteAPI authData = ToServantApi (Site authData) data Site authData route = Site { config :: route :- diff --git a/stack.yaml b/stack.yaml index 8a963df916c..1ba45779784 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,7 @@ -resolver: lts-11.13 +resolver: lts-12.10 packages: - . extra-deps: -- servant-auth-0.3.2.0 -- servant-auth-server-0.4.0.0 - network-uri-static-0.1.1.0 diff --git a/test/Test/Capabilities/MetaSchemaSpec.hs b/test/Test/Capabilities/MetaSchemaSpec.hs index 43b07b5acdc..d6d5c0881e4 100644 --- a/test/Test/Capabilities/MetaSchemaSpec.hs +++ b/test/Test/Capabilities/MetaSchemaSpec.hs @@ -6,7 +6,6 @@ import Test.Util import qualified Data.List as List import Data.Aeson -import Data.Monoid import Data.Text (Text) import Data.Coerce import Web.SCIM.Capabilities.MetaSchema @@ -14,7 +13,8 @@ import Web.SCIM.Server (ConfigAPI, mkapp) import Web.SCIM.Server.Mock import Network.Wai.Test (SResponse (..)) import Servant -import Servant.Generic +import Servant.API.Generic + import Test.Hspec hiding (shouldSatisfy) import qualified Test.Hspec.Expectations as Expect import Test.Hspec.Wai hiding (post, put, patch) diff --git a/test/Test/Class/GroupSpec.hs b/test/Test/Class/GroupSpec.hs index a3d67266af3..9b1d0acc940 100644 --- a/test/Test/Class/GroupSpec.hs +++ b/test/Test/Class/GroupSpec.hs @@ -5,13 +5,13 @@ module Test.Class.GroupSpec (spec) where import Test.Util import Network.Wai (Application) -import Servant.Generic import Servant (Proxy(Proxy)) import Web.SCIM.Server (mkapp, GroupAPI, groupServer) import Web.SCIM.Server.Mock import Data.ByteString.Lazy (ByteString) import Test.Hspec hiding (shouldSatisfy) import Test.Hspec.Wai hiding (post, put, patch) +import Servant.API.Generic app :: IO Application diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index cdbd13bde1c..0dd74ad364c 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -10,8 +10,8 @@ import Test.Hspec import Test.Hspec.Wai hiding (post, put, patch) import Data.ByteString.Lazy (ByteString) import Servant (Proxy(Proxy)) -import Servant.Generic import Network.Wai (Application) +import Servant.API.Generic app :: IO Application diff --git a/test/Test/Util.hs b/test/Test/Util.hs index 9dbe484661f..06ef2d4ce6c 100644 --- a/test/Test/Util.hs +++ b/test/Test/Util.hs @@ -15,7 +15,6 @@ import qualified Data.ByteString.Lazy as L import Data.Aeson import Data.Aeson.Internal (JSONPathElement (Key), ()) import Data.Aeson.QQ -import Data.Monoid import Data.Text import Language.Haskell.TH.Quote import Network.HTTP.Types From 5306564bffeeb4ad7216481e6ba132dffb214213 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Sun, 20 Jan 2019 21:52:28 +1100 Subject: [PATCH 21/64] SCIM -> Scim (#22) --- server/Main.hs | 18 +++---- src/Web/SCIM/Handler.hs | 30 ----------- .../{SCIM => Scim}/Capabilities/MetaSchema.hs | 32 ++++++------ .../Capabilities/MetaSchema/Group.hs | 2 +- .../Capabilities/MetaSchema/ResourceType.hs | 2 +- .../Capabilities/MetaSchema/SPConfig.hs | 2 +- .../Capabilities/MetaSchema/Schema.hs | 2 +- .../Capabilities/MetaSchema/User.hs | 2 +- src/Web/{SCIM => Scim}/Class/Auth.hs | 10 ++-- src/Web/{SCIM => Scim}/Class/Group.hs | 42 +++++++-------- src/Web/{SCIM => Scim}/Class/User.hs | 52 +++++++++---------- src/Web/{SCIM => Scim}/ContentType.hs | 2 +- src/Web/{SCIM => Scim}/Filter.hs | 4 +- src/Web/Scim/Handler.hs | 30 +++++++++++ .../Schema/AuthenticationScheme.hs | 4 +- src/Web/{SCIM => Scim}/Schema/Common.hs | 2 +- src/Web/{SCIM => Scim}/Schema/Error.hs | 48 ++++++++--------- src/Web/{SCIM => Scim}/Schema/ListResponse.hs | 7 ++- src/Web/{SCIM => Scim}/Schema/Meta.hs | 6 +-- src/Web/{SCIM => Scim}/Schema/ResourceType.hs | 6 +-- src/Web/{SCIM => Scim}/Schema/Schema.hs | 12 ++--- src/Web/{SCIM => Scim}/Schema/User.hs | 20 +++---- src/Web/{SCIM => Scim}/Schema/User/Address.hs | 4 +- .../{SCIM => Scim}/Schema/User/Certificate.hs | 4 +- src/Web/{SCIM => Scim}/Schema/User/Email.hs | 4 +- src/Web/{SCIM => Scim}/Schema/User/IM.hs | 4 +- src/Web/{SCIM => Scim}/Schema/User/Name.hs | 4 +- src/Web/{SCIM => Scim}/Schema/User/Phone.hs | 4 +- src/Web/{SCIM => Scim}/Schema/User/Photo.hs | 4 +- src/Web/{SCIM => Scim}/Server.hs | 20 +++---- src/Web/{SCIM => Scim}/Server/Mock.hs | 50 +++++++++--------- test/Test/Capabilities/MetaSchemaSpec.hs | 6 +-- test/Test/Class/AuthSpec.hs | 6 +-- test/Test/Class/GroupSpec.hs | 4 +- test/Test/Class/UserSpec.hs | 4 +- test/Test/FilterSpec.hs | 2 +- 36 files changed, 227 insertions(+), 228 deletions(-) delete mode 100644 src/Web/SCIM/Handler.hs rename src/Web/{SCIM => Scim}/Capabilities/MetaSchema.hs (78%) rename src/Web/{SCIM => Scim}/Capabilities/MetaSchema/Group.hs (97%) rename src/Web/{SCIM => Scim}/Capabilities/MetaSchema/ResourceType.hs (98%) rename src/Web/{SCIM => Scim}/Capabilities/MetaSchema/SPConfig.hs (99%) rename src/Web/{SCIM => Scim}/Capabilities/MetaSchema/Schema.hs (99%) rename src/Web/{SCIM => Scim}/Capabilities/MetaSchema/User.hs (99%) rename src/Web/{SCIM => Scim}/Class/Auth.hs (81%) rename src/Web/{SCIM => Scim}/Class/Group.hs (72%) rename src/Web/{SCIM => Scim}/Class/User.hs (75%) rename src/Web/{SCIM => Scim}/ContentType.hs (95%) rename src/Web/{SCIM => Scim}/Filter.hs (99%) create mode 100644 src/Web/Scim/Handler.hs rename src/Web/{SCIM => Scim}/Schema/AuthenticationScheme.hs (96%) rename src/Web/{SCIM => Scim}/Schema/Common.hs (98%) rename src/Web/{SCIM => Scim}/Schema/Error.hs (87%) rename src/Web/{SCIM => Scim}/Schema/ListResponse.hs (93%) rename src/Web/{SCIM => Scim}/Schema/Meta.hs (93%) rename src/Web/{SCIM => Scim}/Schema/ResourceType.hs (92%) rename src/Web/{SCIM => Scim}/Schema/Schema.hs (87%) rename src/Web/{SCIM => Scim}/Schema/User.hs (78%) rename src/Web/{SCIM => Scim}/Schema/User/Address.hs (89%) rename src/Web/{SCIM => Scim}/Schema/User/Certificate.hs (82%) rename src/Web/{SCIM => Scim}/Schema/User/Email.hs (92%) rename src/Web/{SCIM => Scim}/Schema/User/IM.hs (82%) rename src/Web/{SCIM => Scim}/Schema/User/Name.hs (86%) rename src/Web/{SCIM => Scim}/Schema/User/Phone.hs (83%) rename src/Web/{SCIM => Scim}/Schema/User/Photo.hs (82%) rename src/Web/{SCIM => Scim}/Server.hs (78%) rename src/Web/{SCIM => Scim}/Server/Mock.hs (81%) diff --git a/server/Main.hs b/server/Main.hs index 03021e79b25..5d6f0605dd0 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -2,15 +2,15 @@ module Main where -import Web.SCIM.Server -import Web.SCIM.Server.Mock -import Web.SCIM.Schema.Meta hiding (meta) -import Web.SCIM.Schema.Common as Common -import Web.SCIM.Schema.ResourceType hiding (name) -import Web.SCIM.Schema.User as User -import Web.SCIM.Schema.User.Name -import Web.SCIM.Schema.User.Email as E -import Web.SCIM.Capabilities.MetaSchema as MetaSchema +import Web.Scim.Server +import Web.Scim.Server.Mock +import Web.Scim.Schema.Meta hiding (meta) +import Web.Scim.Schema.Common as Common +import Web.Scim.Schema.ResourceType hiding (name) +import Web.Scim.Schema.User as User +import Web.Scim.Schema.User.Name +import Web.Scim.Schema.User.Email as E +import Web.Scim.Capabilities.MetaSchema as MetaSchema import Data.Time import Network.Wai.Handler.Warp diff --git a/src/Web/SCIM/Handler.hs b/src/Web/SCIM/Handler.hs deleted file mode 100644 index 855e6a860a8..00000000000 --- a/src/Web/SCIM/Handler.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Web.SCIM.Handler - ( SCIMHandler - , throwSCIM - , fromSCIMHandler - ) where - -import Control.Monad.Except -import Web.SCIM.Schema.Error - --- | Handler type for SCIM. All errors will be thrown via 'ExceptT'. -type SCIMHandler m = ExceptT SCIMError m - --- | Throw a 'SCIMError'. -throwSCIM :: Monad m => SCIMError -> SCIMHandler m a -throwSCIM = throwError - --- | A natural transformation for Servant handlers. To use it, you need to --- provide a way to throw errors in the underlying @m@ monad. --- --- We can't use something like 'MonadError' to throw errors in @m@ because --- 'MonadError' allows only one type of errors per monad and @m@ might have --- one already. --- --- You can either do something custom for 'SCIMError', or use --- 'scimToServantErr'. -fromSCIMHandler - :: Monad m - => (forall a. SCIMError -> m a) - -> (forall a. SCIMHandler m a -> m a) -fromSCIMHandler fromError = either fromError pure <=< runExceptT diff --git a/src/Web/SCIM/Capabilities/MetaSchema.hs b/src/Web/Scim/Capabilities/MetaSchema.hs similarity index 78% rename from src/Web/SCIM/Capabilities/MetaSchema.hs rename to src/Web/Scim/Capabilities/MetaSchema.hs index 30ce80d9f71..3734e2521aa 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema.hs +++ b/src/Web/Scim/Capabilities/MetaSchema.hs @@ -1,4 +1,4 @@ -module Web.SCIM.Capabilities.MetaSchema ( +module Web.Scim.Capabilities.MetaSchema ( ConfigSite , configServer , Supported (..) @@ -8,19 +8,19 @@ module Web.SCIM.Capabilities.MetaSchema ( , empty ) where -import Web.SCIM.Schema.Schema -import Web.SCIM.Schema.Common -import Web.SCIM.Schema.Error hiding (schemas) -import Web.SCIM.Schema.ResourceType hiding (schema) -import Web.SCIM.Schema.AuthenticationScheme -import Web.SCIM.Schema.ListResponse as ListResponse hiding (schemas) -import Web.SCIM.Capabilities.MetaSchema.User -import Web.SCIM.Capabilities.MetaSchema.SPConfig -import Web.SCIM.Capabilities.MetaSchema.Group -import Web.SCIM.Capabilities.MetaSchema.Schema -import Web.SCIM.Capabilities.MetaSchema.ResourceType -import Web.SCIM.ContentType -import Web.SCIM.Handler +import Web.Scim.Schema.Schema +import Web.Scim.Schema.Common +import Web.Scim.Schema.Error hiding (schemas) +import Web.Scim.Schema.ResourceType hiding (schema) +import Web.Scim.Schema.AuthenticationScheme +import Web.Scim.Schema.ListResponse as ListResponse hiding (schemas) +import Web.Scim.Capabilities.MetaSchema.User +import Web.Scim.Capabilities.MetaSchema.SPConfig +import Web.Scim.Capabilities.MetaSchema.Group +import Web.Scim.Capabilities.MetaSchema.Schema +import Web.Scim.Capabilities.MetaSchema.ResourceType +import Web.Scim.ContentType +import Web.Scim.Handler import Data.Aeson import qualified Data.HashMap.Lazy as HML import Data.Text (Text) @@ -92,7 +92,7 @@ empty = Configuration configServer :: Monad m - => Configuration -> ConfigSite (AsServerT (SCIMHandler m)) + => Configuration -> ConfigSite (AsServerT (ScimHandler m)) configServer config = ConfigSite { spConfig = pure config , getSchemas = pure $ @@ -103,7 +103,7 @@ configServer config = ConfigSite , resourceSchema ] , schema = \uri -> case getSchema =<< fromSchemaUri uri of - Nothing -> throwSCIM (notFound "Schema" uri) + Nothing -> throwScim (notFound "Schema" uri) Just s -> pure s , resourceTypes = pure $ ListResponse.fromList [ usersResource diff --git a/src/Web/SCIM/Capabilities/MetaSchema/Group.hs b/src/Web/Scim/Capabilities/MetaSchema/Group.hs similarity index 97% rename from src/Web/SCIM/Capabilities/MetaSchema/Group.hs rename to src/Web/Scim/Capabilities/MetaSchema/Group.hs index d6d6dfb97f7..1050f17ce66 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema/Group.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/Group.hs @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} -module Web.SCIM.Capabilities.MetaSchema.Group (groupSchema) where +module Web.Scim.Capabilities.MetaSchema.Group (groupSchema) where import Data.Aeson (Value) import Data.Aeson.QQ diff --git a/src/Web/SCIM/Capabilities/MetaSchema/ResourceType.hs b/src/Web/Scim/Capabilities/MetaSchema/ResourceType.hs similarity index 98% rename from src/Web/SCIM/Capabilities/MetaSchema/ResourceType.hs rename to src/Web/Scim/Capabilities/MetaSchema/ResourceType.hs index 3a1b0b5bbde..865884b0d13 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema/ResourceType.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/ResourceType.hs @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} -module Web.SCIM.Capabilities.MetaSchema.ResourceType (resourceSchema) where +module Web.Scim.Capabilities.MetaSchema.ResourceType (resourceSchema) where import Data.Aeson (Value) import Data.Aeson.QQ diff --git a/src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs b/src/Web/Scim/Capabilities/MetaSchema/SPConfig.hs similarity index 99% rename from src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs rename to src/Web/Scim/Capabilities/MetaSchema/SPConfig.hs index df85630afa3..67b111b29f0 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema/SPConfig.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/SPConfig.hs @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} -module Web.SCIM.Capabilities.MetaSchema.SPConfig (spConfigSchema) where +module Web.Scim.Capabilities.MetaSchema.SPConfig (spConfigSchema) where import Data.Aeson (Value) import Data.Aeson.QQ diff --git a/src/Web/SCIM/Capabilities/MetaSchema/Schema.hs b/src/Web/Scim/Capabilities/MetaSchema/Schema.hs similarity index 99% rename from src/Web/SCIM/Capabilities/MetaSchema/Schema.hs rename to src/Web/Scim/Capabilities/MetaSchema/Schema.hs index ab04ae38b2a..82792cc1f04 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema/Schema.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/Schema.hs @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} -module Web.SCIM.Capabilities.MetaSchema.Schema (metaSchema) where +module Web.Scim.Capabilities.MetaSchema.Schema (metaSchema) where import Data.Aeson (Value) import Data.Aeson.QQ diff --git a/src/Web/SCIM/Capabilities/MetaSchema/User.hs b/src/Web/Scim/Capabilities/MetaSchema/User.hs similarity index 99% rename from src/Web/SCIM/Capabilities/MetaSchema/User.hs rename to src/Web/Scim/Capabilities/MetaSchema/User.hs index 71efccd7a86..b5ca1490393 100644 --- a/src/Web/SCIM/Capabilities/MetaSchema/User.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/User.hs @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} -module Web.SCIM.Capabilities.MetaSchema.User (userSchema) where +module Web.Scim.Capabilities.MetaSchema.User (userSchema) where import Data.Aeson (Value) import Data.Aeson.QQ diff --git a/src/Web/SCIM/Class/Auth.hs b/src/Web/Scim/Class/Auth.hs similarity index 81% rename from src/Web/SCIM/Class/Auth.hs rename to src/Web/Scim/Class/Auth.hs index b8f423a9221..1976c33e635 100644 --- a/src/Web/SCIM/Class/Auth.hs +++ b/src/Web/Scim/Class/Auth.hs @@ -1,12 +1,12 @@ -- | HTTP authentication support. Can be used with basic auth, token-based -- auth, or something else (though OAuth is likely not implementable with -- this API). -module Web.SCIM.Class.Auth +module Web.Scim.Class.Auth ( AuthDB (..) ) where import Servant -import Web.SCIM.Handler +import Web.Scim.Handler -- | An interface that has to be implemented for a server to provide -- authentication. @@ -23,9 +23,9 @@ class FromHttpApiData (AuthData m) => AuthDB m where -- be the ID of that organization). type AuthInfo m - -- | Do authentication or throw an error in `SCIMHandler` (e.g. - -- 'Web.SCIM.Schema.Error.unauthorized') if the provided credentials are + -- | Do authentication or throw an error in `ScimHandler` (e.g. + -- 'Web.Scim.Schema.Error.unauthorized') if the provided credentials are -- invalid or don't correspond to any user. authCheck :: Maybe (AuthData m) - -> SCIMHandler m (AuthInfo m) + -> ScimHandler m (AuthInfo m) diff --git a/src/Web/SCIM/Class/Group.hs b/src/Web/Scim/Class/Group.hs similarity index 72% rename from src/Web/SCIM/Class/Group.hs rename to src/Web/Scim/Class/Group.hs index 8aaa1b7f94a..a9654fc891d 100644 --- a/src/Web/SCIM/Class/Group.hs +++ b/src/Web/Scim/Class/Group.hs @@ -1,4 +1,4 @@ -module Web.SCIM.Class.Group ( +module Web.Scim.Class.Group ( GroupSite (..) , GroupDB (..) , StoredGroup @@ -12,12 +12,12 @@ import Control.Monad import Data.Text import Data.Aeson import GHC.Generics (Generic) -import Web.SCIM.Schema.Common -import Web.SCIM.Schema.Error -import Web.SCIM.Schema.Meta -import Web.SCIM.ContentType -import Web.SCIM.Handler -import Web.SCIM.Class.Auth +import Web.Scim.Schema.Common +import Web.Scim.Schema.Error +import Web.Scim.Schema.Meta +import Web.Scim.ContentType +import Web.Scim.Handler +import Web.Scim.Class.Auth import Servant import Servant.API.Generic import Servant.Server.Generic @@ -76,19 +76,19 @@ data GroupSite route = GroupSite -- Methods used by the API class (Monad m, AuthDB m) => GroupDB m where - list :: AuthInfo m -> SCIMHandler m [StoredGroup] - get :: AuthInfo m -> GroupId -> SCIMHandler m (Maybe StoredGroup) - create :: AuthInfo m -> Group -> SCIMHandler m StoredGroup - update :: AuthInfo m -> GroupId -> Group -> SCIMHandler m StoredGroup - delete :: AuthInfo m -> GroupId -> SCIMHandler m Bool -- ^ Return 'False' if the group didn't exist - getGroupMeta :: AuthInfo m -> SCIMHandler m Meta + list :: AuthInfo m -> ScimHandler m [StoredGroup] + get :: AuthInfo m -> GroupId -> ScimHandler m (Maybe StoredGroup) + create :: AuthInfo m -> Group -> ScimHandler m StoredGroup + update :: AuthInfo m -> GroupId -> Group -> ScimHandler m StoredGroup + delete :: AuthInfo m -> GroupId -> ScimHandler m Bool -- ^ Return 'False' if the group didn't exist + getGroupMeta :: AuthInfo m -> ScimHandler m Meta ---------------------------------------------------------------------------- -- API handlers groupServer :: GroupDB m - => Maybe (AuthData m) -> GroupSite (AsServerT (SCIMHandler m)) + => Maybe (AuthData m) -> GroupSite (AsServerT (ScimHandler m)) groupServer authData = GroupSite { getGroups = do auth <- authCheck authData @@ -110,33 +110,33 @@ groupServer authData = GroupSite getGroups' :: GroupDB m - => AuthInfo m -> SCIMHandler m [StoredGroup] + => AuthInfo m -> ScimHandler m [StoredGroup] getGroups' auth = do list auth getGroup' :: GroupDB m - => AuthInfo m -> GroupId -> SCIMHandler m StoredGroup + => AuthInfo m -> GroupId -> ScimHandler m StoredGroup getGroup' auth gid = do maybeGroup <- get auth gid - maybe (throwSCIM (notFound "Group" gid)) pure maybeGroup + maybe (throwScim (notFound "Group" gid)) pure maybeGroup postGroup' :: GroupDB m - => AuthInfo m -> Group -> SCIMHandler m StoredGroup + => AuthInfo m -> Group -> ScimHandler m StoredGroup postGroup' auth gr = do create auth gr putGroup' :: GroupDB m - => AuthInfo m -> GroupId -> Group -> SCIMHandler m StoredGroup + => AuthInfo m -> GroupId -> Group -> ScimHandler m StoredGroup putGroup' auth gid gr = do update auth gid gr deleteGroup' :: GroupDB m - => AuthInfo m -> GroupId -> SCIMHandler m NoContent + => AuthInfo m -> GroupId -> ScimHandler m NoContent deleteGroup' auth gid = do deleted <- delete auth gid - unless deleted $ throwSCIM (notFound "Group" gid) + unless deleted $ throwScim (notFound "Group" gid) pure NoContent diff --git a/src/Web/SCIM/Class/User.hs b/src/Web/Scim/Class/User.hs similarity index 75% rename from src/Web/SCIM/Class/User.hs rename to src/Web/Scim/Class/User.hs index 6f93d9d8ac2..fd8dfdc2265 100644 --- a/src/Web/SCIM/Class/User.hs +++ b/src/Web/Scim/Class/User.hs @@ -1,4 +1,4 @@ -module Web.SCIM.Class.User +module Web.Scim.Class.User ( UserDB (..) , StoredUser , UserSite (..) @@ -9,15 +9,15 @@ import Control.Applicative ((<|>), Alternative) import Control.Monad import Data.Text import GHC.Generics (Generic) -import Web.SCIM.Schema.User hiding (schemas) -import Web.SCIM.Schema.Meta -import Web.SCIM.Schema.Common -import Web.SCIM.Schema.Error -import Web.SCIM.Schema.ListResponse hiding (schemas) -import Web.SCIM.Handler -import Web.SCIM.Filter -import Web.SCIM.ContentType -import Web.SCIM.Class.Auth +import Web.Scim.Schema.User hiding (schemas) +import Web.Scim.Schema.Meta +import Web.Scim.Schema.Common +import Web.Scim.Schema.Error +import Web.Scim.Schema.ListResponse hiding (schemas) +import Web.Scim.Handler +import Web.Scim.Filter +import Web.Scim.ContentType +import Web.Scim.Class.Auth import Servant import Servant.API.Generic import Servant.Server.Generic @@ -47,19 +47,19 @@ data UserSite route = UserSite -- TODO: parameterize UserId class (Monad m, AuthDB m) => UserDB m where - list :: AuthInfo m -> Maybe Filter -> SCIMHandler m (ListResponse StoredUser) - get :: AuthInfo m -> UserId -> SCIMHandler m (Maybe StoredUser) - create :: AuthInfo m -> User -> SCIMHandler m StoredUser - update :: AuthInfo m -> UserId -> User -> SCIMHandler m StoredUser - delete :: AuthInfo m -> UserId -> SCIMHandler m Bool -- ^ Return 'False' if the user didn't exist - getMeta :: AuthInfo m -> SCIMHandler m Meta + list :: AuthInfo m -> Maybe Filter -> ScimHandler m (ListResponse StoredUser) + get :: AuthInfo m -> UserId -> ScimHandler m (Maybe StoredUser) + create :: AuthInfo m -> User -> ScimHandler m StoredUser + update :: AuthInfo m -> UserId -> User -> ScimHandler m StoredUser + delete :: AuthInfo m -> UserId -> ScimHandler m Bool -- ^ Return 'False' if the user didn't exist + getMeta :: AuthInfo m -> ScimHandler m Meta ---------------------------------------------------------------------------- -- API handlers userServer :: UserDB m - => Maybe (AuthData m) -> UserSite (AsServerT (SCIMHandler m)) + => Maybe (AuthData m) -> UserSite (AsServerT (ScimHandler m)) userServer authData = UserSite { getUsers = \mbFilter -> do auth <- authCheck authData @@ -81,20 +81,20 @@ userServer authData = UserSite getUsers' :: UserDB m - => AuthInfo m -> Maybe Filter -> SCIMHandler m (ListResponse StoredUser) + => AuthInfo m -> Maybe Filter -> ScimHandler m (ListResponse StoredUser) getUsers' auth mbFilter = do list auth mbFilter getUser' :: UserDB m - => AuthInfo m -> UserId -> SCIMHandler m StoredUser + => AuthInfo m -> UserId -> ScimHandler m StoredUser getUser' auth uid = do maybeUser <- get auth uid - maybe (throwSCIM (notFound "User" uid)) pure maybeUser + maybe (throwScim (notFound "User" uid)) pure maybeUser postUser' :: UserDB m - => AuthInfo m -> User -> SCIMHandler m StoredUser + => AuthInfo m -> User -> ScimHandler m StoredUser postUser' auth user = do -- Find users with the same username (case-insensitive) -- @@ -104,26 +104,26 @@ postUser' auth user = do let filter_ = FilterAttrCompare AttrUserName OpEq (ValString (userName user)) stored <- list auth (Just filter_) when (totalResults stored > 0) $ - throwSCIM conflict + throwScim conflict create auth user putUser' :: UserDB m - => AuthInfo m -> UserId -> User -> SCIMHandler m StoredUser + => AuthInfo m -> UserId -> User -> ScimHandler m StoredUser putUser' auth uid updatedUser = do stored <- get auth uid case stored of Just (WithMeta _meta (WithId _ existing)) -> do let newUser = existing `overwriteWith` updatedUser update auth uid newUser - Nothing -> throwSCIM (notFound "User" uid) + Nothing -> throwScim (notFound "User" uid) deleteUser' :: UserDB m - => AuthInfo m -> UserId -> SCIMHandler m NoContent + => AuthInfo m -> UserId -> ScimHandler m NoContent deleteUser' auth uid = do deleted <- delete auth uid - unless deleted $ throwSCIM (notFound "User" uid) + unless deleted $ throwScim (notFound "User" uid) pure NoContent ---------------------------------------------------------------------------- diff --git a/src/Web/SCIM/ContentType.hs b/src/Web/Scim/ContentType.hs similarity index 95% rename from src/Web/SCIM/ContentType.hs rename to src/Web/Scim/ContentType.hs index 6ca10f11b0b..f8a0cb68fec 100644 --- a/src/Web/SCIM/ContentType.hs +++ b/src/Web/Scim/ContentType.hs @@ -6,7 +6,7 @@ -- This module contains helpers for handling it. Basically, just write -- 'SCIM' instead of 'JSON' in all Servant routes. -module Web.SCIM.ContentType (SCIM) where +module Web.Scim.ContentType (SCIM) where import Data.Proxy import Data.List.NonEmpty diff --git a/src/Web/SCIM/Filter.hs b/src/Web/Scim/Filter.hs similarity index 99% rename from src/Web/SCIM/Filter.hs rename to src/Web/Scim/Filter.hs index e3df4b23026..9c92e2a906d 100644 --- a/src/Web/SCIM/Filter.hs +++ b/src/Web/Scim/Filter.hs @@ -14,7 +14,7 @@ -- * Combined filters -- * Fully qualified attribute names (schema prefixes, attribute paths) -module Web.SCIM.Filter +module Web.Scim.Filter ( -- * Filter type Filter(..) @@ -41,7 +41,7 @@ import Data.Aeson as Aeson import Lens.Micro import Web.HttpApiData -import Web.SCIM.Schema.User +import Web.Scim.Schema.User ---------------------------------------------------------------------------- -- Types diff --git a/src/Web/Scim/Handler.hs b/src/Web/Scim/Handler.hs new file mode 100644 index 00000000000..841bb379fc8 --- /dev/null +++ b/src/Web/Scim/Handler.hs @@ -0,0 +1,30 @@ +module Web.Scim.Handler + ( ScimHandler + , throwScim + , fromScimHandler + ) where + +import Control.Monad.Except +import Web.Scim.Schema.Error + +-- | Handler type for SCIM. All errors will be thrown via 'ExceptT'. +type ScimHandler m = ExceptT ScimError m + +-- | Throw a 'ScimError'. +throwScim :: Monad m => ScimError -> ScimHandler m a +throwScim = throwError + +-- | A natural transformation for Servant handlers. To use it, you need to +-- provide a way to throw errors in the underlying @m@ monad. +-- +-- We can't use something like 'MonadError' to throw errors in @m@ because +-- 'MonadError' allows only one type of errors per monad and @m@ might have +-- one already. +-- +-- You can either do something custom for 'ScimError', or use +-- 'scimToServantErr'. +fromScimHandler + :: Monad m + => (forall a. ScimError -> m a) + -> (forall a. ScimHandler m a -> m a) +fromScimHandler fromError = either fromError pure <=< runExceptT diff --git a/src/Web/SCIM/Schema/AuthenticationScheme.hs b/src/Web/Scim/Schema/AuthenticationScheme.hs similarity index 96% rename from src/Web/SCIM/Schema/AuthenticationScheme.hs rename to src/Web/Scim/Schema/AuthenticationScheme.hs index 98b23737d08..70fc0a4faef 100644 --- a/src/Web/SCIM/Schema/AuthenticationScheme.hs +++ b/src/Web/Scim/Schema/AuthenticationScheme.hs @@ -1,12 +1,12 @@ {-# LANGUAGE QuasiQuotes #-} -module Web.SCIM.Schema.AuthenticationScheme +module Web.Scim.Schema.AuthenticationScheme ( AuthenticationScheme(..) , AuthenticationSchemeEncoding , authHttpBasicEncoding ) where -import Web.SCIM.Schema.Common +import Web.Scim.Schema.Common import Data.Aeson import Data.Text diff --git a/src/Web/SCIM/Schema/Common.hs b/src/Web/Scim/Schema/Common.hs similarity index 98% rename from src/Web/SCIM/Schema/Common.hs rename to src/Web/Scim/Schema/Common.hs index e5518e77845..29d25157d59 100644 --- a/src/Web/SCIM/Schema/Common.hs +++ b/src/Web/Scim/Schema/Common.hs @@ -1,5 +1,5 @@ -module Web.SCIM.Schema.Common where +module Web.Scim.Schema.Common where import Data.Text hiding (dropWhile) import Data.Aeson diff --git a/src/Web/SCIM/Schema/Error.hs b/src/Web/Scim/Schema/Error.hs similarity index 87% rename from src/Web/SCIM/Schema/Error.hs rename to src/Web/Scim/Schema/Error.hs index 2dbaac969ac..1afad8df9d9 100644 --- a/src/Web/SCIM/Schema/Error.hs +++ b/src/Web/Scim/Schema/Error.hs @@ -1,9 +1,9 @@ -- | SCIM errors -module Web.SCIM.Schema.Error +module Web.Scim.Schema.Error ( -- * Types - SCIMErrorType(..) - , SCIMError(..) + ScimErrorType(..) + , ScimError(..) , Status(..) -- * Constructors @@ -20,8 +20,8 @@ module Web.SCIM.Schema.Error import Data.Text (Text, pack) import Data.Aeson hiding (Error) import Control.Exception -import Web.SCIM.Schema.Common -import Web.SCIM.Schema.Schema +import Web.Scim.Schema.Common +import Web.Scim.Schema.Schema import Servant (ServantErr (..)) import GHC.Generics (Generic) @@ -30,11 +30,11 @@ import GHC.Generics (Generic) -- Types -- | An ADT for error types in the SCIM specification. Not all possible SCIM --- errors have a corresponding 'SCIMErrorType' (for instance, authorization +-- errors have a corresponding 'ScimErrorType' (for instance, authorization -- is not covered by this type). -- -- See -data SCIMErrorType +data ScimErrorType = InvalidFilter | TooMany | Uniqueness @@ -47,7 +47,7 @@ data SCIMErrorType | Sensitive deriving (Show, Eq, Generic) -instance ToJSON SCIMErrorType where +instance ToJSON ScimErrorType where toJSON InvalidFilter = "invalidFilter" toJSON TooMany = "tooMany" toJSON Uniqueness = "uniqueness" @@ -66,27 +66,27 @@ newtype Status = Status {unStatus :: Int} instance ToJSON Status where toJSON (Status stat) = String . pack . show $ stat -data SCIMError = SCIMError +data ScimError = ScimError { schemas :: [Schema] , status :: Status - , scimType :: Maybe SCIMErrorType + , scimType :: Maybe ScimErrorType , detail :: Maybe Text } deriving (Show, Eq, Generic) -instance ToJSON SCIMError where +instance ToJSON ScimError where toJSON = genericToJSON serializeOptions -instance Exception SCIMError +instance Exception ScimError ---------------------------------------------------------------------------- -- Constructors badRequest - :: SCIMErrorType -- ^ Error type + :: ScimErrorType -- ^ Error type -> Maybe Text -- ^ Error details - -> SCIMError + -> ScimError badRequest typ mbDetail = - SCIMError + ScimError { schemas = [Error2_0] , status = Status 400 , scimType = pure typ @@ -96,18 +96,18 @@ badRequest typ mbDetail = notFound :: Text -- ^ Resource type -> Text -- ^ Resource ID - -> SCIMError + -> ScimError notFound resourceType resourceId = - SCIMError + ScimError { schemas = [Error2_0] , status = Status 404 , scimType = Nothing , detail = pure $ resourceType <> " '" <> resourceId <> "' not found" } -conflict :: SCIMError +conflict :: ScimError conflict = - SCIMError + ScimError { schemas = [Error2_0] , status = Status 409 , scimType = Just Uniqueness @@ -116,9 +116,9 @@ conflict = unauthorized :: Text -- ^ Error details - -> SCIMError + -> ScimError unauthorized details = - SCIMError + ScimError { schemas = [Error2_0] , status = Status 401 , scimType = Nothing @@ -127,9 +127,9 @@ unauthorized details = serverError :: Text -- ^ Error details - -> SCIMError + -> ScimError serverError details = - SCIMError + ScimError { schemas = [Error2_0] , status = Status 500 , scimType = Nothing @@ -141,7 +141,7 @@ serverError details = -- | Convert a SCIM 'Error' to a Servant one by encoding it with the -- appropriate headers. -scimToServantErr :: SCIMError -> ServantErr +scimToServantErr :: ScimError -> ServantErr scimToServantErr err = ServantErr { errHTTPCode = unStatus (status err) diff --git a/src/Web/SCIM/Schema/ListResponse.hs b/src/Web/Scim/Schema/ListResponse.hs similarity index 93% rename from src/Web/SCIM/Schema/ListResponse.hs rename to src/Web/Scim/Schema/ListResponse.hs index 312664303e9..09fe4f6ae20 100644 --- a/src/Web/SCIM/Schema/ListResponse.hs +++ b/src/Web/Scim/Schema/ListResponse.hs @@ -1,14 +1,14 @@ {-# LANGUAGE RecordWildCards #-} -module Web.SCIM.Schema.ListResponse +module Web.Scim.Schema.ListResponse ( ListResponse(..) , fromList ) where import Data.Aeson import GHC.Generics (Generic) -import Web.SCIM.Schema.Common -import Web.SCIM.Schema.Schema +import Web.Scim.Schema.Common +import Web.Scim.Schema.Schema -- | A "pagination" type used as a wrapper whenever a SCIM endpoint has to -- return a list. @@ -49,4 +49,3 @@ instance ToJSON a => ToJSON (ListResponse a) where , "itemsPerPage" .= itemsPerPage , "startIndex" .= startIndex ] - diff --git a/src/Web/SCIM/Schema/Meta.hs b/src/Web/Scim/Schema/Meta.hs similarity index 93% rename from src/Web/SCIM/Schema/Meta.hs rename to src/Web/Scim/Schema/Meta.hs index 98ac4423320..5019983752c 100644 --- a/src/Web/SCIM/Schema/Meta.hs +++ b/src/Web/Scim/Schema/Meta.hs @@ -1,5 +1,5 @@ -module Web.SCIM.Schema.Meta where +module Web.Scim.Schema.Meta where import Prelude hiding (map) @@ -7,8 +7,8 @@ import Data.Text (Text, unpack, pack) import qualified Data.Text as Text import Text.Read (readEither) import Data.Aeson -import Web.SCIM.Schema.Common -import Web.SCIM.Schema.ResourceType +import Web.Scim.Schema.Common +import Web.Scim.Schema.ResourceType import GHC.Generics (Generic) import qualified Data.HashMap.Lazy as HML import Data.Time.Clock diff --git a/src/Web/SCIM/Schema/ResourceType.hs b/src/Web/Scim/Schema/ResourceType.hs similarity index 92% rename from src/Web/SCIM/Schema/ResourceType.hs rename to src/Web/Scim/Schema/ResourceType.hs index c791fe2753e..f542580d351 100644 --- a/src/Web/SCIM/Schema/ResourceType.hs +++ b/src/Web/Scim/Schema/ResourceType.hs @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} -module Web.SCIM.Schema.ResourceType where +module Web.Scim.Schema.ResourceType where import Prelude hiding (map) @@ -8,8 +8,8 @@ import Data.Text (Text) import Data.Aeson import Network.URI.Static -import Web.SCIM.Schema.Common -import Web.SCIM.Schema.Schema (Schema(..)) +import Web.Scim.Schema.Common +import Web.Scim.Schema.Schema (Schema(..)) import GHC.Generics (Generic) diff --git a/src/Web/SCIM/Schema/Schema.hs b/src/Web/Scim/Schema/Schema.hs similarity index 87% rename from src/Web/SCIM/Schema/Schema.hs rename to src/Web/Scim/Schema/Schema.hs index 72a58ad423d..8bc8d45040d 100644 --- a/src/Web/SCIM/Schema/Schema.hs +++ b/src/Web/Scim/Schema/Schema.hs @@ -1,11 +1,11 @@ -module Web.SCIM.Schema.Schema where +module Web.Scim.Schema.Schema where -import Web.SCIM.Capabilities.MetaSchema.User -import Web.SCIM.Capabilities.MetaSchema.SPConfig -import Web.SCIM.Capabilities.MetaSchema.Group -import Web.SCIM.Capabilities.MetaSchema.Schema -import Web.SCIM.Capabilities.MetaSchema.ResourceType +import Web.Scim.Capabilities.MetaSchema.User +import Web.Scim.Capabilities.MetaSchema.SPConfig +import Web.Scim.Capabilities.MetaSchema.Group +import Web.Scim.Capabilities.MetaSchema.Schema +import Web.Scim.Capabilities.MetaSchema.ResourceType import Data.Text import Data.Aeson diff --git a/src/Web/SCIM/Schema/User.hs b/src/Web/Scim/Schema/User.hs similarity index 78% rename from src/Web/SCIM/Schema/User.hs rename to src/Web/Scim/Schema/User.hs index 8f05f556da2..70b5feec341 100644 --- a/src/Web/SCIM/Schema/User.hs +++ b/src/Web/Scim/Schema/User.hs @@ -1,20 +1,20 @@ -module Web.SCIM.Schema.User where +module Web.Scim.Schema.User where import Prelude hiding (map) import Data.Text (Text) import Data.Aeson -import Web.SCIM.Schema.Common -import Web.SCIM.Schema.Schema (Schema(..)) -import Web.SCIM.Schema.User.Address (Address) -import Web.SCIM.Schema.User.Certificate (Certificate) -import Web.SCIM.Schema.User.Email (Email) -import Web.SCIM.Schema.User.IM (IM) -import Web.SCIM.Schema.User.Name (Name) -import Web.SCIM.Schema.User.Phone (Phone) -import Web.SCIM.Schema.User.Photo (Photo) +import Web.Scim.Schema.Common +import Web.Scim.Schema.Schema (Schema(..)) +import Web.Scim.Schema.User.Address (Address) +import Web.Scim.Schema.User.Certificate (Certificate) +import Web.Scim.Schema.User.Email (Email) +import Web.Scim.Schema.User.IM (IM) +import Web.Scim.Schema.User.Name (Name) +import Web.Scim.Schema.User.Phone (Phone) +import Web.Scim.Schema.User.Photo (Photo) import GHC.Generics (Generic) diff --git a/src/Web/SCIM/Schema/User/Address.hs b/src/Web/Scim/Schema/User/Address.hs similarity index 89% rename from src/Web/SCIM/Schema/User/Address.hs rename to src/Web/Scim/Schema/User/Address.hs index 002fc6bcca5..be980f1992d 100644 --- a/src/Web/SCIM/Schema/User/Address.hs +++ b/src/Web/Scim/Schema/User/Address.hs @@ -1,10 +1,10 @@ -module Web.SCIM.Schema.User.Address where +module Web.Scim.Schema.User.Address where import Data.Text hiding (dropWhile) import Data.Aeson import GHC.Generics (Generic) -import Web.SCIM.Schema.Common +import Web.Scim.Schema.Common data Address = Address { formatted :: Maybe Text diff --git a/src/Web/SCIM/Schema/User/Certificate.hs b/src/Web/Scim/Schema/User/Certificate.hs similarity index 82% rename from src/Web/SCIM/Schema/User/Certificate.hs rename to src/Web/Scim/Schema/User/Certificate.hs index f76bb4edbbf..eaee117d29b 100644 --- a/src/Web/SCIM/Schema/User/Certificate.hs +++ b/src/Web/Scim/Schema/User/Certificate.hs @@ -1,11 +1,11 @@ -module Web.SCIM.Schema.User.Certificate where +module Web.Scim.Schema.User.Certificate where import Data.Text (Text) import Data.Aeson import GHC.Generics -import Web.SCIM.Schema.Common +import Web.Scim.Schema.Common data Certificate = Certificate diff --git a/src/Web/SCIM/Schema/User/Email.hs b/src/Web/Scim/Schema/User/Email.hs similarity index 92% rename from src/Web/SCIM/Schema/User/Email.hs rename to src/Web/Scim/Schema/User/Email.hs index d51e27a1d1a..b913ad40094 100644 --- a/src/Web/SCIM/Schema/User/Email.hs +++ b/src/Web/Scim/Schema/User/Email.hs @@ -1,11 +1,11 @@ -module Web.SCIM.Schema.User.Email where +module Web.Scim.Schema.User.Email where import Data.Text hiding (dropWhile) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Aeson import GHC.Generics (Generic) -import Web.SCIM.Schema.Common +import Web.Scim.Schema.Common import Text.Email.Validate newtype EmailAddress2 = EmailAddress2 diff --git a/src/Web/SCIM/Schema/User/IM.hs b/src/Web/Scim/Schema/User/IM.hs similarity index 82% rename from src/Web/SCIM/Schema/User/IM.hs rename to src/Web/Scim/Schema/User/IM.hs index b83250dbe99..0eeecdc5fea 100644 --- a/src/Web/SCIM/Schema/User/IM.hs +++ b/src/Web/Scim/Schema/User/IM.hs @@ -1,11 +1,11 @@ -module Web.SCIM.Schema.User.IM where +module Web.Scim.Schema.User.IM where import Data.Text (Text) import Data.Aeson import GHC.Generics -import Web.SCIM.Schema.Common +import Web.Scim.Schema.Common data IM = IM { typ :: Maybe Text diff --git a/src/Web/SCIM/Schema/User/Name.hs b/src/Web/Scim/Schema/User/Name.hs similarity index 86% rename from src/Web/SCIM/Schema/User/Name.hs rename to src/Web/Scim/Schema/User/Name.hs index 2a5ce72805f..f7981182b1a 100644 --- a/src/Web/SCIM/Schema/User/Name.hs +++ b/src/Web/Scim/Schema/User/Name.hs @@ -1,11 +1,11 @@ -module Web.SCIM.Schema.User.Name where +module Web.Scim.Schema.User.Name where import Data.Text (Text) import Data.Aeson import GHC.Generics -import Web.SCIM.Schema.Common +import Web.Scim.Schema.Common data Name = Name { formatted :: Maybe Text diff --git a/src/Web/SCIM/Schema/User/Phone.hs b/src/Web/Scim/Schema/User/Phone.hs similarity index 83% rename from src/Web/SCIM/Schema/User/Phone.hs rename to src/Web/Scim/Schema/User/Phone.hs index 1c4375f634e..947990fa887 100644 --- a/src/Web/SCIM/Schema/User/Phone.hs +++ b/src/Web/Scim/Schema/User/Phone.hs @@ -1,10 +1,10 @@ -module Web.SCIM.Schema.User.Phone where +module Web.Scim.Schema.User.Phone where import Data.Text hiding (dropWhile) import Data.Aeson import GHC.Generics (Generic) -import Web.SCIM.Schema.Common +import Web.Scim.Schema.Common data Phone = Phone { typ :: Maybe Text diff --git a/src/Web/SCIM/Schema/User/Photo.hs b/src/Web/Scim/Schema/User/Photo.hs similarity index 82% rename from src/Web/SCIM/Schema/User/Photo.hs rename to src/Web/Scim/Schema/User/Photo.hs index c6e501f0744..1565c09a10a 100644 --- a/src/Web/SCIM/Schema/User/Photo.hs +++ b/src/Web/Scim/Schema/User/Photo.hs @@ -1,10 +1,10 @@ -module Web.SCIM.Schema.User.Photo where +module Web.Scim.Schema.User.Photo where import Data.Text (Text) import Data.Aeson import GHC.Generics -import Web.SCIM.Schema.Common +import Web.Scim.Schema.Common data Photo = Photo { typ :: Maybe Text diff --git a/src/Web/SCIM/Server.hs b/src/Web/Scim/Server.hs similarity index 78% rename from src/Web/SCIM/Server.hs rename to src/Web/Scim/Server.hs index d84bad2926c..41db69ae5fb 100644 --- a/src/Web/SCIM/Server.hs +++ b/src/Web/Scim/Server.hs @@ -1,4 +1,4 @@ -module Web.SCIM.Server +module Web.Scim.Server ( -- * WAI application app, mkapp, App @@ -11,11 +11,11 @@ module Web.SCIM.Server , GroupAPI, groupServer ) where -import Web.SCIM.Class.User (UserSite (..), UserDB, userServer) -import Web.SCIM.Class.Group (GroupSite (..), GroupDB, groupServer) -import Web.SCIM.Class.Auth (AuthDB (..)) -import Web.SCIM.Capabilities.MetaSchema (ConfigSite, Configuration, configServer) -import Web.SCIM.Handler +import Web.Scim.Class.User (UserSite (..), UserDB, userServer) +import Web.Scim.Class.Group (GroupSite (..), GroupDB, groupServer) +import Web.Scim.Class.Auth (AuthDB (..)) +import Web.Scim.Capabilities.MetaSchema (ConfigSite, Configuration, configServer) +import Web.Scim.Handler import GHC.Generics (Generic) import Network.Wai import Servant @@ -48,7 +48,7 @@ data Site authData route = Site siteServer :: forall m. DB m => - Configuration -> Site (AuthData m) (AsServerT (SCIMHandler m)) + Configuration -> Site (AuthData m) (AsServerT (ScimHandler m)) siteServer conf = Site { config = toServant $ configServer conf , users = \authData -> toServant (userServer authData) @@ -66,8 +66,8 @@ type App m api = mkapp :: forall m api. (App m api) => Proxy api - -> ServerT api (SCIMHandler m) - -> (forall a. SCIMHandler m a -> Handler a) + -> ServerT api (ScimHandler m) + -> (forall a. ScimHandler m a -> Handler a) -> Application mkapp proxy api nt = serve proxy $ @@ -75,6 +75,6 @@ mkapp proxy api nt = app :: forall m. App m (SiteAPI (AuthData m)) => Configuration - -> (forall a. SCIMHandler m a -> Handler a) + -> (forall a. ScimHandler m a -> Handler a) -> Application app c = mkapp (Proxy @(SiteAPI (AuthData m))) (toServant $ siteServer c) diff --git a/src/Web/SCIM/Server/Mock.hs b/src/Web/Scim/Server/Mock.hs similarity index 81% rename from src/Web/SCIM/Server/Mock.hs rename to src/Web/Scim/Server/Mock.hs index 1791000ae7b..18955e00521 100644 --- a/src/Web/SCIM/Server/Mock.hs +++ b/src/Web/Scim/Server/Mock.hs @@ -4,11 +4,11 @@ -- compliance testing (e.g. with Runscope – see -- ). -module Web.SCIM.Server.Mock where +module Web.Scim.Server.Mock where -import Web.SCIM.Class.Group hiding (value) -import Web.SCIM.Class.User -import Web.SCIM.Class.Auth +import Web.Scim.Class.Group hiding (value) +import Web.Scim.Class.User +import Web.Scim.Class.Auth import Control.Monad.STM (STM, atomically) import Control.Monad.Reader import Control.Monad.Morph @@ -18,15 +18,15 @@ import Data.Time.Calendar import GHC.Exts (sortWith) import ListT import qualified STMContainers.Map as STMMap -import Web.SCIM.Schema.User -import Web.SCIM.Schema.Error -import Web.SCIM.Schema.Meta -import Web.SCIM.Schema.ListResponse -import Web.SCIM.Schema.ResourceType -import Web.SCIM.Schema.Common (WithId(WithId, value)) -import qualified Web.SCIM.Schema.Common as Common -import Web.SCIM.Filter -import Web.SCIM.Handler +import Web.Scim.Schema.User +import Web.Scim.Schema.Error +import Web.Scim.Schema.Meta +import Web.Scim.Schema.ListResponse +import Web.Scim.Schema.ResourceType +import Web.Scim.Schema.Common (WithId(WithId, value)) +import qualified Web.Scim.Schema.Common as Common +import Web.Scim.Filter +import Web.Scim.Handler import Servant type UserStorage = STMMap.Map Text StoredUser @@ -66,7 +66,7 @@ instance UserDB TestServer where let user' = value (thing user) -- unwrap case filterUser filter_ user' of Right res -> pure res - Left err -> throwSCIM (badRequest InvalidFilter (Just err)) + Left err -> throwScim (badRequest InvalidFilter (Just err)) fromList . sortWith (Common.id . thing) <$> filterM check (snd <$> users) get () i = do @@ -111,9 +111,9 @@ instance AuthDB TestServer where type AuthInfo TestServer = () authCheck = \case Just "authorized" -> pure () - _ -> throwSCIM (unauthorized "expected 'authorized'") + _ -> throwScim (unauthorized "expected 'authorized'") -insertGroup :: Group -> Meta -> GroupStorage -> SCIMHandler STM StoredGroup +insertGroup :: Group -> Meta -> GroupStorage -> ScimHandler STM StoredGroup insertGroup grp met storage = do size <- lift $ STMMap.size storage let gid = pack . show $ size @@ -121,22 +121,22 @@ insertGroup grp met storage = do lift $ STMMap.insert newGroup gid storage return newGroup -updateGroup :: GroupId -> Group -> GroupStorage -> SCIMHandler STM StoredGroup +updateGroup :: GroupId -> Group -> GroupStorage -> ScimHandler STM StoredGroup updateGroup gid grp storage = do existing <- lift $ STMMap.lookup gid storage case existing of - Nothing -> throwSCIM (notFound "Group" gid) + Nothing -> throwScim (notFound "Group" gid) Just stored -> do let newMeta = meta stored newGroup = WithMeta newMeta $ WithId gid grp lift $ STMMap.insert newGroup gid storage pure newGroup -updateUser :: UserId -> User -> UserStorage -> SCIMHandler STM StoredUser +updateUser :: UserId -> User -> UserStorage -> ScimHandler STM StoredUser updateUser uid user storage = do existing <- lift $ STMMap.lookup uid storage case existing of - Nothing -> throwSCIM (notFound "User" uid) + Nothing -> throwScim (notFound "User" uid) Just stored -> do let newMeta = meta stored newUser = WithMeta newMeta $ WithId uid user @@ -147,14 +147,14 @@ updateUser uid user storage = do assertMutability :: User -> StoredUser -> Bool assertMutability _newUser _stored = True -delGroup :: GroupId -> GroupStorage -> SCIMHandler STM Bool +delGroup :: GroupId -> GroupStorage -> ScimHandler STM Bool delGroup gid storage = do g <- lift $ STMMap.lookup gid storage case g of Nothing -> return False Just _ -> lift $ STMMap.delete gid storage >> return True -delUser :: UserId -> UserStorage -> SCIMHandler STM Bool +delUser :: UserId -> UserStorage -> ScimHandler STM Bool delUser uid storage = do u <- lift $ STMMap.lookup uid storage case u of @@ -179,7 +179,7 @@ createMeta rType = Meta } -- insert with a simple incrementing integer id (good for testing) -insertUser :: User -> Meta -> UserStorage -> SCIMHandler STM StoredUser +insertUser :: User -> Meta -> UserStorage -> ScimHandler STM StoredUser insertUser user met storage = do size <- lift $ STMMap.size storage let uid = pack . show $ size @@ -189,7 +189,7 @@ insertUser user met storage = do -- Natural transformation from our transformer stack to the Servant stack -- this takes the initial environment and returns the transformation -nt :: TestStorage -> SCIMHandler TestServer a -> Handler a +nt :: TestStorage -> ScimHandler TestServer a -> Handler a nt storage = flip runReaderT storage . - fromSCIMHandler (lift . throwError . scimToServantErr) + fromScimHandler (lift . throwError . scimToServantErr) diff --git a/test/Test/Capabilities/MetaSchemaSpec.hs b/test/Test/Capabilities/MetaSchemaSpec.hs index d6d5c0881e4..7e899e289e6 100644 --- a/test/Test/Capabilities/MetaSchemaSpec.hs +++ b/test/Test/Capabilities/MetaSchemaSpec.hs @@ -8,9 +8,9 @@ import qualified Data.List as List import Data.Aeson import Data.Text (Text) import Data.Coerce -import Web.SCIM.Capabilities.MetaSchema -import Web.SCIM.Server (ConfigAPI, mkapp) -import Web.SCIM.Server.Mock +import Web.Scim.Capabilities.MetaSchema +import Web.Scim.Server (ConfigAPI, mkapp) +import Web.Scim.Server.Mock import Network.Wai.Test (SResponse (..)) import Servant import Servant.API.Generic diff --git a/test/Test/Class/AuthSpec.hs b/test/Test/Class/AuthSpec.hs index f644e608991..9f2d0597d4e 100644 --- a/test/Test/Class/AuthSpec.hs +++ b/test/Test/Class/AuthSpec.hs @@ -2,9 +2,9 @@ module Test.Class.AuthSpec (spec) where -import Web.SCIM.Server (app) -import Web.SCIM.Server.Mock -import Web.SCIM.Capabilities.MetaSchema (empty) +import Web.Scim.Server (app) +import Web.Scim.Server.Mock +import Web.Scim.Capabilities.MetaSchema (empty) import Data.Text (Text) import Data.Text.Encoding import Test.Hspec diff --git a/test/Test/Class/GroupSpec.hs b/test/Test/Class/GroupSpec.hs index 9b1d0acc940..d7de49be1ca 100644 --- a/test/Test/Class/GroupSpec.hs +++ b/test/Test/Class/GroupSpec.hs @@ -6,8 +6,8 @@ import Test.Util import Network.Wai (Application) import Servant (Proxy(Proxy)) -import Web.SCIM.Server (mkapp, GroupAPI, groupServer) -import Web.SCIM.Server.Mock +import Web.Scim.Server (mkapp, GroupAPI, groupServer) +import Web.Scim.Server.Mock import Data.ByteString.Lazy (ByteString) import Test.Hspec hiding (shouldSatisfy) import Test.Hspec.Wai hiding (post, put, patch) diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index 0dd74ad364c..7985c0ffa0a 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -4,8 +4,8 @@ module Test.Class.UserSpec (spec) where import Test.Util -import Web.SCIM.Server (mkapp, UserAPI, userServer) -import Web.SCIM.Server.Mock +import Web.Scim.Server (mkapp, UserAPI, userServer) +import Web.Scim.Server.Mock import Test.Hspec import Test.Hspec.Wai hiding (post, put, patch) import Data.ByteString.Lazy (ByteString) diff --git a/test/Test/FilterSpec.hs b/test/Test/FilterSpec.hs index 62d53d2c053..592fbfd968e 100644 --- a/test/Test/FilterSpec.hs +++ b/test/Test/FilterSpec.hs @@ -2,7 +2,7 @@ module Test.FilterSpec (spec) where -import Web.SCIM.Filter +import Web.Scim.Filter import Test.Hspec import HaskellWorks.Hspec.Hedgehog From 53db8029e17e7085322e7055f71efb5e7058d4a5 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Wed, 23 Jan 2019 14:07:31 +0100 Subject: [PATCH 22/64] Don't merge fields in PUT /Users (#23) * Clarify 'version' * Don't merge fields in PUT /Users * Fix a warning * Redo User serialization * More tests for new User serialization --- server/Main.hs | 2 +- src/Web/Scim/Class/User.hs | 52 ++------- src/Web/Scim/Schema/Meta.hs | 9 ++ src/Web/Scim/Schema/User.hs | 146 +++++++++++++++++++----- test/Test/Class/UserSpec.hs | 2 +- test/Test/Schema/UserSpec.hs | 212 +++++++++++++++++++++++++++++++++++ test/Test/Util.hs | 3 + 7 files changed, 359 insertions(+), 67 deletions(-) create mode 100644 test/Test/Schema/UserSpec.hs diff --git a/server/Main.hs b/server/Main.hs index 5d6f0605dd0..da04fec41da 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -61,7 +61,7 @@ mkUserDB = do , honorificSuffix = Nothing } , active = Just True - , emails = Just [email] + , emails = [email] } atomically $ STMMap.insert (WithMeta meta (WithId "elton" user)) "elton" db pure db diff --git a/src/Web/Scim/Class/User.hs b/src/Web/Scim/Class/User.hs index fd8dfdc2265..1922642f960 100644 --- a/src/Web/Scim/Class/User.hs +++ b/src/Web/Scim/Class/User.hs @@ -5,11 +5,10 @@ module Web.Scim.Class.User , userServer ) where -import Control.Applicative ((<|>), Alternative) import Control.Monad import Data.Text import GHC.Generics (Generic) -import Web.Scim.Schema.User hiding (schemas) +import Web.Scim.Schema.User import Web.Scim.Schema.Meta import Web.Scim.Schema.Common import Web.Scim.Schema.Error @@ -107,15 +106,22 @@ postUser' auth user = do throwScim conflict create auth user +-- | Fully update a 'User'. +-- +-- Spec: . +-- +-- FUTUREWORK: according to the spec, we should handle cases where someone +-- attempts to overwrite @readOnly@ and @immutable@ attributes. Currently we +-- don't have any such attributes. +-- +-- See . putUser' :: UserDB m => AuthInfo m -> UserId -> User -> ScimHandler m StoredUser -putUser' auth uid updatedUser = do +putUser' auth uid user = do stored <- get auth uid case stored of - Just (WithMeta _meta (WithId _ existing)) -> do - let newUser = existing `overwriteWith` updatedUser - update auth uid newUser + Just _ -> update auth uid user Nothing -> throwScim (notFound "User" uid) deleteUser' @@ -125,37 +131,3 @@ deleteUser' auth uid = do deleted <- delete auth uid unless deleted $ throwScim (notFound "User" uid) pure NoContent - ----------------------------------------------------------------------------- --- Utilities - -overwriteWith :: User -> User -> User -overwriteWith old new = old - { --externalId :: Unsettable Text - name = merge name - , displayName = merge displayName - , nickName = merge nickName - , profileUrl = merge profileUrl - , title = merge title - , userType = merge userType - , preferredLanguage = merge preferredLanguage - , locale = merge locale - , active = merge active - , password = merge password - , emails = mergeList emails - , phoneNumbers = mergeList phoneNumbers - , ims = mergeList ims - , photos = mergeList photos - , addresses = mergeList addresses - , entitlements = mergeList entitlements - , roles = mergeList roles - , x509Certificates = mergeList x509Certificates - } - where - merge :: (Alternative f) => (User -> f a) -> f a - merge accessor = (accessor new) <|> (accessor old) - - mergeList :: (User -> Maybe [a]) -> Maybe [a] - mergeList accessor = case accessor new of - Just [] -> accessor old - _ -> (accessor new) <|> (accessor old) diff --git a/src/Web/Scim/Schema/Meta.hs b/src/Web/Scim/Schema/Meta.hs index 5019983752c..924a84b0416 100644 --- a/src/Web/Scim/Schema/Meta.hs +++ b/src/Web/Scim/Schema/Meta.hs @@ -34,6 +34,15 @@ data Meta = Meta { resourceType :: ResourceType , created :: UTCTime , lastModified :: UTCTime + -- | Resource version: . + -- + -- A version is an /opaque/ string that doesn't need to conform to any + -- format (e.g. it does not have to be a monotonically increasing integer, + -- contrary to what the word @version@ suggests). + -- + -- For 'Weak' versions we have to guarantee that different resources will + -- have different 'version's. For 'Strong' versions we also have to + -- guarantee that same resources will have the same 'version'. , version :: ETag , location :: URI } deriving (Eq, Show, Generic) diff --git a/src/Web/Scim/Schema/User.hs b/src/Web/Scim/Schema/User.hs index 70b5feec341..db1befb3e81 100644 --- a/src/Web/Scim/Schema/User.hs +++ b/src/Web/Scim/Schema/User.hs @@ -1,10 +1,48 @@ +{-# LANGUAGE RecordWildCards #-} +-- | SCIM user representation. +-- +-- = Our interpretation of the spec +-- +-- The spec can be read at . +-- While implementing the spec we had to resolve some ambiguities and place some +-- additional constraints on the possible SCIM server behavior we can support. +-- +-- == Resource ID / user ID +-- +-- The 'User' object doesn't contain a user ID (as in "opaque server-assigned +-- immutable ID") by design. IDs and metadata are added to types in a uniform +-- fashion by using @WithId@ and @WithMeta@. +-- +-- == Optional fields +-- +-- The spec doesn't say which fields should be optional and which shouldn't, and +-- in theory every SCIM server can decide for itself which fields it will +-- consider optional (as long as it makes it clear in the resource schema). +-- Currently we don't provide any control over this; all fields are optional +-- except for @userName@. +-- +-- TODO: why @userName@? +-- +-- == Multi-valued fields +-- +-- When a multi-valued field (e.g. @emails@) doesn't contain any values, it's +-- unclear whether we should serialize it as @[]@ or omit it entirely. We have +-- opted for the latter to conform to an example in the spec: +-- . +-- +-- == Field names +-- +-- When parsing JSON objects, we ignore capitalization differences in field +-- names -- e.g. both @USERNAME@ and @userName@ are accepted. This behavior is +-- not prescribed by the spec, but it allows us to work with buggy SCIM +-- implementations. module Web.Scim.Schema.User where -import Prelude hiding (map) - -import Data.Text (Text) +import Data.Text (Text, toLower) import Data.Aeson +import qualified Data.HashMap.Strict as HM +import Lens.Micro import Web.Scim.Schema.Common import Web.Scim.Schema.Schema (Schema(..)) @@ -20,8 +58,10 @@ import GHC.Generics (Generic) data User = User - { schemas :: [Schema] -- TODO: not sure it should be a part of this type - , userName :: Text + { + -- Mandatory fields + userName :: Text + -- Optional fields , externalId :: Maybe Text , name :: Maybe Name , displayName :: Maybe Text @@ -33,20 +73,20 @@ data User = User , locale :: Maybe Text , active :: Maybe Bool , password :: Maybe Text - , emails :: Maybe [Email] - , phoneNumbers :: Maybe [Phone] - , ims :: Maybe [IM] - , photos :: Maybe [Photo] - , addresses :: Maybe [Address] - , entitlements :: Maybe [Text] - , roles :: Maybe [Text] - , x509Certificates :: Maybe [Certificate] + -- Multi-valued fields + , emails :: [Email] + , phoneNumbers :: [Phone] + , ims :: [IM] + , photos :: [Photo] + , addresses :: [Address] + , entitlements :: [Text] + , roles :: [Text] + , x509Certificates :: [Certificate] } deriving (Show, Eq, Generic) empty :: User empty = User - { schemas = [User20] - , userName = "" + { userName = "" , externalId = Nothing , name = Nothing , displayName = Nothing @@ -58,20 +98,76 @@ empty = User , locale = Nothing , active = Nothing , password = Nothing - , emails = Nothing - , phoneNumbers = Nothing - , ims = Nothing - , photos = Nothing - , addresses = Nothing - , entitlements = Nothing - , roles = Nothing - , x509Certificates = Nothing + , emails = [] + , phoneNumbers = [] + , ims = [] + , photos = [] + , addresses = [] + , entitlements = [] + , roles = [] + , x509Certificates = [] } instance FromJSON User where - parseJSON = genericParseJSON parseOptions . jsonLower + parseJSON = withObject "User" $ \obj -> do + -- Lowercase all fields + let o = HM.fromList . map (over _1 toLower) . HM.toList $ obj + + userName <- o .: "username" + externalId <- o .:? "externalid" + name <- o .:? "name" + displayName <- o .:? "displayname" + nickName <- o .:? "nickname" + profileUrl <- o .:? "profileurl" + title <- o .:? "title" + userType <- o .:? "usertype" + preferredLanguage <- o .:? "preferredlanguage" + locale <- o .:? "locale" + active <- o .:? "active" + password <- o .:? "password" + emails <- o .:? "emails" .!= [] + phoneNumbers <- o .:? "phonenumbers" .!= [] + ims <- o .:? "ims" .!= [] + photos <- o .:? "photos" .!= [] + addresses <- o .:? "addresses" .!= [] + entitlements <- o .:? "entitlements" .!= [] + roles <- o .:? "roles" .!= [] + x509Certificates <- o .:? "x509certificates" .!= [] + + pure User{..} instance ToJSON User where - toJSON = genericToJSON serializeOptions + toJSON User{..} = object $ concat + [ [ "schemas" .= [User20] ] + , [ "userName" .= userName ] + , optionalField "externalId" externalId + , optionalField "name" name + , optionalField "displayName" displayName + , optionalField "nickName" nickName + , optionalField "profileUrl" profileUrl + , optionalField "title" title + , optionalField "userType" userType + , optionalField "preferredLanguage" preferredLanguage + , optionalField "locale" locale + , optionalField "active" active + , optionalField "password" password + , multiValuedField "emails" emails + , multiValuedField "phoneNumbers" phoneNumbers + , multiValuedField "ims" ims + , multiValuedField "photos" photos + , multiValuedField "addresses" addresses + , multiValuedField "entitlements" entitlements + , multiValuedField "roles" roles + , multiValuedField "x509Certificates" x509Certificates + ] + where + -- Omit a field if it's Nothing + optionalField fname = \case + Nothing -> [] + Just x -> [fname .= x] + -- Omit a field if it's [] + multiValuedField fname = \case + [] -> [] + xs -> [fname .= xs] type UserId = Text diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index 7985c0ffa0a..8ed33d1452e 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -60,7 +60,7 @@ spec = beforeAll app $ do get "/0" `shouldRespondWith` barbara describe "PUT /Users/:id" $ do - it "updates mutable fields" $ do + it "overwrites the user" $ do put "/0" barbUpdate0 `shouldRespondWith` updatedBarb0 it "does not create new user" $ do diff --git a/test/Test/Schema/UserSpec.hs b/test/Test/Schema/UserSpec.hs new file mode 100644 index 00000000000..8f6f9bc80bd --- /dev/null +++ b/test/Test/Schema/UserSpec.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Test.Schema.UserSpec (spec) where + +import Test.Util + +import Web.Scim.Schema.Common (URI(..)) +import Web.Scim.Schema.User +import Web.Scim.Schema.User.Address as Address +import Web.Scim.Schema.User.Certificate as Certificate +import Web.Scim.Schema.User.Email as Email +import Web.Scim.Schema.User.IM as IM +import Web.Scim.Schema.User.Name as Name +import Web.Scim.Schema.User.Phone as Phone +import Web.Scim.Schema.User.Photo as Photo +import Data.Aeson +import Test.Hspec +import Text.Email.Validate (emailAddress) +import Network.URI.Static (uri) + +spec :: Spec +spec = do + describe "JSON serialization" $ do + it "handles all fields" $ do + toJSON completeUser `shouldBe` completeUserJson + eitherDecode (encode completeUserJson) `shouldBe` Right completeUser + + it "has defaults for all optional and multi-valued fields" $ do + toJSON minimalUser `shouldBe` minimalUserJson + eitherDecode (encode minimalUserJson) `shouldBe` Right minimalUser + + it "treats 'null' and '[]' as absence of fields" $ + eitherDecode (encode minimalUserJsonRedundant) `shouldBe` Right minimalUser + + it "allows casing variations in field names" $ + eitherDecode (encode minimalUserJsonNonCanonical) `shouldBe` Right minimalUser + +-- | A 'User' with all attributes present. +completeUser :: User +completeUser = User + { userName = "sample userName" + , externalId = Just "sample externalId" + , name = Just $ Name + { Name.formatted = Just "sample formatted name" + , Name.familyName = Nothing + , Name.givenName = Nothing + , Name.middleName = Nothing + , Name.honorificPrefix = Nothing + , Name.honorificSuffix = Nothing + } + , displayName = Just "sample displayName" + , nickName = Just "sample nickName" + , profileUrl = Just (URI [uri|https://example.com|]) + , title = Just "sample title" + , userType = Just "sample userType" + , preferredLanguage = Just "da, en-gb;q=0.8, en;q=0.7" + , locale = Just "en-US" + , active = Just True + , password = Just "sample password" + , emails = [ + Email { Email.typ = Just "work" + , Email.value = maybe (error "couldn't parse email") EmailAddress2 + (emailAddress "user@example.com") + , Email.primary = Nothing } + ] + , phoneNumbers = [ + Phone { Phone.typ = Just "work" + , Phone.value = Just "+15417543010" } + ] + , ims = [ + IM { IM.typ = Just "Wire" + , IM.value = Just "@user" } + ] + , photos = [ + Photo { Photo.typ = Just "userpic" + , Photo.value = Just (URI [uri|https://example.com/userpic.png|]) } + ] + , addresses = [ + Address { Address.formatted = Just "sample Address" + , Address.streetAddress = Nothing + , Address.locality = Nothing + , Address.region = Nothing + , Address.postalCode = Nothing + , Address.country = Nothing + , Address.typ = Just "home" + , Address.primary = Just True } + ] + , entitlements = ["sample entitlement"] + , roles = ["sample role"] + , x509Certificates = [ + Certificate { Certificate.typ = Just "sample certificate type" + , Certificate.value = Just "sample certificate" } + ] + } + +-- | Reference encoding of 'completeUser'. +completeUserJson :: Value +completeUserJson = [scim| +{ + "roles": [ + "sample role" + ], + "x509Certificates": [ + { + "value": "sample certificate", + "type": "sample certificate type" + } + ], + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User" + ], + "locale": "en-US", + "addresses": [ + { + "formatted": "sample Address", + "primary": true, + "type": "home" + } + ], + "userName": "sample userName", + "phoneNumbers": [ + { + "value": "+15417543010", + "type": "work" + } + ], + "active": true, + "photos": [ + { + "value": "https://example.com/userpic.png", + "type": "userpic" + } + ], + "name": { + "formatted": "sample formatted name" + }, + "password": "sample password", + "emails": [ + { + "value": "user@example.com", + "type": "work" + } + ], + "ims": [ + { + "value": "@user", + "type": "Wire" + } + ], + "preferredLanguage": "da, en-gb;q=0.8, en;q=0.7", + "entitlements": [ + "sample entitlement" + ], + "displayName": "sample displayName", + "nickName": "sample nickName", + "profileUrl": "https://example.com", + "title": "sample title", + "externalId": "sample externalId", + "userType": "sample userType" +} +|] + +-- | A 'User' with all attributes empty (if possible). +minimalUser :: User +minimalUser = empty { userName = "sample userName" } + +-- | Reference encoding of 'minimalUser'. +minimalUserJson :: Value +minimalUserJson = [scim| +{ + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User" + ], + "userName": "sample userName" +} +|] + +-- | An encoding of 'minimalUser' with redundant @null@s and @[]@s for missing +-- fields. +minimalUserJsonRedundant :: Value +minimalUserJsonRedundant = [scim| +{ + "roles": [], + "x509Certificates": [], + "locale": null, + "addresses": [], + "userName": "sample userName", + "phoneNumbers": [], + "active": null, + "photos": [], + "name": null, + "password": null, + "emails": [], + "ims": [], + "preferredLanguage": null, + "entitlements": [], + "displayName": null, + "nickName": null, + "profileUrl": null, + "title": null, + "externalId": null, + "userType": null +} +|] + +-- | An encoding of 'minimalUser' with non-canonical field name casing. +minimalUserJsonNonCanonical :: Value +minimalUserJsonNonCanonical = [scim| +{ + "USERname": "sample userName" +} +|] diff --git a/test/Test/Util.hs b/test/Test/Util.hs index 06ef2d4ce6c..4f4551d5b75 100644 --- a/test/Test/Util.hs +++ b/test/Test/Util.hs @@ -73,6 +73,9 @@ equalsJSON expected = MatchBody matcher instance FromValue L.ByteString where fromValue = encode +instance FromValue Value where + fromValue = id + ---------------------------------------------------------------------------- -- Ad-hoc JSON parsing From 24c7cc1bc2d178e9bcc2cc58bea821856dfcd65d Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Mon, 25 Feb 2019 16:19:49 +0100 Subject: [PATCH 23/64] Support extra fields in 'User' (#24) * Support extra fields in 'User' * Comments --- server/Main.hs | 3 +- src/Web/Scim/Capabilities/MetaSchema.hs | 2 +- src/Web/Scim/Class/User.hs | 51 ++++++++----- src/Web/Scim/Filter.hs | 2 +- src/Web/Scim/Schema/Schema.hs | 34 +++++---- src/Web/Scim/Schema/User.hs | 96 ++++++++++++++++--------- src/Web/Scim/Server.hs | 21 +++--- src/Web/Scim/Server/Mock.hs | 17 +++-- test/Test/Class/UserSpec.hs | 3 +- test/Test/Schema/UserSpec.hs | 91 +++++++++++++++++++++-- 10 files changed, 235 insertions(+), 85 deletions(-) diff --git a/server/Main.hs b/server/Main.hs index da04fec41da..142861d68d5 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -4,6 +4,7 @@ module Main where import Web.Scim.Server import Web.Scim.Server.Mock +import Web.Scim.Schema.Schema (Schema (User20)) import Web.Scim.Schema.Meta hiding (meta) import Web.Scim.Schema.Common as Common import Web.Scim.Schema.ResourceType hiding (name) @@ -50,7 +51,7 @@ mkUserDB = do (emailAddress "elton@wire.com") , E.primary = Nothing } - let user = User.empty + let user = (User.empty [User20] NoUserExtra) { userName = "elton" , name = Just Name { formatted = Just "Elton John" diff --git a/src/Web/Scim/Capabilities/MetaSchema.hs b/src/Web/Scim/Capabilities/MetaSchema.hs index 3734e2521aa..727fc9db686 100644 --- a/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/src/Web/Scim/Capabilities/MetaSchema.hs @@ -102,7 +102,7 @@ configServer config = ConfigSite , metaSchema , resourceSchema ] - , schema = \uri -> case getSchema =<< fromSchemaUri uri of + , schema = \uri -> case getSchema (fromSchemaUri uri) of Nothing -> throwScim (notFound "Schema" uri) Just s -> pure s , resourceTypes = pure $ diff --git a/src/Web/Scim/Class/User.hs b/src/Web/Scim/Class/User.hs index 1922642f960..7fe9e0d09a1 100644 --- a/src/Web/Scim/Class/User.hs +++ b/src/Web/Scim/Class/User.hs @@ -24,21 +24,28 @@ import Servant.Server.Generic ---------------------------------------------------------------------------- -- /Users API -type StoredUser = WithMeta (WithId User) +type StoredUser extra = WithMeta (WithId (User extra)) -data UserSite route = UserSite +data UserSite extra route = UserSite { getUsers :: route :- - QueryParam "filter" Filter :> Get '[SCIM] (ListResponse StoredUser) + QueryParam "filter" Filter :> + Get '[SCIM] (ListResponse (StoredUser extra)) , getUser :: route :- - Capture "id" Text :> Get '[SCIM] StoredUser + Capture "id" Text :> + Get '[SCIM] (StoredUser extra) , postUser :: route :- - ReqBody '[SCIM] User :> PostCreated '[SCIM] StoredUser + ReqBody '[SCIM] (User extra) :> + PostCreated '[SCIM] (StoredUser extra) , putUser :: route :- - Capture "id" Text :> ReqBody '[SCIM] User :> Put '[SCIM] StoredUser + Capture "id" Text :> + ReqBody '[SCIM] (User extra) :> + Put '[SCIM] (StoredUser extra) , patchUser :: route :- - Capture "id" Text :> Patch '[SCIM] StoredUser + Capture "id" Text :> + Patch '[SCIM] (StoredUser extra) , deleteUser :: route :- - Capture "id" Text :> DeleteNoContent '[SCIM] NoContent + Capture "id" Text :> + DeleteNoContent '[SCIM] NoContent } deriving (Generic) ---------------------------------------------------------------------------- @@ -46,10 +53,11 @@ data UserSite route = UserSite -- TODO: parameterize UserId class (Monad m, AuthDB m) => UserDB m where - list :: AuthInfo m -> Maybe Filter -> ScimHandler m (ListResponse StoredUser) - get :: AuthInfo m -> UserId -> ScimHandler m (Maybe StoredUser) - create :: AuthInfo m -> User -> ScimHandler m StoredUser - update :: AuthInfo m -> UserId -> User -> ScimHandler m StoredUser + type UserExtra m + list :: AuthInfo m -> Maybe Filter -> ScimHandler m (ListResponse (StoredUser (UserExtra m))) + get :: AuthInfo m -> UserId -> ScimHandler m (Maybe (StoredUser (UserExtra m))) + create :: AuthInfo m -> User (UserExtra m) -> ScimHandler m (StoredUser (UserExtra m)) + update :: AuthInfo m -> UserId -> User (UserExtra m) -> ScimHandler m (StoredUser (UserExtra m)) delete :: AuthInfo m -> UserId -> ScimHandler m Bool -- ^ Return 'False' if the user didn't exist getMeta :: AuthInfo m -> ScimHandler m Meta @@ -58,7 +66,7 @@ class (Monad m, AuthDB m) => UserDB m where userServer :: UserDB m - => Maybe (AuthData m) -> UserSite (AsServerT (ScimHandler m)) + => Maybe (AuthData m) -> UserSite (UserExtra m) (AsServerT (ScimHandler m)) userServer authData = UserSite { getUsers = \mbFilter -> do auth <- authCheck authData @@ -80,20 +88,26 @@ userServer authData = UserSite getUsers' :: UserDB m - => AuthInfo m -> Maybe Filter -> ScimHandler m (ListResponse StoredUser) + => AuthInfo m + -> Maybe Filter + -> ScimHandler m (ListResponse (StoredUser (UserExtra m))) getUsers' auth mbFilter = do list auth mbFilter getUser' :: UserDB m - => AuthInfo m -> UserId -> ScimHandler m StoredUser + => AuthInfo m + -> UserId + -> ScimHandler m (StoredUser (UserExtra m)) getUser' auth uid = do maybeUser <- get auth uid maybe (throwScim (notFound "User" uid)) pure maybeUser postUser' :: UserDB m - => AuthInfo m -> User -> ScimHandler m StoredUser + => AuthInfo m + -> User (UserExtra m) + -> ScimHandler m (StoredUser (UserExtra m)) postUser' auth user = do -- Find users with the same username (case-insensitive) -- @@ -117,7 +131,10 @@ postUser' auth user = do -- See . putUser' :: UserDB m - => AuthInfo m -> UserId -> User -> ScimHandler m StoredUser + => AuthInfo m + -> UserId + -> User (UserExtra m) + -> ScimHandler m (StoredUser (UserExtra m)) putUser' auth uid user = do stored <- get auth uid case stored of diff --git a/src/Web/Scim/Filter.hs b/src/Web/Scim/Filter.hs index 9c92e2a906d..9ca0aec9424 100644 --- a/src/Web/Scim/Filter.hs +++ b/src/Web/Scim/Filter.hs @@ -190,7 +190,7 @@ rAttribute = \case -- -- Returns 'Left' if the filter is constructed incorrectly (e.g. tries to -- compare a username with a boolean). -filterUser :: Filter -> User -> Either Text Bool +filterUser :: Filter -> User extra -> Either Text Bool filterUser filter_ user = case filter_ of FilterAttrCompare AttrUserName op (ValString str) -> -- Comparing usernames has to be case-insensitive; look at the diff --git a/src/Web/Scim/Schema/Schema.hs b/src/Web/Scim/Schema/Schema.hs index 8bc8d45040d..e0a0c29dcbb 100644 --- a/src/Web/Scim/Schema/Schema.hs +++ b/src/Web/Scim/Schema/Schema.hs @@ -18,12 +18,11 @@ data Schema = User20 | ResourceType20 | ListResponse2_0 | Error2_0 + | CustomSchema Text deriving (Show, Eq) instance FromJSON Schema where - parseJSON = withText "schema" $ \t -> case fromSchemaUri t of - Just s -> pure s - Nothing -> fail "unsupported schema" + parseJSON = withText "schema" $ \t -> pure (fromSchemaUri t) instance ToJSON Schema where toJSON = toJSON . getSchemaUri @@ -44,26 +43,28 @@ getSchemaUri ListResponse2_0 = "urn:ietf:params:scim:api:messages:2.0:ListResponse" getSchemaUri Error2_0 = "urn:ietf:params:scim:api:messages:2.0:Error" +getSchemaUri (CustomSchema x) = + x -- | Get a schema by its URI. -fromSchemaUri :: Text -> Maybe Schema +fromSchemaUri :: Text -> Schema fromSchemaUri s = case s of "urn:ietf:params:scim:schemas:core:2.0:User" -> - pure User20 + User20 "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig" -> - pure ServiceProviderConfig20 + ServiceProviderConfig20 "urn:ietf:params:scim:schemas:core:2.0:Group" -> - pure Group20 + Group20 "urn:ietf:params:scim:schemas:core:2.0:Schema" -> - pure Schema20 + Schema20 "urn:ietf:params:scim:schemas:core:2.0:ResourceType" -> - pure ResourceType20 + ResourceType20 "urn:ietf:params:scim:api:messages:2.0:ListResponse" -> - pure ListResponse2_0 + ListResponse2_0 "urn:ietf:params:scim:api:messages:2.0:Error" -> - pure Error2_0 - _ -> - Nothing + Error2_0 + x -> + CustomSchema x -- | Get schema description as JSON. getSchema :: Schema -> Maybe Value @@ -77,8 +78,13 @@ getSchema Schema20 = pure metaSchema getSchema ResourceType20 = pure resourceSchema --- Schemas for these types are not in the SCIM standard +-- Schemas for these types are not in the SCIM standard. +-- FUTUREWORK: write schema definitions anyway. getSchema ListResponse2_0 = Nothing getSchema Error2_0 = Nothing +-- This is not controlled by @hscim@ so we can't write a schema. +-- FUTUREWORK: allow supplying schemas for 'CustomSchema'. +getSchema (CustomSchema _) = + Nothing diff --git a/src/Web/Scim/Schema/User.hs b/src/Web/Scim/Schema/User.hs index db1befb3e81..24ecd74d55f 100644 --- a/src/Web/Scim/Schema/User.hs +++ b/src/Web/Scim/Schema/User.hs @@ -57,10 +57,11 @@ import Web.Scim.Schema.User.Photo (Photo) import GHC.Generics (Generic) -data User = User +data User extra = User { + schemas :: [Schema] -- Mandatory fields - userName :: Text + , userName :: Text -- Optional fields , externalId :: Maybe Text , name :: Maybe Name @@ -82,11 +83,21 @@ data User = User , entitlements :: [Text] , roles :: [Text] , x509Certificates :: [Certificate] + -- Extra data (merged with the main user object). Note that as per SCIM spec, the 'FromJSON' + -- parser has to accept lowercase fields. + -- + -- FUTUREWORK: make it easy for hscim users to implement a proper parser (with correct + -- rendering of optional and multivalued fields, lowercase objects, etc). + , extra :: extra } deriving (Show, Eq, Generic) -empty :: User -empty = User - { userName = "" +empty + :: [Schema] -- ^ Schemas + -> extra -- ^ Extra data + -> User extra +empty schemas extra = User + { schemas = schemas + , userName = "" , externalId = Nothing , name = Nothing , displayName = Nothing @@ -106,13 +117,16 @@ empty = User , entitlements = [] , roles = [] , x509Certificates = [] + , extra = extra } -instance FromJSON User where +instance FromJSON extra => FromJSON (User extra) where parseJSON = withObject "User" $ \obj -> do -- Lowercase all fields let o = HM.fromList . map (over _1 toLower) . HM.toList $ obj - + schemas <- o .:? "schemas" <&> \case + Nothing -> [User20] + Just xs -> if User20 `elem` xs then xs else User20 : xs userName <- o .: "username" externalId <- o .:? "externalid" name <- o .:? "name" @@ -133,33 +147,40 @@ instance FromJSON User where entitlements <- o .:? "entitlements" .!= [] roles <- o .:? "roles" .!= [] x509Certificates <- o .:? "x509certificates" .!= [] - + extra <- parseJSON (Object o) pure User{..} -instance ToJSON User where - toJSON User{..} = object $ concat - [ [ "schemas" .= [User20] ] - , [ "userName" .= userName ] - , optionalField "externalId" externalId - , optionalField "name" name - , optionalField "displayName" displayName - , optionalField "nickName" nickName - , optionalField "profileUrl" profileUrl - , optionalField "title" title - , optionalField "userType" userType - , optionalField "preferredLanguage" preferredLanguage - , optionalField "locale" locale - , optionalField "active" active - , optionalField "password" password - , multiValuedField "emails" emails - , multiValuedField "phoneNumbers" phoneNumbers - , multiValuedField "ims" ims - , multiValuedField "photos" photos - , multiValuedField "addresses" addresses - , multiValuedField "entitlements" entitlements - , multiValuedField "roles" roles - , multiValuedField "x509Certificates" x509Certificates - ] +instance ToJSON extra => ToJSON (User extra) where + toJSON User{..} = + let mainObject = HM.fromList $ concat + [ [ "schemas" .= schemas ] + , [ "userName" .= userName ] + , optionalField "externalId" externalId + , optionalField "name" name + , optionalField "displayName" displayName + , optionalField "nickName" nickName + , optionalField "profileUrl" profileUrl + , optionalField "title" title + , optionalField "userType" userType + , optionalField "preferredLanguage" preferredLanguage + , optionalField "locale" locale + , optionalField "active" active + , optionalField "password" password + , multiValuedField "emails" emails + , multiValuedField "phoneNumbers" phoneNumbers + , multiValuedField "ims" ims + , multiValuedField "photos" photos + , multiValuedField "addresses" addresses + , multiValuedField "entitlements" entitlements + , multiValuedField "roles" roles + , multiValuedField "x509Certificates" x509Certificates + ] + extraObject = case toJSON extra of + Null -> mempty + Object x -> x + other -> HM.fromList ["extra" .= other] + in Object (HM.union mainObject extraObject) + where -- Omit a field if it's Nothing optionalField fname = \case @@ -171,3 +192,14 @@ instance ToJSON User where xs -> [fname .= xs] type UserId = Text + +-- | A type used to indicate that the SCIM record doesn't have any extra data. Encoded as an +-- empty map. +data NoUserExtra = NoUserExtra + deriving (Eq, Show) + +instance FromJSON NoUserExtra where + parseJSON = withObject "NoUserExtra" $ \_ -> pure NoUserExtra + +instance ToJSON NoUserExtra where + toJSON _ = object [] diff --git a/src/Web/Scim/Server.hs b/src/Web/Scim/Server.hs index 41db69ae5fb..0a050e19ee9 100644 --- a/src/Web/Scim/Server.hs +++ b/src/Web/Scim/Server.hs @@ -11,7 +11,7 @@ module Web.Scim.Server , GroupAPI, groupServer ) where -import Web.Scim.Class.User (UserSite (..), UserDB, userServer) +import Web.Scim.Class.User (UserSite (..), UserDB (..), userServer) import Web.Scim.Class.Group (GroupSite (..), GroupDB, groupServer) import Web.Scim.Class.Auth (AuthDB (..)) import Web.Scim.Capabilities.MetaSchema (ConfigSite, Configuration, configServer) @@ -27,17 +27,17 @@ import Servant.Server.Generic type DB m = (UserDB m, GroupDB m, AuthDB m) -type ConfigAPI = ToServantApi ConfigSite -type UserAPI = ToServantApi UserSite -type GroupAPI = ToServantApi GroupSite -type SiteAPI authData = ToServantApi (Site authData) +type ConfigAPI = ToServantApi ConfigSite +type UserAPI userExtra = ToServantApi (UserSite userExtra) +type GroupAPI = ToServantApi GroupSite +type SiteAPI authData userExtra = ToServantApi (Site authData userExtra) -data Site authData route = Site +data Site authData userExtra route = Site { config :: route :- ConfigAPI , users :: route :- Header "Authorization" authData :> - "Users" :> UserAPI + "Users" :> UserAPI userExtra , groups :: route :- Header "Authorization" authData :> "Groups" :> GroupAPI @@ -48,7 +48,7 @@ data Site authData route = Site siteServer :: forall m. DB m => - Configuration -> Site (AuthData m) (AsServerT (ScimHandler m)) + Configuration -> Site (AuthData m) (UserExtra m) (AsServerT (ScimHandler m)) siteServer conf = Site { config = toServant $ configServer conf , users = \authData -> toServant (userServer authData) @@ -73,8 +73,9 @@ mkapp proxy api nt = serve proxy $ hoistServer proxy nt api -app :: forall m. App m (SiteAPI (AuthData m)) +app :: forall m. App m (SiteAPI (AuthData m) (UserExtra m)) => Configuration -> (forall a. ScimHandler m a -> Handler a) -> Application -app c = mkapp (Proxy @(SiteAPI (AuthData m))) (toServant $ siteServer c) +app c = mkapp (Proxy @(SiteAPI (AuthData m) (UserExtra m))) + (toServant $ siteServer c) diff --git a/src/Web/Scim/Server/Mock.hs b/src/Web/Scim/Server/Mock.hs index 18955e00521..3118ce3e63c 100644 --- a/src/Web/Scim/Server/Mock.hs +++ b/src/Web/Scim/Server/Mock.hs @@ -29,7 +29,7 @@ import Web.Scim.Filter import Web.Scim.Handler import Servant -type UserStorage = STMMap.Map Text StoredUser +type UserStorage = STMMap.Map Text (StoredUser NoUserExtra) type GroupStorage = STMMap.Map Text StoredGroup data TestStorage = TestStorage @@ -51,6 +51,7 @@ hoistSTM :: (MFunctor t, MonadIO m) => t STM a -> t m a hoistSTM = hoist liftSTM instance UserDB TestServer where + type UserExtra TestServer = NoUserExtra list () mbFilter = do -- Note: in production instances it would make sense to remove this code -- and let the implementor of the 'UserDB' instance do filtering (e.g. @@ -132,7 +133,11 @@ updateGroup gid grp storage = do lift $ STMMap.insert newGroup gid storage pure newGroup -updateUser :: UserId -> User -> UserStorage -> ScimHandler STM StoredUser +updateUser + :: UserId + -> User NoUserExtra + -> UserStorage + -> ScimHandler STM (StoredUser NoUserExtra) updateUser uid user storage = do existing <- lift $ STMMap.lookup uid storage case existing of @@ -144,7 +149,7 @@ updateUser uid user storage = do pure newUser -- (there seems to be no readOnly fields in User) -assertMutability :: User -> StoredUser -> Bool +assertMutability :: User NoUserExtra -> StoredUser NoUserExtra -> Bool assertMutability _newUser _stored = True delGroup :: GroupId -> GroupStorage -> ScimHandler STM Bool @@ -179,7 +184,11 @@ createMeta rType = Meta } -- insert with a simple incrementing integer id (good for testing) -insertUser :: User -> Meta -> UserStorage -> ScimHandler STM StoredUser +insertUser + :: User NoUserExtra + -> Meta + -> UserStorage + -> ScimHandler STM (StoredUser NoUserExtra) insertUser user met storage = do size <- lift $ STMMap.size storage let uid = pack . show $ size diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index 8ed33d1452e..6f19fdac8c8 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -4,6 +4,7 @@ module Test.Class.UserSpec (spec) where import Test.Util +import Web.Scim.Schema.User (NoUserExtra) import Web.Scim.Server (mkapp, UserAPI, userServer) import Web.Scim.Server.Mock import Test.Hspec @@ -18,7 +19,7 @@ app :: IO Application app = do storage <- emptyTestStorage let auth = Just "authorized" - pure $ mkapp (Proxy @UserAPI) (toServant (userServer auth)) (nt storage) + pure $ mkapp (Proxy @(UserAPI NoUserExtra)) (toServant (userServer auth)) (nt storage) spec :: Spec spec = beforeAll app $ do diff --git a/test/Test/Schema/UserSpec.hs b/test/Test/Schema/UserSpec.hs index 8f6f9bc80bd..3def446a5a3 100644 --- a/test/Test/Schema/UserSpec.hs +++ b/test/Test/Schema/UserSpec.hs @@ -1,10 +1,12 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ViewPatterns #-} module Test.Schema.UserSpec (spec) where import Test.Util import Web.Scim.Schema.Common (URI(..)) +import Web.Scim.Schema.Schema (Schema(..)) import Web.Scim.Schema.User import Web.Scim.Schema.User.Address as Address import Web.Scim.Schema.User.Certificate as Certificate @@ -14,6 +16,9 @@ import Web.Scim.Schema.User.Name as Name import Web.Scim.Schema.User.Phone as Phone import Web.Scim.Schema.User.Photo as Photo import Data.Aeson +import qualified Data.HashMap.Strict as HM +import Data.Text (Text, toLower) +import Lens.Micro import Test.Hspec import Text.Email.Validate (emailAddress) import Network.URI.Static (uri) @@ -35,10 +40,24 @@ spec = do it "allows casing variations in field names" $ eitherDecode (encode minimalUserJsonNonCanonical) `shouldBe` Right minimalUser + it "doesn't require the 'schemas' field" $ + eitherDecode (encode minimalUserJsonNoSchemas) `shouldBe` Right minimalUser + + it "doesn't add 'extra' if it's an empty object" $ do + toJSON (extendedUser UserExtraEmpty) `shouldBe` extendedUserEmptyJson + eitherDecode (encode extendedUserEmptyJson) `shouldBe` + Right (extendedUser UserExtraEmpty) + + it "encodes and decodes 'extra' correctly" $ do + toJSON (extendedUser (UserExtraObject "foo")) `shouldBe` extendedUserObjectJson + eitherDecode (encode extendedUserObjectJson) `shouldBe` + Right (extendedUser (UserExtraObject "foo")) + -- | A 'User' with all attributes present. -completeUser :: User +completeUser :: User NoUserExtra completeUser = User - { userName = "sample userName" + { schemas = [User20] + , userName = "sample userName" , externalId = Just "sample externalId" , name = Just $ Name { Name.formatted = Just "sample formatted name" @@ -91,6 +110,7 @@ completeUser = User Certificate { Certificate.typ = Just "sample certificate type" , Certificate.value = Just "sample certificate" } ] + , extra = NoUserExtra } -- | Reference encoding of 'completeUser'. @@ -161,8 +181,8 @@ completeUserJson = [scim| |] -- | A 'User' with all attributes empty (if possible). -minimalUser :: User -minimalUser = empty { userName = "sample userName" } +minimalUser :: User NoUserExtra +minimalUser = (empty [User20] NoUserExtra) { userName = "sample userName" } -- | Reference encoding of 'minimalUser'. minimalUserJson :: Value @@ -180,6 +200,9 @@ minimalUserJson = [scim| minimalUserJsonRedundant :: Value minimalUserJsonRedundant = [scim| { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User" + ], "roles": [], "x509Certificates": [], "locale": null, @@ -207,6 +230,66 @@ minimalUserJsonRedundant = [scim| minimalUserJsonNonCanonical :: Value minimalUserJsonNonCanonical = [scim| { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User" + ], "USERname": "sample userName" } |] + +-- | An encoding of 'minimalUser' without the @schemas@ field. +minimalUserJsonNoSchemas :: Value +minimalUserJsonNoSchemas = [scim| +{ + "userName": "sample userName" +} +|] + +data UserExtraTest = UserExtraEmpty | UserExtraObject { test :: Text } + deriving (Show, Eq) + +instance FromJSON UserExtraTest where + parseJSON = withObject "UserExtraObject" $ \(lowercase -> o) -> do + o .:? "urn:hscim:test" >>= \case + Nothing -> pure UserExtraEmpty + Just (lowercase -> o2) -> UserExtraObject <$> o2 .: "test" + where + lowercase = HM.fromList . map (over _1 toLower) . HM.toList + +instance ToJSON UserExtraTest where + toJSON UserExtraEmpty = object [] + toJSON (UserExtraObject t) = + object ["urn:hscim:test" .= object ["test" .= t]] + +-- | A 'User' with extra fields present. +extendedUser :: UserExtraTest -> User UserExtraTest +extendedUser e = + (empty [User20, CustomSchema "urn:hscim:test"] e) + { userName = "sample userName" } + +-- | Encoding of @extendedUser UserExtraEmpty@. +extendedUserEmptyJson :: Value +extendedUserEmptyJson = [scim| +{ + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User", + "urn:hscim:test" + ], + "userName": "sample userName" +} +|] + +-- | Encoding of @extendedUser (UserExtraObject "foo")@. +extendedUserObjectJson :: Value +extendedUserObjectJson = [scim| +{ + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User", + "urn:hscim:test" + ], + "userName": "sample userName", + "urn:hscim:test": { + "test": "foo" + } +} +|] From 42f6018812bf0f04741231b67b1f5e790ce0d489 Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Mon, 25 Feb 2019 18:41:56 +0100 Subject: [PATCH 24/64] More comments + don't sent the lowercase version to FromJSON extra (#25) * More comments; don't send the lowercase version to FromJSON extra * Clarify --- src/Web/Scim/Schema/User.hs | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/src/Web/Scim/Schema/User.hs b/src/Web/Scim/Schema/User.hs index 24ecd74d55f..74b10bdf9d4 100644 --- a/src/Web/Scim/Schema/User.hs +++ b/src/Web/Scim/Schema/User.hs @@ -60,8 +60,10 @@ import GHC.Generics (Generic) data User extra = User { schemas :: [Schema] + -- Mandatory fields , userName :: Text + -- Optional fields , externalId :: Maybe Text , name :: Maybe Name @@ -74,6 +76,7 @@ data User extra = User , locale :: Maybe Text , active :: Maybe Bool , password :: Maybe Text + -- Multi-valued fields , emails :: [Email] , phoneNumbers :: [Phone] @@ -83,8 +86,18 @@ data User extra = User , entitlements :: [Text] , roles :: [Text] , x509Certificates :: [Certificate] - -- Extra data (merged with the main user object). Note that as per SCIM spec, the 'FromJSON' - -- parser has to accept lowercase fields. + + -- Extra data. + -- + -- During rendering, we'll convert it to JSON; if it's an object we'll merge it with the + -- main user object, if it's @null@ we'll do nothing, otherwise we'll add it under the + -- @"extra"@ field (though you should definitely not rely on this). + -- + -- During parsing, we'll attempt to parse the /whole/ user object as @extra@, so your + -- 'FromJSON' instance should be prepared to ignore unrelated fields. Also keep in mind that + -- the SCIM spec requires field names to be case-insensitive, i.e. if you're looking for a + -- field "foo" you should also handle a field called "FOO". Look at the @FromJSON User@ + -- instance to see how it can be done. -- -- FUTUREWORK: make it easy for hscim users to implement a proper parser (with correct -- rendering of optional and multivalued fields, lowercase objects, etc). @@ -147,7 +160,7 @@ instance FromJSON extra => FromJSON (User extra) where entitlements <- o .:? "entitlements" .!= [] roles <- o .:? "roles" .!= [] x509Certificates <- o .:? "x509certificates" .!= [] - extra <- parseJSON (Object o) + extra <- parseJSON (Object obj) pure User{..} instance ToJSON extra => ToJSON (User extra) where From b2ddde040426d332a2eddcddb00e81ffb1144a90 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 13 Mar 2019 12:26:31 +0100 Subject: [PATCH 25/64] Add 'forbidden' error helper (#26) * Add 'forbidden' error helper --- package.yaml | 2 +- src/Web/Scim/Schema/Error.hs | 34 +++++++++++++++++++++++----------- 2 files changed, 24 insertions(+), 12 deletions(-) diff --git a/package.yaml b/package.yaml index 3678c87153d..02e15a51e44 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: hscim -version: 0.1.0.0 +version: 0.1.1.0 synopsis: ... description: ... homepage: https://github.com/wireapp/hscim/README.md diff --git a/src/Web/Scim/Schema/Error.hs b/src/Web/Scim/Schema/Error.hs index 1afad8df9d9..bce6f7f33c7 100644 --- a/src/Web/Scim/Schema/Error.hs +++ b/src/Web/Scim/Schema/Error.hs @@ -11,6 +11,7 @@ module Web.Scim.Schema.Error , badRequest , conflict , unauthorized + , forbidden , serverError -- * Servant interoperability @@ -93,6 +94,28 @@ badRequest typ mbDetail = , detail = mbDetail } +unauthorized + :: Text -- ^ Error details + -> ScimError +unauthorized details = + ScimError + { schemas = [Error2_0] + , status = Status 401 + , scimType = Nothing + , detail = pure $ "authorization failed: " <> details + } + +forbidden + :: Text -- ^ Error details + -> ScimError +forbidden details = + ScimError + { schemas = [Error2_0] + , status = Status 403 + , scimType = Nothing + , detail = pure $ "forbidden: " <> details + } + notFound :: Text -- ^ Resource type -> Text -- ^ Resource ID @@ -114,17 +137,6 @@ conflict = , detail = Nothing } -unauthorized - :: Text -- ^ Error details - -> ScimError -unauthorized details = - ScimError - { schemas = [Error2_0] - , status = Status 401 - , scimType = Nothing - , detail = pure $ "authorization failed: " <> details - } - serverError :: Text -- ^ Error details -> ScimError From 6b98b894c127eed4a5bde646ebf20febcfa656fa Mon Sep 17 00:00:00 2001 From: Artyom Kazak Date: Tue, 2 Apr 2019 14:33:44 +0200 Subject: [PATCH 26/64] Customizable ID types + no extra logic (#28) * Customizable ID types + no extra logic * Fix the Id type (it must behave like a string) * Don't test how we handle duplicate usernames * Migrate groups * Inline mock server methods --- package.yaml | 1 + server/Main.hs | 4 +- src/Web/Scim/Class/Auth.hs | 23 ++- src/Web/Scim/Class/Group.hs | 188 +++++++++++--------- src/Web/Scim/Class/User.hs | 208 +++++++++++----------- src/Web/Scim/Schema/Common.hs | 10 +- src/Web/Scim/Schema/Error.hs | 2 +- src/Web/Scim/Schema/User.hs | 30 ++-- src/Web/Scim/Server.hs | 53 +++--- src/Web/Scim/Server/Mock.hs | 211 +++++++++++------------ test/Test/Capabilities/MetaSchemaSpec.hs | 2 +- test/Test/Class/AuthSpec.hs | 2 +- test/Test/Class/GroupSpec.hs | 60 ++++--- test/Test/Class/UserSpec.hs | 46 ++--- test/Test/Schema/UserSpec.hs | 6 +- test/Test/Util.hs | 24 +++ 16 files changed, 456 insertions(+), 414 deletions(-) diff --git a/package.yaml b/package.yaml index 02e15a51e44..507c8bb0bef 100644 --- a/package.yaml +++ b/package.yaml @@ -61,6 +61,7 @@ dependencies: - microlens - http-api-data - mmorph + - hashable ghc-options: -Wall diff --git a/server/Main.hs b/server/Main.hs index 142861d68d5..638c940d0b3 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -23,7 +23,7 @@ import Text.Email.Validate main :: IO () main = do storage <- TestStorage <$> mkUserDB <*> STMMap.newIO - run 9000 (app MetaSchema.empty (nt storage)) + run 9000 (app @Mock MetaSchema.empty (nt storage)) -- | Create a UserDB with a single user: -- @@ -64,5 +64,5 @@ mkUserDB = do , active = Just True , emails = [email] } - atomically $ STMMap.insert (WithMeta meta (WithId "elton" user)) "elton" db + atomically $ STMMap.insert (WithMeta meta (WithId (Id 0) user)) (Id 0) db pure db diff --git a/src/Web/Scim/Class/Auth.hs b/src/Web/Scim/Class/Auth.hs index 1976c33e635..ada3585727b 100644 --- a/src/Web/Scim/Class/Auth.hs +++ b/src/Web/Scim/Class/Auth.hs @@ -1,19 +1,21 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + -- | HTTP authentication support. Can be used with basic auth, token-based -- auth, or something else (though OAuth is likely not implementable with -- this API). module Web.Scim.Class.Auth - ( AuthDB (..) + ( AuthTypes (..) + , AuthDB (..) ) where import Servant import Web.Scim.Handler --- | An interface that has to be implemented for a server to provide --- authentication. -class FromHttpApiData (AuthData m) => AuthDB m where +-- | Types used in authentication routines. +class AuthTypes tag where -- | The type that the “Authorization” header will be parsed as. This info - -- will be given to 'AuthCheck'. - type AuthData m + -- will be given to 'authCheck'. + type AuthData tag -- | The result of performing authentication. -- @@ -21,11 +23,14 @@ class FromHttpApiData (AuthData m) => AuthDB m where -- complex – for instance, if the auth header provides a token that may or -- may not correspond to a particular organization, then the result could -- be the ID of that organization). - type AuthInfo m + type AuthInfo tag +-- | An interface that has to be implemented for a server to provide +-- authentication. +class (AuthTypes tag, FromHttpApiData (AuthData tag)) => AuthDB tag m where -- | Do authentication or throw an error in `ScimHandler` (e.g. -- 'Web.Scim.Schema.Error.unauthorized') if the provided credentials are -- invalid or don't correspond to any user. authCheck - :: Maybe (AuthData m) - -> ScimHandler m (AuthInfo m) + :: Maybe (AuthData tag) + -> ScimHandler m (AuthInfo tag) diff --git a/src/Web/Scim/Class/Group.hs b/src/Web/Scim/Class/Group.hs index a9654fc891d..99056927f63 100644 --- a/src/Web/Scim/Class/Group.hs +++ b/src/Web/Scim/Class/Group.hs @@ -1,20 +1,21 @@ -module Web.Scim.Class.Group ( - GroupSite (..) +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Web.Scim.Class.Group + ( GroupSite (..) , GroupDB (..) + , GroupTypes (..) , StoredGroup , Group (..) - , GroupId , Member (..) , groupServer ) where -import Control.Monad import Data.Text import Data.Aeson import GHC.Generics (Generic) import Web.Scim.Schema.Common -import Web.Scim.Schema.Error import Web.Scim.Schema.Meta +import Web.Scim.Schema.ListResponse import Web.Scim.ContentType import Web.Scim.Handler import Web.Scim.Class.Auth @@ -22,13 +23,18 @@ import Servant import Servant.API.Generic import Servant.Server.Generic +import qualified Data.Aeson as Aeson + ---------------------------------------------------------------------------- -- /Groups API -type GroupId = Text - type Schema = Text +-- | Configurable parts of 'Group'. +class GroupTypes tag where + -- | Group ID type. + type GroupId tag + -- TODO data Member = Member { value :: Text @@ -55,88 +61,110 @@ instance FromJSON Group where instance ToJSON Group where toJSON = genericToJSON serializeOptions -type StoredGroup = WithMeta (WithId Group) - -data GroupSite route = GroupSite - { getGroups :: route :- - Get '[SCIM] [StoredGroup] - , getGroup :: route :- - Capture "id" Text :> Get '[SCIM] StoredGroup - , postGroup :: route :- - ReqBody '[SCIM] Group :> PostCreated '[SCIM] StoredGroup - , putGroup :: route :- - Capture "id" Text :> ReqBody '[SCIM] Group :> Put '[SCIM] StoredGroup - , patchGroup :: route :- - Capture "id" Text :> Patch '[SCIM] StoredGroup - , deleteGroup :: route :- - Capture "id" Text :> DeleteNoContent '[SCIM] NoContent +type StoredGroup tag = WithMeta (WithId (GroupId tag) Group) + +data GroupSite tag route = GroupSite + { gsGetGroups :: route :- + Get '[SCIM] (ListResponse (StoredGroup tag)) + , gsGetGroup :: route :- + Capture "id" (GroupId tag) :> + Get '[SCIM] (StoredGroup tag) + , gsPostGroup :: route :- + ReqBody '[SCIM] Group :> + PostCreated '[SCIM] (StoredGroup tag) + , gsPutGroup :: route :- + Capture "id" (GroupId tag) :> + ReqBody '[SCIM] Group :> + Put '[SCIM] (StoredGroup tag) + , gsPatchGroup :: route :- + Capture "id" (GroupId tag) :> + ReqBody '[SCIM] Aeson.Value :> + Patch '[SCIM] (StoredGroup tag) + , gsDeleteGroup :: route :- + Capture "id" (GroupId tag) :> + DeleteNoContent '[SCIM] NoContent } deriving (Generic) ---------------------------------------------------------------------------- -- Methods used by the API -class (Monad m, AuthDB m) => GroupDB m where - list :: AuthInfo m -> ScimHandler m [StoredGroup] - get :: AuthInfo m -> GroupId -> ScimHandler m (Maybe StoredGroup) - create :: AuthInfo m -> Group -> ScimHandler m StoredGroup - update :: AuthInfo m -> GroupId -> Group -> ScimHandler m StoredGroup - delete :: AuthInfo m -> GroupId -> ScimHandler m Bool -- ^ Return 'False' if the group didn't exist - getGroupMeta :: AuthInfo m -> ScimHandler m Meta +class (Monad m, GroupTypes tag, AuthDB tag m) => GroupDB tag m where + -- | Get all groups. + getGroups + :: AuthInfo tag + -> ScimHandler m (ListResponse (StoredGroup tag)) + + -- | Get a single group by ID. + -- + -- Should throw 'notFound' if the group does not. + getGroup + :: AuthInfo tag + -> GroupId tag + -> ScimHandler m (StoredGroup tag) + + -- | Create a new group. + -- + -- Should throw 'conflict' if uniqueness constraints are violated. + postGroup + :: AuthInfo tag + -> Group + -> ScimHandler m (StoredGroup tag) + + -- | Overwrite an existing group. + -- + -- Should throw 'notFound' if the group does not exist, and 'conflict' if uniqueness + -- constraints are violated. + putGroup + :: AuthInfo tag + -> GroupId tag + -> Group + -> ScimHandler m (StoredGroup tag) + + -- | Modify an existing group. + -- + -- Should throw 'notFound' if the group doesn't exist, and 'conflict' if uniqueness + -- constraints are violated. + -- + -- FUTUREWORK: add types for PATCH (instead of 'Aeson.Value'). + -- See + patchGroup + :: AuthInfo tag + -> GroupId tag + -> Aeson.Value -- ^ PATCH payload + -> ScimHandler m (StoredGroup tag) + + -- | Delete a group. + -- + -- Should throw 'notFound' if the group does not exist. + deleteGroup + :: AuthInfo tag + -> GroupId tag + -> ScimHandler m () ---------------------------------------------------------------------------- -- API handlers groupServer - :: GroupDB m - => Maybe (AuthData m) -> GroupSite (AsServerT (ScimHandler m)) + :: forall tag m. (Show (GroupId tag), GroupDB tag m) + => Maybe (AuthData tag) -> GroupSite tag (AsServerT (ScimHandler m)) groupServer authData = GroupSite - { getGroups = do - auth <- authCheck authData - getGroups' auth - , getGroup = \gid -> do - auth <- authCheck authData - getGroup' auth gid - , postGroup = \gr -> do - auth <- authCheck authData - postGroup' auth gr - , putGroup = \gid gr -> do - auth <- authCheck authData - putGroup' auth gid gr - , patchGroup = error "PATCH /Groups: not implemented" - , deleteGroup = \gid -> do - auth <- authCheck authData - deleteGroup' auth gid + { gsGetGroups = do + auth <- authCheck @tag authData + getGroups @tag auth + , gsGetGroup = \gid -> do + auth <- authCheck @tag authData + getGroup @tag auth gid + , gsPostGroup = \gr -> do + auth <- authCheck @tag authData + postGroup @tag auth gr + , gsPutGroup = \gid gr -> do + auth <- authCheck @tag authData + putGroup @tag auth gid gr + , gsPatchGroup = \gid patch -> do + auth <- authCheck @tag authData + patchGroup @tag auth gid patch + , gsDeleteGroup = \gid -> do + auth <- authCheck @tag authData + deleteGroup @tag auth gid + pure NoContent } - -getGroups' - :: GroupDB m - => AuthInfo m -> ScimHandler m [StoredGroup] -getGroups' auth = do - list auth - -getGroup' - :: GroupDB m - => AuthInfo m -> GroupId -> ScimHandler m StoredGroup -getGroup' auth gid = do - maybeGroup <- get auth gid - maybe (throwScim (notFound "Group" gid)) pure maybeGroup - -postGroup' - :: GroupDB m - => AuthInfo m -> Group -> ScimHandler m StoredGroup -postGroup' auth gr = do - create auth gr - -putGroup' - :: GroupDB m - => AuthInfo m -> GroupId -> Group -> ScimHandler m StoredGroup -putGroup' auth gid gr = do - update auth gid gr - -deleteGroup' - :: GroupDB m - => AuthInfo m -> GroupId -> ScimHandler m NoContent -deleteGroup' auth gid = do - deleted <- delete auth gid - unless deleted $ throwScim (notFound "Group" gid) - pure NoContent diff --git a/src/Web/Scim/Class/User.hs b/src/Web/Scim/Class/User.hs index 7fe9e0d09a1..5862a14f6f6 100644 --- a/src/Web/Scim/Class/User.hs +++ b/src/Web/Scim/Class/User.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + module Web.Scim.Class.User ( UserDB (..) , StoredUser @@ -5,13 +7,10 @@ module Web.Scim.Class.User , userServer ) where -import Control.Monad -import Data.Text import GHC.Generics (Generic) import Web.Scim.Schema.User import Web.Scim.Schema.Meta import Web.Scim.Schema.Common -import Web.Scim.Schema.Error import Web.Scim.Schema.ListResponse hiding (schemas) import Web.Scim.Handler import Web.Scim.Filter @@ -21,130 +20,117 @@ import Servant import Servant.API.Generic import Servant.Server.Generic +import qualified Data.Aeson as Aeson + ---------------------------------------------------------------------------- -- /Users API -type StoredUser extra = WithMeta (WithId (User extra)) +type StoredUser tag = WithMeta (WithId (UserId tag) (User tag)) -data UserSite extra route = UserSite - { getUsers :: route :- +data UserSite tag route = UserSite + { usGetUsers :: route :- QueryParam "filter" Filter :> - Get '[SCIM] (ListResponse (StoredUser extra)) - , getUser :: route :- - Capture "id" Text :> - Get '[SCIM] (StoredUser extra) - , postUser :: route :- - ReqBody '[SCIM] (User extra) :> - PostCreated '[SCIM] (StoredUser extra) - , putUser :: route :- - Capture "id" Text :> - ReqBody '[SCIM] (User extra) :> - Put '[SCIM] (StoredUser extra) - , patchUser :: route :- - Capture "id" Text :> - Patch '[SCIM] (StoredUser extra) - , deleteUser :: route :- - Capture "id" Text :> + Get '[SCIM] (ListResponse (StoredUser tag)) + , usGetUser :: route :- + Capture "id" (UserId tag) :> + Get '[SCIM] (StoredUser tag) + , usPostUser :: route :- + ReqBody '[SCIM] (User tag) :> + PostCreated '[SCIM] (StoredUser tag) + , usPutUser :: route :- + Capture "id" (UserId tag) :> + ReqBody '[SCIM] (User tag) :> + Put '[SCIM] (StoredUser tag) + , usPatchUser :: route :- + Capture "id" (UserId tag) :> + ReqBody '[SCIM] Aeson.Value :> + Patch '[SCIM] (StoredUser tag) + , usDeleteUser :: route :- + Capture "id" (UserId tag) :> DeleteNoContent '[SCIM] NoContent } deriving (Generic) ---------------------------------------------------------------------------- -- Methods used by the API --- TODO: parameterize UserId -class (Monad m, AuthDB m) => UserDB m where - type UserExtra m - list :: AuthInfo m -> Maybe Filter -> ScimHandler m (ListResponse (StoredUser (UserExtra m))) - get :: AuthInfo m -> UserId -> ScimHandler m (Maybe (StoredUser (UserExtra m))) - create :: AuthInfo m -> User (UserExtra m) -> ScimHandler m (StoredUser (UserExtra m)) - update :: AuthInfo m -> UserId -> User (UserExtra m) -> ScimHandler m (StoredUser (UserExtra m)) - delete :: AuthInfo m -> UserId -> ScimHandler m Bool -- ^ Return 'False' if the user didn't exist - getMeta :: AuthInfo m -> ScimHandler m Meta +class (Monad m, AuthTypes tag, UserTypes tag) => UserDB tag m where + -- | Get all users, optionally filtered by a 'Filter'. + getUsers + :: AuthInfo tag + -> Maybe Filter + -> ScimHandler m (ListResponse (StoredUser tag)) ----------------------------------------------------------------------------- --- API handlers + -- | Get a single user by ID. + -- + -- Should throw 'notFound' if the user doesn't exist. + getUser + :: AuthInfo tag + -> UserId tag + -> ScimHandler m (StoredUser tag) -userServer - :: UserDB m - => Maybe (AuthData m) -> UserSite (UserExtra m) (AsServerT (ScimHandler m)) -userServer authData = UserSite - { getUsers = \mbFilter -> do - auth <- authCheck authData - getUsers' auth mbFilter - , getUser = \uid -> do - auth <- authCheck authData - getUser' auth uid - , postUser = \user -> do - auth <- authCheck authData - postUser' auth user - , putUser = \uid user -> do - auth <- authCheck authData - putUser' auth uid user - , patchUser = error "PATCH /Users: not implemented" - , deleteUser = \uid -> do - auth <- authCheck authData - deleteUser' auth uid - } + -- | Create a new user. + -- + -- Should throw 'conflict' if uniqueness constraints are violated. + postUser + :: AuthInfo tag + -> User tag + -> ScimHandler m (StoredUser tag) -getUsers' - :: UserDB m - => AuthInfo m - -> Maybe Filter - -> ScimHandler m (ListResponse (StoredUser (UserExtra m))) -getUsers' auth mbFilter = do - list auth mbFilter + -- | Overwrite an existing user. + -- + -- Should throw 'notFound' if the user doesn't exist, and 'conflict' if uniqueness + -- constraints are violated. + putUser + :: AuthInfo tag + -> UserId tag + -> User tag + -> ScimHandler m (StoredUser tag) -getUser' - :: UserDB m - => AuthInfo m - -> UserId - -> ScimHandler m (StoredUser (UserExtra m)) -getUser' auth uid = do - maybeUser <- get auth uid - maybe (throwScim (notFound "User" uid)) pure maybeUser + -- | Modify an existing user. + -- + -- Should throw 'notFound' if the user doesn't exist, and 'conflict' if uniqueness + -- constraints are violated. + -- + -- FUTUREWORK: add types for PATCH (instead of 'Aeson.Value'). + -- See + patchUser + :: AuthInfo tag + -> UserId tag + -> Aeson.Value -- ^ PATCH payload + -> ScimHandler m (StoredUser tag) -postUser' - :: UserDB m - => AuthInfo m - -> User (UserExtra m) - -> ScimHandler m (StoredUser (UserExtra m)) -postUser' auth user = do - -- Find users with the same username (case-insensitive) + -- | Delete a user. -- - -- TODO: it might be worth it to let 'create' handle conflicts if it can - -- do it in one pass instead of two passes. Same applies to 'updateUser'' - -- and similar functions. - let filter_ = FilterAttrCompare AttrUserName OpEq (ValString (userName user)) - stored <- list auth (Just filter_) - when (totalResults stored > 0) $ - throwScim conflict - create auth user + -- Should throw 'notFound' if the user doesn't exist. + deleteUser + :: AuthInfo tag + -> UserId tag + -> ScimHandler m () --- | Fully update a 'User'. --- --- Spec: . --- --- FUTUREWORK: according to the spec, we should handle cases where someone --- attempts to overwrite @readOnly@ and @immutable@ attributes. Currently we --- don't have any such attributes. --- --- See . -putUser' - :: UserDB m - => AuthInfo m - -> UserId - -> User (UserExtra m) - -> ScimHandler m (StoredUser (UserExtra m)) -putUser' auth uid user = do - stored <- get auth uid - case stored of - Just _ -> update auth uid user - Nothing -> throwScim (notFound "User" uid) +---------------------------------------------------------------------------- +-- API handlers -deleteUser' - :: UserDB m - => AuthInfo m -> UserId -> ScimHandler m NoContent -deleteUser' auth uid = do - deleted <- delete auth uid - unless deleted $ throwScim (notFound "User" uid) - pure NoContent +userServer + :: forall tag m. (AuthDB tag m, UserDB tag m) + => Maybe (AuthData tag) -> UserSite tag (AsServerT (ScimHandler m)) +userServer authData = UserSite + { usGetUsers = \mbFilter -> do + auth <- authCheck @tag authData + getUsers @tag auth mbFilter + , usGetUser = \uid -> do + auth <- authCheck @tag authData + getUser @tag auth uid + , usPostUser = \user -> do + auth <- authCheck @tag authData + postUser @tag auth user + , usPutUser = \uid user -> do + auth <- authCheck @tag authData + putUser @tag auth uid user + , usPatchUser = \uid patch -> do + auth <- authCheck @tag authData + patchUser @tag auth uid patch + , usDeleteUser = \uid -> do + auth <- authCheck @tag authData + deleteUser @tag auth uid + pure NoContent + } diff --git a/src/Web/Scim/Schema/Common.hs b/src/Web/Scim/Schema/Common.hs index 29d25157d59..c67b41be273 100644 --- a/src/Web/Scim/Schema/Common.hs +++ b/src/Web/Scim/Schema/Common.hs @@ -10,17 +10,17 @@ import qualified Network.URI as Network import qualified Data.HashMap.Lazy as HML -data WithId a = WithId - { id :: Text +data WithId id a = WithId + { id :: id , value :: a } deriving (Eq, Show) -instance (ToJSON a) => ToJSON (WithId a) where +instance (ToJSON id, ToJSON a) => ToJSON (WithId id a) where toJSON (WithId i v) = case toJSON v of - (Object o) -> Object (HML.insert "id" (String i) o) + (Object o) -> Object (HML.insert "id" (toJSON i) o) other -> other -instance (FromJSON a) => FromJSON (WithId a) where +instance (FromJSON id, FromJSON a) => FromJSON (WithId id a) where parseJSON = withObject "WithId" $ \o -> WithId <$> o .: "id" <*> parseJSON (Object o) diff --git a/src/Web/Scim/Schema/Error.hs b/src/Web/Scim/Schema/Error.hs index bce6f7f33c7..8aa8f7416aa 100644 --- a/src/Web/Scim/Schema/Error.hs +++ b/src/Web/Scim/Schema/Error.hs @@ -125,7 +125,7 @@ notFound resourceType resourceId = { schemas = [Error2_0] , status = Status 404 , scimType = Nothing - , detail = pure $ resourceType <> " '" <> resourceId <> "' not found" + , detail = pure $ resourceType <> " " <> resourceId <> " not found" } conflict :: ScimError diff --git a/src/Web/Scim/Schema/User.hs b/src/Web/Scim/Schema/User.hs index 74b10bdf9d4..2a2e990c478 100644 --- a/src/Web/Scim/Schema/User.hs +++ b/src/Web/Scim/Schema/User.hs @@ -1,4 +1,6 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} -- | SCIM user representation. -- @@ -56,8 +58,15 @@ import Web.Scim.Schema.User.Photo (Photo) import GHC.Generics (Generic) +-- | Configurable parts of 'User'. +class UserTypes tag where + -- | User ID type. + type UserId tag + -- | Extra data carried with each 'User'. + type UserExtra tag -data User extra = User +-- | SCIM user record, parametrized with type-level tag @t@ (see 'UserTypes'). +data User tag = User { schemas :: [Schema] @@ -101,13 +110,16 @@ data User extra = User -- -- FUTUREWORK: make it easy for hscim users to implement a proper parser (with correct -- rendering of optional and multivalued fields, lowercase objects, etc). - , extra :: extra - } deriving (Show, Eq, Generic) + , extra :: UserExtra tag + } deriving (Generic) + +deriving instance Show (UserExtra tag) => Show (User tag) +deriving instance Eq (UserExtra tag) => Eq (User tag) empty - :: [Schema] -- ^ Schemas - -> extra -- ^ Extra data - -> User extra + :: [Schema] -- ^ Schemas + -> UserExtra tag -- ^ Extra data + -> User tag empty schemas extra = User { schemas = schemas , userName = "" @@ -133,7 +145,7 @@ empty schemas extra = User , extra = extra } -instance FromJSON extra => FromJSON (User extra) where +instance FromJSON (UserExtra tag) => FromJSON (User tag) where parseJSON = withObject "User" $ \obj -> do -- Lowercase all fields let o = HM.fromList . map (over _1 toLower) . HM.toList $ obj @@ -163,7 +175,7 @@ instance FromJSON extra => FromJSON (User extra) where extra <- parseJSON (Object obj) pure User{..} -instance ToJSON extra => ToJSON (User extra) where +instance ToJSON (UserExtra tag) => ToJSON (User tag) where toJSON User{..} = let mainObject = HM.fromList $ concat [ [ "schemas" .= schemas ] @@ -204,8 +216,6 @@ instance ToJSON extra => ToJSON (User extra) where [] -> [] xs -> [fname .= xs] -type UserId = Text - -- | A type used to indicate that the SCIM record doesn't have any extra data. Encoded as an -- empty map. data NoUserExtra = NoUserExtra diff --git a/src/Web/Scim/Server.hs b/src/Web/Scim/Server.hs index 0a050e19ee9..e2930e094a4 100644 --- a/src/Web/Scim/Server.hs +++ b/src/Web/Scim/Server.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + module Web.Scim.Server ( -- * WAI application @@ -11,60 +13,64 @@ module Web.Scim.Server , GroupAPI, groupServer ) where -import Web.Scim.Class.User (UserSite (..), UserDB (..), userServer) -import Web.Scim.Class.Group (GroupSite (..), GroupDB, groupServer) -import Web.Scim.Class.Auth (AuthDB (..)) -import Web.Scim.Capabilities.MetaSchema (ConfigSite, Configuration, configServer) -import Web.Scim.Handler import GHC.Generics (Generic) import Network.Wai import Servant import Servant.API.Generic import Servant.Server.Generic +import Web.Scim.Class.User (UserSite (..), UserDB (..), userServer) +import Web.Scim.Class.Group (GroupSite (..), GroupTypes (..), GroupDB, groupServer) +import Web.Scim.Class.Auth (AuthDB (..), AuthTypes (..)) +import Web.Scim.Capabilities.MetaSchema (ConfigSite, Configuration, configServer) +import Web.Scim.Handler + ---------------------------------------------------------------------------- -- API specification -type DB m = (UserDB m, GroupDB m, AuthDB m) +-- | A constraint indicating that monad @m@ supports operations with users and groups marked +-- with tag @t@. +type DB tag m = (UserDB tag m, GroupDB tag m, AuthDB tag m) type ConfigAPI = ToServantApi ConfigSite -type UserAPI userExtra = ToServantApi (UserSite userExtra) -type GroupAPI = ToServantApi GroupSite -type SiteAPI authData userExtra = ToServantApi (Site authData userExtra) +type UserAPI tag = ToServantApi (UserSite tag) +type GroupAPI tag = ToServantApi (GroupSite tag) +type SiteAPI tag = ToServantApi (Site tag) -data Site authData userExtra route = Site +data Site tag route = Site { config :: route :- ConfigAPI , users :: route :- - Header "Authorization" authData :> - "Users" :> UserAPI userExtra + Header "Authorization" (AuthData tag) :> + "Users" :> UserAPI tag , groups :: route :- - Header "Authorization" authData :> - "Groups" :> GroupAPI + Header "Authorization" (AuthData tag) :> + "Groups" :> GroupAPI tag } deriving (Generic) ---------------------------------------------------------------------------- -- API implementation siteServer :: - forall m. DB m => - Configuration -> Site (AuthData m) (UserExtra m) (AsServerT (ScimHandler m)) + forall tag m. (DB tag m, Show (GroupId tag)) => + Configuration -> Site tag (AsServerT (ScimHandler m)) siteServer conf = Site { config = toServant $ configServer conf - , users = \authData -> toServant (userServer authData) - , groups = \authData -> toServant (groupServer authData) + , users = \authData -> toServant (userServer @tag authData) + , groups = \authData -> toServant (groupServer @tag authData) } where ---------------------------------------------------------------------------- -- Server-starting utilities -type App m api = - ( DB m +type App tag m api = + ( DB tag m + , Show (GroupId tag) , HasServer api '[] ) -mkapp :: forall m api. (App m api) +mkapp :: forall tag m api. (App tag m api) => Proxy api -> ServerT api (ScimHandler m) -> (forall a. ScimHandler m a -> Handler a) @@ -73,9 +79,10 @@ mkapp proxy api nt = serve proxy $ hoistServer proxy nt api -app :: forall m. App m (SiteAPI (AuthData m) (UserExtra m)) +app :: forall tag m. App tag m (SiteAPI tag) => Configuration -> (forall a. ScimHandler m a -> Handler a) -> Application -app c = mkapp (Proxy @(SiteAPI (AuthData m) (UserExtra m))) +app c = mkapp @tag + (Proxy @(SiteAPI tag)) (toServant $ siteServer c) diff --git a/src/Web/Scim/Server/Mock.hs b/src/Web/Scim/Server/Mock.hs index 3118ce3e63c..07102100af3 100644 --- a/src/Web/Scim/Server/Mock.hs +++ b/src/Web/Scim/Server/Mock.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} -- | A mock server for use in our testsuite, as well as for automated @@ -12,12 +14,15 @@ import Web.Scim.Class.Auth import Control.Monad.STM (STM, atomically) import Control.Monad.Reader import Control.Monad.Morph +import Data.Aeson +import Data.Hashable import Data.Text (Text, pack) import Data.Time.Clock import Data.Time.Calendar import GHC.Exts (sortWith) import ListT import qualified STMContainers.Map as STMMap +import Text.Read (readMaybe) import Web.Scim.Schema.User import Web.Scim.Schema.Error import Web.Scim.Schema.Meta @@ -29,8 +34,20 @@ import Web.Scim.Filter import Web.Scim.Handler import Servant -type UserStorage = STMMap.Map Text (StoredUser NoUserExtra) -type GroupStorage = STMMap.Map Text StoredGroup +-- | Tag used in the mock server. +data Mock + +-- | A simple ID type. +newtype Id = Id { unId :: Int } + deriving (Eq, Show, Ord, Hashable, ToHttpApiData, FromHttpApiData) + +instance ToJSON Id where + toJSON = toJSON . show . unId +instance FromJSON Id where + parseJSON = maybe (fail "not a number") (pure . Id) . readMaybe <=< parseJSON + +type UserStorage = STMMap.Map Id (StoredUser Mock) +type GroupStorage = STMMap.Map Id (StoredGroup Mock) data TestStorage = TestStorage { userDB :: UserStorage @@ -50,15 +67,15 @@ liftSTM = liftIO . atomically hoistSTM :: (MFunctor t, MonadIO m) => t STM a -> t m a hoistSTM = hoist liftSTM -instance UserDB TestServer where - type UserExtra TestServer = NoUserExtra - list () mbFilter = do - -- Note: in production instances it would make sense to remove this code - -- and let the implementor of the 'UserDB' instance do filtering (e.g. - -- doing case-insensitive queries on common attributes can be done - -- faster if the underlying database has indices). However, it might - -- still be useful to provide a default implementation in @hscim@ and - -- let users of the library decide whether they want to use it or not. +---------------------------------------------------------------------------- +-- UserDB + +instance UserTypes Mock where + type UserId Mock = Id + type UserExtra Mock = NoUserExtra + +instance UserDB Mock TestServer where + getUsers () mbFilter = do m <- userDB <$> ask users <- liftSTM $ ListT.toList $ STMMap.stream m let check user = case mbFilter of @@ -68,103 +85,98 @@ instance UserDB TestServer where case filterUser filter_ user' of Right res -> pure res Left err -> throwScim (badRequest InvalidFilter (Just err)) - fromList . sortWith (Common.id . thing) <$> - filterM check (snd <$> users) - get () i = do + fromList . sortWith (Common.id . thing) <$> filterM check (snd <$> users) + + getUser () uid = do m <- userDB <$> ask - liftSTM $ STMMap.lookup i m - create auth user = do + liftSTM (STMMap.lookup uid m) >>= \case + Nothing -> throwScim (notFound "User" (pack (show uid))) + Just x -> pure x + + postUser () user = do m <- userDB <$> ask - met <- getMeta auth - newUser <- hoistSTM $ insertUser user met m + uid <- Id <$> liftSTM (STMMap.size m) + let newUser = WithMeta (createMeta UserResource) $ WithId uid user + liftSTM $ STMMap.insert newUser uid m return newUser - update () uid user = do - storage <- userDB <$> ask - hoistSTM $ updateUser uid user storage - delete () uid = do + + putUser () uid user = do + m <- userDB <$> ask + liftSTM (STMMap.lookup uid m) >>= \case + Nothing -> throwScim (notFound "User" (pack (show uid))) + Just stored -> do + let newUser = WithMeta (meta stored) $ WithId uid user + liftSTM $ STMMap.insert newUser uid m + pure newUser + + patchUser _ _ _ = throwScim (serverError "PATCH /Users not implemented") + + deleteUser () uid = do m <- userDB <$> ask - hoistSTM $ delUser uid m - getMeta () = return (createMeta UserResource) + liftSTM (STMMap.lookup uid m) >>= \case + Nothing -> throwScim (notFound "User" (pack (show uid))) + Just _ -> liftSTM $ STMMap.delete uid m + +-- (there seems to be no readOnly fields in User) +assertMutability :: User Mock -> StoredUser Mock -> Bool +assertMutability _newUser _stored = True + +---------------------------------------------------------------------------- +-- GroupDB -instance GroupDB TestServer where - list () = do +instance GroupTypes Mock where + type GroupId Mock = Id + +instance GroupDB Mock TestServer where + getGroups () = do m <- groupDB <$> ask groups <- liftSTM $ ListT.toList $ STMMap.stream m - return $ sortWith (Common.id . thing) $ snd <$> groups - get () i = do + return $ fromList . sortWith (Common.id . thing) $ snd <$> groups + + getGroup () gid = do m <- groupDB <$> ask - liftSTM $ STMMap.lookup i m - create auth grp = do - storage <- groupDB <$> ask - met <- getGroupMeta auth - newGroup <- hoistSTM $ insertGroup grp met storage - pure newGroup - update () i g = do + liftSTM (STMMap.lookup gid m) >>= \case + Nothing -> throwScim (notFound "Group" (pack (show gid))) + Just grp -> pure grp + + postGroup () grp = do m <- groupDB <$> ask - hoistSTM $ updateGroup i g m - delete () gid = do + gid <- Id <$> liftSTM (STMMap.size m) + let newGroup = WithMeta (createMeta GroupResource) $ WithId gid grp + liftSTM $ STMMap.insert newGroup gid m + return newGroup + + putGroup () gid grp = do m <- groupDB <$> ask - hoistSTM $ delGroup gid m - getGroupMeta () = return (createMeta GroupResource) + liftSTM (STMMap.lookup gid m) >>= \case + Nothing -> throwScim (notFound "Group" (pack (show gid))) + Just stored -> do + let newGroup = WithMeta (meta stored) $ WithId gid grp + liftSTM $ STMMap.insert newGroup gid m + pure newGroup -instance AuthDB TestServer where - type AuthData TestServer = Text - type AuthInfo TestServer = () - authCheck = \case - Just "authorized" -> pure () - _ -> throwScim (unauthorized "expected 'authorized'") + patchGroup _ _ _ = throwScim (serverError "PATCH /Users not implemented") -insertGroup :: Group -> Meta -> GroupStorage -> ScimHandler STM StoredGroup -insertGroup grp met storage = do - size <- lift $ STMMap.size storage - let gid = pack . show $ size - newGroup = WithMeta met $ WithId gid grp - lift $ STMMap.insert newGroup gid storage - return newGroup - -updateGroup :: GroupId -> Group -> GroupStorage -> ScimHandler STM StoredGroup -updateGroup gid grp storage = do - existing <- lift $ STMMap.lookup gid storage - case existing of - Nothing -> throwScim (notFound "Group" gid) - Just stored -> do - let newMeta = meta stored - newGroup = WithMeta newMeta $ WithId gid grp - lift $ STMMap.insert newGroup gid storage - pure newGroup - -updateUser - :: UserId - -> User NoUserExtra - -> UserStorage - -> ScimHandler STM (StoredUser NoUserExtra) -updateUser uid user storage = do - existing <- lift $ STMMap.lookup uid storage - case existing of - Nothing -> throwScim (notFound "User" uid) - Just stored -> do - let newMeta = meta stored - newUser = WithMeta newMeta $ WithId uid user - lift $ STMMap.insert newUser uid storage - pure newUser + deleteGroup () gid = do + m <- groupDB <$> ask + liftSTM (STMMap.lookup gid m) >>= \case + Nothing -> throwScim (notFound "Group" (pack (show gid))) + Just _ -> liftSTM $ STMMap.delete gid m --- (there seems to be no readOnly fields in User) -assertMutability :: User NoUserExtra -> StoredUser NoUserExtra -> Bool -assertMutability _newUser _stored = True +---------------------------------------------------------------------------- +-- AuthDB -delGroup :: GroupId -> GroupStorage -> ScimHandler STM Bool -delGroup gid storage = do - g <- lift $ STMMap.lookup gid storage - case g of - Nothing -> return False - Just _ -> lift $ STMMap.delete gid storage >> return True +instance AuthTypes Mock where + type AuthData Mock = Text + type AuthInfo Mock = () -delUser :: UserId -> UserStorage -> ScimHandler STM Bool -delUser uid storage = do - u <- lift $ STMMap.lookup uid storage - case u of - Nothing -> return False - Just _ -> lift $ STMMap.delete uid storage >> return True +instance AuthDB Mock TestServer where + authCheck = \case + Just "authorized" -> pure () + _ -> throwScim (unauthorized "expected 'authorized'") + +---------------------------------------------------------------------------- +-- Misc -- 2018-01-01 00:00 testDate :: UTCTime @@ -183,19 +195,6 @@ createMeta rType = Meta , location = Common.URI $ URI "todo" Nothing "" "" "" } --- insert with a simple incrementing integer id (good for testing) -insertUser - :: User NoUserExtra - -> Meta - -> UserStorage - -> ScimHandler STM (StoredUser NoUserExtra) -insertUser user met storage = do - size <- lift $ STMMap.size storage - let uid = pack . show $ size - newUser = WithMeta met $ WithId uid user - lift $ STMMap.insert newUser uid storage - return newUser - -- Natural transformation from our transformer stack to the Servant stack -- this takes the initial environment and returns the transformation nt :: TestStorage -> ScimHandler TestServer a -> Handler a diff --git a/test/Test/Capabilities/MetaSchemaSpec.hs b/test/Test/Capabilities/MetaSchemaSpec.hs index 7e899e289e6..08cb970fd0f 100644 --- a/test/Test/Capabilities/MetaSchemaSpec.hs +++ b/test/Test/Capabilities/MetaSchemaSpec.hs @@ -22,7 +22,7 @@ import Test.Hspec.Wai hiding (post, put, patch) app :: IO Application app = do storage <- emptyTestStorage - pure $ mkapp (Proxy @ConfigAPI) (toServant (configServer empty)) (nt storage) + pure $ mkapp @Mock (Proxy @ConfigAPI) (toServant (configServer empty)) (nt storage) shouldSatisfy :: (Show a, FromJSON a) => WaiSession SResponse -> (a -> Bool) -> WaiExpectation diff --git a/test/Test/Class/AuthSpec.hs b/test/Test/Class/AuthSpec.hs index 9f2d0597d4e..7805e1fd66d 100644 --- a/test/Test/Class/AuthSpec.hs +++ b/test/Test/Class/AuthSpec.hs @@ -17,7 +17,7 @@ testStorage :: IO TestStorage testStorage = TestStorage <$> STMMap.newIO <*> STMMap.newIO spec :: Spec -spec = beforeAll ((\s -> app empty (nt s)) <$> testStorage) $ do +spec = beforeAll ((\s -> app @Mock empty (nt s)) <$> testStorage) $ do describe "/ServiceProviderConfig" $ do it "is accessible without authentication" $ do get "/ServiceProviderConfig" `shouldRespondWith` 200 diff --git a/test/Test/Class/GroupSpec.hs b/test/Test/Class/GroupSpec.hs index d7de49be1ca..33046bea694 100644 --- a/test/Test/Class/GroupSpec.hs +++ b/test/Test/Class/GroupSpec.hs @@ -13,18 +13,18 @@ import Test.Hspec hiding (shouldSatisfy) import Test.Hspec.Wai hiding (post, put, patch) import Servant.API.Generic - app :: IO Application app = do storage <- emptyTestStorage let auth = Just "authorized" - pure $ mkapp (Proxy @GroupAPI) (toServant (groupServer auth)) (nt storage) + pure $ mkapp @Mock (Proxy @(GroupAPI Mock)) + (toServant (groupServer @Mock auth)) (nt storage) spec :: Spec spec = beforeAll app $ do describe "GET & POST /Groups" $ do it "responds with [] in empty environment" $ do - get "/" `shouldRespondWith` [scim|[]|] + get "/" `shouldRespondWith` emptyList it "can insert then retrieve stored group" $ do post "/" adminGroup `shouldRespondWith` 201 @@ -32,10 +32,10 @@ spec = beforeAll app $ do describe "GET /Groups/:id" $ do it "responds with 404 for unknown group" $ do - get "/unknown" `shouldRespondWith` unknown + get "/9999" `shouldRespondWith` 404 - it "retrieves stored user" $ do - -- the test implementation stores users with uid [0,1..n-1] + it "retrieves stored group" $ do + -- the test implementation stores groups with uid [0,1..n-1] get "/0" `shouldRespondWith` admins describe "PUT /Groups/:id" $ do @@ -43,7 +43,7 @@ spec = beforeAll app $ do put "/0" adminUpdate0 `shouldRespondWith` updatedAdmins0 it "does not create new group" $ do - put "/nonexisting" adminGroup `shouldRespondWith` 404 + put "/9999" adminGroup `shouldRespondWith` 404 describe "DELETE /Groups/:id" $ do it "responds with 404 for unknown group" $ do @@ -67,18 +67,25 @@ adminGroup = [scim| groups :: ResponseMatcher groups = [scim| - [{ "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], - "displayName":"Admin", - "members":[], - "id":"0", - "meta":{ - "resourceType":"Group", - "location":"todo", - "created":"2018-01-01T00:00:00Z", - "version":"W/\"testVersion\"", - "lastModified":"2018-01-01T00:00:00Z" - } - }]|] + { "schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], + "Resources": + [{ "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], + "displayName":"Admin", + "members":[], + "id":"0", + "meta":{ + "resourceType":"Group", + "location":"todo", + "created":"2018-01-01T00:00:00Z", + "version":"W/\"testVersion\"", + "lastModified":"2018-01-01T00:00:00Z" + } + } + ], + "totalResults":1, + "itemsPerPage":1, + "startIndex":0 + }|] admins :: ResponseMatcher admins = [scim| @@ -126,10 +133,11 @@ updatedAdmins0 = [scim| } }|] - -unknown :: ResponseMatcher -unknown = [scim| - { "schemas": ["urn:ietf:params:scim:api:messages:2.0:Error"], - "status": "404", - "detail": "Group 'unknown' not found" - }|] { matchStatus = 404 } +emptyList :: ResponseMatcher +emptyList = [scim| + { "schemas": ["urn:ietf:params:scim:api:messages:2.0:ListResponse"], + "Resources":[], + "totalResults":0, + "itemsPerPage":0, + "startIndex":0 + }|] diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index 6f19fdac8c8..62508cb4e74 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -4,7 +4,6 @@ module Test.Class.UserSpec (spec) where import Test.Util -import Web.Scim.Schema.User (NoUserExtra) import Web.Scim.Server (mkapp, UserAPI, userServer) import Web.Scim.Server.Mock import Test.Hspec @@ -19,7 +18,7 @@ app :: IO Application app = do storage <- emptyTestStorage let auth = Just "authorized" - pure $ mkapp (Proxy @(UserAPI NoUserExtra)) (toServant (userServer auth)) (nt storage) + pure $ mkapp @Mock (Proxy @(UserAPI Mock)) (toServant (userServer auth)) (nt storage) spec :: Spec spec = beforeAll app $ do @@ -32,9 +31,6 @@ spec = beforeAll app $ do post "/" newJim `shouldRespondWith` 201 get "/" `shouldRespondWith` allUsers - it "doesn't allow duplicate usernames" $ do - post "/" newBarbara' `shouldRespondWith` conflict - describe "filtering" $ do it "can filter by username" $ do get "/?filter=userName eq \"bjensen\"" `shouldRespondWith` onlyBarbara @@ -54,7 +50,12 @@ spec = beforeAll app $ do describe "GET /Users/:id" $ do it "responds with 404 for unknown user" $ do - get "/unknown" `shouldRespondWith` unknown + get "/9999" `shouldRespondWith` 404 + + -- FUTUREWORK: currently it returns 404: + -- https://github.com/haskell-servant/servant/issues/1155 + xit "responds with 401 for unparseable user ID" $ do + get "/unparseable" `shouldRespondWith` 401 it "retrieves stored user" $ do -- the test implementation stores users with uid [0,1..n-1] @@ -64,12 +65,12 @@ spec = beforeAll app $ do it "overwrites the user" $ do put "/0" barbUpdate0 `shouldRespondWith` updatedBarb0 - it "does not create new user" $ do - put "/nonexisting" newBarbara `shouldRespondWith` 404 + it "does not create new users" $ do + put "/9999" newBarbara `shouldRespondWith` 404 describe "DELETE /Users/:id" $ do it "responds with 404 for unknown user" $ do - delete "/unknown" `shouldRespondWith` 404 + delete "/9999" `shouldRespondWith` 404 it "deletes a stored user" $ do delete "/0" `shouldRespondWith` 204 @@ -90,19 +91,6 @@ newBarbara = [scim| } }|] --- Same as 'newBarbara', but with a different userName (the names only differ in case) -newBarbara' :: ByteString -newBarbara' = [scim| - { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], - "userName":"BJensen", - "externalId":"bjensen", - "name":{ - "formatted":"Ms. Barbara J Jensen III", - "familyName":"Jensen", - "givenName":"Barbara" - } - }|] - newJim :: ByteString newJim = [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], @@ -266,17 +254,3 @@ emptyList = [scim| "itemsPerPage":0, "startIndex":0 }|] - -unknown :: ResponseMatcher -unknown = [scim| - { "schemas": ["urn:ietf:params:scim:api:messages:2.0:Error"], - "status": "404", - "detail": "User 'unknown' not found" - }|] { matchStatus = 404 } - -conflict :: ResponseMatcher -conflict = [scim| - { "schemas": ["urn:ietf:params:scim:api:messages:2.0:Error"], - "scimType": "uniqueness", - "status": "409" - }|] { matchStatus = 409 } diff --git a/test/Test/Schema/UserSpec.hs b/test/Test/Schema/UserSpec.hs index 3def446a5a3..ce98af0ef7d 100644 --- a/test/Test/Schema/UserSpec.hs +++ b/test/Test/Schema/UserSpec.hs @@ -54,7 +54,7 @@ spec = do Right (extendedUser (UserExtraObject "foo")) -- | A 'User' with all attributes present. -completeUser :: User NoUserExtra +completeUser :: User (TestTag Text () () NoUserExtra) completeUser = User { schemas = [User20] , userName = "sample userName" @@ -181,7 +181,7 @@ completeUserJson = [scim| |] -- | A 'User' with all attributes empty (if possible). -minimalUser :: User NoUserExtra +minimalUser :: User (TestTag Text () () NoUserExtra) minimalUser = (empty [User20] NoUserExtra) { userName = "sample userName" } -- | Reference encoding of 'minimalUser'. @@ -262,7 +262,7 @@ instance ToJSON UserExtraTest where object ["urn:hscim:test" .= object ["test" .= t]] -- | A 'User' with extra fields present. -extendedUser :: UserExtraTest -> User UserExtraTest +extendedUser :: UserExtraTest -> User (TestTag Text () () UserExtraTest) extendedUser e = (empty [User20, CustomSchema "urn:hscim:test"] e) { userName = "sample userName" } diff --git a/test/Test/Util.hs b/test/Test/Util.hs index 4f4551d5b75..c3fee3424d7 100644 --- a/test/Test/Util.hs +++ b/test/Test/Util.hs @@ -8,6 +8,8 @@ module Test.Util ( -- * JSON parsing , Field(..) , getField + -- * Tag + , TestTag ) where import Data.ByteString (ByteString) @@ -25,6 +27,10 @@ import Data.Proxy import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import qualified Data.HashMap.Strict as SMap +import Web.Scim.Schema.User (UserTypes (..)) +import Web.Scim.Class.Group (GroupTypes (..)) +import Web.Scim.Class.Auth (AuthTypes (..)) + ---------------------------------------------------------------------------- -- Redefine wai test helpers to include scim+json content type @@ -101,3 +107,21 @@ instance (KnownSymbol s, ToJSON a) => ToJSON (Field s a) where toJSON (Field x) = object [ key .= x] where key = pack $ symbolVal (Proxy :: Proxy s) + +---------------------------------------------------------------------------- +-- Tag + +-- | A type-level tag for 'UserTypes', 'AuthTypes', etc. that allows picking any types we +-- might need in tests. +data TestTag id authData authInfo userExtra + +instance UserTypes (TestTag id authData authInfo userExtra) where + type UserId (TestTag id authData authInfo userExtra) = id + type UserExtra (TestTag id authData authInfo userExtra) = userExtra + +instance GroupTypes (TestTag id authData authInfo userExtra) where + type GroupId (TestTag id authData authInfo userExtra) = id + +instance AuthTypes (TestTag id authData authInfo userExtra) where + type AuthData (TestTag id authData authInfo userExtra) = authData + type AuthInfo (TestTag id authData authInfo userExtra) = authInfo From 37d4e2ede83267e2fc9ccca87403751566ebed19 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Tue, 7 Jan 2020 10:38:33 +0100 Subject: [PATCH 27/64] Implement PATCH (#35) * ListResponse is 1-indexed, not 0-indexed * implement patch in terms of get and put * Implements patch _only_ for userName, displayName, externalId * Add Azure acceptance test Co-authored-by: fisx --- package.yaml | 82 ++++--- server/Main.hs | 5 +- src/Web/Scim/AttrName.hs | 42 ++++ src/Web/Scim/Capabilities/MetaSchema.hs | 2 +- src/Web/Scim/Class/User.hs | 48 +++- src/Web/Scim/Filter.hs | 143 ++++++++---- src/Web/Scim/Schema/Common.hs | 24 -- src/Web/Scim/Schema/Error.hs | 12 +- src/Web/Scim/Schema/ListResponse.hs | 4 +- src/Web/Scim/Schema/PatchOp.hs | 113 +++++++++ src/Web/Scim/Schema/Schema.hs | 58 ++++- src/Web/Scim/Schema/User.hs | 110 +++++++-- src/Web/Scim/Schema/User/Name.hs | 1 - src/Web/Scim/Server/Mock.hs | 26 ++- src/Web/Scim/Test/Acceptance.hs | 209 +++++++++++++++++ {test => src/Web/Scim}/Test/Util.hs | 25 +- stack.yaml | 5 + test/Test/AcceptanceSpec.hs | 19 ++ test/Test/Capabilities/MetaSchemaSpec.hs | 6 +- test/Test/Class/GroupSpec.hs | 6 +- test/Test/Class/UserSpec.hs | 279 ++++++++++++++++++++++- test/Test/FilterSpec.hs | 44 +++- test/Test/Schema/PatchOpSpec.hs | 79 +++++++ test/Test/Schema/UserSpec.hs | 105 ++++++++- 24 files changed, 1258 insertions(+), 189 deletions(-) create mode 100644 src/Web/Scim/AttrName.hs create mode 100644 src/Web/Scim/Schema/PatchOp.hs create mode 100644 src/Web/Scim/Test/Acceptance.hs rename {test => src/Web/Scim}/Test/Util.hs (83%) create mode 100644 test/Test/AcceptanceSpec.hs create mode 100644 test/Test/Schema/PatchOpSpec.hs diff --git a/package.yaml b/package.yaml index 507c8bb0bef..5c8370e9460 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: hscim -version: 0.1.1.0 +version: 0.2 synopsis: ... description: ... homepage: https://github.com/wireapp/hscim/README.md @@ -34,36 +34,46 @@ extra-source-files: - README.md dependencies: - - base >= 4.11 && < 5 - - bytestring - aeson - aeson-qq + - attoparsec + - base >= 4.11 && < 5 + - bytestring + - email-validate + - errors + - hashable + - hedgehog + - hspec + - hspec-expectations + - hspec-wai + - http-api-data + - http-media + - http-types + - hw-hspec-hedgehog + - list-t + - microlens + - mmorph - mtl + - network-uri + - network-uri-static >= 0.1.1.0 + - scientific - servant + - servant-server - servant-server >= 0.14.1 + - stm + - stm-containers + - template-haskell - text - time - - wai - - network-uri - - network-uri-static >= 0.1.1.0 - unordered-containers - - email-validate - - errors - - stm - - list-t - - http-types - - stm-containers - - http-media - uuid - - template-haskell - - scientific - - attoparsec - - microlens - - http-api-data - - mmorph - - hashable + - vector + - wai + - wai-extra + - wai-logger + - warp -ghc-options: -Wall +ghc-options: -Wall -Werror library: source-dirs: src @@ -83,29 +93,27 @@ tests: ghc-options: -threaded -rtsopts -with-rtsopts=-N source-dirs: - test - - src dependencies: + - hscim + - aeson + - aeson-qq - base - bytestring - - hscim + - containers + - hedgehog - hspec + - hspec-discover + - hspec-expectations - hspec-wai - - aeson - - aeson-qq - http-types - - text - - bytestring - - wai-extra - - stm-containers + - hw-hspec-hedgehog - mtl - - time - servant-server - - vector - - hspec-expectations - - hspec-discover - - warp + - stm-containers - template-haskell - - aeson-qq + - text + - time + - vector + - wai-extra - wai-logger - - hedgehog - - hw-hspec-hedgehog + - warp diff --git a/server/Main.hs b/server/Main.hs index 638c940d0b3..2bd9598b894 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -51,9 +51,8 @@ mkUserDB = do (emailAddress "elton@wire.com") , E.primary = Nothing } - let user = (User.empty [User20] NoUserExtra) - { userName = "elton" - , name = Just Name + let user = (User.empty [User20] "elton" NoUserExtra) + { name = Just Name { formatted = Just "Elton John" , familyName = Just "John" , givenName = Just "Elton" diff --git a/src/Web/Scim/AttrName.hs b/src/Web/Scim/AttrName.hs new file mode 100644 index 00000000000..6cd400102f9 --- /dev/null +++ b/src/Web/Scim/AttrName.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | Scim attribute names. these are case-insensitive +module Web.Scim.AttrName where + +import Prelude hiding (takeWhile) +import Data.Text (Text, toCaseFold, cons) +import Data.Text.Encoding (decodeUtf8) +import Data.String (IsString, fromString) +import Data.Aeson.Types (ToJSONKey, FromJSONKey) +import Data.Attoparsec.ByteString.Char8 +import Data.Hashable + +-- | An attribute (e.g. username). +-- +-- ATTRNAME = ALPHA *(nameChar) +-- NOTE: We use the FromJSONKey instance of Text. The default instances parses +-- a list of key values instead of a map +newtype AttrName + = AttrName Text deriving (Show, FromJSONKey, ToJSONKey) + +instance Eq AttrName where + AttrName a == AttrName b = toCaseFold a == toCaseFold b + +instance Ord AttrName where + compare (AttrName a) (AttrName b) = compare (toCaseFold a) (toCaseFold b) + +instance Hashable AttrName where + hashWithSalt x (AttrName a) = hashWithSalt x (toCaseFold a) + +instance IsString AttrName where + fromString = AttrName . fromString + +-- | Attribute name parser. +pAttrName :: Parser AttrName +pAttrName = + (\c str -> AttrName (cons c (decodeUtf8 str))) + <$> letter_ascii + <*> takeWhile (\x -> isDigit x || isAlpha_ascii x || x == '-' || x == '_') + +-- | Attribute name renderer. +rAttrName :: AttrName -> Text +rAttrName (AttrName x) = x diff --git a/src/Web/Scim/Capabilities/MetaSchema.hs b/src/Web/Scim/Capabilities/MetaSchema.hs index 727fc9db686..4f32f274d93 100644 --- a/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/src/Web/Scim/Capabilities/MetaSchema.hs @@ -81,7 +81,7 @@ empty = Configuration , Schema20 , ResourceType20 ] - , patch = Supported False () + , patch = Supported True () , bulk = Supported False $ BulkConfig 0 0 , filter = Supported False $ FilterConfig 0 , changePassword = Supported False () diff --git a/src/Web/Scim/Class/User.hs b/src/Web/Scim/Class/User.hs index 5862a14f6f6..1c2b66a5840 100644 --- a/src/Web/Scim/Class/User.hs +++ b/src/Web/Scim/Class/User.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} module Web.Scim.Class.User ( UserDB (..) @@ -7,8 +8,10 @@ module Web.Scim.Class.User , userServer ) where +import Data.Aeson.Types (FromJSON) import GHC.Generics (Generic) import Web.Scim.Schema.User +import Web.Scim.Schema.PatchOp import Web.Scim.Schema.Meta import Web.Scim.Schema.Common import Web.Scim.Schema.ListResponse hiding (schemas) @@ -20,8 +23,6 @@ import Servant import Servant.API.Generic import Servant.Server.Generic -import qualified Data.Aeson as Aeson - ---------------------------------------------------------------------------- -- /Users API @@ -43,7 +44,7 @@ data UserSite tag route = UserSite Put '[SCIM] (StoredUser tag) , usPatchUser :: route :- Capture "id" (UserId tag) :> - ReqBody '[SCIM] Aeson.Value :> + ReqBody '[SCIM] PatchOp :> Patch '[SCIM] (StoredUser tag) , usDeleteUser :: route :- Capture "id" (UserId tag) :> @@ -78,8 +79,9 @@ class (Monad m, AuthTypes tag, UserTypes tag) => UserDB tag m where -- | Overwrite an existing user. -- - -- Should throw 'notFound' if the user doesn't exist, and 'conflict' if uniqueness - -- constraints are violated. + -- Should throw 'notFound' if the user doesn't exist, and 'conflict' if + -- uniqueness constraints are violated. + -- putUser :: AuthInfo tag -> UserId tag @@ -88,16 +90,40 @@ class (Monad m, AuthTypes tag, UserTypes tag) => UserDB tag m where -- | Modify an existing user. -- - -- Should throw 'notFound' if the user doesn't exist, and 'conflict' if uniqueness - -- constraints are violated. + -- Should throw 'notFound' if the user doesn't exist, and 'conflict' if + -- uniqueness constraints are violated. + -- + -- https://tools.ietf.org/html/rfc7644#section-3.5.2 + -- + -- If the target location already contains the value specified, no changes + -- SHOULD be made to the resource, and a success response SHOULD be + -- returned. Unless other operations change the resource, this operation + -- SHALL NOT change the modify timestamp of the resource. -- - -- FUTUREWORK: add types for PATCH (instead of 'Aeson.Value'). - -- See + -- Given that PUT has the same constraints, we can implement PATCH in terms + -- of some magic in this library, GET and PUT. + -- + -- SCIM's Patch semantics are hard to get right. So we advice using the + -- library built-in implementation. we implement PATCH in terms of a GET + -- followed by a PUT. GET will retrieve the entire record; we then modify + -- this record by a series of PATCH operations, and then PUT the entire + -- record. + -- patchUser :: AuthInfo tag -> UserId tag - -> Aeson.Value -- ^ PATCH payload + -> PatchOp -- ^ PATCH payload + -> ScimHandler m (StoredUser tag) + default patchUser + :: FromJSON (UserExtra tag) + => AuthInfo tag + -> UserId tag + -> PatchOp -- ^ PATCH payload -> ScimHandler m (StoredUser tag) + patchUser info uid op' = do + (WithMeta _ (WithId _ (user :: User tag))) <- getUser info uid + (newUser :: User tag) <- applyPatch user op' + putUser info uid newUser -- | Delete a user. -- @@ -128,7 +154,7 @@ userServer authData = UserSite putUser @tag auth uid user , usPatchUser = \uid patch -> do auth <- authCheck @tag authData - patchUser @tag auth uid patch + patchUser @tag @m auth uid patch , usDeleteUser = \uid -> do auth <- authCheck @tag authData deleteUser @tag auth uid diff --git a/src/Web/Scim/Filter.hs b/src/Web/Scim/Filter.hs index 9ca0aec9424..fde3faa588e 100644 --- a/src/Web/Scim/Filter.hs +++ b/src/Web/Scim/Filter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | A query might specify a filter that should be applied to the results -- before returning them. This module implements a very limited subset of -- the specification: . @@ -21,27 +22,40 @@ module Web.Scim.Filter , parseFilter , renderFilter - -- * Filtering logic - , filterUser - -- * Constructing filters , CompValue(..) , CompareOp(..) - , Attribute(..) + , AttrPath(..) + , ValuePath(..) + , SubAttr(..) + , pAttrPath + , pValuePath + , pSubAttr + , pFilter + , rAttrPath + , rValuePath + , rSubAttr + , compareStr + , topLevelAttrPath ) where +import Data.String +import Prelude hiding (takeWhile) +import Control.Applicative(optional) import Data.Scientific -import Data.Text -import Data.Text.Encoding +import Data.Text (Text, pack, isInfixOf, isPrefixOf, isSuffixOf) +import Data.Text.Encoding (encodeUtf8) import Data.Text.Lazy (toStrict) import Data.Attoparsec.ByteString.Char8 import Data.Aeson.Parser as Aeson import Data.Aeson.Text as Aeson import Data.Aeson as Aeson +import Data.Maybe (fromMaybe) import Lens.Micro import Web.HttpApiData -import Web.Scim.Schema.User +import Web.Scim.Schema.Schema (getSchemaUri, Schema, pSchema) +import Web.Scim.AttrName ---------------------------------------------------------------------------- -- Types @@ -67,14 +81,7 @@ data CompareOp | OpGe -- ^ Greater than or equal to | OpLt -- ^ Less than | OpLe -- ^ Less than or equal to - deriving (Eq, Ord, Show) - --- | An attribute (e.g. username). --- --- Only usernames are supported as attributes. Paths are not supported. -data Attribute - = AttrUserName - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Enum, Bounded) -- | A filter. -- @@ -82,27 +89,82 @@ data Attribute -- validity on the type level. If a filter does something silly (e.g. tries -- to compare a username with a boolean), it will be caught during filtering -- and an appropriate error message will be thrown (see 'filterUser'). +-- +-- TODO(arianvp): Implement the following grammar fully if we want to support +-- more complex filters +-- +-- FILTER = attrExp / logExp / valuePath / *1"not" "(" FILTER ")" data Filter -- | Compare the attribute value with a literal - = FilterAttrCompare Attribute CompareOp CompValue + = FilterAttrCompare AttrPath CompareOp CompValue + deriving (Eq, Show) + +-- | valuePath = attrPath "[" valFilter "]" +-- TODO(arianvp): This is a slight simplification at the moment as we +-- don't support the complete Filter grammar. This should be a +-- valFilter, not a FILTER. +data ValuePath = ValuePath AttrPath Filter deriving (Eq, Show) +-- | subAttr = "." ATTRNAME +newtype SubAttr = SubAttr AttrName + deriving (Eq, Show, IsString) + +-- | attrPath = [URI ":"] ATTRNAME *1subAtt +data AttrPath = AttrPath (Maybe Schema) AttrName (Maybe SubAttr) + deriving (Eq, Show) + + +-- | Smart constructor that refers to a toplevel field with default schema +topLevelAttrPath :: Text -> AttrPath +topLevelAttrPath x = AttrPath Nothing (AttrName x) Nothing + +-- | PATH = attrPath / valuePath [subAttr] +-- +-- Currently we don't support matching on lists in paths as +-- we currently don't support filtering on arbitrary attributes yet +-- e.g. +-- @ +-- "path":"members[value eq +-- \"2819c223-7f76-453a-919d-413861904646\"].displayName" +-- @ +-- is not supported + ---------------------------------------------------------------------------- -- Parsing --- Note: this parser is written with Attoparsec because I don't know how to --- lift an Attoparsec parser (from Aeson) to Megaparsec - -- | Parse a filter. Spaces surrounding the filter will be stripped. -- -- If parsing fails, returns a 'Left' with an error description. +-- +-- Note: this parser is written with Attoparsec because I don't know how to +-- lift an Attoparsec parser (from Aeson) to Megaparsec parseFilter :: Text -> Either Text Filter parseFilter = over _Left pack . parseOnly (skipSpace *> pFilter <* skipSpace <* endOfInput) . encodeUtf8 --- parser pieces +-- | +-- @ +-- ATTRNAME = ALPHA *(nameChar) +-- attrPath = [URI ":"] ATTRNAME *1subAtt +-- @ +pAttrPath :: Parser AttrPath +pAttrPath = + AttrPath + <$> (optional (pSchema <* char ':')) + <*> pAttrName + <*> optional pSubAttr + +-- | subAttr = "." ATTRNAME +pSubAttr :: Parser SubAttr +pSubAttr = char '.' *> (SubAttr <$> pAttrName) + +-- | valuePath = attrPath "[" valFilter "]" +pValuePath :: Parser ValuePath +pValuePath = + ValuePath <$> pAttrPath <*> (char '[' *> pFilter <* char ']') -- | Value literal parser. pCompValue :: Parser CompValue @@ -128,17 +190,11 @@ pCompareOp = choice , OpLe <$ stringCI "le" ] --- | Attribute name parser. -pAttribute :: Parser Attribute -pAttribute = choice - [ AttrUserName <$ stringCI "username" - ] - -- | Filter parser. pFilter :: Parser Filter pFilter = choice [ FilterAttrCompare - <$> pAttribute + <$> pAttrPath <*> (skipSpace1 *> pCompareOp) <*> (skipSpace1 *> pCompValue) ] @@ -154,7 +210,17 @@ skipSpace1 = space *> skipSpace renderFilter :: Filter -> Text renderFilter filter_ = case filter_ of FilterAttrCompare attr op val -> - rAttribute attr <> " " <> rCompareOp op <> " " <> rCompValue val + rAttrPath attr <> " " <> rCompareOp op <> " " <> rCompValue val + +rAttrPath :: AttrPath -> Text +rAttrPath (AttrPath schema attr subAttr) + = fromMaybe "" ((<> ":") . getSchemaUri <$> schema) <> rAttrName attr <> fromMaybe "" (rSubAttr <$> subAttr) + +rSubAttr :: SubAttr -> Text +rSubAttr (SubAttr x) = "." <> (rAttrName x) + +rValuePath :: ValuePath -> Text +rValuePath (ValuePath attrPath filter') = rAttrPath attrPath <> "[" <> renderFilter filter' <> "]" -- | Value literal renderer. rCompValue :: CompValue -> Text @@ -178,27 +244,6 @@ rCompareOp = \case OpLt -> "lt" OpLe -> "le" --- | Attribute name renderer. -rAttribute :: Attribute -> Text -rAttribute = \case - AttrUserName -> "username" - ----------------------------------------------------------------------------- --- Applying - --- | Check whether a user satisfies the filter. --- --- Returns 'Left' if the filter is constructed incorrectly (e.g. tries to --- compare a username with a boolean). -filterUser :: Filter -> User extra -> Either Text Bool -filterUser filter_ user = case filter_ of - FilterAttrCompare AttrUserName op (ValString str) -> - -- Comparing usernames has to be case-insensitive; look at the - -- 'caseExact' parameter of the user schema - Right (compareStr op (toCaseFold (userName user)) (toCaseFold str)) - FilterAttrCompare AttrUserName _ _ -> - Left "usernames can only be compared with strings" - -- | Execute a comparison operator. compareStr :: CompareOp -> Text -> Text -> Bool compareStr = \case diff --git a/src/Web/Scim/Schema/Common.hs b/src/Web/Scim/Schema/Common.hs index c67b41be273..d6b2cef1871 100644 --- a/src/Web/Scim/Schema/Common.hs +++ b/src/Web/Scim/Schema/Common.hs @@ -63,27 +63,3 @@ parseOptions = defaultOptions { fieldLabelModifier = fmap Char.toLower } -data Unsettable a = Unset | Omitted | Some a - deriving (Show, Eq) - -instance Functor Unsettable where - fmap f (Some a) = Some $ f a - fmap _ Unset = Unset - fmap _ Omitted = Omitted - -instance (FromJSON a) => FromJSON (Unsettable a) where - parseJSON Null = pure Unset - parseJSON v = do - res <- parseJSON v - case res of - Nothing -> pure Omitted - Just some -> pure $ Some some - -toMaybe :: Unsettable a -> Maybe a -toMaybe Unset = Nothing -toMaybe Omitted = Nothing -toMaybe (Some a) = Just a - -instance (ToJSON a) => ToJSON (Unsettable a) where - toJSON Unset = Null - toJSON v = toJSON . toMaybe $ v diff --git a/src/Web/Scim/Schema/Error.hs b/src/Web/Scim/Schema/Error.hs index 8aa8f7416aa..151a7d8e308 100644 --- a/src/Web/Scim/Schema/Error.hs +++ b/src/Web/Scim/Schema/Error.hs @@ -88,7 +88,7 @@ badRequest -> ScimError badRequest typ mbDetail = ScimError - { schemas = [Error2_0] + { schemas = [Error20] , status = Status 400 , scimType = pure typ , detail = mbDetail @@ -99,7 +99,7 @@ unauthorized -> ScimError unauthorized details = ScimError - { schemas = [Error2_0] + { schemas = [Error20] , status = Status 401 , scimType = Nothing , detail = pure $ "authorization failed: " <> details @@ -110,7 +110,7 @@ forbidden -> ScimError forbidden details = ScimError - { schemas = [Error2_0] + { schemas = [Error20] , status = Status 403 , scimType = Nothing , detail = pure $ "forbidden: " <> details @@ -122,7 +122,7 @@ notFound -> ScimError notFound resourceType resourceId = ScimError - { schemas = [Error2_0] + { schemas = [Error20] , status = Status 404 , scimType = Nothing , detail = pure $ resourceType <> " " <> resourceId <> " not found" @@ -131,7 +131,7 @@ notFound resourceType resourceId = conflict :: ScimError conflict = ScimError - { schemas = [Error2_0] + { schemas = [Error20] , status = Status 409 , scimType = Just Uniqueness , detail = Nothing @@ -142,7 +142,7 @@ serverError -> ScimError serverError details = ScimError - { schemas = [Error2_0] + { schemas = [Error20] , status = Status 500 , scimType = Nothing , detail = pure details diff --git a/src/Web/Scim/Schema/ListResponse.hs b/src/Web/Scim/Schema/ListResponse.hs index 09fe4f6ae20..803b0252de7 100644 --- a/src/Web/Scim/Schema/ListResponse.hs +++ b/src/Web/Scim/Schema/ListResponse.hs @@ -29,10 +29,10 @@ data ListResponse a = ListResponse fromList :: [a] -> ListResponse a fromList list = ListResponse - { schemas = [ListResponse2_0] + { schemas = [ListResponse20] , totalResults = len , itemsPerPage = len - , startIndex = 0 + , startIndex = 1 -- NOTE: lists are 1-indexed in SCIM , resources = list } where diff --git a/src/Web/Scim/Schema/PatchOp.hs b/src/Web/Scim/Schema/PatchOp.hs new file mode 100644 index 00000000000..ecc40cc3a41 --- /dev/null +++ b/src/Web/Scim/Schema/PatchOp.hs @@ -0,0 +1,113 @@ +module Web.Scim.Schema.PatchOp where + +import Control.Applicative +import Control.Monad (guard) +import Web.Scim.Schema.Schema (Schema(PatchOp20)) +import Data.Aeson.Types (withText, ToJSON(toJSON), object, (.=), FromJSON(parseJSON), withObject, (.:), (.:?), Value(String)) +import qualified Data.HashMap.Strict as HashMap +import Data.Text (toCaseFold, toLower, Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Bifunctor (first) +import Data.Attoparsec.ByteString (Parser, parseOnly, endOfInput) +import Web.Scim.Filter (AttrPath(..), ValuePath(..), SubAttr(..), pAttrPath, pValuePath, pSubAttr, rAttrPath, rSubAttr, rValuePath) +import Data.Maybe (fromMaybe) + +newtype PatchOp = PatchOp + { getOperations :: [Operation] } + deriving (Eq, Show) + +-- | The 'Path' attribute value is a 'String' containing an attribute path +-- describing the target of the operation. It is OPTIONAL +-- for 'Op's "add" and "replace", and is REQUIRED for "remove". See +-- relevant operation sections below for details. +-- +-- TODO(arianvp): When value is an array, it needs special handling. +-- e.g. primary fields need to be negated and whatnot. +-- We currently do not do that :) +-- +-- NOTE: When the path contains a schema, this schema must be implicitly added +-- to the list of schemas on the result type +data Operation = Operation + { op :: Op + , path :: Maybe Path + , value :: Maybe Value + } deriving (Eq, Show) + +data Op + = Add + | Replace + | Remove + deriving (Eq, Show, Enum, Bounded) + +-- | PATH = attrPath / valuePath [subAttr] +data Path + = NormalPath AttrPath + | IntoValuePath ValuePath (Maybe SubAttr) + deriving (Eq, Show) + + +parsePath :: Text -> Either String Path +parsePath = parseOnly (pPath <* endOfInput) . encodeUtf8 + +-- | PATH = attrPath / valuePath [subAttr] +pPath :: Parser Path +pPath = + IntoValuePath <$> pValuePath <*> optional pSubAttr <|> + NormalPath <$> pAttrPath + +rPath :: Path -> Text +rPath (NormalPath attrPath) = rAttrPath attrPath +rPath (IntoValuePath valuePath subAttr) = rValuePath valuePath <> fromMaybe "" (rSubAttr <$> subAttr) + + +-- TODO(arianvp): According to the SCIM spec we should throw an InvalidPath +-- error when the path is invalid syntax. this is a bit hard to do though as we +-- can't control what errors FromJSON throws :/ +instance FromJSON PatchOp where + parseJSON = withObject "PatchOp" $ \v -> do + let o = HashMap.fromList . map (first toLower) . HashMap.toList $ v + schemas :: [Schema] <- o .: "schemas" + guard $ PatchOp20 `elem` schemas + operations <- o .: "operations" + pure $ PatchOp operations + +instance ToJSON PatchOp where + toJSON (PatchOp operations) = + object [ "operations" .= operations , "schemas" .= [PatchOp20] ] + + +-- TODO: Azure wants us to be case-insensitive on _values_ as well here. We currently do not +-- comply with that. +instance FromJSON Operation where + parseJSON = withObject "Operation" $ \v -> do + let o = HashMap.fromList . map (first toLower) . HashMap.toList $ v + Operation <$> (o .: "op") <*> (o .:? "path") <*> (o .:? "value") + +instance ToJSON Operation where + toJSON (Operation op' path' value') = + object $ ("op" .= op') : concat [optionalField "path" path', optionalField "value" value'] + where + optionalField fname = \case + Nothing -> [] + Just x -> [fname .= x] + + +instance FromJSON Op where + parseJSON = withText "Op" $ \op' -> + case toCaseFold op' of + "add" -> pure Add + "replace" -> pure Replace + "remove" -> pure Remove + _ -> fail "unknown operation" + +instance ToJSON Op where + toJSON Add = String "add" + toJSON Replace = String "replace" + toJSON Remove = String "remove" + + +instance FromJSON Path where + parseJSON = withText "Path" $ either fail pure . parsePath + +instance ToJSON Path where + toJSON = String . rPath diff --git a/src/Web/Scim/Schema/Schema.hs b/src/Web/Scim/Schema/Schema.hs index e0a0c29dcbb..f1ecfde78bc 100644 --- a/src/Web/Scim/Schema/Schema.hs +++ b/src/Web/Scim/Schema/Schema.hs @@ -9,6 +9,8 @@ import Web.Scim.Capabilities.MetaSchema.ResourceType import Data.Text import Data.Aeson +import Data.Attoparsec.ByteString (Parser, ()) +import Control.Applicative ((<|>)) -- | All schemas that we support. data Schema = User20 @@ -16,8 +18,9 @@ data Schema = User20 | Group20 | Schema20 | ResourceType20 - | ListResponse2_0 - | Error2_0 + | ListResponse20 + | Error20 + | PatchOp20 | CustomSchema Text deriving (Show, Eq) @@ -39,14 +42,49 @@ getSchemaUri Schema20 = "urn:ietf:params:scim:schemas:core:2.0:Schema" getSchemaUri ResourceType20 = "urn:ietf:params:scim:schemas:core:2.0:ResourceType" -getSchemaUri ListResponse2_0 = +getSchemaUri ListResponse20 = "urn:ietf:params:scim:api:messages:2.0:ListResponse" -getSchemaUri Error2_0 = +getSchemaUri Error20 = "urn:ietf:params:scim:api:messages:2.0:Error" +getSchemaUri PatchOp20 = + "urn:ietf:params:scim:api:messages:2.0:PatchOp" getSchemaUri (CustomSchema x) = x +-- | Parser for known schemas. Fails on unknown schemas (E.g. CustomSchema escape hatch doesn't work) +-- +-- NOTE: according to the spec, this parser needs to be case insensitive, but +-- that is literally insane. Won't implement. +pSchema :: Parser Schema +pSchema = + (User20 + <$ "urn:ietf:params:scim:schemas:core:2.0:User" <|> + ServiceProviderConfig20 + <$ "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig" <|> + Group20 + <$ "urn:ietf:params:scim:schemas:core:2.0:Group" <|> + Schema20 + <$ "urn:ietf:params:scim:schemas:core:2.0:Schema" <|> + ResourceType20 + <$ "urn:ietf:params:scim:schemas:core:2.0:ResourceType" <|> + ListResponse20 + <$ "urn:ietf:params:scim:api:messages:2.0:ListResponse" <|> + Error20 + <$ "urn:ietf:params:scim:api:messages:2.0:Error" <|> + PatchOp20 + <$ "urn:ietf:params:scim:api:messages:2.0:PatchOp") "unknown schema" + -- | Get a schema by its URI. +-- +-- NOTE: cas sensitive against the spec. Same as 'pSchema'. +-- +-- FUTUREWORK: implement this in terms of 'pSchema': parse all the non-custom schemas with +-- 'pSchema; in case of error, use the parser *input* as the custom schema. +-- +-- TODO(arianvp): probably too lenient. want to only accept valid URNs +-- This means the CustomSchema part might go... We need to kind of +-- rethink how we're gonna do extensions anyway, as we're gonna have to +-- support multiple extensions, which is currently a bit iffy I think fromSchemaUri :: Text -> Schema fromSchemaUri s = case s of "urn:ietf:params:scim:schemas:core:2.0:User" -> @@ -60,9 +98,11 @@ fromSchemaUri s = case s of "urn:ietf:params:scim:schemas:core:2.0:ResourceType" -> ResourceType20 "urn:ietf:params:scim:api:messages:2.0:ListResponse" -> - ListResponse2_0 + ListResponse20 "urn:ietf:params:scim:api:messages:2.0:Error" -> - Error2_0 + Error20 + "urn:ietf:params:scim:api:messages:2.0:PatchOp" -> + PatchOp20 x -> CustomSchema x @@ -80,9 +120,11 @@ getSchema ResourceType20 = pure resourceSchema -- Schemas for these types are not in the SCIM standard. -- FUTUREWORK: write schema definitions anyway. -getSchema ListResponse2_0 = +getSchema ListResponse20 = + Nothing +getSchema Error20 = Nothing -getSchema Error2_0 = +getSchema PatchOp20 = Nothing -- This is not controlled by @hscim@ so we can't write a schema. -- FUTUREWORK: allow supplying schemas for 'CustomSchema'. diff --git a/src/Web/Scim/Schema/User.hs b/src/Web/Scim/Schema/User.hs index 2a2e990c478..2e7fd02dafd 100644 --- a/src/Web/Scim/Schema/User.hs +++ b/src/Web/Scim/Schema/User.hs @@ -1,6 +1,9 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | SCIM user representation. -- @@ -18,13 +21,8 @@ -- -- == Optional fields -- --- The spec doesn't say which fields should be optional and which shouldn't, and --- in theory every SCIM server can decide for itself which fields it will --- consider optional (as long as it makes it clear in the resource schema). --- Currently we don't provide any control over this; all fields are optional --- except for @userName@. --- --- TODO: why @userName@? +-- The spec only mandates the @userName@ and @id@ attribute. All other +-- attributes seem optional. -- -- == Multi-valued fields -- @@ -33,19 +31,31 @@ -- opted for the latter to conform to an example in the spec: -- . -- --- == Field names +-- TODO(arianvp): +-- Multi-valued attributes actually have some more quirky semantics that we +-- currently don't support yet. E.g. if the multi-values have a +-- 'primary' field then only one of the entires must have 'primary: true' +-- and all the others are either implied 'primary: false' or must be checked +-- that they're false +-- +-- +-- == Attribute names -- -- When parsing JSON objects, we ignore capitalization differences in field --- names -- e.g. both @USERNAME@ and @userName@ are accepted. This behavior is --- not prescribed by the spec, but it allows us to work with buggy SCIM --- implementations. +-- names -- e.g. both @USERNAME@ and @userName@ are accepted. +-- This is described by the spec https://tools.ietf.org/html/rfc7643#section-2.1 +-- module Web.Scim.Schema.User where -import Data.Text (Text, toLower) +import Control.Monad (foldM) import Data.Aeson +import Data.List ((\\)) import qualified Data.HashMap.Strict as HM +import Data.Text (Text, pack, toLower) import Lens.Micro +import Web.Scim.AttrName +import Web.Scim.Filter (AttrPath(..)) import Web.Scim.Schema.Common import Web.Scim.Schema.Schema (Schema(..)) import Web.Scim.Schema.User.Address (Address) @@ -55,8 +65,11 @@ import Web.Scim.Schema.User.IM (IM) import Web.Scim.Schema.User.Name (Name) import Web.Scim.Schema.User.Phone (Phone) import Web.Scim.Schema.User.Photo (Photo) +import Web.Scim.Schema.PatchOp +import Web.Scim.Schema.Error import GHC.Generics (Generic) +import Control.Monad.Except -- | Configurable parts of 'User'. class UserTypes tag where @@ -116,13 +129,15 @@ data User tag = User deriving instance Show (UserExtra tag) => Show (User tag) deriving instance Eq (UserExtra tag) => Eq (User tag) + empty :: [Schema] -- ^ Schemas + -> Text -- ^ userName -> UserExtra tag -- ^ Extra data -> User tag -empty schemas extra = User +empty schemas userName extra = User { schemas = schemas - , userName = "" + , userName = userName , externalId = Nothing , name = Nothing , displayName = Nothing @@ -226,3 +241,70 @@ instance FromJSON NoUserExtra where instance ToJSON NoUserExtra where toJSON _ = object [] + +---------------------------------------------------------------------------- +-- Applying + +-- | Applies a JSON Patch to a SCIM Core User +-- Only supports the core attributes. +-- Evenmore, only some hand-picked ones currently. +-- We'll have to think how patch is going to work in the presence of extensions. +-- Also, we can probably make PatchOp type-safe to some extent (Read arianvp's thesis :)) +applyPatch :: (FromJSON (UserExtra tag), MonadError ScimError m) => User tag -> PatchOp -> m (User tag) +applyPatch = (. getOperations) . foldM applyOperation + +resultToScimError :: (MonadError ScimError m) => Result a -> m a +resultToScimError (Error reason) = throwError $ badRequest InvalidValue (Just (pack reason)) +resultToScimError (Success a) = pure a + +-- TODO(arianvp): support multi-valued and complex attributes. +-- TODO(arianvp): Actually do this in some kind of type-safe way. e.g. +-- have a UserPatch type. +-- +-- What I understand from the spec: The difference between add an replace is only +-- in the fact that replace will not concat multi-values, and behaves differently for complex values too. +-- For simple attributes, add and replace are identical. +applyOperation :: forall m tag. (MonadError ScimError m, FromJSON (UserExtra tag)) => User tag -> Operation -> m (User tag) +applyOperation user (Operation Add path value) = applyOperation user (Operation Replace path value) + +applyOperation user (Operation Replace (Just (NormalPath (AttrPath _schema attr _subAttr))) (Just value)) = do + case attr of + "username" -> + (\x -> user { userName = x }) <$> resultToScimError (fromJSON value) + "displayname" -> + (\x -> user { displayName = x }) <$> resultToScimError (fromJSON value) + "externalid" -> + (\x -> user { externalId = x }) <$> resultToScimError (fromJSON value) + _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid")) +applyOperation _ (Operation Replace (Just (IntoValuePath _ _)) _) = do + throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet")) +applyOperation user (Operation Replace Nothing (Just value)) = do + case value of + Object hm | null ((AttrName <$> HM.keys hm) \\ ["username", "displayname", "externalid"]) -> pure () + _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid")) + (u :: User tag) <- resultToScimError $ fromJSON value + pure $ user + { userName = userName u + , displayName = displayName u + , externalId = externalId u + } +applyOperation _ (Operation Replace _ Nothing) = + throwError (badRequest InvalidValue (Just "No value was provided")) + +applyOperation _ (Operation Remove Nothing _) = throwError (badRequest NoTarget Nothing) +applyOperation user (Operation Remove (Just (NormalPath (AttrPath _schema attr _subAttr))) _value) = + case attr of + "username" -> throwError (badRequest Mutability Nothing) + "displayname" -> pure $ user { displayName = Nothing } + "externalid" -> pure $ user { externalId = Nothing } + _ -> pure user +applyOperation _ (Operation Remove (Just (IntoValuePath _ _)) _) = do + throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet")) + + +-- Omission of a schema for users is implicitly the core schema +-- TODO(arianvp): Link to part of the spec that claims this. +isUserSchema :: Maybe Schema -> Bool +isUserSchema Nothing = True +isUserSchema (Just User20) = True +isUserSchema (Just _) = False diff --git a/src/Web/Scim/Schema/User/Name.hs b/src/Web/Scim/Schema/User/Name.hs index f7981182b1a..07de4418eac 100644 --- a/src/Web/Scim/Schema/User/Name.hs +++ b/src/Web/Scim/Schema/User/Name.hs @@ -4,7 +4,6 @@ module Web.Scim.Schema.User.Name where import Data.Text (Text) import Data.Aeson import GHC.Generics - import Web.Scim.Schema.Common data Name = Name diff --git a/src/Web/Scim/Server/Mock.hs b/src/Web/Scim/Server/Mock.hs index 07102100af3..4bdee33085c 100644 --- a/src/Web/Scim/Server/Mock.hs +++ b/src/Web/Scim/Server/Mock.hs @@ -16,13 +16,14 @@ import Control.Monad.Reader import Control.Monad.Morph import Data.Aeson import Data.Hashable -import Data.Text (Text, pack) +import Data.Text (Text, pack, toCaseFold) import Data.Time.Clock import Data.Time.Calendar import GHC.Exts (sortWith) import ListT import qualified STMContainers.Map as STMMap import Text.Read (readMaybe) +import Web.Scim.Filter (Filter(..), CompValue(..), AttrPath(..), compareStr) import Web.Scim.Schema.User import Web.Scim.Schema.Error import Web.Scim.Schema.Meta @@ -30,7 +31,6 @@ import Web.Scim.Schema.ListResponse import Web.Scim.Schema.ResourceType import Web.Scim.Schema.Common (WithId(WithId, value)) import qualified Web.Scim.Schema.Common as Common -import Web.Scim.Filter import Web.Scim.Handler import Servant @@ -109,8 +109,6 @@ instance UserDB Mock TestServer where liftSTM $ STMMap.insert newUser uid m pure newUser - patchUser _ _ _ = throwScim (serverError "PATCH /Users not implemented") - deleteUser () uid = do m <- userDB <$> ask liftSTM (STMMap.lookup uid m) >>= \case @@ -201,3 +199,23 @@ nt :: TestStorage -> ScimHandler TestServer a -> Handler a nt storage = flip runReaderT storage . fromScimHandler (lift . throwError . scimToServantErr) + + +-- | Check whether a user satisfies the filter. +-- +-- Returns 'Left' if the filter is constructed incorrectly (e.g. tries to +-- compare a username with a boolean). +-- +-- TODO(arianvp): We need to generalise filtering at some point probably. +filterUser :: Filter -> User extra -> Either Text Bool +filterUser (FilterAttrCompare (AttrPath schema' attrib subAttr) op val) user + | isUserSchema schema' = + case (subAttr, val) of + (Nothing, (ValString str)) | attrib == "userName" -> + Right (compareStr op (toCaseFold (userName user)) (toCaseFold str)) + (Nothing, _) | attrib == "userName" -> + Left "usernames can only be compared with strings" + (_, _) -> + Left "Only search on usernames is currently supported" + | otherwise = Left "Invalid schema. Only user schema is supported" + diff --git a/src/Web/Scim/Test/Acceptance.hs b/src/Web/Scim/Test/Acceptance.hs new file mode 100644 index 00000000000..5a821b0cc7f --- /dev/null +++ b/src/Web/Scim/Test/Acceptance.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE QuasiQuotes #-} +-- | A bunch of hspec acceptance tests that assert that your SCIM +-- implementation is compatible with popular SCIM 2.0 providers +module Web.Scim.Test.Acceptance where + +import Web.Scim.Test.Util (scim, get', post', patch', delete') +import Test.Hspec (Spec, xit, it, shouldBe, beforeAll, pending, describe,) +import Test.Hspec.Wai (shouldRespondWith, matchStatus) +import Network.Wai (Application) + + +-- https://docs.microsoft.com/en-us/azure/active-directory/manage-apps/use-scim-to-provision-users-and-groups#step-2-understand-the-azure-ad-scim-implementation +microsoftAzure :: IO Application -> Spec +microsoftAzure app = do + describe "Within the SCIM 2.0 protocol specification, your application must meet these requirements:" $ do + it "Supports creating users, and optionally also groups, as per section 3.3 of the SCIM protocol." $ pending -- TODO(arianvp): Write test + it "Supports modifying users or groups with PATCH requests, as per section 3.5.2 of the SCIM protocol." $ pending -- TODO(arianvp): Write test + it "Supports retrieving a known resource for a user or group created earlier, as per section 3.4.1 of the SCIM protocol." $ pending -- TODO(arianvp): Write test + it "Supports querying users or groups, as per section 3.4.2 of the SCIM protocol. By default, users are retrieved by their id and queried by their username and externalid, and groups are queried by displayName." $ pending + describe "Supports querying user by ID and by manager, as per section 3.4.2 of the SCIM protocol." $ do + it "query by id" $ pending -- TODO(arianvp): Write test + it "query by manager" $ pending -- TODO(arianvp): Implement support for enterprise extension + it "Supports querying groups by ID and by member, as per section 3.4.2 of the SCIM protocol." $ pending -- TODO(arianvp): Implement groups + it "Accepts a single bearer token for authentication and authorization of Azure AD to your application." $ + -- This is provided by the library + True `shouldBe` True + + describe "Follow these general guidelines when implementing a SCIM endpoint to ensure compatibility with Azure AD:" $ do + it "id is a required property for all the resources. Every response that returns a resource should ensure each resource has this property, except for ListResponse with zero members." $ + -- NOTE: This is guaranteed by the type-system. No need for a test + True `shouldBe` True + it "Response to a query/filter request should always be a ListResponse." $ + -- NOTE: This is guaranteed by the type-system. No need for a test + True `shouldBe` True + it "Groups are optional, but only supported if the SCIM implementation supports PATCH requests." $ + -- TODO(arianvp): Implement groups + True `shouldBe` True + it "Don't require a case-sensitive match on structural elements in SCIM, in particular PATCH op operation values, as defined in https://tools.ietf.org/html/rfc7644#section-3.5.2. Azure AD emits the values of 'op' as Add, " $ + -- TODO(arianvp): Write test + pending + describe "Microsoft Azure AD only uses the following operators: eq and" $ do + -- TODO(arianvp): Write test + it "eq" $ pending + -- TODO(arianvp): Implement 'and' as Azure needs it + it "and" $ pending + + beforeAll app $ do + describe "User Operations" $ do + it "POST /Users" $ do + let user = [scim| + { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User", + "urn:ietf:params:scim:schemas:extension:enterprise:2.0:User"], + "externalId": "0a21f0f2-8d2a-4f8e-bf98-7363c4aed4ef", + "userName": "Test_User_ab6490ee-1e48-479e-a20b-2d77186b5dd1", + "active": true, + "emails": [{ + "primary": true, + "type": "work", + "value": "Test_User_fd0ea19b-0777-472c-9f96-4f70d2226f2e@testuser.com" + }], + "meta": { + "resourceType": "User" + }, + "name": { + "formatted": "givenName familyName", + "familyName": "familyName", + "givenName": "givenName" + }, + "roles": [] + } + |] + post' "/Users" user `shouldRespondWith` 201 + it "Get user by query" $ do + get' "/Users?filter userName eq \"Test_User_ab6490ee-1e48-479e-a20b-2d77186b5dd1\"" `shouldRespondWith` 200 + it "Get user by query, zero results" $ do + get' "/Users?filter=userName eq \"non-existent user\"" `shouldRespondWith` [scim| + { + "schemas": ["urn:ietf:params:scim:api:messages:2.0:ListResponse"], + "totalResults": 0, + "Resources": [], + "startIndex": 1, + "itemsPerPage": 0 + } + |] { matchStatus = 200 } + it "Get user by externalId works" $ do + get' "/Users?filter externalId eq \"0a21f0f2-8d2a-4f8e-479e-a20b-2d77186b5dd1\"" `shouldRespondWith` 200 + xit "Update user [Multi-valued properties]" $ do + patch' "/Users/0" [scim| + { + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [ + { + "op": "Replace", + "path": "emails[type eq \"work\"].value", + "value": "updatedEmail@microsoft.com" + }, + { + "op": "Replace", + "path": "name.familyName", + "value": "updatedFamilyName" + } + ] + } + |] `shouldRespondWith` 200 + describe "Update user [Single-valued properties]" $ do + it "replace userName" $ patch' "/Users/0" + [scim| + { + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Replace", + "path": "userName", + "value": "5b50642d-79fc-4410-9e90-4c077cdd1a59@testuser.com" + }] + } + |] `shouldRespondWith` 200 + it "replace displayName" $ patch' "/Users/0" + [scim| + { + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Replace", + "path": "displayName", + "value": "newDisplayName" + }] + } + |] `shouldRespondWith` [scim| + { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User", + "urn:ietf:params:scim:schemas:extension:enterprise:2.0:User" + ], + "userName": "5b50642d-79fc-4410-9e90-4c077cdd1a59@testuser.com", + "active": true, + "name": { + "givenName": "givenName", + "formatted": "givenName familyName", + "familyName": "familyName" + }, + "emails": [ + { + "value": "Test_User_fd0ea19b-0777-472c-9f96-4f70d2226f2e@testuser.com", + "primary": true, + "type": "work" + } + ], + "displayName": "newDisplayName", + "id": "0", + "meta": { + "resourceType": "User", + "location": "todo", + "created": "2018-01-01T00:00:00Z", + "version": "W/\"testVersion\"", + "lastModified": "2018-01-01T00:00:00Z" + }, + "externalId": "0a21f0f2-8d2a-4f8e-bf98-7363c4aed4ef" + } + |] + it "remove displayName" $ patch' "/Users/0" + [scim| + { + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Remove", + "path": "displayName" + }] + } + |] `shouldRespondWith` [scim| + { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User", + "urn:ietf:params:scim:schemas:extension:enterprise:2.0:User" + ], + "userName": "5b50642d-79fc-4410-9e90-4c077cdd1a59@testuser.com", + "active": true, + "name": { + "givenName": "givenName", + "formatted": "givenName familyName", + "familyName": "familyName" + }, + "emails": [ + { + "value": "Test_User_fd0ea19b-0777-472c-9f96-4f70d2226f2e@testuser.com", + "primary": true, + "type": "work" + } + ], + "id": "0", + "meta": { + "resourceType": "User", + "location": "todo", + "created": "2018-01-01T00:00:00Z", + "version": "W/\"testVersion\"", + "lastModified": "2018-01-01T00:00:00Z" + }, + "externalId": "0a21f0f2-8d2a-4f8e-bf98-7363c4aed4ef" + } + |] + -- TODO match body + it "Delete User" $ do + delete' "/Users/0" "" `shouldRespondWith` 204 + delete' "/Users/0" "" `shouldRespondWith` 404 + describe "Group operations" $ + it "is in progress" $ \_-> pending + + + diff --git a/test/Test/Util.hs b/src/Web/Scim/Test/Util.hs similarity index 83% rename from test/Test/Util.hs rename to src/Web/Scim/Test/Util.hs index c3fee3424d7..ed2e0c6ad98 100644 --- a/test/Test/Util.hs +++ b/src/Web/Scim/Test/Util.hs @@ -1,8 +1,10 @@ + {-# LANGUAGE TemplateHaskell #-} -module Test.Util ( +module Web.Scim.Test.Util ( -- * Making wai requests - post, put, patch + post, put, patch, + post', put', patch', get', delete' -- * Request/response quasiquoter , scim -- * JSON parsing @@ -43,6 +45,24 @@ put path = request methodPut path [(hContentType, "application/scim+json")] patch :: ByteString -> L.ByteString -> WaiSession SResponse patch path = request methodPatch path [(hContentType, "application/scim+json")] +get' :: ByteString -> WaiSession SResponse +get' path = request methodGet path [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] "" + +post' :: ByteString -> L.ByteString -> WaiSession SResponse +post' path = request methodPost path [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] + +put' :: ByteString -> L.ByteString -> WaiSession SResponse +put' path = request methodPut path [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] + +patch' :: ByteString -> L.ByteString -> WaiSession SResponse +patch' path = request methodPatch path [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] + +delete' :: ByteString -> L.ByteString -> WaiSession SResponse +delete' path = request methodDelete path [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] + + + + ---------------------------------------------------------------------------- -- Redefine wai quasiquoter -- @@ -125,3 +145,4 @@ instance GroupTypes (TestTag id authData authInfo userExtra) where instance AuthTypes (TestTag id authData authInfo userExtra) where type AuthData (TestTag id authData authInfo userExtra) = authData type AuthInfo (TestTag id authData authInfo userExtra) = authInfo + diff --git a/stack.yaml b/stack.yaml index 1ba45779784..faddcb4d08c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,12 @@ resolver: lts-12.10 +compiler: ghc-8.4.4 packages: - . extra-deps: - network-uri-static-0.1.1.0 + +nix: + packages: + - zlib diff --git a/test/Test/AcceptanceSpec.hs b/test/Test/AcceptanceSpec.hs new file mode 100644 index 00000000000..a635bb4489b --- /dev/null +++ b/test/Test/AcceptanceSpec.hs @@ -0,0 +1,19 @@ +-- | A set of acceptance tests that you can use to test that your server is +module Test.AcceptanceSpec where + +import Test.Hspec (Spec, describe) +import Web.Scim.Server (app) +import Web.Scim.Server.Mock + +import Web.Scim.Capabilities.MetaSchema (empty) +import Web.Scim.Test.Acceptance (microsoftAzure) + + +spec :: Spec +spec = do + let + app' = do + storage <- emptyTestStorage + pure (app @Mock empty (nt storage)) + + describe "Azure" $ microsoftAzure app' diff --git a/test/Test/Capabilities/MetaSchemaSpec.hs b/test/Test/Capabilities/MetaSchemaSpec.hs index 08cb970fd0f..bcfae33fce8 100644 --- a/test/Test/Capabilities/MetaSchemaSpec.hs +++ b/test/Test/Capabilities/MetaSchemaSpec.hs @@ -2,7 +2,7 @@ module Test.Capabilities.MetaSchemaSpec (spec) where -import Test.Util +import Web.Scim.Test.Util import qualified Data.List as List import Data.Aeson @@ -85,7 +85,7 @@ spConfig = [scim| "maxPayloadSize":0, "supported":false }, - "patch":{"supported":false}, + "patch":{"supported":true}, "authenticationSchemes":[ {"type":"httpbasic", "name":"HTTP Basic", @@ -113,7 +113,7 @@ resourceTypes = [scim| "name":"Group", "endpoint":"/Groups"}], "totalResults":2, - "startIndex":0, + "startIndex":1, "itemsPerPage":2 } |] diff --git a/test/Test/Class/GroupSpec.hs b/test/Test/Class/GroupSpec.hs index 33046bea694..a4078d20ab5 100644 --- a/test/Test/Class/GroupSpec.hs +++ b/test/Test/Class/GroupSpec.hs @@ -2,7 +2,7 @@ module Test.Class.GroupSpec (spec) where -import Test.Util +import Web.Scim.Test.Util import Network.Wai (Application) import Servant (Proxy(Proxy)) @@ -84,7 +84,7 @@ groups = [scim| ], "totalResults":1, "itemsPerPage":1, - "startIndex":0 + "startIndex":1 }|] admins :: ResponseMatcher @@ -139,5 +139,5 @@ emptyList = [scim| "Resources":[], "totalResults":0, "itemsPerPage":0, - "startIndex":0 + "startIndex":1 }|] diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index 62508cb4e74..4e897e70a53 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -2,7 +2,7 @@ module Test.Class.UserSpec (spec) where -import Test.Util +import Web.Scim.Test.Util import Web.Scim.Server (mkapp, UserAPI, userServer) import Web.Scim.Server.Mock @@ -68,6 +68,251 @@ spec = beforeAll app $ do it "does not create new users" $ do put "/9999" newBarbara `shouldRespondWith` 404 + -- TODO(arianvp): Perhaps we want to make this an acceptance spec. + describe "PATCH /Users/:id" $ do + describe "Add" $ do + -- TODO(arianvp): Implement and test multi-value fields properly + -- TODO(arianvp): We need to merge multi-value fields, but not supported yet + -- TODO(arianvp): Add and Replace tests currently identical, because of lack of multi-value + it "adds all fields if no target" $ do + _ <- put "/0" smallUser -- reset + patch "/0" [scim|{ + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Add", + "value": { + "userName": "arian", + "displayName": "arian" + } + + }] + }|] `shouldRespondWith` [scim| + { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User" + ], + "userName": "arian", + "displayName": "arian", + "id": "0", + "meta": { + "resourceType": "User", + "location": "todo", + "created": "2018-01-01T00:00:00Z", + "version": "W/\"testVersion\"", + "lastModified": "2018-01-01T00:00:00Z" + } + } + |] { matchStatus = 200 } + it "adds fields if they didn't exist yet" $ do + _ <- put "/0" smallUser -- reset + patch "/0" [scim|{ + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Add", + "path": "displayName", + "value": "arian" + }] + }|] `shouldRespondWith` [scim| + { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User" + ], + "userName": "bjensen", + "displayName": "arian", + "id": "0", + "meta": { + "resourceType": "User", + "location": "todo", + "created": "2018-01-01T00:00:00Z", + "version": "W/\"testVersion\"", + "lastModified": "2018-01-01T00:00:00Z" + } + } + |] { matchStatus = 200 } + it "replaces individual simple fields" $ do + _ <- put "/0" smallUser -- reset + patch "/0" [scim|{ + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Add", + "path": "userName", + "value": "arian" + }] + }|] `shouldRespondWith` [scim| + { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User" + ], + "userName": "arian", + "displayName": "bjensen2", + "id": "0", + "meta": { + "resourceType": "User", + "location": "todo", + "created": "2018-01-01T00:00:00Z", + "version": "W/\"testVersion\"", + "lastModified": "2018-01-01T00:00:00Z" + } + } + |] { matchStatus = 200 } + + -- TODO(arianvp): I think this is better done with quickcheck test. + -- Generate some adds, replaces, removes and then an invalid one However, + -- for this we need to be able to generate valid patches but a patch does + -- not limit by type what fields it lenses in to. It is a very untyped + -- thingy currently. + it "PatchOp is atomic. Either fully applies or not at all" $ do + _ <- put "/0" smallUser -- reset + patch "/0" [scim|{ + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Add", + "path": "userName", + "value": "arian" + }, + { "op": "Add", + "path": "displayName", + "value": 5 + }]}|] `shouldRespondWith` 400 + get "/0" `shouldRespondWith` smallUserGet { matchStatus = 200 } + + + describe "Replace" $ do + -- TODO(arianvp): Implement and test multi-value fields properly + it "adds all fields if no target" $ do + _ <- put "/0" smallUser -- reset + patch "/0" [scim|{ + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Replace", + "value": { + "userName": "arian", + "displayName": "arian" + } + + }] + }|] `shouldRespondWith` [scim| + { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User" + ], + "userName": "arian", + "displayName": "arian", + "id": "0", + "meta": { + "resourceType": "User", + "location": "todo", + "created": "2018-01-01T00:00:00Z", + "version": "W/\"testVersion\"", + "lastModified": "2018-01-01T00:00:00Z" + } + } + |] { matchStatus = 200 } + it "adds fields if they didn't exist yet" $ do + _ <- put "/0" smallUser -- reset + patch "/0" [scim|{ + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Replace", + "path": "displayName", + "value": "arian" + }] + }|] `shouldRespondWith` [scim| + { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User" + ], + "userName": "bjensen", + "displayName": "arian", + "id": "0", + "meta": { + "resourceType": "User", + "location": "todo", + "created": "2018-01-01T00:00:00Z", + "version": "W/\"testVersion\"", + "lastModified": "2018-01-01T00:00:00Z" + } + } + |] { matchStatus = 200 } + it "replaces individual simple fields" $ do + _ <- put "/0" smallUser -- reset + patch "/0" [scim|{ + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Replace", + "path": "userName", + "value": "arian" + }] + }|] `shouldRespondWith` [scim| + { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User" + ], + "userName": "arian", + "displayName": "bjensen2", + "id": "0", + "meta": { + "resourceType": "User", + "location": "todo", + "created": "2018-01-01T00:00:00Z", + "version": "W/\"testVersion\"", + "lastModified": "2018-01-01T00:00:00Z" + } + } + |] { matchStatus = 200 } + + it "PatchOp is atomic. Either fully applies or not at all" $ do + _ <- put "/0" smallUser -- reset + patch "/0" [scim|{ + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Replace", + "path": "userName", + "value": "arian" + }, + { "op": "Replace", + "path": "displayName", + "value": 5 + }]}|] `shouldRespondWith` 400 + get "/0" `shouldRespondWith` smallUserGet { matchStatus = 200 } + + describe "Remove" $ do + it "fails if no target" $ do + _ <- put "/0" barbUpdate0 -- reset + patch "/0" [scim|{ + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ "op": "Remove" }] + }|] `shouldRespondWith` [scim|{ + "scimType":"noTarget","status":"400","schemas":["urn:ietf:params:scim:api:messages:2.0:Error"] + }|] { matchStatus = 400 } + it "fails if removing immutable" $ do + _ <- put "/0" barbUpdate0 -- reset + patch "/0" [scim|{ + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ "op": "Remove", "path": "userName"}] + }|] `shouldRespondWith` [scim|{ + "scimType":"mutability","status":"400","schemas":["urn:ietf:params:scim:api:messages:2.0:Error"] + }|] { matchStatus = 400 } + it "deletes the specified attribute" $ do + _ <- put "/0" smallUser -- reset + patch "/0" [scim|{ + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ "op": "Remove", "path": "displayName"}] + }|] `shouldRespondWith` [scim|{ + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User" + ], + "userName": "bjensen", + "id": "0", + "meta": { + "resourceType": "User", + "location": "todo", + "created": "2018-01-01T00:00:00Z", + "version": "W/\"testVersion\"", + "lastModified": "2018-01-01T00:00:00Z" + } + }|] { matchStatus = 200 } + describe "DELETE /Users/:id" $ do it "responds with 404 for unknown user" $ do delete "/9999" `shouldRespondWith` 404 @@ -79,6 +324,32 @@ spec = beforeAll app $ do delete "/0" `shouldRespondWith` 404 +smallUser :: ByteString +smallUser = [scim| + { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], + "userName":"bjensen", + "displayName": "bjensen2" + }|] + +smallUserGet :: ResponseMatcher +smallUserGet = [scim| +{ + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User" + ], + "userName": "bjensen", + "displayName": "bjensen2", + "id": "0", + "meta": { + "resourceType": "User", + "location": "todo", + "created": "2018-01-01T00:00:00Z", + "version": "W/\"testVersion\"", + "lastModified": "2018-01-01T00:00:00Z" + } +} +|] + newBarbara :: ByteString newBarbara = [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], @@ -128,7 +399,7 @@ allUsers = [scim| { "schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "totalResults": 2, "itemsPerPage": 2, - "startIndex": 0, + "startIndex": 1, "Resources": [{ "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "userName":"bjensen", @@ -171,7 +442,7 @@ onlyBarbara = [scim| { "schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "totalResults": 1, "itemsPerPage": 1, - "startIndex": 0, + "startIndex": 1, "Resources": [{ "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "userName":"bjensen", @@ -252,5 +523,5 @@ emptyList = [scim| "Resources":[], "totalResults":0, "itemsPerPage":0, - "startIndex":0 + "startIndex":1 }|] diff --git a/test/Test/FilterSpec.hs b/test/Test/FilterSpec.hs index 592fbfd968e..00ecd080cb0 100644 --- a/test/Test/FilterSpec.hs +++ b/test/Test/FilterSpec.hs @@ -1,25 +1,35 @@ {-# LANGUAGE QuasiQuotes #-} -module Test.FilterSpec (spec) where +module Test.FilterSpec where import Web.Scim.Filter +import Web.Scim.AttrName +import Web.Scim.Schema.Schema (Schema(..)) import Test.Hspec import HaskellWorks.Hspec.Hedgehog import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range +import Data.Text (cons) + + +prop_roundtrip :: Property +prop_roundtrip = property $ do + x <- forAll genFilter + tripping x renderFilter parseFilter spec :: Spec spec = do - context "parsing:" $ do - it "parse . render === id" $ require $ property $ do - filter_ <- forAll genFilter - parseFilter (renderFilter filter_) === Right filter_ + describe "Filter" $ do + it "parse . render === id" $ require $ prop_roundtrip ---------------------------------------------------------------------------- -- Generators +genValuePath :: Gen ValuePath +genValuePath = ValuePath <$> genAttrPath <*> genFilter + genCompValue :: Gen CompValue genCompValue = Gen.choice [ pure ValNull @@ -32,14 +42,26 @@ genCompValue = Gen.choice ] genCompareOp :: Gen CompareOp -genCompareOp = Gen.element - [ OpEq, OpNe, OpCo, OpSw, OpEw, OpGt, OpGe, OpLt, OpLe ] +genCompareOp = Gen.enumBounded + +genSubAttr :: Gen SubAttr +genSubAttr = SubAttr <$> genAttrName + +-- | FUTUREWORK: no support for custom schemas. +-- +-- FUTUREWORK: we also may want to factor a bounded enum type out of the 'Schema' type for +-- this: @data Schema = Buitin BuitinSchema | Custom Text; data BuiltinSchema = ... deriving +-- (Bounded, Enum, ...)@ +genSchema :: Gen Schema +genSchema = Gen.element [ServiceProviderConfig20, Group20, Schema20, ResourceType20, ListResponse20, Error20, PatchOp20] + +genAttrPath :: Gen AttrPath +genAttrPath = AttrPath <$> Gen.maybe genSchema <*> genAttrName <*> Gen.maybe genSubAttr -genAttribute :: Gen Attribute -genAttribute = Gen.element - [ AttrUserName ] +genAttrName :: Gen AttrName +genAttrName = AttrName <$> (cons <$> Gen.alpha <*> Gen.text (Range.constant 0 50) (Gen.choice [Gen.alphaNum, Gen.constant '-', Gen.constant '_'])) genFilter :: Gen Filter genFilter = Gen.choice - [ FilterAttrCompare <$> genAttribute <*> genCompareOp <*> genCompValue + [ FilterAttrCompare <$> genAttrPath <*> genCompareOp <*> genCompValue ] diff --git a/test/Test/Schema/PatchOpSpec.hs b/test/Test/Schema/PatchOpSpec.hs new file mode 100644 index 00000000000..07c3f2992e7 --- /dev/null +++ b/test/Test/Schema/PatchOpSpec.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE QuasiQuotes #-} +module Test.Schema.PatchOpSpec where +import Data.Foldable (for_) +import Test.Hspec (Spec, describe, xit, it, shouldSatisfy, shouldBe) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Web.Scim.Test.Util (scim) +import Web.Scim.Schema.PatchOp +import Data.Aeson.Types (toJSON, fromJSON, Result(Success, Error), Value(String)) +import Data.Attoparsec.ByteString (parseOnly) +import HaskellWorks.Hspec.Hedgehog (require) +import Hedgehog (Gen, tripping, forAll, Property, property) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.FilterSpec (genValuePath, genAttrPath, genSubAttr) + +isSuccess :: Result a -> Bool +isSuccess (Success _) = True +isSuccess (Error _) = False + +genPatchOp :: Gen Value -> Gen PatchOp +genPatchOp genValue = PatchOp <$> Gen.list (Range.constant 0 20) (genOperation genValue) + +genOperation :: Gen Value -> Gen Operation +genOperation genValue = Operation <$> Gen.enumBounded <*> Gen.maybe genPath <*> Gen.maybe genValue + +genPath :: Gen Path +genPath = Gen.choice + [ IntoValuePath <$> genValuePath <*> Gen.maybe genSubAttr + , NormalPath <$> genAttrPath + ] + +prop_roundtrip :: Property +prop_roundtrip = property $ do + x <- forAll genPath + tripping x (encodeUtf8 . rPath) (parseOnly pPath) + +prop_roundtrip_PatchOp :: Property +prop_roundtrip_PatchOp = property $ do + -- Just some strings for now. However, should be constrained to what the + -- PatchOp is operating on in the future... We need better typed PatchOp for + -- this. TODO(arianvp) + x <- forAll (genPatchOp (String <$> Gen.text (Range.constant 0 20) Gen.unicode)) + tripping x toJSON fromJSON + +spec :: Spec +spec = do + describe "urn:ietf:params:scim:api:messages:2.0:PatchOp" $ do + describe "The body of each request MUST contain the \"schemas\" attribute with the URI value of \"urn:ietf:params:scim:api:messages:2.0:PatchOp\"." $ do + it "rejects an empty schemas list" $ do + fromJSON @PatchOp [scim| { + "schemas": [], + "operations": [] + }|] `shouldSatisfy` (not . isSuccess) + --TODO(arianvp): We don't support arbitrary path names (yet) + it "roundtrips Path" $ require prop_roundtrip + it "roundtrips PatchOp" $ require prop_roundtrip_PatchOp + it "rejects invalid operations" $ do + fromJSON @PatchOp [scim| { + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "operations": [{"op":"unknown"}] + }|] `shouldSatisfy` (not . isSuccess) + + -- TODO(arianvp): Only makes sense if we have a Patch type _specifically_ for User + xit "rejects unknown paths" $ do + fromJSON @Path "unknown.field" `shouldSatisfy` (not . isSuccess) + it "rejects invalid paths" $ do + fromJSON @Path "unknown]field" `shouldSatisfy` (not . isSuccess) + describe "Examples from https://tools.ietf.org/html/rfc7644#section-3.5.2 Figure 8" $ do + let + examples = + [ "members" + , "name.familyname" + , "addresses[type eq \"work\"]" + , "members[value eq \"2819c223-7f76-453a-919d-413861904646\"]" + , "members[value eq \"2819c223-7f76-453a-919d-413861904646\"].displayname" + ] + for_ examples $ \p -> it ("parses " ++ show p) $ (rPath <$> parseOnly pPath p) `shouldBe` Right (decodeUtf8 p) + + diff --git a/test/Test/Schema/UserSpec.hs b/test/Test/Schema/UserSpec.hs index ce98af0ef7d..c9dabd0998a 100644 --- a/test/Test/Schema/UserSpec.hs +++ b/test/Test/Schema/UserSpec.hs @@ -1,9 +1,11 @@ +{- LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ViewPatterns #-} module Test.Schema.UserSpec (spec) where -import Test.Util +import Web.Scim.Test.Util import Web.Scim.Schema.Common (URI(..)) import Web.Scim.Schema.Schema (Schema(..)) @@ -17,16 +19,41 @@ import Web.Scim.Schema.User.Phone as Phone import Web.Scim.Schema.User.Photo as Photo import Data.Aeson import qualified Data.HashMap.Strict as HM -import Data.Text (Text, toLower) +import Data.Text (Text, toLower, toUpper) import Lens.Micro import Test.Hspec import Text.Email.Validate (emailAddress) import Network.URI.Static (uri) +import HaskellWorks.Hspec.Hedgehog (require) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +prop_roundtrip :: Property +prop_roundtrip = property $ do + user <- forAll genUser + tripping user toJSON fromJSON + + + +-- TODO(arianvp): Note that this only tests the top-level fields. +-- extrac this to a generic test and also do this for sub-properties +prop_caseInsensitive :: Property +prop_caseInsensitive = property $ do + user <- forAll genUser + let (Object user') = toJSON user + let user'' = HM.foldlWithKey' (\u k v -> HM.insert (toUpper k) v u) user' HM.empty + let user''' = HM.foldlWithKey' (\u k v -> HM.insert (toLower k) v u) user' HM.empty + + fromJSON (Object user'') === Success user + fromJSON (Object user''') === Success user + spec :: Spec spec = do describe "JSON serialization" $ do it "handles all fields" $ do + require prop_roundtrip toJSON completeUser `shouldBe` completeUserJson eitherDecode (encode completeUserJson) `shouldBe` Right completeUser @@ -37,7 +64,8 @@ spec = do it "treats 'null' and '[]' as absence of fields" $ eitherDecode (encode minimalUserJsonRedundant) `shouldBe` Right minimalUser - it "allows casing variations in field names" $ + it "allows casing variations in field names" $ do + require prop_caseInsensitive eitherDecode (encode minimalUserJsonNonCanonical) `shouldBe` Right minimalUser it "doesn't require the 'schemas' field" $ @@ -53,6 +81,72 @@ spec = do eitherDecode (encode extendedUserObjectJson) `shouldBe` Right (extendedUser (UserExtraObject "foo")) +genName :: Gen Name +genName = + Name + <$> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode) + <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode) + <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode) + <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode) + <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode) + <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode) + + +genUri :: Gen URI +genUri = Gen.element [ URI [uri|https://example.com|] ] + +-- TODO(arianvp) Generate the lists too, but first need better support for SCIM +-- lists in the first place +genUser :: Gen (User (TestTag Text () () NoUserExtra)) +genUser = do + schemas' <- pure [User20] -- TODO random schemas or? + userName' <- Gen.text (Range.constant 0 20) Gen.unicode + externalId' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode + name' <- Gen.maybe genName + displayName' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode + nickName' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode + profileUrl' <- Gen.maybe $ genUri + title' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode + userType' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode + preferredLanguage' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode + locale' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode + active' <- Gen.maybe $ Gen.bool + password' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode + emails' <- pure [] -- Gen.list (Range.constant 0 20) genEmail + phoneNumbers' <- pure [] -- Gen.list (Range.constant 0 20) genPhone + ims' <- pure [] -- Gen.list (Range.constant 0 20) genIM + photos' <- pure [] -- Gen.list (Range.constant 0 20) genPhoto + addresses' <- pure [] -- Gen.list (Range.constant 0 20) genAddress + entitlements' <- pure [] -- Gen.list (Range.constant 0 20) (Gen.text (Range.constant 0 20) Gen.unicode) + roles' <- pure [] -- Gen.list (Range.constant 0 20) (Gen.text (Range.constant 0 10) Gen.unicode) + x509Certificates' <- pure [] -- Gen.list (Range.constant 0 20) genCertificate + + pure $ User + { schemas = schemas' + , userName = userName' + , externalId = externalId' + , name = name' + , displayName = displayName' + , nickName = nickName' + , profileUrl = profileUrl' + , title = title' + , userType = userType' + , preferredLanguage = preferredLanguage' + , locale = locale' + , active = active' + , password = password' + , emails = emails' + , phoneNumbers = phoneNumbers' + , ims = ims' + , photos = photos' + , addresses = addresses' + , entitlements = entitlements' + , roles = roles' + , x509Certificates = x509Certificates' + , extra = NoUserExtra + } + + -- | A 'User' with all attributes present. completeUser :: User (TestTag Text () () NoUserExtra) completeUser = User @@ -182,7 +276,7 @@ completeUserJson = [scim| -- | A 'User' with all attributes empty (if possible). minimalUser :: User (TestTag Text () () NoUserExtra) -minimalUser = (empty [User20] NoUserExtra) { userName = "sample userName" } +minimalUser = empty [User20] "sample userName" NoUserExtra -- | Reference encoding of 'minimalUser'. minimalUserJson :: Value @@ -264,8 +358,7 @@ instance ToJSON UserExtraTest where -- | A 'User' with extra fields present. extendedUser :: UserExtraTest -> User (TestTag Text () () UserExtraTest) extendedUser e = - (empty [User20, CustomSchema "urn:hscim:test"] e) - { userName = "sample userName" } + (empty [User20, CustomSchema "urn:hscim:test"] "sample userName" e) -- | Encoding of @extendedUser UserExtraEmpty@. extendedUserEmptyJson :: Value From 5b40fba3665c1e8b69fad569cfb9e0634ecbffc8 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Mon, 27 Jan 2020 10:56:09 +0100 Subject: [PATCH 28/64] Build hscim with LTS 14.12 (#40) * Make hscim compile with LTS 14.12 We need this to bump wire-server * Add version bounds This makes it possible to also build this with Cabal and get a similar build plan :) * Don't ignore cabal file I think we even need it if we need to upload this to Hackage? Sure hpack is cute, but for applications... Also I'm not sure if I buy the yaml all the things trend * Update gitignore * Don't hardcode LTS version in CI? what's the point of that :) --- .gitignore | 3 +- .travis.yml | 7 +- hscim.cabal | 217 ++++++++++++++++++++++++++++++++++ package.yaml | 103 +++++++--------- server/Main.hs | 2 +- src/Web/Scim/Class/User.hs | 4 +- src/Web/Scim/Schema/Error.hs | 10 +- src/Web/Scim/Schema/Schema.hs | 2 +- src/Web/Scim/Server/Mock.hs | 8 +- stack.yaml | 10 +- test/Test/Class/AuthSpec.hs | 2 +- 11 files changed, 282 insertions(+), 86 deletions(-) create mode 100644 hscim.cabal diff --git a/.gitignore b/.gitignore index c04fa9f5d2b..691684e8295 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,6 @@ dist dist-* cabal-dev -*.cabal *.o *.hi *.chi @@ -21,8 +20,8 @@ cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* +.stac-work-tmp/ *~ *.el \#* -hscim.cabal diff --git a/.travis.yml b/.travis.yml index 1cfd3d37254..9e17a079b4b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -12,19 +12,16 @@ addons: packages: - libgmp-dev -env: -- RESOLVER=lts-12.10 - before_install: - mkdir -p ~/.local/bin - export PATH=$HOME/.local/bin:$PATH - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' install: -- stack --resolver=$RESOLVER --no-terminal --install-ghc test --fast --only-dependencies +- stack --no-terminal --install-ghc test --fast --only-dependencies script: -- stack --resolver=$RESOLVER --no-terminal test --fast --haddock --no-haddock-deps +- stack --no-terminal test --fast --haddock --no-haddock-deps notifications: # see https://docs.travis-ci.com/user/notifications email: false diff --git a/hscim.cabal b/hscim.cabal new file mode 100644 index 00000000000..147fc550b8b --- /dev/null +++ b/hscim.cabal @@ -0,0 +1,217 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.32.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: f2b10a42030a70e77c8ab8273dccb11998299e253bb932b5ad69a0a1da8aac1d + +name: hscim +version: 0.3.0 +synopsis: ... +description: ... +category: Web +homepage: https://github.com/wireapp/hscim/README.md +bug-reports: https://github.com/wireapp/hscim/issues +author: Wire Swiss GmbH +maintainer: Wire Swiss GmbH +copyright: (c) 2018 Wire Swiss GmbH +license: AGPL-3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/wireapp/hscim + +library + exposed-modules: + Web.Scim.AttrName + Web.Scim.Capabilities.MetaSchema + Web.Scim.Capabilities.MetaSchema.Group + Web.Scim.Capabilities.MetaSchema.ResourceType + Web.Scim.Capabilities.MetaSchema.Schema + Web.Scim.Capabilities.MetaSchema.SPConfig + Web.Scim.Capabilities.MetaSchema.User + Web.Scim.Class.Auth + Web.Scim.Class.Group + Web.Scim.Class.User + Web.Scim.ContentType + Web.Scim.Filter + Web.Scim.Handler + Web.Scim.Schema.AuthenticationScheme + Web.Scim.Schema.Common + Web.Scim.Schema.Error + Web.Scim.Schema.ListResponse + Web.Scim.Schema.Meta + Web.Scim.Schema.PatchOp + Web.Scim.Schema.ResourceType + Web.Scim.Schema.Schema + Web.Scim.Schema.User + Web.Scim.Schema.User.Address + Web.Scim.Schema.User.Certificate + Web.Scim.Schema.User.Email + Web.Scim.Schema.User.IM + Web.Scim.Schema.User.Name + Web.Scim.Schema.User.Phone + Web.Scim.Schema.User.Photo + Web.Scim.Server + Web.Scim.Server.Mock + Web.Scim.Test.Acceptance + Web.Scim.Test.Util + other-modules: + Paths_hscim + hs-source-dirs: + src + default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances + ghc-options: -Wall -Werror + build-depends: + aeson >=1.4.5 && <1.5 + , aeson-qq >=0.8.2 && <0.9 + , attoparsec >=0.13.2 && <0.14 + , base >=4.12 && <4.13 + , bytestring >=0.10.8 && <0.11 + , email-validate >=2.3.2 && <2.4 + , errors >=2.3.0 && <2.4 + , hashable >=1.2.7 && <1.4 + , hedgehog >=1.0.1 && <1.1 + , hspec >=2.7.1 && <2.8 + , hspec-expectations >=0.8.2 && <0.9 + , hspec-wai >=0.9.2 && <0.10 + , http-api-data >=0.4.1 && <0.5 + , http-media >=0.8.0 && <0.9 + , http-types >=0.12.3 && <0.13 + , hw-hspec-hedgehog >=0.1.0 && <0.2 + , list-t >=1.0.4 && <1.1 + , microlens >=0.4.10 && <0.5 + , mmorph >=1.1.3 && <1.2 + , mtl >=2.2.2 && <2.3 + , network-uri >=2.6.1 && <2.7 + , network-uri-static >=0.1.2 && <0.2 + , scientific >=0.3.6 && <0.4 + , servant >=0.16.2 && <0.17 + , servant-server >=0.16.2 && <0.17 + , stm >=2.5.0 && <2.6 + , stm-containers >=1.1.0 && <1.2 + , template-haskell >=2.14.0 && <2.15 + , text >=1.2.3 && <1.3 + , time >=1.8.0 && <1.9 + , unordered-containers >=0.2.10 && <0.3 + , uuid >=1.3.13 && <1.4 + , vector >=0.12.0 && <0.13 + , wai >=3.2.2 && <3.3 + , wai-extra >=3.0.28 && <3.1 + , wai-logger >=2.3.5 && <2.4 + , warp >=3.2.28 && <3.4 + default-language: Haskell2010 + +executable hscim-server + main-is: Main.hs + other-modules: + Paths_hscim + hs-source-dirs: + server + default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances + ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=1.4.5 && <1.5 + , aeson-qq >=0.8.2 && <0.9 + , attoparsec >=0.13.2 && <0.14 + , base >=4.12 && <4.13 + , bytestring >=0.10.8 && <0.11 + , email-validate >=2.3.2 && <2.4 + , errors >=2.3.0 && <2.4 + , hashable >=1.2.7 && <1.4 + , hedgehog >=1.0.1 && <1.1 + , hscim + , hspec >=2.7.1 && <2.8 + , hspec-expectations >=0.8.2 && <0.9 + , hspec-wai >=0.9.2 && <0.10 + , http-api-data >=0.4.1 && <0.5 + , http-media >=0.8.0 && <0.9 + , http-types >=0.12.3 && <0.13 + , hw-hspec-hedgehog >=0.1.0 && <0.2 + , list-t >=1.0.4 && <1.1 + , microlens >=0.4.10 && <0.5 + , mmorph >=1.1.3 && <1.2 + , mtl >=2.2.2 && <2.3 + , network-uri >=2.6.1 && <2.7 + , network-uri-static >=0.1.2 && <0.2 + , scientific >=0.3.6 && <0.4 + , servant >=0.16.2 && <0.17 + , servant-server >=0.16.2 && <0.17 + , stm >=2.5.0 && <2.6 + , stm-containers >=1.1.0 && <1.2 + , template-haskell >=2.14.0 && <2.15 + , text >=1.2.3 && <1.3 + , time >=1.8.0 && <1.9 + , unordered-containers >=0.2.10 && <0.3 + , uuid >=1.3.13 && <1.4 + , vector >=0.12.0 && <0.13 + , wai >=3.2.2 && <3.3 + , wai-extra >=3.0.28 && <3.1 + , wai-logger >=2.3.5 && <2.4 + , warp >=3.2.28 && <3.4 + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.AcceptanceSpec + Test.Capabilities.MetaSchemaSpec + Test.Class.AuthSpec + Test.Class.GroupSpec + Test.Class.UserSpec + Test.FilterSpec + Test.Schema.PatchOpSpec + Test.Schema.UserSpec + Paths_hscim + hs-source-dirs: + test + default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances + ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + aeson >=1.4.5 && <1.5 + , aeson-qq >=0.8.2 && <0.9 + , attoparsec >=0.13.2 && <0.14 + , base >=4.12 && <4.13 + , bytestring >=0.10.8 && <0.11 + , email-validate >=2.3.2 && <2.4 + , errors >=2.3.0 && <2.4 + , hashable >=1.2.7 && <1.4 + , hedgehog >=1.0.1 && <1.1 + , hscim + , hspec >=2.7.1 && <2.8 + , hspec-expectations >=0.8.2 && <0.9 + , hspec-wai >=0.9.2 && <0.10 + , http-api-data >=0.4.1 && <0.5 + , http-media >=0.8.0 && <0.9 + , http-types >=0.12.3 && <0.13 + , hw-hspec-hedgehog >=0.1.0 && <0.2 + , list-t >=1.0.4 && <1.1 + , microlens >=0.4.10 && <0.5 + , mmorph >=1.1.3 && <1.2 + , mtl >=2.2.2 && <2.3 + , network-uri >=2.6.1 && <2.7 + , network-uri-static >=0.1.2 && <0.2 + , scientific >=0.3.6 && <0.4 + , servant >=0.16.2 && <0.17 + , servant-server >=0.16.2 && <0.17 + , stm >=2.5.0 && <2.6 + , stm-containers >=1.1.0 && <1.2 + , template-haskell >=2.14.0 && <2.15 + , text >=1.2.3 && <1.3 + , time >=1.8.0 && <1.9 + , unordered-containers >=0.2.10 && <0.3 + , uuid >=1.3.13 && <1.4 + , vector >=0.12.0 && <0.13 + , wai >=3.2.2 && <3.3 + , wai-extra >=3.0.28 && <3.1 + , wai-logger >=2.3.5 && <2.4 + , warp >=3.2.28 && <3.4 + default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 5c8370e9460..6ce8e8b5a33 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: hscim -version: 0.2 +version: 0.3.0 synopsis: ... description: ... homepage: https://github.com/wireapp/hscim/README.md @@ -33,45 +33,45 @@ default-extensions: extra-source-files: - README.md + dependencies: - - aeson - - aeson-qq - - attoparsec - - base >= 4.11 && < 5 - - bytestring - - email-validate - - errors - - hashable - - hedgehog - - hspec - - hspec-expectations - - hspec-wai - - http-api-data - - http-media - - http-types - - hw-hspec-hedgehog - - list-t - - microlens - - mmorph - - mtl - - network-uri - - network-uri-static >= 0.1.1.0 - - scientific - - servant - - servant-server - - servant-server >= 0.14.1 - - stm - - stm-containers - - template-haskell - - text - - time - - unordered-containers - - uuid - - vector - - wai - - wai-extra - - wai-logger - - warp + - aeson >= 1.4.5 && < 1.5 + - attoparsec >= 0.13.2 && < 0.14 + - bytestring >= 0.10.8 && < 0.11 + - base >= 4.12 && < 4.13 + - scientific >= 0.3.6 && < 0.4 + - hashable >= 1.2.7 && < 1.4 + - text >= 1.2.3 && < 1.3 + - time >= 1.8.0 && < 1.9 + - template-haskell >= 2.14.0 && < 2.15 + - unordered-containers >= 0.2.10 && < 0.3 + - vector >= 0.12.0 && < 0.13 + - aeson-qq >= 0.8.2 && < 0.9 + - mtl >= 2.2.2 && < 2.3 + - email-validate >= 2.3.2 && < 2.4 + - errors >= 2.3.0 && < 2.4 + - stm >= 2.5.0 && < 2.6 + - hedgehog >= 1.0.1 && < 1.1 + - mmorph >= 1.1.3 && < 1.2 + - hspec >= 2.7.1 && < 2.8 + - hspec-wai >= 0.9.2 && < 0.10 + - hspec-expectations >= 0.8.2 && < 0.9 + - http-types >= 0.12.3 && < 0.13 + - wai >= 3.2.2 && < 3.3 + - wai-extra >= 3.0.28 && < 3.1 + - wai-logger >= 2.3.5 && < 2.4 + - http-api-data >= 0.4.1 && < 0.5 + - http-media >= 0.8.0 && < 0.9 + - hw-hspec-hedgehog >= 0.1.0 && < 0.2 + - list-t >= 1.0.4 && < 1.1 + - microlens >= 0.4.10 && < 0.5 + - network-uri >= 2.6.1 && < 2.7 + - network-uri-static >= 0.1.2 && < 0.2 + - servant >= 0.16.2 && < 0.17 + - servant-server >= 0.16.2 && < 0.17 + - warp >= 3.2.28 && < 3.4 + - stm-containers >= 1.1.0 && < 1.2 + - uuid >= 1.3.13 && < 1.4 ghc-options: -Wall -Werror @@ -85,7 +85,6 @@ executables: source-dirs: server dependencies: - hscim - - warp tests: spec: @@ -93,27 +92,7 @@ tests: ghc-options: -threaded -rtsopts -with-rtsopts=-N source-dirs: - test + build-tools: + - hspec-discover:hspec-discover dependencies: - hscim - - aeson - - aeson-qq - - base - - bytestring - - containers - - hedgehog - - hspec - - hspec-discover - - hspec-expectations - - hspec-wai - - http-types - - hw-hspec-hedgehog - - mtl - - servant-server - - stm-containers - - template-haskell - - text - - time - - vector - - wai-extra - - wai-logger - - warp diff --git a/server/Main.hs b/server/Main.hs index 2bd9598b894..5ef890f2a45 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -16,7 +16,7 @@ import Web.Scim.Capabilities.MetaSchema as MetaSchema import Data.Time import Network.Wai.Handler.Warp import Network.URI.Static -import qualified STMContainers.Map as STMMap +import qualified StmContainers.Map as STMMap import Control.Monad.STM (atomically) import Text.Email.Validate diff --git a/src/Web/Scim/Class/User.hs b/src/Web/Scim/Class/User.hs index 1c2b66a5840..d767a6700fb 100644 --- a/src/Web/Scim/Class/User.hs +++ b/src/Web/Scim/Class/User.hs @@ -108,13 +108,13 @@ class (Monad m, AuthTypes tag, UserTypes tag) => UserDB tag m where -- followed by a PUT. GET will retrieve the entire record; we then modify -- this record by a series of PATCH operations, and then PUT the entire -- record. - -- + -- patchUser :: AuthInfo tag -> UserId tag -> PatchOp -- ^ PATCH payload -> ScimHandler m (StoredUser tag) - default patchUser + default patchUser :: FromJSON (UserExtra tag) => AuthInfo tag -> UserId tag diff --git a/src/Web/Scim/Schema/Error.hs b/src/Web/Scim/Schema/Error.hs index 151a7d8e308..6e5b198b163 100644 --- a/src/Web/Scim/Schema/Error.hs +++ b/src/Web/Scim/Schema/Error.hs @@ -15,7 +15,7 @@ module Web.Scim.Schema.Error , serverError -- * Servant interoperability - , scimToServantErr + , scimToServerError ) where import Data.Text (Text, pack) @@ -23,7 +23,7 @@ import Data.Aeson hiding (Error) import Control.Exception import Web.Scim.Schema.Common import Web.Scim.Schema.Schema -import Servant (ServantErr (..)) +import Servant (ServerError (..)) import GHC.Generics (Generic) @@ -153,9 +153,9 @@ serverError details = -- | Convert a SCIM 'Error' to a Servant one by encoding it with the -- appropriate headers. -scimToServantErr :: ScimError -> ServantErr -scimToServantErr err = - ServantErr +scimToServerError :: ScimError -> ServerError +scimToServerError err = + ServerError { errHTTPCode = unStatus (status err) , errReasonPhrase = reasonPhrase (status err) , errBody = encode err diff --git a/src/Web/Scim/Schema/Schema.hs b/src/Web/Scim/Schema/Schema.hs index f1ecfde78bc..8b598cec31c 100644 --- a/src/Web/Scim/Schema/Schema.hs +++ b/src/Web/Scim/Schema/Schema.hs @@ -8,7 +8,7 @@ import Web.Scim.Capabilities.MetaSchema.Schema import Web.Scim.Capabilities.MetaSchema.ResourceType import Data.Text -import Data.Aeson +import Data.Aeson (FromJSON, parseJSON, toJSON, ToJSON, withText, Value) import Data.Attoparsec.ByteString (Parser, ()) import Control.Applicative ((<|>)) diff --git a/src/Web/Scim/Server/Mock.hs b/src/Web/Scim/Server/Mock.hs index 4bdee33085c..00e0e242ee1 100644 --- a/src/Web/Scim/Server/Mock.hs +++ b/src/Web/Scim/Server/Mock.hs @@ -21,7 +21,7 @@ import Data.Time.Clock import Data.Time.Calendar import GHC.Exts (sortWith) import ListT -import qualified STMContainers.Map as STMMap +import qualified StmContainers.Map as STMMap import Text.Read (readMaybe) import Web.Scim.Filter (Filter(..), CompValue(..), AttrPath(..), compareStr) import Web.Scim.Schema.User @@ -77,7 +77,7 @@ instance UserTypes Mock where instance UserDB Mock TestServer where getUsers () mbFilter = do m <- userDB <$> ask - users <- liftSTM $ ListT.toList $ STMMap.stream m + users <- liftSTM $ ListT.toList $ STMMap.listT m let check user = case mbFilter of Nothing -> pure True Just filter_ -> do @@ -128,7 +128,7 @@ instance GroupTypes Mock where instance GroupDB Mock TestServer where getGroups () = do m <- groupDB <$> ask - groups <- liftSTM $ ListT.toList $ STMMap.stream m + groups <- liftSTM $ ListT.toList $ STMMap.listT m return $ fromList . sortWith (Common.id . thing) $ snd <$> groups getGroup () gid = do @@ -198,7 +198,7 @@ createMeta rType = Meta nt :: TestStorage -> ScimHandler TestServer a -> Handler a nt storage = flip runReaderT storage . - fromScimHandler (lift . throwError . scimToServantErr) + fromScimHandler (lift . throwError . scimToServerError) -- | Check whether a user satisfies the filter. diff --git a/stack.yaml b/stack.yaml index faddcb4d08c..f65f4f731a0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,11 +1,15 @@ -resolver: lts-12.10 -compiler: ghc-8.4.4 +resolver: lts-14.12 packages: - . extra-deps: -- network-uri-static-0.1.1.0 +- network-uri-static-0.1.2.1@sha256:7e1ca4358b319ac2db6514d0e0beb073c296789eeef9cebd89cc9517618fbfe8,1724 +- stm-containers-1.1.0.4@sha256:f83a683357b6e3b1dda3e70d2077a37224ed534df1f74c4e11f3f6daa7945c5b,3248 +- stm-hamt-1.2.0.4@sha256:7957497c022554b7599e790696d1a3e56359ad99e5da36a251894c626ca1f60a,3970 +- primitive-0.7.0.0@sha256:ee352d97cc390d8513530029a2213a95c179a66c406906b18d03702c1d9ab8e5,3416 +- primitive-extras-0.8@sha256:fca0310150496867f5b9421fe1541ecda87fae17eae44885a29f9c52dd00c8ff,2963 +- primitive-unlifted-0.1.2.0@sha256:9c3df73af54ed19fb3f4874da19334863cc414b22e578e27b5f52beeac4a60dd,1360 nix: packages: diff --git a/test/Test/Class/AuthSpec.hs b/test/Test/Class/AuthSpec.hs index 7805e1fd66d..921311022a3 100644 --- a/test/Test/Class/AuthSpec.hs +++ b/test/Test/Class/AuthSpec.hs @@ -11,7 +11,7 @@ import Test.Hspec import Test.Hspec.Wai hiding (post, put, patch) import Network.HTTP.Types.Header import Network.HTTP.Types.Method (methodGet) -import qualified STMContainers.Map as STMMap +import qualified StmContainers.Map as STMMap testStorage :: IO TestStorage testStorage = TestStorage <$> STMMap.newIO <*> STMMap.newIO From d4cf3e3e9b44b6d6e12db2ea4b1109b2f5cdac58 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Fri, 10 Jan 2020 20:20:59 +0100 Subject: [PATCH 29/64] Implement `PATCH` for the `extra` field in User [zinfra/backend-issues#985] --- hscim.cabal | 5 +- src/Web/Scim/Class/User.hs | 8 +-- src/Web/Scim/Filter.hs | 49 +++++++++-------- src/Web/Scim/Schema/Common.hs | 1 - src/Web/Scim/Schema/PatchOp.hs | 65 +++++++++++++++-------- src/Web/Scim/Schema/Schema.hs | 38 ++++--------- src/Web/Scim/Schema/User.hs | 73 ++++++++++++++++--------- src/Web/Scim/Schema/UserTypes.hs | 15 ++++++ src/Web/Scim/Server/Mock.hs | 3 +- src/Web/Scim/Test/Util.hs | 2 + test/Test/Class/UserSpec.hs | 6 +-- test/Test/FilterSpec.hs | 31 ++++++----- test/Test/Schema/PatchOpSpec.hs | 91 +++++++++++++++++++++++--------- test/Test/Schema/UserSpec.hs | 29 +++++++--- 14 files changed, 261 insertions(+), 155 deletions(-) create mode 100644 src/Web/Scim/Schema/UserTypes.hs diff --git a/hscim.cabal b/hscim.cabal index 147fc550b8b..9a861086152 100644 --- a/hscim.cabal +++ b/hscim.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.32.0. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: f2b10a42030a70e77c8ab8273dccb11998299e253bb932b5ad69a0a1da8aac1d +-- hash: dacbefe6b2a13bf0be7cc0a32b675c371e2afc853228e2feb0e834c908d9aaf6 name: hscim version: 0.3.0 @@ -57,6 +57,7 @@ library Web.Scim.Schema.User.Name Web.Scim.Schema.User.Phone Web.Scim.Schema.User.Photo + Web.Scim.Schema.UserTypes Web.Scim.Server Web.Scim.Server.Mock Web.Scim.Test.Acceptance diff --git a/src/Web/Scim/Class/User.hs b/src/Web/Scim/Class/User.hs index d767a6700fb..7b5f6c6eb8d 100644 --- a/src/Web/Scim/Class/User.hs +++ b/src/Web/Scim/Class/User.hs @@ -44,7 +44,7 @@ data UserSite tag route = UserSite Put '[SCIM] (StoredUser tag) , usPatchUser :: route :- Capture "id" (UserId tag) :> - ReqBody '[SCIM] PatchOp :> + ReqBody '[SCIM] (PatchOp tag) :> Patch '[SCIM] (StoredUser tag) , usDeleteUser :: route :- Capture "id" (UserId tag) :> @@ -112,13 +112,13 @@ class (Monad m, AuthTypes tag, UserTypes tag) => UserDB tag m where patchUser :: AuthInfo tag -> UserId tag - -> PatchOp -- ^ PATCH payload + -> PatchOp tag -- ^ PATCH payload -> ScimHandler m (StoredUser tag) default patchUser - :: FromJSON (UserExtra tag) + :: (Patchable (UserExtra tag), FromJSON (UserExtra tag)) => AuthInfo tag -> UserId tag - -> PatchOp -- ^ PATCH payload + -> PatchOp tag -- ^ PATCH payload -> ScimHandler m (StoredUser tag) patchUser info uid op' = do (WithMeta _ (WithId _ (user :: User tag))) <- getUser info uid diff --git a/src/Web/Scim/Filter.hs b/src/Web/Scim/Filter.hs index fde3faa588e..8b0c88a11f9 100644 --- a/src/Web/Scim/Filter.hs +++ b/src/Web/Scim/Filter.hs @@ -41,7 +41,7 @@ module Web.Scim.Filter import Data.String import Prelude hiding (takeWhile) -import Control.Applicative(optional) +import Control.Applicative (optional, (<|>)) import Data.Scientific import Data.Text (Text, pack, isInfixOf, isPrefixOf, isSuffixOf) import Data.Text.Encoding (encodeUtf8) @@ -50,11 +50,10 @@ import Data.Attoparsec.ByteString.Char8 import Data.Aeson.Parser as Aeson import Data.Aeson.Text as Aeson import Data.Aeson as Aeson -import Data.Maybe (fromMaybe) import Lens.Micro import Web.HttpApiData -import Web.Scim.Schema.Schema (getSchemaUri, Schema, pSchema) +import Web.Scim.Schema.Schema (Schema(User20), getSchemaUri, pSchema) import Web.Scim.AttrName ---------------------------------------------------------------------------- @@ -139,10 +138,10 @@ topLevelAttrPath x = AttrPath Nothing (AttrName x) Nothing -- -- Note: this parser is written with Attoparsec because I don't know how to -- lift an Attoparsec parser (from Aeson) to Megaparsec -parseFilter :: Text -> Either Text Filter -parseFilter = +parseFilter :: [Schema] -> Text -> Either Text Filter +parseFilter supportedSchemas = over _Left pack . - parseOnly (skipSpace *> pFilter <* skipSpace <* endOfInput) . + parseOnly (skipSpace *> pFilter supportedSchemas <* skipSpace <* endOfInput) . encodeUtf8 -- | @@ -150,21 +149,19 @@ parseFilter = -- ATTRNAME = ALPHA *(nameChar) -- attrPath = [URI ":"] ATTRNAME *1subAtt -- @ -pAttrPath :: Parser AttrPath -pAttrPath = - AttrPath - <$> (optional (pSchema <* char ':')) - <*> pAttrName - <*> optional pSubAttr +pAttrPath :: [Schema] -> Parser AttrPath +pAttrPath supportedSchemas = do + schema <- (Just <$> (pSchema supportedSchemas <* char ':') ) <|> pure Nothing + AttrPath schema <$> pAttrName <*> optional pSubAttr -- | subAttr = "." ATTRNAME pSubAttr :: Parser SubAttr pSubAttr = char '.' *> (SubAttr <$> pAttrName) -- | valuePath = attrPath "[" valFilter "]" -pValuePath :: Parser ValuePath -pValuePath = - ValuePath <$> pAttrPath <*> (char '[' *> pFilter <* char ']') +pValuePath :: [Schema] -> Parser ValuePath +pValuePath supportedSchemas = + ValuePath <$> pAttrPath supportedSchemas <*> (char '[' *> pFilter supportedSchemas <* char ']') -- | Value literal parser. pCompValue :: Parser CompValue @@ -191,13 +188,12 @@ pCompareOp = choice ] -- | Filter parser. -pFilter :: Parser Filter -pFilter = choice - [ FilterAttrCompare - <$> pAttrPath - <*> (skipSpace1 *> pCompareOp) - <*> (skipSpace1 *> pCompValue) - ] +pFilter :: [Schema] -> Parser Filter +pFilter supportedSchemas = + FilterAttrCompare + <$> pAttrPath supportedSchemas + <*> (skipSpace1 *> pCompareOp) + <*> (skipSpace1 *> pCompValue) -- | Utility parser for skipping one or more spaces. skipSpace1 :: Parser () @@ -214,10 +210,12 @@ renderFilter filter_ = case filter_ of rAttrPath :: AttrPath -> Text rAttrPath (AttrPath schema attr subAttr) - = fromMaybe "" ((<> ":") . getSchemaUri <$> schema) <> rAttrName attr <> fromMaybe "" (rSubAttr <$> subAttr) + = maybe "" ((<> ":") . getSchemaUri) schema + <> rAttrName attr + <> maybe "" rSubAttr subAttr rSubAttr :: SubAttr -> Text -rSubAttr (SubAttr x) = "." <> (rAttrName x) +rSubAttr (SubAttr x) = "." <> rAttrName x rValuePath :: ValuePath -> Text rValuePath (ValuePath attrPath filter') = rAttrPath attrPath <> "[" <> renderFilter filter' <> "]" @@ -260,8 +258,9 @@ compareStr = \case ---------------------------------------------------------------------------- -- Instances +-- | We currently only support filtering on core user schema instance FromHttpApiData Filter where - parseUrlPiece = parseFilter + parseUrlPiece = parseFilter [User20] instance ToHttpApiData Filter where toUrlPiece = renderFilter diff --git a/src/Web/Scim/Schema/Common.hs b/src/Web/Scim/Schema/Common.hs index d6b2cef1871..e60d6a16c45 100644 --- a/src/Web/Scim/Schema/Common.hs +++ b/src/Web/Scim/Schema/Common.hs @@ -24,7 +24,6 @@ instance (FromJSON id, FromJSON a) => FromJSON (WithId id a) where parseJSON = withObject "WithId" $ \o -> WithId <$> o .: "id" <*> parseJSON (Object o) - newtype URI = URI { unURI :: Network.URI } deriving (Show, Eq) diff --git a/src/Web/Scim/Schema/PatchOp.hs b/src/Web/Scim/Schema/PatchOp.hs index ecc40cc3a41..fdbf7393700 100644 --- a/src/Web/Scim/Schema/PatchOp.hs +++ b/src/Web/Scim/Schema/PatchOp.hs @@ -2,17 +2,22 @@ module Web.Scim.Schema.PatchOp where import Control.Applicative import Control.Monad (guard) +import Control.Monad.Except import Web.Scim.Schema.Schema (Schema(PatchOp20)) +import Web.Scim.Schema.UserTypes (UserTypes(supportedSchemas)) import Data.Aeson.Types (withText, ToJSON(toJSON), object, (.=), FromJSON(parseJSON), withObject, (.:), (.:?), Value(String)) +import qualified Data.Aeson.Types as Aeson import qualified Data.HashMap.Strict as HashMap import Data.Text (toCaseFold, toLower, Text) import Data.Text.Encoding (encodeUtf8) import Data.Bifunctor (first) import Data.Attoparsec.ByteString (Parser, parseOnly, endOfInput) +import Web.Scim.AttrName (AttrName(..)) import Web.Scim.Filter (AttrPath(..), ValuePath(..), SubAttr(..), pAttrPath, pValuePath, pSubAttr, rAttrPath, rSubAttr, rValuePath) -import Data.Maybe (fromMaybe) +import Web.Scim.Schema.Error +import qualified Data.HashMap.Strict as HM -newtype PatchOp = PatchOp +newtype PatchOp tag = PatchOp { getOperations :: [Operation] } deriving (Eq, Show) @@ -45,43 +50,49 @@ data Path | IntoValuePath ValuePath (Maybe SubAttr) deriving (Eq, Show) - -parsePath :: Text -> Either String Path -parsePath = parseOnly (pPath <* endOfInput) . encodeUtf8 +parsePath :: [Schema] -> Text -> Either String Path +parsePath schemas' = parseOnly (pPath schemas' <* endOfInput) . encodeUtf8 -- | PATH = attrPath / valuePath [subAttr] -pPath :: Parser Path -pPath = - IntoValuePath <$> pValuePath <*> optional pSubAttr <|> - NormalPath <$> pAttrPath +pPath :: [Schema] -> Parser Path +pPath schemas' = + IntoValuePath <$> pValuePath schemas' <*> optional pSubAttr <|> + NormalPath <$> pAttrPath schemas' rPath :: Path -> Text rPath (NormalPath attrPath) = rAttrPath attrPath -rPath (IntoValuePath valuePath subAttr) = rValuePath valuePath <> fromMaybe "" (rSubAttr <$> subAttr) +rPath (IntoValuePath valuePath subAttr) = rValuePath valuePath <> maybe "" rSubAttr subAttr -- TODO(arianvp): According to the SCIM spec we should throw an InvalidPath -- error when the path is invalid syntax. this is a bit hard to do though as we -- can't control what errors FromJSON throws :/ -instance FromJSON PatchOp where +instance UserTypes tag => FromJSON (PatchOp tag) where parseJSON = withObject "PatchOp" $ \v -> do let o = HashMap.fromList . map (first toLower) . HashMap.toList $ v - schemas :: [Schema] <- o .: "schemas" - guard $ PatchOp20 `elem` schemas - operations <- o .: "operations" + schemas' :: [Schema] <- o .: "schemas" + guard $ PatchOp20 `elem` schemas' + operations <- Aeson.explicitParseField (Aeson.listParser $ operationFromJSON $ supportedSchemas @tag) o "operations" pure $ PatchOp operations -instance ToJSON PatchOp where +instance ToJSON (PatchOp tag) where toJSON (PatchOp operations) = object [ "operations" .= operations , "schemas" .= [PatchOp20] ] - -- TODO: Azure wants us to be case-insensitive on _values_ as well here. We currently do not -- comply with that. -instance FromJSON Operation where - parseJSON = withObject "Operation" $ \v -> do +operationFromJSON :: [Schema] -> Value -> Aeson.Parser Operation +operationFromJSON schemas' = + withObject "Operation" $ \v -> do let o = HashMap.fromList . map (first toLower) . HashMap.toList $ v - Operation <$> (o .: "op") <*> (o .:? "path") <*> (o .:? "value") + Operation + <$> (o .: "op") + <*> (Aeson.explicitParseFieldMaybe (pathFromJSON schemas') o "path") + <*> (o .:? "value") + +pathFromJSON :: [Schema] -> Value -> Aeson.Parser Path +pathFromJSON schemas' = + withText "Path" $ either fail pure . (parsePath schemas') instance ToJSON Operation where toJSON (Operation op' path' value') = @@ -105,9 +116,17 @@ instance ToJSON Op where toJSON Replace = String "replace" toJSON Remove = String "remove" - -instance FromJSON Path where - parseJSON = withText "Path" $ either fail pure . parsePath - instance ToJSON Path where toJSON = String . rPath + +-- | A very coarse description of what it means to be 'Patchable' +-- I do not like it. We should handhold people using this library more +class Patchable a where + applyOperation :: (MonadError ScimError m) => a -> Operation -> m a + +instance Patchable (HM.HashMap Text Text) where + applyOperation theMap (Operation Remove (Just (NormalPath (AttrPath _schema (AttrName attrName) _subAttr))) _) = + pure $ HM.delete attrName theMap + applyOperation theMap (Operation _AddOrReplace (Just (NormalPath (AttrPath _schema (AttrName attrName) _subAttr))) (Just (String val))) = + pure $ HM.insert attrName val theMap + applyOperation _ _ = throwError $ badRequest InvalidValue $ Just "Unsupported operation" diff --git a/src/Web/Scim/Schema/Schema.hs b/src/Web/Scim/Schema/Schema.hs index 8b598cec31c..ca972583afa 100644 --- a/src/Web/Scim/Schema/Schema.hs +++ b/src/Web/Scim/Schema/Schema.hs @@ -1,4 +1,3 @@ - module Web.Scim.Schema.Schema where import Web.Scim.Capabilities.MetaSchema.User @@ -7,10 +6,11 @@ import Web.Scim.Capabilities.MetaSchema.Group import Web.Scim.Capabilities.MetaSchema.Schema import Web.Scim.Capabilities.MetaSchema.ResourceType -import Data.Text +import Data.Text (Text) import Data.Aeson (FromJSON, parseJSON, toJSON, ToJSON, withText, Value) -import Data.Attoparsec.ByteString (Parser, ()) -import Control.Applicative ((<|>)) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Attoparsec.ByteString (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as Parser -- | All schemas that we support. data Schema = User20 @@ -51,35 +51,19 @@ getSchemaUri PatchOp20 = getSchemaUri (CustomSchema x) = x --- | Parser for known schemas. Fails on unknown schemas (E.g. CustomSchema escape hatch doesn't work) +-- TODO: (akshay)Make everything Text, ByteStrings are unnecessary here +-- | Parser for schemas -- -- NOTE: according to the spec, this parser needs to be case insensitive, but -- that is literally insane. Won't implement. -pSchema :: Parser Schema -pSchema = - (User20 - <$ "urn:ietf:params:scim:schemas:core:2.0:User" <|> - ServiceProviderConfig20 - <$ "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig" <|> - Group20 - <$ "urn:ietf:params:scim:schemas:core:2.0:Group" <|> - Schema20 - <$ "urn:ietf:params:scim:schemas:core:2.0:Schema" <|> - ResourceType20 - <$ "urn:ietf:params:scim:schemas:core:2.0:ResourceType" <|> - ListResponse20 - <$ "urn:ietf:params:scim:api:messages:2.0:ListResponse" <|> - Error20 - <$ "urn:ietf:params:scim:api:messages:2.0:Error" <|> - PatchOp20 - <$ "urn:ietf:params:scim:api:messages:2.0:PatchOp") "unknown schema" +pSchema :: [Schema] -> Parser Schema +pSchema supportedSchemas = + Parser.choice + $ map (\s -> fromSchemaUri . decodeUtf8 <$> Parser.string (encodeUtf8 $ getSchemaUri s)) supportedSchemas -- | Get a schema by its URI. -- --- NOTE: cas sensitive against the spec. Same as 'pSchema'. --- --- FUTUREWORK: implement this in terms of 'pSchema': parse all the non-custom schemas with --- 'pSchema; in case of error, use the parser *input* as the custom schema. +-- NOTE: case sensitive against the spec. Same as 'pSchema'. -- -- TODO(arianvp): probably too lenient. want to only accept valid URNs -- This means the CustomSchema part might go... We need to kind of diff --git a/src/Web/Scim/Schema/User.hs b/src/Web/Scim/Schema/User.hs index 2e7fd02dafd..b36130b1402 100644 --- a/src/Web/Scim/Schema/User.hs +++ b/src/Web/Scim/Schema/User.hs @@ -45,7 +45,16 @@ -- names -- e.g. both @USERNAME@ and @userName@ are accepted. -- This is described by the spec https://tools.ietf.org/html/rfc7643#section-2.1 -- -module Web.Scim.Schema.User where +module Web.Scim.Schema.User + ( User(..) + , empty + , NoUserExtra(..) + , applyPatch + , resultToScimError + , isUserSchema + , module Web.Scim.Schema.UserTypes + ) +where import Control.Monad (foldM) import Data.Aeson @@ -57,7 +66,7 @@ import Lens.Micro import Web.Scim.AttrName import Web.Scim.Filter (AttrPath(..)) import Web.Scim.Schema.Common -import Web.Scim.Schema.Schema (Schema(..)) +import Web.Scim.Schema.Schema (Schema(..), getSchemaUri) import Web.Scim.Schema.User.Address (Address) import Web.Scim.Schema.User.Certificate (Certificate) import Web.Scim.Schema.User.Email (Email) @@ -67,16 +76,11 @@ import Web.Scim.Schema.User.Phone (Phone) import Web.Scim.Schema.User.Photo (Photo) import Web.Scim.Schema.PatchOp import Web.Scim.Schema.Error +import Web.Scim.Schema.UserTypes import GHC.Generics (Generic) import Control.Monad.Except - --- | Configurable parts of 'User'. -class UserTypes tag where - -- | User ID type. - type UserId tag - -- | Extra data carried with each 'User'. - type UserExtra tag +import qualified Data.Text as Text -- | SCIM user record, parametrized with type-level tag @t@ (see 'UserTypes'). data User tag = User @@ -137,7 +141,7 @@ empty -> User tag empty schemas userName extra = User { schemas = schemas - , userName = userName + , userName = userName , externalId = Nothing , name = Nothing , displayName = Nothing @@ -242,6 +246,9 @@ instance FromJSON NoUserExtra where instance ToJSON NoUserExtra where toJSON _ = object [] +instance Patchable NoUserExtra where + applyOperation a _ = pure a + ---------------------------------------------------------------------------- -- Applying @@ -250,7 +257,12 @@ instance ToJSON NoUserExtra where -- Evenmore, only some hand-picked ones currently. -- We'll have to think how patch is going to work in the presence of extensions. -- Also, we can probably make PatchOp type-safe to some extent (Read arianvp's thesis :)) -applyPatch :: (FromJSON (UserExtra tag), MonadError ScimError m) => User tag -> PatchOp -> m (User tag) +applyPatch :: + ( Patchable (UserExtra tag) + , FromJSON (UserExtra tag) + , MonadError ScimError m + , UserTypes tag + ) => User tag -> PatchOp tag -> m (User tag) applyPatch = (. getOperations) . foldM applyOperation resultToScimError :: (MonadError ScimError m) => Result a -> m a @@ -264,10 +276,16 @@ resultToScimError (Success a) = pure a -- What I understand from the spec: The difference between add an replace is only -- in the fact that replace will not concat multi-values, and behaves differently for complex values too. -- For simple attributes, add and replace are identical. -applyOperation :: forall m tag. (MonadError ScimError m, FromJSON (UserExtra tag)) => User tag -> Operation -> m (User tag) -applyOperation user (Operation Add path value) = applyOperation user (Operation Replace path value) - -applyOperation user (Operation Replace (Just (NormalPath (AttrPath _schema attr _subAttr))) (Just value)) = do +applyUserOperation + :: forall m tag.( UserTypes tag + , FromJSON (User tag) + , Patchable (UserExtra tag) + , MonadError ScimError m) + => User tag + -> Operation + -> m (User tag) +applyUserOperation user (Operation Add path value) = applyUserOperation user (Operation Replace path value) +applyUserOperation user (Operation Replace (Just (NormalPath (AttrPath _schema attr _subAttr))) (Just value)) = case attr of "username" -> (\x -> user { userName = x }) <$> resultToScimError (fromJSON value) @@ -276,9 +294,10 @@ applyOperation user (Operation Replace (Just (NormalPath (AttrPath _schema attr "externalid" -> (\x -> user { externalId = x }) <$> resultToScimError (fromJSON value) _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid")) -applyOperation _ (Operation Replace (Just (IntoValuePath _ _)) _) = do + +applyUserOperation _ (Operation Replace (Just (IntoValuePath _ _)) _) = do throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet")) -applyOperation user (Operation Replace Nothing (Just value)) = do +applyUserOperation user (Operation Replace Nothing (Just value)) = do case value of Object hm | null ((AttrName <$> HM.keys hm) \\ ["username", "displayname", "externalid"]) -> pure () _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid")) @@ -288,23 +307,29 @@ applyOperation user (Operation Replace Nothing (Just value)) = do , displayName = displayName u , externalId = externalId u } -applyOperation _ (Operation Replace _ Nothing) = +applyUserOperation _ (Operation Replace _ Nothing) = throwError (badRequest InvalidValue (Just "No value was provided")) -applyOperation _ (Operation Remove Nothing _) = throwError (badRequest NoTarget Nothing) -applyOperation user (Operation Remove (Just (NormalPath (AttrPath _schema attr _subAttr))) _value) = +applyUserOperation _ (Operation Remove Nothing _) = throwError (badRequest NoTarget Nothing) +applyUserOperation user (Operation Remove (Just (NormalPath (AttrPath _schema attr _subAttr))) _value) = case attr of "username" -> throwError (badRequest Mutability Nothing) "displayname" -> pure $ user { displayName = Nothing } "externalid" -> pure $ user { externalId = Nothing } _ -> pure user -applyOperation _ (Operation Remove (Just (IntoValuePath _ _)) _) = do +applyUserOperation _ (Operation Remove (Just (IntoValuePath _ _)) _) = do throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet")) +instance (UserTypes tag, FromJSON (User tag), Patchable (UserExtra tag)) => Patchable (User tag) where + applyOperation user op@(Operation _ (Just (NormalPath (AttrPath schema _ _))) _) + | isUserSchema schema = applyUserOperation user op + | isSupportedCustomSchema schema = (\x -> user { extra = x }) <$> applyOperation (extra user) op + | otherwise = + throwError $ badRequest InvalidPath $ Just $ "we only support these schemas: " <> (Text.intercalate ", " $ map getSchemaUri $ supportedSchemas @tag) + where isSupportedCustomSchema = maybe False (`elem` supportedSchemas @tag) + applyOperation user op = applyUserOperation user op -- Omission of a schema for users is implicitly the core schema -- TODO(arianvp): Link to part of the spec that claims this. isUserSchema :: Maybe Schema -> Bool -isUserSchema Nothing = True -isUserSchema (Just User20) = True -isUserSchema (Just _) = False +isUserSchema = maybe True (== User20) diff --git a/src/Web/Scim/Schema/UserTypes.hs b/src/Web/Scim/Schema/UserTypes.hs new file mode 100644 index 00000000000..a1ecb93f6c2 --- /dev/null +++ b/src/Web/Scim/Schema/UserTypes.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +module Web.Scim.Schema.UserTypes where + +import Web.Scim.Schema.Schema (Schema) + +-- | Configurable parts of 'User'. +class UserTypes tag where + -- | User ID type. + type UserId tag + -- | Extra data carried with each 'User'. + type UserExtra tag + -- | Schemas supported by the 'User' for filtering and patching. + -- + -- This must include User20, this is not checked. + supportedSchemas :: [Schema] diff --git a/src/Web/Scim/Server/Mock.hs b/src/Web/Scim/Server/Mock.hs index 00e0e242ee1..3f455d9cd42 100644 --- a/src/Web/Scim/Server/Mock.hs +++ b/src/Web/Scim/Server/Mock.hs @@ -29,6 +29,7 @@ import Web.Scim.Schema.Error import Web.Scim.Schema.Meta import Web.Scim.Schema.ListResponse import Web.Scim.Schema.ResourceType +import Web.Scim.Schema.Schema (Schema(User20)) import Web.Scim.Schema.Common (WithId(WithId, value)) import qualified Web.Scim.Schema.Common as Common import Web.Scim.Handler @@ -73,6 +74,7 @@ hoistSTM = hoist liftSTM instance UserTypes Mock where type UserId Mock = Id type UserExtra Mock = NoUserExtra + supportedSchemas = [User20] instance UserDB Mock TestServer where getUsers () mbFilter = do @@ -218,4 +220,3 @@ filterUser (FilterAttrCompare (AttrPath schema' attrib subAttr) op val) user (_, _) -> Left "Only search on usernames is currently supported" | otherwise = Left "Invalid schema. Only user schema is supported" - diff --git a/src/Web/Scim/Test/Util.hs b/src/Web/Scim/Test/Util.hs index ed2e0c6ad98..29a9911b814 100644 --- a/src/Web/Scim/Test/Util.hs +++ b/src/Web/Scim/Test/Util.hs @@ -32,6 +32,7 @@ import qualified Data.HashMap.Strict as SMap import Web.Scim.Schema.User (UserTypes (..)) import Web.Scim.Class.Group (GroupTypes (..)) import Web.Scim.Class.Auth (AuthTypes (..)) +import Web.Scim.Schema.Schema (Schema (User20, CustomSchema)) ---------------------------------------------------------------------------- -- Redefine wai test helpers to include scim+json content type @@ -138,6 +139,7 @@ data TestTag id authData authInfo userExtra instance UserTypes (TestTag id authData authInfo userExtra) where type UserId (TestTag id authData authInfo userExtra) = id type UserExtra (TestTag id authData authInfo userExtra) = userExtra + supportedSchemas = [User20, CustomSchema "urn:hscim:test"] instance GroupTypes (TestTag id authData authInfo userExtra) where type GroupId (TestTag id authData authInfo userExtra) = id diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index 4e897e70a53..99f80903f19 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -175,8 +175,8 @@ spec = beforeAll app $ do "value": 5 }]}|] `shouldRespondWith` 400 get "/0" `shouldRespondWith` smallUserGet { matchStatus = 200 } - - + + describe "Replace" $ do -- TODO(arianvp): Implement and test multi-value fields properly it "adds all fields if no target" $ do @@ -276,7 +276,7 @@ spec = beforeAll app $ do }]}|] `shouldRespondWith` 400 get "/0" `shouldRespondWith` smallUserGet { matchStatus = 200 } - describe "Remove" $ do + describe "Remove" $ do it "fails if no target" $ do _ <- put "/0" barbUpdate0 -- reset patch "/0" [scim|{ diff --git a/test/Test/FilterSpec.hs b/test/Test/FilterSpec.hs index 00ecd080cb0..88fe83ccae2 100644 --- a/test/Test/FilterSpec.hs +++ b/test/Test/FilterSpec.hs @@ -1,34 +1,37 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Test.FilterSpec where import Web.Scim.Filter import Web.Scim.AttrName import Web.Scim.Schema.Schema (Schema(..)) +import Web.Scim.Schema.UserTypes (UserTypes(supportedSchemas)) +import Web.Scim.Schema.User (NoUserExtra) +import Web.Scim.Test.Util (TestTag) import Test.Hspec import HaskellWorks.Hspec.Hedgehog import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Data.Text (cons) +import Data.Text (cons, Text) - -prop_roundtrip :: Property +prop_roundtrip :: forall tag.UserTypes tag => Property prop_roundtrip = property $ do - x <- forAll genFilter - tripping x renderFilter parseFilter + x <- forAll $ genFilter @tag + tripping x renderFilter (parseFilter $ supportedSchemas @tag) spec :: Spec spec = do describe "Filter" $ do - it "parse . render === id" $ require $ prop_roundtrip + it "parse . render === id" $ require $ prop_roundtrip @(TestTag Text () () NoUserExtra) ---------------------------------------------------------------------------- -- Generators -genValuePath :: Gen ValuePath -genValuePath = ValuePath <$> genAttrPath <*> genFilter +genValuePath :: forall tag.UserTypes tag => Gen ValuePath +genValuePath = ValuePath <$> genAttrPath @tag <*> genFilter @tag genCompValue :: Gen CompValue genCompValue = Gen.choice @@ -52,16 +55,16 @@ genSubAttr = SubAttr <$> genAttrName -- FUTUREWORK: we also may want to factor a bounded enum type out of the 'Schema' type for -- this: @data Schema = Buitin BuitinSchema | Custom Text; data BuiltinSchema = ... deriving -- (Bounded, Enum, ...)@ -genSchema :: Gen Schema -genSchema = Gen.element [ServiceProviderConfig20, Group20, Schema20, ResourceType20, ListResponse20, Error20, PatchOp20] +genSchema :: forall tag.UserTypes tag => Gen Schema +genSchema = Gen.element $ supportedSchemas @tag -genAttrPath :: Gen AttrPath -genAttrPath = AttrPath <$> Gen.maybe genSchema <*> genAttrName <*> Gen.maybe genSubAttr +genAttrPath :: forall tag.UserTypes tag => Gen AttrPath +genAttrPath = AttrPath <$> Gen.maybe (genSchema @tag) <*> genAttrName <*> Gen.maybe genSubAttr genAttrName :: Gen AttrName genAttrName = AttrName <$> (cons <$> Gen.alpha <*> Gen.text (Range.constant 0 50) (Gen.choice [Gen.alphaNum, Gen.constant '-', Gen.constant '_'])) -genFilter :: Gen Filter +genFilter :: forall tag.UserTypes tag => Gen Filter genFilter = Gen.choice - [ FilterAttrCompare <$> genAttrPath <*> genCompareOp <*> genCompValue + [ FilterAttrCompare <$> (genAttrPath @tag) <*> genCompareOp <*> genCompValue ] diff --git a/test/Test/Schema/PatchOpSpec.hs b/test/Test/Schema/PatchOpSpec.hs index 07c3f2992e7..d8095d49f95 100644 --- a/test/Test/Schema/PatchOpSpec.hs +++ b/test/Test/Schema/PatchOpSpec.hs @@ -1,10 +1,20 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Test.Schema.PatchOpSpec where import Data.Foldable (for_) -import Test.Hspec (Spec, describe, xit, it, shouldSatisfy, shouldBe) +import Test.Hspec (Spec, describe, it, xit, shouldSatisfy, shouldBe) +import Data.Text (Text) import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Web.Scim.Test.Util (scim) +import Data.Either (isLeft) +import Web.Scim.Test.Util (scim, TestTag) import Web.Scim.Schema.PatchOp +import Web.Scim.Schema.User (UserTypes) +import Web.Scim.Schema.UserTypes (supportedSchemas) +import Web.Scim.Schema.Schema (Schema(User20)) +import Web.Scim.AttrName (AttrName(..)) +import Web.Scim.Filter (AttrPath(..), Filter(..), ValuePath(..), CompareOp(OpEq), CompValue(ValNull)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson import Data.Aeson.Types (toJSON, fromJSON, Result(Success, Error), Value(String)) import Data.Attoparsec.ByteString (parseOnly) import HaskellWorks.Hspec.Hedgehog (require) @@ -12,59 +22,92 @@ import Hedgehog (Gen, tripping, forAll, Property, property) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Test.FilterSpec (genValuePath, genAttrPath, genSubAttr) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM isSuccess :: Result a -> Bool isSuccess (Success _) = True isSuccess (Error _) = False -genPatchOp :: Gen Value -> Gen PatchOp -genPatchOp genValue = PatchOp <$> Gen.list (Range.constant 0 20) (genOperation genValue) +genPatchOp :: forall tag.UserTypes tag => Gen Value -> Gen (PatchOp tag) +genPatchOp genValue = PatchOp <$> Gen.list (Range.constant 0 20) ((genOperation @tag) genValue) -genOperation :: Gen Value -> Gen Operation -genOperation genValue = Operation <$> Gen.enumBounded <*> Gen.maybe genPath <*> Gen.maybe genValue +genOperation :: forall tag.UserTypes tag => Gen Value -> Gen Operation +genOperation genValue = Operation <$> Gen.enumBounded <*> Gen.maybe (genPath @tag) <*> Gen.maybe genValue -genPath :: Gen Path +genPath :: forall tag.UserTypes tag => Gen Path genPath = Gen.choice - [ IntoValuePath <$> genValuePath <*> Gen.maybe genSubAttr - , NormalPath <$> genAttrPath + [ IntoValuePath <$> (genValuePath @tag) <*> Gen.maybe genSubAttr + , NormalPath <$> (genAttrPath @tag) ] -prop_roundtrip :: Property +prop_roundtrip :: forall tag.UserTypes tag => Property prop_roundtrip = property $ do - x <- forAll genPath - tripping x (encodeUtf8 . rPath) (parseOnly pPath) + x <- forAll $ genPath @tag + tripping x (encodeUtf8 . rPath) (parseOnly $ pPath $ supportedSchemas @tag) -prop_roundtrip_PatchOp :: Property +prop_roundtrip_PatchOp :: forall tag.UserTypes tag => Property prop_roundtrip_PatchOp = property $ do -- Just some strings for now. However, should be constrained to what the -- PatchOp is operating on in the future... We need better typed PatchOp for -- this. TODO(arianvp) - x <- forAll (genPatchOp (String <$> Gen.text (Range.constant 0 20) Gen.unicode)) + x <- forAll (genPatchOp @tag (String <$> Gen.text (Range.constant 0 20) Gen.unicode)) tripping x toJSON fromJSON - + +type PatchTestTag = TestTag () () () () + spec :: Spec spec = do + describe "Patchable" $ do + describe "HashMap Text Text" $ do + it "supports `Add` operation" $ do + let theMap :: HashMap Text Text = HM.empty + operation = Operation Add (Just $ NormalPath (AttrPath Nothing (AttrName "key") Nothing)) $ Just "value" + applyOperation theMap operation `shouldBe` (Right $ HM.singleton "key" "value") + + it "supports `Replace` operation" $ do + let theMap :: HashMap Text Text = HM.singleton "key" "value1" + operation = Operation Replace (Just $ NormalPath (AttrPath Nothing (AttrName "key") Nothing)) $ Just "value2" + applyOperation theMap operation `shouldBe` (Right $ HM.singleton "key" "value2") + + it "supports `Delete` operation" $ do + let theMap :: HashMap Text Text = HM.fromList [("key1", "value1"), ("key2", "value2")] + operation = Operation Remove (Just $ NormalPath (AttrPath Nothing (AttrName "key1") Nothing)) Nothing + applyOperation theMap operation `shouldBe` (Right $ HM.singleton "key2" "value2") + + it "gracefully rejects invalid/unsupported operations" $ do + let theMap :: HashMap Text Text = HM.fromList [("key1", "value1"), ("key2", "value2")] + key1Path = (AttrPath Nothing (AttrName "key1") Nothing) + key2Path = (AttrPath Nothing (AttrName "key2") Nothing) + invalidOperations = + [ Operation Add (Just $ NormalPath key1Path) Nothing -- Nothing to add + , Operation Replace (Just $ NormalPath key1Path) Nothing -- Nothing to replace + , Operation Add (Just $ IntoValuePath (ValuePath key1Path (FilterAttrCompare key2Path OpEq ValNull)) Nothing) Nothing + -- IntoValuePaths don't make sense for HashMap Text Text + ] + mapM_ (\o -> applyOperation theMap o `shouldSatisfy` isLeft) invalidOperations + describe "urn:ietf:params:scim:api:messages:2.0:PatchOp" $ do describe "The body of each request MUST contain the \"schemas\" attribute with the URI value of \"urn:ietf:params:scim:api:messages:2.0:PatchOp\"." $ do it "rejects an empty schemas list" $ do - fromJSON @PatchOp [scim| { + fromJSON @(PatchOp PatchTestTag) [scim| { "schemas": [], "operations": [] }|] `shouldSatisfy` (not . isSuccess) --TODO(arianvp): We don't support arbitrary path names (yet) - it "roundtrips Path" $ require prop_roundtrip - it "roundtrips PatchOp" $ require prop_roundtrip_PatchOp + it "roundtrips Path" $ require $ prop_roundtrip @PatchTestTag + it "roundtrips PatchOp" $ require $ prop_roundtrip_PatchOp @PatchTestTag it "rejects invalid operations" $ do - fromJSON @PatchOp [scim| { + fromJSON @(PatchOp PatchTestTag) [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "operations": [{"op":"unknown"}] }|] `shouldSatisfy` (not . isSuccess) - -- TODO(arianvp): Only makes sense if we have a Patch type _specifically_ for User + -- TODO(arianvp/akshay): Implement if required xit "rejects unknown paths" $ do - fromJSON @Path "unknown.field" `shouldSatisfy` (not . isSuccess) + Aeson.parse (pathFromJSON [User20]) (Aeson.String "unknown.field") `shouldSatisfy` (not . isSuccess) it "rejects invalid paths" $ do - fromJSON @Path "unknown]field" `shouldSatisfy` (not . isSuccess) + Aeson.parse (pathFromJSON [User20]) "unknown]field" `shouldSatisfy` (not . isSuccess) describe "Examples from https://tools.ietf.org/html/rfc7644#section-3.5.2 Figure 8" $ do let examples = @@ -74,6 +117,4 @@ spec = do , "members[value eq \"2819c223-7f76-453a-919d-413861904646\"]" , "members[value eq \"2819c223-7f76-453a-919d-413861904646\"].displayname" ] - for_ examples $ \p -> it ("parses " ++ show p) $ (rPath <$> parseOnly pPath p) `shouldBe` Right (decodeUtf8 p) - - + for_ examples $ \p -> it ("parses " ++ show p) $ (rPath <$> parseOnly (pPath $ supportedSchemas @PatchTestTag) p) `shouldBe` Right (decodeUtf8 p) diff --git a/test/Test/Schema/UserSpec.hs b/test/Test/Schema/UserSpec.hs index c9dabd0998a..4651a3890d5 100644 --- a/test/Test/Schema/UserSpec.hs +++ b/test/Test/Schema/UserSpec.hs @@ -1,4 +1,3 @@ -{- LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ViewPatterns #-} @@ -9,7 +8,10 @@ import Web.Scim.Test.Util import Web.Scim.Schema.Common (URI(..)) import Web.Scim.Schema.Schema (Schema(..)) -import Web.Scim.Schema.User +import Web.Scim.Schema.User (User(..), NoUserExtra(..)) +import qualified Web.Scim.Schema.User as User +import Web.Scim.Schema.PatchOp (PatchOp(..), Op(..), Operation(..), Patchable(..)) +import qualified Web.Scim.Schema.PatchOp as PatchOp import Web.Scim.Schema.User.Address as Address import Web.Scim.Schema.User.Certificate as Certificate import Web.Scim.Schema.User.Email as Email @@ -34,8 +36,6 @@ prop_roundtrip = property $ do user <- forAll genUser tripping user toJSON fromJSON - - -- TODO(arianvp): Note that this only tests the top-level fields. -- extrac this to a generic test and also do this for sub-properties prop_caseInsensitive :: Property @@ -48,9 +48,22 @@ prop_caseInsensitive = property $ do fromJSON (Object user'') === Success user fromJSON (Object user''') === Success user +type PatchTag = TestTag Text () () UserExtraPatch + +type UserExtraPatch = HM.HashMap Text Text spec :: Spec spec = do + describe "applyPatch" $ do + it "applies patch to `extra`" $ do + let schemas' = [] + let extras = HM.empty + let user :: User PatchTag = User.empty schemas' "hello" extras + let Right programmingLanguagePath = PatchOp.parsePath (User.supportedSchemas @PatchTag) "urn:hscim:test:programmingLanguage" + let operation = Operation Replace (Just programmingLanguagePath) (Just (toJSON @Text "haskell")) + let patchOp = PatchOp [ operation ] + User.extra <$> (User.applyPatch user patchOp) `shouldBe` Right (HM.singleton "programmingLanguage" "haskell") + describe "JSON serialization" $ do it "handles all fields" $ do require prop_roundtrip @@ -276,7 +289,7 @@ completeUserJson = [scim| -- | A 'User' with all attributes empty (if possible). minimalUser :: User (TestTag Text () () NoUserExtra) -minimalUser = empty [User20] "sample userName" NoUserExtra +minimalUser = User.empty [User20] "sample userName" NoUserExtra -- | Reference encoding of 'minimalUser'. minimalUserJson :: Value @@ -355,10 +368,14 @@ instance ToJSON UserExtraTest where toJSON (UserExtraObject t) = object ["urn:hscim:test" .= object ["test" .= t]] + +instance Patchable UserExtraTest where + applyOperation _ _ = undefined + -- | A 'User' with extra fields present. extendedUser :: UserExtraTest -> User (TestTag Text () () UserExtraTest) extendedUser e = - (empty [User20, CustomSchema "urn:hscim:test"] "sample userName" e) + (User.empty [User20, CustomSchema "urn:hscim:test"] "sample userName" e) -- | Encoding of @extendedUser UserExtraEmpty@. extendedUserEmptyJson :: Value From e8835fc537cc30977d51e6c6e14fa0af2fbd606a Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 27 Jan 2020 10:48:56 +0100 Subject: [PATCH 30/64] Fix TODO for consistency Co-Authored-By: fisx --- src/Web/Scim/Schema/Schema.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Web/Scim/Schema/Schema.hs b/src/Web/Scim/Schema/Schema.hs index ca972583afa..6e197e28b75 100644 --- a/src/Web/Scim/Schema/Schema.hs +++ b/src/Web/Scim/Schema/Schema.hs @@ -51,7 +51,7 @@ getSchemaUri PatchOp20 = getSchemaUri (CustomSchema x) = x --- TODO: (akshay)Make everything Text, ByteStrings are unnecessary here +-- TODO(akshay): Make everything Text, ByteStrings are unnecessary here -- | Parser for schemas -- -- NOTE: according to the spec, this parser needs to be case insensitive, but From 3800b151d27a295702bf21afd290d72381c3d82e Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 27 Jan 2020 12:17:16 +0100 Subject: [PATCH 31/64] Throw error when patch is applied on NoUserExtra --- src/Web/Scim/Schema/User.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Web/Scim/Schema/User.hs b/src/Web/Scim/Schema/User.hs index b36130b1402..9a139fc50a6 100644 --- a/src/Web/Scim/Schema/User.hs +++ b/src/Web/Scim/Schema/User.hs @@ -247,7 +247,7 @@ instance ToJSON NoUserExtra where toJSON _ = object [] instance Patchable NoUserExtra where - applyOperation a _ = pure a + applyOperation _ _ = throwError $ badRequest InvalidValue (Just "there are no user extra attributes to patch") ---------------------------------------------------------------------------- -- Applying From da16cf9581979c1f180f412dd7b9eed983a43e5d Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 27 Jan 2020 12:22:08 +0100 Subject: [PATCH 32/64] Use parens for clarity Co-Authored-By: fisx --- src/Web/Scim/Schema/PatchOp.hs | 2 +- src/Web/Scim/Schema/User.hs | 2 +- test/Test/FilterSpec.hs | 4 ++-- test/Test/Schema/PatchOpSpec.hs | 4 ++-- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Web/Scim/Schema/PatchOp.hs b/src/Web/Scim/Schema/PatchOp.hs index fdbf7393700..c7ec56ba82c 100644 --- a/src/Web/Scim/Schema/PatchOp.hs +++ b/src/Web/Scim/Schema/PatchOp.hs @@ -72,7 +72,7 @@ instance UserTypes tag => FromJSON (PatchOp tag) where let o = HashMap.fromList . map (first toLower) . HashMap.toList $ v schemas' :: [Schema] <- o .: "schemas" guard $ PatchOp20 `elem` schemas' - operations <- Aeson.explicitParseField (Aeson.listParser $ operationFromJSON $ supportedSchemas @tag) o "operations" + operations <- Aeson.explicitParseField (Aeson.listParser $ operationFromJSON (supportedSchemas @tag)) o "operations" pure $ PatchOp operations instance ToJSON (PatchOp tag) where diff --git a/src/Web/Scim/Schema/User.hs b/src/Web/Scim/Schema/User.hs index 9a139fc50a6..f187805d94e 100644 --- a/src/Web/Scim/Schema/User.hs +++ b/src/Web/Scim/Schema/User.hs @@ -325,7 +325,7 @@ instance (UserTypes tag, FromJSON (User tag), Patchable (UserExtra tag)) => Patc | isUserSchema schema = applyUserOperation user op | isSupportedCustomSchema schema = (\x -> user { extra = x }) <$> applyOperation (extra user) op | otherwise = - throwError $ badRequest InvalidPath $ Just $ "we only support these schemas: " <> (Text.intercalate ", " $ map getSchemaUri $ supportedSchemas @tag) + throwError $ badRequest InvalidPath $ Just $ "we only support these schemas: " <> (Text.intercalate ", " $ map getSchemaUri (supportedSchemas @tag)) where isSupportedCustomSchema = maybe False (`elem` supportedSchemas @tag) applyOperation user op = applyUserOperation user op diff --git a/test/Test/FilterSpec.hs b/test/Test/FilterSpec.hs index 88fe83ccae2..1dfde6b42fd 100644 --- a/test/Test/FilterSpec.hs +++ b/test/Test/FilterSpec.hs @@ -20,7 +20,7 @@ import Data.Text (cons, Text) prop_roundtrip :: forall tag.UserTypes tag => Property prop_roundtrip = property $ do x <- forAll $ genFilter @tag - tripping x renderFilter (parseFilter $ supportedSchemas @tag) + tripping x renderFilter $ parseFilter (supportedSchemas @tag) spec :: Spec spec = do @@ -56,7 +56,7 @@ genSubAttr = SubAttr <$> genAttrName -- this: @data Schema = Buitin BuitinSchema | Custom Text; data BuiltinSchema = ... deriving -- (Bounded, Enum, ...)@ genSchema :: forall tag.UserTypes tag => Gen Schema -genSchema = Gen.element $ supportedSchemas @tag +genSchema = Gen.element (supportedSchemas @tag) genAttrPath :: forall tag.UserTypes tag => Gen AttrPath genAttrPath = AttrPath <$> Gen.maybe (genSchema @tag) <*> genAttrName <*> Gen.maybe genSubAttr diff --git a/test/Test/Schema/PatchOpSpec.hs b/test/Test/Schema/PatchOpSpec.hs index d8095d49f95..3aae204a9d1 100644 --- a/test/Test/Schema/PatchOpSpec.hs +++ b/test/Test/Schema/PatchOpSpec.hs @@ -44,7 +44,7 @@ genPath = Gen.choice prop_roundtrip :: forall tag.UserTypes tag => Property prop_roundtrip = property $ do x <- forAll $ genPath @tag - tripping x (encodeUtf8 . rPath) (parseOnly $ pPath $ supportedSchemas @tag) + tripping x (encodeUtf8 . rPath) (parseOnly $ pPath (supportedSchemas @tag)) prop_roundtrip_PatchOp :: forall tag.UserTypes tag => Property prop_roundtrip_PatchOp = property $ do @@ -117,4 +117,4 @@ spec = do , "members[value eq \"2819c223-7f76-453a-919d-413861904646\"]" , "members[value eq \"2819c223-7f76-453a-919d-413861904646\"].displayname" ] - for_ examples $ \p -> it ("parses " ++ show p) $ (rPath <$> parseOnly (pPath $ supportedSchemas @PatchTestTag) p) `shouldBe` Right (decodeUtf8 p) + for_ examples $ \p -> it ("parses " ++ show p) $ (rPath <$> parseOnly (pPath (supportedSchemas @PatchTestTag)) p) `shouldBe` Right (decodeUtf8 p) From b11744cba7f7604d817b16b2aaa6dacb478ffbe8 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 28 Jan 2020 12:30:51 +0100 Subject: [PATCH 33/64] Revert "Build hscim with LTS 14.12 (#40)" This reverts commit 5b40fba3665c1e8b69fad569cfb9e0634ecbffc8. --- .gitignore | 3 +- .travis.yml | 7 ++- package.yaml | 103 ++++++++++++++++++++-------------- server/Main.hs | 2 +- src/Web/Scim/Schema/Error.hs | 10 ++-- src/Web/Scim/Schema/Schema.hs | 6 +- src/Web/Scim/Server/Mock.hs | 8 +-- stack.yaml | 10 +--- test/Test/Class/AuthSpec.hs | 2 +- 9 files changed, 86 insertions(+), 65 deletions(-) diff --git a/.gitignore b/.gitignore index 691684e8295..c04fa9f5d2b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ dist dist-* cabal-dev +*.cabal *.o *.hi *.chi @@ -20,8 +21,8 @@ cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* -.stac-work-tmp/ *~ *.el \#* +hscim.cabal diff --git a/.travis.yml b/.travis.yml index 9e17a079b4b..1cfd3d37254 100644 --- a/.travis.yml +++ b/.travis.yml @@ -12,16 +12,19 @@ addons: packages: - libgmp-dev +env: +- RESOLVER=lts-12.10 + before_install: - mkdir -p ~/.local/bin - export PATH=$HOME/.local/bin:$PATH - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' install: -- stack --no-terminal --install-ghc test --fast --only-dependencies +- stack --resolver=$RESOLVER --no-terminal --install-ghc test --fast --only-dependencies script: -- stack --no-terminal test --fast --haddock --no-haddock-deps +- stack --resolver=$RESOLVER --no-terminal test --fast --haddock --no-haddock-deps notifications: # see https://docs.travis-ci.com/user/notifications email: false diff --git a/package.yaml b/package.yaml index 6ce8e8b5a33..5c8370e9460 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: hscim -version: 0.3.0 +version: 0.2 synopsis: ... description: ... homepage: https://github.com/wireapp/hscim/README.md @@ -33,45 +33,45 @@ default-extensions: extra-source-files: - README.md - dependencies: - - aeson >= 1.4.5 && < 1.5 - - attoparsec >= 0.13.2 && < 0.14 - - bytestring >= 0.10.8 && < 0.11 - - base >= 4.12 && < 4.13 - - scientific >= 0.3.6 && < 0.4 - - hashable >= 1.2.7 && < 1.4 - - text >= 1.2.3 && < 1.3 - - time >= 1.8.0 && < 1.9 - - template-haskell >= 2.14.0 && < 2.15 - - unordered-containers >= 0.2.10 && < 0.3 - - vector >= 0.12.0 && < 0.13 - - aeson-qq >= 0.8.2 && < 0.9 - - mtl >= 2.2.2 && < 2.3 - - email-validate >= 2.3.2 && < 2.4 - - errors >= 2.3.0 && < 2.4 - - stm >= 2.5.0 && < 2.6 - - hedgehog >= 1.0.1 && < 1.1 - - mmorph >= 1.1.3 && < 1.2 - - hspec >= 2.7.1 && < 2.8 - - hspec-wai >= 0.9.2 && < 0.10 - - hspec-expectations >= 0.8.2 && < 0.9 - - http-types >= 0.12.3 && < 0.13 - - wai >= 3.2.2 && < 3.3 - - wai-extra >= 3.0.28 && < 3.1 - - wai-logger >= 2.3.5 && < 2.4 - - http-api-data >= 0.4.1 && < 0.5 - - http-media >= 0.8.0 && < 0.9 - - hw-hspec-hedgehog >= 0.1.0 && < 0.2 - - list-t >= 1.0.4 && < 1.1 - - microlens >= 0.4.10 && < 0.5 - - network-uri >= 2.6.1 && < 2.7 - - network-uri-static >= 0.1.2 && < 0.2 - - servant >= 0.16.2 && < 0.17 - - servant-server >= 0.16.2 && < 0.17 - - warp >= 3.2.28 && < 3.4 - - stm-containers >= 1.1.0 && < 1.2 - - uuid >= 1.3.13 && < 1.4 + - aeson + - aeson-qq + - attoparsec + - base >= 4.11 && < 5 + - bytestring + - email-validate + - errors + - hashable + - hedgehog + - hspec + - hspec-expectations + - hspec-wai + - http-api-data + - http-media + - http-types + - hw-hspec-hedgehog + - list-t + - microlens + - mmorph + - mtl + - network-uri + - network-uri-static >= 0.1.1.0 + - scientific + - servant + - servant-server + - servant-server >= 0.14.1 + - stm + - stm-containers + - template-haskell + - text + - time + - unordered-containers + - uuid + - vector + - wai + - wai-extra + - wai-logger + - warp ghc-options: -Wall -Werror @@ -85,6 +85,7 @@ executables: source-dirs: server dependencies: - hscim + - warp tests: spec: @@ -92,7 +93,27 @@ tests: ghc-options: -threaded -rtsopts -with-rtsopts=-N source-dirs: - test - build-tools: - - hspec-discover:hspec-discover dependencies: - hscim + - aeson + - aeson-qq + - base + - bytestring + - containers + - hedgehog + - hspec + - hspec-discover + - hspec-expectations + - hspec-wai + - http-types + - hw-hspec-hedgehog + - mtl + - servant-server + - stm-containers + - template-haskell + - text + - time + - vector + - wai-extra + - wai-logger + - warp diff --git a/server/Main.hs b/server/Main.hs index 5ef890f2a45..2bd9598b894 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -16,7 +16,7 @@ import Web.Scim.Capabilities.MetaSchema as MetaSchema import Data.Time import Network.Wai.Handler.Warp import Network.URI.Static -import qualified StmContainers.Map as STMMap +import qualified STMContainers.Map as STMMap import Control.Monad.STM (atomically) import Text.Email.Validate diff --git a/src/Web/Scim/Schema/Error.hs b/src/Web/Scim/Schema/Error.hs index 6e5b198b163..151a7d8e308 100644 --- a/src/Web/Scim/Schema/Error.hs +++ b/src/Web/Scim/Schema/Error.hs @@ -15,7 +15,7 @@ module Web.Scim.Schema.Error , serverError -- * Servant interoperability - , scimToServerError + , scimToServantErr ) where import Data.Text (Text, pack) @@ -23,7 +23,7 @@ import Data.Aeson hiding (Error) import Control.Exception import Web.Scim.Schema.Common import Web.Scim.Schema.Schema -import Servant (ServerError (..)) +import Servant (ServantErr (..)) import GHC.Generics (Generic) @@ -153,9 +153,9 @@ serverError details = -- | Convert a SCIM 'Error' to a Servant one by encoding it with the -- appropriate headers. -scimToServerError :: ScimError -> ServerError -scimToServerError err = - ServerError +scimToServantErr :: ScimError -> ServantErr +scimToServantErr err = + ServantErr { errHTTPCode = unStatus (status err) , errReasonPhrase = reasonPhrase (status err) , errBody = encode err diff --git a/src/Web/Scim/Schema/Schema.hs b/src/Web/Scim/Schema/Schema.hs index 6e197e28b75..9e67fc98a08 100644 --- a/src/Web/Scim/Schema/Schema.hs +++ b/src/Web/Scim/Schema/Schema.hs @@ -6,11 +6,11 @@ import Web.Scim.Capabilities.MetaSchema.Group import Web.Scim.Capabilities.MetaSchema.Schema import Web.Scim.Capabilities.MetaSchema.ResourceType -import Data.Text (Text) import Data.Aeson (FromJSON, parseJSON, toJSON, ToJSON, withText, Value) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Attoparsec.ByteString (Parser) +import Data.Attoparsec.ByteString (Parser) import qualified Data.Attoparsec.ByteString.Char8 as Parser +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text (Text) -- | All schemas that we support. data Schema = User20 diff --git a/src/Web/Scim/Server/Mock.hs b/src/Web/Scim/Server/Mock.hs index 3f455d9cd42..d944148020a 100644 --- a/src/Web/Scim/Server/Mock.hs +++ b/src/Web/Scim/Server/Mock.hs @@ -21,7 +21,7 @@ import Data.Time.Clock import Data.Time.Calendar import GHC.Exts (sortWith) import ListT -import qualified StmContainers.Map as STMMap +import qualified STMContainers.Map as STMMap import Text.Read (readMaybe) import Web.Scim.Filter (Filter(..), CompValue(..), AttrPath(..), compareStr) import Web.Scim.Schema.User @@ -79,7 +79,7 @@ instance UserTypes Mock where instance UserDB Mock TestServer where getUsers () mbFilter = do m <- userDB <$> ask - users <- liftSTM $ ListT.toList $ STMMap.listT m + users <- liftSTM $ ListT.toList $ STMMap.stream m let check user = case mbFilter of Nothing -> pure True Just filter_ -> do @@ -130,7 +130,7 @@ instance GroupTypes Mock where instance GroupDB Mock TestServer where getGroups () = do m <- groupDB <$> ask - groups <- liftSTM $ ListT.toList $ STMMap.listT m + groups <- liftSTM $ ListT.toList $ STMMap.stream m return $ fromList . sortWith (Common.id . thing) $ snd <$> groups getGroup () gid = do @@ -200,7 +200,7 @@ createMeta rType = Meta nt :: TestStorage -> ScimHandler TestServer a -> Handler a nt storage = flip runReaderT storage . - fromScimHandler (lift . throwError . scimToServerError) + fromScimHandler (lift . throwError . scimToServantErr) -- | Check whether a user satisfies the filter. diff --git a/stack.yaml b/stack.yaml index f65f4f731a0..faddcb4d08c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,15 +1,11 @@ -resolver: lts-14.12 +resolver: lts-12.10 +compiler: ghc-8.4.4 packages: - . extra-deps: -- network-uri-static-0.1.2.1@sha256:7e1ca4358b319ac2db6514d0e0beb073c296789eeef9cebd89cc9517618fbfe8,1724 -- stm-containers-1.1.0.4@sha256:f83a683357b6e3b1dda3e70d2077a37224ed534df1f74c4e11f3f6daa7945c5b,3248 -- stm-hamt-1.2.0.4@sha256:7957497c022554b7599e790696d1a3e56359ad99e5da36a251894c626ca1f60a,3970 -- primitive-0.7.0.0@sha256:ee352d97cc390d8513530029a2213a95c179a66c406906b18d03702c1d9ab8e5,3416 -- primitive-extras-0.8@sha256:fca0310150496867f5b9421fe1541ecda87fae17eae44885a29f9c52dd00c8ff,2963 -- primitive-unlifted-0.1.2.0@sha256:9c3df73af54ed19fb3f4874da19334863cc414b22e578e27b5f52beeac4a60dd,1360 +- network-uri-static-0.1.1.0 nix: packages: diff --git a/test/Test/Class/AuthSpec.hs b/test/Test/Class/AuthSpec.hs index 921311022a3..7805e1fd66d 100644 --- a/test/Test/Class/AuthSpec.hs +++ b/test/Test/Class/AuthSpec.hs @@ -11,7 +11,7 @@ import Test.Hspec import Test.Hspec.Wai hiding (post, put, patch) import Network.HTTP.Types.Header import Network.HTTP.Types.Method (methodGet) -import qualified StmContainers.Map as STMMap +import qualified STMContainers.Map as STMMap testStorage :: IO TestStorage testStorage = TestStorage <$> STMMap.newIO <*> STMMap.newIO From 484e761e31506d4804844bd51a54ef8fd4f00c2f Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 28 Jan 2020 12:37:40 +0100 Subject: [PATCH 34/64] Fixup --- hscim.cabal | 218 ---------------------------------------------------- 1 file changed, 218 deletions(-) delete mode 100644 hscim.cabal diff --git a/hscim.cabal b/hscim.cabal deleted file mode 100644 index 9a861086152..00000000000 --- a/hscim.cabal +++ /dev/null @@ -1,218 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.33.0. --- --- see: https://github.com/sol/hpack --- --- hash: dacbefe6b2a13bf0be7cc0a32b675c371e2afc853228e2feb0e834c908d9aaf6 - -name: hscim -version: 0.3.0 -synopsis: ... -description: ... -category: Web -homepage: https://github.com/wireapp/hscim/README.md -bug-reports: https://github.com/wireapp/hscim/issues -author: Wire Swiss GmbH -maintainer: Wire Swiss GmbH -copyright: (c) 2018 Wire Swiss GmbH -license: AGPL-3 -license-file: LICENSE -build-type: Simple -extra-source-files: - README.md - -source-repository head - type: git - location: https://github.com/wireapp/hscim - -library - exposed-modules: - Web.Scim.AttrName - Web.Scim.Capabilities.MetaSchema - Web.Scim.Capabilities.MetaSchema.Group - Web.Scim.Capabilities.MetaSchema.ResourceType - Web.Scim.Capabilities.MetaSchema.Schema - Web.Scim.Capabilities.MetaSchema.SPConfig - Web.Scim.Capabilities.MetaSchema.User - Web.Scim.Class.Auth - Web.Scim.Class.Group - Web.Scim.Class.User - Web.Scim.ContentType - Web.Scim.Filter - Web.Scim.Handler - Web.Scim.Schema.AuthenticationScheme - Web.Scim.Schema.Common - Web.Scim.Schema.Error - Web.Scim.Schema.ListResponse - Web.Scim.Schema.Meta - Web.Scim.Schema.PatchOp - Web.Scim.Schema.ResourceType - Web.Scim.Schema.Schema - Web.Scim.Schema.User - Web.Scim.Schema.User.Address - Web.Scim.Schema.User.Certificate - Web.Scim.Schema.User.Email - Web.Scim.Schema.User.IM - Web.Scim.Schema.User.Name - Web.Scim.Schema.User.Phone - Web.Scim.Schema.User.Photo - Web.Scim.Schema.UserTypes - Web.Scim.Server - Web.Scim.Server.Mock - Web.Scim.Test.Acceptance - Web.Scim.Test.Util - other-modules: - Paths_hscim - hs-source-dirs: - src - default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances - ghc-options: -Wall -Werror - build-depends: - aeson >=1.4.5 && <1.5 - , aeson-qq >=0.8.2 && <0.9 - , attoparsec >=0.13.2 && <0.14 - , base >=4.12 && <4.13 - , bytestring >=0.10.8 && <0.11 - , email-validate >=2.3.2 && <2.4 - , errors >=2.3.0 && <2.4 - , hashable >=1.2.7 && <1.4 - , hedgehog >=1.0.1 && <1.1 - , hspec >=2.7.1 && <2.8 - , hspec-expectations >=0.8.2 && <0.9 - , hspec-wai >=0.9.2 && <0.10 - , http-api-data >=0.4.1 && <0.5 - , http-media >=0.8.0 && <0.9 - , http-types >=0.12.3 && <0.13 - , hw-hspec-hedgehog >=0.1.0 && <0.2 - , list-t >=1.0.4 && <1.1 - , microlens >=0.4.10 && <0.5 - , mmorph >=1.1.3 && <1.2 - , mtl >=2.2.2 && <2.3 - , network-uri >=2.6.1 && <2.7 - , network-uri-static >=0.1.2 && <0.2 - , scientific >=0.3.6 && <0.4 - , servant >=0.16.2 && <0.17 - , servant-server >=0.16.2 && <0.17 - , stm >=2.5.0 && <2.6 - , stm-containers >=1.1.0 && <1.2 - , template-haskell >=2.14.0 && <2.15 - , text >=1.2.3 && <1.3 - , time >=1.8.0 && <1.9 - , unordered-containers >=0.2.10 && <0.3 - , uuid >=1.3.13 && <1.4 - , vector >=0.12.0 && <0.13 - , wai >=3.2.2 && <3.3 - , wai-extra >=3.0.28 && <3.1 - , wai-logger >=2.3.5 && <2.4 - , warp >=3.2.28 && <3.4 - default-language: Haskell2010 - -executable hscim-server - main-is: Main.hs - other-modules: - Paths_hscim - hs-source-dirs: - server - default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances - ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N - build-depends: - aeson >=1.4.5 && <1.5 - , aeson-qq >=0.8.2 && <0.9 - , attoparsec >=0.13.2 && <0.14 - , base >=4.12 && <4.13 - , bytestring >=0.10.8 && <0.11 - , email-validate >=2.3.2 && <2.4 - , errors >=2.3.0 && <2.4 - , hashable >=1.2.7 && <1.4 - , hedgehog >=1.0.1 && <1.1 - , hscim - , hspec >=2.7.1 && <2.8 - , hspec-expectations >=0.8.2 && <0.9 - , hspec-wai >=0.9.2 && <0.10 - , http-api-data >=0.4.1 && <0.5 - , http-media >=0.8.0 && <0.9 - , http-types >=0.12.3 && <0.13 - , hw-hspec-hedgehog >=0.1.0 && <0.2 - , list-t >=1.0.4 && <1.1 - , microlens >=0.4.10 && <0.5 - , mmorph >=1.1.3 && <1.2 - , mtl >=2.2.2 && <2.3 - , network-uri >=2.6.1 && <2.7 - , network-uri-static >=0.1.2 && <0.2 - , scientific >=0.3.6 && <0.4 - , servant >=0.16.2 && <0.17 - , servant-server >=0.16.2 && <0.17 - , stm >=2.5.0 && <2.6 - , stm-containers >=1.1.0 && <1.2 - , template-haskell >=2.14.0 && <2.15 - , text >=1.2.3 && <1.3 - , time >=1.8.0 && <1.9 - , unordered-containers >=0.2.10 && <0.3 - , uuid >=1.3.13 && <1.4 - , vector >=0.12.0 && <0.13 - , wai >=3.2.2 && <3.3 - , wai-extra >=3.0.28 && <3.1 - , wai-logger >=2.3.5 && <2.4 - , warp >=3.2.28 && <3.4 - default-language: Haskell2010 - -test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Test.AcceptanceSpec - Test.Capabilities.MetaSchemaSpec - Test.Class.AuthSpec - Test.Class.GroupSpec - Test.Class.UserSpec - Test.FilterSpec - Test.Schema.PatchOpSpec - Test.Schema.UserSpec - Paths_hscim - hs-source-dirs: - test - default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances - ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N - build-tool-depends: - hspec-discover:hspec-discover - build-depends: - aeson >=1.4.5 && <1.5 - , aeson-qq >=0.8.2 && <0.9 - , attoparsec >=0.13.2 && <0.14 - , base >=4.12 && <4.13 - , bytestring >=0.10.8 && <0.11 - , email-validate >=2.3.2 && <2.4 - , errors >=2.3.0 && <2.4 - , hashable >=1.2.7 && <1.4 - , hedgehog >=1.0.1 && <1.1 - , hscim - , hspec >=2.7.1 && <2.8 - , hspec-expectations >=0.8.2 && <0.9 - , hspec-wai >=0.9.2 && <0.10 - , http-api-data >=0.4.1 && <0.5 - , http-media >=0.8.0 && <0.9 - , http-types >=0.12.3 && <0.13 - , hw-hspec-hedgehog >=0.1.0 && <0.2 - , list-t >=1.0.4 && <1.1 - , microlens >=0.4.10 && <0.5 - , mmorph >=1.1.3 && <1.2 - , mtl >=2.2.2 && <2.3 - , network-uri >=2.6.1 && <2.7 - , network-uri-static >=0.1.2 && <0.2 - , scientific >=0.3.6 && <0.4 - , servant >=0.16.2 && <0.17 - , servant-server >=0.16.2 && <0.17 - , stm >=2.5.0 && <2.6 - , stm-containers >=1.1.0 && <1.2 - , template-haskell >=2.14.0 && <2.15 - , text >=1.2.3 && <1.3 - , time >=1.8.0 && <1.9 - , unordered-containers >=0.2.10 && <0.3 - , uuid >=1.3.13 && <1.4 - , vector >=0.12.0 && <0.13 - , wai >=3.2.2 && <3.3 - , wai-extra >=3.0.28 && <3.1 - , wai-logger >=2.3.5 && <2.4 - , warp >=3.2.28 && <3.4 - default-language: Haskell2010 From a05ebfd6d569f008ae568eeb6c8d6e20fb688380 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 14 Jan 2020 14:38:56 +0100 Subject: [PATCH 35/64] Whitespace --- src/Web/Scim/Test/Acceptance.hs | 13 +++++-------- src/Web/Scim/Test/Util.hs | 1 - test/Test/AcceptanceSpec.hs | 2 +- 3 files changed, 6 insertions(+), 10 deletions(-) diff --git a/src/Web/Scim/Test/Acceptance.hs b/src/Web/Scim/Test/Acceptance.hs index 5a821b0cc7f..dfcf1fac7e3 100644 --- a/src/Web/Scim/Test/Acceptance.hs +++ b/src/Web/Scim/Test/Acceptance.hs @@ -21,8 +21,8 @@ microsoftAzure app = do it "query by id" $ pending -- TODO(arianvp): Write test it "query by manager" $ pending -- TODO(arianvp): Implement support for enterprise extension it "Supports querying groups by ID and by member, as per section 3.4.2 of the SCIM protocol." $ pending -- TODO(arianvp): Implement groups - it "Accepts a single bearer token for authentication and authorization of Azure AD to your application." $ - -- This is provided by the library + it "Accepts a single bearer token for authentication and authorization of Azure AD to your application." $ + -- This is provided by the library True `shouldBe` True describe "Follow these general guidelines when implementing a SCIM endpoint to ensure compatibility with Azure AD:" $ do @@ -32,10 +32,10 @@ microsoftAzure app = do it "Response to a query/filter request should always be a ListResponse." $ -- NOTE: This is guaranteed by the type-system. No need for a test True `shouldBe` True - it "Groups are optional, but only supported if the SCIM implementation supports PATCH requests." $ + it "Groups are optional, but only supported if the SCIM implementation supports PATCH requests." $ -- TODO(arianvp): Implement groups True `shouldBe` True - it "Don't require a case-sensitive match on structural elements in SCIM, in particular PATCH op operation values, as defined in https://tools.ietf.org/html/rfc7644#section-3.5.2. Azure AD emits the values of 'op' as Add, " $ + it "Don't require a case-sensitive match on structural elements in SCIM, in particular PATCH op operation values, as defined in https://tools.ietf.org/html/rfc7644#section-3.5.2. Azure AD emits the values of 'op' as Add, " $ -- TODO(arianvp): Write test pending describe "Microsoft Azure AD only uses the following operators: eq and" $ do @@ -202,8 +202,5 @@ microsoftAzure app = do it "Delete User" $ do delete' "/Users/0" "" `shouldRespondWith` 204 delete' "/Users/0" "" `shouldRespondWith` 404 - describe "Group operations" $ + describe "Group operations" $ it "is in progress" $ \_-> pending - - - diff --git a/src/Web/Scim/Test/Util.hs b/src/Web/Scim/Test/Util.hs index 29a9911b814..f390c9e714a 100644 --- a/src/Web/Scim/Test/Util.hs +++ b/src/Web/Scim/Test/Util.hs @@ -147,4 +147,3 @@ instance GroupTypes (TestTag id authData authInfo userExtra) where instance AuthTypes (TestTag id authData authInfo userExtra) where type AuthData (TestTag id authData authInfo userExtra) = authData type AuthInfo (TestTag id authData authInfo userExtra) = authInfo - diff --git a/test/Test/AcceptanceSpec.hs b/test/Test/AcceptanceSpec.hs index a635bb4489b..c189517c51d 100644 --- a/test/Test/AcceptanceSpec.hs +++ b/test/Test/AcceptanceSpec.hs @@ -11,7 +11,7 @@ import Web.Scim.Test.Acceptance (microsoftAzure) spec :: Spec spec = do - let + let app' = do storage <- emptyTestStorage pure (app @Mock empty (nt storage)) From b7ac4627e633766698f3254d6bc4442c9649eec3 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 14 Jan 2020 14:40:39 +0100 Subject: [PATCH 36/64] Path prefix for acceptance test suite. (the test suite is exposed by the library for the library user, so it needs ot be a bit more flexible.) --- src/Web/Scim/Test/Acceptance.hs | 33 +++++++++++++++++---------------- src/Web/Scim/Test/Util.hs | 29 +++++++++++++++++++---------- test/Test/AcceptanceSpec.hs | 2 +- 3 files changed, 37 insertions(+), 27 deletions(-) diff --git a/src/Web/Scim/Test/Acceptance.hs b/src/Web/Scim/Test/Acceptance.hs index dfcf1fac7e3..dff42519cbd 100644 --- a/src/Web/Scim/Test/Acceptance.hs +++ b/src/Web/Scim/Test/Acceptance.hs @@ -3,15 +3,16 @@ -- implementation is compatible with popular SCIM 2.0 providers module Web.Scim.Test.Acceptance where -import Web.Scim.Test.Util (scim, get', post', patch', delete') -import Test.Hspec (Spec, xit, it, shouldBe, beforeAll, pending, describe,) -import Test.Hspec.Wai (shouldRespondWith, matchStatus) +import Data.ByteString import Network.Wai (Application) +import Test.Hspec (Spec, xit, it, shouldBe, beforeAll, pending, describe) +import Test.Hspec.Wai (shouldRespondWith, matchStatus) +import Web.Scim.Test.Util (scim, get', post', patch', delete') -- https://docs.microsoft.com/en-us/azure/active-directory/manage-apps/use-scim-to-provision-users-and-groups#step-2-understand-the-azure-ad-scim-implementation -microsoftAzure :: IO Application -> Spec -microsoftAzure app = do +microsoftAzure :: ByteString -> IO Application -> Spec +microsoftAzure scimPathPrefix scimApp = do describe "Within the SCIM 2.0 protocol specification, your application must meet these requirements:" $ do it "Supports creating users, and optionally also groups, as per section 3.3 of the SCIM protocol." $ pending -- TODO(arianvp): Write test it "Supports modifying users or groups with PATCH requests, as per section 3.5.2 of the SCIM protocol." $ pending -- TODO(arianvp): Write test @@ -44,7 +45,7 @@ microsoftAzure app = do -- TODO(arianvp): Implement 'and' as Azure needs it it "and" $ pending - beforeAll app $ do + beforeAll scimApp $ do describe "User Operations" $ do it "POST /Users" $ do let user = [scim| @@ -71,11 +72,11 @@ microsoftAzure app = do "roles": [] } |] - post' "/Users" user `shouldRespondWith` 201 + post' scimPathPrefix "/Users" user `shouldRespondWith` 201 it "Get user by query" $ do - get' "/Users?filter userName eq \"Test_User_ab6490ee-1e48-479e-a20b-2d77186b5dd1\"" `shouldRespondWith` 200 + get' scimPathPrefix "/Users?filter userName eq \"Test_User_ab6490ee-1e48-479e-a20b-2d77186b5dd1\"" `shouldRespondWith` 200 it "Get user by query, zero results" $ do - get' "/Users?filter=userName eq \"non-existent user\"" `shouldRespondWith` [scim| + get' scimPathPrefix "/Users?filter=userName eq \"non-existent user\"" `shouldRespondWith` [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "totalResults": 0, @@ -85,9 +86,9 @@ microsoftAzure app = do } |] { matchStatus = 200 } it "Get user by externalId works" $ do - get' "/Users?filter externalId eq \"0a21f0f2-8d2a-4f8e-479e-a20b-2d77186b5dd1\"" `shouldRespondWith` 200 + get' scimPathPrefix "/Users?filter externalId eq \"0a21f0f2-8d2a-4f8e-479e-a20b-2d77186b5dd1\"" `shouldRespondWith` 200 xit "Update user [Multi-valued properties]" $ do - patch' "/Users/0" [scim| + patch' scimPathPrefix "/Users/0" [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [ @@ -105,7 +106,7 @@ microsoftAzure app = do } |] `shouldRespondWith` 200 describe "Update user [Single-valued properties]" $ do - it "replace userName" $ patch' "/Users/0" + it "replace userName" $ patch' scimPathPrefix "/Users/0" [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], @@ -116,7 +117,7 @@ microsoftAzure app = do }] } |] `shouldRespondWith` 200 - it "replace displayName" $ patch' "/Users/0" + it "replace displayName" $ patch' scimPathPrefix "/Users/0" [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], @@ -158,7 +159,7 @@ microsoftAzure app = do "externalId": "0a21f0f2-8d2a-4f8e-bf98-7363c4aed4ef" } |] - it "remove displayName" $ patch' "/Users/0" + it "remove displayName" $ patch' scimPathPrefix "/Users/0" [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], @@ -200,7 +201,7 @@ microsoftAzure app = do |] -- TODO match body it "Delete User" $ do - delete' "/Users/0" "" `shouldRespondWith` 204 - delete' "/Users/0" "" `shouldRespondWith` 404 + delete' scimPathPrefix "/Users/0" "" `shouldRespondWith` 204 + delete' scimPathPrefix "/Users/0" "" `shouldRespondWith` 404 describe "Group operations" $ it "is in progress" $ \_-> pending diff --git a/src/Web/Scim/Test/Util.hs b/src/Web/Scim/Test/Util.hs index f390c9e714a..61a22c14b4c 100644 --- a/src/Web/Scim/Test/Util.hs +++ b/src/Web/Scim/Test/Util.hs @@ -15,6 +15,7 @@ module Web.Scim.Test.Util ( ) where import Data.ByteString (ByteString) +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L import Data.Aeson import Data.Aeson.Internal (JSONPathElement (Key), ()) @@ -37,6 +38,14 @@ import Web.Scim.Schema.Schema (Schema (User20, CustomSchema)) ---------------------------------------------------------------------------- -- Redefine wai test helpers to include scim+json content type +-- | avoid multiple @/@. (kill at most one @/@ at the end of first arg and beginning of +-- second arg, resp., then add one during concatenation. +() :: ByteString -> ByteString -> ByteString +() a b = a' <> "/" <> b' + where + a' = maybe a fst $ BS.unsnoc a + b' = maybe b snd $ BS.uncons b + post :: ByteString -> L.ByteString -> WaiSession SResponse post path = request methodPost path [(hContentType, "application/scim+json")] @@ -46,20 +55,20 @@ put path = request methodPut path [(hContentType, "application/scim+json")] patch :: ByteString -> L.ByteString -> WaiSession SResponse patch path = request methodPatch path [(hContentType, "application/scim+json")] -get' :: ByteString -> WaiSession SResponse -get' path = request methodGet path [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] "" +get' :: ByteString -> ByteString -> WaiSession SResponse +get' prefix path = request methodGet (prefix path) [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] "" -post' :: ByteString -> L.ByteString -> WaiSession SResponse -post' path = request methodPost path [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] +post' :: ByteString -> ByteString -> L.ByteString -> WaiSession SResponse +post' prefix path = request methodPost (prefix path) [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] -put' :: ByteString -> L.ByteString -> WaiSession SResponse -put' path = request methodPut path [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] +put' :: ByteString -> ByteString -> L.ByteString -> WaiSession SResponse +put' prefix path = request methodPut (prefix path) [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] -patch' :: ByteString -> L.ByteString -> WaiSession SResponse -patch' path = request methodPatch path [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] +patch' :: ByteString -> ByteString -> L.ByteString -> WaiSession SResponse +patch' prefix path = request methodPatch (prefix path) [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] -delete' :: ByteString -> L.ByteString -> WaiSession SResponse -delete' path = request methodDelete path [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] +delete' :: ByteString -> ByteString -> L.ByteString -> WaiSession SResponse +delete' prefix path = request methodDelete (prefix path) [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] diff --git a/test/Test/AcceptanceSpec.hs b/test/Test/AcceptanceSpec.hs index c189517c51d..f51ae9f055d 100644 --- a/test/Test/AcceptanceSpec.hs +++ b/test/Test/AcceptanceSpec.hs @@ -16,4 +16,4 @@ spec = do storage <- emptyTestStorage pure (app @Mock empty (nt storage)) - describe "Azure" $ microsoftAzure app' + describe "Azure" $ microsoftAzure "" app' From af22d89e7723d0f1a264fb4dbd0b4bbb4097c7a1 Mon Sep 17 00:00:00 2001 From: fisx Date: Tue, 4 Feb 2020 14:30:57 +0100 Subject: [PATCH 37/64] Build hscim with LTS 14.12 (again) (#41) --- .gitignore | 3 +- .travis.yml | 7 +- hscim.cabal | 218 ++++++++++++++++++++++++++++++++++ package.yaml | 103 +++++++--------- server/Main.hs | 2 +- src/Web/Scim/Schema/Error.hs | 10 +- src/Web/Scim/Schema/Schema.hs | 6 +- src/Web/Scim/Server/Mock.hs | 8 +- stack.yaml | 10 +- test/Test/Class/AuthSpec.hs | 2 +- 10 files changed, 283 insertions(+), 86 deletions(-) create mode 100644 hscim.cabal diff --git a/.gitignore b/.gitignore index c04fa9f5d2b..691684e8295 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,6 @@ dist dist-* cabal-dev -*.cabal *.o *.hi *.chi @@ -21,8 +20,8 @@ cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* +.stac-work-tmp/ *~ *.el \#* -hscim.cabal diff --git a/.travis.yml b/.travis.yml index 1cfd3d37254..9e17a079b4b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -12,19 +12,16 @@ addons: packages: - libgmp-dev -env: -- RESOLVER=lts-12.10 - before_install: - mkdir -p ~/.local/bin - export PATH=$HOME/.local/bin:$PATH - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' install: -- stack --resolver=$RESOLVER --no-terminal --install-ghc test --fast --only-dependencies +- stack --no-terminal --install-ghc test --fast --only-dependencies script: -- stack --resolver=$RESOLVER --no-terminal test --fast --haddock --no-haddock-deps +- stack --no-terminal test --fast --haddock --no-haddock-deps notifications: # see https://docs.travis-ci.com/user/notifications email: false diff --git a/hscim.cabal b/hscim.cabal new file mode 100644 index 00000000000..9a861086152 --- /dev/null +++ b/hscim.cabal @@ -0,0 +1,218 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: dacbefe6b2a13bf0be7cc0a32b675c371e2afc853228e2feb0e834c908d9aaf6 + +name: hscim +version: 0.3.0 +synopsis: ... +description: ... +category: Web +homepage: https://github.com/wireapp/hscim/README.md +bug-reports: https://github.com/wireapp/hscim/issues +author: Wire Swiss GmbH +maintainer: Wire Swiss GmbH +copyright: (c) 2018 Wire Swiss GmbH +license: AGPL-3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/wireapp/hscim + +library + exposed-modules: + Web.Scim.AttrName + Web.Scim.Capabilities.MetaSchema + Web.Scim.Capabilities.MetaSchema.Group + Web.Scim.Capabilities.MetaSchema.ResourceType + Web.Scim.Capabilities.MetaSchema.Schema + Web.Scim.Capabilities.MetaSchema.SPConfig + Web.Scim.Capabilities.MetaSchema.User + Web.Scim.Class.Auth + Web.Scim.Class.Group + Web.Scim.Class.User + Web.Scim.ContentType + Web.Scim.Filter + Web.Scim.Handler + Web.Scim.Schema.AuthenticationScheme + Web.Scim.Schema.Common + Web.Scim.Schema.Error + Web.Scim.Schema.ListResponse + Web.Scim.Schema.Meta + Web.Scim.Schema.PatchOp + Web.Scim.Schema.ResourceType + Web.Scim.Schema.Schema + Web.Scim.Schema.User + Web.Scim.Schema.User.Address + Web.Scim.Schema.User.Certificate + Web.Scim.Schema.User.Email + Web.Scim.Schema.User.IM + Web.Scim.Schema.User.Name + Web.Scim.Schema.User.Phone + Web.Scim.Schema.User.Photo + Web.Scim.Schema.UserTypes + Web.Scim.Server + Web.Scim.Server.Mock + Web.Scim.Test.Acceptance + Web.Scim.Test.Util + other-modules: + Paths_hscim + hs-source-dirs: + src + default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances + ghc-options: -Wall -Werror + build-depends: + aeson >=1.4.5 && <1.5 + , aeson-qq >=0.8.2 && <0.9 + , attoparsec >=0.13.2 && <0.14 + , base >=4.12 && <4.13 + , bytestring >=0.10.8 && <0.11 + , email-validate >=2.3.2 && <2.4 + , errors >=2.3.0 && <2.4 + , hashable >=1.2.7 && <1.4 + , hedgehog >=1.0.1 && <1.1 + , hspec >=2.7.1 && <2.8 + , hspec-expectations >=0.8.2 && <0.9 + , hspec-wai >=0.9.2 && <0.10 + , http-api-data >=0.4.1 && <0.5 + , http-media >=0.8.0 && <0.9 + , http-types >=0.12.3 && <0.13 + , hw-hspec-hedgehog >=0.1.0 && <0.2 + , list-t >=1.0.4 && <1.1 + , microlens >=0.4.10 && <0.5 + , mmorph >=1.1.3 && <1.2 + , mtl >=2.2.2 && <2.3 + , network-uri >=2.6.1 && <2.7 + , network-uri-static >=0.1.2 && <0.2 + , scientific >=0.3.6 && <0.4 + , servant >=0.16.2 && <0.17 + , servant-server >=0.16.2 && <0.17 + , stm >=2.5.0 && <2.6 + , stm-containers >=1.1.0 && <1.2 + , template-haskell >=2.14.0 && <2.15 + , text >=1.2.3 && <1.3 + , time >=1.8.0 && <1.9 + , unordered-containers >=0.2.10 && <0.3 + , uuid >=1.3.13 && <1.4 + , vector >=0.12.0 && <0.13 + , wai >=3.2.2 && <3.3 + , wai-extra >=3.0.28 && <3.1 + , wai-logger >=2.3.5 && <2.4 + , warp >=3.2.28 && <3.4 + default-language: Haskell2010 + +executable hscim-server + main-is: Main.hs + other-modules: + Paths_hscim + hs-source-dirs: + server + default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances + ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=1.4.5 && <1.5 + , aeson-qq >=0.8.2 && <0.9 + , attoparsec >=0.13.2 && <0.14 + , base >=4.12 && <4.13 + , bytestring >=0.10.8 && <0.11 + , email-validate >=2.3.2 && <2.4 + , errors >=2.3.0 && <2.4 + , hashable >=1.2.7 && <1.4 + , hedgehog >=1.0.1 && <1.1 + , hscim + , hspec >=2.7.1 && <2.8 + , hspec-expectations >=0.8.2 && <0.9 + , hspec-wai >=0.9.2 && <0.10 + , http-api-data >=0.4.1 && <0.5 + , http-media >=0.8.0 && <0.9 + , http-types >=0.12.3 && <0.13 + , hw-hspec-hedgehog >=0.1.0 && <0.2 + , list-t >=1.0.4 && <1.1 + , microlens >=0.4.10 && <0.5 + , mmorph >=1.1.3 && <1.2 + , mtl >=2.2.2 && <2.3 + , network-uri >=2.6.1 && <2.7 + , network-uri-static >=0.1.2 && <0.2 + , scientific >=0.3.6 && <0.4 + , servant >=0.16.2 && <0.17 + , servant-server >=0.16.2 && <0.17 + , stm >=2.5.0 && <2.6 + , stm-containers >=1.1.0 && <1.2 + , template-haskell >=2.14.0 && <2.15 + , text >=1.2.3 && <1.3 + , time >=1.8.0 && <1.9 + , unordered-containers >=0.2.10 && <0.3 + , uuid >=1.3.13 && <1.4 + , vector >=0.12.0 && <0.13 + , wai >=3.2.2 && <3.3 + , wai-extra >=3.0.28 && <3.1 + , wai-logger >=2.3.5 && <2.4 + , warp >=3.2.28 && <3.4 + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.AcceptanceSpec + Test.Capabilities.MetaSchemaSpec + Test.Class.AuthSpec + Test.Class.GroupSpec + Test.Class.UserSpec + Test.FilterSpec + Test.Schema.PatchOpSpec + Test.Schema.UserSpec + Paths_hscim + hs-source-dirs: + test + default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances + ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + aeson >=1.4.5 && <1.5 + , aeson-qq >=0.8.2 && <0.9 + , attoparsec >=0.13.2 && <0.14 + , base >=4.12 && <4.13 + , bytestring >=0.10.8 && <0.11 + , email-validate >=2.3.2 && <2.4 + , errors >=2.3.0 && <2.4 + , hashable >=1.2.7 && <1.4 + , hedgehog >=1.0.1 && <1.1 + , hscim + , hspec >=2.7.1 && <2.8 + , hspec-expectations >=0.8.2 && <0.9 + , hspec-wai >=0.9.2 && <0.10 + , http-api-data >=0.4.1 && <0.5 + , http-media >=0.8.0 && <0.9 + , http-types >=0.12.3 && <0.13 + , hw-hspec-hedgehog >=0.1.0 && <0.2 + , list-t >=1.0.4 && <1.1 + , microlens >=0.4.10 && <0.5 + , mmorph >=1.1.3 && <1.2 + , mtl >=2.2.2 && <2.3 + , network-uri >=2.6.1 && <2.7 + , network-uri-static >=0.1.2 && <0.2 + , scientific >=0.3.6 && <0.4 + , servant >=0.16.2 && <0.17 + , servant-server >=0.16.2 && <0.17 + , stm >=2.5.0 && <2.6 + , stm-containers >=1.1.0 && <1.2 + , template-haskell >=2.14.0 && <2.15 + , text >=1.2.3 && <1.3 + , time >=1.8.0 && <1.9 + , unordered-containers >=0.2.10 && <0.3 + , uuid >=1.3.13 && <1.4 + , vector >=0.12.0 && <0.13 + , wai >=3.2.2 && <3.3 + , wai-extra >=3.0.28 && <3.1 + , wai-logger >=2.3.5 && <2.4 + , warp >=3.2.28 && <3.4 + default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 5c8370e9460..6ce8e8b5a33 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: hscim -version: 0.2 +version: 0.3.0 synopsis: ... description: ... homepage: https://github.com/wireapp/hscim/README.md @@ -33,45 +33,45 @@ default-extensions: extra-source-files: - README.md + dependencies: - - aeson - - aeson-qq - - attoparsec - - base >= 4.11 && < 5 - - bytestring - - email-validate - - errors - - hashable - - hedgehog - - hspec - - hspec-expectations - - hspec-wai - - http-api-data - - http-media - - http-types - - hw-hspec-hedgehog - - list-t - - microlens - - mmorph - - mtl - - network-uri - - network-uri-static >= 0.1.1.0 - - scientific - - servant - - servant-server - - servant-server >= 0.14.1 - - stm - - stm-containers - - template-haskell - - text - - time - - unordered-containers - - uuid - - vector - - wai - - wai-extra - - wai-logger - - warp + - aeson >= 1.4.5 && < 1.5 + - attoparsec >= 0.13.2 && < 0.14 + - bytestring >= 0.10.8 && < 0.11 + - base >= 4.12 && < 4.13 + - scientific >= 0.3.6 && < 0.4 + - hashable >= 1.2.7 && < 1.4 + - text >= 1.2.3 && < 1.3 + - time >= 1.8.0 && < 1.9 + - template-haskell >= 2.14.0 && < 2.15 + - unordered-containers >= 0.2.10 && < 0.3 + - vector >= 0.12.0 && < 0.13 + - aeson-qq >= 0.8.2 && < 0.9 + - mtl >= 2.2.2 && < 2.3 + - email-validate >= 2.3.2 && < 2.4 + - errors >= 2.3.0 && < 2.4 + - stm >= 2.5.0 && < 2.6 + - hedgehog >= 1.0.1 && < 1.1 + - mmorph >= 1.1.3 && < 1.2 + - hspec >= 2.7.1 && < 2.8 + - hspec-wai >= 0.9.2 && < 0.10 + - hspec-expectations >= 0.8.2 && < 0.9 + - http-types >= 0.12.3 && < 0.13 + - wai >= 3.2.2 && < 3.3 + - wai-extra >= 3.0.28 && < 3.1 + - wai-logger >= 2.3.5 && < 2.4 + - http-api-data >= 0.4.1 && < 0.5 + - http-media >= 0.8.0 && < 0.9 + - hw-hspec-hedgehog >= 0.1.0 && < 0.2 + - list-t >= 1.0.4 && < 1.1 + - microlens >= 0.4.10 && < 0.5 + - network-uri >= 2.6.1 && < 2.7 + - network-uri-static >= 0.1.2 && < 0.2 + - servant >= 0.16.2 && < 0.17 + - servant-server >= 0.16.2 && < 0.17 + - warp >= 3.2.28 && < 3.4 + - stm-containers >= 1.1.0 && < 1.2 + - uuid >= 1.3.13 && < 1.4 ghc-options: -Wall -Werror @@ -85,7 +85,6 @@ executables: source-dirs: server dependencies: - hscim - - warp tests: spec: @@ -93,27 +92,7 @@ tests: ghc-options: -threaded -rtsopts -with-rtsopts=-N source-dirs: - test + build-tools: + - hspec-discover:hspec-discover dependencies: - hscim - - aeson - - aeson-qq - - base - - bytestring - - containers - - hedgehog - - hspec - - hspec-discover - - hspec-expectations - - hspec-wai - - http-types - - hw-hspec-hedgehog - - mtl - - servant-server - - stm-containers - - template-haskell - - text - - time - - vector - - wai-extra - - wai-logger - - warp diff --git a/server/Main.hs b/server/Main.hs index 2bd9598b894..5ef890f2a45 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -16,7 +16,7 @@ import Web.Scim.Capabilities.MetaSchema as MetaSchema import Data.Time import Network.Wai.Handler.Warp import Network.URI.Static -import qualified STMContainers.Map as STMMap +import qualified StmContainers.Map as STMMap import Control.Monad.STM (atomically) import Text.Email.Validate diff --git a/src/Web/Scim/Schema/Error.hs b/src/Web/Scim/Schema/Error.hs index 151a7d8e308..6e5b198b163 100644 --- a/src/Web/Scim/Schema/Error.hs +++ b/src/Web/Scim/Schema/Error.hs @@ -15,7 +15,7 @@ module Web.Scim.Schema.Error , serverError -- * Servant interoperability - , scimToServantErr + , scimToServerError ) where import Data.Text (Text, pack) @@ -23,7 +23,7 @@ import Data.Aeson hiding (Error) import Control.Exception import Web.Scim.Schema.Common import Web.Scim.Schema.Schema -import Servant (ServantErr (..)) +import Servant (ServerError (..)) import GHC.Generics (Generic) @@ -153,9 +153,9 @@ serverError details = -- | Convert a SCIM 'Error' to a Servant one by encoding it with the -- appropriate headers. -scimToServantErr :: ScimError -> ServantErr -scimToServantErr err = - ServantErr +scimToServerError :: ScimError -> ServerError +scimToServerError err = + ServerError { errHTTPCode = unStatus (status err) , errReasonPhrase = reasonPhrase (status err) , errBody = encode err diff --git a/src/Web/Scim/Schema/Schema.hs b/src/Web/Scim/Schema/Schema.hs index 9e67fc98a08..6e197e28b75 100644 --- a/src/Web/Scim/Schema/Schema.hs +++ b/src/Web/Scim/Schema/Schema.hs @@ -6,11 +6,11 @@ import Web.Scim.Capabilities.MetaSchema.Group import Web.Scim.Capabilities.MetaSchema.Schema import Web.Scim.Capabilities.MetaSchema.ResourceType +import Data.Text (Text) import Data.Aeson (FromJSON, parseJSON, toJSON, ToJSON, withText, Value) -import Data.Attoparsec.ByteString (Parser) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Attoparsec.ByteString (Parser) import qualified Data.Attoparsec.ByteString.Char8 as Parser -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Text (Text) -- | All schemas that we support. data Schema = User20 diff --git a/src/Web/Scim/Server/Mock.hs b/src/Web/Scim/Server/Mock.hs index d944148020a..3f455d9cd42 100644 --- a/src/Web/Scim/Server/Mock.hs +++ b/src/Web/Scim/Server/Mock.hs @@ -21,7 +21,7 @@ import Data.Time.Clock import Data.Time.Calendar import GHC.Exts (sortWith) import ListT -import qualified STMContainers.Map as STMMap +import qualified StmContainers.Map as STMMap import Text.Read (readMaybe) import Web.Scim.Filter (Filter(..), CompValue(..), AttrPath(..), compareStr) import Web.Scim.Schema.User @@ -79,7 +79,7 @@ instance UserTypes Mock where instance UserDB Mock TestServer where getUsers () mbFilter = do m <- userDB <$> ask - users <- liftSTM $ ListT.toList $ STMMap.stream m + users <- liftSTM $ ListT.toList $ STMMap.listT m let check user = case mbFilter of Nothing -> pure True Just filter_ -> do @@ -130,7 +130,7 @@ instance GroupTypes Mock where instance GroupDB Mock TestServer where getGroups () = do m <- groupDB <$> ask - groups <- liftSTM $ ListT.toList $ STMMap.stream m + groups <- liftSTM $ ListT.toList $ STMMap.listT m return $ fromList . sortWith (Common.id . thing) $ snd <$> groups getGroup () gid = do @@ -200,7 +200,7 @@ createMeta rType = Meta nt :: TestStorage -> ScimHandler TestServer a -> Handler a nt storage = flip runReaderT storage . - fromScimHandler (lift . throwError . scimToServantErr) + fromScimHandler (lift . throwError . scimToServerError) -- | Check whether a user satisfies the filter. diff --git a/stack.yaml b/stack.yaml index faddcb4d08c..f65f4f731a0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,11 +1,15 @@ -resolver: lts-12.10 -compiler: ghc-8.4.4 +resolver: lts-14.12 packages: - . extra-deps: -- network-uri-static-0.1.1.0 +- network-uri-static-0.1.2.1@sha256:7e1ca4358b319ac2db6514d0e0beb073c296789eeef9cebd89cc9517618fbfe8,1724 +- stm-containers-1.1.0.4@sha256:f83a683357b6e3b1dda3e70d2077a37224ed534df1f74c4e11f3f6daa7945c5b,3248 +- stm-hamt-1.2.0.4@sha256:7957497c022554b7599e790696d1a3e56359ad99e5da36a251894c626ca1f60a,3970 +- primitive-0.7.0.0@sha256:ee352d97cc390d8513530029a2213a95c179a66c406906b18d03702c1d9ab8e5,3416 +- primitive-extras-0.8@sha256:fca0310150496867f5b9421fe1541ecda87fae17eae44885a29f9c52dd00c8ff,2963 +- primitive-unlifted-0.1.2.0@sha256:9c3df73af54ed19fb3f4874da19334863cc414b22e578e27b5f52beeac4a60dd,1360 nix: packages: diff --git a/test/Test/Class/AuthSpec.hs b/test/Test/Class/AuthSpec.hs index 7805e1fd66d..921311022a3 100644 --- a/test/Test/Class/AuthSpec.hs +++ b/test/Test/Class/AuthSpec.hs @@ -11,7 +11,7 @@ import Test.Hspec import Test.Hspec.Wai hiding (post, put, patch) import Network.HTTP.Types.Header import Network.HTTP.Types.Method (methodGet) -import qualified STMContainers.Map as STMMap +import qualified StmContainers.Map as STMMap testStorage :: IO TestStorage testStorage = TestStorage <$> STMMap.newIO <*> STMMap.newIO From 20e2ce169d2c85a10c09b4dc564eacedf8acad68 Mon Sep 17 00:00:00 2001 From: fisx Date: Mon, 9 Mar 2020 13:50:49 +0100 Subject: [PATCH 38/64] Make acceptance tests flexible enough to ge called by lib user. (#42) * Allow to configure displayName generators in acceptance tests. This required to give up on the idea of isolating individual test cases in individual `it`s, which was illegal to begin with: test cases are morally collected in a set by a writer, and are only executed in order by coincidence, and only if nobody adds `parallel` anywhere in the test tree. * Make auth token configurable as well. * Introduce doctest. * More verbose shouldRespondWith function. * Better error messages in tests. * Make missing metadata location field at least parseable. * Add missing tests as pending; add TODOs. * Make test wait for deletion to happen asynchronously. --- doctests/doctests.hs | 34 +++ hscim.cabal | 64 ++++- package.yaml | 13 +- src/Web/Scim/Server/Mock.hs | 8 +- src/Web/Scim/Test/Acceptance.hs | 347 +++++++++++++---------- src/Web/Scim/Test/Util.hs | 102 +++++-- test/Test/AcceptanceSpec.hs | 4 +- test/Test/Capabilities/MetaSchemaSpec.hs | 2 +- test/Test/Class/GroupSpec.hs | 8 +- test/Test/Class/UserSpec.hs | 28 +- 10 files changed, 423 insertions(+), 187 deletions(-) create mode 100644 doctests/doctests.hs diff --git a/doctests/doctests.hs b/doctests/doctests.hs new file mode 100644 index 00000000000..29ca0651202 --- /dev/null +++ b/doctests/doctests.hs @@ -0,0 +1,34 @@ +import Test.DocTest + +main :: IO () +main = doctest $ ["-isrc"] <> (("-X" <>) <$> ghcExts) <> modules + +-- | FUTUREWORK: is there a way to auto-detect them? +-- (https://github.com/karun012/doctest-discover is out of maintenance, but that'd probably be +-- the solution.) +modules :: [String] +modules = + [ "src/Web/Scim/Server/Mock.hs", + "src/Web/Scim/Test/Util.hs" + ] + +-- | FUTUREWORK: keep this in sync with default-extensions in package.yaml. +ghcExts :: [String] +ghcExts = + [ "ConstraintKinds", + "DataKinds", + "DeriveFunctor", + "DeriveGeneric", + "FlexibleContexts", + "FlexibleInstances", + "KindSignatures", + "LambdaCase", + "MultiParamTypeClasses", + "OverloadedStrings", + "RankNTypes", + "ScopedTypeVariables", + "TypeApplications", + "TypeFamilies", + "TypeOperators", + "TypeSynonymInstances" + ] diff --git a/hscim.cabal b/hscim.cabal index 9a861086152..8c17fdcb665 100644 --- a/hscim.cabal +++ b/hscim.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: dacbefe6b2a13bf0be7cc0a32b675c371e2afc853228e2feb0e834c908d9aaf6 +-- hash: c5f5fd678522776d61449fb5e696f7aae333e56fcbdb7c9d7871d9cf732462bf name: hscim -version: 0.3.0 +version: 0.3.4 synopsis: ... description: ... category: Web @@ -91,11 +91,13 @@ library , mtl >=2.2.2 && <2.3 , network-uri >=2.6.1 && <2.7 , network-uri-static >=0.1.2 && <0.2 + , retry >=0.8.1.0 && <0.9 , scientific >=0.3.6 && <0.4 , servant >=0.16.2 && <0.17 , servant-server >=0.16.2 && <0.17 , stm >=2.5.0 && <2.6 , stm-containers >=1.1.0 && <1.2 + , string-conversions >=0.4.0 && <0.5 , template-haskell >=2.14.0 && <2.15 , text >=1.2.3 && <1.3 , time >=1.8.0 && <1.9 @@ -140,11 +142,65 @@ executable hscim-server , mtl >=2.2.2 && <2.3 , network-uri >=2.6.1 && <2.7 , network-uri-static >=0.1.2 && <0.2 + , retry >=0.8.1.0 && <0.9 , scientific >=0.3.6 && <0.4 , servant >=0.16.2 && <0.17 , servant-server >=0.16.2 && <0.17 , stm >=2.5.0 && <2.6 , stm-containers >=1.1.0 && <1.2 + , string-conversions >=0.4.0 && <0.5 + , template-haskell >=2.14.0 && <2.15 + , text >=1.2.3 && <1.3 + , time >=1.8.0 && <1.9 + , unordered-containers >=0.2.10 && <0.3 + , uuid >=1.3.13 && <1.4 + , vector >=0.12.0 && <0.13 + , wai >=3.2.2 && <3.3 + , wai-extra >=3.0.28 && <3.1 + , wai-logger >=2.3.5 && <2.4 + , warp >=3.2.28 && <3.4 + default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + other-modules: + Paths_hscim + hs-source-dirs: + doctests + default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveGeneric FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators TypeSynonymInstances + ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=1.4.5 && <1.5 + , aeson-qq >=0.8.2 && <0.9 + , attoparsec >=0.13.2 && <0.14 + , base + , bytestring >=0.10.8 && <0.11 + , doctest + , email-validate >=2.3.2 && <2.4 + , errors >=2.3.0 && <2.4 + , hashable >=1.2.7 && <1.4 + , hedgehog >=1.0.1 && <1.1 + , hspec >=2.7.1 && <2.8 + , hspec-expectations >=0.8.2 && <0.9 + , hspec-wai >=0.9.2 && <0.10 + , http-api-data >=0.4.1 && <0.5 + , http-media >=0.8.0 && <0.9 + , http-types >=0.12.3 && <0.13 + , hw-hspec-hedgehog >=0.1.0 && <0.2 + , list-t >=1.0.4 && <1.1 + , microlens >=0.4.10 && <0.5 + , mmorph >=1.1.3 && <1.2 + , mtl >=2.2.2 && <2.3 + , network-uri >=2.6.1 && <2.7 + , network-uri-static >=0.1.2 && <0.2 + , retry >=0.8.1.0 && <0.9 + , scientific >=0.3.6 && <0.4 + , servant >=0.16.2 && <0.17 + , servant-server >=0.16.2 && <0.17 + , stm >=2.5.0 && <2.6 + , stm-containers >=1.1.0 && <1.2 + , string-conversions >=0.4.0 && <0.5 , template-haskell >=2.14.0 && <2.15 , text >=1.2.3 && <1.3 , time >=1.8.0 && <1.9 @@ -200,11 +256,13 @@ test-suite spec , mtl >=2.2.2 && <2.3 , network-uri >=2.6.1 && <2.7 , network-uri-static >=0.1.2 && <0.2 + , retry >=0.8.1.0 && <0.9 , scientific >=0.3.6 && <0.4 , servant >=0.16.2 && <0.17 , servant-server >=0.16.2 && <0.17 , stm >=2.5.0 && <2.6 , stm-containers >=1.1.0 && <1.2 + , string-conversions >=0.4.0 && <0.5 , template-haskell >=2.14.0 && <2.15 , text >=1.2.3 && <1.3 , time >=1.8.0 && <1.9 diff --git a/package.yaml b/package.yaml index 6ce8e8b5a33..f2fbc6e3dd8 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: hscim -version: 0.3.0 +version: 0.3.4 synopsis: ... description: ... homepage: https://github.com/wireapp/hscim/README.md @@ -71,7 +71,9 @@ dependencies: - servant-server >= 0.16.2 && < 0.17 - warp >= 3.2.28 && < 3.4 - stm-containers >= 1.1.0 && < 1.2 + - string-conversions >= 0.4.0 && < 0.5 - uuid >= 1.3.13 && < 1.4 + - retry >= 0.8.1.0 && < 0.9 ghc-options: -Wall -Werror @@ -96,3 +98,12 @@ tests: - hspec-discover:hspec-discover dependencies: - hscim + + doctests: + main: doctests.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + source-dirs: + - doctests + dependencies: + - base + - doctest diff --git a/src/Web/Scim/Server/Mock.hs b/src/Web/Scim/Server/Mock.hs index 3f455d9cd42..0615d15f107 100644 --- a/src/Web/Scim/Server/Mock.hs +++ b/src/Web/Scim/Server/Mock.hs @@ -21,6 +21,7 @@ import Data.Time.Clock import Data.Time.Calendar import GHC.Exts (sortWith) import ListT +import qualified Network.URI as URI import qualified StmContainers.Map as STMMap import Text.Read (readMaybe) import Web.Scim.Filter (Filter(..), CompValue(..), AttrPath(..), compareStr) @@ -39,6 +40,9 @@ import Servant data Mock -- | A simple ID type. +-- +-- >>> eitherDecode' @Id . encode $ (Id 3) +-- Right (Id {unId = 3}) newtype Id = Id { unId :: Int } deriving (Eq, Show, Ord, Hashable, ToHttpApiData, FromHttpApiData) @@ -192,7 +196,9 @@ createMeta rType = Meta , created = testDate , lastModified = testDate , version = Weak "testVersion" - , location = Common.URI $ URI "todo" Nothing "" "" "" + , location = Common.URI $ -- FUTUREWORK: getting the actual schema, authority, and path here + -- is a bit of work, but it may be required one day. + URI "https:" (Just $ URI.URIAuth "" "example.com" "") "/Users/id" "" "" } -- Natural transformation from our transformer stack to the Servant stack diff --git a/src/Web/Scim/Test/Acceptance.hs b/src/Web/Scim/Test/Acceptance.hs index dff42519cbd..c1cf1aaf32b 100644 --- a/src/Web/Scim/Test/Acceptance.hs +++ b/src/Web/Scim/Test/Acceptance.hs @@ -1,18 +1,39 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} -- | A bunch of hspec acceptance tests that assert that your SCIM -- implementation is compatible with popular SCIM 2.0 providers -module Web.Scim.Test.Acceptance where +module Web.Scim.Test.Acceptance + ( module Web.Scim.Test.Acceptance, + module Web.Scim.Test.Util + ) where -import Data.ByteString -import Network.Wai (Application) -import Test.Hspec (Spec, xit, it, shouldBe, beforeAll, pending, describe) -import Test.Hspec.Wai (shouldRespondWith, matchStatus) -import Web.Scim.Test.Util (scim, get', post', patch', delete') +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as L +import Data.String.Conversions (cs) +import Data.Text (Text) +import Network.HTTP.Types.Status +import Network.Wai.Test +import Servant.API as Servant +import Test.Hspec (Spec, it, shouldBe, beforeAll, pending, pendingWith, describe) +import Test.Hspec.Wai.Internal (runWaiSession) +import Test.Hspec.Wai (matchStatus) +import Web.Scim.Test.Util +import Web.Scim.Class.User +import Web.Scim.Schema.Common as Hscim +import Web.Scim.Schema.Meta +import Web.Scim.Schema.UserTypes + + +ignore :: Monad m => m a -> m () +ignore _ = pure () -- https://docs.microsoft.com/en-us/azure/active-directory/manage-apps/use-scim-to-provision-users-and-groups#step-2-understand-the-azure-ad-scim-implementation -microsoftAzure :: ByteString -> IO Application -> Spec -microsoftAzure scimPathPrefix scimApp = do +microsoftAzure :: forall tag. (Aeson.FromJSON (UserId tag), Aeson.FromJSON (UserExtra tag), ToHttpApiData (UserId tag)) => AcceptanceConfig tag -> Spec +microsoftAzure AcceptanceConfig{..} = do describe "Within the SCIM 2.0 protocol specification, your application must meet these requirements:" $ do it "Supports creating users, and optionally also groups, as per section 3.3 of the SCIM protocol." $ pending -- TODO(arianvp): Write test it "Supports modifying users or groups with PATCH requests, as per section 3.5.2 of the SCIM protocol." $ pending -- TODO(arianvp): Write test @@ -45,38 +66,32 @@ microsoftAzure scimPathPrefix scimApp = do -- TODO(arianvp): Implement 'and' as Azure needs it it "and" $ pending - beforeAll scimApp $ do - describe "User Operations" $ do - it "POST /Users" $ do - let user = [scim| - { - "schemas": [ - "urn:ietf:params:scim:schemas:core:2.0:User", - "urn:ietf:params:scim:schemas:extension:enterprise:2.0:User"], - "externalId": "0a21f0f2-8d2a-4f8e-bf98-7363c4aed4ef", - "userName": "Test_User_ab6490ee-1e48-479e-a20b-2d77186b5dd1", - "active": true, - "emails": [{ - "primary": true, - "type": "work", - "value": "Test_User_fd0ea19b-0777-472c-9f96-4f70d2226f2e@testuser.com" - }], - "meta": { - "resourceType": "User" - }, - "name": { - "formatted": "givenName familyName", - "familyName": "familyName", - "givenName": "givenName" - }, - "roles": [] - } - |] - post' scimPathPrefix "/Users" user `shouldRespondWith` 201 - it "Get user by query" $ do - get' scimPathPrefix "/Users?filter userName eq \"Test_User_ab6490ee-1e48-479e-a20b-2d77186b5dd1\"" `shouldRespondWith` 200 - it "Get user by query, zero results" $ do - get' scimPathPrefix "/Users?filter=userName eq \"non-existent user\"" `shouldRespondWith` [scim| + describe "good errors" $ do + -- (we may touch servant for this?) + it "surfaces parse errors of the user id path segment" $ do + pendingWith "should contain the offending id and the error; currently contains neither" + it "same for user id in query" $ do + pending + it "same for all other things parsed in path, query, body, ..." $ do + pending + + beforeAll scimAppAndConfig $ do + it "User Operations" $ \(app, queryConfig) -> flip runWaiSession app $ do + userName1 <- liftIO genUserName + userName2 <- liftIO genUserName + + -- POST /Users + resp :: SResponse <- post' queryConfig "/Users" (sampleUser1 userName1) + liftIO $ simpleStatus resp `shouldBe` status201 + let testuid :: BS.ByteString + testuid = either (error . show . (, resp)) (cs . Servant.toUrlPiece . Hscim.id . thing) + $ Aeson.eitherDecode' @(StoredUser tag) (simpleBody resp) + + -- Get user by query + get' queryConfig (cs $ "/Users?filter userName eq " <> show userName1) `shouldRespondWith` 200 + + -- Get user by query, zero results + get' queryConfig (cs $ "/Users?filter=userName eq " <> show userName2) `shouldRespondWith` [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "totalResults": 0, @@ -85,10 +100,12 @@ microsoftAzure scimPathPrefix scimApp = do "itemsPerPage": 0 } |] { matchStatus = 200 } - it "Get user by externalId works" $ do - get' scimPathPrefix "/Users?filter externalId eq \"0a21f0f2-8d2a-4f8e-479e-a20b-2d77186b5dd1\"" `shouldRespondWith` 200 - xit "Update user [Multi-valued properties]" $ do - patch' scimPathPrefix "/Users/0" [scim| + + -- Get user by externalId works + get' queryConfig "/Users?filter externalId eq \"0a21f0f2-8d2a-4f8e-479e-a20b-2d77186b5dd1\"" `shouldRespondWith` 200 + + -- Update user [Multi-valued properties] + ignore $ patch' queryConfig "/Users/0" [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [ @@ -105,103 +122,145 @@ microsoftAzure scimPathPrefix scimApp = do ] } |] `shouldRespondWith` 200 - describe "Update user [Single-valued properties]" $ do - it "replace userName" $ patch' scimPathPrefix "/Users/0" - [scim| - { - "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], - "Operations": [{ - "op": "Replace", - "path": "userName", - "value": "5b50642d-79fc-4410-9e90-4c077cdd1a59@testuser.com" - }] - } - |] `shouldRespondWith` 200 - it "replace displayName" $ patch' scimPathPrefix "/Users/0" - [scim| - { - "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], - "Operations": [{ - "op": "Replace", - "path": "displayName", - "value": "newDisplayName" - }] - } - |] `shouldRespondWith` [scim| - { - "schemas": [ - "urn:ietf:params:scim:schemas:core:2.0:User", - "urn:ietf:params:scim:schemas:extension:enterprise:2.0:User" - ], - "userName": "5b50642d-79fc-4410-9e90-4c077cdd1a59@testuser.com", - "active": true, - "name": { - "givenName": "givenName", - "formatted": "givenName familyName", - "familyName": "familyName" - }, - "emails": [ - { - "value": "Test_User_fd0ea19b-0777-472c-9f96-4f70d2226f2e@testuser.com", - "primary": true, - "type": "work" - } - ], - "displayName": "newDisplayName", - "id": "0", - "meta": { - "resourceType": "User", - "location": "todo", - "created": "2018-01-01T00:00:00Z", - "version": "W/\"testVersion\"", - "lastModified": "2018-01-01T00:00:00Z" - }, - "externalId": "0a21f0f2-8d2a-4f8e-bf98-7363c4aed4ef" - } - |] - it "remove displayName" $ patch' scimPathPrefix "/Users/0" - [scim| - { - "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], - "Operations": [{ - "op": "Remove", - "path": "displayName" - }] - } - |] `shouldRespondWith` [scim| - { - "schemas": [ - "urn:ietf:params:scim:schemas:core:2.0:User", - "urn:ietf:params:scim:schemas:extension:enterprise:2.0:User" - ], - "userName": "5b50642d-79fc-4410-9e90-4c077cdd1a59@testuser.com", - "active": true, - "name": { - "givenName": "givenName", - "formatted": "givenName familyName", - "familyName": "familyName" - }, - "emails": [ - { - "value": "Test_User_fd0ea19b-0777-472c-9f96-4f70d2226f2e@testuser.com", - "primary": true, - "type": "work" - } - ], - "id": "0", - "meta": { - "resourceType": "User", - "location": "todo", - "created": "2018-01-01T00:00:00Z", - "version": "W/\"testVersion\"", - "lastModified": "2018-01-01T00:00:00Z" - }, - "externalId": "0a21f0f2-8d2a-4f8e-bf98-7363c4aed4ef" - } - |] - -- TODO match body - it "Delete User" $ do - delete' scimPathPrefix "/Users/0" "" `shouldRespondWith` 204 - delete' scimPathPrefix "/Users/0" "" `shouldRespondWith` 404 - describe "Group operations" $ - it "is in progress" $ \_-> pending + + -- update user [single-valued properties] + -- replace userName + let ops1 = [scim| + { + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Replace", + "path": "userName", + "value": #{userName2} + }] + } + |] + patch' queryConfig ("/Users/" <> testuid) ops1 `shouldRespondWith` 200 + + -- replace displayName + let ops2 = [scim| + { + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Replace", + "path": "displayName", + "value": "newDisplayName" + }] + } + |] + + exactResult = [scim| + { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User", + "urn:ietf:params:scim:schemas:extension:enterprise:2.0:User" + ], + "userName": #{userName2}, + "active": true, + "name": { + "givenName": "givenName", + "formatted": "givenName familyName", + "familyName": "familyName" + }, + "emails": [ + { + "value": #{userName1 <> "@testuser.com"}, + "primary": true, + "type": "work" + } + ], + "displayName": "newDisplayName", + "id": "0", + "meta": { + "resourceType": "User", + "location": "https://example.com/Users/id", + "created": "2018-01-01T00:00:00Z", + "version": "W/\"testVersion\"", + "lastModified": "2018-01-01T00:00:00Z" + }, + "externalId": "0a21f0f2-8d2a-4f8e-bf98-7363c4aed4ef" + } + |] + result = if responsesFullyKnown + then exactResult + else 200 -- TODO(fisx): check the fields changed by the patch operations? + patch' queryConfig ("/Users/" <> testuid) ops2 `shouldRespondWith` result + + -- remove displayName + let op3 = [scim| + { + "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], + "Operations": [{ + "op": "Remove", + "path": "displayName" + }] + } + |] + exactResult3 = [scim| + { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User", + "urn:ietf:params:scim:schemas:extension:enterprise:2.0:User" + ], + "userName": #{userName2}, + "active": true, + "name": { + "givenName": "givenName", + "formatted": "givenName familyName", + "familyName": "familyName" + }, + "emails": [ + { + "value": #{userName1 <> "@testuser.com"}, + "primary": true, + "type": "work" + } + ], + "id": "0", + "meta": { + "resourceType": "User", + "location": "https://example.com/Users/id", + "created": "2018-01-01T00:00:00Z", + "version": "W/\"testVersion\"", + "lastModified": "2018-01-01T00:00:00Z" + }, + "externalId": "0a21f0f2-8d2a-4f8e-bf98-7363c4aed4ef" + } + |] + result3 = if responsesFullyKnown + then exactResult3 + else 200 -- TODO(fisx): check the fields changed by the patch operations? + patch' queryConfig ("/Users/" <> testuid) op3 `shouldRespondWith` result3 + + -- Delete User + delete' queryConfig ("/Users/" <> testuid) "" `shouldRespondWith` 204 + delete' queryConfig ("/Users/" <> testuid) "" `shouldEventuallyRespondWith` 404 + + it "Group operations" $ \_ -> pending + + +sampleUser1 :: Text -> L.ByteString +sampleUser1 userName1 = [scim| + { + "schemas": [ + "urn:ietf:params:scim:schemas:core:2.0:User", + "urn:ietf:params:scim:schemas:extension:enterprise:2.0:User"], + "externalId": "0a21f0f2-8d2a-4f8e-bf98-7363c4aed4ef", + "userName": #{userName1}, + "active": true, + "emails": [{ + "primary": true, + "type": "work", + "value": #{userName1 <> "@testuser.com"} + }], + "meta": { + "resourceType": "User" + }, + "name": { + "formatted": "givenName familyName", + "familyName": "familyName", + "givenName": "givenName" + }, + "roles": [] + } +|] diff --git a/src/Web/Scim/Test/Util.hs b/src/Web/Scim/Test/Util.hs index 61a22c14b4c..edac0028677 100644 --- a/src/Web/Scim/Test/Util.hs +++ b/src/Web/Scim/Test/Util.hs @@ -1,9 +1,14 @@ - +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} module Web.Scim.Test.Util ( + shouldRespondWith, + shouldEventuallyRespondWith, -- * Making wai requests post, put, patch, + AcceptanceConfig(..), defAcceptanceConfig, + AcceptanceQueryConfig(..), defAcceptanceQueryConfig, post', put', patch', get', delete' -- * Request/response quasiquoter , scim @@ -14,20 +19,28 @@ module Web.Scim.Test.Util ( , TestTag ) where +import qualified Control.Retry as Retry import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as L import Data.Aeson import Data.Aeson.Internal (JSONPathElement (Key), ()) import Data.Aeson.QQ +import Data.Proxy import Data.Text +import Data.UUID as UUID +import Data.UUID.V4 as UUID +import GHC.Stack +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import Language.Haskell.TH.Quote import Network.HTTP.Types +import Network.Wai (Application) import Network.Wai.Test (SResponse) -import Test.Hspec.Wai hiding (post, put, patch) +import Test.Hspec.Expectations (expectationFailure) +import Test.Hspec.Wai hiding (post, put, patch, shouldRespondWith) import Test.Hspec.Wai.Matcher (bodyEquals) -import Data.Proxy -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Test.Hspec.Wai.Matcher (match) import qualified Data.HashMap.Strict as SMap import Web.Scim.Schema.User (UserTypes (..)) @@ -35,16 +48,70 @@ import Web.Scim.Class.Group (GroupTypes (..)) import Web.Scim.Class.Auth (AuthTypes (..)) import Web.Scim.Schema.Schema (Schema (User20, CustomSchema)) +-- | re-implementation of 'shouldRespondWith' with better error reporting. +-- FUTUREWORK: make this a PR upstream. (while we're at it, we can also patch 'WaiSession' +-- and 'request' to keep track of the 'SRequest', and add that to the error message here with +-- the response.) +shouldRespondWith :: HasCallStack => WaiSession SResponse -> ResponseMatcher -> WaiExpectation +shouldRespondWith action matcher = + either (liftIO . expectationFailure) pure =<< doesRespondWith action matcher + +doesRespondWith :: HasCallStack => WaiSession SResponse -> ResponseMatcher -> WaiSession (Either String ()) +doesRespondWith action matcher = do + r <- action + let extmsg = " details: " <> show r <> "\n" + pure $ maybe (Right ()) (Left . (<> extmsg)) (match r matcher) + +shouldEventuallyRespondWith :: HasCallStack => WaiSession SResponse -> ResponseMatcher -> WaiExpectation +shouldEventuallyRespondWith action matcher = + either (liftIO . expectationFailure) pure =<< + Retry.retrying (Retry.exponentialBackoff 66000 <> Retry.limitRetries 6) + (\_ -> pure . either (const True) (const False)) + (\_ -> doesRespondWith action matcher) + +data AcceptanceConfig tag = AcceptanceConfig + { scimAppAndConfig :: IO (Application, AcceptanceQueryConfig tag) + , genUserName :: IO Text + , responsesFullyKnown :: Bool -- ^ some acceptance tests match against a fully rendered + -- response body, which will now work when running the test + -- as a library user (since the response will have more and + -- other information). if you leave this on 'False' (default + -- from 'defAcceptanceConfig'), the test will only check some + -- invariants on the response instead that must hold in all + -- cases. + } + +defAcceptanceConfig :: IO Application -> AcceptanceConfig tag +defAcceptanceConfig scimApp = AcceptanceConfig{..} + where + scimAppAndConfig = (, defAcceptanceQueryConfig) <$> scimApp + genUserName = ("Test_User_" <>) . UUID.toText <$> UUID.nextRandom + responsesFullyKnown = False + +data AcceptanceQueryConfig tag = AcceptanceQueryConfig + { scimPathPrefix :: BS.ByteString + , scimAuthToken :: BS.ByteString + } + +defAcceptanceQueryConfig :: AcceptanceQueryConfig tag +defAcceptanceQueryConfig = AcceptanceQueryConfig{..} + where + scimPathPrefix = "" + scimAuthToken = "authorized" + ---------------------------------------------------------------------------- -- Redefine wai test helpers to include scim+json content type -- | avoid multiple @/@. (kill at most one @/@ at the end of first arg and beginning of -- second arg, resp., then add one during concatenation. +-- +-- >>> ["a" "b", "a" "/b", "a/" "b", "a/" "/b"] +-- ["a/b","a/b","a/b","a/b"] () :: ByteString -> ByteString -> ByteString () a b = a' <> "/" <> b' where - a' = maybe a fst $ BS.unsnoc a - b' = maybe b snd $ BS.uncons b + a' = maybe a (\(t,l) -> if l == '/' then t else a) $ BS8.unsnoc a + b' = maybe b (\(h,t) -> if h == '/' then t else b) $ BS8.uncons b post :: ByteString -> L.ByteString -> WaiSession SResponse post path = request methodPost path [(hContentType, "application/scim+json")] @@ -55,22 +122,23 @@ put path = request methodPut path [(hContentType, "application/scim+json")] patch :: ByteString -> L.ByteString -> WaiSession SResponse patch path = request methodPatch path [(hContentType, "application/scim+json")] -get' :: ByteString -> ByteString -> WaiSession SResponse -get' prefix path = request methodGet (prefix path) [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] "" - -post' :: ByteString -> ByteString -> L.ByteString -> WaiSession SResponse -post' prefix path = request methodPost (prefix path) [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] +request' :: Method -> AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession SResponse +request' method (AcceptanceQueryConfig prefix token) path = request method (prefix path) [(hAuthorization, token), (hContentType, "application/scim+json")] -put' :: ByteString -> ByteString -> L.ByteString -> WaiSession SResponse -put' prefix path = request methodPut (prefix path) [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] +get' :: AcceptanceQueryConfig tag -> ByteString -> WaiSession SResponse +get' cfg path = request' methodGet cfg path "" -patch' :: ByteString -> ByteString -> L.ByteString -> WaiSession SResponse -patch' prefix path = request methodPatch (prefix path) [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] +post' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession SResponse +post' = request' methodPost -delete' :: ByteString -> ByteString -> L.ByteString -> WaiSession SResponse -delete' prefix path = request methodDelete (prefix path) [(hAuthorization, "authorized"), (hContentType, "application/scim+json")] +put' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession SResponse +put' = request' methodPut +patch' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession SResponse +patch' = request' methodPatch +delete' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession SResponse +delete' = request' methodDelete ---------------------------------------------------------------------------- diff --git a/test/Test/AcceptanceSpec.hs b/test/Test/AcceptanceSpec.hs index f51ae9f055d..f18fe18551d 100644 --- a/test/Test/AcceptanceSpec.hs +++ b/test/Test/AcceptanceSpec.hs @@ -6,7 +6,7 @@ import Web.Scim.Server (app) import Web.Scim.Server.Mock import Web.Scim.Capabilities.MetaSchema (empty) -import Web.Scim.Test.Acceptance (microsoftAzure) +import Web.Scim.Test.Acceptance (microsoftAzure, defAcceptanceConfig, responsesFullyKnown) spec :: Spec @@ -16,4 +16,4 @@ spec = do storage <- emptyTestStorage pure (app @Mock empty (nt storage)) - describe "Azure" $ microsoftAzure "" app' + describe "Azure" $ microsoftAzure ((defAcceptanceConfig @Mock app') { responsesFullyKnown = True }) diff --git a/test/Test/Capabilities/MetaSchemaSpec.hs b/test/Test/Capabilities/MetaSchemaSpec.hs index bcfae33fce8..7b5a6e2348b 100644 --- a/test/Test/Capabilities/MetaSchemaSpec.hs +++ b/test/Test/Capabilities/MetaSchemaSpec.hs @@ -17,7 +17,7 @@ import Servant.API.Generic import Test.Hspec hiding (shouldSatisfy) import qualified Test.Hspec.Expectations as Expect -import Test.Hspec.Wai hiding (post, put, patch) +import Test.Hspec.Wai hiding (post, put, patch, shouldRespondWith) app :: IO Application app = do diff --git a/test/Test/Class/GroupSpec.hs b/test/Test/Class/GroupSpec.hs index a4078d20ab5..e04cc8747cd 100644 --- a/test/Test/Class/GroupSpec.hs +++ b/test/Test/Class/GroupSpec.hs @@ -10,7 +10,7 @@ import Web.Scim.Server (mkapp, GroupAPI, groupServer) import Web.Scim.Server.Mock import Data.ByteString.Lazy (ByteString) import Test.Hspec hiding (shouldSatisfy) -import Test.Hspec.Wai hiding (post, put, patch) +import Test.Hspec.Wai hiding (post, put, patch, shouldRespondWith) import Servant.API.Generic app :: IO Application @@ -75,7 +75,7 @@ groups = [scim| "id":"0", "meta":{ "resourceType":"Group", - "location":"todo", + "location":"https://example.com/Users/id", "created":"2018-01-01T00:00:00Z", "version":"W/\"testVersion\"", "lastModified":"2018-01-01T00:00:00Z" @@ -95,7 +95,7 @@ admins = [scim| "id":"0", "meta":{ "resourceType":"Group", - "location":"todo", + "location":"https://example.com/Users/id", "created":"2018-01-01T00:00:00Z", "version":"W/\"testVersion\"", "lastModified":"2018-01-01T00:00:00Z" @@ -126,7 +126,7 @@ updatedAdmins0 = [scim| "id":"0", "meta":{ "resourceType":"Group", - "location":"todo", + "location":"https://example.com/Users/id", "created":"2018-01-01T00:00:00Z", "version":"W/\"testVersion\"", "lastModified":"2018-01-01T00:00:00Z" diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index 99f80903f19..223fc8fc0ae 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -7,7 +7,7 @@ import Web.Scim.Test.Util import Web.Scim.Server (mkapp, UserAPI, userServer) import Web.Scim.Server.Mock import Test.Hspec -import Test.Hspec.Wai hiding (post, put, patch) +import Test.Hspec.Wai hiding (post, put, patch, shouldRespondWith) import Data.ByteString.Lazy (ByteString) import Servant (Proxy(Proxy)) import Network.Wai (Application) @@ -96,7 +96,7 @@ spec = beforeAll app $ do "id": "0", "meta": { "resourceType": "User", - "location": "todo", + "location": "https://example.com/Users/id", "created": "2018-01-01T00:00:00Z", "version": "W/\"testVersion\"", "lastModified": "2018-01-01T00:00:00Z" @@ -122,7 +122,7 @@ spec = beforeAll app $ do "id": "0", "meta": { "resourceType": "User", - "location": "todo", + "location": "https://example.com/Users/id", "created": "2018-01-01T00:00:00Z", "version": "W/\"testVersion\"", "lastModified": "2018-01-01T00:00:00Z" @@ -148,7 +148,7 @@ spec = beforeAll app $ do "id": "0", "meta": { "resourceType": "User", - "location": "todo", + "location": "https://example.com/Users/id", "created": "2018-01-01T00:00:00Z", "version": "W/\"testVersion\"", "lastModified": "2018-01-01T00:00:00Z" @@ -201,7 +201,7 @@ spec = beforeAll app $ do "id": "0", "meta": { "resourceType": "User", - "location": "todo", + "location": "https://example.com/Users/id", "created": "2018-01-01T00:00:00Z", "version": "W/\"testVersion\"", "lastModified": "2018-01-01T00:00:00Z" @@ -227,7 +227,7 @@ spec = beforeAll app $ do "id": "0", "meta": { "resourceType": "User", - "location": "todo", + "location": "https://example.com/Users/id", "created": "2018-01-01T00:00:00Z", "version": "W/\"testVersion\"", "lastModified": "2018-01-01T00:00:00Z" @@ -253,7 +253,7 @@ spec = beforeAll app $ do "id": "0", "meta": { "resourceType": "User", - "location": "todo", + "location": "https://example.com/Users/id", "created": "2018-01-01T00:00:00Z", "version": "W/\"testVersion\"", "lastModified": "2018-01-01T00:00:00Z" @@ -306,7 +306,7 @@ spec = beforeAll app $ do "id": "0", "meta": { "resourceType": "User", - "location": "todo", + "location": "https://example.com/Users/id", "created": "2018-01-01T00:00:00Z", "version": "W/\"testVersion\"", "lastModified": "2018-01-01T00:00:00Z" @@ -342,7 +342,7 @@ smallUserGet = [scim| "id": "0", "meta": { "resourceType": "User", - "location": "todo", + "location": "https://example.com/Users/id", "created": "2018-01-01T00:00:00Z", "version": "W/\"testVersion\"", "lastModified": "2018-01-01T00:00:00Z" @@ -387,7 +387,7 @@ barbara = [scim| "externalId":"bjensen", "meta":{ "resourceType":"User", - "location":"todo", + "location":"https://example.com/Users/id", "created":"2018-01-01T00:00:00Z", "version":"W/\"testVersion\"", "lastModified":"2018-01-01T00:00:00Z" @@ -412,7 +412,7 @@ allUsers = [scim| }, "meta":{ "resourceType":"User", - "location":"todo", + "location":"https://example.com/Users/id", "created":"2018-01-01T00:00:00Z", "version":"W/\"testVersion\"", "lastModified":"2018-01-01T00:00:00Z" @@ -429,7 +429,7 @@ allUsers = [scim| }, "meta":{ "resourceType":"User", - "location":"todo", + "location":"https://example.com/Users/id", "created":"2018-01-01T00:00:00Z", "version":"W/\"testVersion\"", "lastModified":"2018-01-01T00:00:00Z" @@ -455,7 +455,7 @@ onlyBarbara = [scim| }, "meta":{ "resourceType":"User", - "location":"todo", + "location":"https://example.com/Users/id", "created":"2018-01-01T00:00:00Z", "version":"W/\"testVersion\"", "lastModified":"2018-01-01T00:00:00Z" @@ -510,7 +510,7 @@ updatedBarb0 = [scim| ], "meta":{ "resourceType":"User", - "location":"todo", + "location":"https://example.com/Users/id", "created":"2018-01-01T00:00:00Z", "version":"W/\"testVersion\"", "lastModified":"2018-01-01T00:00:00Z" From a82db55e684f1e952c03b1d38416860c49bc7c09 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 13 Mar 2020 20:23:36 +0100 Subject: [PATCH 39/64] ormolu tooling. --- Makefile | 14 ++++++++ README.md | 6 ++++ stack.yaml | 2 ++ tools/ormolu.sh | 90 +++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 112 insertions(+) create mode 100644 Makefile create mode 100755 tools/ormolu.sh diff --git a/Makefile b/Makefile new file mode 100644 index 00000000000..ac61b453344 --- /dev/null +++ b/Makefile @@ -0,0 +1,14 @@ +# formats all Haskell files (which don't contain CPP) +.PHONY: format +format: + ./tools/ormolu.sh + +# formats all Haskell files even if local changes are not committed to git +.PHONY: formatf +formatf: + ./tools/ormolu.sh -f + +# checks that all Haskell files are formatted; fail if a `make format` run is needed. +.PHONY: formatc +formatc: + ./tools/ormolu.sh -c diff --git a/README.md b/README.md index f83eaaec306..51837f77ee1 100644 --- a/README.md +++ b/README.md @@ -25,3 +25,9 @@ for tests. You can run the tests with the standard stack interface: ```sh stack test ``` + +# Contributing + +Before submitting a PR, make sure to install [ormolu](https://github.com/tweag/ormolu) +by doing `stack install ormolu` (we pin the version in our `stack.yaml` file) +and run `make format`. diff --git a/stack.yaml b/stack.yaml index f65f4f731a0..6b898ad9e77 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,6 +10,8 @@ extra-deps: - primitive-0.7.0.0@sha256:ee352d97cc390d8513530029a2213a95c179a66c406906b18d03702c1d9ab8e5,3416 - primitive-extras-0.8@sha256:fca0310150496867f5b9421fe1541ecda87fae17eae44885a29f9c52dd00c8ff,2963 - primitive-unlifted-0.1.2.0@sha256:9c3df73af54ed19fb3f4874da19334863cc414b22e578e27b5f52beeac4a60dd,1360 +- ormolu-0.0.3.1 +- ghc-lib-parser-8.8.2.20200205@sha256:343f889f7b29f5ec07cf0d18d2a53f250fa5c002b6468a6a05b385d0191b8d34,8408 # for ormolu-0.0.3.1 nix: packages: diff --git a/tools/ormolu.sh b/tools/ormolu.sh new file mode 100755 index 00000000000..68680626f66 --- /dev/null +++ b/tools/ormolu.sh @@ -0,0 +1,90 @@ +#!/usr/bin/env bash + +cd "$( dirname "${BASH_SOURCE[0]}" )/.." + +command -v grep >/dev/null 2>&1 || { echo >&2 "grep is not installed, aborting."; exit 1; } +command -v awk >/dev/null 2>&1 || { echo >&2 "awk is not installed, aborting."; exit 1; } +command -v sed >/dev/null 2>&1 || { echo >&2 "sed is not installed, aborting."; exit 1; } +command -v yq >/dev/null 2>&1 || { echo >&2 "yq is not installed, aborting. See https://github.com/mikefarah/yq"; exit 1; } + +ORMOLU_VERSION=$(yq read stack.yaml 'extra-deps[*]' | sed -n 's/ormolu-//p') +( ormolu -v 2>/dev/null | grep -q $ORMOLU_VERSION ) || ( echo "please install ormolu $ORMOLU_VERSION (eg., run 'stack install ormolu' and ensure ormolu is on your PATH.)"; exit 1 ) +echo "ormolu version: $ORMOLU_VERSION" + +ARG_ALLOW_DIRTY_WC="0" +ARG_ORMOLU_MODE="inplace" + +USAGE=" +This bash script can either (a) apply ormolu formatting in-place to +all haskell modules in your working copy, or (b) check all modules for +formatting and fail if ormolu needs to be applied. + +(a) is mostly for migrating from manually-formatted projects to +ormolu-formatted ones; (b) can be run in by a continuous integration +service to make sure no branches with non-ormolu formatting make get +merged. + +For every-day dev work, consider using one of the ormolu editor +integrations (see https://github.com/tweag/ormolu#editor-integration). + +USAGE: $0 + -h: show this help. + -f: run even if working copy is dirty. default: ${ARG_ALLOW_DIRTY_WC} + -c: set ormolu mode to 'check'. default: 'inplace' + +" + +# Option parsing: +# https://sookocheff.com/post/bash/parsing-bash-script-arguments-with-shopts/ +while getopts ":fch" opt; do + case ${opt} in + f ) ARG_ALLOW_DIRTY_WC="1" + ;; + c ) ARG_ORMOLU_MODE="check" + ;; + h ) echo "$USAGE" 1>&2 + exit 0 + ;; + esac +done +shift $((OPTIND -1)) + +if [ "$#" -ne 0 ]; then + echo "$USAGE" 1>&2 + exit 1 +fi + +if [ "$(git status -s | grep -v \?\?)" != "" ]; then + echo "working copy not clean." + if [ "$ARG_ALLOW_DIRTY_WC" == "1" ]; then + echo "running with -f. this will mix ormolu and other changes." + else + echo "run with -f if you want to force mixing ormolu and other changes." + exit 1 + fi +fi + +LANGUAGE_EXTS=$(yq read package.yaml 'default-extensions[*]' | awk '{print "--ghc-opt -X" $0}' ORS=' ') +echo "ormolu mode: $ARG_ORMOLU_MODE" +echo "language extensions: $LANGUAGE_EXTS" + +FAILURES=0 + +for hsfile in $(git grep -L "LANGUAGE CPP" | grep '\.hs$'); do + FAILED=0 + ormolu --mode $ARG_ORMOLU_MODE --check-idempotency $LANGUAGE_EXTS "$hsfile" || FAILED=1 + if [ "$FAILED" == "1" ]; then + ((FAILURES++)) + echo "$hsfile... *** FAILED" + else + echo "$hsfile... ok" + fi +done + +if [ "$FAILURES" != 0 ]; then + echo "ormolu failed on $FAILURES files." + if [ "$ARG_ORMOLU_MODE" == "check" ]; then + echo -en "\n\nyou can fix this by running 'make format' from the git repo root.\n\n" + fi + exit 1 +fi From 1baca97f6525eeca5531a2686589312fdbc9c65d Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 13 Mar 2020 20:24:21 +0100 Subject: [PATCH 40/64] run ormolu (noisy commit!) --- Setup.hs | 1 + server/Main.hs | 89 ++--- src/Web/Scim/AttrName.hs | 14 +- src/Web/Scim/Capabilities/MetaSchema.hs | 209 ++++++------ src/Web/Scim/Capabilities/MetaSchema/Group.hs | 8 +- .../Capabilities/MetaSchema/ResourceType.hs | 8 +- .../Scim/Capabilities/MetaSchema/SPConfig.hs | 8 +- .../Scim/Capabilities/MetaSchema/Schema.hs | 8 +- src/Web/Scim/Capabilities/MetaSchema/User.hs | 8 +- src/Web/Scim/Class/Auth.hs | 13 +- src/Web/Scim/Class/Group.hs | 219 ++++++------ src/Web/Scim/Class/User.hs | 210 ++++++------ src/Web/Scim/ContentType.hs | 24 +- src/Web/Scim/Filter.hs | 187 ++++++----- src/Web/Scim/Handler.hs | 17 +- src/Web/Scim/Schema/AuthenticationScheme.hs | 71 ++-- src/Web/Scim/Schema/Common.hs | 40 +-- src/Web/Scim/Schema/Error.hs | 172 +++++----- src/Web/Scim/Schema/ListResponse.hs | 53 +-- src/Web/Scim/Schema/Meta.hs | 60 ++-- src/Web/Scim/Schema/PatchOp.hs | 45 +-- src/Web/Scim/Schema/ResourceType.hs | 45 +-- src/Web/Scim/Schema/Schema.hs | 41 +-- src/Web/Scim/Schema/User.hs | 314 +++++++++--------- src/Web/Scim/Schema/User/Address.hs | 27 +- src/Web/Scim/Schema/User/Certificate.hs | 15 +- src/Web/Scim/Schema/User/Email.hs | 24 +- src/Web/Scim/Schema/User/IM.hs | 14 +- src/Web/Scim/Schema/User/Name.hs | 21 +- src/Web/Scim/Schema/User/Phone.hs | 13 +- src/Web/Scim/Schema/User/Photo.hs | 13 +- src/Web/Scim/Schema/UserTypes.hs | 3 + src/Web/Scim/Server.hs | 134 +++++--- src/Web/Scim/Server/Mock.hs | 123 +++---- src/Web/Scim/Test/Acceptance.hs | 84 ++--- src/Web/Scim/Test/Util.hs | 160 +++++---- test/Test/AcceptanceSpec.hs | 22 +- test/Test/Capabilities/MetaSchemaSpec.hs | 58 ++-- test/Test/Class/AuthSpec.hs | 31 +- test/Test/Class/GroupSpec.hs | 63 ++-- test/Test/Class/UserSpec.hs | 216 +++++++----- test/Test/FilterSpec.hs | 62 ++-- test/Test/Schema/PatchOpSpec.hs | 99 +++--- test/Test/Schema/UserSpec.hs | 284 ++++++++-------- 44 files changed, 1779 insertions(+), 1551 deletions(-) diff --git a/Setup.hs b/Setup.hs index 9a994af677b..e8ef27dbba9 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/server/Main.hs b/server/Main.hs index 5ef890f2a45..83ee3cbef2b 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -2,23 +2,22 @@ module Main where -import Web.Scim.Server -import Web.Scim.Server.Mock -import Web.Scim.Schema.Schema (Schema (User20)) -import Web.Scim.Schema.Meta hiding (meta) -import Web.Scim.Schema.Common as Common -import Web.Scim.Schema.ResourceType hiding (name) -import Web.Scim.Schema.User as User -import Web.Scim.Schema.User.Name -import Web.Scim.Schema.User.Email as E -import Web.Scim.Capabilities.MetaSchema as MetaSchema - -import Data.Time -import Network.Wai.Handler.Warp -import Network.URI.Static +import Control.Monad.STM (atomically) +import Data.Time +import Network.URI.Static +import Network.Wai.Handler.Warp import qualified StmContainers.Map as STMMap -import Control.Monad.STM (atomically) -import Text.Email.Validate +import Text.Email.Validate +import Web.Scim.Capabilities.MetaSchema as MetaSchema +import Web.Scim.Schema.Common as Common +import Web.Scim.Schema.Meta hiding (meta) +import Web.Scim.Schema.ResourceType hiding (name) +import Web.Scim.Schema.Schema (Schema (User20)) +import Web.Scim.Schema.User as User +import Web.Scim.Schema.User.Email as E +import Web.Scim.Schema.User.Name +import Web.Scim.Server +import Web.Scim.Server.Mock main :: IO () main = do @@ -34,34 +33,42 @@ mkUserDB :: IO UserStorage mkUserDB = do db <- STMMap.newIO now <- getCurrentTime - let meta = Meta - { resourceType = UserResource - , created = now - , lastModified = now - , version = Weak "0" -- we don't support etags - , location = Common.URI [relativeReference|/Users/sample-user|] - } + let meta = + Meta + { resourceType = UserResource, + created = now, + lastModified = now, + version = Weak "0", -- we don't support etags + location = Common.URI [relativeReference|/Users/sample-user|] + } -- Note: Okta required at least one email, 'active', 'name.familyName', -- and 'name.givenName'. We might want to be able to express these -- constraints in code (and in the schema we serve) without turning this -- library into something that is Okta-specific. - let email = Email - { E.typ = Just "work" - , E.value = maybe (error "couldn't parse email") EmailAddress2 - (emailAddress "elton@wire.com") - , E.primary = Nothing - } - let user = (User.empty [User20] "elton" NoUserExtra) - { name = Just Name - { formatted = Just "Elton John" - , familyName = Just "John" - , givenName = Just "Elton" - , middleName = Nothing - , honorificPrefix = Nothing - , honorificSuffix = Nothing - } - , active = Just True - , emails = [email] - } + let email = + Email + { E.typ = Just "work", + E.value = + maybe + (error "couldn't parse email") + EmailAddress2 + (emailAddress "elton@wire.com"), + E.primary = Nothing + } + let user = + (User.empty [User20] "elton" NoUserExtra) + { name = + Just + Name + { formatted = Just "Elton John", + familyName = Just "John", + givenName = Just "Elton", + middleName = Nothing, + honorificPrefix = Nothing, + honorificSuffix = Nothing + }, + active = Just True, + emails = [email] + } atomically $ STMMap.insert (WithMeta meta (WithId (Id 0) user)) (Id 0) db pure db diff --git a/src/Web/Scim/AttrName.hs b/src/Web/Scim/AttrName.hs index 6cd400102f9..984f7d428c7 100644 --- a/src/Web/Scim/AttrName.hs +++ b/src/Web/Scim/AttrName.hs @@ -1,14 +1,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- | Scim attribute names. these are case-insensitive module Web.Scim.AttrName where -import Prelude hiding (takeWhile) -import Data.Text (Text, toCaseFold, cons) -import Data.Text.Encoding (decodeUtf8) -import Data.String (IsString, fromString) -import Data.Aeson.Types (ToJSONKey, FromJSONKey) +import Data.Aeson.Types (FromJSONKey, ToJSONKey) import Data.Attoparsec.ByteString.Char8 import Data.Hashable +import Data.String (IsString, fromString) +import Data.Text (Text, cons, toCaseFold) +import Data.Text.Encoding (decodeUtf8) +import Prelude hiding (takeWhile) -- | An attribute (e.g. username). -- @@ -16,7 +17,8 @@ import Data.Hashable -- NOTE: We use the FromJSONKey instance of Text. The default instances parses -- a list of key values instead of a map newtype AttrName - = AttrName Text deriving (Show, FromJSONKey, ToJSONKey) + = AttrName Text + deriving (Show, FromJSONKey, ToJSONKey) instance Eq AttrName where AttrName a == AttrName b = toCaseFold a == toCaseFold b diff --git a/src/Web/Scim/Capabilities/MetaSchema.hs b/src/Web/Scim/Capabilities/MetaSchema.hs index 4f32f274d93..3cddd93799b 100644 --- a/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/src/Web/Scim/Capabilities/MetaSchema.hs @@ -1,119 +1,136 @@ -module Web.Scim.Capabilities.MetaSchema ( - ConfigSite - , configServer - , Supported (..) - , BulkConfig (..) - , FilterConfig (..) - , Configuration (..) - , empty - ) where +module Web.Scim.Capabilities.MetaSchema + ( ConfigSite, + configServer, + Supported (..), + BulkConfig (..), + FilterConfig (..), + Configuration (..), + empty, + ) +where -import Web.Scim.Schema.Schema -import Web.Scim.Schema.Common -import Web.Scim.Schema.Error hiding (schemas) -import Web.Scim.Schema.ResourceType hiding (schema) -import Web.Scim.Schema.AuthenticationScheme -import Web.Scim.Schema.ListResponse as ListResponse hiding (schemas) -import Web.Scim.Capabilities.MetaSchema.User -import Web.Scim.Capabilities.MetaSchema.SPConfig -import Web.Scim.Capabilities.MetaSchema.Group -import Web.Scim.Capabilities.MetaSchema.Schema -import Web.Scim.Capabilities.MetaSchema.ResourceType -import Web.Scim.ContentType -import Web.Scim.Handler -import Data.Aeson +import Data.Aeson import qualified Data.HashMap.Lazy as HML -import Data.Text (Text) -import GHC.Generics (Generic) -import Servant hiding (URI) -import Servant.API.Generic -import Servant.Server.Generic - -import Prelude hiding (filter) +import Data.Text (Text) +import GHC.Generics (Generic) +import Servant hiding (URI) +import Servant.API.Generic +import Servant.Server.Generic +import Web.Scim.Capabilities.MetaSchema.Group +import Web.Scim.Capabilities.MetaSchema.ResourceType +import Web.Scim.Capabilities.MetaSchema.SPConfig +import Web.Scim.Capabilities.MetaSchema.Schema +import Web.Scim.Capabilities.MetaSchema.User +import Web.Scim.ContentType +import Web.Scim.Handler +import Web.Scim.Schema.AuthenticationScheme +import Web.Scim.Schema.Common +import Web.Scim.Schema.Error hiding (schemas) +import Web.Scim.Schema.ListResponse as ListResponse hiding (schemas) +import Web.Scim.Schema.ResourceType hiding (schema) +import Web.Scim.Schema.Schema +import Prelude hiding (filter) -data Supported a = Supported - { supported :: Bool - , subConfig :: a - } deriving (Show, Eq, Generic) +data Supported a + = Supported + { supported :: Bool, + subConfig :: a + } + deriving (Show, Eq, Generic) instance ToJSON a => ToJSON (Supported a) where toJSON (Supported b v) = case toJSON v of (Object o) -> Object $ HML.insert "supported" (Bool b) o - _ -> Object $ HML.fromList [("supported", Bool b)] + _ -> Object $ HML.fromList [("supported", Bool b)] - -data BulkConfig = BulkConfig - { maxOperations :: Int - , maxPayloadSize :: Int - } deriving (Show, Eq, Generic) +data BulkConfig + = BulkConfig + { maxOperations :: Int, + maxPayloadSize :: Int + } + deriving (Show, Eq, Generic) instance ToJSON BulkConfig where toJSON = genericToJSON serializeOptions -data FilterConfig = FilterConfig - { maxResults :: Int - } deriving (Show, Eq, Generic) +data FilterConfig + = FilterConfig + { maxResults :: Int + } + deriving (Show, Eq, Generic) instance ToJSON FilterConfig where toJSON = genericToJSON serializeOptions -data Configuration = Configuration - { documentationUri :: Maybe URI - , schemas :: [Schema] - , patch :: Supported () - , bulk :: Supported BulkConfig - , filter :: Supported FilterConfig - , changePassword :: Supported () - , sort :: Supported () - , etag :: Supported () - , authenticationSchemes :: [AuthenticationSchemeEncoding] - } deriving (Show, Eq, Generic) +data Configuration + = Configuration + { documentationUri :: Maybe URI, + schemas :: [Schema], + patch :: Supported (), + bulk :: Supported BulkConfig, + filter :: Supported FilterConfig, + changePassword :: Supported (), + sort :: Supported (), + etag :: Supported (), + authenticationSchemes :: [AuthenticationSchemeEncoding] + } + deriving (Show, Eq, Generic) instance ToJSON Configuration where toJSON = genericToJSON serializeOptions empty :: Configuration -empty = Configuration - { documentationUri = Nothing - , schemas = [ User20 - , ServiceProviderConfig20 - , Group20 - , Schema20 - , ResourceType20 - ] - , patch = Supported True () - , bulk = Supported False $ BulkConfig 0 0 - , filter = Supported False $ FilterConfig 0 - , changePassword = Supported False () - , sort = Supported False () - , etag = Supported False () - , authenticationSchemes = [authHttpBasicEncoding] - } +empty = + Configuration + { documentationUri = Nothing, + schemas = + [ User20, + ServiceProviderConfig20, + Group20, + Schema20, + ResourceType20 + ], + patch = Supported True (), + bulk = Supported False $ BulkConfig 0 0, + filter = Supported False $ FilterConfig 0, + changePassword = Supported False (), + sort = Supported False (), + etag = Supported False (), + authenticationSchemes = [authHttpBasicEncoding] + } -configServer - :: Monad m - => Configuration -> ConfigSite (AsServerT (ScimHandler m)) -configServer config = ConfigSite - { spConfig = pure config - , getSchemas = pure $ - ListResponse.fromList [ userSchema - , spConfigSchema - , groupSchema - , metaSchema - , resourceSchema - ] - , schema = \uri -> case getSchema (fromSchemaUri uri) of - Nothing -> throwScim (notFound "Schema" uri) - Just s -> pure s - , resourceTypes = pure $ - ListResponse.fromList [ usersResource - , groupsResource - ] - } +configServer :: + Monad m => + Configuration -> + ConfigSite (AsServerT (ScimHandler m)) +configServer config = + ConfigSite + { spConfig = pure config, + getSchemas = + pure $ + ListResponse.fromList + [ userSchema, + spConfigSchema, + groupSchema, + metaSchema, + resourceSchema + ], + schema = \uri -> case getSchema (fromSchemaUri uri) of + Nothing -> throwScim (notFound "Schema" uri) + Just s -> pure s, + resourceTypes = + pure $ + ListResponse.fromList + [ usersResource, + groupsResource + ] + } -data ConfigSite route = ConfigSite - { spConfig :: route :- "ServiceProviderConfig" :> Get '[SCIM] Configuration - , getSchemas :: route :- "Schemas" :> Get '[SCIM] (ListResponse Value) - , schema :: route :- "Schemas" :> Capture "id" Text :> Get '[SCIM] Value - , resourceTypes :: route :- "ResourceTypes" :> Get '[SCIM] (ListResponse Resource) - } deriving (Generic) +data ConfigSite route + = ConfigSite + { spConfig :: route :- "ServiceProviderConfig" :> Get '[SCIM] Configuration, + getSchemas :: route :- "Schemas" :> Get '[SCIM] (ListResponse Value), + schema :: route :- "Schemas" :> Capture "id" Text :> Get '[SCIM] Value, + resourceTypes :: route :- "ResourceTypes" :> Get '[SCIM] (ListResponse Resource) + } + deriving (Generic) diff --git a/src/Web/Scim/Capabilities/MetaSchema/Group.hs b/src/Web/Scim/Capabilities/MetaSchema/Group.hs index 1050f17ce66..cffbf9820d1 100644 --- a/src/Web/Scim/Capabilities/MetaSchema/Group.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/Group.hs @@ -1,6 +1,9 @@ {-# LANGUAGE QuasiQuotes #-} -module Web.Scim.Capabilities.MetaSchema.Group (groupSchema) where +module Web.Scim.Capabilities.MetaSchema.Group + ( groupSchema, + ) +where import Data.Aeson (Value) import Data.Aeson.QQ @@ -10,7 +13,8 @@ import Data.Aeson.QQ -- now because nobody seems to care about these schemas anyway. -- See https://www.rfc-editor.org/errata_search.php?rfc=7643 groupSchema :: Value -groupSchema = [aesonQQ| +groupSchema = + [aesonQQ| { "id": "urn:ietf:params:scim:schemas:core:2.0:Group", "name": "Group", diff --git a/src/Web/Scim/Capabilities/MetaSchema/ResourceType.hs b/src/Web/Scim/Capabilities/MetaSchema/ResourceType.hs index 865884b0d13..beabbc32829 100644 --- a/src/Web/Scim/Capabilities/MetaSchema/ResourceType.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/ResourceType.hs @@ -1,12 +1,16 @@ {-# LANGUAGE QuasiQuotes #-} -module Web.Scim.Capabilities.MetaSchema.ResourceType (resourceSchema) where +module Web.Scim.Capabilities.MetaSchema.ResourceType + ( resourceSchema, + ) +where import Data.Aeson (Value) import Data.Aeson.QQ resourceSchema :: Value -resourceSchema = [aesonQQ| +resourceSchema = + [aesonQQ| { "id": "urn:ietf:params:scim:schemas:core:2.0:ResourceType", "name": "ResourceType", diff --git a/src/Web/Scim/Capabilities/MetaSchema/SPConfig.hs b/src/Web/Scim/Capabilities/MetaSchema/SPConfig.hs index 67b111b29f0..7b0ae7a991e 100644 --- a/src/Web/Scim/Capabilities/MetaSchema/SPConfig.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/SPConfig.hs @@ -1,6 +1,9 @@ {-# LANGUAGE QuasiQuotes #-} -module Web.Scim.Capabilities.MetaSchema.SPConfig (spConfigSchema) where +module Web.Scim.Capabilities.MetaSchema.SPConfig + ( spConfigSchema, + ) +where import Data.Aeson (Value) import Data.Aeson.QQ @@ -8,7 +11,8 @@ import Data.Aeson.QQ -- NB: it looks like 'authenticationSchemes' should also have a 'type' -- attribute. The sample schema from the RFC doesn't list it, though. spConfigSchema :: Value -spConfigSchema = [aesonQQ| +spConfigSchema = + [aesonQQ| { "id": "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig", "name": "Service Provider Configuration", diff --git a/src/Web/Scim/Capabilities/MetaSchema/Schema.hs b/src/Web/Scim/Capabilities/MetaSchema/Schema.hs index 82792cc1f04..2280561cf8c 100644 --- a/src/Web/Scim/Capabilities/MetaSchema/Schema.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/Schema.hs @@ -1,12 +1,16 @@ {-# LANGUAGE QuasiQuotes #-} -module Web.Scim.Capabilities.MetaSchema.Schema (metaSchema) where +module Web.Scim.Capabilities.MetaSchema.Schema + ( metaSchema, + ) +where import Data.Aeson (Value) import Data.Aeson.QQ metaSchema :: Value -metaSchema = [aesonQQ| +metaSchema = + [aesonQQ| { "id": "urn:ietf:params:scim:schemas:core:2.0:Schema", "name": "Schema", diff --git a/src/Web/Scim/Capabilities/MetaSchema/User.hs b/src/Web/Scim/Capabilities/MetaSchema/User.hs index b5ca1490393..dcb9b3d8b5f 100644 --- a/src/Web/Scim/Capabilities/MetaSchema/User.hs +++ b/src/Web/Scim/Capabilities/MetaSchema/User.hs @@ -1,12 +1,16 @@ {-# LANGUAGE QuasiQuotes #-} -module Web.Scim.Capabilities.MetaSchema.User (userSchema) where +module Web.Scim.Capabilities.MetaSchema.User + ( userSchema, + ) +where import Data.Aeson (Value) import Data.Aeson.QQ userSchema :: Value -userSchema = [aesonQQ| +userSchema = + [aesonQQ| { "id": "urn:ietf:params:scim:schemas:core:2.0:User", "name": "User", diff --git a/src/Web/Scim/Class/Auth.hs b/src/Web/Scim/Class/Auth.hs index ada3585727b..111dec4ca15 100644 --- a/src/Web/Scim/Class/Auth.hs +++ b/src/Web/Scim/Class/Auth.hs @@ -4,9 +4,10 @@ -- auth, or something else (though OAuth is likely not implementable with -- this API). module Web.Scim.Class.Auth - ( AuthTypes (..) - , AuthDB (..) - ) where + ( AuthTypes (..), + AuthDB (..), + ) +where import Servant import Web.Scim.Handler @@ -31,6 +32,6 @@ class (AuthTypes tag, FromHttpApiData (AuthData tag)) => AuthDB tag m where -- | Do authentication or throw an error in `ScimHandler` (e.g. -- 'Web.Scim.Schema.Error.unauthorized') if the provided credentials are -- invalid or don't correspond to any user. - authCheck - :: Maybe (AuthData tag) - -> ScimHandler m (AuthInfo tag) + authCheck :: + Maybe (AuthData tag) -> + ScimHandler m (AuthInfo tag) diff --git a/src/Web/Scim/Class/Group.hs b/src/Web/Scim/Class/Group.hs index 99056927f63..2491c2dfaa6 100644 --- a/src/Web/Scim/Class/Group.hs +++ b/src/Web/Scim/Class/Group.hs @@ -1,29 +1,29 @@ {-# LANGUAGE AllowAmbiguousTypes #-} module Web.Scim.Class.Group - ( GroupSite (..) - , GroupDB (..) - , GroupTypes (..) - , StoredGroup - , Group (..) - , Member (..) - , groupServer - ) where - -import Data.Text -import Data.Aeson -import GHC.Generics (Generic) -import Web.Scim.Schema.Common -import Web.Scim.Schema.Meta -import Web.Scim.Schema.ListResponse -import Web.Scim.ContentType -import Web.Scim.Handler -import Web.Scim.Class.Auth -import Servant -import Servant.API.Generic -import Servant.Server.Generic - + ( GroupSite (..), + GroupDB (..), + GroupTypes (..), + StoredGroup, + Group (..), + Member (..), + groupServer, + ) +where + +import Data.Aeson import qualified Data.Aeson as Aeson +import Data.Text +import GHC.Generics (Generic) +import Servant +import Servant.API.Generic +import Servant.Server.Generic +import Web.Scim.Class.Auth +import Web.Scim.ContentType +import Web.Scim.Handler +import Web.Scim.Schema.Common +import Web.Scim.Schema.ListResponse +import Web.Scim.Schema.Meta ---------------------------------------------------------------------------- -- /Groups API @@ -36,11 +36,13 @@ class GroupTypes tag where type GroupId tag -- TODO -data Member = Member - { value :: Text - , typ :: Text - , ref :: Text - } deriving (Show, Eq, Generic) +data Member + = Member + { value :: Text, + typ :: Text, + ref :: Text + } + deriving (Show, Eq, Generic) instance FromJSON Member where parseJSON = genericParseJSON parseOptions . jsonLower @@ -48,11 +50,12 @@ instance FromJSON Member where instance ToJSON Member where toJSON = genericToJSON serializeOptions -data Group = Group - { schemas :: [Schema] - , displayName :: Text - , members :: [Member] - } +data Group + = Group + { schemas :: [Schema], + displayName :: Text, + members :: [Member] + } deriving (Show, Eq, Generic) instance FromJSON Group where @@ -63,62 +66,70 @@ instance ToJSON Group where type StoredGroup tag = WithMeta (WithId (GroupId tag) Group) -data GroupSite tag route = GroupSite - { gsGetGroups :: route :- - Get '[SCIM] (ListResponse (StoredGroup tag)) - , gsGetGroup :: route :- - Capture "id" (GroupId tag) :> - Get '[SCIM] (StoredGroup tag) - , gsPostGroup :: route :- - ReqBody '[SCIM] Group :> - PostCreated '[SCIM] (StoredGroup tag) - , gsPutGroup :: route :- - Capture "id" (GroupId tag) :> - ReqBody '[SCIM] Group :> - Put '[SCIM] (StoredGroup tag) - , gsPatchGroup :: route :- - Capture "id" (GroupId tag) :> - ReqBody '[SCIM] Aeson.Value :> - Patch '[SCIM] (StoredGroup tag) - , gsDeleteGroup :: route :- - Capture "id" (GroupId tag) :> - DeleteNoContent '[SCIM] NoContent - } deriving (Generic) +data GroupSite tag route + = GroupSite + { gsGetGroups :: + route + :- Get '[SCIM] (ListResponse (StoredGroup tag)), + gsGetGroup :: + route + :- Capture "id" (GroupId tag) + :> Get '[SCIM] (StoredGroup tag), + gsPostGroup :: + route + :- ReqBody '[SCIM] Group + :> PostCreated '[SCIM] (StoredGroup tag), + gsPutGroup :: + route + :- Capture "id" (GroupId tag) + :> ReqBody '[SCIM] Group + :> Put '[SCIM] (StoredGroup tag), + gsPatchGroup :: + route + :- Capture "id" (GroupId tag) + :> ReqBody '[SCIM] Aeson.Value + :> Patch '[SCIM] (StoredGroup tag), + gsDeleteGroup :: + route + :- Capture "id" (GroupId tag) + :> DeleteNoContent '[SCIM] NoContent + } + deriving (Generic) ---------------------------------------------------------------------------- -- Methods used by the API class (Monad m, GroupTypes tag, AuthDB tag m) => GroupDB tag m where -- | Get all groups. - getGroups - :: AuthInfo tag - -> ScimHandler m (ListResponse (StoredGroup tag)) + getGroups :: + AuthInfo tag -> + ScimHandler m (ListResponse (StoredGroup tag)) -- | Get a single group by ID. -- -- Should throw 'notFound' if the group does not. - getGroup - :: AuthInfo tag - -> GroupId tag - -> ScimHandler m (StoredGroup tag) + getGroup :: + AuthInfo tag -> + GroupId tag -> + ScimHandler m (StoredGroup tag) -- | Create a new group. -- -- Should throw 'conflict' if uniqueness constraints are violated. - postGroup - :: AuthInfo tag - -> Group - -> ScimHandler m (StoredGroup tag) + postGroup :: + AuthInfo tag -> + Group -> + ScimHandler m (StoredGroup tag) -- | Overwrite an existing group. -- -- Should throw 'notFound' if the group does not exist, and 'conflict' if uniqueness -- constraints are violated. - putGroup - :: AuthInfo tag - -> GroupId tag - -> Group - -> ScimHandler m (StoredGroup tag) + putGroup :: + AuthInfo tag -> + GroupId tag -> + Group -> + ScimHandler m (StoredGroup tag) -- | Modify an existing group. -- @@ -127,44 +138,48 @@ class (Monad m, GroupTypes tag, AuthDB tag m) => GroupDB tag m where -- -- FUTUREWORK: add types for PATCH (instead of 'Aeson.Value'). -- See - patchGroup - :: AuthInfo tag - -> GroupId tag - -> Aeson.Value -- ^ PATCH payload - -> ScimHandler m (StoredGroup tag) + patchGroup :: + AuthInfo tag -> + GroupId tag -> + -- | PATCH payload + Aeson.Value -> + ScimHandler m (StoredGroup tag) -- | Delete a group. -- -- Should throw 'notFound' if the group does not exist. - deleteGroup - :: AuthInfo tag - -> GroupId tag - -> ScimHandler m () + deleteGroup :: + AuthInfo tag -> + GroupId tag -> + ScimHandler m () ---------------------------------------------------------------------------- -- API handlers -groupServer - :: forall tag m. (Show (GroupId tag), GroupDB tag m) - => Maybe (AuthData tag) -> GroupSite tag (AsServerT (ScimHandler m)) -groupServer authData = GroupSite - { gsGetGroups = do - auth <- authCheck @tag authData - getGroups @tag auth - , gsGetGroup = \gid -> do - auth <- authCheck @tag authData - getGroup @tag auth gid - , gsPostGroup = \gr -> do - auth <- authCheck @tag authData - postGroup @tag auth gr - , gsPutGroup = \gid gr -> do - auth <- authCheck @tag authData - putGroup @tag auth gid gr - , gsPatchGroup = \gid patch -> do - auth <- authCheck @tag authData - patchGroup @tag auth gid patch - , gsDeleteGroup = \gid -> do - auth <- authCheck @tag authData - deleteGroup @tag auth gid - pure NoContent - } +groupServer :: + forall tag m. + (Show (GroupId tag), GroupDB tag m) => + Maybe (AuthData tag) -> + GroupSite tag (AsServerT (ScimHandler m)) +groupServer authData = + GroupSite + { gsGetGroups = do + auth <- authCheck @tag authData + getGroups @tag auth, + gsGetGroup = \gid -> do + auth <- authCheck @tag authData + getGroup @tag auth gid, + gsPostGroup = \gr -> do + auth <- authCheck @tag authData + postGroup @tag auth gr, + gsPutGroup = \gid gr -> do + auth <- authCheck @tag authData + putGroup @tag auth gid gr, + gsPatchGroup = \gid patch -> do + auth <- authCheck @tag authData + patchGroup @tag auth gid patch, + gsDeleteGroup = \gid -> do + auth <- authCheck @tag authData + deleteGroup @tag auth gid + pure NoContent + } diff --git a/src/Web/Scim/Class/User.hs b/src/Web/Scim/Class/User.hs index 7b5f6c6eb8d..caf83d04878 100644 --- a/src/Web/Scim/Class/User.hs +++ b/src/Web/Scim/Class/User.hs @@ -2,91 +2,99 @@ {-# LANGUAGE DefaultSignatures #-} module Web.Scim.Class.User - ( UserDB (..) - , StoredUser - , UserSite (..) - , userServer - ) where + ( UserDB (..), + StoredUser, + UserSite (..), + userServer, + ) +where -import Data.Aeson.Types (FromJSON) -import GHC.Generics (Generic) -import Web.Scim.Schema.User -import Web.Scim.Schema.PatchOp -import Web.Scim.Schema.Meta -import Web.Scim.Schema.Common -import Web.Scim.Schema.ListResponse hiding (schemas) -import Web.Scim.Handler -import Web.Scim.Filter -import Web.Scim.ContentType -import Web.Scim.Class.Auth -import Servant -import Servant.API.Generic -import Servant.Server.Generic +import Data.Aeson.Types (FromJSON) +import GHC.Generics (Generic) +import Servant +import Servant.API.Generic +import Servant.Server.Generic +import Web.Scim.Class.Auth +import Web.Scim.ContentType +import Web.Scim.Filter +import Web.Scim.Handler +import Web.Scim.Schema.Common +import Web.Scim.Schema.ListResponse hiding (schemas) +import Web.Scim.Schema.Meta +import Web.Scim.Schema.PatchOp +import Web.Scim.Schema.User ---------------------------------------------------------------------------- -- /Users API type StoredUser tag = WithMeta (WithId (UserId tag) (User tag)) -data UserSite tag route = UserSite - { usGetUsers :: route :- - QueryParam "filter" Filter :> - Get '[SCIM] (ListResponse (StoredUser tag)) - , usGetUser :: route :- - Capture "id" (UserId tag) :> - Get '[SCIM] (StoredUser tag) - , usPostUser :: route :- - ReqBody '[SCIM] (User tag) :> - PostCreated '[SCIM] (StoredUser tag) - , usPutUser :: route :- - Capture "id" (UserId tag) :> - ReqBody '[SCIM] (User tag) :> - Put '[SCIM] (StoredUser tag) - , usPatchUser :: route :- - Capture "id" (UserId tag) :> - ReqBody '[SCIM] (PatchOp tag) :> - Patch '[SCIM] (StoredUser tag) - , usDeleteUser :: route :- - Capture "id" (UserId tag) :> - DeleteNoContent '[SCIM] NoContent - } deriving (Generic) +data UserSite tag route + = UserSite + { usGetUsers :: + route + :- QueryParam "filter" Filter + :> Get '[SCIM] (ListResponse (StoredUser tag)), + usGetUser :: + route + :- Capture "id" (UserId tag) + :> Get '[SCIM] (StoredUser tag), + usPostUser :: + route + :- ReqBody '[SCIM] (User tag) + :> PostCreated '[SCIM] (StoredUser tag), + usPutUser :: + route + :- Capture "id" (UserId tag) + :> ReqBody '[SCIM] (User tag) + :> Put '[SCIM] (StoredUser tag), + usPatchUser :: + route + :- Capture "id" (UserId tag) + :> ReqBody '[SCIM] (PatchOp tag) + :> Patch '[SCIM] (StoredUser tag), + usDeleteUser :: + route + :- Capture "id" (UserId tag) + :> DeleteNoContent '[SCIM] NoContent + } + deriving (Generic) ---------------------------------------------------------------------------- -- Methods used by the API class (Monad m, AuthTypes tag, UserTypes tag) => UserDB tag m where -- | Get all users, optionally filtered by a 'Filter'. - getUsers - :: AuthInfo tag - -> Maybe Filter - -> ScimHandler m (ListResponse (StoredUser tag)) + getUsers :: + AuthInfo tag -> + Maybe Filter -> + ScimHandler m (ListResponse (StoredUser tag)) -- | Get a single user by ID. -- -- Should throw 'notFound' if the user doesn't exist. - getUser - :: AuthInfo tag - -> UserId tag - -> ScimHandler m (StoredUser tag) + getUser :: + AuthInfo tag -> + UserId tag -> + ScimHandler m (StoredUser tag) -- | Create a new user. -- -- Should throw 'conflict' if uniqueness constraints are violated. - postUser - :: AuthInfo tag - -> User tag - -> ScimHandler m (StoredUser tag) + postUser :: + AuthInfo tag -> + User tag -> + ScimHandler m (StoredUser tag) -- | Overwrite an existing user. -- -- Should throw 'notFound' if the user doesn't exist, and 'conflict' if -- uniqueness constraints are violated. - -- - putUser - :: AuthInfo tag - -> UserId tag - -> User tag - -> ScimHandler m (StoredUser tag) + putUser :: + AuthInfo tag -> + UserId tag -> + User tag -> + ScimHandler m (StoredUser tag) -- | Modify an existing user. -- @@ -108,18 +116,19 @@ class (Monad m, AuthTypes tag, UserTypes tag) => UserDB tag m where -- followed by a PUT. GET will retrieve the entire record; we then modify -- this record by a series of PATCH operations, and then PUT the entire -- record. - -- - patchUser - :: AuthInfo tag - -> UserId tag - -> PatchOp tag -- ^ PATCH payload - -> ScimHandler m (StoredUser tag) - default patchUser - :: (Patchable (UserExtra tag), FromJSON (UserExtra tag)) - => AuthInfo tag - -> UserId tag - -> PatchOp tag -- ^ PATCH payload - -> ScimHandler m (StoredUser tag) + patchUser :: + AuthInfo tag -> + UserId tag -> + -- | PATCH payload + PatchOp tag -> + ScimHandler m (StoredUser tag) + default patchUser :: + (Patchable (UserExtra tag), FromJSON (UserExtra tag)) => + AuthInfo tag -> + UserId tag -> + -- | PATCH payload + PatchOp tag -> + ScimHandler m (StoredUser tag) patchUser info uid op' = do (WithMeta _ (WithId _ (user :: User tag))) <- getUser info uid (newUser :: User tag) <- applyPatch user op' @@ -128,35 +137,38 @@ class (Monad m, AuthTypes tag, UserTypes tag) => UserDB tag m where -- | Delete a user. -- -- Should throw 'notFound' if the user doesn't exist. - deleteUser - :: AuthInfo tag - -> UserId tag - -> ScimHandler m () + deleteUser :: + AuthInfo tag -> + UserId tag -> + ScimHandler m () ---------------------------------------------------------------------------- -- API handlers -userServer - :: forall tag m. (AuthDB tag m, UserDB tag m) - => Maybe (AuthData tag) -> UserSite tag (AsServerT (ScimHandler m)) -userServer authData = UserSite - { usGetUsers = \mbFilter -> do - auth <- authCheck @tag authData - getUsers @tag auth mbFilter - , usGetUser = \uid -> do - auth <- authCheck @tag authData - getUser @tag auth uid - , usPostUser = \user -> do - auth <- authCheck @tag authData - postUser @tag auth user - , usPutUser = \uid user -> do - auth <- authCheck @tag authData - putUser @tag auth uid user - , usPatchUser = \uid patch -> do - auth <- authCheck @tag authData - patchUser @tag @m auth uid patch - , usDeleteUser = \uid -> do - auth <- authCheck @tag authData - deleteUser @tag auth uid - pure NoContent - } +userServer :: + forall tag m. + (AuthDB tag m, UserDB tag m) => + Maybe (AuthData tag) -> + UserSite tag (AsServerT (ScimHandler m)) +userServer authData = + UserSite + { usGetUsers = \mbFilter -> do + auth <- authCheck @tag authData + getUsers @tag auth mbFilter, + usGetUser = \uid -> do + auth <- authCheck @tag authData + getUser @tag auth uid, + usPostUser = \user -> do + auth <- authCheck @tag authData + postUser @tag auth user, + usPutUser = \uid user -> do + auth <- authCheck @tag authData + putUser @tag auth uid user, + usPatchUser = \uid patch -> do + auth <- authCheck @tag authData + patchUser @tag @m auth uid patch, + usDeleteUser = \uid -> do + auth <- authCheck @tag authData + deleteUser @tag auth uid + pure NoContent + } diff --git a/src/Web/Scim/ContentType.hs b/src/Web/Scim/ContentType.hs index f8a0cb68fec..a7fefaf83d9 100644 --- a/src/Web/Scim/ContentType.hs +++ b/src/Web/Scim/ContentType.hs @@ -5,12 +5,14 @@ -- -- This module contains helpers for handling it. Basically, just write -- 'SCIM' instead of 'JSON' in all Servant routes. +module Web.Scim.ContentType + ( SCIM, + ) +where -module Web.Scim.ContentType (SCIM) where - -import Data.Proxy -import Data.List.NonEmpty import Data.Aeson +import Data.List.NonEmpty +import Data.Proxy import Network.HTTP.Media hiding (Accept) import Servant.API.ContentTypes @@ -18,14 +20,14 @@ data SCIM instance Accept SCIM where contentTypes _ = - "application" // "scim+json" /: ("charset", "utf-8") :| - "application" // "scim+json" : - "application" // "json" /: ("charset", "utf-8") : - "application" // "json" : - [] + "application" // "scim+json" /: ("charset", "utf-8") + :| "application" // "scim+json" + : "application" // "json" /: ("charset", "utf-8") + : "application" // "json" + : [] instance ToJSON a => MimeRender SCIM a where - mimeRender _ = mimeRender (Proxy @JSON) + mimeRender _ = mimeRender (Proxy @JSON) instance FromJSON a => MimeUnrender SCIM a where - mimeUnrender _ = mimeUnrender (Proxy @JSON) + mimeUnrender _ = mimeUnrender (Proxy @JSON) diff --git a/src/Web/Scim/Filter.hs b/src/Web/Scim/Filter.hs index 8b0c88a11f9..589a30d80c4 100644 --- a/src/Web/Scim/Filter.hs +++ b/src/Web/Scim/Filter.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- | A query might specify a filter that should be applied to the results -- before returning them. This module implements a very limited subset of -- the specification: . @@ -14,47 +15,45 @@ -- * Boolean operators -- * Combined filters -- * Fully qualified attribute names (schema prefixes, attribute paths) - module Web.Scim.Filter - ( - -- * Filter type - Filter(..) - , parseFilter - , renderFilter - - -- * Constructing filters - , CompValue(..) - , CompareOp(..) - , AttrPath(..) - , ValuePath(..) - , SubAttr(..) - , pAttrPath - , pValuePath - , pSubAttr - , pFilter - , rAttrPath - , rValuePath - , rSubAttr - , compareStr - , topLevelAttrPath - ) where - -import Data.String -import Prelude hiding (takeWhile) -import Control.Applicative (optional, (<|>)) + ( -- * Filter type + Filter (..), + parseFilter, + renderFilter, + + -- * Constructing filters + CompValue (..), + CompareOp (..), + AttrPath (..), + ValuePath (..), + SubAttr (..), + pAttrPath, + pValuePath, + pSubAttr, + pFilter, + rAttrPath, + rValuePath, + rSubAttr, + compareStr, + topLevelAttrPath, + ) +where + +import Control.Applicative ((<|>), optional) +import Data.Aeson as Aeson +import Data.Aeson.Parser as Aeson +import Data.Aeson.Text as Aeson +import Data.Attoparsec.ByteString.Char8 import Data.Scientific -import Data.Text (Text, pack, isInfixOf, isPrefixOf, isSuffixOf) +import Data.String +import Data.Text (Text, isInfixOf, isPrefixOf, isSuffixOf, pack) import Data.Text.Encoding (encodeUtf8) import Data.Text.Lazy (toStrict) -import Data.Attoparsec.ByteString.Char8 -import Data.Aeson.Parser as Aeson -import Data.Aeson.Text as Aeson -import Data.Aeson as Aeson import Lens.Micro import Web.HttpApiData - -import Web.Scim.Schema.Schema (Schema(User20), getSchemaUri, pSchema) import Web.Scim.AttrName +import Web.Scim.Schema.Schema (Schema (User20), getSchemaUri, pSchema) +import Prelude hiding (takeWhile) ---------------------------------------------------------------------------- -- Types @@ -71,15 +70,24 @@ data CompValue -- | A comparison operator. data CompareOp - = OpEq -- ^ Equal - | OpNe -- ^ Not equal - | OpCo -- ^ Contains - | OpSw -- ^ Starts with - | OpEw -- ^ Ends with - | OpGt -- ^ Greater than - | OpGe -- ^ Greater than or equal to - | OpLt -- ^ Less than - | OpLe -- ^ Less than or equal to + = -- | Equal + OpEq + | -- | Not equal + OpNe + | -- | Contains + OpCo + | -- | Starts with + OpSw + | -- | Ends with + OpEw + | -- | Greater than + OpGt + | -- | Greater than or equal to + OpGe + | -- | Less than + OpLt + | -- | Less than or equal to + OpLe deriving (Eq, Ord, Show, Enum, Bounded) -- | A filter. @@ -94,15 +102,15 @@ data CompareOp -- -- FILTER = attrExp / logExp / valuePath / *1"not" "(" FILTER ")" data Filter - -- | Compare the attribute value with a literal - = FilterAttrCompare AttrPath CompareOp CompValue + = -- | Compare the attribute value with a literal + FilterAttrCompare AttrPath CompareOp CompValue deriving (Eq, Show) -- | valuePath = attrPath "[" valFilter "]" -- TODO(arianvp): This is a slight simplification at the moment as we -- don't support the complete Filter grammar. This should be a -- valFilter, not a FILTER. -data ValuePath = ValuePath AttrPath Filter +data ValuePath = ValuePath AttrPath Filter deriving (Eq, Show) -- | subAttr = "." ATTRNAME @@ -113,7 +121,6 @@ newtype SubAttr = SubAttr AttrName data AttrPath = AttrPath (Maybe Schema) AttrName (Maybe SubAttr) deriving (Eq, Show) - -- | Smart constructor that refers to a toplevel field with default schema topLevelAttrPath :: Text -> AttrPath topLevelAttrPath x = AttrPath Nothing (AttrName x) Nothing @@ -140,9 +147,9 @@ topLevelAttrPath x = AttrPath Nothing (AttrName x) Nothing -- lift an Attoparsec parser (from Aeson) to Megaparsec parseFilter :: [Schema] -> Text -> Either Text Filter parseFilter supportedSchemas = - over _Left pack . - parseOnly (skipSpace *> pFilter supportedSchemas <* skipSpace <* endOfInput) . - encodeUtf8 + over _Left pack + . parseOnly (skipSpace *> pFilter supportedSchemas <* skipSpace <* endOfInput) + . encodeUtf8 -- | -- @ @@ -151,7 +158,7 @@ parseFilter supportedSchemas = -- @ pAttrPath :: [Schema] -> Parser AttrPath pAttrPath supportedSchemas = do - schema <- (Just <$> (pSchema supportedSchemas <* char ':') ) <|> pure Nothing + schema <- (Just <$> (pSchema supportedSchemas <* char ':')) <|> pure Nothing AttrPath schema <$> pAttrName <*> optional pSubAttr -- | subAttr = "." ATTRNAME @@ -165,35 +172,37 @@ pValuePath supportedSchemas = -- | Value literal parser. pCompValue :: Parser CompValue -pCompValue = choice - [ ValNull <$ string "null" - , ValBool True <$ string "true" - , ValBool False <$ string "false" - , ValNumber <$> Aeson.scientific - , ValString <$> Aeson.jstring - ] +pCompValue = + choice + [ ValNull <$ string "null", + ValBool True <$ string "true", + ValBool False <$ string "false", + ValNumber <$> Aeson.scientific, + ValString <$> Aeson.jstring + ] -- | Comparison operator parser. pCompareOp :: Parser CompareOp -pCompareOp = choice - [ OpEq <$ stringCI "eq" - , OpNe <$ stringCI "ne" - , OpCo <$ stringCI "co" - , OpSw <$ stringCI "sw" - , OpEw <$ stringCI "ew" - , OpGt <$ stringCI "gt" - , OpGe <$ stringCI "ge" - , OpLt <$ stringCI "lt" - , OpLe <$ stringCI "le" - ] +pCompareOp = + choice + [ OpEq <$ stringCI "eq", + OpNe <$ stringCI "ne", + OpCo <$ stringCI "co", + OpSw <$ stringCI "sw", + OpEw <$ stringCI "ew", + OpGt <$ stringCI "gt", + OpGe <$ stringCI "ge", + OpLt <$ stringCI "lt", + OpLe <$ stringCI "le" + ] -- | Filter parser. pFilter :: [Schema] -> Parser Filter pFilter supportedSchemas = FilterAttrCompare - <$> pAttrPath supportedSchemas - <*> (skipSpace1 *> pCompareOp) - <*> (skipSpace1 *> pCompValue) + <$> pAttrPath supportedSchemas + <*> (skipSpace1 *> pCompareOp) + <*> (skipSpace1 *> pCompValue) -- | Utility parser for skipping one or more spaces. skipSpace1 :: Parser () @@ -209,10 +218,10 @@ renderFilter filter_ = case filter_ of rAttrPath attr <> " " <> rCompareOp op <> " " <> rCompValue val rAttrPath :: AttrPath -> Text -rAttrPath (AttrPath schema attr subAttr) - = maybe "" ((<> ":") . getSchemaUri) schema - <> rAttrName attr - <> maybe "" rSubAttr subAttr +rAttrPath (AttrPath schema attr subAttr) = + maybe "" ((<> ":") . getSchemaUri) schema + <> rAttrName attr + <> maybe "" rSubAttr subAttr rSubAttr :: SubAttr -> Text rSubAttr (SubAttr x) = "." <> rAttrName x @@ -223,11 +232,11 @@ rValuePath (ValuePath attrPath filter') = rAttrPath attrPath <> "[" <> renderFil -- | Value literal renderer. rCompValue :: CompValue -> Text rCompValue = \case - ValNull -> "null" - ValBool True -> "true" + ValNull -> "null" + ValBool True -> "true" ValBool False -> "false" - ValNumber n -> toStrict $ Aeson.encodeToLazyText (Aeson.Number n) - ValString s -> toStrict $ Aeson.encodeToLazyText (Aeson.String s) + ValNumber n -> toStrict $ Aeson.encodeToLazyText (Aeson.Number n) + ValString s -> toStrict $ Aeson.encodeToLazyText (Aeson.String s) -- | Comparison operator renderer. rCompareOp :: CompareOp -> Text @@ -245,15 +254,15 @@ rCompareOp = \case -- | Execute a comparison operator. compareStr :: CompareOp -> Text -> Text -> Bool compareStr = \case - OpEq -> (==) -- equal - OpNe -> (/=) -- not equal - OpCo -> flip isInfixOf -- A contains B - OpSw -> flip isPrefixOf -- A starts with B - OpEw -> flip isSuffixOf -- A ends with B - OpGt -> (>) -- greater than - OpGe -> (>=) -- greater than or equal to - OpLt -> (<) -- less than - OpLe -> (<=) -- less than or equal to + OpEq -> (==) -- equal + OpNe -> (/=) -- not equal + OpCo -> flip isInfixOf -- A contains B + OpSw -> flip isPrefixOf -- A starts with B + OpEw -> flip isSuffixOf -- A ends with B + OpGt -> (>) -- greater than + OpGe -> (>=) -- greater than or equal to + OpLt -> (<) -- less than + OpLe -> (<=) -- less than or equal to ---------------------------------------------------------------------------- -- Instances diff --git a/src/Web/Scim/Handler.hs b/src/Web/Scim/Handler.hs index 841bb379fc8..140398088a4 100644 --- a/src/Web/Scim/Handler.hs +++ b/src/Web/Scim/Handler.hs @@ -1,8 +1,9 @@ module Web.Scim.Handler - ( ScimHandler - , throwScim - , fromScimHandler - ) where + ( ScimHandler, + throwScim, + fromScimHandler, + ) +where import Control.Monad.Except import Web.Scim.Schema.Error @@ -23,8 +24,8 @@ throwScim = throwError -- -- You can either do something custom for 'ScimError', or use -- 'scimToServantErr'. -fromScimHandler - :: Monad m - => (forall a. ScimError -> m a) - -> (forall a. ScimHandler m a -> m a) +fromScimHandler :: + Monad m => + (forall a. ScimError -> m a) -> + (forall a. ScimHandler m a -> m a) fromScimHandler fromError = either fromError pure <=< runExceptT diff --git a/src/Web/Scim/Schema/AuthenticationScheme.hs b/src/Web/Scim/Schema/AuthenticationScheme.hs index 70fc0a4faef..ae9722e0cd7 100644 --- a/src/Web/Scim/Schema/AuthenticationScheme.hs +++ b/src/Web/Scim/Schema/AuthenticationScheme.hs @@ -1,17 +1,17 @@ {-# LANGUAGE QuasiQuotes #-} module Web.Scim.Schema.AuthenticationScheme - ( AuthenticationScheme(..) - , AuthenticationSchemeEncoding - , authHttpBasicEncoding - ) where - -import Web.Scim.Schema.Common + ( AuthenticationScheme (..), + AuthenticationSchemeEncoding, + authHttpBasicEncoding, + ) +where import Data.Aeson import Data.Text import GHC.Generics import Network.URI.Static +import Web.Scim.Schema.Common ---------------------------------------------------------------------------- -- Types @@ -19,45 +19,48 @@ import Network.URI.Static -- | Possible authentication schemes. The specification defines the values -- "oauth", "oauth2", "oauthbearertoken", "httpbasic", and "httpdigest". data AuthenticationScheme - = AuthOAuth - | AuthOAuth2 - | AuthOAuthBearerToken - | AuthHttpBasic - | AuthHttpDigest + = AuthOAuth + | AuthOAuth2 + | AuthOAuthBearerToken + | AuthHttpBasic + | AuthHttpDigest deriving (Eq, Show, Enum, Bounded, Ord) -- | The way authentication schemes are expected to be represented in the -- configuration. Each 'AuthenticationScheme' corresponds to one of such -- encodings. -data AuthenticationSchemeEncoding = AuthenticationSchemeEncoding - { - -- | The authentication scheme - typ :: Text - -- | The common authentication scheme name, e.g. HTTP Basic - , name :: Text - -- | A description of the authentication scheme - , description :: Text - -- | An HTTP-addressable URL pointing to the authentication scheme's - -- specification - , specUri :: Maybe URI - -- | An HTTP-addressable URL pointing to the authentication scheme's usage - -- documentation - , documentationUri :: Maybe URI - } deriving (Show, Eq, Generic) +data AuthenticationSchemeEncoding + = AuthenticationSchemeEncoding + { -- | The authentication scheme + typ :: Text, + -- | The common authentication scheme name, e.g. HTTP Basic + name :: Text, + -- | A description of the authentication scheme + description :: Text, + -- | An HTTP-addressable URL pointing to the authentication scheme's + -- specification + specUri :: Maybe URI, + -- | An HTTP-addressable URL pointing to the authentication scheme's usage + -- documentation + documentationUri :: Maybe URI + } + deriving (Show, Eq, Generic) instance ToJSON AuthenticationSchemeEncoding where toJSON = genericToJSON serializeOptions - -- NB: "typ" will be converted to "type" thanks to 'serializeOptions' + +-- NB: "typ" will be converted to "type" thanks to 'serializeOptions' ---------------------------------------------------------------------------- -- Scheme encodings -- | The description of the 'AuthHttpBasic' scheme. authHttpBasicEncoding :: AuthenticationSchemeEncoding -authHttpBasicEncoding = AuthenticationSchemeEncoding - { typ = "httpbasic" - , name = "HTTP Basic" - , description = "Authentication via the HTTP Basic standard" - , specUri = Just $ URI [uri|https://tools.ietf.org/html/rfc7617|] - , documentationUri = Just $ URI [uri|https://en.wikipedia.org/wiki/Basic_access_authentication|] - } +authHttpBasicEncoding = + AuthenticationSchemeEncoding + { typ = "httpbasic", + name = "HTTP Basic", + description = "Authentication via the HTTP Basic standard", + specUri = Just $ URI [uri|https://tools.ietf.org/html/rfc7617|], + documentationUri = Just $ URI [uri|https://en.wikipedia.org/wiki/Basic_access_authentication|] + } diff --git a/src/Web/Scim/Schema/Common.hs b/src/Web/Scim/Schema/Common.hs index e60d6a16c45..944d1549777 100644 --- a/src/Web/Scim/Schema/Common.hs +++ b/src/Web/Scim/Schema/Common.hs @@ -1,30 +1,30 @@ - module Web.Scim.Schema.Common where -import Data.Text hiding (dropWhile) import Data.Aeson import qualified Data.Char as Char +import qualified Data.HashMap.Lazy as HML import qualified Data.HashMap.Strict as HM import Data.String (IsString) +import Data.Text hiding (dropWhile) import qualified Network.URI as Network -import qualified Data.HashMap.Lazy as HML - -data WithId id a = WithId - { id :: id - , value :: a - } deriving (Eq, Show) +data WithId id a + = WithId + { id :: id, + value :: a + } + deriving (Eq, Show) instance (ToJSON id, ToJSON a) => ToJSON (WithId id a) where toJSON (WithId i v) = case toJSON v of (Object o) -> Object (HML.insert "id" (toJSON i) o) - other -> other + other -> other instance (FromJSON id, FromJSON a) => FromJSON (WithId id a) where parseJSON = withObject "WithId" $ \o -> WithId <$> o .: "id" <*> parseJSON (Object o) -newtype URI = URI { unURI :: Network.URI } +newtype URI = URI {unURI :: Network.URI} deriving (Show, Eq) instance FromJSON URI where @@ -41,15 +41,17 @@ toKeyword "ref" = "$ref" toKeyword other = other serializeOptions :: Options -serializeOptions = defaultOptions - { omitNothingFields = True - , fieldLabelModifier = toKeyword - } +serializeOptions = + defaultOptions + { omitNothingFields = True, + fieldLabelModifier = toKeyword + } -- | Turn all keys in a JSON object to lowercase. jsonLower :: Value -> Value jsonLower (Object o) = Object . HM.fromList . fmap lowerPair . HM.toList $ o - where lowerPair (key, val) = (fromKeyword . toLower $ key, val) + where + lowerPair (key, val) = (fromKeyword . toLower $ key, val) jsonLower x = x fromKeyword :: (IsString p, Eq p) => p -> p @@ -58,7 +60,7 @@ fromKeyword "$ref" = "ref" fromKeyword other = other parseOptions :: Options -parseOptions = defaultOptions - { fieldLabelModifier = fmap Char.toLower - } - +parseOptions = + defaultOptions + { fieldLabelModifier = fmap Char.toLower + } diff --git a/src/Web/Scim/Schema/Error.hs b/src/Web/Scim/Schema/Error.hs index 6e5b198b163..7f6abf77f32 100644 --- a/src/Web/Scim/Schema/Error.hs +++ b/src/Web/Scim/Schema/Error.hs @@ -1,31 +1,30 @@ -- | SCIM errors module Web.Scim.Schema.Error - ( - -- * Types - ScimErrorType(..) - , ScimError(..) - , Status(..) - - -- * Constructors - , notFound - , badRequest - , conflict - , unauthorized - , forbidden - , serverError - - -- * Servant interoperability - , scimToServerError - ) where + ( -- * Types + ScimErrorType (..), + ScimError (..), + Status (..), + + -- * Constructors + notFound, + badRequest, + conflict, + unauthorized, + forbidden, + serverError, + + -- * Servant interoperability + scimToServerError, + ) +where -import Data.Text (Text, pack) -import Data.Aeson hiding (Error) import Control.Exception +import Data.Aeson hiding (Error) +import Data.Text (Text, pack) +import GHC.Generics (Generic) +import Servant (ServerError (..)) import Web.Scim.Schema.Common import Web.Scim.Schema.Schema -import Servant (ServerError (..)) - -import GHC.Generics (Generic) ---------------------------------------------------------------------------- -- Types @@ -50,15 +49,15 @@ data ScimErrorType instance ToJSON ScimErrorType where toJSON InvalidFilter = "invalidFilter" - toJSON TooMany = "tooMany" - toJSON Uniqueness = "uniqueness" - toJSON Mutability = "mutability" + toJSON TooMany = "tooMany" + toJSON Uniqueness = "uniqueness" + toJSON Mutability = "mutability" toJSON InvalidSyntax = "invalidSyntax" - toJSON InvalidPath = "invalidPath" - toJSON NoTarget = "noTarget" - toJSON InvalidValue = "invalidValue" - toJSON InvalidVers = "invalidVers" - toJSON Sensitive = "sensitive" + toJSON InvalidPath = "invalidPath" + toJSON NoTarget = "noTarget" + toJSON InvalidValue = "invalidValue" + toJSON InvalidVers = "invalidVers" + toJSON Sensitive = "sensitive" -- wrapped in a newtype because SCIM wants strings for status codes newtype Status = Status {unStatus :: Int} @@ -67,12 +66,14 @@ newtype Status = Status {unStatus :: Int} instance ToJSON Status where toJSON (Status stat) = String . pack . show $ stat -data ScimError = ScimError - { schemas :: [Schema] - , status :: Status - , scimType :: Maybe ScimErrorType - , detail :: Maybe Text - } deriving (Show, Eq, Generic) +data ScimError + = ScimError + { schemas :: [Schema], + status :: Status, + scimType :: Maybe ScimErrorType, + detail :: Maybe Text + } + deriving (Show, Eq, Generic) instance ToJSON ScimError where toJSON = genericToJSON serializeOptions @@ -82,70 +83,77 @@ instance Exception ScimError ---------------------------------------------------------------------------- -- Constructors -badRequest - :: ScimErrorType -- ^ Error type - -> Maybe Text -- ^ Error details - -> ScimError +badRequest :: + -- | Error type + ScimErrorType -> + -- | Error details + Maybe Text -> + ScimError badRequest typ mbDetail = ScimError - { schemas = [Error20] - , status = Status 400 - , scimType = pure typ - , detail = mbDetail + { schemas = [Error20], + status = Status 400, + scimType = pure typ, + detail = mbDetail } -unauthorized - :: Text -- ^ Error details - -> ScimError +unauthorized :: + -- | Error details + Text -> + ScimError unauthorized details = ScimError - { schemas = [Error20] - , status = Status 401 - , scimType = Nothing - , detail = pure $ "authorization failed: " <> details + { schemas = [Error20], + status = Status 401, + scimType = Nothing, + detail = pure $ "authorization failed: " <> details } -forbidden - :: Text -- ^ Error details - -> ScimError +forbidden :: + -- | Error details + Text -> + ScimError forbidden details = ScimError - { schemas = [Error20] - , status = Status 403 - , scimType = Nothing - , detail = pure $ "forbidden: " <> details + { schemas = [Error20], + status = Status 403, + scimType = Nothing, + detail = pure $ "forbidden: " <> details } -notFound - :: Text -- ^ Resource type - -> Text -- ^ Resource ID - -> ScimError +notFound :: + -- | Resource type + Text -> + -- | Resource ID + Text -> + ScimError notFound resourceType resourceId = ScimError - { schemas = [Error20] - , status = Status 404 - , scimType = Nothing - , detail = pure $ resourceType <> " " <> resourceId <> " not found" + { schemas = [Error20], + status = Status 404, + scimType = Nothing, + detail = pure $ resourceType <> " " <> resourceId <> " not found" } conflict :: ScimError conflict = ScimError - { schemas = [Error20] - , status = Status 409 - , scimType = Just Uniqueness - , detail = Nothing + { schemas = [Error20], + status = Status 409, + scimType = Just Uniqueness, + detail = Nothing } -serverError - :: Text -- ^ Error details - -> ScimError +serverError :: + -- | Error details + Text -> + ScimError serverError details = ScimError - { schemas = [Error20] - , status = Status 500 - , scimType = Nothing - , detail = pure details + { schemas = [Error20], + status = Status 500, + scimType = Nothing, + detail = pure details } ---------------------------------------------------------------------------- @@ -156,10 +164,10 @@ serverError details = scimToServerError :: ScimError -> ServerError scimToServerError err = ServerError - { errHTTPCode = unStatus (status err) - , errReasonPhrase = reasonPhrase (status err) - , errBody = encode err - , errHeaders = [("Content-Type", "application/scim+json;charset=utf-8")] + { errHTTPCode = unStatus (status err), + errReasonPhrase = reasonPhrase (status err), + errBody = encode err, + errHeaders = [("Content-Type", "application/scim+json;charset=utf-8")] } -- | A mapping of error code "reason phrases" (e.g. "Method Not Allowed") @@ -191,4 +199,4 @@ reasonPhrase = \case Status 503 -> "Service Unavailable" Status 504 -> "Gateway Time-out" Status 505 -> "HTTP Version not supported" - other -> show other + other -> show other diff --git a/src/Web/Scim/Schema/ListResponse.hs b/src/Web/Scim/Schema/ListResponse.hs index 803b0252de7..cfa7d08e4c2 100644 --- a/src/Web/Scim/Schema/ListResponse.hs +++ b/src/Web/Scim/Schema/ListResponse.hs @@ -1,9 +1,10 @@ {-# LANGUAGE RecordWildCards #-} module Web.Scim.Schema.ListResponse - ( ListResponse(..) - , fromList - ) where + ( ListResponse (..), + fromList, + ) +where import Data.Aeson import GHC.Generics (Generic) @@ -19,22 +20,25 @@ import Web.Scim.Schema.Schema -- -- FUTUREWORK: Support for pagination might be added once we have to handle -- organizations with lots of users. -data ListResponse a = ListResponse - { schemas :: [Schema] - , totalResults :: Int - , itemsPerPage :: Int - , startIndex :: Int - , resources :: [a] - } deriving (Show, Eq, Generic) +data ListResponse a + = ListResponse + { schemas :: [Schema], + totalResults :: Int, + itemsPerPage :: Int, + startIndex :: Int, + resources :: [a] + } + deriving (Show, Eq, Generic) fromList :: [a] -> ListResponse a -fromList list = ListResponse - { schemas = [ListResponse20] - , totalResults = len - , itemsPerPage = len - , startIndex = 1 -- NOTE: lists are 1-indexed in SCIM - , resources = list - } +fromList list = + ListResponse + { schemas = [ListResponse20], + totalResults = len, + itemsPerPage = len, + startIndex = 1, -- NOTE: lists are 1-indexed in SCIM + resources = list + } where len = length list @@ -42,10 +46,11 @@ instance FromJSON a => FromJSON (ListResponse a) where parseJSON = genericParseJSON parseOptions . jsonLower instance ToJSON a => ToJSON (ListResponse a) where - toJSON ListResponse{..} = - object [ "Resources" .= resources - , "schemas" .= schemas - , "totalResults" .= totalResults - , "itemsPerPage" .= itemsPerPage - , "startIndex" .= startIndex - ] + toJSON ListResponse {..} = + object + [ "Resources" .= resources, + "schemas" .= schemas, + "totalResults" .= totalResults, + "itemsPerPage" .= itemsPerPage, + "startIndex" .= startIndex + ] diff --git a/src/Web/Scim/Schema/Meta.hs b/src/Web/Scim/Schema/Meta.hs index 924a84b0416..6b8d666bed5 100644 --- a/src/Web/Scim/Schema/Meta.hs +++ b/src/Web/Scim/Schema/Meta.hs @@ -1,17 +1,15 @@ - module Web.Scim.Schema.Meta where -import Prelude hiding (map) - -import Data.Text (Text, unpack, pack) +import Data.Aeson +import qualified Data.HashMap.Lazy as HML +import Data.Text (Text, pack, unpack) import qualified Data.Text as Text +import Data.Time.Clock +import GHC.Generics (Generic) import Text.Read (readEither) -import Data.Aeson import Web.Scim.Schema.Common import Web.Scim.Schema.ResourceType -import GHC.Generics (Generic) -import qualified Data.HashMap.Lazy as HML -import Data.Time.Clock +import Prelude hiding (map) data ETag = Weak Text | Strong Text deriving (Eq, Show) @@ -30,22 +28,24 @@ instance FromJSON ETag where Right x -> pure x Left e -> fail ("couldn't unquote the string: " <> e) -data Meta = Meta - { resourceType :: ResourceType - , created :: UTCTime - , lastModified :: UTCTime - -- | Resource version: . - -- - -- A version is an /opaque/ string that doesn't need to conform to any - -- format (e.g. it does not have to be a monotonically increasing integer, - -- contrary to what the word @version@ suggests). - -- - -- For 'Weak' versions we have to guarantee that different resources will - -- have different 'version's. For 'Strong' versions we also have to - -- guarantee that same resources will have the same 'version'. - , version :: ETag - , location :: URI - } deriving (Eq, Show, Generic) +data Meta + = Meta + { resourceType :: ResourceType, + created :: UTCTime, + lastModified :: UTCTime, + -- | Resource version: . + -- + -- A version is an /opaque/ string that doesn't need to conform to any + -- format (e.g. it does not have to be a monotonically increasing integer, + -- contrary to what the word @version@ suggests). + -- + -- For 'Weak' versions we have to guarantee that different resources will + -- have different 'version's. For 'Strong' versions we also have to + -- guarantee that same resources will have the same 'version'. + version :: ETag, + location :: URI + } + deriving (Eq, Show, Generic) instance ToJSON Meta where toJSON = genericToJSON serializeOptions @@ -53,15 +53,17 @@ instance ToJSON Meta where instance FromJSON Meta where parseJSON = genericParseJSON parseOptions . jsonLower -data WithMeta a = WithMeta - { meta :: Meta - , thing :: a - } deriving (Eq, Show, Generic) +data WithMeta a + = WithMeta + { meta :: Meta, + thing :: a + } + deriving (Eq, Show, Generic) instance (ToJSON a) => ToJSON (WithMeta a) where toJSON (WithMeta m v) = case toJSON v of (Object o) -> Object (HML.insert "meta" (toJSON m) o) - other -> other + other -> other instance (FromJSON a) => FromJSON (WithMeta a) where parseJSON = withObject "WithMeta" $ \o -> diff --git a/src/Web/Scim/Schema/PatchOp.hs b/src/Web/Scim/Schema/PatchOp.hs index c7ec56ba82c..35bbec7cc03 100644 --- a/src/Web/Scim/Schema/PatchOp.hs +++ b/src/Web/Scim/Schema/PatchOp.hs @@ -3,22 +3,23 @@ module Web.Scim.Schema.PatchOp where import Control.Applicative import Control.Monad (guard) import Control.Monad.Except -import Web.Scim.Schema.Schema (Schema(PatchOp20)) -import Web.Scim.Schema.UserTypes (UserTypes(supportedSchemas)) -import Data.Aeson.Types (withText, ToJSON(toJSON), object, (.=), FromJSON(parseJSON), withObject, (.:), (.:?), Value(String)) +import Data.Aeson.Types ((.:), (.:?), (.=), FromJSON (parseJSON), ToJSON (toJSON), Value (String), object, withObject, withText) import qualified Data.Aeson.Types as Aeson +import Data.Attoparsec.ByteString (Parser, endOfInput, parseOnly) +import Data.Bifunctor (first) import qualified Data.HashMap.Strict as HashMap -import Data.Text (toCaseFold, toLower, Text) +import qualified Data.HashMap.Strict as HM +import Data.Text (Text, toCaseFold, toLower) import Data.Text.Encoding (encodeUtf8) -import Data.Bifunctor (first) -import Data.Attoparsec.ByteString (Parser, parseOnly, endOfInput) -import Web.Scim.AttrName (AttrName(..)) -import Web.Scim.Filter (AttrPath(..), ValuePath(..), SubAttr(..), pAttrPath, pValuePath, pSubAttr, rAttrPath, rSubAttr, rValuePath) +import Web.Scim.AttrName (AttrName (..)) +import Web.Scim.Filter (AttrPath (..), SubAttr (..), ValuePath (..), pAttrPath, pSubAttr, pValuePath, rAttrPath, rSubAttr, rValuePath) import Web.Scim.Schema.Error -import qualified Data.HashMap.Strict as HM +import Web.Scim.Schema.Schema (Schema (PatchOp20)) +import Web.Scim.Schema.UserTypes (UserTypes (supportedSchemas)) -newtype PatchOp tag = PatchOp - { getOperations :: [Operation] } +newtype PatchOp tag + = PatchOp + {getOperations :: [Operation]} deriving (Eq, Show) -- | The 'Path' attribute value is a 'String' containing an attribute path @@ -32,11 +33,13 @@ newtype PatchOp tag = PatchOp -- -- NOTE: When the path contains a schema, this schema must be implicitly added -- to the list of schemas on the result type -data Operation = Operation - { op :: Op - , path :: Maybe Path - , value :: Maybe Value - } deriving (Eq, Show) +data Operation + = Operation + { op :: Op, + path :: Maybe Path, + value :: Maybe Value + } + deriving (Eq, Show) data Op = Add @@ -56,14 +59,13 @@ parsePath schemas' = parseOnly (pPath schemas' <* endOfInput) . encodeUtf8 -- | PATH = attrPath / valuePath [subAttr] pPath :: [Schema] -> Parser Path pPath schemas' = - IntoValuePath <$> pValuePath schemas' <*> optional pSubAttr <|> - NormalPath <$> pAttrPath schemas' + IntoValuePath <$> pValuePath schemas' <*> optional pSubAttr + <|> NormalPath <$> pAttrPath schemas' rPath :: Path -> Text rPath (NormalPath attrPath) = rAttrPath attrPath rPath (IntoValuePath valuePath subAttr) = rValuePath valuePath <> maybe "" rSubAttr subAttr - -- TODO(arianvp): According to the SCIM spec we should throw an InvalidPath -- error when the path is invalid syntax. this is a bit hard to do though as we -- can't control what errors FromJSON throws :/ @@ -77,7 +79,7 @@ instance UserTypes tag => FromJSON (PatchOp tag) where instance ToJSON (PatchOp tag) where toJSON (PatchOp operations) = - object [ "operations" .= operations , "schemas" .= [PatchOp20] ] + object ["operations" .= operations, "schemas" .= [PatchOp20]] -- TODO: Azure wants us to be case-insensitive on _values_ as well here. We currently do not -- comply with that. @@ -100,8 +102,7 @@ instance ToJSON Operation where where optionalField fname = \case Nothing -> [] - Just x -> [fname .= x] - + Just x -> [fname .= x] instance FromJSON Op where parseJSON = withText "Op" $ \op' -> diff --git a/src/Web/Scim/Schema/ResourceType.hs b/src/Web/Scim/Schema/ResourceType.hs index f542580d351..6001fcfe229 100644 --- a/src/Web/Scim/Schema/ResourceType.hs +++ b/src/Web/Scim/Schema/ResourceType.hs @@ -2,16 +2,13 @@ module Web.Scim.Schema.ResourceType where -import Prelude hiding (map) - -import Data.Text (Text) import Data.Aeson +import Data.Text (Text) +import GHC.Generics (Generic) import Network.URI.Static - import Web.Scim.Schema.Common -import Web.Scim.Schema.Schema (Schema(..)) - -import GHC.Generics (Generic) +import Web.Scim.Schema.Schema (Schema (..)) +import Prelude hiding (map) -- | Supported resource types. Each resource type also corresponds to an -- endpoint, described by 'ResourceTypeEndpoint'. @@ -31,11 +28,13 @@ instance FromJSON ResourceType where other -> fail ("unknown ResourceType: " ++ show other) -- | Definitions of endpoints, returned by @/ResourceTypes@. -data Resource = Resource - { name :: Text - , endpoint :: URI - , schema :: Schema - } deriving (Show, Eq, Generic) +data Resource + = Resource + { name :: Text, + endpoint :: URI, + schema :: Schema + } + deriving (Show, Eq, Generic) instance ToJSON Resource where toJSON = genericToJSON serializeOptions @@ -47,15 +46,17 @@ instance FromJSON Resource where -- Available resource endpoints usersResource :: Resource -usersResource = Resource - { name = "User" - , endpoint = URI [relativeReference|/Users|] - , schema = User20 - } +usersResource = + Resource + { name = "User", + endpoint = URI [relativeReference|/Users|], + schema = User20 + } groupsResource :: Resource -groupsResource = Resource - { name = "Group" - , endpoint = URI [relativeReference|/Groups|] - , schema = Group20 - } +groupsResource = + Resource + { name = "Group", + endpoint = URI [relativeReference|/Groups|], + schema = Group20 + } diff --git a/src/Web/Scim/Schema/Schema.hs b/src/Web/Scim/Schema/Schema.hs index 6e197e28b75..ca49dcbc7b8 100644 --- a/src/Web/Scim/Schema/Schema.hs +++ b/src/Web/Scim/Schema/Schema.hs @@ -1,27 +1,27 @@ module Web.Scim.Schema.Schema where -import Web.Scim.Capabilities.MetaSchema.User -import Web.Scim.Capabilities.MetaSchema.SPConfig -import Web.Scim.Capabilities.MetaSchema.Group -import Web.Scim.Capabilities.MetaSchema.Schema -import Web.Scim.Capabilities.MetaSchema.ResourceType - -import Data.Text (Text) -import Data.Aeson (FromJSON, parseJSON, toJSON, ToJSON, withText, Value) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Aeson (FromJSON, ToJSON, Value, parseJSON, toJSON, withText) import Data.Attoparsec.ByteString (Parser) import qualified Data.Attoparsec.ByteString.Char8 as Parser +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Web.Scim.Capabilities.MetaSchema.Group +import Web.Scim.Capabilities.MetaSchema.ResourceType +import Web.Scim.Capabilities.MetaSchema.SPConfig +import Web.Scim.Capabilities.MetaSchema.Schema +import Web.Scim.Capabilities.MetaSchema.User -- | All schemas that we support. -data Schema = User20 - | ServiceProviderConfig20 - | Group20 - | Schema20 - | ResourceType20 - | ListResponse20 - | Error20 - | PatchOp20 - | CustomSchema Text +data Schema + = User20 + | ServiceProviderConfig20 + | Group20 + | Schema20 + | ResourceType20 + | ListResponse20 + | Error20 + | PatchOp20 + | CustomSchema Text deriving (Show, Eq) instance FromJSON Schema where @@ -52,14 +52,15 @@ getSchemaUri (CustomSchema x) = x -- TODO(akshay): Make everything Text, ByteStrings are unnecessary here + -- | Parser for schemas -- -- NOTE: according to the spec, this parser needs to be case insensitive, but -- that is literally insane. Won't implement. pSchema :: [Schema] -> Parser Schema pSchema supportedSchemas = - Parser.choice - $ map (\s -> fromSchemaUri . decodeUtf8 <$> Parser.string (encodeUtf8 $ getSchemaUri s)) supportedSchemas + Parser.choice $ + map (\s -> fromSchemaUri . decodeUtf8 <$> Parser.string (encodeUtf8 $ getSchemaUri s)) supportedSchemas -- | Get a schema by its URI. -- diff --git a/src/Web/Scim/Schema/User.hs b/src/Web/Scim/Schema/User.hs index f187805d94e..ea079078ab4 100644 --- a/src/Web/Scim/Schema/User.hs +++ b/src/Web/Scim/Schema/User.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} -- | SCIM user representation. -- @@ -44,29 +44,32 @@ -- When parsing JSON objects, we ignore capitalization differences in field -- names -- e.g. both @USERNAME@ and @userName@ are accepted. -- This is described by the spec https://tools.ietf.org/html/rfc7643#section-2.1 --- module Web.Scim.Schema.User - ( User(..) - , empty - , NoUserExtra(..) - , applyPatch - , resultToScimError - , isUserSchema - , module Web.Scim.Schema.UserTypes + ( User (..), + empty, + NoUserExtra (..), + applyPatch, + resultToScimError, + isUserSchema, + module Web.Scim.Schema.UserTypes, ) where import Control.Monad (foldM) +import Control.Monad.Except import Data.Aeson -import Data.List ((\\)) import qualified Data.HashMap.Strict as HM +import Data.List ((\\)) import Data.Text (Text, pack, toLower) +import qualified Data.Text as Text +import GHC.Generics (Generic) import Lens.Micro - import Web.Scim.AttrName -import Web.Scim.Filter (AttrPath(..)) +import Web.Scim.Filter (AttrPath (..)) import Web.Scim.Schema.Common -import Web.Scim.Schema.Schema (Schema(..), getSchemaUri) +import Web.Scim.Schema.Error +import Web.Scim.Schema.PatchOp +import Web.Scim.Schema.Schema (Schema (..), getSchemaUri) import Web.Scim.Schema.User.Address (Address) import Web.Scim.Schema.User.Certificate (Certificate) import Web.Scim.Schema.User.Email (Email) @@ -74,103 +77,98 @@ import Web.Scim.Schema.User.IM (IM) import Web.Scim.Schema.User.Name (Name) import Web.Scim.Schema.User.Phone (Phone) import Web.Scim.Schema.User.Photo (Photo) -import Web.Scim.Schema.PatchOp -import Web.Scim.Schema.Error import Web.Scim.Schema.UserTypes -import GHC.Generics (Generic) -import Control.Monad.Except -import qualified Data.Text as Text - -- | SCIM user record, parametrized with type-level tag @t@ (see 'UserTypes'). -data User tag = User - { - schemas :: [Schema] - - -- Mandatory fields - , userName :: Text - - -- Optional fields - , externalId :: Maybe Text - , name :: Maybe Name - , displayName :: Maybe Text - , nickName :: Maybe Text - , profileUrl :: Maybe URI - , title :: Maybe Text - , userType :: Maybe Text - , preferredLanguage :: Maybe Text - , locale :: Maybe Text - , active :: Maybe Bool - , password :: Maybe Text - - -- Multi-valued fields - , emails :: [Email] - , phoneNumbers :: [Phone] - , ims :: [IM] - , photos :: [Photo] - , addresses :: [Address] - , entitlements :: [Text] - , roles :: [Text] - , x509Certificates :: [Certificate] - - -- Extra data. - -- - -- During rendering, we'll convert it to JSON; if it's an object we'll merge it with the - -- main user object, if it's @null@ we'll do nothing, otherwise we'll add it under the - -- @"extra"@ field (though you should definitely not rely on this). - -- - -- During parsing, we'll attempt to parse the /whole/ user object as @extra@, so your - -- 'FromJSON' instance should be prepared to ignore unrelated fields. Also keep in mind that - -- the SCIM spec requires field names to be case-insensitive, i.e. if you're looking for a - -- field "foo" you should also handle a field called "FOO". Look at the @FromJSON User@ - -- instance to see how it can be done. - -- - -- FUTUREWORK: make it easy for hscim users to implement a proper parser (with correct - -- rendering of optional and multivalued fields, lowercase objects, etc). - , extra :: UserExtra tag - } deriving (Generic) +data User tag + = User + { schemas :: [Schema], + -- Mandatory fields + userName :: Text, + -- Optional fields + externalId :: Maybe Text, + name :: Maybe Name, + displayName :: Maybe Text, + nickName :: Maybe Text, + profileUrl :: Maybe URI, + title :: Maybe Text, + userType :: Maybe Text, + preferredLanguage :: Maybe Text, + locale :: Maybe Text, + active :: Maybe Bool, + password :: Maybe Text, + -- Multi-valued fields + emails :: [Email], + phoneNumbers :: [Phone], + ims :: [IM], + photos :: [Photo], + addresses :: [Address], + entitlements :: [Text], + roles :: [Text], + x509Certificates :: [Certificate], + -- Extra data. + -- + -- During rendering, we'll convert it to JSON; if it's an object we'll merge it with the + -- main user object, if it's @null@ we'll do nothing, otherwise we'll add it under the + -- @"extra"@ field (though you should definitely not rely on this). + -- + -- During parsing, we'll attempt to parse the /whole/ user object as @extra@, so your + -- 'FromJSON' instance should be prepared to ignore unrelated fields. Also keep in mind that + -- the SCIM spec requires field names to be case-insensitive, i.e. if you're looking for a + -- field "foo" you should also handle a field called "FOO". Look at the @FromJSON User@ + -- instance to see how it can be done. + -- + -- FUTUREWORK: make it easy for hscim users to implement a proper parser (with correct + -- rendering of optional and multivalued fields, lowercase objects, etc). + extra :: UserExtra tag + } + deriving (Generic) deriving instance Show (UserExtra tag) => Show (User tag) -deriving instance Eq (UserExtra tag) => Eq (User tag) +deriving instance Eq (UserExtra tag) => Eq (User tag) -empty - :: [Schema] -- ^ Schemas - -> Text -- ^ userName - -> UserExtra tag -- ^ Extra data - -> User tag -empty schemas userName extra = User - { schemas = schemas - , userName = userName - , externalId = Nothing - , name = Nothing - , displayName = Nothing - , nickName = Nothing - , profileUrl = Nothing - , title = Nothing - , userType = Nothing - , preferredLanguage = Nothing - , locale = Nothing - , active = Nothing - , password = Nothing - , emails = [] - , phoneNumbers = [] - , ims = [] - , photos = [] - , addresses = [] - , entitlements = [] - , roles = [] - , x509Certificates = [] - , extra = extra - } +empty :: + -- | Schemas + [Schema] -> + -- | userName + Text -> + -- | Extra data + UserExtra tag -> + User tag +empty schemas userName extra = + User + { schemas = schemas, + userName = userName, + externalId = Nothing, + name = Nothing, + displayName = Nothing, + nickName = Nothing, + profileUrl = Nothing, + title = Nothing, + userType = Nothing, + preferredLanguage = Nothing, + locale = Nothing, + active = Nothing, + password = Nothing, + emails = [], + phoneNumbers = [], + ims = [], + photos = [], + addresses = [], + entitlements = [], + roles = [], + x509Certificates = [], + extra = extra + } instance FromJSON (UserExtra tag) => FromJSON (User tag) where parseJSON = withObject "User" $ \obj -> do -- Lowercase all fields let o = HM.fromList . map (over _1 toLower) . HM.toList $ obj schemas <- o .:? "schemas" <&> \case - Nothing -> [User20] - Just xs -> if User20 `elem` xs then xs else User20 : xs + Nothing -> [User20] + Just xs -> if User20 `elem` xs then xs else User20 : xs userName <- o .: "username" externalId <- o .:? "externalid" name <- o .:? "name" @@ -192,44 +190,45 @@ instance FromJSON (UserExtra tag) => FromJSON (User tag) where roles <- o .:? "roles" .!= [] x509Certificates <- o .:? "x509certificates" .!= [] extra <- parseJSON (Object obj) - pure User{..} + pure User {..} instance ToJSON (UserExtra tag) => ToJSON (User tag) where - toJSON User{..} = - let mainObject = HM.fromList $ concat - [ [ "schemas" .= schemas ] - , [ "userName" .= userName ] - , optionalField "externalId" externalId - , optionalField "name" name - , optionalField "displayName" displayName - , optionalField "nickName" nickName - , optionalField "profileUrl" profileUrl - , optionalField "title" title - , optionalField "userType" userType - , optionalField "preferredLanguage" preferredLanguage - , optionalField "locale" locale - , optionalField "active" active - , optionalField "password" password - , multiValuedField "emails" emails - , multiValuedField "phoneNumbers" phoneNumbers - , multiValuedField "ims" ims - , multiValuedField "photos" photos - , multiValuedField "addresses" addresses - , multiValuedField "entitlements" entitlements - , multiValuedField "roles" roles - , multiValuedField "x509Certificates" x509Certificates - ] + toJSON User {..} = + let mainObject = + HM.fromList $ + concat + [ ["schemas" .= schemas], + ["userName" .= userName], + optionalField "externalId" externalId, + optionalField "name" name, + optionalField "displayName" displayName, + optionalField "nickName" nickName, + optionalField "profileUrl" profileUrl, + optionalField "title" title, + optionalField "userType" userType, + optionalField "preferredLanguage" preferredLanguage, + optionalField "locale" locale, + optionalField "active" active, + optionalField "password" password, + multiValuedField "emails" emails, + multiValuedField "phoneNumbers" phoneNumbers, + multiValuedField "ims" ims, + multiValuedField "photos" photos, + multiValuedField "addresses" addresses, + multiValuedField "entitlements" entitlements, + multiValuedField "roles" roles, + multiValuedField "x509Certificates" x509Certificates + ] extraObject = case toJSON extra of Null -> mempty Object x -> x other -> HM.fromList ["extra" .= other] - in Object (HM.union mainObject extraObject) - + in Object (HM.union mainObject extraObject) where -- Omit a field if it's Nothing optionalField fname = \case Nothing -> [] - Just x -> [fname .= x] + Just x -> [fname .= x] -- Omit a field if it's [] multiValuedField fname = \case [] -> [] @@ -258,11 +257,14 @@ instance Patchable NoUserExtra where -- We'll have to think how patch is going to work in the presence of extensions. -- Also, we can probably make PatchOp type-safe to some extent (Read arianvp's thesis :)) applyPatch :: - ( Patchable (UserExtra tag) - , FromJSON (UserExtra tag) - , MonadError ScimError m - , UserTypes tag - ) => User tag -> PatchOp tag -> m (User tag) + ( Patchable (UserExtra tag), + FromJSON (UserExtra tag), + MonadError ScimError m, + UserTypes tag + ) => + User tag -> + PatchOp tag -> + m (User tag) applyPatch = (. getOperations) . foldM applyOperation resultToScimError :: (MonadError ScimError m) => Result a -> m a @@ -276,25 +278,26 @@ resultToScimError (Success a) = pure a -- What I understand from the spec: The difference between add an replace is only -- in the fact that replace will not concat multi-values, and behaves differently for complex values too. -- For simple attributes, add and replace are identical. -applyUserOperation - :: forall m tag.( UserTypes tag - , FromJSON (User tag) - , Patchable (UserExtra tag) - , MonadError ScimError m) - => User tag - -> Operation - -> m (User tag) +applyUserOperation :: + forall m tag. + ( UserTypes tag, + FromJSON (User tag), + Patchable (UserExtra tag), + MonadError ScimError m + ) => + User tag -> + Operation -> + m (User tag) applyUserOperation user (Operation Add path value) = applyUserOperation user (Operation Replace path value) applyUserOperation user (Operation Replace (Just (NormalPath (AttrPath _schema attr _subAttr))) (Just value)) = case attr of "username" -> - (\x -> user { userName = x }) <$> resultToScimError (fromJSON value) + (\x -> user {userName = x}) <$> resultToScimError (fromJSON value) "displayname" -> - (\x -> user { displayName = x }) <$> resultToScimError (fromJSON value) + (\x -> user {displayName = x}) <$> resultToScimError (fromJSON value) "externalid" -> - (\x -> user { externalId = x }) <$> resultToScimError (fromJSON value) + (\x -> user {externalId = x}) <$> resultToScimError (fromJSON value) _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid")) - applyUserOperation _ (Operation Replace (Just (IntoValuePath _ _)) _) = do throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet")) applyUserOperation user (Operation Replace Nothing (Just value)) = do @@ -302,20 +305,20 @@ applyUserOperation user (Operation Replace Nothing (Just value)) = do Object hm | null ((AttrName <$> HM.keys hm) \\ ["username", "displayname", "externalid"]) -> pure () _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid")) (u :: User tag) <- resultToScimError $ fromJSON value - pure $ user - { userName = userName u - , displayName = displayName u - , externalId = externalId u - } + pure $ + user + { userName = userName u, + displayName = displayName u, + externalId = externalId u + } applyUserOperation _ (Operation Replace _ Nothing) = throwError (badRequest InvalidValue (Just "No value was provided")) - applyUserOperation _ (Operation Remove Nothing _) = throwError (badRequest NoTarget Nothing) applyUserOperation user (Operation Remove (Just (NormalPath (AttrPath _schema attr _subAttr))) _value) = case attr of "username" -> throwError (badRequest Mutability Nothing) - "displayname" -> pure $ user { displayName = Nothing } - "externalid" -> pure $ user { externalId = Nothing } + "displayname" -> pure $ user {displayName = Nothing} + "externalid" -> pure $ user {externalId = Nothing} _ -> pure user applyUserOperation _ (Operation Remove (Just (IntoValuePath _ _)) _) = do throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet")) @@ -323,10 +326,11 @@ applyUserOperation _ (Operation Remove (Just (IntoValuePath _ _)) _) = do instance (UserTypes tag, FromJSON (User tag), Patchable (UserExtra tag)) => Patchable (User tag) where applyOperation user op@(Operation _ (Just (NormalPath (AttrPath schema _ _))) _) | isUserSchema schema = applyUserOperation user op - | isSupportedCustomSchema schema = (\x -> user { extra = x }) <$> applyOperation (extra user) op + | isSupportedCustomSchema schema = (\x -> user {extra = x}) <$> applyOperation (extra user) op | otherwise = throwError $ badRequest InvalidPath $ Just $ "we only support these schemas: " <> (Text.intercalate ", " $ map getSchemaUri (supportedSchemas @tag)) - where isSupportedCustomSchema = maybe False (`elem` supportedSchemas @tag) + where + isSupportedCustomSchema = maybe False (`elem` supportedSchemas @tag) applyOperation user op = applyUserOperation user op -- Omission of a schema for users is implicitly the core schema diff --git a/src/Web/Scim/Schema/User/Address.hs b/src/Web/Scim/Schema/User/Address.hs index be980f1992d..2dee10060d9 100644 --- a/src/Web/Scim/Schema/User/Address.hs +++ b/src/Web/Scim/Schema/User/Address.hs @@ -1,22 +1,23 @@ - module Web.Scim.Schema.User.Address where -import Data.Text hiding (dropWhile) import Data.Aeson +import Data.Text hiding (dropWhile) import GHC.Generics (Generic) import Web.Scim.Schema.Common -data Address = Address - { formatted :: Maybe Text - , streetAddress :: Maybe Text - , locality :: Maybe Text - , region :: Maybe Text - , postalCode :: Maybe Text - -- TODO: country is specified as ISO3166, but example uses "USA" - , country :: Maybe Text - , typ :: Maybe Text - , primary :: Maybe Bool - } deriving (Show, Eq, Generic) +data Address + = Address + { formatted :: Maybe Text, + streetAddress :: Maybe Text, + locality :: Maybe Text, + region :: Maybe Text, + postalCode :: Maybe Text, + -- TODO: country is specified as ISO3166, but example uses "USA" + country :: Maybe Text, + typ :: Maybe Text, + primary :: Maybe Bool + } + deriving (Show, Eq, Generic) instance FromJSON Address where parseJSON = genericParseJSON parseOptions . jsonLower diff --git a/src/Web/Scim/Schema/User/Certificate.hs b/src/Web/Scim/Schema/User/Certificate.hs index eaee117d29b..e05d41f5526 100644 --- a/src/Web/Scim/Schema/User/Certificate.hs +++ b/src/Web/Scim/Schema/User/Certificate.hs @@ -1,17 +1,16 @@ - module Web.Scim.Schema.User.Certificate where -import Data.Text (Text) import Data.Aeson +import Data.Text (Text) import GHC.Generics - import Web.Scim.Schema.Common - -data Certificate = Certificate - { typ :: Maybe Text - , value :: Maybe Text - } deriving (Show, Eq, Generic) +data Certificate + = Certificate + { typ :: Maybe Text, + value :: Maybe Text + } + deriving (Show, Eq, Generic) instance FromJSON Certificate where parseJSON = genericParseJSON parseOptions . jsonLower diff --git a/src/Web/Scim/Schema/User/Email.hs b/src/Web/Scim/Schema/User/Email.hs index b913ad40094..b8a1fd5c489 100644 --- a/src/Web/Scim/Schema/User/Email.hs +++ b/src/Web/Scim/Schema/User/Email.hs @@ -1,15 +1,15 @@ - module Web.Scim.Schema.User.Email where -import Data.Text hiding (dropWhile) -import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Aeson +import Data.Text hiding (dropWhile) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import GHC.Generics (Generic) -import Web.Scim.Schema.Common import Text.Email.Validate +import Web.Scim.Schema.Common -newtype EmailAddress2 = EmailAddress2 - { unEmailAddress :: EmailAddress } +newtype EmailAddress2 + = EmailAddress2 + {unEmailAddress :: EmailAddress} deriving (Show, Eq) instance FromJSON EmailAddress2 where @@ -20,11 +20,13 @@ instance FromJSON EmailAddress2 where instance ToJSON EmailAddress2 where toJSON (EmailAddress2 e) = String $ decodeUtf8 . toByteString $ e -data Email = Email - { typ :: Maybe Text - , value :: EmailAddress2 - , primary :: Maybe Bool - } deriving (Show, Eq, Generic) +data Email + = Email + { typ :: Maybe Text, + value :: EmailAddress2, + primary :: Maybe Bool + } + deriving (Show, Eq, Generic) instance FromJSON Email where parseJSON = genericParseJSON parseOptions . jsonLower diff --git a/src/Web/Scim/Schema/User/IM.hs b/src/Web/Scim/Schema/User/IM.hs index 0eeecdc5fea..98ac7575de4 100644 --- a/src/Web/Scim/Schema/User/IM.hs +++ b/src/Web/Scim/Schema/User/IM.hs @@ -1,16 +1,16 @@ - module Web.Scim.Schema.User.IM where -import Data.Text (Text) import Data.Aeson +import Data.Text (Text) import GHC.Generics - import Web.Scim.Schema.Common -data IM = IM - { typ :: Maybe Text - , value :: Maybe Text - } deriving (Show, Eq, Generic) +data IM + = IM + { typ :: Maybe Text, + value :: Maybe Text + } + deriving (Show, Eq, Generic) instance FromJSON IM where parseJSON = genericParseJSON parseOptions . jsonLower diff --git a/src/Web/Scim/Schema/User/Name.hs b/src/Web/Scim/Schema/User/Name.hs index 07de4418eac..2ff94dea2dc 100644 --- a/src/Web/Scim/Schema/User/Name.hs +++ b/src/Web/Scim/Schema/User/Name.hs @@ -1,19 +1,20 @@ - module Web.Scim.Schema.User.Name where -import Data.Text (Text) import Data.Aeson +import Data.Text (Text) import GHC.Generics import Web.Scim.Schema.Common -data Name = Name - { formatted :: Maybe Text - , familyName :: Maybe Text - , givenName :: Maybe Text - , middleName :: Maybe Text - , honorificPrefix :: Maybe Text - , honorificSuffix :: Maybe Text - } deriving (Show, Eq, Generic) +data Name + = Name + { formatted :: Maybe Text, + familyName :: Maybe Text, + givenName :: Maybe Text, + middleName :: Maybe Text, + honorificPrefix :: Maybe Text, + honorificSuffix :: Maybe Text + } + deriving (Show, Eq, Generic) instance FromJSON Name where parseJSON = genericParseJSON parseOptions . jsonLower diff --git a/src/Web/Scim/Schema/User/Phone.hs b/src/Web/Scim/Schema/User/Phone.hs index 947990fa887..4da1c66bb4d 100644 --- a/src/Web/Scim/Schema/User/Phone.hs +++ b/src/Web/Scim/Schema/User/Phone.hs @@ -1,15 +1,16 @@ - module Web.Scim.Schema.User.Phone where -import Data.Text hiding (dropWhile) import Data.Aeson +import Data.Text hiding (dropWhile) import GHC.Generics (Generic) import Web.Scim.Schema.Common -data Phone = Phone - { typ :: Maybe Text - , value :: Maybe Text - } deriving (Show, Eq, Generic) +data Phone + = Phone + { typ :: Maybe Text, + value :: Maybe Text + } + deriving (Show, Eq, Generic) instance FromJSON Phone where parseJSON = genericParseJSON parseOptions . jsonLower diff --git a/src/Web/Scim/Schema/User/Photo.hs b/src/Web/Scim/Schema/User/Photo.hs index 1565c09a10a..7727798b8bd 100644 --- a/src/Web/Scim/Schema/User/Photo.hs +++ b/src/Web/Scim/Schema/User/Photo.hs @@ -1,15 +1,16 @@ - module Web.Scim.Schema.User.Photo where -import Data.Text (Text) import Data.Aeson +import Data.Text (Text) import GHC.Generics import Web.Scim.Schema.Common -data Photo = Photo - { typ :: Maybe Text - , value :: Maybe URI - } deriving (Show, Eq, Generic) +data Photo + = Photo + { typ :: Maybe Text, + value :: Maybe URI + } + deriving (Show, Eq, Generic) instance FromJSON Photo where parseJSON = genericParseJSON parseOptions . jsonLower diff --git a/src/Web/Scim/Schema/UserTypes.hs b/src/Web/Scim/Schema/UserTypes.hs index a1ecb93f6c2..653b43b28c7 100644 --- a/src/Web/Scim/Schema/UserTypes.hs +++ b/src/Web/Scim/Schema/UserTypes.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} + module Web.Scim.Schema.UserTypes where import Web.Scim.Schema.Schema (Schema) @@ -7,8 +8,10 @@ import Web.Scim.Schema.Schema (Schema) class UserTypes tag where -- | User ID type. type UserId tag + -- | Extra data carried with each 'User'. type UserExtra tag + -- | Schemas supported by the 'User' for filtering and patching. -- -- This must include User20, this is not checked. diff --git a/src/Web/Scim/Server.hs b/src/Web/Scim/Server.hs index e2930e094a4..b54c3326f60 100644 --- a/src/Web/Scim/Server.hs +++ b/src/Web/Scim/Server.hs @@ -1,29 +1,35 @@ {-# LANGUAGE AllowAmbiguousTypes #-} module Web.Scim.Server - ( - -- * WAI application - app, mkapp, App - - -- * API tree - , SiteAPI, siteServer - -- ** API subtrees, useful for tests - , ConfigAPI, configServer - , UserAPI, userServer - , GroupAPI, groupServer - ) where - -import GHC.Generics (Generic) -import Network.Wai -import Servant -import Servant.API.Generic -import Servant.Server.Generic - -import Web.Scim.Class.User (UserSite (..), UserDB (..), userServer) -import Web.Scim.Class.Group (GroupSite (..), GroupTypes (..), GroupDB, groupServer) -import Web.Scim.Class.Auth (AuthDB (..), AuthTypes (..)) -import Web.Scim.Capabilities.MetaSchema (ConfigSite, Configuration, configServer) -import Web.Scim.Handler + ( -- * WAI application + app, + mkapp, + App, + + -- * API tree + SiteAPI, + siteServer, + + -- ** API subtrees, useful for tests + ConfigAPI, + configServer, + UserAPI, + userServer, + GroupAPI, + groupServer, + ) +where + +import GHC.Generics (Generic) +import Network.Wai +import Servant +import Servant.API.Generic +import Servant.Server.Generic +import Web.Scim.Capabilities.MetaSchema (ConfigSite, Configuration, configServer) +import Web.Scim.Class.Auth (AuthDB (..), AuthTypes (..)) +import Web.Scim.Class.Group (GroupDB, GroupSite (..), GroupTypes (..), groupServer) +import Web.Scim.Class.User (UserDB (..), UserSite (..), userServer) +import Web.Scim.Handler ---------------------------------------------------------------------------- -- API specification @@ -33,56 +39,74 @@ import Web.Scim.Handler type DB tag m = (UserDB tag m, GroupDB tag m, AuthDB tag m) type ConfigAPI = ToServantApi ConfigSite + type UserAPI tag = ToServantApi (UserSite tag) + type GroupAPI tag = ToServantApi (GroupSite tag) + type SiteAPI tag = ToServantApi (Site tag) -data Site tag route = Site - { config :: route :- - ConfigAPI - , users :: route :- - Header "Authorization" (AuthData tag) :> - "Users" :> UserAPI tag - , groups :: route :- - Header "Authorization" (AuthData tag) :> - "Groups" :> GroupAPI tag - } deriving (Generic) +data Site tag route + = Site + { config :: + route + :- ConfigAPI, + users :: + route + :- Header "Authorization" (AuthData tag) + :> "Users" + :> UserAPI tag, + groups :: + route + :- Header "Authorization" (AuthData tag) + :> "Groups" + :> GroupAPI tag + } + deriving (Generic) ---------------------------------------------------------------------------- -- API implementation siteServer :: - forall tag m. (DB tag m, Show (GroupId tag)) => - Configuration -> Site tag (AsServerT (ScimHandler m)) -siteServer conf = Site - { config = toServant $ configServer conf - , users = \authData -> toServant (userServer @tag authData) - , groups = \authData -> toServant (groupServer @tag authData) - } + forall tag m. + (DB tag m, Show (GroupId tag)) => + Configuration -> + Site tag (AsServerT (ScimHandler m)) +siteServer conf = + Site + { config = toServant $ configServer conf, + users = \authData -> toServant (userServer @tag authData), + groups = \authData -> toServant (groupServer @tag authData) + } where ---------------------------------------------------------------------------- -- Server-starting utilities type App tag m api = - ( DB tag m - , Show (GroupId tag) - , HasServer api '[] + ( DB tag m, + Show (GroupId tag), + HasServer api '[] ) -mkapp :: forall tag m api. (App tag m api) - => Proxy api - -> ServerT api (ScimHandler m) - -> (forall a. ScimHandler m a -> Handler a) - -> Application +mkapp :: + forall tag m api. + (App tag m api) => + Proxy api -> + ServerT api (ScimHandler m) -> + (forall a. ScimHandler m a -> Handler a) -> + Application mkapp proxy api nt = serve proxy $ hoistServer proxy nt api -app :: forall tag m. App tag m (SiteAPI tag) - => Configuration - -> (forall a. ScimHandler m a -> Handler a) - -> Application -app c = mkapp @tag - (Proxy @(SiteAPI tag)) - (toServant $ siteServer c) +app :: + forall tag m. + App tag m (SiteAPI tag) => + Configuration -> + (forall a. ScimHandler m a -> Handler a) -> + Application +app c = + mkapp @tag + (Proxy @(SiteAPI tag)) + (toServant $ siteServer c) diff --git a/src/Web/Scim/Server/Mock.hs b/src/Web/Scim/Server/Mock.hs index 0615d15f107..7a910cd4984 100644 --- a/src/Web/Scim/Server/Mock.hs +++ b/src/Web/Scim/Server/Mock.hs @@ -1,40 +1,38 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} -- | A mock server for use in our testsuite, as well as for automated -- compliance testing (e.g. with Runscope – see -- ). - module Web.Scim.Server.Mock where -import Web.Scim.Class.Group hiding (value) -import Web.Scim.Class.User -import Web.Scim.Class.Auth -import Control.Monad.STM (STM, atomically) -import Control.Monad.Reader -import Control.Monad.Morph -import Data.Aeson -import Data.Hashable -import Data.Text (Text, pack, toCaseFold) -import Data.Time.Clock -import Data.Time.Calendar -import GHC.Exts (sortWith) -import ListT +import Control.Monad.Morph +import Control.Monad.Reader +import Control.Monad.STM (STM, atomically) +import Data.Aeson +import Data.Hashable +import Data.Text (Text, pack, toCaseFold) +import Data.Time.Calendar +import Data.Time.Clock +import GHC.Exts (sortWith) +import ListT import qualified Network.URI as URI +import Servant import qualified StmContainers.Map as STMMap -import Text.Read (readMaybe) -import Web.Scim.Filter (Filter(..), CompValue(..), AttrPath(..), compareStr) -import Web.Scim.Schema.User -import Web.Scim.Schema.Error -import Web.Scim.Schema.Meta -import Web.Scim.Schema.ListResponse -import Web.Scim.Schema.ResourceType -import Web.Scim.Schema.Schema (Schema(User20)) -import Web.Scim.Schema.Common (WithId(WithId, value)) -import qualified Web.Scim.Schema.Common as Common -import Web.Scim.Handler -import Servant +import Text.Read (readMaybe) +import Web.Scim.Class.Auth +import Web.Scim.Class.Group hiding (value) +import Web.Scim.Class.User +import Web.Scim.Filter (AttrPath (..), CompValue (..), Filter (..), compareStr) +import Web.Scim.Handler +import Web.Scim.Schema.Common (WithId (WithId, value)) +import qualified Web.Scim.Schema.Common as Common +import Web.Scim.Schema.Error +import Web.Scim.Schema.ListResponse +import Web.Scim.Schema.Meta +import Web.Scim.Schema.ResourceType +import Web.Scim.Schema.Schema (Schema (User20)) +import Web.Scim.Schema.User -- | Tag used in the mock server. data Mock @@ -43,21 +41,24 @@ data Mock -- -- >>> eitherDecode' @Id . encode $ (Id 3) -- Right (Id {unId = 3}) -newtype Id = Id { unId :: Int } +newtype Id = Id {unId :: Int} deriving (Eq, Show, Ord, Hashable, ToHttpApiData, FromHttpApiData) instance ToJSON Id where toJSON = toJSON . show . unId + instance FromJSON Id where parseJSON = maybe (fail "not a number") (pure . Id) . readMaybe <=< parseJSON -type UserStorage = STMMap.Map Id (StoredUser Mock) +type UserStorage = STMMap.Map Id (StoredUser Mock) + type GroupStorage = STMMap.Map Id (StoredGroup Mock) -data TestStorage = TestStorage - { userDB :: UserStorage - , groupDB :: GroupStorage - } +data TestStorage + = TestStorage + { userDB :: UserStorage, + groupDB :: GroupStorage + } emptyTestStorage :: IO TestStorage emptyTestStorage = @@ -87,17 +88,17 @@ instance UserDB Mock TestServer where let check user = case mbFilter of Nothing -> pure True Just filter_ -> do - let user' = value (thing user) -- unwrap + let user' = value (thing user) -- unwrap case filterUser filter_ user' of Right res -> pure res - Left err -> throwScim (badRequest InvalidFilter (Just err)) + Left err -> throwScim (badRequest InvalidFilter (Just err)) fromList . sortWith (Common.id . thing) <$> filterM check (snd <$> users) getUser () uid = do m <- userDB <$> ask liftSTM (STMMap.lookup uid m) >>= \case Nothing -> throwScim (notFound "User" (pack (show uid))) - Just x -> pure x + Just x -> pure x postUser () user = do m <- userDB <$> ask @@ -176,38 +177,40 @@ instance AuthTypes Mock where instance AuthDB Mock TestServer where authCheck = \case - Just "authorized" -> pure () - _ -> throwScim (unauthorized "expected 'authorized'") + Just "authorized" -> pure () + _ -> throwScim (unauthorized "expected 'authorized'") ---------------------------------------------------------------------------- -- Misc -- 2018-01-01 00:00 testDate :: UTCTime -testDate = UTCTime - { utctDay = ModifiedJulianDay 58119 - , utctDayTime = 0 - } +testDate = + UTCTime + { utctDay = ModifiedJulianDay 58119, + utctDayTime = 0 + } -- static meta for testing createMeta :: ResourceType -> Meta -createMeta rType = Meta - { resourceType = rType - , created = testDate - , lastModified = testDate - , version = Weak "testVersion" - , location = Common.URI $ -- FUTUREWORK: getting the actual schema, authority, and path here - -- is a bit of work, but it may be required one day. - URI "https:" (Just $ URI.URIAuth "" "example.com" "") "/Users/id" "" "" - } +createMeta rType = + Meta + { resourceType = rType, + created = testDate, + lastModified = testDate, + version = Weak "testVersion", + location = + Common.URI $ -- FUTUREWORK: getting the actual schema, authority, and path here + -- is a bit of work, but it may be required one day. + URI "https:" (Just $ URI.URIAuth "" "example.com" "") "/Users/id" "" "" + } -- Natural transformation from our transformer stack to the Servant stack -- this takes the initial environment and returns the transformation nt :: TestStorage -> ScimHandler TestServer a -> Handler a nt storage = - flip runReaderT storage . - fromScimHandler (lift . throwError . scimToServerError) - + flip runReaderT storage + . fromScimHandler (lift . throwError . scimToServerError) -- | Check whether a user satisfies the filter. -- @@ -218,11 +221,13 @@ nt storage = filterUser :: Filter -> User extra -> Either Text Bool filterUser (FilterAttrCompare (AttrPath schema' attrib subAttr) op val) user | isUserSchema schema' = - case (subAttr, val) of - (Nothing, (ValString str)) | attrib == "userName" -> + case (subAttr, val) of + (Nothing, (ValString str)) + | attrib == "userName" -> Right (compareStr op (toCaseFold (userName user)) (toCaseFold str)) - (Nothing, _) | attrib == "userName" -> + (Nothing, _) + | attrib == "userName" -> Left "usernames can only be compared with strings" - (_, _) -> - Left "Only search on usernames is currently supported" + (_, _) -> + Left "Only search on usernames is currently supported" | otherwise = Left "Invalid schema. Only user schema is supported" diff --git a/src/Web/Scim/Test/Acceptance.hs b/src/Web/Scim/Test/Acceptance.hs index c1cf1aaf32b..05bbea231fa 100644 --- a/src/Web/Scim/Test/Acceptance.hs +++ b/src/Web/Scim/Test/Acceptance.hs @@ -1,12 +1,14 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} + -- | A bunch of hspec acceptance tests that assert that your SCIM -- implementation is compatible with popular SCIM 2.0 providers module Web.Scim.Test.Acceptance ( module Web.Scim.Test.Acceptance, - module Web.Scim.Test.Util - ) where + module Web.Scim.Test.Util, + ) +where import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as Aeson @@ -17,23 +19,21 @@ import Data.Text (Text) import Network.HTTP.Types.Status import Network.Wai.Test import Servant.API as Servant -import Test.Hspec (Spec, it, shouldBe, beforeAll, pending, pendingWith, describe) -import Test.Hspec.Wai.Internal (runWaiSession) +import Test.Hspec (Spec, beforeAll, describe, it, pending, pendingWith, shouldBe) import Test.Hspec.Wai (matchStatus) -import Web.Scim.Test.Util +import Test.Hspec.Wai.Internal (runWaiSession) import Web.Scim.Class.User import Web.Scim.Schema.Common as Hscim import Web.Scim.Schema.Meta import Web.Scim.Schema.UserTypes - +import Web.Scim.Test.Util ignore :: Monad m => m a -> m () ignore _ = pure () - -- https://docs.microsoft.com/en-us/azure/active-directory/manage-apps/use-scim-to-provision-users-and-groups#step-2-understand-the-azure-ad-scim-implementation microsoftAzure :: forall tag. (Aeson.FromJSON (UserId tag), Aeson.FromJSON (UserExtra tag), ToHttpApiData (UserId tag)) => AcceptanceConfig tag -> Spec -microsoftAzure AcceptanceConfig{..} = do +microsoftAzure AcceptanceConfig {..} = do describe "Within the SCIM 2.0 protocol specification, your application must meet these requirements:" $ do it "Supports creating users, and optionally also groups, as per section 3.3 of the SCIM protocol." $ pending -- TODO(arianvp): Write test it "Supports modifying users or groups with PATCH requests, as per section 3.5.2 of the SCIM protocol." $ pending -- TODO(arianvp): Write test @@ -46,7 +46,6 @@ microsoftAzure AcceptanceConfig{..} = do it "Accepts a single bearer token for authentication and authorization of Azure AD to your application." $ -- This is provided by the library True `shouldBe` True - describe "Follow these general guidelines when implementing a SCIM endpoint to ensure compatibility with Azure AD:" $ do it "id is a required property for all the resources. Every response that returns a resource should ensure each resource has this property, except for ListResponse with zero members." $ -- NOTE: This is guaranteed by the type-system. No need for a test @@ -65,7 +64,6 @@ microsoftAzure AcceptanceConfig{..} = do it "eq" $ pending -- TODO(arianvp): Implement 'and' as Azure needs it it "and" $ pending - describe "good errors" $ do -- (we may touch servant for this?) it "surfaces parse errors of the user id path segment" $ do @@ -74,24 +72,22 @@ microsoftAzure AcceptanceConfig{..} = do pending it "same for all other things parsed in path, query, body, ..." $ do pending - beforeAll scimAppAndConfig $ do it "User Operations" $ \(app, queryConfig) -> flip runWaiSession app $ do userName1 <- liftIO genUserName userName2 <- liftIO genUserName - -- POST /Users resp :: SResponse <- post' queryConfig "/Users" (sampleUser1 userName1) liftIO $ simpleStatus resp `shouldBe` status201 let testuid :: BS.ByteString - testuid = either (error . show . (, resp)) (cs . Servant.toUrlPiece . Hscim.id . thing) - $ Aeson.eitherDecode' @(StoredUser tag) (simpleBody resp) - + testuid = + either (error . show . (,resp)) (cs . Servant.toUrlPiece . Hscim.id . thing) $ + Aeson.eitherDecode' @(StoredUser tag) (simpleBody resp) -- Get user by query get' queryConfig (cs $ "/Users?filter userName eq " <> show userName1) `shouldRespondWith` 200 - -- Get user by query, zero results - get' queryConfig (cs $ "/Users?filter=userName eq " <> show userName2) `shouldRespondWith` [scim| + get' queryConfig (cs $ "/Users?filter=userName eq " <> show userName2) + `shouldRespondWith` [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "totalResults": 0, @@ -99,13 +95,17 @@ microsoftAzure AcceptanceConfig{..} = do "startIndex": 1, "itemsPerPage": 0 } - |] { matchStatus = 200 } - + |] + { matchStatus = 200 + } -- Get user by externalId works get' queryConfig "/Users?filter externalId eq \"0a21f0f2-8d2a-4f8e-479e-a20b-2d77186b5dd1\"" `shouldRespondWith` 200 - -- Update user [Multi-valued properties] - ignore $ patch' queryConfig "/Users/0" [scim| + ignore $ + patch' + queryConfig + "/Users/0" + [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [ @@ -121,11 +121,12 @@ microsoftAzure AcceptanceConfig{..} = do } ] } - |] `shouldRespondWith` 200 - + |] + `shouldRespondWith` 200 -- update user [single-valued properties] -- replace userName - let ops1 = [scim| + let ops1 = + [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ @@ -136,9 +137,9 @@ microsoftAzure AcceptanceConfig{..} = do } |] patch' queryConfig ("/Users/" <> testuid) ops1 `shouldRespondWith` 200 - -- replace displayName - let ops2 = [scim| + let ops2 = + [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ @@ -148,8 +149,8 @@ microsoftAzure AcceptanceConfig{..} = do }] } |] - - exactResult = [scim| + exactResult = + [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User", @@ -181,13 +182,14 @@ microsoftAzure AcceptanceConfig{..} = do "externalId": "0a21f0f2-8d2a-4f8e-bf98-7363c4aed4ef" } |] - result = if responsesFullyKnown - then exactResult - else 200 -- TODO(fisx): check the fields changed by the patch operations? + result = + if responsesFullyKnown + then exactResult + else 200 -- TODO(fisx): check the fields changed by the patch operations? patch' queryConfig ("/Users/" <> testuid) ops2 `shouldRespondWith` result - -- remove displayName - let op3 = [scim| + let op3 = + [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ @@ -196,7 +198,8 @@ microsoftAzure AcceptanceConfig{..} = do }] } |] - exactResult3 = [scim| + exactResult3 = + [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User", @@ -227,20 +230,19 @@ microsoftAzure AcceptanceConfig{..} = do "externalId": "0a21f0f2-8d2a-4f8e-bf98-7363c4aed4ef" } |] - result3 = if responsesFullyKnown - then exactResult3 - else 200 -- TODO(fisx): check the fields changed by the patch operations? + result3 = + if responsesFullyKnown + then exactResult3 + else 200 -- TODO(fisx): check the fields changed by the patch operations? patch' queryConfig ("/Users/" <> testuid) op3 `shouldRespondWith` result3 - -- Delete User delete' queryConfig ("/Users/" <> testuid) "" `shouldRespondWith` 204 delete' queryConfig ("/Users/" <> testuid) "" `shouldEventuallyRespondWith` 404 - it "Group operations" $ \_ -> pending - sampleUser1 :: Text -> L.ByteString -sampleUser1 userName1 = [scim| +sampleUser1 userName1 = + [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User", diff --git a/src/Web/Scim/Test/Util.hs b/src/Web/Scim/Test/Util.hs index edac0028677..43da52b1fcf 100644 --- a/src/Web/Scim/Test/Util.hs +++ b/src/Web/Scim/Test/Util.hs @@ -1,52 +1,64 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} -module Web.Scim.Test.Util ( - shouldRespondWith, +module Web.Scim.Test.Util + ( shouldRespondWith, shouldEventuallyRespondWith, - -- * Making wai requests - post, put, patch, - AcceptanceConfig(..), defAcceptanceConfig, - AcceptanceQueryConfig(..), defAcceptanceQueryConfig, - post', put', patch', get', delete' - -- * Request/response quasiquoter - , scim - -- * JSON parsing - , Field(..) - , getField - -- * Tag - , TestTag - ) where + + -- * Making wai requests + post, + put, + patch, + AcceptanceConfig (..), + defAcceptanceConfig, + AcceptanceQueryConfig (..), + defAcceptanceQueryConfig, + post', + put', + patch', + get', + delete', + + -- * Request/response quasiquoter + scim, + + -- * JSON parsing + Field (..), + getField, + + -- * Tag + TestTag, + ) +where import qualified Control.Retry as Retry -import Data.ByteString (ByteString) +import Data.Aeson +import Data.Aeson.Internal ((), JSONPathElement (Key)) +import Data.Aeson.QQ +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as L -import Data.Aeson -import Data.Aeson.Internal (JSONPathElement (Key), ()) -import Data.Aeson.QQ -import Data.Proxy -import Data.Text -import Data.UUID as UUID -import Data.UUID.V4 as UUID -import GHC.Stack -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) -import Language.Haskell.TH.Quote -import Network.HTTP.Types -import Network.Wai (Application) -import Network.Wai.Test (SResponse) -import Test.Hspec.Expectations (expectationFailure) -import Test.Hspec.Wai hiding (post, put, patch, shouldRespondWith) -import Test.Hspec.Wai.Matcher (bodyEquals) -import Test.Hspec.Wai.Matcher (match) import qualified Data.HashMap.Strict as SMap - -import Web.Scim.Schema.User (UserTypes (..)) -import Web.Scim.Class.Group (GroupTypes (..)) -import Web.Scim.Class.Auth (AuthTypes (..)) -import Web.Scim.Schema.Schema (Schema (User20, CustomSchema)) +import Data.Proxy +import Data.Text +import Data.UUID as UUID +import Data.UUID.V4 as UUID +import GHC.Stack +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Language.Haskell.TH.Quote +import Network.HTTP.Types +import Network.Wai (Application) +import Network.Wai.Test (SResponse) +import Test.Hspec.Expectations (expectationFailure) +import Test.Hspec.Wai hiding (patch, post, put, shouldRespondWith) +import Test.Hspec.Wai.Matcher (bodyEquals) +import Test.Hspec.Wai.Matcher (match) +import Web.Scim.Class.Auth (AuthTypes (..)) +import Web.Scim.Class.Group (GroupTypes (..)) +import Web.Scim.Schema.Schema (Schema (CustomSchema, User20)) +import Web.Scim.Schema.User (UserTypes (..)) -- | re-implementation of 'shouldRespondWith' with better error reporting. -- FUTUREWORK: make this a PR upstream. (while we're at it, we can also patch 'WaiSession' @@ -64,37 +76,41 @@ doesRespondWith action matcher = do shouldEventuallyRespondWith :: HasCallStack => WaiSession SResponse -> ResponseMatcher -> WaiExpectation shouldEventuallyRespondWith action matcher = - either (liftIO . expectationFailure) pure =<< - Retry.retrying (Retry.exponentialBackoff 66000 <> Retry.limitRetries 6) + either (liftIO . expectationFailure) pure + =<< Retry.retrying + (Retry.exponentialBackoff 66000 <> Retry.limitRetries 6) (\_ -> pure . either (const True) (const False)) (\_ -> doesRespondWith action matcher) -data AcceptanceConfig tag = AcceptanceConfig - { scimAppAndConfig :: IO (Application, AcceptanceQueryConfig tag) - , genUserName :: IO Text - , responsesFullyKnown :: Bool -- ^ some acceptance tests match against a fully rendered - -- response body, which will now work when running the test - -- as a library user (since the response will have more and - -- other information). if you leave this on 'False' (default - -- from 'defAcceptanceConfig'), the test will only check some - -- invariants on the response instead that must hold in all - -- cases. - } +data AcceptanceConfig tag + = AcceptanceConfig + { scimAppAndConfig :: IO (Application, AcceptanceQueryConfig tag), + genUserName :: IO Text, + -- | some acceptance tests match against a fully rendered + -- response body, which will now work when running the test + -- as a library user (since the response will have more and + -- other information). if you leave this on 'False' (default + -- from 'defAcceptanceConfig'), the test will only check some + -- invariants on the response instead that must hold in all + -- cases. + responsesFullyKnown :: Bool + } defAcceptanceConfig :: IO Application -> AcceptanceConfig tag -defAcceptanceConfig scimApp = AcceptanceConfig{..} +defAcceptanceConfig scimApp = AcceptanceConfig {..} where - scimAppAndConfig = (, defAcceptanceQueryConfig) <$> scimApp - genUserName = ("Test_User_" <>) . UUID.toText <$> UUID.nextRandom + scimAppAndConfig = (,defAcceptanceQueryConfig) <$> scimApp + genUserName = ("Test_User_" <>) . UUID.toText <$> UUID.nextRandom responsesFullyKnown = False -data AcceptanceQueryConfig tag = AcceptanceQueryConfig - { scimPathPrefix :: BS.ByteString - , scimAuthToken :: BS.ByteString - } +data AcceptanceQueryConfig tag + = AcceptanceQueryConfig + { scimPathPrefix :: BS.ByteString, + scimAuthToken :: BS.ByteString + } defAcceptanceQueryConfig :: AcceptanceQueryConfig tag -defAcceptanceQueryConfig = AcceptanceQueryConfig{..} +defAcceptanceQueryConfig = AcceptanceQueryConfig {..} where scimPathPrefix = "" scimAuthToken = "authorized" @@ -110,8 +126,8 @@ defAcceptanceQueryConfig = AcceptanceQueryConfig{..} () :: ByteString -> ByteString -> ByteString () a b = a' <> "/" <> b' where - a' = maybe a (\(t,l) -> if l == '/' then t else a) $ BS8.unsnoc a - b' = maybe b (\(h,t) -> if h == '/' then t else b) $ BS8.uncons b + a' = maybe a (\(t, l) -> if l == '/' then t else a) $ BS8.unsnoc a + b' = maybe b (\(h, t) -> if h == '/' then t else b) $ BS8.uncons b post :: ByteString -> L.ByteString -> WaiSession SResponse post path = request methodPost path [(hContentType, "application/scim+json")] @@ -140,7 +156,6 @@ patch' = request' methodPatch delete' :: AcceptanceQueryConfig tag -> ByteString -> L.ByteString -> WaiSession SResponse delete' = request' methodDelete - ---------------------------------------------------------------------------- -- Redefine wai quasiquoter -- @@ -152,12 +167,13 @@ delete' = request' methodDelete -- | A response matcher and quasiquoter that should be used instead of -- 'Test.Hspec.Wai.JSON.json'. scim :: QuasiQuoter -scim = QuasiQuoter - { quoteExp = \input -> [|fromValue $(quoteExp aesonQQ input)|] - , quotePat = const $ error "No quotePat defined for Test.Util.scim" - , quoteType = const $ error "No quoteType defined for Test.Util.scim" - , quoteDec = const $ error "No quoteDec defined for Test.Util.scim" - } +scim = + QuasiQuoter + { quoteExp = \input -> [|fromValue $(quoteExp aesonQQ input)|], + quotePat = const $ error "No quotePat defined for Test.Util.scim", + quoteType = const $ error "No quoteType defined for Test.Util.scim", + quoteDec = const $ error "No quoteDec defined for Test.Util.scim" + } class FromValue a where fromValue :: Value -> a @@ -196,13 +212,13 @@ getField (Field a) = a instance (KnownSymbol s, FromJSON a) => FromJSON (Field s a) where parseJSON = withObject ("Field " <> show key) $ \obj -> case SMap.lookup key obj of - Nothing -> fail $ "key " ++ show key ++ " not present" - Just v -> Field <$> parseJSON v Key key + Nothing -> fail $ "key " ++ show key ++ " not present" + Just v -> Field <$> parseJSON v Key key where key = pack $ symbolVal (Proxy :: Proxy s) instance (KnownSymbol s, ToJSON a) => ToJSON (Field s a) where - toJSON (Field x) = object [ key .= x] + toJSON (Field x) = object [key .= x] where key = pack $ symbolVal (Proxy :: Proxy s) diff --git a/test/Test/AcceptanceSpec.hs b/test/Test/AcceptanceSpec.hs index f18fe18551d..6de44eb92a5 100644 --- a/test/Test/AcceptanceSpec.hs +++ b/test/Test/AcceptanceSpec.hs @@ -1,19 +1,15 @@ -- | A set of acceptance tests that you can use to test that your server is module Test.AcceptanceSpec where -import Test.Hspec (Spec, describe) -import Web.Scim.Server (app) -import Web.Scim.Server.Mock - -import Web.Scim.Capabilities.MetaSchema (empty) -import Web.Scim.Test.Acceptance (microsoftAzure, defAcceptanceConfig, responsesFullyKnown) - +import Test.Hspec (Spec, describe) +import Web.Scim.Capabilities.MetaSchema (empty) +import Web.Scim.Server (app) +import Web.Scim.Server.Mock +import Web.Scim.Test.Acceptance (defAcceptanceConfig, microsoftAzure, responsesFullyKnown) spec :: Spec spec = do - let - app' = do - storage <- emptyTestStorage - pure (app @Mock empty (nt storage)) - - describe "Azure" $ microsoftAzure ((defAcceptanceConfig @Mock app') { responsesFullyKnown = True }) + let app' = do + storage <- emptyTestStorage + pure (app @Mock empty (nt storage)) + describe "Azure" $ microsoftAzure ((defAcceptanceConfig @Mock app') {responsesFullyKnown = True}) diff --git a/test/Test/Capabilities/MetaSchemaSpec.hs b/test/Test/Capabilities/MetaSchemaSpec.hs index 7b5a6e2348b..7a01327b8d7 100644 --- a/test/Test/Capabilities/MetaSchemaSpec.hs +++ b/test/Test/Capabilities/MetaSchemaSpec.hs @@ -1,31 +1,35 @@ {-# LANGUAGE QuasiQuotes #-} -module Test.Capabilities.MetaSchemaSpec (spec) where - -import Web.Scim.Test.Util +module Test.Capabilities.MetaSchemaSpec + ( spec, + ) +where +import Data.Aeson +import Data.Coerce import qualified Data.List as List -import Data.Aeson -import Data.Text (Text) -import Data.Coerce -import Web.Scim.Capabilities.MetaSchema -import Web.Scim.Server (ConfigAPI, mkapp) -import Web.Scim.Server.Mock -import Network.Wai.Test (SResponse (..)) -import Servant -import Servant.API.Generic - -import Test.Hspec hiding (shouldSatisfy) +import Data.Text (Text) +import Network.Wai.Test (SResponse (..)) +import Servant +import Servant.API.Generic +import Test.Hspec hiding (shouldSatisfy) import qualified Test.Hspec.Expectations as Expect -import Test.Hspec.Wai hiding (post, put, patch, shouldRespondWith) +import Test.Hspec.Wai hiding (patch, post, put, shouldRespondWith) +import Web.Scim.Capabilities.MetaSchema +import Web.Scim.Server (ConfigAPI, mkapp) +import Web.Scim.Server.Mock +import Web.Scim.Test.Util app :: IO Application app = do storage <- emptyTestStorage pure $ mkapp @Mock (Proxy @ConfigAPI) (toServant (configServer empty)) (nt storage) -shouldSatisfy :: (Show a, FromJSON a) => - WaiSession SResponse -> (a -> Bool) -> WaiExpectation +shouldSatisfy :: + (Show a, FromJSON a) => + WaiSession SResponse -> + (a -> Bool) -> + WaiExpectation shouldSatisfy resp predicate = do maybeDecoded <- eitherDecode . simpleBody <$> resp case maybeDecoded of @@ -40,11 +44,11 @@ type SchemasResponse = Field "Resources" [Field "id" Text] coreSchemas :: [Text] coreSchemas = - [ "urn:ietf:params:scim:schemas:core:2.0:User" - , "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig" - , "urn:ietf:params:scim:schemas:core:2.0:Group" - , "urn:ietf:params:scim:schemas:core:2.0:Schema" - , "urn:ietf:params:scim:schemas:core:2.0:ResourceType" + [ "urn:ietf:params:scim:schemas:core:2.0:User", + "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig", + "urn:ietf:params:scim:schemas:core:2.0:Group", + "urn:ietf:params:scim:schemas:core:2.0:Schema", + "urn:ietf:params:scim:schemas:core:2.0:ResourceType" ] spec :: Spec @@ -54,7 +58,6 @@ spec = beforeAll app $ do get "/Schemas" `shouldRespondWith` 200 get "/Schemas" `shouldSatisfy` \(resp :: SchemasResponse) -> List.sort (coerce resp) == List.sort coreSchemas - describe "GET /Schemas/:id" $ do it "returns valid schema" $ do -- TODO: (partially) verify content @@ -62,19 +65,17 @@ spec = beforeAll app $ do `shouldRespondWith` 200 it "returns 404 on unknown schemaId" $ do get "/Schemas/unknown" `shouldRespondWith` 404 - describe "GET /ServiceProviderConfig" $ do it "returns configuration" $ do get "/ServiceProviderConfig" `shouldRespondWith` spConfig - describe "GET /ResourceTypes" $ do it "returns resource types" $ do get "/ResourceTypes" `shouldRespondWith` resourceTypes - -- FIXME: missing some "supported" fields spConfig :: ResponseMatcher -spConfig = [scim| +spConfig = + [scim| {"schemas":["urn:ietf:params:scim:schemas:core:2.0:User", "urn:ietf:params:scim:schemas:core:2.0:ServiceProviderConfig", "urn:ietf:params:scim:schemas:core:2.0:Group", @@ -103,7 +104,8 @@ spConfig = [scim| |] resourceTypes :: ResponseMatcher -resourceTypes = [scim| +resourceTypes = + [scim| {"schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "Resources":[ {"schema":"urn:ietf:params:scim:schemas:core:2.0:User", diff --git a/test/Test/Class/AuthSpec.hs b/test/Test/Class/AuthSpec.hs index 921311022a3..5280c47a8bd 100644 --- a/test/Test/Class/AuthSpec.hs +++ b/test/Test/Class/AuthSpec.hs @@ -1,17 +1,20 @@ {-# LANGUAGE QuasiQuotes #-} -module Test.Class.AuthSpec (spec) where - -import Web.Scim.Server (app) -import Web.Scim.Server.Mock -import Web.Scim.Capabilities.MetaSchema (empty) -import Data.Text (Text) -import Data.Text.Encoding -import Test.Hspec -import Test.Hspec.Wai hiding (post, put, patch) -import Network.HTTP.Types.Header -import Network.HTTP.Types.Method (methodGet) -import qualified StmContainers.Map as STMMap +module Test.Class.AuthSpec + ( spec, + ) +where + +import Data.Text (Text) +import Data.Text.Encoding +import Network.HTTP.Types.Header +import Network.HTTP.Types.Method (methodGet) +import qualified StmContainers.Map as STMMap +import Test.Hspec +import Test.Hspec.Wai hiding (patch, post, put) +import Web.Scim.Capabilities.MetaSchema (empty) +import Web.Scim.Server (app) +import Web.Scim.Server.Mock testStorage :: IO TestStorage testStorage = TestStorage <$> STMMap.newIO <*> STMMap.newIO @@ -21,20 +24,16 @@ spec = beforeAll ((\s -> app @Mock empty (nt s)) <$> testStorage) $ do describe "/ServiceProviderConfig" $ do it "is accessible without authentication" $ do get "/ServiceProviderConfig" `shouldRespondWith` 200 - it "doesn't check auth credentials" $ do request methodGet "/ServiceProviderConfig" [authHeader "blah"] "" `shouldRespondWith` 200 - describe "/Users" $ do it "succeeds with authentication" $ do request methodGet "/Users" [authHeader "authorized"] "" `shouldRespondWith` 200 - it "fails if the auth token is invalid" $ do request methodGet "/Users" [authHeader "blah"] "" `shouldRespondWith` 401 - it "fails if no authentication is provided" $ do get "/Users" `shouldRespondWith` 401 diff --git a/test/Test/Class/GroupSpec.hs b/test/Test/Class/GroupSpec.hs index e04cc8747cd..0cb8d2d9988 100644 --- a/test/Test/Class/GroupSpec.hs +++ b/test/Test/Class/GroupSpec.hs @@ -1,72 +1,69 @@ {-# LANGUAGE QuasiQuotes #-} -module Test.Class.GroupSpec (spec) where - -import Web.Scim.Test.Util - -import Network.Wai (Application) -import Servant (Proxy(Proxy)) -import Web.Scim.Server (mkapp, GroupAPI, groupServer) -import Web.Scim.Server.Mock -import Data.ByteString.Lazy (ByteString) -import Test.Hspec hiding (shouldSatisfy) -import Test.Hspec.Wai hiding (post, put, patch, shouldRespondWith) -import Servant.API.Generic +module Test.Class.GroupSpec + ( spec, + ) +where + +import Data.ByteString.Lazy (ByteString) +import Network.Wai (Application) +import Servant (Proxy (Proxy)) +import Servant.API.Generic +import Test.Hspec hiding (shouldSatisfy) +import Test.Hspec.Wai hiding (patch, post, put, shouldRespondWith) +import Web.Scim.Server (GroupAPI, groupServer, mkapp) +import Web.Scim.Server.Mock +import Web.Scim.Test.Util app :: IO Application app = do storage <- emptyTestStorage let auth = Just "authorized" - pure $ mkapp @Mock (Proxy @(GroupAPI Mock)) - (toServant (groupServer @Mock auth)) (nt storage) + pure $ + mkapp @Mock + (Proxy @(GroupAPI Mock)) + (toServant (groupServer @Mock auth)) + (nt storage) spec :: Spec spec = beforeAll app $ do describe "GET & POST /Groups" $ do it "responds with [] in empty environment" $ do get "/" `shouldRespondWith` emptyList - it "can insert then retrieve stored group" $ do post "/" adminGroup `shouldRespondWith` 201 get "/" `shouldRespondWith` groups - describe "GET /Groups/:id" $ do it "responds with 404 for unknown group" $ do get "/9999" `shouldRespondWith` 404 - it "retrieves stored group" $ do -- the test implementation stores groups with uid [0,1..n-1] get "/0" `shouldRespondWith` admins - describe "PUT /Groups/:id" $ do it "adds member to existing group" $ do put "/0" adminUpdate0 `shouldRespondWith` updatedAdmins0 - it "does not create new group" $ do put "/9999" adminGroup `shouldRespondWith` 404 - describe "DELETE /Groups/:id" $ do it "responds with 404 for unknown group" $ do delete "/Users/unknown" `shouldRespondWith` 404 - it "deletes a stored group" $ do delete "/0" `shouldRespondWith` 204 -- group should be gone - get "/0" `shouldRespondWith` 404 + get "/0" `shouldRespondWith` 404 delete "/0" `shouldRespondWith` 404 - - adminGroup :: ByteString -adminGroup = [scim| +adminGroup = + [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], "displayName":"Admin", "members":[] }|] - groups :: ResponseMatcher -groups = [scim| +groups = + [scim| { "schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "Resources": [{ "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], @@ -88,7 +85,8 @@ groups = [scim| }|] admins :: ResponseMatcher -admins = [scim| +admins = + [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], "displayName":"Admin", "members":[], @@ -103,7 +101,8 @@ admins = [scim| }|] adminUpdate0 :: ByteString -adminUpdate0 = [scim| +adminUpdate0 = + [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], "displayName":"Admin", "members":[ @@ -115,7 +114,8 @@ adminUpdate0 = [scim| }|] updatedAdmins0 :: ResponseMatcher -updatedAdmins0 = [scim| +updatedAdmins0 = + [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:Group"], "displayName":"Admin", "members":[ @@ -134,7 +134,8 @@ updatedAdmins0 = [scim| }|] emptyList :: ResponseMatcher -emptyList = [scim| +emptyList = + [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "Resources":[], "totalResults":0, diff --git a/test/Test/Class/UserSpec.hs b/test/Test/Class/UserSpec.hs index 223fc8fc0ae..90cd95ae08d 100644 --- a/test/Test/Class/UserSpec.hs +++ b/test/Test/Class/UserSpec.hs @@ -1,18 +1,19 @@ {-# LANGUAGE QuasiQuotes #-} -module Test.Class.UserSpec (spec) where - -import Web.Scim.Test.Util - -import Web.Scim.Server (mkapp, UserAPI, userServer) -import Web.Scim.Server.Mock -import Test.Hspec -import Test.Hspec.Wai hiding (post, put, patch, shouldRespondWith) -import Data.ByteString.Lazy (ByteString) -import Servant (Proxy(Proxy)) -import Network.Wai (Application) -import Servant.API.Generic - +module Test.Class.UserSpec + ( spec, + ) +where + +import Data.ByteString.Lazy (ByteString) +import Network.Wai (Application) +import Servant (Proxy (Proxy)) +import Servant.API.Generic +import Test.Hspec +import Test.Hspec.Wai hiding (patch, post, put, shouldRespondWith) +import Web.Scim.Server (UserAPI, mkapp, userServer) +import Web.Scim.Server.Mock +import Web.Scim.Test.Util app :: IO Application app = do @@ -25,49 +26,38 @@ spec = beforeAll app $ do describe "GET & POST /Users" $ do it "responds with [] in empty environment" $ do get "/" `shouldRespondWith` emptyList - it "can insert then retrieve stored Users" $ do post "/" newBarbara `shouldRespondWith` 201 post "/" newJim `shouldRespondWith` 201 get "/" `shouldRespondWith` allUsers - describe "filtering" $ do it "can filter by username" $ do get "/?filter=userName eq \"bjensen\"" `shouldRespondWith` onlyBarbara - it "is case-insensitive regarding syntax" $ do get "/?filter=USERName EQ \"bjensen\"" `shouldRespondWith` onlyBarbara - it "is case-insensitive regarding usernames" $ do get "/?filter=userName eq \"BJensen\"" `shouldRespondWith` onlyBarbara - it "handles malformed filter syntax" $ do get "/?filter=userName eqq \"bjensen\"" `shouldRespondWith` 400 - -- TODO: would be nice to check the error message as well + -- TODO: would be nice to check the error message as well it "handles type errors in comparisons" $ do get "/?filter=userName eq true" `shouldRespondWith` 400 - describe "GET /Users/:id" $ do it "responds with 404 for unknown user" $ do get "/9999" `shouldRespondWith` 404 - -- FUTUREWORK: currently it returns 404: -- https://github.com/haskell-servant/servant/issues/1155 xit "responds with 401 for unparseable user ID" $ do get "/unparseable" `shouldRespondWith` 401 - it "retrieves stored user" $ do -- the test implementation stores users with uid [0,1..n-1] get "/0" `shouldRespondWith` barbara - describe "PUT /Users/:id" $ do it "overwrites the user" $ do put "/0" barbUpdate0 `shouldRespondWith` updatedBarb0 - it "does not create new users" $ do put "/9999" newBarbara `shouldRespondWith` 404 - -- TODO(arianvp): Perhaps we want to make this an acceptance spec. describe "PATCH /Users/:id" $ do describe "Add" $ do @@ -76,7 +66,9 @@ spec = beforeAll app $ do -- TODO(arianvp): Add and Replace tests currently identical, because of lack of multi-value it "adds all fields if no target" $ do _ <- put "/0" smallUser -- reset - patch "/0" [scim|{ + patch + "/0" + [scim|{ "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ "op": "Add", @@ -86,7 +78,8 @@ spec = beforeAll app $ do } }] - }|] `shouldRespondWith` [scim| + }|] + `shouldRespondWith` [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User" @@ -102,17 +95,22 @@ spec = beforeAll app $ do "lastModified": "2018-01-01T00:00:00Z" } } - |] { matchStatus = 200 } + |] + { matchStatus = 200 + } it "adds fields if they didn't exist yet" $ do - _ <- put "/0" smallUser -- reset - patch "/0" [scim|{ + _ <- put "/0" smallUser -- reset + patch + "/0" + [scim|{ "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ "op": "Add", "path": "displayName", "value": "arian" }] - }|] `shouldRespondWith` [scim| + }|] + `shouldRespondWith` [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User" @@ -128,17 +126,22 @@ spec = beforeAll app $ do "lastModified": "2018-01-01T00:00:00Z" } } - |] { matchStatus = 200 } + |] + { matchStatus = 200 + } it "replaces individual simple fields" $ do - _ <- put "/0" smallUser -- reset - patch "/0" [scim|{ + _ <- put "/0" smallUser -- reset + patch + "/0" + [scim|{ "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ "op": "Add", "path": "userName", "value": "arian" }] - }|] `shouldRespondWith` [scim| + }|] + `shouldRespondWith` [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User" @@ -154,16 +157,19 @@ spec = beforeAll app $ do "lastModified": "2018-01-01T00:00:00Z" } } - |] { matchStatus = 200 } - + |] + { matchStatus = 200 + } -- TODO(arianvp): I think this is better done with quickcheck test. -- Generate some adds, replaces, removes and then an invalid one However, -- for this we need to be able to generate valid patches but a patch does -- not limit by type what fields it lenses in to. It is a very untyped -- thingy currently. it "PatchOp is atomic. Either fully applies or not at all" $ do - _ <- put "/0" smallUser -- reset - patch "/0" [scim|{ + _ <- put "/0" smallUser -- reset + patch + "/0" + [scim|{ "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ "op": "Add", @@ -173,15 +179,16 @@ spec = beforeAll app $ do { "op": "Add", "path": "displayName", "value": 5 - }]}|] `shouldRespondWith` 400 - get "/0" `shouldRespondWith` smallUserGet { matchStatus = 200 } - - + }]}|] + `shouldRespondWith` 400 + get "/0" `shouldRespondWith` smallUserGet {matchStatus = 200} describe "Replace" $ do -- TODO(arianvp): Implement and test multi-value fields properly it "adds all fields if no target" $ do _ <- put "/0" smallUser -- reset - patch "/0" [scim|{ + patch + "/0" + [scim|{ "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ "op": "Replace", @@ -191,7 +198,8 @@ spec = beforeAll app $ do } }] - }|] `shouldRespondWith` [scim| + }|] + `shouldRespondWith` [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User" @@ -207,17 +215,22 @@ spec = beforeAll app $ do "lastModified": "2018-01-01T00:00:00Z" } } - |] { matchStatus = 200 } + |] + { matchStatus = 200 + } it "adds fields if they didn't exist yet" $ do - _ <- put "/0" smallUser -- reset - patch "/0" [scim|{ + _ <- put "/0" smallUser -- reset + patch + "/0" + [scim|{ "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ "op": "Replace", "path": "displayName", "value": "arian" }] - }|] `shouldRespondWith` [scim| + }|] + `shouldRespondWith` [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User" @@ -233,17 +246,22 @@ spec = beforeAll app $ do "lastModified": "2018-01-01T00:00:00Z" } } - |] { matchStatus = 200 } + |] + { matchStatus = 200 + } it "replaces individual simple fields" $ do - _ <- put "/0" smallUser -- reset - patch "/0" [scim|{ + _ <- put "/0" smallUser -- reset + patch + "/0" + [scim|{ "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ "op": "Replace", "path": "userName", "value": "arian" }] - }|] `shouldRespondWith` [scim| + }|] + `shouldRespondWith` [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User" @@ -259,11 +277,14 @@ spec = beforeAll app $ do "lastModified": "2018-01-01T00:00:00Z" } } - |] { matchStatus = 200 } - + |] + { matchStatus = 200 + } it "PatchOp is atomic. Either fully applies or not at all" $ do - _ <- put "/0" smallUser -- reset - patch "/0" [scim|{ + _ <- put "/0" smallUser -- reset + patch + "/0" + [scim|{ "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ "op": "Replace", @@ -273,32 +294,45 @@ spec = beforeAll app $ do { "op": "Replace", "path": "displayName", "value": 5 - }]}|] `shouldRespondWith` 400 - get "/0" `shouldRespondWith` smallUserGet { matchStatus = 200 } - + }]}|] + `shouldRespondWith` 400 + get "/0" `shouldRespondWith` smallUserGet {matchStatus = 200} describe "Remove" $ do it "fails if no target" $ do - _ <- put "/0" barbUpdate0 -- reset - patch "/0" [scim|{ + _ <- put "/0" barbUpdate0 -- reset + patch + "/0" + [scim|{ "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ "op": "Remove" }] - }|] `shouldRespondWith` [scim|{ + }|] + `shouldRespondWith` [scim|{ "scimType":"noTarget","status":"400","schemas":["urn:ietf:params:scim:api:messages:2.0:Error"] - }|] { matchStatus = 400 } + }|] + { matchStatus = 400 + } it "fails if removing immutable" $ do - _ <- put "/0" barbUpdate0 -- reset - patch "/0" [scim|{ + _ <- put "/0" barbUpdate0 -- reset + patch + "/0" + [scim|{ "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ "op": "Remove", "path": "userName"}] - }|] `shouldRespondWith` [scim|{ + }|] + `shouldRespondWith` [scim|{ "scimType":"mutability","status":"400","schemas":["urn:ietf:params:scim:api:messages:2.0:Error"] - }|] { matchStatus = 400 } + }|] + { matchStatus = 400 + } it "deletes the specified attribute" $ do - _ <- put "/0" smallUser -- reset - patch "/0" [scim|{ + _ <- put "/0" smallUser -- reset + patch + "/0" + [scim|{ "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "Operations": [{ "op": "Remove", "path": "displayName"}] - }|] `shouldRespondWith` [scim|{ + }|] + `shouldRespondWith` [scim|{ "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User" ], @@ -311,28 +345,29 @@ spec = beforeAll app $ do "version": "W/\"testVersion\"", "lastModified": "2018-01-01T00:00:00Z" } - }|] { matchStatus = 200 } - + }|] + { matchStatus = 200 + } describe "DELETE /Users/:id" $ do it "responds with 404 for unknown user" $ do delete "/9999" `shouldRespondWith` 404 - it "deletes a stored user" $ do delete "/0" `shouldRespondWith` 204 -- user should be gone - get "/0" `shouldRespondWith` 404 + get "/0" `shouldRespondWith` 404 delete "/0" `shouldRespondWith` 404 - smallUser :: ByteString -smallUser = [scim| +smallUser = + [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "userName":"bjensen", "displayName": "bjensen2" }|] smallUserGet :: ResponseMatcher -smallUserGet = [scim| +smallUserGet = + [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User" @@ -351,7 +386,8 @@ smallUserGet = [scim| |] newBarbara :: ByteString -newBarbara = [scim| +newBarbara = + [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "userName":"bjensen", "externalId":"bjensen", @@ -363,7 +399,8 @@ newBarbara = [scim| }|] newJim :: ByteString -newJim = [scim| +newJim = + [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "userName":"jim", "externalId":"jim", @@ -375,7 +412,8 @@ newJim = [scim| }|] barbara :: ResponseMatcher -barbara = [scim| +barbara = + [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "userName":"bjensen", "name": { @@ -395,7 +433,8 @@ barbara = [scim| }|] allUsers :: ResponseMatcher -allUsers = [scim| +allUsers = + [scim| { "schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "totalResults": 2, "itemsPerPage": 2, @@ -438,7 +477,8 @@ allUsers = [scim| }|] onlyBarbara :: ResponseMatcher -onlyBarbara = [scim| +onlyBarbara = + [scim| { "schemas":["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "totalResults": 1, "itemsPerPage": 1, @@ -465,7 +505,8 @@ onlyBarbara = [scim| -- source: https://tools.ietf.org/html/rfc7644#section-3.5.1 (p. 30) barbUpdate0 :: ByteString -barbUpdate0 = [scim| +barbUpdate0 = + [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "id":"0", "userName":"bjensen", @@ -487,9 +528,9 @@ barbUpdate0 = [scim| ] }|] - updatedBarb0 :: ResponseMatcher -updatedBarb0 = [scim| +updatedBarb0 = + [scim| { "schemas":["urn:ietf:params:scim:schemas:core:2.0:User"], "id":"0", "userName":"bjensen", @@ -518,7 +559,8 @@ updatedBarb0 = [scim| }|] emptyList :: ResponseMatcher -emptyList = [scim| +emptyList = + [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:ListResponse"], "Resources":[], "totalResults":0, diff --git a/test/Test/FilterSpec.hs b/test/Test/FilterSpec.hs index 1dfde6b42fd..34bcef910b2 100644 --- a/test/Test/FilterSpec.hs +++ b/test/Test/FilterSpec.hs @@ -1,23 +1,22 @@ -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE QuasiQuotes #-} module Test.FilterSpec where -import Web.Scim.Filter -import Web.Scim.AttrName -import Web.Scim.Schema.Schema (Schema(..)) -import Web.Scim.Schema.UserTypes (UserTypes(supportedSchemas)) -import Web.Scim.Schema.User (NoUserExtra) -import Web.Scim.Test.Util (TestTag) - -import Test.Hspec -import HaskellWorks.Hspec.Hedgehog -import Hedgehog +import Data.Text (Text, cons) +import HaskellWorks.Hspec.Hedgehog +import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Data.Text (cons, Text) +import Test.Hspec +import Web.Scim.AttrName +import Web.Scim.Filter +import Web.Scim.Schema.Schema (Schema (..)) +import Web.Scim.Schema.User (NoUserExtra) +import Web.Scim.Schema.UserTypes (UserTypes (supportedSchemas)) +import Web.Scim.Test.Util (TestTag) -prop_roundtrip :: forall tag.UserTypes tag => Property +prop_roundtrip :: forall tag. UserTypes tag => Property prop_roundtrip = property $ do x <- forAll $ genFilter @tag tripping x renderFilter $ parseFilter (supportedSchemas @tag) @@ -30,19 +29,21 @@ spec = do ---------------------------------------------------------------------------- -- Generators -genValuePath :: forall tag.UserTypes tag => Gen ValuePath -genValuePath = ValuePath <$> genAttrPath @tag <*> genFilter @tag +genValuePath :: forall tag. UserTypes tag => Gen ValuePath +genValuePath = ValuePath <$> genAttrPath @tag <*> genFilter @tag genCompValue :: Gen CompValue -genCompValue = Gen.choice - [ pure ValNull - , ValBool <$> Gen.bool - , ValNumber <$> Gen.choice - [ Gen.realFrac_ (Range.constantFrom 0 (-100) 100) - , fromInteger <$> Gen.integral (Range.constantFrom 0 (-100) 100) - ] - , ValString <$> Gen.text (Range.constant 0 1000) Gen.unicode - ] +genCompValue = + Gen.choice + [ pure ValNull, + ValBool <$> Gen.bool, + ValNumber + <$> Gen.choice + [ Gen.realFrac_ (Range.constantFrom 0 (-100) 100), + fromInteger <$> Gen.integral (Range.constantFrom 0 (-100) 100) + ], + ValString <$> Gen.text (Range.constant 0 1000) Gen.unicode + ] genCompareOp :: Gen CompareOp genCompareOp = Gen.enumBounded @@ -55,16 +56,17 @@ genSubAttr = SubAttr <$> genAttrName -- FUTUREWORK: we also may want to factor a bounded enum type out of the 'Schema' type for -- this: @data Schema = Buitin BuitinSchema | Custom Text; data BuiltinSchema = ... deriving -- (Bounded, Enum, ...)@ -genSchema :: forall tag.UserTypes tag => Gen Schema +genSchema :: forall tag. UserTypes tag => Gen Schema genSchema = Gen.element (supportedSchemas @tag) -genAttrPath :: forall tag.UserTypes tag => Gen AttrPath +genAttrPath :: forall tag. UserTypes tag => Gen AttrPath genAttrPath = AttrPath <$> Gen.maybe (genSchema @tag) <*> genAttrName <*> Gen.maybe genSubAttr genAttrName :: Gen AttrName genAttrName = AttrName <$> (cons <$> Gen.alpha <*> Gen.text (Range.constant 0 50) (Gen.choice [Gen.alphaNum, Gen.constant '-', Gen.constant '_'])) -genFilter :: forall tag.UserTypes tag => Gen Filter -genFilter = Gen.choice - [ FilterAttrCompare <$> (genAttrPath @tag) <*> genCompareOp <*> genCompValue - ] +genFilter :: forall tag. UserTypes tag => Gen Filter +genFilter = + Gen.choice + [ FilterAttrCompare <$> (genAttrPath @tag) <*> genCompareOp <*> genCompValue + ] diff --git a/test/Test/Schema/PatchOpSpec.hs b/test/Test/Schema/PatchOpSpec.hs index 3aae204a9d1..f04ce6dabfe 100644 --- a/test/Test/Schema/PatchOpSpec.hs +++ b/test/Test/Schema/PatchOpSpec.hs @@ -1,52 +1,55 @@ -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE QuasiQuotes #-} + module Test.Schema.PatchOpSpec where -import Data.Foldable (for_) -import Test.Hspec (Spec, describe, it, xit, shouldSatisfy, shouldBe) -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Either (isLeft) -import Web.Scim.Test.Util (scim, TestTag) -import Web.Scim.Schema.PatchOp -import Web.Scim.Schema.User (UserTypes) -import Web.Scim.Schema.UserTypes (supportedSchemas) -import Web.Scim.Schema.Schema (Schema(User20)) -import Web.Scim.AttrName (AttrName(..)) -import Web.Scim.Filter (AttrPath(..), Filter(..), ValuePath(..), CompareOp(OpEq), CompValue(ValNull)) + import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson -import Data.Aeson.Types (toJSON, fromJSON, Result(Success, Error), Value(String)) +import Data.Aeson.Types (Result (Error, Success), Value (String), fromJSON, toJSON) import Data.Attoparsec.ByteString (parseOnly) +import Data.Either (isLeft) +import Data.Foldable (for_) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import HaskellWorks.Hspec.Hedgehog (require) -import Hedgehog (Gen, tripping, forAll, Property, property) +import Hedgehog (Gen, Property, forAll, property, tripping) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Test.FilterSpec (genValuePath, genAttrPath, genSubAttr) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM +import Test.FilterSpec (genAttrPath, genSubAttr, genValuePath) +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy, xit) +import Web.Scim.AttrName (AttrName (..)) +import Web.Scim.Filter (AttrPath (..), CompValue (ValNull), CompareOp (OpEq), Filter (..), ValuePath (..)) +import Web.Scim.Schema.PatchOp +import Web.Scim.Schema.Schema (Schema (User20)) +import Web.Scim.Schema.User (UserTypes) +import Web.Scim.Schema.UserTypes (supportedSchemas) +import Web.Scim.Test.Util (TestTag, scim) isSuccess :: Result a -> Bool isSuccess (Success _) = True isSuccess (Error _) = False -genPatchOp :: forall tag.UserTypes tag => Gen Value -> Gen (PatchOp tag) +genPatchOp :: forall tag. UserTypes tag => Gen Value -> Gen (PatchOp tag) genPatchOp genValue = PatchOp <$> Gen.list (Range.constant 0 20) ((genOperation @tag) genValue) -genOperation :: forall tag.UserTypes tag => Gen Value -> Gen Operation +genOperation :: forall tag. UserTypes tag => Gen Value -> Gen Operation genOperation genValue = Operation <$> Gen.enumBounded <*> Gen.maybe (genPath @tag) <*> Gen.maybe genValue -genPath :: forall tag.UserTypes tag => Gen Path -genPath = Gen.choice - [ IntoValuePath <$> (genValuePath @tag) <*> Gen.maybe genSubAttr - , NormalPath <$> (genAttrPath @tag) - ] +genPath :: forall tag. UserTypes tag => Gen Path +genPath = + Gen.choice + [ IntoValuePath <$> (genValuePath @tag) <*> Gen.maybe genSubAttr, + NormalPath <$> (genAttrPath @tag) + ] -prop_roundtrip :: forall tag.UserTypes tag => Property +prop_roundtrip :: forall tag. UserTypes tag => Property prop_roundtrip = property $ do x <- forAll $ genPath @tag tripping x (encodeUtf8 . rPath) (parseOnly $ pPath (supportedSchemas @tag)) -prop_roundtrip_PatchOp :: forall tag.UserTypes tag => Property +prop_roundtrip_PatchOp :: forall tag. UserTypes tag => Property prop_roundtrip_PatchOp = property $ do -- Just some strings for now. However, should be constrained to what the -- PatchOp is operating on in the future... We need better typed PatchOp for @@ -64,57 +67,55 @@ spec = do let theMap :: HashMap Text Text = HM.empty operation = Operation Add (Just $ NormalPath (AttrPath Nothing (AttrName "key") Nothing)) $ Just "value" applyOperation theMap operation `shouldBe` (Right $ HM.singleton "key" "value") - it "supports `Replace` operation" $ do let theMap :: HashMap Text Text = HM.singleton "key" "value1" operation = Operation Replace (Just $ NormalPath (AttrPath Nothing (AttrName "key") Nothing)) $ Just "value2" applyOperation theMap operation `shouldBe` (Right $ HM.singleton "key" "value2") - it "supports `Delete` operation" $ do let theMap :: HashMap Text Text = HM.fromList [("key1", "value1"), ("key2", "value2")] operation = Operation Remove (Just $ NormalPath (AttrPath Nothing (AttrName "key1") Nothing)) Nothing applyOperation theMap operation `shouldBe` (Right $ HM.singleton "key2" "value2") - it "gracefully rejects invalid/unsupported operations" $ do let theMap :: HashMap Text Text = HM.fromList [("key1", "value1"), ("key2", "value2")] key1Path = (AttrPath Nothing (AttrName "key1") Nothing) key2Path = (AttrPath Nothing (AttrName "key2") Nothing) invalidOperations = - [ Operation Add (Just $ NormalPath key1Path) Nothing -- Nothing to add - , Operation Replace (Just $ NormalPath key1Path) Nothing -- Nothing to replace - , Operation Add (Just $ IntoValuePath (ValuePath key1Path (FilterAttrCompare key2Path OpEq ValNull)) Nothing) Nothing + [ Operation Add (Just $ NormalPath key1Path) Nothing, -- Nothing to add + Operation Replace (Just $ NormalPath key1Path) Nothing, -- Nothing to replace + Operation Add (Just $ IntoValuePath (ValuePath key1Path (FilterAttrCompare key2Path OpEq ValNull)) Nothing) Nothing -- IntoValuePaths don't make sense for HashMap Text Text ] mapM_ (\o -> applyOperation theMap o `shouldSatisfy` isLeft) invalidOperations - describe "urn:ietf:params:scim:api:messages:2.0:PatchOp" $ do describe "The body of each request MUST contain the \"schemas\" attribute with the URI value of \"urn:ietf:params:scim:api:messages:2.0:PatchOp\"." $ do it "rejects an empty schemas list" $ do - fromJSON @(PatchOp PatchTestTag) [scim| { + fromJSON @(PatchOp PatchTestTag) + [scim| { "schemas": [], "operations": [] - }|] `shouldSatisfy` (not . isSuccess) + }|] + `shouldSatisfy` (not . isSuccess) --TODO(arianvp): We don't support arbitrary path names (yet) it "roundtrips Path" $ require $ prop_roundtrip @PatchTestTag - it "roundtrips PatchOp" $ require $ prop_roundtrip_PatchOp @PatchTestTag + it "roundtrips PatchOp" $ require $ prop_roundtrip_PatchOp @PatchTestTag it "rejects invalid operations" $ do - fromJSON @(PatchOp PatchTestTag) [scim| { + fromJSON @(PatchOp PatchTestTag) + [scim| { "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"], "operations": [{"op":"unknown"}] - }|] `shouldSatisfy` (not . isSuccess) - + }|] + `shouldSatisfy` (not . isSuccess) -- TODO(arianvp/akshay): Implement if required xit "rejects unknown paths" $ do - Aeson.parse (pathFromJSON [User20]) (Aeson.String "unknown.field") `shouldSatisfy` (not . isSuccess) + Aeson.parse (pathFromJSON [User20]) (Aeson.String "unknown.field") `shouldSatisfy` (not . isSuccess) it "rejects invalid paths" $ do Aeson.parse (pathFromJSON [User20]) "unknown]field" `shouldSatisfy` (not . isSuccess) describe "Examples from https://tools.ietf.org/html/rfc7644#section-3.5.2 Figure 8" $ do - let - examples = - [ "members" - , "name.familyname" - , "addresses[type eq \"work\"]" - , "members[value eq \"2819c223-7f76-453a-919d-413861904646\"]" - , "members[value eq \"2819c223-7f76-453a-919d-413861904646\"].displayname" - ] + let examples = + [ "members", + "name.familyname", + "addresses[type eq \"work\"]", + "members[value eq \"2819c223-7f76-453a-919d-413861904646\"]", + "members[value eq \"2819c223-7f76-453a-919d-413861904646\"].displayname" + ] for_ examples $ \p -> it ("parses " ++ show p) $ (rPath <$> parseOnly (pPath (supportedSchemas @PatchTestTag)) p) `shouldBe` Right (decodeUtf8 p) diff --git a/test/Test/Schema/UserSpec.hs b/test/Test/Schema/UserSpec.hs index 4651a3890d5..07e5d973478 100644 --- a/test/Test/Schema/UserSpec.hs +++ b/test/Test/Schema/UserSpec.hs @@ -1,35 +1,37 @@ -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -module Test.Schema.UserSpec (spec) where - -import Web.Scim.Test.Util +module Test.Schema.UserSpec + ( spec, + ) +where -import Web.Scim.Schema.Common (URI(..)) -import Web.Scim.Schema.Schema (Schema(..)) -import Web.Scim.Schema.User (User(..), NoUserExtra(..)) -import qualified Web.Scim.Schema.User as User -import Web.Scim.Schema.PatchOp (PatchOp(..), Op(..), Operation(..), Patchable(..)) -import qualified Web.Scim.Schema.PatchOp as PatchOp -import Web.Scim.Schema.User.Address as Address -import Web.Scim.Schema.User.Certificate as Certificate -import Web.Scim.Schema.User.Email as Email -import Web.Scim.Schema.User.IM as IM -import Web.Scim.Schema.User.Name as Name -import Web.Scim.Schema.User.Phone as Phone -import Web.Scim.Schema.User.Photo as Photo -import Data.Aeson +import Data.Aeson import qualified Data.HashMap.Strict as HM -import Data.Text (Text, toLower, toUpper) -import Lens.Micro -import Test.Hspec -import Text.Email.Validate (emailAddress) -import Network.URI.Static (uri) -import HaskellWorks.Hspec.Hedgehog (require) -import Hedgehog +import Data.Text (Text, toLower, toUpper) +import HaskellWorks.Hspec.Hedgehog (require) +import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range +import Lens.Micro +import Network.URI.Static (uri) +import Test.Hspec +import Text.Email.Validate (emailAddress) +import Web.Scim.Schema.Common (URI (..)) +import Web.Scim.Schema.PatchOp (Op (..), Operation (..), PatchOp (..), Patchable (..)) +import qualified Web.Scim.Schema.PatchOp as PatchOp +import Web.Scim.Schema.Schema (Schema (..)) +import Web.Scim.Schema.User (NoUserExtra (..), User (..)) +import qualified Web.Scim.Schema.User as User +import Web.Scim.Schema.User.Address as Address +import Web.Scim.Schema.User.Certificate as Certificate +import Web.Scim.Schema.User.Email as Email +import Web.Scim.Schema.User.IM as IM +import Web.Scim.Schema.User.Name as Name +import Web.Scim.Schema.User.Phone as Phone +import Web.Scim.Schema.User.Photo as Photo +import Web.Scim.Test.Util prop_roundtrip :: Property prop_roundtrip = property $ do @@ -44,7 +46,6 @@ prop_caseInsensitive = property $ do let (Object user') = toJSON user let user'' = HM.foldlWithKey' (\u k v -> HM.insert (toUpper k) v u) user' HM.empty let user''' = HM.foldlWithKey' (\u k v -> HM.insert (toLower k) v u) user' HM.empty - fromJSON (Object user'') === Success user fromJSON (Object user''') === Success user @@ -60,39 +61,32 @@ spec = do let extras = HM.empty let user :: User PatchTag = User.empty schemas' "hello" extras let Right programmingLanguagePath = PatchOp.parsePath (User.supportedSchemas @PatchTag) "urn:hscim:test:programmingLanguage" - let operation = Operation Replace (Just programmingLanguagePath) (Just (toJSON @Text "haskell")) - let patchOp = PatchOp [ operation ] + let operation = Operation Replace (Just programmingLanguagePath) (Just (toJSON @Text "haskell")) + let patchOp = PatchOp [operation] User.extra <$> (User.applyPatch user patchOp) `shouldBe` Right (HM.singleton "programmingLanguage" "haskell") - describe "JSON serialization" $ do it "handles all fields" $ do require prop_roundtrip toJSON completeUser `shouldBe` completeUserJson eitherDecode (encode completeUserJson) `shouldBe` Right completeUser - it "has defaults for all optional and multi-valued fields" $ do toJSON minimalUser `shouldBe` minimalUserJson eitherDecode (encode minimalUserJson) `shouldBe` Right minimalUser - it "treats 'null' and '[]' as absence of fields" $ eitherDecode (encode minimalUserJsonRedundant) `shouldBe` Right minimalUser - it "allows casing variations in field names" $ do require prop_caseInsensitive eitherDecode (encode minimalUserJsonNonCanonical) `shouldBe` Right minimalUser - it "doesn't require the 'schemas' field" $ eitherDecode (encode minimalUserJsonNoSchemas) `shouldBe` Right minimalUser - it "doesn't add 'extra' if it's an empty object" $ do toJSON (extendedUser UserExtraEmpty) `shouldBe` extendedUserEmptyJson - eitherDecode (encode extendedUserEmptyJson) `shouldBe` - Right (extendedUser UserExtraEmpty) - + eitherDecode (encode extendedUserEmptyJson) + `shouldBe` Right (extendedUser UserExtraEmpty) it "encodes and decodes 'extra' correctly" $ do toJSON (extendedUser (UserExtraObject "foo")) `shouldBe` extendedUserObjectJson - eitherDecode (encode extendedUserObjectJson) `shouldBe` - Right (extendedUser (UserExtraObject "foo")) + eitherDecode (encode extendedUserObjectJson) + `shouldBe` Right (extendedUser (UserExtraObject "foo")) genName :: Gen Name genName = @@ -104,9 +98,8 @@ genName = <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode) <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode) - genUri :: Gen URI -genUri = Gen.element [ URI [uri|https://example.com|] ] +genUri = Gen.element [URI [uri|https://example.com|]] -- TODO(arianvp) Generate the lists too, but first need better support for SCIM -- lists in the first place @@ -133,96 +126,114 @@ genUser = do entitlements' <- pure [] -- Gen.list (Range.constant 0 20) (Gen.text (Range.constant 0 20) Gen.unicode) roles' <- pure [] -- Gen.list (Range.constant 0 20) (Gen.text (Range.constant 0 10) Gen.unicode) x509Certificates' <- pure [] -- Gen.list (Range.constant 0 20) genCertificate - - pure $ User - { schemas = schemas' - , userName = userName' - , externalId = externalId' - , name = name' - , displayName = displayName' - , nickName = nickName' - , profileUrl = profileUrl' - , title = title' - , userType = userType' - , preferredLanguage = preferredLanguage' - , locale = locale' - , active = active' - , password = password' - , emails = emails' - , phoneNumbers = phoneNumbers' - , ims = ims' - , photos = photos' - , addresses = addresses' - , entitlements = entitlements' - , roles = roles' - , x509Certificates = x509Certificates' - , extra = NoUserExtra - } - + pure $ + User + { schemas = schemas', + userName = userName', + externalId = externalId', + name = name', + displayName = displayName', + nickName = nickName', + profileUrl = profileUrl', + title = title', + userType = userType', + preferredLanguage = preferredLanguage', + locale = locale', + active = active', + password = password', + emails = emails', + phoneNumbers = phoneNumbers', + ims = ims', + photos = photos', + addresses = addresses', + entitlements = entitlements', + roles = roles', + x509Certificates = x509Certificates', + extra = NoUserExtra + } -- | A 'User' with all attributes present. completeUser :: User (TestTag Text () () NoUserExtra) -completeUser = User - { schemas = [User20] - , userName = "sample userName" - , externalId = Just "sample externalId" - , name = Just $ Name - { Name.formatted = Just "sample formatted name" - , Name.familyName = Nothing - , Name.givenName = Nothing - , Name.middleName = Nothing - , Name.honorificPrefix = Nothing - , Name.honorificSuffix = Nothing - } - , displayName = Just "sample displayName" - , nickName = Just "sample nickName" - , profileUrl = Just (URI [uri|https://example.com|]) - , title = Just "sample title" - , userType = Just "sample userType" - , preferredLanguage = Just "da, en-gb;q=0.8, en;q=0.7" - , locale = Just "en-US" - , active = Just True - , password = Just "sample password" - , emails = [ - Email { Email.typ = Just "work" - , Email.value = maybe (error "couldn't parse email") EmailAddress2 - (emailAddress "user@example.com") - , Email.primary = Nothing } - ] - , phoneNumbers = [ - Phone { Phone.typ = Just "work" - , Phone.value = Just "+15417543010" } - ] - , ims = [ - IM { IM.typ = Just "Wire" - , IM.value = Just "@user" } - ] - , photos = [ - Photo { Photo.typ = Just "userpic" - , Photo.value = Just (URI [uri|https://example.com/userpic.png|]) } - ] - , addresses = [ - Address { Address.formatted = Just "sample Address" - , Address.streetAddress = Nothing - , Address.locality = Nothing - , Address.region = Nothing - , Address.postalCode = Nothing - , Address.country = Nothing - , Address.typ = Just "home" - , Address.primary = Just True } - ] - , entitlements = ["sample entitlement"] - , roles = ["sample role"] - , x509Certificates = [ - Certificate { Certificate.typ = Just "sample certificate type" - , Certificate.value = Just "sample certificate" } - ] - , extra = NoUserExtra - } +completeUser = + User + { schemas = [User20], + userName = "sample userName", + externalId = Just "sample externalId", + name = + Just $ + Name + { Name.formatted = Just "sample formatted name", + Name.familyName = Nothing, + Name.givenName = Nothing, + Name.middleName = Nothing, + Name.honorificPrefix = Nothing, + Name.honorificSuffix = Nothing + }, + displayName = Just "sample displayName", + nickName = Just "sample nickName", + profileUrl = Just (URI [uri|https://example.com|]), + title = Just "sample title", + userType = Just "sample userType", + preferredLanguage = Just "da, en-gb;q=0.8, en;q=0.7", + locale = Just "en-US", + active = Just True, + password = Just "sample password", + emails = + [ Email + { Email.typ = Just "work", + Email.value = + maybe + (error "couldn't parse email") + EmailAddress2 + (emailAddress "user@example.com"), + Email.primary = Nothing + } + ], + phoneNumbers = + [ Phone + { Phone.typ = Just "work", + Phone.value = Just "+15417543010" + } + ], + ims = + [ IM + { IM.typ = Just "Wire", + IM.value = Just "@user" + } + ], + photos = + [ Photo + { Photo.typ = Just "userpic", + Photo.value = Just (URI [uri|https://example.com/userpic.png|]) + } + ], + addresses = + [ Address + { Address.formatted = Just "sample Address", + Address.streetAddress = Nothing, + Address.locality = Nothing, + Address.region = Nothing, + Address.postalCode = Nothing, + Address.country = Nothing, + Address.typ = Just "home", + Address.primary = Just True + } + ], + entitlements = ["sample entitlement"], + roles = ["sample role"], + x509Certificates = + [ Certificate + { Certificate.typ = Just "sample certificate type", + Certificate.value = Just "sample certificate" + } + ], + extra = NoUserExtra + } -- | Reference encoding of 'completeUser'. completeUserJson :: Value -completeUserJson = [scim| +completeUserJson = + [scim| { "roles": [ "sample role" @@ -293,7 +304,8 @@ minimalUser = User.empty [User20] "sample userName" NoUserExtra -- | Reference encoding of 'minimalUser'. minimalUserJson :: Value -minimalUserJson = [scim| +minimalUserJson = + [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User" @@ -305,7 +317,8 @@ minimalUserJson = [scim| -- | An encoding of 'minimalUser' with redundant @null@s and @[]@s for missing -- fields. minimalUserJsonRedundant :: Value -minimalUserJsonRedundant = [scim| +minimalUserJsonRedundant = + [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User" @@ -335,7 +348,8 @@ minimalUserJsonRedundant = [scim| -- | An encoding of 'minimalUser' with non-canonical field name casing. minimalUserJsonNonCanonical :: Value -minimalUserJsonNonCanonical = [scim| +minimalUserJsonNonCanonical = + [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User" @@ -346,13 +360,14 @@ minimalUserJsonNonCanonical = [scim| -- | An encoding of 'minimalUser' without the @schemas@ field. minimalUserJsonNoSchemas :: Value -minimalUserJsonNoSchemas = [scim| +minimalUserJsonNoSchemas = + [scim| { "userName": "sample userName" } |] -data UserExtraTest = UserExtraEmpty | UserExtraObject { test :: Text } +data UserExtraTest = UserExtraEmpty | UserExtraObject {test :: Text} deriving (Show, Eq) instance FromJSON UserExtraTest where @@ -368,18 +383,18 @@ instance ToJSON UserExtraTest where toJSON (UserExtraObject t) = object ["urn:hscim:test" .= object ["test" .= t]] - instance Patchable UserExtraTest where applyOperation _ _ = undefined -- | A 'User' with extra fields present. extendedUser :: UserExtraTest -> User (TestTag Text () () UserExtraTest) extendedUser e = - (User.empty [User20, CustomSchema "urn:hscim:test"] "sample userName" e) + (User.empty [User20, CustomSchema "urn:hscim:test"] "sample userName" e) -- | Encoding of @extendedUser UserExtraEmpty@. extendedUserEmptyJson :: Value -extendedUserEmptyJson = [scim| +extendedUserEmptyJson = + [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User", @@ -391,7 +406,8 @@ extendedUserEmptyJson = [scim| -- | Encoding of @extendedUser (UserExtraObject "foo")@. extendedUserObjectJson :: Value -extendedUserObjectJson = [scim| +extendedUserObjectJson = + [scim| { "schemas": [ "urn:ietf:params:scim:schemas:core:2.0:User", From ebd77e606cc274959aa649e1fb0410bc5017e5bb Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 13 Mar 2020 20:24:35 +0100 Subject: [PATCH 41/64] Put stack.yaml.lock under version control. --- stack.yaml.lock | 54 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 stack.yaml.lock diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 00000000000..3dfb56e2624 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,54 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: network-uri-static-0.1.2.1@sha256:7e1ca4358b319ac2db6514d0e0beb073c296789eeef9cebd89cc9517618fbfe8,1724 + pantry-tree: + size: 334 + sha256: ee5fd663eed91eedc681a798578b32b1ba8fbf7a15924303aef8f1761a42c137 + original: + hackage: network-uri-static-0.1.2.1@sha256:7e1ca4358b319ac2db6514d0e0beb073c296789eeef9cebd89cc9517618fbfe8,1724 +- completed: + hackage: stm-containers-1.1.0.4@sha256:f83a683357b6e3b1dda3e70d2077a37224ed534df1f74c4e11f3f6daa7945c5b,3248 + pantry-tree: + size: 761 + sha256: 059c5a2d657d392aca0a887648f57380d6321734dc8879c056a44d4414308ac6 + original: + hackage: stm-containers-1.1.0.4@sha256:f83a683357b6e3b1dda3e70d2077a37224ed534df1f74c4e11f3f6daa7945c5b,3248 +- completed: + hackage: stm-hamt-1.2.0.4@sha256:7957497c022554b7599e790696d1a3e56359ad99e5da36a251894c626ca1f60a,3970 + pantry-tree: + size: 1009 + sha256: d9a8be48da86bd4a2ba9d52ea29b9a74f1b686d439ba1bbfba04ab1a002391da + original: + hackage: stm-hamt-1.2.0.4@sha256:7957497c022554b7599e790696d1a3e56359ad99e5da36a251894c626ca1f60a,3970 +- completed: + hackage: primitive-0.7.0.0@sha256:ee352d97cc390d8513530029a2213a95c179a66c406906b18d03702c1d9ab8e5,3416 + pantry-tree: + size: 3221 + sha256: ad604aab554e26d78561ad1288636b52c2e88b40e1fb37594efc96465a0ce68c + original: + hackage: primitive-0.7.0.0@sha256:ee352d97cc390d8513530029a2213a95c179a66c406906b18d03702c1d9ab8e5,3416 +- completed: + hackage: primitive-extras-0.8@sha256:fca0310150496867f5b9421fe1541ecda87fae17eae44885a29f9c52dd00c8ff,2963 + pantry-tree: + size: 1105 + sha256: e7c1d26202b80d1fca2ef780ec7fe76ede1275f4d9a996c6d44c08d8de1c45db + original: + hackage: primitive-extras-0.8@sha256:fca0310150496867f5b9421fe1541ecda87fae17eae44885a29f9c52dd00c8ff,2963 +- completed: + hackage: primitive-unlifted-0.1.2.0@sha256:9c3df73af54ed19fb3f4874da19334863cc414b22e578e27b5f52beeac4a60dd,1360 + pantry-tree: + size: 420 + sha256: cc6ffb1b48aa3f514c107f5188d5d5beb4e61a4232a81be7025b54f9be66a837 + original: + hackage: primitive-unlifted-0.1.2.0@sha256:9c3df73af54ed19fb3f4874da19334863cc414b22e578e27b5f52beeac4a60dd,1360 +snapshots: +- completed: + size: 545658 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/12.yaml + sha256: 26b807457213126d26b595439d705dc824dbb7618b0de6b900adc2bf6a059406 + original: lts-14.12 From 3db8136d4137538278ea561e888f0e7c352eee5c Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 13 Mar 2020 20:29:31 +0100 Subject: [PATCH 42/64] update stack.yaml.lock --- stack.yaml.lock | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/stack.yaml.lock b/stack.yaml.lock index 3dfb56e2624..9d8d32d69f2 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -46,6 +46,20 @@ packages: sha256: cc6ffb1b48aa3f514c107f5188d5d5beb4e61a4232a81be7025b54f9be66a837 original: hackage: primitive-unlifted-0.1.2.0@sha256:9c3df73af54ed19fb3f4874da19334863cc414b22e578e27b5f52beeac4a60dd,1360 +- completed: + hackage: ormolu-0.0.3.1@sha256:d8ae7f63b4ae0d55ad21f189652b9b912de118eeb671af1e7a2e7173231535df,7980 + pantry-tree: + size: 64583 + sha256: aafd93fb839fda7b294a199048817517337df5e59258034006dfd1d7bb992af7 + original: + hackage: ormolu-0.0.3.1 +- completed: + hackage: ghc-lib-parser-8.8.2.20200205@sha256:343f889f7b29f5ec07cf0d18d2a53f250fa5c002b6468a6a05b385d0191b8d34,8408 + pantry-tree: + size: 18102 + sha256: 3749da93f98300b35fe20e4947478a9ec081405e700e48d9d1998718c55e7eb2 + original: + hackage: ghc-lib-parser-8.8.2.20200205@sha256:343f889f7b29f5ec07cf0d18d2a53f250fa5c002b6468a6a05b385d0191b8d34,8408 snapshots: - completed: size: 545658 From 2909c81a0aa4bd4c2c21acafa64b2f744f787df6 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Fri, 27 Mar 2020 17:42:56 +0100 Subject: [PATCH 43/64] Drop dependency on network-uri-static (#44) Was merged into network-uri in 2.6.2 This allows us to move to a newer version of LTS 14 --- hscim.cabal | 14 +++++--------- package.yaml | 3 +-- stack.yaml | 3 +-- stack.yaml.lock | 15 ++++----------- 4 files changed, 11 insertions(+), 24 deletions(-) diff --git a/hscim.cabal b/hscim.cabal index 8c17fdcb665..45bf2d21514 100644 --- a/hscim.cabal +++ b/hscim.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: c5f5fd678522776d61449fb5e696f7aae333e56fcbdb7c9d7871d9cf732462bf +-- hash: 5df30998bc9a19063e47e0949c4888569451221502b9bebb8cad20088db91d19 name: hscim version: 0.3.4 @@ -89,8 +89,7 @@ library , microlens >=0.4.10 && <0.5 , mmorph >=1.1.3 && <1.2 , mtl >=2.2.2 && <2.3 - , network-uri >=2.6.1 && <2.7 - , network-uri-static >=0.1.2 && <0.2 + , network-uri >=2.6.2 && <2.7 , retry >=0.8.1.0 && <0.9 , scientific >=0.3.6 && <0.4 , servant >=0.16.2 && <0.17 @@ -140,8 +139,7 @@ executable hscim-server , microlens >=0.4.10 && <0.5 , mmorph >=1.1.3 && <1.2 , mtl >=2.2.2 && <2.3 - , network-uri >=2.6.1 && <2.7 - , network-uri-static >=0.1.2 && <0.2 + , network-uri >=2.6.2 && <2.7 , retry >=0.8.1.0 && <0.9 , scientific >=0.3.6 && <0.4 , servant >=0.16.2 && <0.17 @@ -192,8 +190,7 @@ test-suite doctests , microlens >=0.4.10 && <0.5 , mmorph >=1.1.3 && <1.2 , mtl >=2.2.2 && <2.3 - , network-uri >=2.6.1 && <2.7 - , network-uri-static >=0.1.2 && <0.2 + , network-uri >=2.6.2 && <2.7 , retry >=0.8.1.0 && <0.9 , scientific >=0.3.6 && <0.4 , servant >=0.16.2 && <0.17 @@ -254,8 +251,7 @@ test-suite spec , microlens >=0.4.10 && <0.5 , mmorph >=1.1.3 && <1.2 , mtl >=2.2.2 && <2.3 - , network-uri >=2.6.1 && <2.7 - , network-uri-static >=0.1.2 && <0.2 + , network-uri >=2.6.2 && <2.7 , retry >=0.8.1.0 && <0.9 , scientific >=0.3.6 && <0.4 , servant >=0.16.2 && <0.17 diff --git a/package.yaml b/package.yaml index f2fbc6e3dd8..7b6bf91cf9e 100644 --- a/package.yaml +++ b/package.yaml @@ -65,8 +65,7 @@ dependencies: - hw-hspec-hedgehog >= 0.1.0 && < 0.2 - list-t >= 1.0.4 && < 1.1 - microlens >= 0.4.10 && < 0.5 - - network-uri >= 2.6.1 && < 2.7 - - network-uri-static >= 0.1.2 && < 0.2 + - network-uri >= 2.6.2 && < 2.7 - servant >= 0.16.2 && < 0.17 - servant-server >= 0.16.2 && < 0.17 - warp >= 3.2.28 && < 3.4 diff --git a/stack.yaml b/stack.yaml index 6b898ad9e77..59be778fa51 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,10 +1,9 @@ -resolver: lts-14.12 +resolver: lts-14.27 packages: - . extra-deps: -- network-uri-static-0.1.2.1@sha256:7e1ca4358b319ac2db6514d0e0beb073c296789eeef9cebd89cc9517618fbfe8,1724 - stm-containers-1.1.0.4@sha256:f83a683357b6e3b1dda3e70d2077a37224ed534df1f74c4e11f3f6daa7945c5b,3248 - stm-hamt-1.2.0.4@sha256:7957497c022554b7599e790696d1a3e56359ad99e5da36a251894c626ca1f60a,3970 - primitive-0.7.0.0@sha256:ee352d97cc390d8513530029a2213a95c179a66c406906b18d03702c1d9ab8e5,3416 diff --git a/stack.yaml.lock b/stack.yaml.lock index 9d8d32d69f2..f0c06cfda10 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,13 +4,6 @@ # https://docs.haskellstack.org/en/stable/lock_files packages: -- completed: - hackage: network-uri-static-0.1.2.1@sha256:7e1ca4358b319ac2db6514d0e0beb073c296789eeef9cebd89cc9517618fbfe8,1724 - pantry-tree: - size: 334 - sha256: ee5fd663eed91eedc681a798578b32b1ba8fbf7a15924303aef8f1761a42c137 - original: - hackage: network-uri-static-0.1.2.1@sha256:7e1ca4358b319ac2db6514d0e0beb073c296789eeef9cebd89cc9517618fbfe8,1724 - completed: hackage: stm-containers-1.1.0.4@sha256:f83a683357b6e3b1dda3e70d2077a37224ed534df1f74c4e11f3f6daa7945c5b,3248 pantry-tree: @@ -62,7 +55,7 @@ packages: hackage: ghc-lib-parser-8.8.2.20200205@sha256:343f889f7b29f5ec07cf0d18d2a53f250fa5c002b6468a6a05b385d0191b8d34,8408 snapshots: - completed: - size: 545658 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/12.yaml - sha256: 26b807457213126d26b595439d705dc824dbb7618b0de6b900adc2bf6a059406 - original: lts-14.12 + size: 524996 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml + sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0 + original: lts-14.27 From 6fc6ff150ee5679e4b8f1b75bfbddd75e6a7a460 Mon Sep 17 00:00:00 2001 From: fisx Date: Tue, 23 Jun 2020 22:22:07 +0200 Subject: [PATCH 44/64] Fix ormolu script. (#46) --- tools/ormolu.sh | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tools/ormolu.sh b/tools/ormolu.sh index 68680626f66..0fa51159be3 100755 --- a/tools/ormolu.sh +++ b/tools/ormolu.sh @@ -1,5 +1,7 @@ #!/usr/bin/env bash +set -e + cd "$( dirname "${BASH_SOURCE[0]}" )/.." command -v grep >/dev/null 2>&1 || { echo >&2 "grep is not installed, aborting."; exit 1; } From 4878a7e4cc0f1458a3c10e1429719fe02f87d2ec Mon Sep 17 00:00:00 2001 From: fisx Date: Tue, 23 Jun 2020 22:26:40 +0200 Subject: [PATCH 45/64] Fix ormolu script. (#1142) --- tools/ormolu.sh | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tools/ormolu.sh b/tools/ormolu.sh index 631eba9612b..d2f7a47aa2e 100755 --- a/tools/ormolu.sh +++ b/tools/ormolu.sh @@ -1,5 +1,7 @@ #!/usr/bin/env bash +set -e + cd "$( dirname "${BASH_SOURCE[0]}" )/.." command -v grep >/dev/null 2>&1 || { echo >&2 "grep is not installed, aborting."; exit 1; } From b66acf707dccac80c72cee28dca69287f1e41bed Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Wed, 24 Jun 2020 11:16:38 +0200 Subject: [PATCH 46/64] Test sign up with invalid email (#1141) * test invalid email or phone * move validateDomain --- libs/brig-types/src/Brig/Types/Common.hs | 1 + libs/wire-api/package.yaml | 1 + libs/wire-api/src/Wire/API/User/Identity.hs | 44 +++++++++++++++++++ libs/wire-api/wire-api.cabal | 3 +- services/brig/brig.cabal | 3 +- services/brig/package.yaml | 1 - services/brig/src/Brig/Email.hs | 33 -------------- .../brig/test/integration/API/User/Account.hs | 34 +++++++++++--- 8 files changed, 77 insertions(+), 43 deletions(-) diff --git a/libs/brig-types/src/Brig/Types/Common.hs b/libs/brig-types/src/Brig/Types/Common.hs index 97887544ea9..bfc1cbef1ca 100644 --- a/libs/brig-types/src/Brig/Types/Common.hs +++ b/libs/brig-types/src/Brig/Types/Common.hs @@ -37,6 +37,7 @@ module Brig.Types.Common Email (..), fromEmail, parseEmail, + validateEmail, Phone (..), parsePhone, isValidPhone, diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index 2ffe8e699f5..c7f8a436f5e 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -26,6 +26,7 @@ library: - cassandra-util - cryptonite >=0.11 - currency-codes >=2.0 + - email-validate >=2.0 - errors - exceptions >=0.10.0 - extra diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index d6d0fca5f51..edf244b6811 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -31,6 +31,7 @@ module Wire.API.User.Identity Email (..), fromEmail, parseEmail, + validateEmail, -- * Phone Phone (..), @@ -47,11 +48,14 @@ where import Control.Applicative (optional) import Data.Aeson hiding (()) import Data.Attoparsec.Text +import Data.Bifunctor (first) import Data.ByteString.Conversion import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8', encodeUtf8) import Data.Time.Clock import Imports import qualified Test.QuickCheck as QC +import qualified Text.Email.Validate as Email.V import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) -------------------------------------------------------------------------------- @@ -155,6 +159,46 @@ parseEmail t = case Text.split (== '@') t of [localPart, domain] -> Just $! Email localPart domain _ -> Nothing +-- | +-- FUTUREWORK: +-- +-- * Enforce these constrains during parsing already or use a separate type, see +-- [Parse, don't validate](https://lexi-lambda.github.io/blog/2019/11/05/parse-don-t-validate). +-- +-- * Check for differences to validation of `Data.Domain.Domain` and decide whether to +-- align/de-duplicate the two. +-- +-- * Drop dependency on email-validate? We do our own email domain validation anyways, +-- is the dependency worth it just for validating the local part? +validateEmail :: Email -> Either String Email +validateEmail = + pure . uncurry Email + <=< validateDomain + <=< validateExternalLib + <=< validateLength . fromEmail + where + validateLength e + | len <= 100 = Right e + | otherwise = Left $ "length " <> show len <> " exceeds 100" + where + len = Text.length e + validateExternalLib e = do + email <- Email.V.validate $ encodeUtf8 e + l <- first show . decodeUtf8' $ Email.V.localPart email + d <- first show . decodeUtf8' $ Email.V.domainPart email + pure (l, d) + -- cf. https://en.wikipedia.org/wiki/Email_address#Domain + -- n.b. We do not allow IP address literals, comments or non-ASCII + -- characters, mostly because SES (and probably many other mail + -- systems) don't support that (yet?) either. + validateDomain (l, d) = parseOnly domain d + where + domain = label *> many1 (char '.' *> label) *> endOfInput *> pure (l, d) + label = + satisfy (inClass "a-zA-Z0-9") + *> count 61 (optional (satisfy (inClass "-a-zA-Z0-9"))) + *> optional (satisfy (inClass "a-zA-Z0-9")) + -------------------------------------------------------------------------------- -- Phone diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index cc30f4b145e..f084cc5bf6e 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 0b7804e84887d0d642757ae3d7c847a618e620969c1980684e728683b4be5d3e +-- hash: b5bd8bb8589df54572262f534ebd7e422f17cc5bb76b88b1b64ef0390ffbd6ad name: wire-api version: 0.1.0 @@ -86,6 +86,7 @@ library , containers >=0.5 , cryptonite >=0.11 , currency-codes >=2.0 + , email-validate >=2.0 , errors , exceptions >=0.10.0 , extra diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index bfce591b023..f197b9f8eb4 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -4,7 +4,7 @@ cabal-version: 2.0 -- -- see: https://github.com/sol/hpack -- --- hash: b6a944d4d084f81687d2b816c99a5fe95cdd1d7c6aa866bf3f709981c28fe442 +-- hash: 5b6d9d31d5e95d40726d293fd31802c4a12c0d31327e3b948142f77d22117abb name: brig version: 1.35.0 @@ -136,7 +136,6 @@ library , data-timeout >=0.3 , directory >=1.2 , either >=4.3 - , email-validate >=2.0 , enclosed-exceptions >=1.0 , errors >=1.4 , exceptions >=0.5 diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 6a873572b14..50ba0151cff 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -42,7 +42,6 @@ library: - data-timeout >=0.3 - directory >=1.2 - either >=4.3 - - email-validate >=2.0 - enclosed-exceptions >=1.0 - errors >=1.4 - extra >=1.3 diff --git a/services/brig/src/Brig/Email.hs b/services/brig/src/Brig/Email.hs index 648917af983..fedd0e07a42 100644 --- a/services/brig/src/Brig/Email.hs +++ b/services/brig/src/Brig/Email.hs @@ -43,14 +43,10 @@ import qualified Brig.AWS as AWS import Brig.App (AppIO, awsEnv, smtpEnv) import qualified Brig.SMTP as SMTP import Brig.Types -import Control.Applicative (optional) import Control.Lens (view) -import Data.Attoparsec.ByteString.Char8 import qualified Data.Text as Text -import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Imports import Network.Mail.Mime -import qualified Text.Email.Validate as Email ------------------------------------------------------------------------------- sendMail :: Mail -> AppIO () @@ -58,35 +54,6 @@ sendMail m = view smtpEnv >>= \case Just smtp -> SMTP.sendMail smtp m Nothing -> view awsEnv >>= \e -> AWS.execute e $ AWS.sendMail m --- Validation - --- | (Check out 'mkEmailKey' if you wonder about equality of emails with @+@ in their local part.) -validateEmail :: Email -> Either String Email -validateEmail (fromEmail -> e) = - validateLength - >>= Email.validate - >>= validateDomain - >>= pure . mkEmail - where - len = Text.length e - validateLength - | len <= 100 = Right $ encodeUtf8 e - | otherwise = Left $ "length " <> show len <> " exceeds 100" - -- cf. https://en.wikipedia.org/wiki/Email_address#Domain - -- n.b. We do not allow IP address literals, comments or non-ASCII - -- characters, mostly because SES (and probably many other mail - -- systems) don't support that (yet?) either. - validateDomain e' = parseOnly parser (Email.domainPart e') - where - parser = label *> many1 (char '.' *> label) *> endOfInput *> pure e' - label = - satisfy (inClass "a-zA-Z0-9") - *> count 61 (optional (satisfy (inClass "-a-zA-Z0-9"))) - *> optional (satisfy (inClass "a-zA-Z0-9")) - mkEmail v = Email (mkLocal v) (mkDomain v) - mkLocal = decodeUtf8 . Email.localPart - mkDomain = decodeUtf8 . Email.domainPart - ------------------------------------------------------------------------------- -- Unique Keys diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 81940b583b0..4f3932d4e13 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -83,7 +83,7 @@ tests _ at opts p b c ch g aws = test' aws p "post /register - 201 pending" $ testCreateUserPending b, test' aws p "post /register - 201 existing activation" $ testCreateAccountPendingActivationKey b, test' aws p "post /register - 409 conflict" $ testCreateUserConflict b, - test' aws p "post /register - 400" $ testCreateUserInvalidPhone b, + test' aws p "post /register - 400 invalid input" $ testCreateUserInvalidEmailOrPhone b, test' aws p "post /register - 403 blacklist" $ testCreateUserBlacklist b aws, test' aws p "post /register - 400 external-SSO" $ testCreateUserExternalSSO b, test' aws p "post /activate - 200/204 + expiry" $ testActivateWithExpiry b at, @@ -97,7 +97,8 @@ tests _ at opts p b c ch g aws = test' aws p "put /self/password - 200" $ testPasswordChange b, test' aws p "put /self/locale - 200" $ testUserLocaleUpdate b aws, test' aws p "post /activate/send - 200" $ testSendActivationCode b, - test' aws p "post /activate/send - 403" $ testSendActivationCodePrefixExcluded b, + test' aws p "post /activate/send - 400 invalid input" $ testSendActivationCodeInvalidEmailOrPhone b, + test' aws p "post /activate/send - 403 prefix excluded" $ testSendActivationCodePrefixExcluded b, test' aws p "post /i/users/phone-prefix" $ testInternalPhonePrefixes b, test' aws p "put /i/users/:uid/status (suspend)" $ testSuspendUser b, test' aws p "get /i/users?:(email|phone) - 200" $ testGetByIdentity b, @@ -284,10 +285,10 @@ testCreateUserConflict brig = do const 409 === statusCode const (Just "key-exists") === fmap Error.label . responseJsonMaybe -testCreateUserInvalidPhone :: Brig -> Http () -testCreateUserInvalidPhone brig = do +testCreateUserInvalidEmailOrPhone :: Brig -> Http () +testCreateUserInvalidEmailOrPhone brig = do email <- randomEmail - let p = + let reqEmail = RequestBodyLBS . encode $ object [ "name" .= ("foo" :: Text), @@ -295,7 +296,19 @@ testCreateUserInvalidPhone brig = do "password" .= defPassword, "phone" .= ("123456" :: Text) -- invalid phone nr ] - post (brig . path "/register" . contentJson . body p) + post (brig . path "/register" . contentJson . body reqEmail) + !!! const 400 === statusCode + + phone <- randomPhone + let reqPhone = + RequestBodyLBS . encode $ + object + [ "name" .= ("foo" :: Text), + "email" .= ("invalid@email" :: Text), -- invalid since there's only a single label + "password" .= defPassword, + "phone" .= fromPhone phone + ] + post (brig . path "/register" . contentJson . body reqPhone) !!! const 400 === statusCode testCreateUserBlacklist :: Brig -> AWS.Env -> Http () @@ -735,6 +748,15 @@ testSendActivationCode brig = do -- Re-request existing activation code requestActivationCode brig 200 (Left email) +testSendActivationCodeInvalidEmailOrPhone :: Brig -> Http () +testSendActivationCodeInvalidEmailOrPhone brig = do + let Just invalidEmail = parseEmail "?@?" + let invalidPhone = Phone "1234" + -- Code for phone pre-verification + requestActivationCode brig 400 (Right invalidPhone) + -- Code for email pre-verification + requestActivationCode brig 400 (Left invalidEmail) + testSendActivationCodePrefixExcluded :: Brig -> Http () testSendActivationCodePrefixExcluded brig = do p <- randomPhone From 86ffe0566296481b9313650bdf69fc7ddb1d09e5 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Wed, 24 Jun 2020 12:55:10 +0200 Subject: [PATCH 47/64] add missing license headers (#1143) --- .../test/integration/API/Teams/Feature.hs | 17 +++++++++++++++++ .../test/integration/API/Util/TeamFeature.hs | 17 +++++++++++++++++ 2 files changed, 34 insertions(+) diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index 7d6d10f8aea..a7e911be80d 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -1,3 +1,20 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + module API.Teams.Feature (tests) where import qualified API.Util as Util diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs index 8a5d1b71bff..44aeb34f7d1 100644 --- a/services/galley/test/integration/API/Util/TeamFeature.hs +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -1,3 +1,20 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + module API.Util.TeamFeature where import qualified API.Util as Util From f5f7489b5fd731537617eb3b9e9e86f4327e81d3 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Mon, 29 Jun 2020 17:47:39 +0200 Subject: [PATCH 48/64] Active flag (#45) * Add test * Make 'active' field patchable * Make tests marginally more generic. Co-authored-by: Matthias Fischmann --- src/Web/Scim/Schema/User.hs | 24 ++++++++++------- src/Web/Scim/Schema/User/Name.hs | 3 +++ stack-deps.nix | 11 ++++++++ stack.yaml | 3 +-- test/Test/Schema/UserSpec.hs | 46 +++++++++++++++++++++++++++++++- 5 files changed, 74 insertions(+), 13 deletions(-) create mode 100644 stack-deps.nix diff --git a/src/Web/Scim/Schema/User.hs b/src/Web/Scim/Schema/User.hs index ea079078ab4..8645de20eda 100644 --- a/src/Web/Scim/Schema/User.hs +++ b/src/Web/Scim/Schema/User.hs @@ -297,20 +297,23 @@ applyUserOperation user (Operation Replace (Just (NormalPath (AttrPath _schema a (\x -> user {displayName = x}) <$> resultToScimError (fromJSON value) "externalid" -> (\x -> user {externalId = x}) <$> resultToScimError (fromJSON value) - _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid")) + "active" -> + (\x -> user {active = x}) <$> resultToScimError (fromJSON value) + _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid, active")) applyUserOperation _ (Operation Replace (Just (IntoValuePath _ _)) _) = do throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet")) applyUserOperation user (Operation Replace Nothing (Just value)) = do case value of - Object hm | null ((AttrName <$> HM.keys hm) \\ ["username", "displayname", "externalid"]) -> pure () - _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid")) - (u :: User tag) <- resultToScimError $ fromJSON value - pure $ - user - { userName = userName u, - displayName = displayName u, - externalId = externalId u - } + Object hm | null ((AttrName <$> HM.keys hm) \\ ["username", "displayname", "externalid", "active"]) -> do + (u :: User tag) <- resultToScimError $ fromJSON value + pure $ + user + { userName = userName u, + displayName = displayName u, + externalId = externalId u, + active = active u + } + _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid, active")) applyUserOperation _ (Operation Replace _ Nothing) = throwError (badRequest InvalidValue (Just "No value was provided")) applyUserOperation _ (Operation Remove Nothing _) = throwError (badRequest NoTarget Nothing) @@ -319,6 +322,7 @@ applyUserOperation user (Operation Remove (Just (NormalPath (AttrPath _schema at "username" -> throwError (badRequest Mutability Nothing) "displayname" -> pure $ user {displayName = Nothing} "externalid" -> pure $ user {externalId = Nothing} + "active" -> pure $ user {active = Nothing} _ -> pure user applyUserOperation _ (Operation Remove (Just (IntoValuePath _ _)) _) = do throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet")) diff --git a/src/Web/Scim/Schema/User/Name.hs b/src/Web/Scim/Schema/User/Name.hs index 2ff94dea2dc..060b42b868b 100644 --- a/src/Web/Scim/Schema/User/Name.hs +++ b/src/Web/Scim/Schema/User/Name.hs @@ -16,6 +16,9 @@ data Name } deriving (Show, Eq, Generic) +emptyName :: Name +emptyName = Name Nothing Nothing Nothing Nothing Nothing Nothing + instance FromJSON Name where parseJSON = genericParseJSON parseOptions . jsonLower diff --git a/stack-deps.nix b/stack-deps.nix new file mode 100644 index 00000000000..9df08d7fa93 --- /dev/null +++ b/stack-deps.nix @@ -0,0 +1,11 @@ +let + pkgs = import ; +in +pkgs.haskell.lib.buildStackProject { + name = "wire-server"; + buildInputs = with pkgs; [ + pkgconfig + zlib + ]; + ghc = pkgs.haskell.compiler.ghc865; +} diff --git a/stack.yaml b/stack.yaml index 59be778fa51..24582d14512 100644 --- a/stack.yaml +++ b/stack.yaml @@ -13,5 +13,4 @@ extra-deps: - ghc-lib-parser-8.8.2.20200205@sha256:343f889f7b29f5ec07cf0d18d2a53f250fa5c002b6468a6a05b385d0191b8d34,8408 # for ormolu-0.0.3.1 nix: - packages: - - zlib + shell-file: stack-deps.nix diff --git a/test/Test/Schema/UserSpec.hs b/test/Test/Schema/UserSpec.hs index 07e5d973478..d455d9a46f4 100644 --- a/test/Test/Schema/UserSpec.hs +++ b/test/Test/Schema/UserSpec.hs @@ -8,6 +8,8 @@ module Test.Schema.UserSpec where import Data.Aeson +import Data.Either (isLeft, isRight) +import Data.Foldable (for_) import qualified Data.HashMap.Strict as HM import Data.Text (Text, toLower, toUpper) import HaskellWorks.Hspec.Hedgehog (require) @@ -18,8 +20,9 @@ import Lens.Micro import Network.URI.Static (uri) import Test.Hspec import Text.Email.Validate (emailAddress) +import Web.Scim.Filter (AttrPath (..)) import Web.Scim.Schema.Common (URI (..)) -import Web.Scim.Schema.PatchOp (Op (..), Operation (..), PatchOp (..), Patchable (..)) +import Web.Scim.Schema.PatchOp (Op (..), Operation (..), PatchOp (..), Patchable (..), Path (..)) import qualified Web.Scim.Schema.PatchOp as PatchOp import Web.Scim.Schema.Schema (Schema (..)) import Web.Scim.Schema.User (NoUserExtra (..), User (..)) @@ -56,6 +59,47 @@ type UserExtraPatch = HM.HashMap Text Text spec :: Spec spec = do describe "applyPatch" $ do + it "only applies patch for supported fields" $ do + let schemas' = [] + let extras = HM.empty + let user :: User PatchTag = User.empty schemas' "hello" extras + for_ + [ ("username", String "lol"), + ("displayname", String "lol"), + ("externalid", String "lol"), + ("active", Bool True) + ] + $ \(key, upd) -> do + let operation = Operation Replace (Just (NormalPath (AttrPath Nothing key Nothing))) (Just upd) + let patchOp = PatchOp [operation] + User.applyPatch user patchOp `shouldSatisfy` isRight + it "does not support multi-value attributes" $ do + let schemas' = [] + let extras = HM.empty + let user :: User PatchTag = User.empty schemas' "hello" extras + for_ + [ ("schemas", toJSON @[Schema] mempty), + ("name", toJSON @Name emptyName), + ("nickName", toJSON @Text mempty), + ("profileUrl", toJSON @URI (URI [uri|https://example.com|])), + ("title", toJSON @Text mempty), + ("userType", toJSON @Text mempty), + ("preferredLanguage", toJSON @Text mempty), + ("locale", toJSON @Text mempty), + ("password", toJSON @Text mempty), + ("emails", toJSON @[Email] mempty), + ("phoneNumbers", toJSON @[Phone] mempty), + ("ims", toJSON @[IM] mempty), + ("photos", toJSON @[Photo] mempty), + ("addresses", toJSON @[Address] mempty), + ("entitlements", toJSON @[Text] mempty), + ("roles", toJSON @[Text] mempty), + ("x509Certificates", toJSON @[Certificate] mempty) + ] + $ \(key, upd) -> do + let operation = Operation Replace (Just (NormalPath (AttrPath Nothing key Nothing))) (Just upd) + let patchOp = PatchOp [operation] + User.applyPatch user patchOp `shouldSatisfy` isLeft it "applies patch to `extra`" $ do let schemas' = [] let extras = HM.empty From 3dd69bff7586bc700807999a2943650285485251 Mon Sep 17 00:00:00 2001 From: jschaul Date: Mon, 29 Jun 2020 22:13:09 +0200 Subject: [PATCH 49/64] Add link to twilio message ID format (#1150) --- services/brig/brig.integration.yaml | 2 +- services/brig/src/Brig/Options.hs | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index ea46e2d1c1a..1e8a9a17081 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -76,7 +76,7 @@ emailSMS: general: templateDir: deb/opt/brig/templates emailSender: backend-integration@wire.com - smsSender: "" + smsSender: "+123456789" # or MG123456789... (twilio alphanumeric sender id) templateBranding: brand: Wire brandUrl: https://wire.com diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 4c4acc3e008..ff26ddcf1cc 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -143,8 +143,9 @@ data EmailSMSGeneralOpts = EmailSMSGeneralOpts templateDir :: !FilePath, -- | Email sender address emailSender :: !Email, - -- | Twilio sender identifier (number or - -- messaging service ID) + -- | Twilio sender identifier (sender phone number in E.104 format) + -- or twilio messaging sender ID - see + -- https://www.twilio.com/docs/sms/send-messages#use-an-alphanumeric-sender-id smsSender :: !Text, -- | Customizable branding text for -- emails/sms/calls From 453984c9a8b0e107e07b0a149f6c41312bfedd40 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Tue, 30 Jun 2020 11:11:32 +0200 Subject: [PATCH 50/64] Fix services-demo (Docker) (#1149) * fix galley services-demo config * align nginx-docker.conf with nginx.conf * align other services' Docker config with non-Docker version --- deploy/services-demo/conf/brig.demo-docker.yaml | 3 +++ deploy/services-demo/conf/galley.demo-docker.yaml | 7 +++++++ deploy/services-demo/conf/galley.demo.yaml | 1 + deploy/services-demo/conf/nginz/nginx-docker.conf | 12 +++++++++++- deploy/services-demo/conf/proxy.demo-docker.yaml | 9 +++++++++ deploy/services-demo/docker-compose.yaml | 2 +- 6 files changed, 32 insertions(+), 2 deletions(-) create mode 100644 deploy/services-demo/conf/proxy.demo-docker.yaml diff --git a/deploy/services-demo/conf/brig.demo-docker.yaml b/deploy/services-demo/conf/brig.demo-docker.yaml index 0b522c72fd9..ec93635dec1 100644 --- a/deploy/services-demo/conf/brig.demo-docker.yaml +++ b/deploy/services-demo/conf/brig.demo-docker.yaml @@ -84,6 +84,9 @@ zauth: sessionTokenTimeout: 604800 # 7 days accessTokenTimeout: 900 # 15 minutes providerTokenTimeout: 604800 # 7 days + legalHoldUserTokenTimeout: 4838400 # 56 days + legalHoldSessionTokenTimeout: 604800 # 7 days + legalHoldAccessTokenTimeout: 900 # 15 minutes turn: serversV2: resources/turn/servers-v2.txt diff --git a/deploy/services-demo/conf/galley.demo-docker.yaml b/deploy/services-demo/conf/galley.demo-docker.yaml index b0a57cb5259..5d548e9f9a1 100644 --- a/deploy/services-demo/conf/galley.demo-docker.yaml +++ b/deploy/services-demo/conf/galley.demo-docker.yaml @@ -26,6 +26,13 @@ settings: maxConvSize: 128 intraListing: false conversationCodeURI: https://cannon/join/ + concurrentDeletionEvents: 1024 + deleteConvThrottleMillis: 0 + + featureFlags: # see #RefConfigOptions in `/docs/reference` + sso: disabled-by-default + legalhold: disabled-by-default + teamSearchVisibility: disabled-by-default logLevel: Info logNetStrings: false diff --git a/deploy/services-demo/conf/galley.demo.yaml b/deploy/services-demo/conf/galley.demo.yaml index c60bc4b92e1..9dbce0463c4 100644 --- a/deploy/services-demo/conf/galley.demo.yaml +++ b/deploy/services-demo/conf/galley.demo.yaml @@ -32,6 +32,7 @@ settings: featureFlags: # see #RefConfigOptions in `/docs/reference` sso: disabled-by-default legalhold: disabled-by-default + teamSearchVisibility: disabled-by-default logLevel: Info logNetStrings: false diff --git a/deploy/services-demo/conf/nginz/nginx-docker.conf b/deploy/services-demo/conf/nginz/nginx-docker.conf index 4592ce80ec5..120d6c49e36 100644 --- a/deploy/services-demo/conf/nginz/nginx-docker.conf +++ b/deploy/services-demo/conf/nginz/nginx-docker.conf @@ -58,8 +58,12 @@ http { # # Logging # + # Note sanitized_request: + # We allow passing access_token as query parameter for e.g. websockets + # However we do not want to log access tokens. + # - log_format custom_zeta '$remote_addr - $remote_user [$time_local] "$request" $status $body_bytes_sent "$http_referer" "$http_user_agent" "$http_x_forwarded_for" - $connection $request_time $upstream_response_time $upstream_cache_status $zauth_user $zauth_connection $request_id $proxy_protocol_addr'; + log_format custom_zeta '$remote_addr - $remote_user [$time_local] "$sanitized_request" $status $body_bytes_sent "$http_referer" "$http_user_agent" "$http_x_forwarded_for" - $connection $request_time $upstream_response_time $upstream_cache_status $zauth_user $zauth_connection $request_id $proxy_protocol_addr'; access_log /dev/stdout custom_zeta; # @@ -192,6 +196,7 @@ http { include common_response_with_zauth.conf; proxy_pass http://brig; } + # Cargohold Endpoints rewrite ^/api-docs/assets /assets/api-docs?base_url=http://127.0.0.1:8080/ break; @@ -272,6 +277,11 @@ http { proxy_pass http://galley; } + location ~* ^/teams/([^/]*)/features/([^/]*) { + include common_response_with_zauth.conf; + proxy_pass http://galley; + } + # Gundeck Endpoints rewrite ^/api-docs/push /push/api-docs?base_url=http://127.0.0.1:8080/ break; diff --git a/deploy/services-demo/conf/proxy.demo-docker.yaml b/deploy/services-demo/conf/proxy.demo-docker.yaml new file mode 100644 index 00000000000..f729d3972a0 --- /dev/null +++ b/deploy/services-demo/conf/proxy.demo-docker.yaml @@ -0,0 +1,9 @@ +host: proxy +port: 8087 + +httpPoolSize: 1000 +maxConns: 5000 +secretsConfig: resources/proxy.config + +logLevel: Info +logNetStrings: false diff --git a/deploy/services-demo/docker-compose.yaml b/deploy/services-demo/docker-compose.yaml index 62ff5165f03..35364e5cc67 100644 --- a/deploy/services-demo/docker-compose.yaml +++ b/deploy/services-demo/docker-compose.yaml @@ -113,7 +113,7 @@ services: entrypoint: - /usr/bin/proxy - -c - - /configs/conf/proxy.demo.yaml + - /configs/conf/proxy.demo-docker.yaml working_dir: /configs networks: - dockerephemeral_demo_wire From 87107765fffa792e3e3a3d5516307dcdfacecd25 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Tue, 30 Jun 2020 19:54:03 +0200 Subject: [PATCH 51/64] Fix setting team feature status in Stern/backoffice (#1146) * separate FeatureStatus into sum type and wrapper again * Move json string into query param (or keep it as an object). Co-authored-by: Matthias Fischmann --- libs/wire-api/src/Wire/API/Team/Feature.hs | 70 +++++++++++++------ .../unit/Test/Wire/API/Roundtrip/Aeson.hs | 1 + .../Test/Wire/API/Roundtrip/ByteString.hs | 1 + services/brig/src/Brig/User/Auth.hs | 4 +- services/brig/test/integration/API/Search.hs | 2 +- .../brig/test/integration/API/Team/Util.hs | 10 +-- .../brig/test/integration/API/User/Auth.hs | 2 +- .../brig/test/integration/API/User/Handles.hs | 2 +- services/galley/src/Galley/API/Swagger.hs | 4 +- services/galley/src/Galley/API/Teams.hs | 41 ++++++----- services/galley/src/Galley/Data/Instances.hs | 6 +- .../galley/src/Galley/Data/TeamFeatures.hs | 10 +-- services/galley/test/integration/API/Teams.hs | 16 +++-- .../test/integration/API/Teams/Feature.hs | 32 ++++----- .../test/integration/API/Teams/LegalHold.hs | 16 ++--- .../test/integration/API/Util/TeamFeature.hs | 10 +-- services/spar/src/Spar/Intra/Galley.hs | 6 +- .../Test/Spar/Scim/UserSpec.hs | 2 +- services/spar/test-integration/Util/Core.hs | 6 +- tools/db/migrate-sso-feature-flag/src/Work.hs | 4 +- tools/stern/src/Stern/API.hs | 17 ++--- tools/stern/src/Stern/Intra.hs | 4 +- tools/stern/src/Stern/Swagger.hs | 2 + 23 files changed, 153 insertions(+), 115 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 8f8653f246f..5ed9fd781f0 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StrictData #-} -- This file is part of the Wire Server implementation. @@ -21,11 +22,12 @@ module Wire.API.Team.Feature ( TeamFeatureName (..), TeamFeatureStatus (..), + TeamFeatureStatusValue (..), -- * Swagger - modelTeamFeatureStatus, typeTeamFeatureName, - typeTeamFeatureStatus, + modelTeamFeatureStatus, + typeTeamFeatureStatusValue, ) where @@ -69,35 +71,59 @@ instance ToByteString TeamFeatureName where typeTeamFeatureName :: Doc.DataType typeTeamFeatureName = Doc.string . Doc.enum $ cs . toByteString' <$> [(minBound :: TeamFeatureName) ..] -data TeamFeatureStatus = TeamFeatureEnabled | TeamFeatureDisabled - deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform TeamFeatureStatus) +newtype TeamFeatureStatus = TeamFeatureStatus + {teamFeatureStatusValue :: TeamFeatureStatusValue} + deriving stock (Eq, Show) + deriving newtype (Arbitrary) modelTeamFeatureStatus :: Doc.Model modelTeamFeatureStatus = Doc.defineModel "TeamFeatureStatus" $ do Doc.description "Configuration of a feature for a team" - Doc.property "status" typeTeamFeatureStatus $ Doc.description "status" + Doc.property "status" typeTeamFeatureStatusValue $ Doc.description "status" -typeTeamFeatureStatus :: Doc.DataType -typeTeamFeatureStatus = +instance ToJSON TeamFeatureStatus where + toJSON (TeamFeatureStatus status) = + object + [ "status" .= status + ] + +instance FromJSON TeamFeatureStatus where + parseJSON = withObject "TeamFeatureStatus" $ \o -> + TeamFeatureStatus <$> o .: "status" + +data TeamFeatureStatusValue + = TeamFeatureEnabled + | TeamFeatureDisabled + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform TeamFeatureStatusValue) + +typeTeamFeatureStatusValue :: Doc.DataType +typeTeamFeatureStatusValue = Doc.string $ Doc.enum [ "enabled", "disabled" ] -instance ToJSON TeamFeatureStatus where - toJSON status = - object - [ "status" .= case status of - TeamFeatureEnabled -> String "enabled" - TeamFeatureDisabled -> String "disabled" - ] +instance ToJSON TeamFeatureStatusValue where + toJSON = \case + TeamFeatureEnabled -> String "enabled" + TeamFeatureDisabled -> String "disabled" -instance FromJSON TeamFeatureStatus where - parseJSON = withObject "TeamFeatureStatus" $ \o -> - o .: "status" - >>= \case - "enabled" -> pure TeamFeatureEnabled - "disabled" -> pure TeamFeatureDisabled - x -> fail $ "unexpected status type: " <> T.unpack x +instance FromJSON TeamFeatureStatusValue where + parseJSON = withText "TeamFeatureStatusValue" $ \case + "enabled" -> pure TeamFeatureEnabled + "disabled" -> pure TeamFeatureDisabled + x -> fail $ "unexpected status type: " <> T.unpack x + +instance ToByteString TeamFeatureStatusValue where + builder TeamFeatureEnabled = "enabled" + builder TeamFeatureDisabled = "disabled" + +instance FromByteString TeamFeatureStatusValue where + parser = Parser.takeByteString >>= \b -> + case T.decodeUtf8' b of + Right "enabled" -> pure TeamFeatureEnabled + Right "disabled" -> pure TeamFeatureDisabled + Right t -> fail $ "Invalid TeamFeatureStatusValue: " <> T.unpack t + Left e -> fail $ "Invalid TeamFeatureStatusValue: " <> show e diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index 84dcb832059..e0fd13d2500 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -194,6 +194,7 @@ tests = testRoundTrip @Team.Conversation.TeamConversation, testRoundTrip @Team.Conversation.TeamConversationList, testRoundTrip @Team.Feature.TeamFeatureStatus, + testRoundTrip @Team.Feature.TeamFeatureStatusValue, testRoundTrip @Team.Invitation.InvitationRequest, testRoundTrip @Team.Invitation.Invitation, testRoundTrip @Team.Invitation.InvitationList, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs index 19e211dbc7c..579ecdeb5d1 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/ByteString.hs @@ -64,6 +64,7 @@ tests = testRoundTrip @Provider.Service.Tag.ServiceTag, testRoundTrip @Push.V2.Token.Token, testRoundTrip @Team.Feature.TeamFeatureName, + testRoundTrip @Team.Feature.TeamFeatureStatusValue, testRoundTrip @User.Activation.ActivationCode, testRoundTrip @User.Activation.ActivationKey, testRoundTrip @User.Auth.CookieLabel, diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 845839e7db5..f4a0ec7be2b 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -67,7 +67,7 @@ import Imports import Network.Wai.Utilities.Error ((!>>)) import System.Logger (field, msg, val, (~~)) import qualified System.Logger.Class as Log -import Wire.API.Team.Feature (TeamFeatureStatus (..)) +import Wire.API.Team.Feature (TeamFeatureStatus (..), TeamFeatureStatusValue (..)) data Access u = Access { accessToken :: !AccessToken, @@ -297,6 +297,6 @@ legalHoldLogin (LegalHoldLogin uid plainTextPassword label) typ = do assertLegalHoldEnabled :: TeamId -> ExceptT LegalHoldLoginError AppIO () assertLegalHoldEnabled tid = do stat <- lift $ Intra.getTeamLegalHoldStatus tid - case stat of + case teamFeatureStatusValue stat of TeamFeatureDisabled -> throwE LegalHoldLoginLegalHoldNotEnabled TeamFeatureEnabled -> pure () diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index de32d2c5297..31873c5ffc8 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -48,7 +48,7 @@ import Test.Tasty import Test.Tasty.HUnit import UnliftIO (Concurrently (..), runConcurrently) import Util -import Wire.API.Team.Feature (TeamFeatureStatus (..)) +import Wire.API.Team.Feature (TeamFeatureStatusValue (..)) tests :: Opt.Opts -> Manager -> Galley -> Brig -> IO TestTree tests opts mgr galley brig = do diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 9dfc34a07f7..65439f284d6 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -47,7 +47,7 @@ import qualified Network.Wai.Utilities.Error as Error import Test.Tasty.HUnit import Util import Web.Cookie (parseSetCookie, setCookieName) -import Wire.API.Team.Feature (TeamFeatureStatus (..)) +import Wire.API.Team.Feature (TeamFeatureStatus (..), TeamFeatureStatusValue (..)) -- | FUTUREWORK: Remove 'createPopulatedBindingTeam', 'createPopulatedBindingTeamWithNames', -- and rename 'createPopulatedBindingTeamWithNamesAndHandles' to 'createPopulatedBindingTeam'. @@ -284,13 +284,13 @@ getTeams u galley = newTeam :: Team.BindingNewTeam newTeam = Team.BindingNewTeam $ Team.newNewTeam (unsafeRange "teamName") (unsafeRange "defaultIcon") -putLegalHoldEnabled :: HasCallStack => TeamId -> TeamFeatureStatus -> Galley -> Http () +putLegalHoldEnabled :: HasCallStack => TeamId -> TeamFeatureStatusValue -> Galley -> Http () putLegalHoldEnabled tid enabled g = do void . put $ g . paths ["i", "teams", toByteString' tid, "features", "legalhold"] . contentJson - . lbytes (encode enabled) + . lbytes (encode (TeamFeatureStatus enabled)) . expect2xx accept :: Email -> InvitationCode -> RequestBody @@ -441,13 +441,13 @@ stdInvitationRequest :: Email -> Name -> Maybe Locale -> Maybe Team.Role -> Invi stdInvitationRequest e inviterName loc role = InvitationRequest e inviterName loc role Nothing Nothing -setTeamTeamSearchVisibilityAvailable :: HasCallStack => Galley -> TeamId -> TeamFeatureStatus -> Http () +setTeamTeamSearchVisibilityAvailable :: HasCallStack => Galley -> TeamId -> TeamFeatureStatusValue -> Http () setTeamTeamSearchVisibilityAvailable galley tid status = put ( galley . paths ["i/teams", toByteString' tid, "features/search-visibility"] . contentJson - . body (RequestBodyLBS . encode $ status) + . body (RequestBodyLBS . encode $ TeamFeatureStatus status) ) !!! do const 204 === statusCode diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index f93f0695d1c..2f96bc96cac 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -61,7 +61,7 @@ import Test.Tasty.HUnit import qualified Test.Tasty.HUnit as HUnit import UnliftIO.Async hiding (wait) import Util -import Wire.API.Team.Feature (TeamFeatureStatus (..)) +import Wire.API.Team.Feature (TeamFeatureStatusValue (..)) tests :: Opts.Opts -> Manager -> ZAuth.Env -> Brig -> Galley -> Nginz -> TestTree tests conf m z b g n = diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index 69595a06ac4..e5d566690aa 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -46,7 +46,7 @@ import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently) import Util -import Wire.API.Team.Feature (TeamFeatureStatus (..)) +import Wire.API.Team.Feature (TeamFeatureStatusValue (..)) tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree tests _cl _at conf p b c g = diff --git a/services/galley/src/Galley/API/Swagger.hs b/services/galley/src/Galley/API/Swagger.hs index ab4ec1a8e86..973a21999fc 100644 --- a/services/galley/src/Galley/API/Swagger.hs +++ b/services/galley/src/Galley/API/Swagger.hs @@ -228,12 +228,12 @@ instance ToSchema TeamFeatureStatus where declareNamedSchema _ = pure $ NamedSchema (Just "TeamFeatureStatus") $ mempty - & properties .~ (fromList [("status", Inline status)]) + & properties .~ (fromList [("status", Inline statusValue)]) & required .~ ["status"] & type_ ?~ SwaggerObject & description ?~ "whether a given team feature is enabled" where - status = + statusValue = mempty & enum_ ?~ [String "enabled", String "disabled"] diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 611b07e8089..e5afb96ec76 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -905,27 +905,27 @@ getSSOStatusInternal tid = do FeatureSSOEnabledByDefault -> Public.TeamFeatureEnabled FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled ssoTeamConfig <- TeamFeatures.getFlag tid Public.TeamFeatureSSO - pure . fromMaybe defConfig $ ssoTeamConfig + pure . Public.TeamFeatureStatus . fromMaybe defConfig $ ssoTeamConfig setSSOStatusInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () -setSSOStatusInternal tid ssoTeamConfig = do - case ssoTeamConfig of +setSSOStatusInternal tid (Public.TeamFeatureStatus status) = do + case status of Public.TeamFeatureDisabled -> throwM disableSsoNotImplemented Public.TeamFeatureEnabled -> pure () -- this one is easy to implement :) - TeamFeatures.setFlag tid Public.TeamFeatureSSO ssoTeamConfig + TeamFeatures.setFlag tid Public.TeamFeatureSSO status getLegalholdStatusInternal :: TeamId -> Galley Public.TeamFeatureStatus getLegalholdStatusInternal tid = do featureLegalHold <- view (options . optSettings . setFeatureFlags . flagLegalHold) case featureLegalHold of FeatureLegalHoldDisabledByDefault -> do - legalHoldTeamConfig <- TeamFeatures.getFlag tid Public.TeamFeatureLegalHold - pure (fromMaybe Public.TeamFeatureDisabled legalHoldTeamConfig) + status <- TeamFeatures.getFlag tid Public.TeamFeatureLegalHold + pure . Public.TeamFeatureStatus $ fromMaybe Public.TeamFeatureDisabled status FeatureLegalHoldDisabledPermanently -> do - pure Public.TeamFeatureDisabled + pure (Public.TeamFeatureStatus Public.TeamFeatureDisabled) setLegalholdStatusInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () -setLegalholdStatusInternal tid legalHoldTeamConfig = do +setLegalholdStatusInternal tid (Public.TeamFeatureStatus status) = do do featureLegalHold <- view (options . optSettings . setFeatureFlags . flagLegalHold) case featureLegalHold of @@ -933,11 +933,11 @@ setLegalholdStatusInternal tid legalHoldTeamConfig = do pure () FeatureLegalHoldDisabledPermanently -> do throwM legalHoldFeatureFlagNotEnabled - case legalHoldTeamConfig of + case status of Public.TeamFeatureDisabled -> removeSettings' tid -- FUTUREWORK: We cannot enable legalhold on large teams right now Public.TeamFeatureEnabled -> checkTeamSize - TeamFeatures.setFlag tid Public.TeamFeatureLegalHold legalHoldTeamConfig + TeamFeatures.setFlag tid Public.TeamFeatureLegalHold status where checkTeamSize = do (TeamSize size) <- BrigTeam.getSize tid @@ -953,34 +953,37 @@ getTeamSearchVisibilityAvailableInternal tid = do pure $ case featureTeamSearchVisibility of FeatureTeamSearchVisibilityEnabledByDefault -> Public.TeamFeatureEnabled FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled - fromMaybe defConfig <$> TeamFeatures.getFlag tid Public.TeamFeatureSearchVisibility + Public.TeamFeatureStatus . fromMaybe defConfig + <$> TeamFeatures.getFlag tid Public.TeamFeatureSearchVisibility setTeamSearchVisibilityAvailableInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () -setTeamSearchVisibilityAvailableInternal tid isenabled = do - case isenabled of +setTeamSearchVisibilityAvailableInternal tid (Public.TeamFeatureStatus status) = do + case status of Public.TeamFeatureDisabled -> SearchVisibilityData.resetSearchVisibility tid Public.TeamFeatureEnabled -> pure () -- This allows the option to be set at the team level - TeamFeatures.setFlag tid Public.TeamFeatureSearchVisibility isenabled + TeamFeatures.setFlag tid Public.TeamFeatureSearchVisibility status getValidateSAMLEmailsInternal :: TeamId -> Galley Public.TeamFeatureStatus getValidateSAMLEmailsInternal tid = -- FUTUREWORK: we may also want to get a default from the server config file here, like for -- sso, and team search visibility. - fromMaybe Public.TeamFeatureDisabled + Public.TeamFeatureStatus . fromMaybe Public.TeamFeatureDisabled <$> TeamFeatures.getFlag tid Public.TeamFeatureValidateSAMLEmails setValidateSAMLEmailsInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () -setValidateSAMLEmailsInternal tid = TeamFeatures.setFlag tid Public.TeamFeatureValidateSAMLEmails +setValidateSAMLEmailsInternal tid = + TeamFeatures.setFlag tid Public.TeamFeatureValidateSAMLEmails . Public.teamFeatureStatusValue getDigitalSignaturesInternal :: TeamId -> Galley Public.TeamFeatureStatus getDigitalSignaturesInternal tid = -- FUTUREWORK: we may also want to get a default from the server config file here, like for -- sso, and team search visibility. - fromMaybe Public.TeamFeatureDisabled + Public.TeamFeatureStatus . fromMaybe Public.TeamFeatureDisabled <$> TeamFeatures.getFlag tid Public.TeamFeatureDigitalSignatures setDigitalSignaturesInternal :: TeamId -> Public.TeamFeatureStatus -> Galley () -setDigitalSignaturesInternal tid = TeamFeatures.setFlag tid Public.TeamFeatureDigitalSignatures +setDigitalSignaturesInternal tid = + TeamFeatures.setFlag tid Public.TeamFeatureDigitalSignatures . Public.teamFeatureStatusValue -- | Modify and get visibility type for a team (internal, no user permission checks) getSearchVisibilityInternalH :: TeamId ::: JSON -> Galley Response @@ -997,7 +1000,7 @@ setSearchVisibilityInternalH (tid ::: req ::: _) = do setSearchVisibilityInternal :: TeamId -> TeamSearchVisibilityView -> Galley () setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do - status <- getTeamSearchVisibilityAvailableInternal tid + Public.TeamFeatureStatus status <- getTeamSearchVisibilityAvailableInternal tid unless (status == Public.TeamFeatureEnabled) $ throwM teamSearchVisibilityNotEnabled SearchVisibilityData.setSearchVisibility tid searchVisibility diff --git a/services/galley/src/Galley/Data/Instances.hs b/services/galley/src/Galley/Data/Instances.hs index cdd5e9a4660..d94b533a315 100644 --- a/services/galley/src/Galley/Data/Instances.hs +++ b/services/galley/src/Galley/Data/Instances.hs @@ -125,14 +125,14 @@ instance Cql TeamStatus where n -> fail $ "unexpected team-status: " ++ show n fromCql _ = fail "team-status: int expected" -instance Cql Public.TeamFeatureStatus where +instance Cql Public.TeamFeatureStatusValue where ctype = Tagged IntColumn fromCql (CqlInt n) = case n of 0 -> pure $ Public.TeamFeatureDisabled 1 -> pure $ Public.TeamFeatureEnabled - _ -> fail "fromCql: Invalid TeamFeatureStatus" - fromCql _ = fail "fromCql: TeamFeatureStatus: CqlInt expected" + _ -> fail "fromCql: Invalid TeamFeatureStatusValue" + fromCql _ = fail "fromCql: TeamFeatureStatusValue: CqlInt expected" toCql Public.TeamFeatureDisabled = CqlInt 0 toCql Public.TeamFeatureEnabled = CqlInt 1 diff --git a/services/galley/src/Galley/Data/TeamFeatures.hs b/services/galley/src/Galley/Data/TeamFeatures.hs index 8b6e12d1ffa..968958badef 100644 --- a/services/galley/src/Galley/Data/TeamFeatures.hs +++ b/services/galley/src/Galley/Data/TeamFeatures.hs @@ -27,21 +27,21 @@ import Cassandra import Data.Id import Galley.Data.Instances () import Imports -import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus (..)) +import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatusValue (..)) -- | Is a given feature enabled or disabled? Returns 'Nothing' if team does not exist or the -- feature flag in Cassandra is null. -getFlag :: MonadClient m => TeamId -> TeamFeatureName -> m (Maybe TeamFeatureStatus) +getFlag :: MonadClient m => TeamId -> TeamFeatureName -> m (Maybe TeamFeatureStatusValue) getFlag tid feature = (>>= runIdentity) <$> retry x1 (query1 (select feature) (params Quorum (Identity tid))) -- | Enable or disable feature flag. -setFlag :: MonadClient m => TeamId -> TeamFeatureName -> TeamFeatureStatus -> m () +setFlag :: MonadClient m => TeamId -> TeamFeatureName -> TeamFeatureStatusValue -> m () setFlag tid feature flag = do retry x5 $ write (update feature) (params Quorum (flag, tid)) -select :: TeamFeatureName -> PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatus)) +select :: TeamFeatureName -> PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatusValue)) select feature = fromString $ "select " <> toCol feature <> " from team_features where team_id = ?" -update :: TeamFeatureName -> PrepQuery W (TeamFeatureStatus, TeamId) () +update :: TeamFeatureName -> PrepQuery W (TeamFeatureStatusValue, TeamId) () update feature = fromString $ "update team_features set " <> toCol feature <> " = ? where team_id = ?" toCol :: TeamFeatureName -> String diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index e0bdfe5f91f..ac1821742dd 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -286,9 +286,11 @@ testEnableSSOPerTeam = do owner <- Util.randomUser tid <- Util.createBindingTeamInternal "foo" owner assertQueue "create team" tActivate - let check :: HasCallStack => String -> Public.TeamFeatureStatus -> TestM () + let check :: HasCallStack => String -> Public.TeamFeatureStatusValue -> TestM () check msg enabledness = do - status <- responseJsonUnsafe <$> (getSSOEnabledInternal tid (getSSOEnabledInternal tid TestM () putSSOEnabledInternalCheckNotImplemented = do @@ -298,7 +300,7 @@ testEnableSSOPerTeam = do <$> put ( g . paths ["i", "teams", toByteString' tid, "features", "sso"] - . json Public.TeamFeatureDisabled + . json (Public.TeamFeatureStatus Public.TeamFeatureDisabled) ) liftIO $ do assertEqual "bad status" status403 status @@ -315,9 +317,11 @@ testEnableTeamSearchVisibilityPerTeam :: TestM () testEnableTeamSearchVisibilityPerTeam = do g <- view tsGalley (tid, owner, (member : _)) <- Util.createBindingTeamWithMembers 2 - let check :: (HasCallStack, MonadCatch m, MonadIO m, Monad m, MonadHttp m) => String -> Public.TeamFeatureStatus -> m () + let check :: (HasCallStack, MonadCatch m, MonadIO m, Monad m, MonadHttp m) => String -> Public.TeamFeatureStatusValue -> m () check msg enabledness = do - status <- responseJsonUnsafe <$> (Util.getTeamSearchVisibilityAvailableInternal g tid (Util.getTeamSearchVisibilityAvailableInternal g tid m () putSearchVisibilityCheckNotAllowed = do @@ -1887,7 +1891,7 @@ newTeamMember' perms uid = newTeamMember uid perms Nothing getSSOEnabledInternal :: HasCallStack => TeamId -> TestM ResponseLBS getSSOEnabledInternal = Util.getTeamFeatureFlagInternal Public.TeamFeatureSSO -putSSOEnabledInternal :: HasCallStack => TeamId -> Public.TeamFeatureStatus -> TestM () +putSSOEnabledInternal :: HasCallStack => TeamId -> Public.TeamFeatureStatusValue -> TestM () putSSOEnabledInternal = Util.putTeamFeatureFlagInternal' Public.TeamFeatureSSO expect2xx getSearchVisibility :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> (MonadIO m, MonadHttp m) => m ResponseLBS diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index a7e911be80d..c6107e06b4a 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -52,11 +52,11 @@ testSSO = do Util.connectUsers owner (list1 member []) Util.addTeamMember owner tid (Public.newTeamMember member (rolePermissions RoleMember) Nothing) - let getSSO :: HasCallStack => Public.TeamFeatureStatus -> TestM () + let getSSO :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () getSSO = assertFlag $ Util.getTeamFeatureFlag Public.TeamFeatureSSO member tid - getSSOInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () + getSSOInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () getSSOInternal = assertFlag $ Util.getTeamFeatureFlagInternal Public.TeamFeatureSSO tid - setSSOInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () + setSSOInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () setSSOInternal = Util.putTeamFeatureFlagInternal' Public.TeamFeatureSSO expect2xx tid featureSSO <- view (tsGConf . optSettings . setFeatureFlags . flagSSO) case featureSSO of @@ -83,11 +83,11 @@ testLegalHold = do Util.connectUsers owner (list1 member []) Util.addTeamMember owner tid (Public.newTeamMember member (rolePermissions RoleMember) Nothing) - let getLegalHold :: HasCallStack => Public.TeamFeatureStatus -> TestM () + let getLegalHold :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () getLegalHold = assertFlag $ Util.getTeamFeatureFlag Public.TeamFeatureLegalHold member tid - getLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () + getLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () getLegalHoldInternal = assertFlag $ Util.getTeamFeatureFlagInternal Public.TeamFeatureLegalHold tid - setLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatus -> TestM () + setLegalHoldInternal :: HasCallStack => Public.TeamFeatureStatusValue -> TestM () setLegalHoldInternal = Util.putTeamFeatureFlagInternal' Public.TeamFeatureLegalHold expect2xx tid getLegalHold Public.TeamFeatureDisabled getLegalHoldInternal Public.TeamFeatureDisabled @@ -119,25 +119,25 @@ testSearchVisibility = do let getTeamSearchVisibility :: (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => TeamId -> - Public.TeamFeatureStatus -> + Public.TeamFeatureStatusValue -> m () getTeamSearchVisibility teamid expected = Util.getTeamSearchVisibilityAvailable g owner teamid !!! do statusCode === const 200 - responseJsonEither === const (Right expected) + responseJsonEither === const (Right (Public.TeamFeatureStatus expected)) let getTeamSearchVisibilityInternal :: (Monad m, MonadHttp m, MonadIO m, MonadCatch m, HasCallStack) => TeamId -> - Public.TeamFeatureStatus -> + Public.TeamFeatureStatusValue -> m () getTeamSearchVisibilityInternal teamid expected = Util.getTeamSearchVisibilityAvailableInternal g teamid !!! do statusCode === const 200 - responseJsonEither === const (Right expected) + responseJsonEither === const (Right (Public.TeamFeatureStatus expected)) let setTeamSearchVisibilityInternal :: (Monad m, MonadHttp m, MonadIO m, HasCallStack) => TeamId -> - Public.TeamFeatureStatus -> + Public.TeamFeatureStatusValue -> m () setTeamSearchVisibilityInternal = Util.putTeamSearchVisibilityAvailableInternal g @@ -170,11 +170,11 @@ testSimpleFlag feature = do Util.connectUsers owner (list1 member []) Util.addTeamMember owner tid (Public.newTeamMember member (rolePermissions RoleMember) Nothing) - let getFlag :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatus -> TestM () + let getFlag :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatusValue -> TestM () getFlag f expected = flip assertFlag expected $ Util.getTeamFeatureFlag f member tid - getFlagInternal :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatus -> TestM () + getFlagInternal :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatusValue -> TestM () getFlagInternal f expected = flip assertFlag expected $ Util.getTeamFeatureFlagInternal f tid - setFlagInternal :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatus -> TestM () + setFlagInternal :: HasCallStack => Public.TeamFeatureName -> Public.TeamFeatureStatusValue -> TestM () setFlagInternal f = Util.putTeamFeatureFlagInternal' f expect2xx tid -- Disabled by default @@ -186,7 +186,7 @@ testSimpleFlag feature = do getFlag feature Public.TeamFeatureEnabled getFlagInternal feature Public.TeamFeatureEnabled -assertFlag :: HasCallStack => TestM ResponseLBS -> Public.TeamFeatureStatus -> TestM () +assertFlag :: HasCallStack => TestM ResponseLBS -> Public.TeamFeatureStatusValue -> TestM () assertFlag res expected = res !!! do statusCode === const 200 - responseJsonEither === const (Right expected) + responseJsonEither === const (Right (Public.TeamFeatureStatus expected)) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 783dd1dcf47..dd859e26e67 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -497,11 +497,11 @@ testEnablePerTeam = do addTeamMemberInternal tid $ newTeamMember member (rolePermissions RoleMember) Nothing ensureQueueEmpty do - status <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid do requestLegalHoldDevice owner member tid !!! const 201 === statusCode @@ -511,7 +511,7 @@ testEnablePerTeam = do liftIO $ assertEqual "User legal hold status should be enabled" UserLegalHoldEnabled status do putEnabled tid Public.TeamFeatureDisabled -- disable again - status <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid TeamId -> Public.TeamFeatureStatus -> TestM () +putEnabled :: HasCallStack => TeamId -> Public.TeamFeatureStatusValue -> TestM () putEnabled tid enabled = void $ putEnabled' expect2xx tid enabled -putEnabled' :: HasCallStack => (Bilge.Request -> Bilge.Request) -> TeamId -> Public.TeamFeatureStatus -> TestM ResponseLBS +putEnabled' :: HasCallStack => (Bilge.Request -> Bilge.Request) -> TeamId -> Public.TeamFeatureStatusValue -> TestM ResponseLBS putEnabled' extra tid enabled = do g <- view tsGalley put $ g . paths ["i", "teams", toByteString' tid, "features", "legalhold"] - . json enabled + . json (Public.TeamFeatureStatus enabled) . extra postSettings :: HasCallStack => UserId -> TeamId -> NewLegalHoldService -> TestM ResponseLBS diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs index 44aeb34f7d1..183495679f4 100644 --- a/services/galley/test/integration/API/Util/TeamFeature.hs +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -43,14 +43,14 @@ getTeamSearchVisibilityAvailableInternal :: HasCallStack => (Request -> Request) getTeamSearchVisibilityAvailableInternal = getTeamFeatureFlagInternalWithGalley Public.TeamFeatureSearchVisibility -putTeamSearchVisibilityAvailableInternal :: HasCallStack => (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> (MonadIO m, MonadHttp m) => m () +putTeamSearchVisibilityAvailableInternal :: HasCallStack => (Request -> Request) -> TeamId -> Public.TeamFeatureStatusValue -> (MonadIO m, MonadHttp m) => m () putTeamSearchVisibilityAvailableInternal g = putTeamFeatureFlagInternalWithGalleyAndMod Public.TeamFeatureSearchVisibility g expect2xx -putLegalHoldEnabledInternal' :: HasCallStack => (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> TestM () +putLegalHoldEnabledInternal' :: HasCallStack => (Request -> Request) -> TeamId -> Public.TeamFeatureStatusValue -> TestM () putLegalHoldEnabledInternal' = putTeamFeatureFlagInternal' Public.TeamFeatureLegalHold -putTeamFeatureFlagInternal' :: HasCallStack => Public.TeamFeatureName -> (Request -> Request) -> TeamId -> Public.TeamFeatureStatus -> TestM () +putTeamFeatureFlagInternal' :: HasCallStack => Public.TeamFeatureName -> (Request -> Request) -> TeamId -> Public.TeamFeatureStatusValue -> TestM () putTeamFeatureFlagInternal' feature reqmod tid status = do g <- view tsGalley putTeamFeatureFlagInternalWithGalleyAndMod feature g reqmod tid status @@ -61,13 +61,13 @@ putTeamFeatureFlagInternalWithGalleyAndMod :: (Request -> Request) -> (Request -> Request) -> TeamId -> - Public.TeamFeatureStatus -> + Public.TeamFeatureStatusValue -> m () putTeamFeatureFlagInternalWithGalleyAndMod feature galley reqmod tid status = void . put $ galley . paths ["i", "teams", toByteString' tid, "features", toByteString' feature] - . json status + . json (Public.TeamFeatureStatus status) . reqmod getTeamFeatureFlagInternal :: HasCallStack => Public.TeamFeatureName -> TeamId -> TestM ResponseLBS diff --git a/services/spar/src/Spar/Intra/Galley.hs b/services/spar/src/Spar/Intra/Galley.hs index da2942999c1..998e721f14c 100644 --- a/services/spar/src/Spar/Intra/Galley.hs +++ b/services/spar/src/Spar/Intra/Galley.hs @@ -32,7 +32,7 @@ import Imports import Network.HTTP.Types (status403) import Network.HTTP.Types.Method import Spar.Error -import Wire.API.Team.Feature (TeamFeatureStatus (..)) +import Wire.API.Team.Feature (TeamFeatureStatus (..), TeamFeatureStatusValue (..)) ---------------------------------------------------------------------- @@ -84,11 +84,11 @@ assertSSOEnabled tid = do . paths ["i", "teams", toByteString' tid, "features", "sso"] unless (statusCode resp == 200) $ throwSpar (SparGalleyError "Could not retrieve SSO config") - status <- parseResponse resp + TeamFeatureStatus status <- parseResponse resp unless (status == TeamFeatureEnabled) $ throwSpar SparSSODisabled isEmailValidationEnabledTeam :: (HasCallStack, MonadSparToGalley m) => TeamId -> m Bool isEmailValidationEnabledTeam tid = do resp <- call $ method GET . paths ["i", "teams", toByteString' tid, "features", "validate-saml-emails"] - pure (statusCode resp == 200 && responseJsonMaybe resp == Just TeamFeatureEnabled) + pure (statusCode resp == 200 && responseJsonMaybe resp == Just (TeamFeatureStatus TeamFeatureEnabled)) diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 5fd52217759..2675471d37d 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -1083,7 +1083,7 @@ specEmailValidation = do let enableSamlEmailValidation :: HasCallStack => TeamId -> TestSpar () enableSamlEmailValidation tid = do galley <- asks (^. teGalley) - let req = put $ galley . paths p . json Feature.TeamFeatureEnabled + let req = put $ galley . paths p . json (Feature.TeamFeatureStatus Feature.TeamFeatureEnabled) p = ["/i/teams", toByteString' tid, "features", "validate-saml-emails"] call req !!! const 204 === statusCode -- diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 756e040bf9b..8a2524cc380 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -185,7 +185,7 @@ import Util.Options import Util.Types import qualified Web.Cookie as Web import qualified Web.Scim.Class.User as ScimC.User -import Wire.API.Team.Feature (TeamFeatureStatus (..)) +import Wire.API.Team.Feature (TeamFeatureStatus (..), TeamFeatureStatusValue (..)) -- | Call 'mkEnv' with options from config files. mkEnvFromOptions :: IO TestEnv @@ -338,12 +338,12 @@ getSSOEnabledInternal gly tid = do gly . paths ["i", "teams", toByteString' tid, "features", "sso"] -putSSOEnabledInternal :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyReq -> TeamId -> TeamFeatureStatus -> m () +putSSOEnabledInternal :: (HasCallStack, MonadHttp m, MonadIO m) => GalleyReq -> TeamId -> TeamFeatureStatusValue -> m () putSSOEnabledInternal gly tid enabled = do void . put $ gly . paths ["i", "teams", toByteString' tid, "features", "sso"] - . json enabled + . json (TeamFeatureStatus enabled) . expect2xx -- | NB: this does create an SSO UserRef on brig, but not on spar. this is inconsistent, but the diff --git a/tools/db/migrate-sso-feature-flag/src/Work.hs b/tools/db/migrate-sso-feature-flag/src/Work.hs index 82351fa8b42..a194b5c8e60 100644 --- a/tools/db/migrate-sso-feature-flag/src/Work.hs +++ b/tools/db/migrate-sso-feature-flag/src/Work.hs @@ -65,8 +65,8 @@ getSsoTeams = paginateC cql (paramsP Quorum () pageSize) x5 writeSsoFlags :: [TeamId] -> Client () writeSsoFlags = mapM_ (`setSSOTeamConfig` TeamFeatureEnabled) where - setSSOTeamConfig :: MonadClient m => TeamId -> TeamFeatureStatus -> m () + setSSOTeamConfig :: MonadClient m => TeamId -> TeamFeatureStatusValue -> m () setSSOTeamConfig tid ssoTeamConfigStatus = do retry x5 $ write updateSSOTeamConfig (params Quorum (ssoTeamConfigStatus, tid)) - updateSSOTeamConfig :: PrepQuery W (TeamFeatureStatus, TeamId) () + updateSSOTeamConfig :: PrepQuery W (TeamFeatureStatusValue, TeamId) () updateSSOTeamConfig = "update team_features set sso_status = ? where team_id = ?" diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 4862765a7c6..5fb4d16c01f 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -337,22 +337,23 @@ routes = do description "Team ID" Doc.parameter Doc.Path "feature" Public.typeTeamFeatureName $ description "Feature name" - Doc.returns Public.typeTeamFeatureStatus + Doc.returns (Doc.ref Public.modelTeamFeatureStatus) Doc.response 200 "Team feature flag status" Doc.end put "/teams/:tid/features/:feature" (continue setTeamFeatureFlagH) $ capture "tid" .&. capture "feature" - .&. contentType "application" "json" - .&. jsonRequest @Public.TeamFeatureStatus + -- We use a query parameter "status" here instead of a JSON body. + -- This improves usability, since swagger-ui displays is as a dropdown, not a text box. + .&. param "status" document "PUT" "setTeamFeatureFlag" $ do summary "Disable / enable feature flag for a given team" Doc.parameter Doc.Path "tid" Doc.bytes' $ description "Team ID" Doc.parameter Doc.Path "feature" Public.typeTeamFeatureName $ description "Feature name" - Doc.body Public.typeTeamFeatureStatus $ - Doc.description "JSON body" + Doc.parameter Doc.Query "status" Public.typeTeamFeatureStatusValue $ do + Doc.description "team feature status (enabled or disabled)" Doc.response 200 "Team feature flag status" Doc.end -- These endpoints should be part of team settings. Until then, we access them from here @@ -584,9 +585,9 @@ getTeamFeatureFlagH :: TeamId ::: Public.TeamFeatureName -> Handler Response getTeamFeatureFlagH (tid ::: feature) = json <$> Intra.getTeamFeatureFlag tid feature -setTeamFeatureFlagH :: TeamId ::: Public.TeamFeatureName ::: JSON ::: JsonRequest Public.TeamFeatureStatus -> Handler Response -setTeamFeatureFlagH (tid ::: feature ::: _ ::: req) = - empty <$ (Intra.setTeamFeatureFlag tid feature =<< (parseBody req !>> Error status400 "client-error")) +setTeamFeatureFlagH :: TeamId ::: Public.TeamFeatureName ::: Public.TeamFeatureStatusValue -> Handler Response +setTeamFeatureFlagH (tid ::: feature ::: status) = do + empty <$ Intra.setTeamFeatureFlag tid feature status setSearchVisibility :: JSON ::: TeamId ::: JsonRequest Team.TeamSearchVisibility -> Handler Response setSearchVisibility (_ ::: tid ::: req) = do diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 66bc5acf71f..f52cc7bd202 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -433,14 +433,14 @@ getTeamFeatureFlag tid feature = do . expect2xx responseJsonUnsafe <$> catchRpcErrors (rpc' "galley" gly req) -setTeamFeatureFlag :: TeamId -> Public.TeamFeatureName -> Public.TeamFeatureStatus -> Handler () +setTeamFeatureFlag :: TeamId -> Public.TeamFeatureName -> Public.TeamFeatureStatusValue -> Handler () setTeamFeatureFlag tid feature status = do info $ msg "Setting team feature status" gly <- view galley let req = method PUT . paths ["/i/teams", toByteString' tid, "features", toByteString' feature] - . Bilge.json status + . Bilge.json (Public.TeamFeatureStatus status) . contentJson resp <- catchRpcErrors $ rpc' "galley" gly req case statusCode resp of diff --git a/tools/stern/src/Stern/Swagger.hs b/tools/stern/src/Stern/Swagger.hs index 8d1efe8960b..db7699c714e 100644 --- a/tools/stern/src/Stern/Swagger.hs +++ b/tools/stern/src/Stern/Swagger.hs @@ -21,11 +21,13 @@ module Stern.Swagger where import Data.Swagger.Build.Api import Imports +import Wire.API.Team.SearchVisibility (modelTeamSearchVisibility) sternModels :: [Model] sternModels = [ emailUpdate, phoneUpdate, + modelTeamSearchVisibility, teamBillingInfo, teamBillingInfoUpdate ] From 5a0992624c407266d07fa27ea1c11d45bfd3cbe8 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 1 Jul 2020 15:22:45 +0200 Subject: [PATCH 52/64] ormolu --- .../src/Web/Scim/Capabilities/MetaSchema.hs | 61 +++++++------- libs/hscim/src/Web/Scim/Class/Group.hs | 77 +++++++++-------- libs/hscim/src/Web/Scim/Class/User.hs | 57 +++++++------ .../Web/Scim/Schema/AuthenticationScheme.hs | 29 ++++--- libs/hscim/src/Web/Scim/Schema/Common.hs | 9 +- libs/hscim/src/Web/Scim/Schema/Error.hs | 13 ++- .../hscim/src/Web/Scim/Schema/ListResponse.hs | 15 ++-- libs/hscim/src/Web/Scim/Schema/Meta.hs | 42 +++++----- libs/hscim/src/Web/Scim/Schema/PatchOp.hs | 16 ++-- .../hscim/src/Web/Scim/Schema/ResourceType.hs | 11 ++- libs/hscim/src/Web/Scim/Schema/User.hs | 83 +++++++++---------- .../hscim/src/Web/Scim/Schema/User/Address.hs | 23 +++-- .../src/Web/Scim/Schema/User/Certificate.hs | 9 +- libs/hscim/src/Web/Scim/Schema/User/Email.hs | 16 ++-- libs/hscim/src/Web/Scim/Schema/User/IM.hs | 9 +- libs/hscim/src/Web/Scim/Schema/User/Name.hs | 17 ++-- libs/hscim/src/Web/Scim/Schema/User/Phone.hs | 9 +- libs/hscim/src/Web/Scim/Schema/User/Photo.hs | 9 +- libs/hscim/src/Web/Scim/Server.hs | 31 ++++--- libs/hscim/src/Web/Scim/Server/Mock.hs | 9 +- libs/hscim/src/Web/Scim/Test/Util.hs | 34 ++++---- 21 files changed, 274 insertions(+), 305 deletions(-) diff --git a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs index 3cddd93799b..9d776ac5635 100644 --- a/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs +++ b/libs/hscim/src/Web/Scim/Capabilities/MetaSchema.hs @@ -31,11 +31,10 @@ import Web.Scim.Schema.ResourceType hiding (schema) import Web.Scim.Schema.Schema import Prelude hiding (filter) -data Supported a - = Supported - { supported :: Bool, - subConfig :: a - } +data Supported a = Supported + { supported :: Bool, + subConfig :: a + } deriving (Show, Eq, Generic) instance ToJSON a => ToJSON (Supported a) where @@ -43,37 +42,34 @@ instance ToJSON a => ToJSON (Supported a) where (Object o) -> Object $ HML.insert "supported" (Bool b) o _ -> Object $ HML.fromList [("supported", Bool b)] -data BulkConfig - = BulkConfig - { maxOperations :: Int, - maxPayloadSize :: Int - } +data BulkConfig = BulkConfig + { maxOperations :: Int, + maxPayloadSize :: Int + } deriving (Show, Eq, Generic) instance ToJSON BulkConfig where toJSON = genericToJSON serializeOptions -data FilterConfig - = FilterConfig - { maxResults :: Int - } +data FilterConfig = FilterConfig + { maxResults :: Int + } deriving (Show, Eq, Generic) instance ToJSON FilterConfig where toJSON = genericToJSON serializeOptions -data Configuration - = Configuration - { documentationUri :: Maybe URI, - schemas :: [Schema], - patch :: Supported (), - bulk :: Supported BulkConfig, - filter :: Supported FilterConfig, - changePassword :: Supported (), - sort :: Supported (), - etag :: Supported (), - authenticationSchemes :: [AuthenticationSchemeEncoding] - } +data Configuration = Configuration + { documentationUri :: Maybe URI, + schemas :: [Schema], + patch :: Supported (), + bulk :: Supported BulkConfig, + filter :: Supported FilterConfig, + changePassword :: Supported (), + sort :: Supported (), + etag :: Supported (), + authenticationSchemes :: [AuthenticationSchemeEncoding] + } deriving (Show, Eq, Generic) instance ToJSON Configuration where @@ -126,11 +122,10 @@ configServer config = ] } -data ConfigSite route - = ConfigSite - { spConfig :: route :- "ServiceProviderConfig" :> Get '[SCIM] Configuration, - getSchemas :: route :- "Schemas" :> Get '[SCIM] (ListResponse Value), - schema :: route :- "Schemas" :> Capture "id" Text :> Get '[SCIM] Value, - resourceTypes :: route :- "ResourceTypes" :> Get '[SCIM] (ListResponse Resource) - } +data ConfigSite route = ConfigSite + { spConfig :: route :- "ServiceProviderConfig" :> Get '[SCIM] Configuration, + getSchemas :: route :- "Schemas" :> Get '[SCIM] (ListResponse Value), + schema :: route :- "Schemas" :> Capture "id" Text :> Get '[SCIM] Value, + resourceTypes :: route :- "ResourceTypes" :> Get '[SCIM] (ListResponse Resource) + } deriving (Generic) diff --git a/libs/hscim/src/Web/Scim/Class/Group.hs b/libs/hscim/src/Web/Scim/Class/Group.hs index 2491c2dfaa6..c8bcab52d34 100644 --- a/libs/hscim/src/Web/Scim/Class/Group.hs +++ b/libs/hscim/src/Web/Scim/Class/Group.hs @@ -36,12 +36,11 @@ class GroupTypes tag where type GroupId tag -- TODO -data Member - = Member - { value :: Text, - typ :: Text, - ref :: Text - } +data Member = Member + { value :: Text, + typ :: Text, + ref :: Text + } deriving (Show, Eq, Generic) instance FromJSON Member where @@ -50,12 +49,11 @@ instance FromJSON Member where instance ToJSON Member where toJSON = genericToJSON serializeOptions -data Group - = Group - { schemas :: [Schema], - displayName :: Text, - members :: [Member] - } +data Group = Group + { schemas :: [Schema], + displayName :: Text, + members :: [Member] + } deriving (Show, Eq, Generic) instance FromJSON Group where @@ -66,34 +64,33 @@ instance ToJSON Group where type StoredGroup tag = WithMeta (WithId (GroupId tag) Group) -data GroupSite tag route - = GroupSite - { gsGetGroups :: - route - :- Get '[SCIM] (ListResponse (StoredGroup tag)), - gsGetGroup :: - route - :- Capture "id" (GroupId tag) - :> Get '[SCIM] (StoredGroup tag), - gsPostGroup :: - route - :- ReqBody '[SCIM] Group - :> PostCreated '[SCIM] (StoredGroup tag), - gsPutGroup :: - route - :- Capture "id" (GroupId tag) - :> ReqBody '[SCIM] Group - :> Put '[SCIM] (StoredGroup tag), - gsPatchGroup :: - route - :- Capture "id" (GroupId tag) - :> ReqBody '[SCIM] Aeson.Value - :> Patch '[SCIM] (StoredGroup tag), - gsDeleteGroup :: - route - :- Capture "id" (GroupId tag) - :> DeleteNoContent '[SCIM] NoContent - } +data GroupSite tag route = GroupSite + { gsGetGroups :: + route + :- Get '[SCIM] (ListResponse (StoredGroup tag)), + gsGetGroup :: + route + :- Capture "id" (GroupId tag) + :> Get '[SCIM] (StoredGroup tag), + gsPostGroup :: + route + :- ReqBody '[SCIM] Group + :> PostCreated '[SCIM] (StoredGroup tag), + gsPutGroup :: + route + :- Capture "id" (GroupId tag) + :> ReqBody '[SCIM] Group + :> Put '[SCIM] (StoredGroup tag), + gsPatchGroup :: + route + :- Capture "id" (GroupId tag) + :> ReqBody '[SCIM] Aeson.Value + :> Patch '[SCIM] (StoredGroup tag), + gsDeleteGroup :: + route + :- Capture "id" (GroupId tag) + :> DeleteNoContent '[SCIM] NoContent + } deriving (Generic) ---------------------------------------------------------------------------- diff --git a/libs/hscim/src/Web/Scim/Class/User.hs b/libs/hscim/src/Web/Scim/Class/User.hs index caf83d04878..bf42dd65446 100644 --- a/libs/hscim/src/Web/Scim/Class/User.hs +++ b/libs/hscim/src/Web/Scim/Class/User.hs @@ -29,35 +29,34 @@ import Web.Scim.Schema.User type StoredUser tag = WithMeta (WithId (UserId tag) (User tag)) -data UserSite tag route - = UserSite - { usGetUsers :: - route - :- QueryParam "filter" Filter - :> Get '[SCIM] (ListResponse (StoredUser tag)), - usGetUser :: - route - :- Capture "id" (UserId tag) - :> Get '[SCIM] (StoredUser tag), - usPostUser :: - route - :- ReqBody '[SCIM] (User tag) - :> PostCreated '[SCIM] (StoredUser tag), - usPutUser :: - route - :- Capture "id" (UserId tag) - :> ReqBody '[SCIM] (User tag) - :> Put '[SCIM] (StoredUser tag), - usPatchUser :: - route - :- Capture "id" (UserId tag) - :> ReqBody '[SCIM] (PatchOp tag) - :> Patch '[SCIM] (StoredUser tag), - usDeleteUser :: - route - :- Capture "id" (UserId tag) - :> DeleteNoContent '[SCIM] NoContent - } +data UserSite tag route = UserSite + { usGetUsers :: + route + :- QueryParam "filter" Filter + :> Get '[SCIM] (ListResponse (StoredUser tag)), + usGetUser :: + route + :- Capture "id" (UserId tag) + :> Get '[SCIM] (StoredUser tag), + usPostUser :: + route + :- ReqBody '[SCIM] (User tag) + :> PostCreated '[SCIM] (StoredUser tag), + usPutUser :: + route + :- Capture "id" (UserId tag) + :> ReqBody '[SCIM] (User tag) + :> Put '[SCIM] (StoredUser tag), + usPatchUser :: + route + :- Capture "id" (UserId tag) + :> ReqBody '[SCIM] (PatchOp tag) + :> Patch '[SCIM] (StoredUser tag), + usDeleteUser :: + route + :- Capture "id" (UserId tag) + :> DeleteNoContent '[SCIM] NoContent + } deriving (Generic) ---------------------------------------------------------------------------- diff --git a/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs b/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs index ae9722e0cd7..f8ffd34f84f 100644 --- a/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs +++ b/libs/hscim/src/Web/Scim/Schema/AuthenticationScheme.hs @@ -29,21 +29,20 @@ data AuthenticationScheme -- | The way authentication schemes are expected to be represented in the -- configuration. Each 'AuthenticationScheme' corresponds to one of such -- encodings. -data AuthenticationSchemeEncoding - = AuthenticationSchemeEncoding - { -- | The authentication scheme - typ :: Text, - -- | The common authentication scheme name, e.g. HTTP Basic - name :: Text, - -- | A description of the authentication scheme - description :: Text, - -- | An HTTP-addressable URL pointing to the authentication scheme's - -- specification - specUri :: Maybe URI, - -- | An HTTP-addressable URL pointing to the authentication scheme's usage - -- documentation - documentationUri :: Maybe URI - } +data AuthenticationSchemeEncoding = AuthenticationSchemeEncoding + { -- | The authentication scheme + typ :: Text, + -- | The common authentication scheme name, e.g. HTTP Basic + name :: Text, + -- | A description of the authentication scheme + description :: Text, + -- | An HTTP-addressable URL pointing to the authentication scheme's + -- specification + specUri :: Maybe URI, + -- | An HTTP-addressable URL pointing to the authentication scheme's usage + -- documentation + documentationUri :: Maybe URI + } deriving (Show, Eq, Generic) instance ToJSON AuthenticationSchemeEncoding where diff --git a/libs/hscim/src/Web/Scim/Schema/Common.hs b/libs/hscim/src/Web/Scim/Schema/Common.hs index 944d1549777..39f43a57550 100644 --- a/libs/hscim/src/Web/Scim/Schema/Common.hs +++ b/libs/hscim/src/Web/Scim/Schema/Common.hs @@ -8,11 +8,10 @@ import Data.String (IsString) import Data.Text hiding (dropWhile) import qualified Network.URI as Network -data WithId id a - = WithId - { id :: id, - value :: a - } +data WithId id a = WithId + { id :: id, + value :: a + } deriving (Eq, Show) instance (ToJSON id, ToJSON a) => ToJSON (WithId id a) where diff --git a/libs/hscim/src/Web/Scim/Schema/Error.hs b/libs/hscim/src/Web/Scim/Schema/Error.hs index 7f6abf77f32..5b6f111d118 100644 --- a/libs/hscim/src/Web/Scim/Schema/Error.hs +++ b/libs/hscim/src/Web/Scim/Schema/Error.hs @@ -66,13 +66,12 @@ newtype Status = Status {unStatus :: Int} instance ToJSON Status where toJSON (Status stat) = String . pack . show $ stat -data ScimError - = ScimError - { schemas :: [Schema], - status :: Status, - scimType :: Maybe ScimErrorType, - detail :: Maybe Text - } +data ScimError = ScimError + { schemas :: [Schema], + status :: Status, + scimType :: Maybe ScimErrorType, + detail :: Maybe Text + } deriving (Show, Eq, Generic) instance ToJSON ScimError where diff --git a/libs/hscim/src/Web/Scim/Schema/ListResponse.hs b/libs/hscim/src/Web/Scim/Schema/ListResponse.hs index cfa7d08e4c2..9335c51ea23 100644 --- a/libs/hscim/src/Web/Scim/Schema/ListResponse.hs +++ b/libs/hscim/src/Web/Scim/Schema/ListResponse.hs @@ -20,14 +20,13 @@ import Web.Scim.Schema.Schema -- -- FUTUREWORK: Support for pagination might be added once we have to handle -- organizations with lots of users. -data ListResponse a - = ListResponse - { schemas :: [Schema], - totalResults :: Int, - itemsPerPage :: Int, - startIndex :: Int, - resources :: [a] - } +data ListResponse a = ListResponse + { schemas :: [Schema], + totalResults :: Int, + itemsPerPage :: Int, + startIndex :: Int, + resources :: [a] + } deriving (Show, Eq, Generic) fromList :: [a] -> ListResponse a diff --git a/libs/hscim/src/Web/Scim/Schema/Meta.hs b/libs/hscim/src/Web/Scim/Schema/Meta.hs index 6b8d666bed5..6be71737d14 100644 --- a/libs/hscim/src/Web/Scim/Schema/Meta.hs +++ b/libs/hscim/src/Web/Scim/Schema/Meta.hs @@ -28,23 +28,22 @@ instance FromJSON ETag where Right x -> pure x Left e -> fail ("couldn't unquote the string: " <> e) -data Meta - = Meta - { resourceType :: ResourceType, - created :: UTCTime, - lastModified :: UTCTime, - -- | Resource version: . - -- - -- A version is an /opaque/ string that doesn't need to conform to any - -- format (e.g. it does not have to be a monotonically increasing integer, - -- contrary to what the word @version@ suggests). - -- - -- For 'Weak' versions we have to guarantee that different resources will - -- have different 'version's. For 'Strong' versions we also have to - -- guarantee that same resources will have the same 'version'. - version :: ETag, - location :: URI - } +data Meta = Meta + { resourceType :: ResourceType, + created :: UTCTime, + lastModified :: UTCTime, + -- | Resource version: . + -- + -- A version is an /opaque/ string that doesn't need to conform to any + -- format (e.g. it does not have to be a monotonically increasing integer, + -- contrary to what the word @version@ suggests). + -- + -- For 'Weak' versions we have to guarantee that different resources will + -- have different 'version's. For 'Strong' versions we also have to + -- guarantee that same resources will have the same 'version'. + version :: ETag, + location :: URI + } deriving (Eq, Show, Generic) instance ToJSON Meta where @@ -53,11 +52,10 @@ instance ToJSON Meta where instance FromJSON Meta where parseJSON = genericParseJSON parseOptions . jsonLower -data WithMeta a - = WithMeta - { meta :: Meta, - thing :: a - } +data WithMeta a = WithMeta + { meta :: Meta, + thing :: a + } deriving (Eq, Show, Generic) instance (ToJSON a) => ToJSON (WithMeta a) where diff --git a/libs/hscim/src/Web/Scim/Schema/PatchOp.hs b/libs/hscim/src/Web/Scim/Schema/PatchOp.hs index 35bbec7cc03..2dc028ea7e7 100644 --- a/libs/hscim/src/Web/Scim/Schema/PatchOp.hs +++ b/libs/hscim/src/Web/Scim/Schema/PatchOp.hs @@ -17,9 +17,8 @@ import Web.Scim.Schema.Error import Web.Scim.Schema.Schema (Schema (PatchOp20)) import Web.Scim.Schema.UserTypes (UserTypes (supportedSchemas)) -newtype PatchOp tag - = PatchOp - {getOperations :: [Operation]} +newtype PatchOp tag = PatchOp + {getOperations :: [Operation]} deriving (Eq, Show) -- | The 'Path' attribute value is a 'String' containing an attribute path @@ -33,12 +32,11 @@ newtype PatchOp tag -- -- NOTE: When the path contains a schema, this schema must be implicitly added -- to the list of schemas on the result type -data Operation - = Operation - { op :: Op, - path :: Maybe Path, - value :: Maybe Value - } +data Operation = Operation + { op :: Op, + path :: Maybe Path, + value :: Maybe Value + } deriving (Eq, Show) data Op diff --git a/libs/hscim/src/Web/Scim/Schema/ResourceType.hs b/libs/hscim/src/Web/Scim/Schema/ResourceType.hs index 6001fcfe229..9dc0771d898 100644 --- a/libs/hscim/src/Web/Scim/Schema/ResourceType.hs +++ b/libs/hscim/src/Web/Scim/Schema/ResourceType.hs @@ -28,12 +28,11 @@ instance FromJSON ResourceType where other -> fail ("unknown ResourceType: " ++ show other) -- | Definitions of endpoints, returned by @/ResourceTypes@. -data Resource - = Resource - { name :: Text, - endpoint :: URI, - schema :: Schema - } +data Resource = Resource + { name :: Text, + endpoint :: URI, + schema :: Schema + } deriving (Show, Eq, Generic) instance ToJSON Resource where diff --git a/libs/hscim/src/Web/Scim/Schema/User.hs b/libs/hscim/src/Web/Scim/Schema/User.hs index 8645de20eda..a78961b6937 100644 --- a/libs/hscim/src/Web/Scim/Schema/User.hs +++ b/libs/hscim/src/Web/Scim/Schema/User.hs @@ -80,48 +80,47 @@ import Web.Scim.Schema.User.Photo (Photo) import Web.Scim.Schema.UserTypes -- | SCIM user record, parametrized with type-level tag @t@ (see 'UserTypes'). -data User tag - = User - { schemas :: [Schema], - -- Mandatory fields - userName :: Text, - -- Optional fields - externalId :: Maybe Text, - name :: Maybe Name, - displayName :: Maybe Text, - nickName :: Maybe Text, - profileUrl :: Maybe URI, - title :: Maybe Text, - userType :: Maybe Text, - preferredLanguage :: Maybe Text, - locale :: Maybe Text, - active :: Maybe Bool, - password :: Maybe Text, - -- Multi-valued fields - emails :: [Email], - phoneNumbers :: [Phone], - ims :: [IM], - photos :: [Photo], - addresses :: [Address], - entitlements :: [Text], - roles :: [Text], - x509Certificates :: [Certificate], - -- Extra data. - -- - -- During rendering, we'll convert it to JSON; if it's an object we'll merge it with the - -- main user object, if it's @null@ we'll do nothing, otherwise we'll add it under the - -- @"extra"@ field (though you should definitely not rely on this). - -- - -- During parsing, we'll attempt to parse the /whole/ user object as @extra@, so your - -- 'FromJSON' instance should be prepared to ignore unrelated fields. Also keep in mind that - -- the SCIM spec requires field names to be case-insensitive, i.e. if you're looking for a - -- field "foo" you should also handle a field called "FOO". Look at the @FromJSON User@ - -- instance to see how it can be done. - -- - -- FUTUREWORK: make it easy for hscim users to implement a proper parser (with correct - -- rendering of optional and multivalued fields, lowercase objects, etc). - extra :: UserExtra tag - } +data User tag = User + { schemas :: [Schema], + -- Mandatory fields + userName :: Text, + -- Optional fields + externalId :: Maybe Text, + name :: Maybe Name, + displayName :: Maybe Text, + nickName :: Maybe Text, + profileUrl :: Maybe URI, + title :: Maybe Text, + userType :: Maybe Text, + preferredLanguage :: Maybe Text, + locale :: Maybe Text, + active :: Maybe Bool, + password :: Maybe Text, + -- Multi-valued fields + emails :: [Email], + phoneNumbers :: [Phone], + ims :: [IM], + photos :: [Photo], + addresses :: [Address], + entitlements :: [Text], + roles :: [Text], + x509Certificates :: [Certificate], + -- Extra data. + -- + -- During rendering, we'll convert it to JSON; if it's an object we'll merge it with the + -- main user object, if it's @null@ we'll do nothing, otherwise we'll add it under the + -- @"extra"@ field (though you should definitely not rely on this). + -- + -- During parsing, we'll attempt to parse the /whole/ user object as @extra@, so your + -- 'FromJSON' instance should be prepared to ignore unrelated fields. Also keep in mind that + -- the SCIM spec requires field names to be case-insensitive, i.e. if you're looking for a + -- field "foo" you should also handle a field called "FOO". Look at the @FromJSON User@ + -- instance to see how it can be done. + -- + -- FUTUREWORK: make it easy for hscim users to implement a proper parser (with correct + -- rendering of optional and multivalued fields, lowercase objects, etc). + extra :: UserExtra tag + } deriving (Generic) deriving instance Show (UserExtra tag) => Show (User tag) diff --git a/libs/hscim/src/Web/Scim/Schema/User/Address.hs b/libs/hscim/src/Web/Scim/Schema/User/Address.hs index 2dee10060d9..216ec6e61a9 100644 --- a/libs/hscim/src/Web/Scim/Schema/User/Address.hs +++ b/libs/hscim/src/Web/Scim/Schema/User/Address.hs @@ -5,18 +5,17 @@ import Data.Text hiding (dropWhile) import GHC.Generics (Generic) import Web.Scim.Schema.Common -data Address - = Address - { formatted :: Maybe Text, - streetAddress :: Maybe Text, - locality :: Maybe Text, - region :: Maybe Text, - postalCode :: Maybe Text, - -- TODO: country is specified as ISO3166, but example uses "USA" - country :: Maybe Text, - typ :: Maybe Text, - primary :: Maybe Bool - } +data Address = Address + { formatted :: Maybe Text, + streetAddress :: Maybe Text, + locality :: Maybe Text, + region :: Maybe Text, + postalCode :: Maybe Text, + -- TODO: country is specified as ISO3166, but example uses "USA" + country :: Maybe Text, + typ :: Maybe Text, + primary :: Maybe Bool + } deriving (Show, Eq, Generic) instance FromJSON Address where diff --git a/libs/hscim/src/Web/Scim/Schema/User/Certificate.hs b/libs/hscim/src/Web/Scim/Schema/User/Certificate.hs index e05d41f5526..bb83d289710 100644 --- a/libs/hscim/src/Web/Scim/Schema/User/Certificate.hs +++ b/libs/hscim/src/Web/Scim/Schema/User/Certificate.hs @@ -5,11 +5,10 @@ import Data.Text (Text) import GHC.Generics import Web.Scim.Schema.Common -data Certificate - = Certificate - { typ :: Maybe Text, - value :: Maybe Text - } +data Certificate = Certificate + { typ :: Maybe Text, + value :: Maybe Text + } deriving (Show, Eq, Generic) instance FromJSON Certificate where diff --git a/libs/hscim/src/Web/Scim/Schema/User/Email.hs b/libs/hscim/src/Web/Scim/Schema/User/Email.hs index b8a1fd5c489..5bba52843c8 100644 --- a/libs/hscim/src/Web/Scim/Schema/User/Email.hs +++ b/libs/hscim/src/Web/Scim/Schema/User/Email.hs @@ -7,9 +7,8 @@ import GHC.Generics (Generic) import Text.Email.Validate import Web.Scim.Schema.Common -newtype EmailAddress2 - = EmailAddress2 - {unEmailAddress :: EmailAddress} +newtype EmailAddress2 = EmailAddress2 + {unEmailAddress :: EmailAddress} deriving (Show, Eq) instance FromJSON EmailAddress2 where @@ -20,12 +19,11 @@ instance FromJSON EmailAddress2 where instance ToJSON EmailAddress2 where toJSON (EmailAddress2 e) = String $ decodeUtf8 . toByteString $ e -data Email - = Email - { typ :: Maybe Text, - value :: EmailAddress2, - primary :: Maybe Bool - } +data Email = Email + { typ :: Maybe Text, + value :: EmailAddress2, + primary :: Maybe Bool + } deriving (Show, Eq, Generic) instance FromJSON Email where diff --git a/libs/hscim/src/Web/Scim/Schema/User/IM.hs b/libs/hscim/src/Web/Scim/Schema/User/IM.hs index 98ac7575de4..e81585498d4 100644 --- a/libs/hscim/src/Web/Scim/Schema/User/IM.hs +++ b/libs/hscim/src/Web/Scim/Schema/User/IM.hs @@ -5,11 +5,10 @@ import Data.Text (Text) import GHC.Generics import Web.Scim.Schema.Common -data IM - = IM - { typ :: Maybe Text, - value :: Maybe Text - } +data IM = IM + { typ :: Maybe Text, + value :: Maybe Text + } deriving (Show, Eq, Generic) instance FromJSON IM where diff --git a/libs/hscim/src/Web/Scim/Schema/User/Name.hs b/libs/hscim/src/Web/Scim/Schema/User/Name.hs index 060b42b868b..dafc27e4ebe 100644 --- a/libs/hscim/src/Web/Scim/Schema/User/Name.hs +++ b/libs/hscim/src/Web/Scim/Schema/User/Name.hs @@ -5,15 +5,14 @@ import Data.Text (Text) import GHC.Generics import Web.Scim.Schema.Common -data Name - = Name - { formatted :: Maybe Text, - familyName :: Maybe Text, - givenName :: Maybe Text, - middleName :: Maybe Text, - honorificPrefix :: Maybe Text, - honorificSuffix :: Maybe Text - } +data Name = Name + { formatted :: Maybe Text, + familyName :: Maybe Text, + givenName :: Maybe Text, + middleName :: Maybe Text, + honorificPrefix :: Maybe Text, + honorificSuffix :: Maybe Text + } deriving (Show, Eq, Generic) emptyName :: Name diff --git a/libs/hscim/src/Web/Scim/Schema/User/Phone.hs b/libs/hscim/src/Web/Scim/Schema/User/Phone.hs index 4da1c66bb4d..e86eabb4ada 100644 --- a/libs/hscim/src/Web/Scim/Schema/User/Phone.hs +++ b/libs/hscim/src/Web/Scim/Schema/User/Phone.hs @@ -5,11 +5,10 @@ import Data.Text hiding (dropWhile) import GHC.Generics (Generic) import Web.Scim.Schema.Common -data Phone - = Phone - { typ :: Maybe Text, - value :: Maybe Text - } +data Phone = Phone + { typ :: Maybe Text, + value :: Maybe Text + } deriving (Show, Eq, Generic) instance FromJSON Phone where diff --git a/libs/hscim/src/Web/Scim/Schema/User/Photo.hs b/libs/hscim/src/Web/Scim/Schema/User/Photo.hs index 7727798b8bd..7bc9d8a238f 100644 --- a/libs/hscim/src/Web/Scim/Schema/User/Photo.hs +++ b/libs/hscim/src/Web/Scim/Schema/User/Photo.hs @@ -5,11 +5,10 @@ import Data.Text (Text) import GHC.Generics import Web.Scim.Schema.Common -data Photo - = Photo - { typ :: Maybe Text, - value :: Maybe URI - } +data Photo = Photo + { typ :: Maybe Text, + value :: Maybe URI + } deriving (Show, Eq, Generic) instance FromJSON Photo where diff --git a/libs/hscim/src/Web/Scim/Server.hs b/libs/hscim/src/Web/Scim/Server.hs index b54c3326f60..fb90fb6df16 100644 --- a/libs/hscim/src/Web/Scim/Server.hs +++ b/libs/hscim/src/Web/Scim/Server.hs @@ -46,22 +46,21 @@ type GroupAPI tag = ToServantApi (GroupSite tag) type SiteAPI tag = ToServantApi (Site tag) -data Site tag route - = Site - { config :: - route - :- ConfigAPI, - users :: - route - :- Header "Authorization" (AuthData tag) - :> "Users" - :> UserAPI tag, - groups :: - route - :- Header "Authorization" (AuthData tag) - :> "Groups" - :> GroupAPI tag - } +data Site tag route = Site + { config :: + route + :- ConfigAPI, + users :: + route + :- Header "Authorization" (AuthData tag) + :> "Users" + :> UserAPI tag, + groups :: + route + :- Header "Authorization" (AuthData tag) + :> "Groups" + :> GroupAPI tag + } deriving (Generic) ---------------------------------------------------------------------------- diff --git a/libs/hscim/src/Web/Scim/Server/Mock.hs b/libs/hscim/src/Web/Scim/Server/Mock.hs index 7a910cd4984..aad9ad1a9d2 100644 --- a/libs/hscim/src/Web/Scim/Server/Mock.hs +++ b/libs/hscim/src/Web/Scim/Server/Mock.hs @@ -54,11 +54,10 @@ type UserStorage = STMMap.Map Id (StoredUser Mock) type GroupStorage = STMMap.Map Id (StoredGroup Mock) -data TestStorage - = TestStorage - { userDB :: UserStorage, - groupDB :: GroupStorage - } +data TestStorage = TestStorage + { userDB :: UserStorage, + groupDB :: GroupStorage + } emptyTestStorage :: IO TestStorage emptyTestStorage = diff --git a/libs/hscim/src/Web/Scim/Test/Util.hs b/libs/hscim/src/Web/Scim/Test/Util.hs index 43da52b1fcf..30a34a4da82 100644 --- a/libs/hscim/src/Web/Scim/Test/Util.hs +++ b/libs/hscim/src/Web/Scim/Test/Util.hs @@ -82,19 +82,18 @@ shouldEventuallyRespondWith action matcher = (\_ -> pure . either (const True) (const False)) (\_ -> doesRespondWith action matcher) -data AcceptanceConfig tag - = AcceptanceConfig - { scimAppAndConfig :: IO (Application, AcceptanceQueryConfig tag), - genUserName :: IO Text, - -- | some acceptance tests match against a fully rendered - -- response body, which will now work when running the test - -- as a library user (since the response will have more and - -- other information). if you leave this on 'False' (default - -- from 'defAcceptanceConfig'), the test will only check some - -- invariants on the response instead that must hold in all - -- cases. - responsesFullyKnown :: Bool - } +data AcceptanceConfig tag = AcceptanceConfig + { scimAppAndConfig :: IO (Application, AcceptanceQueryConfig tag), + genUserName :: IO Text, + -- | some acceptance tests match against a fully rendered + -- response body, which will now work when running the test + -- as a library user (since the response will have more and + -- other information). if you leave this on 'False' (default + -- from 'defAcceptanceConfig'), the test will only check some + -- invariants on the response instead that must hold in all + -- cases. + responsesFullyKnown :: Bool + } defAcceptanceConfig :: IO Application -> AcceptanceConfig tag defAcceptanceConfig scimApp = AcceptanceConfig {..} @@ -103,11 +102,10 @@ defAcceptanceConfig scimApp = AcceptanceConfig {..} genUserName = ("Test_User_" <>) . UUID.toText <$> UUID.nextRandom responsesFullyKnown = False -data AcceptanceQueryConfig tag - = AcceptanceQueryConfig - { scimPathPrefix :: BS.ByteString, - scimAuthToken :: BS.ByteString - } +data AcceptanceQueryConfig tag = AcceptanceQueryConfig + { scimPathPrefix :: BS.ByteString, + scimAuthToken :: BS.ByteString + } defAcceptanceQueryConfig :: AcceptanceQueryConfig tag defAcceptanceQueryConfig = AcceptanceQueryConfig {..} From 004148b10e39d8b939b4f6311048b6dc5a41bc1f Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Thu, 2 Jul 2020 14:45:38 +0200 Subject: [PATCH 53/64] add missing Swagger models (#1153) They led to errors (and displaying undefined) in swagger-ui. Now there are still 3 cases left where it shows undefined instead of the model, but it seems to be a problem with using returning an array of references like `Doc.returns (Doc.array (Doc.ref Public.modelFoo))`. --- libs/wire-api/src/Wire/API/Swagger.hs | 29 ++++++++++++++++++++++- libs/wire-api/src/Wire/API/User/Client.hs | 2 +- 2 files changed, 29 insertions(+), 2 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Swagger.hs b/libs/wire-api/src/Wire/API/Swagger.hs index 2cd234fe869..3feada1b9db 100644 --- a/libs/wire-api/src/Wire/API/Swagger.hs +++ b/libs/wire-api/src/Wire/API/Swagger.hs @@ -20,6 +20,7 @@ module Wire.API.Swagger where import Data.Swagger.Build.Api (Model) import qualified Wire.API.Call.TURN as Call.TURN import qualified Wire.API.Connection as Connection +import qualified Wire.API.Conversation as Conversation import qualified Wire.API.Conversation.Code as Conversation.Code import qualified Wire.API.Conversation.Member as Conversation.Member import qualified Wire.API.Conversation.Role as Conversation.Role @@ -30,6 +31,7 @@ import qualified Wire.API.Event.Team as Event.Team import qualified Wire.API.Message as Message import qualified Wire.API.Notification as Notification import qualified Wire.API.Properties as Properties +import qualified Wire.API.Provider.Service as Provider.Service import qualified Wire.API.Push.Token as Push.Token import qualified Wire.API.Team as Team import qualified Wire.API.Team.Conversation as Team.Conversation @@ -42,6 +44,8 @@ import qualified Wire.API.User as User import qualified Wire.API.User.Activation as User.Activation import qualified Wire.API.User.Auth as User.Auth import qualified Wire.API.User.Client as User.Client +import qualified Wire.API.User.Client.Prekey as User.Client.Prekey +import qualified Wire.API.User.Handle as User.Handle import qualified Wire.API.User.Password as User.Password import qualified Wire.API.User.Profile as User.Profile import qualified Wire.API.User.RichInfo as User.RichInfo @@ -55,6 +59,16 @@ models = Connection.modelConnection, Connection.modelConnectionRequest, Connection.modelConnectionUpdate, + Conversation.modelConversation, + Conversation.modelConversations, + Conversation.modelConversationIds, + Conversation.modelInvite, + Conversation.modelNewConversation, + Conversation.modelTeamInfo, + Conversation.modelConversationUpdateName, + Conversation.modelConversationAccessUpdate, + Conversation.modelConversationReceiptModeUpdate, + Conversation.modelConversationMessageTimerUpdate, Conversation.Code.modelConversationCode, Conversation.Member.modelConversationMembers, Conversation.Member.modelOtherMember, @@ -95,6 +109,7 @@ models = Notification.modelNotificationList, Properties.modelPropertyValue, Properties.modelPropertyDictionary, + Provider.Service.modelServiceRef, Push.Token.modelPushToken, Push.Token.modelPushTokenList, Team.modelTeam, @@ -111,8 +126,8 @@ models = Team.Invitation.modelTeamInvitationRequest, Team.Member.modelTeamMember, Team.Member.modelTeamMemberList, - Team.Member.modelTeamMemberDelete, Team.Member.modelNewTeamMember, + Team.Member.modelTeamMemberDelete, Team.Permission.modelPermissions, Team.SearchVisibility.modelTeamSearchVisibility, User.modelUserIdList, @@ -139,6 +154,18 @@ models = User.Auth.modelAccessToken, User.Client.modelOtrClientMap, User.Client.modelUserClients, + User.Client.modelNewClient, + User.Client.modelUpdateClient, + User.Client.modelDeleteClient, + User.Client.modelClient, + User.Client.modelSigkeys, + User.Client.modelLocation, -- re-export from types-common + User.Client.modelPubClient, + User.Client.Prekey.modelPrekeyBundle, + User.Client.Prekey.modelClientPrekey, + User.Client.Prekey.modelPrekey, + User.Handle.modelUserHandleInfo, + User.Handle.modelCheckHandles, User.Password.modelNewPasswordReset, User.Password.modelCompletePasswordReset, User.Profile.modelUserDisplayName, diff --git a/libs/wire-api/src/Wire/API/User/Client.hs b/libs/wire-api/src/Wire/API/User/Client.hs index d27c870df71..d9e4ae8bb06 100644 --- a/libs/wire-api/src/Wire/API/User/Client.hs +++ b/libs/wire-api/src/Wire/API/User/Client.hs @@ -53,7 +53,7 @@ module Wire.API.User.Client modelDeleteClient, modelClient, modelSigkeys, - modelLocation, -- re-export + modelLocation, -- re-export from types-common modelPubClient, ) where From fdafba7aea95a259dce48ac92e0a1d0da4f74159 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Thu, 2 Jul 2020 14:54:44 +0200 Subject: [PATCH 54/64] Run backoffice locally (#1148) * add a Back Office tab to swagger-ui * make stern endpoints reachable from UI * add --run-backoffice flag to services-demo * make nginx start even if stern is not there * explain how to run the Back Office locally --- Makefile | 1 + .../conf/nginz/nginx-docker.conf | 42 +++++++++++++++++++ deploy/services-demo/conf/nginz/nginx.conf | 36 ++++++++++++++++ .../services-demo/conf/stern.demo-docker.yaml | 28 +++++++++++++ deploy/services-demo/conf/stern.demo.yaml | 28 +++++++++++++ deploy/services-demo/demo.sh | 22 +++++++--- .../docker-compose-backoffice.yaml | 19 +++++++++ .../backoffice/api-docs/resources.json | 13 ++++++ services/nginz/zwagger-ui/index.html | 4 ++ tools/stern/README.md | 8 ++++ 10 files changed, 196 insertions(+), 5 deletions(-) create mode 100644 deploy/services-demo/conf/stern.demo-docker.yaml create mode 100644 deploy/services-demo/conf/stern.demo.yaml create mode 100644 deploy/services-demo/docker-compose-backoffice.yaml create mode 100644 services/nginz/zwagger-ui/backoffice/api-docs/resources.json diff --git a/Makefile b/Makefile index 95691400531..ee068a23ac7 100644 --- a/Makefile +++ b/Makefile @@ -161,6 +161,7 @@ docker-services: $(MAKE) -C services/cannon docker $(MAKE) -C services/proxy docker $(MAKE) -C services/spar docker + $(MAKE) -C tools/stern docker $(MAKE) docker-exe-zauth $(MAKE) -C services/nginz docker diff --git a/deploy/services-demo/conf/nginz/nginx-docker.conf b/deploy/services-demo/conf/nginz/nginx-docker.conf index 120d6c49e36..770708783ee 100644 --- a/deploy/services-demo/conf/nginz/nginx-docker.conf +++ b/deploy/services-demo/conf/nginz/nginx-docker.conf @@ -101,6 +101,8 @@ http { } + # Docker DNS, required to resolve the references to stern here. + resolver 127.0.0.11; # # Locations @@ -355,6 +357,28 @@ http { proxy_pass http://spar; } + # Stern Endpoints + + # We add a `/stern` suffix to the URL to resolve clashes with non-Stern endpoints. + rewrite ^/backoffice/api-docs/stern /stern/api-docs?base_url=http://127.0.0.1:8080/stern/ break; + + location /stern/api-docs { + include common_response_no_zauth.conf; + # Using a variable instead of plain upstream makes nginx still start up if stern is not there. + # https://sandro-keil.de/blog/let-nginx-start-if-upstream-host-is-unavailable-or-down + set $stern stern:8091; + proxy_pass http://$stern; + } + + location /stern { + include common_response_no_zauth.conf; + # Using a variable instead of plain upstream makes nginx still start up if stern is not there. + # https://sandro-keil.de/blog/let-nginx-start-if-upstream-host-is-unavailable-or-down + set $stern stern:8091; + # The trailing slash matters, as it makes sure the `/stern` prefix is removed. + proxy_pass http://$stern/; + } + # # Swagger Resource Listing # @@ -373,6 +397,24 @@ http { more_set_headers 'Access-Control-Allow-Origin: $http_origin'; } + # + # Back Office Swagger Resource Listing + # + location /backoffice/api-docs { + zauth off; + default_type application/json; + root conf/nginz/zwagger-ui; + index resources.json; + if ($request_method = 'OPTIONS') { + add_header 'Access-Control-Allow-Methods' "GET, POST, PUT, DELETE, OPTIONS"; + add_header 'Access-Control-Allow-Headers' "$http_access_control_request_headers, DNT,X-Mx-ReqToken,Keep-Alive,User-Agent,X-Requested-With,If-Modified-Since,Cache-Control,Content-Type"; + add_header 'Content-Type' 'text/plain; charset=UTF-8'; + add_header 'Content-Length' 0; + return 204; + } + more_set_headers 'Access-Control-Allow-Origin: $http_origin'; + } + # Swagger UI location /swagger-ui { diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index 12d8d569702..f51c3d0f4fd 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -354,6 +354,24 @@ http { proxy_pass http://spar; } + # Stern Endpoints + + # We add a `/stern` suffix to the URL to resolve clashes with non-Stern endpoints. + rewrite ^/backoffice/api-docs/stern /stern/api-docs?base_url=http://127.0.0.1:8080/stern/ break; + + location /stern/api-docs { + include common_response_no_zauth.conf; + # We don't use an `upstream` for stern, since running stern is optional. + proxy_pass http://127.0.0.1:8091; + } + + location /stern { + include common_response_no_zauth.conf; + # We don't use an `upstream` for stern, since running stern is optional. + # The trailing slash matters, as it makes sure the `/stern` prefix is removed. + proxy_pass http://127.0.0.1:8091/; + } + # # Swagger Resource Listing # @@ -372,6 +390,24 @@ http { more_set_headers 'Access-Control-Allow-Origin: $http_origin'; } + # + # Back Office Swagger Resource Listing + # + location /backoffice/api-docs { + zauth off; + default_type application/json; + root conf/nginz/zwagger-ui; + index resources.json; + if ($request_method = 'OPTIONS') { + add_header 'Access-Control-Allow-Methods' "GET, POST, PUT, DELETE, OPTIONS"; + add_header 'Access-Control-Allow-Headers' "$http_access_control_request_headers, DNT,X-Mx-ReqToken,Keep-Alive,User-Agent,X-Requested-With,If-Modified-Since,Cache-Control,Content-Type"; + add_header 'Content-Type' 'text/plain; charset=UTF-8'; + add_header 'Content-Length' 0; + return 204; + } + more_set_headers 'Access-Control-Allow-Origin: $http_origin'; + } + # Swagger UI location /swagger-ui { diff --git a/deploy/services-demo/conf/stern.demo-docker.yaml b/deploy/services-demo/conf/stern.demo-docker.yaml new file mode 100644 index 00000000000..9ddddf4c66b --- /dev/null +++ b/deploy/services-demo/conf/stern.demo-docker.yaml @@ -0,0 +1,28 @@ +stern: + host: stern + port: 8091 + +brig: + host: brig + port: 8082 + +galley: + host: galley + port: 8085 + +gundeck: + host: gundeck + port: 8086 + +# Both ibis and galeb should be made optional for +# installations where these services are not available +galeb: + host: galeb + port: 8089 + +ibis: + host: ibis + port: 8090 + +logLevel: Info +logNetStrings: false diff --git a/deploy/services-demo/conf/stern.demo.yaml b/deploy/services-demo/conf/stern.demo.yaml new file mode 100644 index 00000000000..f9f926e6a6d --- /dev/null +++ b/deploy/services-demo/conf/stern.demo.yaml @@ -0,0 +1,28 @@ +stern: + host: 127.0.0.1 + port: 8091 + +brig: + host: 127.0.0.1 + port: 8082 + +galley: + host: 127.0.0.1 + port: 8085 + +gundeck: + host: 127.0.0.1 + port: 8086 + +# Both ibis and galeb should be made optional for +# installations where these services are not available +galeb: + host: 127.0.0.1 + port: 8089 + +ibis: + host: 127.0.0.1 + port: 8090 + +logLevel: Info +logNetStrings: false diff --git a/deploy/services-demo/demo.sh b/deploy/services-demo/demo.sh index e5957df58c2..7426a541780 100755 --- a/deploy/services-demo/demo.sh +++ b/deploy/services-demo/demo.sh @@ -4,15 +4,19 @@ set -eo pipefail -USAGE="$0 [docker]" -MODE="$1" +USAGE="$0 [docker] [--run-backoffice]" docker_deployment="false" -if [ "$MODE" = "docker" ]; then +if [ "$1" = "docker" ] || [ "$2" = "docker" ] ; then docker_deployment="true" fi +run_backoffice="false" +if [ "$1" = "--run-backoffice" ] || [ "$2" = "--run-backoffice" ] ; then + run_backoffice="true" +fi TOP_LEVEL="$( cd "$( dirname "${BASH_SOURCE[0]}" )/../.." && pwd )" SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" DOCKER_FILE="$SCRIPT_DIR/docker-compose.yaml" +DOCKER_FILE_BACKOFFICE="$SCRIPT_DIR/docker-compose-backoffice.yaml" DIR="${TOP_LEVEL}/services" PARENT_PID=$$ rm -f /tmp/demo.* # remove previous temp files, if any @@ -32,7 +36,7 @@ function list_descendants () { } function kill_gracefully() { - pkill "gundeck|brig|galley|cargohold|cannon|spar" + pkill "gundeck|brig|galley|cargohold|cannon|spar|stern" sleep 1 kill $(list_descendants $PARENT_PID) &> /dev/null } @@ -83,6 +87,7 @@ function check_prerequisites() { && test -f ${DIR}/../dist/cargohold \ && test -f ${DIR}/../dist/proxy \ && test -f ${DIR}/../dist/spar \ + && test -f ${DIR}/../dist/stern \ && test -f ${DIR}/../dist/nginx \ || { echo "Not all services are compiled. How about you run 'cd ${TOP_LEVEL} && make services' first?"; exit 1; } fi @@ -146,9 +151,16 @@ if [ "$docker_deployment" = "false" ]; then run_haskell_service cargohold ${purpleish} run_haskell_service proxy ${redish} run_haskell_service spar ${orange} + if [ "$run_backoffice" = "true" ]; then + run_haskell_service stern ${orange} + fi run_nginz ${blueish} else - docker-compose --file "$DOCKER_FILE" up + if [ "$run_backoffice" = "true" ]; then + docker-compose --file "$DOCKER_FILE" --file "$DOCKER_FILE_BACKOFFICE" up + else + docker-compose --file "$DOCKER_FILE" up + fi fi sleep 3 # wait a moment for services to start before continuing diff --git a/deploy/services-demo/docker-compose-backoffice.yaml b/deploy/services-demo/docker-compose-backoffice.yaml new file mode 100644 index 00000000000..9cf4816468a --- /dev/null +++ b/deploy/services-demo/docker-compose-backoffice.yaml @@ -0,0 +1,19 @@ +networks: + dockerephemeral_demo_wire: + external: true + +version: '2' +services: + stern: + image: quay.io/wire/stern + ports: + - 127.0.0.1:8091:8091 + volumes: + - ./:/configs + entrypoint: + - /usr/bin/stern + - -c + - /configs/conf/stern.demo-docker.yaml + working_dir: /configs + networks: + - dockerephemeral_demo_wire diff --git a/services/nginz/zwagger-ui/backoffice/api-docs/resources.json b/services/nginz/zwagger-ui/backoffice/api-docs/resources.json new file mode 100644 index 00000000000..db64e091275 --- /dev/null +++ b/services/nginz/zwagger-ui/backoffice/api-docs/resources.json @@ -0,0 +1,13 @@ +{ + "Version": "1.0", + "swaggerVersion": "1.2", + "apis": [ + { + "path": "/stern", + "description": "Back Office" + } + ], + "info": { + "description": "The Back Office can only be used if Stern is running. It usually shouldn't be running, and if it is, make sure it can only be reached by admins, as it allows unauthorized access to endpoints. For more details see `tools/stern/README.md` in the `wire-server` repository." + } +} diff --git a/services/nginz/zwagger-ui/index.html b/services/nginz/zwagger-ui/index.html index 1b00bd67b37..d721260080b 100644 --- a/services/nginz/zwagger-ui/index.html +++ b/services/nginz/zwagger-ui/index.html @@ -43,6 +43,8 @@
+ +
@@ -52,6 +54,8 @@ +