servant-auth-cookie 0.1.0.1 → 0.3.0.0
raw patch · 6 files changed
+927/−1069 lines, 6 filesdep +QuickCheckdep +blaze-builderdep +criteriondep ~basedep ~blaze-htmldep ~blaze-markup
Dependencies added: QuickCheck, blaze-builder, criterion, data-default, deepseq, exceptions, hspec, servant-blaze, tagged
Dependency ranges changed: base, blaze-html, blaze-markup, cereal, cookie, cryptonite, http-types, memory, mtl, servant, servant-server, time, transformers, wai, warp
Files
- LICENSE +24/−668
- benchmarks/Main.hs +54/−0
- example/Main.hs +93/−123
- servant-auth-cookie.cabal +89/−26
- src/Servant/Server/Experimental/Auth/Cookie.hs +418/−252
- tests/Main.hs +249/−0
LICENSE view
@@ -1,674 +1,30 @@- GNU GENERAL PUBLIC LICENSE- Version 3, 29 June 2007-- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>- Everyone is permitted to copy and distribute verbatim copies- of this license document, but changing it is not allowed.-- Preamble-- The GNU General Public License is a free, copyleft license for-software and other kinds of works.-- The licenses for most software and other practical works are designed-to take away your freedom to share and change the works. By contrast,-the GNU General Public License is 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. We, the Free Software Foundation, use the-GNU General Public License for most of our software; it applies also to-any other work released this way by its authors. You can apply it to-your programs, too.-- 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.-- To protect your rights, we need to prevent others from denying you-these rights or asking you to surrender the rights. Therefore, you have-certain responsibilities if you distribute copies of the software, or if-you modify it: responsibilities to respect the freedom of others.-- For example, if you distribute copies of such a program, whether-gratis or for a fee, you must pass on to the recipients the same-freedoms that you received. You must make sure that they, too, receive-or can get the source code. And you must show them these terms so they-know their rights.-- Developers that use the GNU GPL protect your rights with two steps:-(1) assert copyright on the software, and (2) offer you this License-giving you legal permission to copy, distribute and/or modify it.-- For the developers' and authors' protection, the GPL clearly explains-that there is no warranty for this free software. For both users' and-authors' sake, the GPL requires that modified versions be marked as-changed, so that their problems will not be attributed erroneously to-authors of previous versions.-- Some devices are designed to deny users access to install or run-modified versions of the software inside them, although the manufacturer-can do so. This is fundamentally incompatible with the aim of-protecting users' freedom to change the software. The systematic-pattern of such abuse occurs in the area of products for individuals to-use, which is precisely where it is most unacceptable. Therefore, we-have designed this version of the GPL to prohibit the practice for those-products. If such problems arise substantially in other domains, we-stand ready to extend this provision to those domains in future versions-of the GPL, as needed to protect the freedom of users.-- Finally, every program is threatened constantly by software patents.-States should not allow patents to restrict development and use of-software on general-purpose computers, but in those that do, we wish to-avoid the special danger that patents applied to a free program could-make it effectively proprietary. To prevent this, the GPL assures that-patents cannot be used to render the program non-free.-- 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 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. Use with the GNU Affero General Public License.-- 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 Affero 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 special requirements of the GNU Affero General Public License,-section 13, concerning interaction through a network will apply to the-combination as such.-- 14. Revised Versions of this License.-- The Free Software Foundation may publish revised and/or new versions of-the GNU 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 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 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 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.-- <one line to give the program's name and a brief idea of what it does.>- Copyright (C) <year> <name of author>-- This program is free software: you can redistribute it and/or modify- it under the terms of the GNU 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 General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program. If not, see <http://www.gnu.org/licenses/>.+Copyright (c) 2016, Al Zohali -Also add information on how to contact you by electronic and paper mail.+All rights reserved. - If the program does terminal interaction, make it output a short-notice like this when it starts in an interactive mode:+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met: - <program> Copyright (C) <year> <name of author>- This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.- This is free software, and you are welcome to redistribute it- under certain conditions; type `show c' for details.+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer. -The hypothetical commands `show w' and `show c' should show the appropriate-parts of the General Public License. Of course, your program's commands-might be different; for a GUI interface, you would use an "about box".+ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution. - 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 GPL, see-<http://www.gnu.org/licenses/>.+ * Neither the name of Al Zohali nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission. - The GNU General Public License does not permit incorporating your program-into proprietary programs. If your program is a subroutine library, you-may consider it more useful to permit linking proprietary applications with-the library. If this is what you want to do, use the GNU Lesser General-Public License instead of this License. But first, please read-<http://www.gnu.org/philosophy/why-not-lgpl.html>.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ benchmarks/Main.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ExistentialQuantification #-}++import Servant.Server.Experimental.Auth.Cookie.Internal++import Crypto.Random (drgNew, DRG, getSystemDRG)+import Data.ByteString (ByteString)+import Control.Monad (when)++import Criterion (Benchmark, bench, nfIO)+import Criterion.Main (bgroup, defaultMain)+++data DRGInit = forall d. (DRG d) => MkDRGInit (IO d)+mkDRGInit :: (DRG d) => IO d -> DRGInit+mkDRGInit = MkDRGInit+++benchRandomSource :: [Benchmark]+benchRandomSource = [ mkBenchmark name drg size | (name, drg) <- drgs, size <- sizes] where++ sizes :: [Int]+ sizes = [+ 2000+ -- , 4000+ -- , 8000+ ]++ drgs :: [(String, DRGInit)]+ drgs = [+ ("ChaCha", mkDRGInit drgNew)+ -- , ("System", mkDRGInit getSystemDRG)+ ]++ mkBenchmark :: String -> DRGInit -> Int -> Benchmark+ mkBenchmark name (MkDRGInit drg) size = bench+ (name ++ "_" ++ (show size))+ (nfIO $ mkRandomSource drg size >>= drainRandomSource 16 1000)++ drainRandomSource :: (DRG d) => Int -> Int -> RandomSource d -> IO ()+ drainRandomSource chunkSize iterNum rs = step iterNum Nothing where+ step :: Int -> Maybe ByteString -> IO ()+ step 0 _ = return ()+ step n ms = do+ s' <- getRandomBytes rs chunkSize+ when (maybe False id $ ((== s') <$> ms)) $ error "RandomSource produced the same output"+ step (n-1) (Just s')+++main :: IO ()+main = defaultMain [+ bgroup "RandomSource" benchRandomSource+ ]++
example/Main.hs view
@@ -1,186 +1,157 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} -import Control.Monad (when)+module Main (main) where -import Data.Maybe (fromJust, isNothing)-import Data.Serialize (Serialize)-import qualified Data.Text as T (unpack)+import Control.Monad+import Crypto.Random (drgNew) import Data.ByteString (ByteString)-import Data.ByteString.Lazy (toStrict, fromStrict)--import Servant (- Proxy(..), Server, (:>), (:<|>)(..)- , Header, Headers, addHeader- , Get, Post, ReqBody, FormUrlEncoded, FromFormUrlEncoded(..))--import Servant.Server (- Context ((:.), EmptyContext)- , serveWithContext)--import Servant.API.Experimental.Auth (AuthProtect)-import Servant.API.ContentTypes (Accept(..), MimeRender(..))+import Data.Default+import Data.List (find)+import Data.Serialize (Serialize)+import GHC.Generics+import Network.Wai (Application, Request)+import Network.Wai.Handler.Warp (run)+import Servant+import Servant.HTML.Blaze import Servant.Server.Experimental.Auth (AuthHandler) import Servant.Server.Experimental.Auth.Cookie--import Network.Wai (Application, Request)-import Network.Wai.Handler.Warp (run)--import GHC.Generics--import Network.HTTP.Media ((//), (/:))--import Text.Blaze.Html5 ((!))-import Text.Blaze.Html.Renderer.Utf8 (renderHtml)+import Text.Blaze.Html5 ((!), Markup)+import qualified Data.Text as T import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A --data HTML--instance Accept HTML where- contentType _ = "text" // "html" /: ("charset", "utf-8")--instance MimeRender HTML ByteString where- mimeRender _ x = fromStrict $ x-+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif -data Account = Account Int String String- deriving (Show, Eq, Generic)+data Account = Account+ { accUid :: Int+ , _accUsername :: String+ , _accPassword :: String+ } deriving (Show, Eq, Generic) instance Serialize Account type instance AuthCookieData = Account- -data LoginForm = LoginForm {- username :: String -, password :: String-} deriving (Eq, Show)+data LoginForm = LoginForm+ { lfUsername :: String+ , lfPassword :: String+ } deriving (Eq, Show) instance FromFormUrlEncoded LoginForm where fromFormUrlEncoded d = do- let username' = lookup "username" d- when (isNothing username') $ Left "username field is missing"-- let password' = lookup "password" d- when (isNothing username') $ Left "password field is missing"-- Right $ LoginForm {- username = T.unpack . fromJust $ username'- , password = T.unpack . fromJust $ password'- }-+ username <- case lookup "username" d of+ Nothing -> Left "username field is missing"+ Just x -> return (T.unpack x)+ password <- case lookup "password" d of+ Nothing -> Left "password field is missing"+ Just x -> return (T.unpack x)+ return LoginForm+ { lfUsername = username+ , lfPassword = password } usersDB :: [Account]-usersDB = [- Account 101 "mr_foo" "password1"+usersDB =+ [ Account 101 "mr_foo" "password1" , Account 102 "mr_bar" "letmein"- , Account 103 "mr_baz" "baseball" - ]+ , Account 103 "mr_baz" "baseball" ] userLookup :: String -> String -> [Account] -> Maybe Int-userLookup _ _ [] = Nothing-userLookup username' password' ((Account uid username'' password''):as) =- case (username', password') == (username'', password'') of- True -> Just uid- False -> userLookup username' password' as-+userLookup username password db = accUid <$> find f db+ where f (Account _ u p) = u == username && p == password type ExampleAPI =- Get '[HTML] ByteString- :<|> "login" :> Get '[HTML] ByteString+ Get '[HTML] Markup+ :<|> "login" :> Get '[HTML] Markup :<|> "login" :> ReqBody '[FormUrlEncoded] LoginForm- :> Post '[HTML] (Headers '[Header "set-cookie" ByteString] ByteString)- :<|> "private" :> AuthProtect "cookie-auth" :> Get '[HTML] ByteString-+ :> Post '[HTML] (Headers '[Header "set-cookie" ByteString] Markup)+ :<|> "private" :> AuthProtect "cookie-auth" :> Get '[HTML] Markup -server :: Server ExampleAPI-server = serveHome+server :: AuthCookieSettings -> RandomSource -> ServerKey -> Server ExampleAPI+server settings rs sk = serveHome :<|> serveLogin :<|> serveLoginPost :<|> servePrivate where - serveHome = return $ render homePage- serveLogin = return $ render $ loginPage True-- serveLoginPost form = case userLookup (username form) (password form) usersDB of- Nothing -> return $ addHeader "" (render $ loginPage False)- Just uid' -> addSession - authSettings- (Account uid' (username form) (password form))- (render $ redirectPage "/private")-- servePrivate (Account uid u p) = return $ render (privatePage uid u p)-- render = toStrict . renderHtml+ serveHome = return homePage+ serveLogin = return (loginPage True) + serveLoginPost LoginForm {..} =+ case userLookup lfUsername lfPassword usersDB of+ Nothing -> return $ addHeader "" (loginPage False)+ Just uid -> addSession+ settings -- the settings+ rs -- random source+ sk -- server key+ (Account uid lfUsername lfPassword)+ (redirectPage "/private") -authSettings :: Settings-authSettings = defaultSettings {- cookieFlags = []- , hideReason = False- }+ servePrivate (Account uid u p) = return (privatePage uid u p) -app :: Application-app = serveWithContext+app :: AuthCookieSettings -> RandomSource -> ServerKey -> Application+app settings rs sk = serveWithContext (Proxy :: Proxy ExampleAPI)- ((defaultAuthHandler authSettings :: AuthHandler Request Account) :. EmptyContext)- server+ ((defaultAuthHandler settings sk :: AuthHandler Request Account) :. EmptyContext)+ (server settings rs sk) main :: IO ()-main = run 8080 app - +main = do+ rs <- mkRandomSource drgNew 1000+ sk <- mkServerKey 16 Nothing+ run 8080 (app def rs sk) -pageMenu :: H.Html+pageMenu :: Markup pageMenu = do H.a ! A.href "/" $ "home"- _ <- " "+ void " " H.a ! A.href "/login" $ "login"- _ <- " "+ void " " H.a ! A.href "/private" $ "private" H.hr --homePage :: H.Html+homePage :: Markup homePage = H.docTypeHtml $ do- H.head $ do- H.title "home"+ H.head (H.title "home") H.body $ do pageMenu H.p "This is an example of using servant-auth-cookie library." H.p "Use login page to get access to the private page." --loginPage :: Bool -> H.Html+loginPage :: Bool -> Markup loginPage firstTime = H.docTypeHtml $ do- H.head $ do- H.title "login"+ H.head (H.title "login") H.body $ do pageMenu H.form ! A.method "post" ! A.action "/login" $ do- H.input ! A.type_ "text" ! A.name "username" >> H.br- H.input ! A.type_ "password" ! A.name "password" >> H.br+ H.table $ do+ H.tr $ do+ H.td "username:"+ H.td (H.input ! A.type_ "text" ! A.name "username")+ H.tr $ do+ H.td "password:"+ H.td (H.input ! A.type_ "password" ! A.name "password") H.input ! A.type_ "submit"- when (not firstTime) $ H.p "Incorrect username/password"-+ unless firstTime $+ H.p "Incorrect username/password" -privatePage :: Int -> String -> String -> H.Html+privatePage :: Int -> String -> String -> Markup privatePage uid username' password' = H.docTypeHtml $ do- H.head $ do- H.title "private"+ H.head (H.title "private") H.body $ do pageMenu H.p $ H.b "ID: " >> H.toHtml (show uid) H.p $ H.b "username: " >> H.toHtml username' H.p $ H.b "password: " >> H.toHtml password' --redirectPage :: String -> H.Html+redirectPage :: String -> Markup redirectPage uri = H.docTypeHtml $ do H.head $ do H.title "redirecting..."@@ -188,6 +159,5 @@ H.body $ do H.p "You are being redirected." H.p $ do- "If your browser does not refresh the page click "+ void "If your browser does not refresh the page click " H.a ! A.href (H.toValue uri) $ "here"-
servant-auth-cookie.cabal view
@@ -1,58 +1,121 @@ name: servant-auth-cookie-version: 0.1.0.1+version: 0.3.0.0 synopsis: Authentication via encrypted cookies description: Authentication via encrypted client-side cookies, inspired by client-session library by Michael Snoyman and based on ideas of the paper "A Secure Cookie Protocol" by Alex Liu et al.-license: GPL-3+license: BSD3 license-file: LICENSE author: Al Zohali maintainer: Al Zohali <zohl@fmap.me>+copyright: Al Zohali <zohl@fmap.me>, Mark Karpov <markkarpov@opmbx.org> category: Web build-type: Simple cabal-version: >=1.10 - source-repository head type: git location: https://github.com/zohl/servant-auth-cookie.git +flag dev+ description: Turn on development settings.+ manual: True+ default: False library- exposed-modules: + exposed-modules: Servant.Server.Experimental.Auth.Cookie- build-depends: base == 4.9.*++ build-depends: base >= 4.7 && < 5.0 , base64-bytestring+ , blaze-builder >= 0.4 && < 0.4.1 , bytestring- , cereal- , cookie- , cryptonite- , http-types- , memory- , servant- , servant-server- , time- , transformers- , wai+ , cereal >= 0.5 && < 0.6+ , cookie >= 0.4.1 && < 0.5+ , cryptonite >= 0.14 && < 0.18+ , data-default+ , exceptions >= 0.8 && < 0.9+ , http-types >= 0.9 && < 0.10+ , memory >= 0.11 && < 0.14+ , mtl >= 2.0 && < 3.0+ , servant >= 0.5 && < 0.9+ , servant-server >= 0.5 && < 0.9+ , time >= 1.5 && < 1.7+ , transformers >= 0.4 && < 0.6+ , wai >= 3.0 && < 3.3+ if !impl(ghc >= 7.8)+ build-depends: tagged == 0.8.*+ if flag(dev)+ ghc-options: -Wall -Werror+ else+ ghc-options: -O2 -Wall hs-source-dirs: src default-language: Haskell2010 - executable example main-is: Main.hs- other-extensions: DataKinds, TypeFamilies, DeriveGeneric, TypeOperators- build-depends: base == 4.9.*- , blaze-html- , blaze-markup+ build-depends: base >= 4.7 && < 5.0+ , blaze-html >= 0.8 && < 0.9+ , blaze-markup >= 0.7 && < 0.8 , bytestring- , cereal- , mtl+ , cereal >= 0.5 && < 0.6+ , cryptonite >= 0.14 && < 0.18+ , data-default , http-media- , servant+ , mtl >= 2.0 && < 3.0+ , servant >= 0.5 && < 0.9 , servant-auth-cookie- , servant-server+ , servant-blaze >= 0.5 && < 0.9+ , servant-server >= 0.5 && < 0.9 , text- , wai- , warp+ , wai >= 3.0 && < 3.3+ , warp >= 3.0 && < 3.3+ if flag(dev)+ ghc-options: -Wall -Werror+ else+ ghc-options: -O2 -Wall hs-source-dirs: example default-language: Haskell2010++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Main.hs+ if flag(dev)+ ghc-options: -Wall -Werror+ else+ ghc-options: -O2 -Wall++ build-depends: base >= 4.7 && < 5.0+ , QuickCheck >= 2.4 && < 3.0+ , bytestring+ , cereal >= 0.5 && < 0.6+ , cryptonite >= 0.14 && < 0.18+ , data-default+ , deepseq >= 1.3 && < 1.5+ , hspec >= 2.0 && < 3.0+ , servant-auth-cookie+ , servant-server >= 0.5 && < 0.9+ , time >= 1.5 && < 1.7+ if !impl(ghc >= 7.8)+ build-depends: tagged == 0.8.*+ default-language: Haskell2010++benchmark bench+ type: exitcode-stdio-1.0++ hs-source-dirs: benchmarks+ main-is: Main.hs++ default-language: Haskell2010++ build-depends: base >= 4.7 && < 5.0+ , bytestring+ , criterion >= 0.6.2.1 && < 1.2+ , cryptonite >= 0.14 && < 0.18+ , servant-auth-cookie+ , servant-server >= 0.5 && < 0.9+ if flag(dev)+ ghc-options: -Wall -Werror+ else+ ghc-options: -O2 -Wall
src/Servant/Server/Experimental/Auth/Cookie.hs view
@@ -1,19 +1,45 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PartialTypeSignatures #-}+{-|+ Module: Servant.Server.Experimental.Auth.Cookie+ Copyright: (c) 2016 Al Zohali+ License: BSD3+ Maintainer: Al Zohali <zohl@fmap.me>+ Stability: experimental + = Description -module Servant.Server.Experimental.Auth.Cookie (- AuthCookieData- , Cookie(..)+ Authentication via encrypted client-side cookies, inspired by+ client-session library by Michael Snoyman and based on ideas of the+ paper \"A Secure Cookie Protocol\" by Alex Liu et al.+-} - , Settings(..)- , defaultSettings+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-} +module Servant.Server.Experimental.Auth.Cookie+ ( CipherAlgorithm+ , AuthCookieData+ , Cookie (..)+ , AuthCookieException (..)++ , RandomSource+ , mkRandomSource+ , getRandomBytes++ , ServerKey+ , mkServerKey+ , getServerKey++ , AuthCookieSettings (..)+ , encryptCookie , decryptCookie @@ -24,285 +50,425 @@ , getSession , defaultAuthHandler- ) where -+ ) where -import Control.Monad.IO.Class-import Control.Monad (when) -import Control.Concurrent-import Data.Either (isLeft)-import Data.Maybe (fromMaybe, fromJust, isNothing)+import Blaze.ByteString.Builder (toByteString)+import Control.Monad+import Control.Monad.Catch (MonadThrow (..), Exception)+import Control.Monad.Except+import Crypto.Cipher.AES (AES256)+import Crypto.Cipher.Types+import Crypto.Error+import Crypto.Hash (HashAlgorithm(..))+import Crypto.Hash.Algorithms (SHA256)+import Crypto.MAC.HMAC (HMAC)+import Crypto.Random (drgNew, DRG(..))+import Data.ByteString (ByteString)+import Data.Default import Data.IORef-+import Data.Maybe (fromMaybe, isNothing)+import Data.Monoid ((<>))+import Data.Proxy+import Data.Serialize+import Data.Time+import Data.Typeable import GHC.TypeLits (Symbol)--import Data.ByteString (ByteString)-import Data.ByteString.Lazy (toStrict, fromStrict)-import Data.ByteString.Lazy.Builder (toLazyByteString)--import qualified Data.ByteArray as BA-import qualified Data.ByteString as BS (length, splitAt, concat, pack)-import qualified Data.ByteString.Base64 as Base64 (encode, decode)-import qualified Data.ByteString.Char8 as BS8-- -import Data.Serialize (Serialize, put, get)-import Data.Serialize.Put (runPut)-import Data.Serialize.Get (runGet)--import Data.Time.Clock (UTCTime, getCurrentTime, addUTCTime)-import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM)--import Network.HTTP.Types.Header (hCookie)-import Network.Wai (Request, requestHeaders)-import Servant (throwError)-import Servant (addHeader)-import Servant.API.Experimental.Auth (AuthProtect)-import Servant.API.ResponseHeaders (AddHeader)-import Servant.Server (err403, errBody, Handler)-import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler)---import Web.Cookie (parseCookies, renderCookies)--import Crypto.Cipher.AES (AES256)-import Crypto.Cipher.Types (ctrCombine, IV, makeIV, Cipher(..), BlockCipher(..))-import Crypto.Error (maybeCryptoError)-import Crypto.Hash (HashAlgorithm(..))-import Crypto.Hash.Algorithms (SHA256)-import Crypto.MAC.HMAC (HMAC)-import qualified Crypto.MAC.HMAC as H (hmac)-import Crypto.Random (drgNew, DRG(..))--import System.IO.Unsafe (unsafePerformIO)-------resetRef :: IORef a -> IO a -> IO ()-resetRef ref f = (forkIO $ f >>= atomicWriteIORef ref) >> return ()---data RandomSource m where- RandomSource :: (DRG a) => a -> Int -> RandomSource a--rsThreshold :: Int-rsThreshold = ivSize * 1024--mkRandomSource :: IO (RandomSource _)-mkRandomSource = RandomSource <$> drgNew <*> return 0--rsRef :: IORef (RandomSource _)-rsRef = unsafePerformIO $ mkRandomSource >>= newIORef-{-# NOINLINE rsRef #-} --getRandomBytes :: Int -> IO ByteString-getRandomBytes n = do- (result, bytes) <- atomicModifyIORef rsRef $ \(RandomSource drg bytes) -> let- (result, drg') = randomBytesGenerate n drg- bytes' = bytes + n- in (RandomSource drg' (bytes + n), (result, bytes')) -- when (bytes >= rsThreshold) $ resetRef rsRef mkRandomSource-- return $! result---data ServerKey = ServerKey ByteString UTCTime--skThreshold :: Int-skThreshold = 60 * 60 * 24--skLength :: Int-skLength = 16--mkServerKey :: IO ServerKey-mkServerKey = ServerKey- <$> (fst . randomBytesGenerate skLength <$> drgNew)- <*> (addUTCTime (fromIntegral skThreshold) <$> getCurrentTime)--skRef :: IORef ServerKey-skRef = unsafePerformIO $ mkServerKey >>= newIORef-{-# NOINLINE skRef #-} --getServerKey :: IO ByteString-getServerKey = do- (ServerKey key time) <- readIORef skRef- currentTime <- getCurrentTime-- when (time < currentTime) $ resetRef skRef mkServerKey-- return $! key---data Cookie = Cookie {- iv :: ByteString- , expiration :: UTCTime- , payload :: ByteString- }--expirationFormat :: String-expirationFormat = "%0Y%m%d%H%M%S"---ivSize :: Int-expirationSize :: Int-macSize :: Int+import Network.HTTP.Types (hCookie)+import Network.Wai (Request, requestHeaders)+import Servant (addHeader)+import Servant.API.Experimental.Auth (AuthProtect)+import Servant.API.ResponseHeaders (AddHeader)+import Servant.Server (err403)+import Servant.Server.Experimental.Auth+import Web.Cookie+import qualified Crypto.MAC.HMAC as H+import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Char8 as BSC8 -[ivSize, expirationSize, macSize] = [- blockSize (undefined::AES256)- , 14- , hashDigestSize (undefined::SHA256)- ]+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif +----------------------------------------------------------------------------+-- General types -hmac :: ByteString -> ByteString -> ByteString-hmac key msg = (BS.pack . BA.unpack) ((H.hmac key msg) :: HMAC SHA256)+-- | A type for encryption and decryption functions operating on 'ByteString's.+type CipherAlgorithm c = c -> IV c -> ByteString -> ByteString -aes :: ByteString -> ByteString -> ByteString -> ByteString-aes iv key msg = (BS.pack . BA.unpack) (ctrCombine key' iv' msg) where- iv' = (fromMaybe (error "bad IV") (makeIV iv)) :: IV AES256- key' = (fromMaybe (error "bad key") (maybeCryptoError $ cipherInit key)) :: AES256+-- | A type family that maps user-defined data to 'AuthServerData'.+type family AuthCookieData+type instance AuthServerData (AuthProtect "cookie-auth") = AuthCookieData -splitMany :: (Int -> a -> (a, a)) -> [Int] -> a -> [a]-splitMany _ [] s = [s]-splitMany f (x:xs) s = let (chunk, rest) = f x s in chunk:(splitMany f xs rest)+-- | Cookie representation.+data Cookie = Cookie+ { cookieIV :: ByteString -- ^ The initialization vector+ , cookieExpirationTime :: UTCTime -- ^ The cookie's expiration time+ , cookiePayload :: ByteString -- ^ The payload+ } deriving (Eq, Show) - --- | Encrypt given cookie with server key-encryptCookie :: ByteString -> Cookie -> ByteString-encryptCookie serverKey cookie = BS.concat [iv', expiration', payload', mac] where- iv' = iv cookie - expiration' = BS8.pack . formatTime defaultTimeLocale expirationFormat $ expiration cookie- key = hmac serverKey $ BS.concat [iv', expiration']- payload' = aes iv' key (payload cookie)- mac = hmac serverKey $ BS.concat [iv', expiration', payload']+-- | The exception is thrown when something goes wrong with this package. --- | Decrypt cookie from bytestring-decryptCookie :: ByteString -> UTCTime -> ByteString -> Either String Cookie-decryptCookie serverKey currentTime s = do- let [iv', expiration', payload', mac'] = splitMany BS.splitAt [- ivSize- , expirationSize- , (BS.length s) - ivSize - expirationSize - macSize] s+data AuthCookieException+ = CannotMakeIV ByteString+ -- ^ Could not make 'IV' for block cipher.+ | BadProperKey CryptoError+ -- ^ Could not initialize a cipher context.+ | TooShortProperKey Int Int+ -- ^ The key is too short for current cipher algorithm. Arguments of+ -- this constructor: minimal key length, actual key length.+ | IncorrectMAC ByteString+ -- ^ Thrown when Message Authentication Code (MAC) is not correct.+ | CannotParseExpirationTime ByteString+ -- ^ Thrown when expiration time cannot be parsed.+ | CookieExpired UTCTime UTCTime+ -- ^ Thrown when 'Cookie' has expired. Arguments of the constructor:+ -- expiration time, actual time.+ | SessionDeserializationFailed String+ -- ^ This is thrown when 'runGet' or 'Base64.decode' blows up.+ deriving (Eq, Show, Typeable) - when (mac' /= (hmac serverKey $ BS.concat [iv', expiration', payload'])) $ Left "MAC failed"+instance Exception AuthCookieException - let parsedTime = parseTimeM True defaultTimeLocale expirationFormat $ BS8.unpack expiration'- when (isNothing parsedTime) $ Left "Wrong time format"+----------------------------------------------------------------------------+-- Random source - let expiration'' = fromJust parsedTime- when (currentTime >= expiration'') $ Left "Expired cookie"+-- | A wrapper of self-resetting 'DRG' suitable for concurrent usage.+data RandomSource where+ RandomSource :: DRG d => IO d -> Int -> IORef (d, Int) -> RandomSource - let key = hmac serverKey $ BS.concat [iv', expiration']+-- | Constructor for 'RandomSource' value.+mkRandomSource :: (MonadIO m, DRG d)+ => IO d -- ^ How to get deterministic random generator+ -> Int -- ^ Threshold (number of bytes to be generated before resetting)+ -> m RandomSource -- ^ New 'RandomSource' value+mkRandomSource mkDRG threshold =+ RandomSource mkDRG threshold `liftM` liftIO ((,0) <$> mkDRG >>= newIORef) - Right Cookie {- iv = iv'- , expiration = expiration''- , payload = aes iv' key payload'- }+-- | Extract pseudo-random bytes from 'RandomSource'.+getRandomBytes :: MonadIO m+ => RandomSource -- ^ The source of random numbers+ -> Int -- ^ How many random bytes to generate+ -> m ByteString -- ^ The generated bytes in form of a 'ByteString'+getRandomBytes (RandomSource mkDRG threshold ref) n = do+ freshDRG <- liftIO mkDRG+ liftIO . atomicModifyIORef' ref $ \(drg, bytes) ->+ let (result, drg') = randomBytesGenerate n drg+ bytes' = bytes + n+ in if bytes' >= threshold+ then ((freshDRG, 0), result)+ else ((drg', bytes'), result) +----------------------------------------------------------------------------+-- Server key --- | Pack session object into a cookie-encryptSession :: (Serialize a) => Int -> a -> IO ByteString-encryptSession maxAge session = do- iv' <- getRandomBytes 16- expiration' <- addUTCTime (fromIntegral maxAge) <$> getCurrentTime- serverKey <- getServerKey +-- | A wrapper of self-resetting 'ByteString' of random symbols suitable for+-- concurrent usage.+data ServerKey =+ ServerKey Int (Maybe NominalDiffTime) (IORef (ByteString, UTCTime)) - return $ Base64.encode $ encryptCookie serverKey Cookie {- iv = iv' - , expiration = expiration'- , payload = (runPut $ put session)- }+-- | Constructor for 'ServerKey' value.+mkServerKey :: MonadIO m+ => Int -- ^ Size of the server key+ -> Maybe NominalDiffTime -- ^ Expiration time ('Nothing' is eternity)+ -> m ServerKey -- ^ New 'ServerKey'+mkServerKey size maxAge =+ ServerKey size maxAge `liftM` liftIO (mkServerKeyState size maxAge >>= newIORef) --- | Unpack session object from a cookie-decryptSession :: (Serialize a) => ByteString -> IO (Either String a)-decryptSession s = do- currentTime <- getCurrentTime - serverKey <- getServerKey- return $ (Base64.decode s) >>= (decryptCookie serverKey currentTime) >>= (runGet get . payload)+-- | Extract value from 'ServerKey'.+getServerKey :: MonadIO m+ => ServerKey -- ^ The 'ServerKey'+ -> m ByteString -- ^ Its random symbol+getServerKey (ServerKey size maxAge ref) = do+ currentTime <- liftIO getCurrentTime+ (key', expirationTime') <- mkServerKeyState size maxAge+ liftIO . atomicModifyIORef' ref $ \(key, expirationTime) ->+ let expired =+ if isNothing maxAge+ then False+ else currentTime > expirationTime+ in if expired+ then ((key', expirationTime'), key')+ else ((key, expirationTime), key) +-- | An initializer of 'ServerKey' state.+mkServerKeyState :: MonadIO m+ => Int -- ^ Size of the server key+ -> Maybe NominalDiffTime -- ^ Expiration time ('Nothing' is eternity)+ -> m (ByteString, UTCTime)+mkServerKeyState size maxAge = liftIO $ do+ key <- fst . randomBytesGenerate size <$> drgNew+ time <- addUTCTime (fromMaybe 0 maxAge) <$> getCurrentTime+ return (key, time) +----------------------------------------------------------------------------+-- Settings +-- | Options that determine authentication mechanisms. Use 'def' to get+-- default value of this type. -data Settings = Settings {- sessionField :: ByteString- -- ^ Name of a cookie which stores session object+data AuthCookieSettings where+ AuthCookieSettings :: (HashAlgorithm h, BlockCipher c) =>+ { acsSessionField :: ByteString+ -- ^ Name of a cookie which stores session object+ , acsCookieFlags :: [ByteString]+ -- ^ Session cookie's flags+ , acsMaxAge :: NominalDiffTime+ -- ^ For how long the cookie will be valid (corresponds to “Max-Age”+ -- attribute).+ , acsExpirationFormat :: String+ -- ^ Expiration format as in 'formatTime'.+ , acsPath :: ByteString+ -- ^ Scope of the cookie (corresponds to “Path” attribute).+ , acsHashAlgorithm :: Proxy h+ -- ^ Hash algorithm that will be used in 'hmac'.+ , acsCipher :: Proxy c+ -- ^ Symmetric cipher that will be used in encryption.+ , acsEncryptAlgorithm :: CipherAlgorithm c+ -- ^ Algorithm to encrypt cookies.+ , acsDecryptAlgorithm :: CipherAlgorithm c+ -- ^ Algorithm to decrypt cookies.+ } -> AuthCookieSettings - , cookieFlags :: [ByteString]- -- ^ Session cookie's flags+instance Default AuthCookieSettings where+ def = AuthCookieSettings+ { acsSessionField = "Session"+ , acsCookieFlags = ["HttpOnly", "Secure"]+ , acsMaxAge = fromIntegral (12 * 3600 :: Integer) -- 12 hours+ , acsExpirationFormat = "%0Y%m%d%H%M%S"+ , acsPath = "/"+ , acsHashAlgorithm = Proxy :: Proxy SHA256+ , acsCipher = Proxy :: Proxy AES256+ , acsEncryptAlgorithm = ctrCombine+ , acsDecryptAlgorithm = ctrCombine } - , maxAge :: Int- -- ^ How much time (in seconds) the cookie will be valid- -- (corresponds to Max-Age attribute)+----------------------------------------------------------------------------+-- Encrypt/decrypt cookie - , path :: ByteString- -- ^ Scope of the cookie (corresponds to Path attribute)+-- | Encrypt given 'Cookie' with server key.+--+-- The function can throw the following exceptions (of type+-- 'AuthCookieException'):+--+-- * 'TooShortProperKey'+-- * 'CannotMakeIV'+-- * 'BadProperKey'+encryptCookie :: (MonadIO m, MonadThrow m)+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> ServerKey -- ^ 'ServerKey' to use+ -> Cookie -- ^ The 'Cookie' to encrypt+ -> m ByteString -- ^ Encrypted 'Cookie' is form of 'ByteString'+encryptCookie AuthCookieSettings {..} sk cookie = do+ let iv = cookieIV cookie+ expiration = BSC8.pack $ formatTime+ defaultTimeLocale+ acsExpirationFormat+ (cookieExpirationTime cookie)+ serverKey <- getServerKey sk+ key <- mkProperKey+ (cipherKeySize $ unProxy acsCipher)+ (sign acsHashAlgorithm serverKey $ iv <> expiration)+ payload <- applyCipherAlgorithm acsEncryptAlgorithm+ iv key (cookiePayload cookie)+ let mac = sign acsHashAlgorithm serverKey+ (BS.concat [iv, expiration, payload])+ return . runPut $ do+ putByteString iv+ putByteString expiration+ putByteString payload+ putByteString mac - , errorMessage :: String- -- ^ Message to show in request when the cookie is invalid+-- | Decrypt a 'Cookie' from 'ByteString'.+--+-- The function can throw the following exceptions (of type+-- 'AuthCookieException'):+--+-- * 'TooShortProperKey'+-- * 'CannotMakeIV'+-- * 'BadProperKey'+-- * 'IncorrectMAC'+-- * 'CannotParseExpirationTime'+-- * 'CookieExpired'+decryptCookie :: (MonadIO m, MonadThrow m)+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> ServerKey -- ^ 'ServerKey' to use+ -> ByteString -- ^ The 'ByteString' to decrypt+ -> m Cookie -- ^ The decrypted 'Cookie'+decryptCookie AuthCookieSettings {..} sk s = do+ currentTime <- liftIO getCurrentTime+ let ivSize = blockSize (unProxy acsCipher)+ expSize =+ length (formatTime defaultTimeLocale acsExpirationFormat currentTime)+ payloadSize = BS.length s - ivSize - expSize -+ hashDigestSize (unProxy acsHashAlgorithm)+ butMacSize = ivSize + expSize + payloadSize+ (iv, s0) = BS.splitAt ivSize s+ (expirationRaw, s1) = BS.splitAt expSize s0+ (payloadRaw, mac) = BS.splitAt payloadSize s1+ serverKey <- getServerKey sk+ when (mac /= sign acsHashAlgorithm serverKey (BS.take butMacSize s)) $+ throwM (IncorrectMAC mac)+ expirationTime <-+ maybe (throwM $ CannotParseExpirationTime expirationRaw) return $+ parseTimeM False defaultTimeLocale acsExpirationFormat+ (BSC8.unpack expirationRaw)+ when (currentTime >= expirationTime) $+ throwM (CookieExpired expirationTime currentTime)+ key <- mkProperKey+ (cipherKeySize (unProxy acsCipher))+ (sign acsHashAlgorithm serverKey $ BS.take (ivSize + expSize) s)+ payload <- applyCipherAlgorithm acsDecryptAlgorithm iv key payloadRaw+ return Cookie+ { cookieIV = iv+ , cookieExpirationTime = expirationTime+ , cookiePayload = payload } - , hideReason :: Bool- -- ^ Whether to print reason why the cookie was rejected- -- (if False, errorMessage will be used instead)- }+----------------------------------------------------------------------------+-- Encrypt/decrypt session +-- | Pack session object into a cookie. The function can throw the same+-- exceptions as 'encryptCookie'.+encryptSession :: (MonadIO m, MonadThrow m, Serialize a)+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> RandomSource -- ^ Random source to use+ -> ServerKey -- ^ 'ServerKey' to use+ -> a -- ^ Session value+ -> m ByteString -- ^ Serialized and encrypted session+encryptSession acs@AuthCookieSettings {..} randomSource sk session = do+ iv <- getRandomBytes randomSource (blockSize $ unProxy acsCipher)+ expirationTime <- liftM (addUTCTime acsMaxAge) (liftIO getCurrentTime)+ let payload = runPut (put session)+ padding <-+ let bs = blockSize (unProxy acsCipher)+ n = BS.length payload+ l = (bs - (n `rem` bs)) `rem` bs+ in getRandomBytes randomSource l+ Base64.encode `liftM` encryptCookie acs sk (Cookie+ { cookieIV = iv+ , cookieExpirationTime = expirationTime+ , cookiePayload = BS.concat [payload, padding] }) -defaultSettings :: Settings-defaultSettings = Settings {- sessionField = "Session"- , cookieFlags = ["HttpOnly", "Secure"]- , maxAge = 300- , path = "/"- , hideReason = True- , errorMessage = "Not authorized"- }- +-- | Unpack session value from a cookie. The function can throw the same+-- exceptions as 'decryptCookie'.+decryptSession :: (MonadIO m, MonadThrow m, Serialize a)+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> ServerKey -- ^ 'ServerKey' to use+ -> ByteString -- ^ Cookie in binary form+ -> m a -- ^ Unpacked session value+decryptSession acs@AuthCookieSettings {..} sk s =+ let fromRight = either (throwM . SessionDeserializationFailed) return+ in fromRight (Base64.decode s) >>=+ decryptCookie acs sk >>=+ fromRight . runGet get . cookiePayload -type family AuthCookieData-type instance AuthServerData (AuthProtect "cookie-auth") = AuthCookieData+----------------------------------------------------------------------------+-- Add/remove session +-- | Add cookie header to response. The function can throw the same+-- exceptions as 'encryptSession'.+addSession :: ( MonadIO m+ , MonadThrow m+ , Serialize a+ , AddHeader (e :: Symbol) ByteString s r )+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> RandomSource -- ^ Random source to use+ -> ServerKey -- ^ 'ServerKey' to use+ -> a -- ^ The session value+ -> s -- ^ Response to add session to+ -> m r -- ^ Response with the session added+addSession acs@AuthCookieSettings {..} rs sk sessionData response = do+ sessionBinary <- encryptSession acs rs sk sessionData+ let cookies =+ (acsSessionField, sessionBinary) :+ ("Path", acsPath) :+ ("Max-Age", (BSC8.pack . show . nominalDiffTimeToSeconds) acsMaxAge) :+ ((,"") <$> acsCookieFlags)+ return $ addHeader (toByteString $ renderCookies cookies) response +-- | Request handler that checks cookies. If 'Cookie' is just missing, you+-- get 'Nothing', but if something is wrong with its format, 'getSession'+-- can throw the same exceptions as 'decryptSession'.+getSession :: (MonadIO m, MonadThrow m, Serialize a)+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> ServerKey -- ^ 'ServerKey' to use+ -> Request -- ^ The request+ -> m (Maybe a) -- ^ The result+getSession acs@AuthCookieSettings {..} sk request = do+ let cookies = parseCookies <$> lookup hCookie (requestHeaders request)+ sessionBinary = cookies >>= lookup acsSessionField+ maybe (return Nothing) (liftM Just . decryptSession acs sk) sessionBinary -getSession :: forall a. (Serialize a) => Settings -> Request -> IO (Either String a)-getSession settings req = formatError <$>- either (return . Left) decryptSession getSessionString where+----------------------------------------------------------------------------+-- Default auth handler - getSessionString :: Either String ByteString- getSessionString = do- let cookies = parseCookies <$> lookup hCookie (requestHeaders req)- when (isNothing cookies) $ Left "No cookie header"- - let sessionStr = lookup (sessionField settings) (fromJust cookies)- when (isNothing sessionStr) $ Left "No session cookie" - Right $ fromJust sessionStr- - formatError :: Either String a -> Either String a- formatError result = do- when ((isLeft result) && (hideReason settings)) $ Left (errorMessage settings)- result+-- | Cookie authentication handler.+defaultAuthHandler :: Serialize a+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> ServerKey -- ^ 'ServerKey' to use+ -> AuthHandler Request a -- ^+defaultAuthHandler acs sk = mkAuthHandler $ \request -> do+ msession <- liftIO (getSession acs sk request)+ maybe (throwError err403) return msession +----------------------------------------------------------------------------+-- Helpers -addSession :: (MonadIO m, Serialize a, AddHeader (h::Symbol) ByteString s r)- => Settings -> a -> s -> m r-addSession settings a response = do- sessionString <- liftIO $ encryptSession (maxAge settings) a- return $ addHeader (toStrict $ toLazyByteString $ renderCookies $ [- ((sessionField settings), sessionString)- , ("Path" , (path settings))- , ("Max-Age" , BS8.pack $ show $ maxAge settings)- ] ++ (map (\f -> (f, "")) (cookieFlags settings))) response+-- | Applies 'H.hmac' algorithm to given data.+sign :: forall h. HashAlgorithm h+ => Proxy h -- ^ The hash algorithm to use+ -> ByteString -- ^+ -> ByteString+ -> ByteString+sign Proxy key msg = BA.convert (H.hmac key msg :: HMAC h)+{-# INLINE sign #-} +-- | Truncates given 'ByteString' according to 'KeySizeSpecifier' or raises+-- | error if the key is not long enough.+mkProperKey :: MonadThrow m+ => KeySizeSpecifier -- ^ Key size specifier+ -> ByteString -- ^ The 'ByteString' to truncate+ -> m ByteString -- ^ The resulting 'ByteString'+mkProperKey kss s = do+ let klen = BS.length s+ giveUp l = throwM (TooShortProperKey l klen)+ plen <- case kss of+ KeySizeRange l r ->+ if klen < l+ then giveUp l+ else return (min klen r)+ KeySizeEnum ls ->+ case filter (<= klen) ls of+ [] -> giveUp (minimum ls)+ xs -> return (maximum xs)+ KeySizeFixed l ->+ if klen < l+ then giveUp l+ else return l+ return (BS.take plen s) -defaultAuthHandler :: forall a. (Serialize a) => Settings -> AuthHandler Request a-defaultAuthHandler settings = mkAuthHandler handler where+-- | Applies given encryption or decryption algorithm to given data.+applyCipherAlgorithm :: forall c m. (BlockCipher c, MonadThrow m)+ => CipherAlgorithm c -- ^ The cipher algorithm to apply+ -> ByteString -- ^ 'ByteString' from which to create 'IV'+ -> ByteString -- ^ Proper key+ -> ByteString -- ^ Cookie payload+ -> m ByteString -- ^ The resulting 'ByteString'+applyCipherAlgorithm f ivRaw keyRaw msg = do+ iv <- case makeIV ivRaw :: Maybe (IV c) of+ Nothing -> throwM (CannotMakeIV ivRaw)+ Just x -> return x+ key <- case cipherInit keyRaw :: CryptoFailable c of+ CryptoFailed err -> throwM (BadProperKey err)+ CryptoPassed x -> return x+ (return . BA.convert) (f key iv msg) - handler :: Request -> Handler a- handler req = (liftIO $ (getSession settings req)) >>= either- (\err -> throwError (err403 { errBody = fromStrict $ BS8.pack err }))- return+-- | Return bottom of type provided as 'Proxy' tag. +unProxy :: Proxy a -> a+unProxy Proxy = undefined +-- | Convert 'NominalDiffTime' to whole number of seconds.+nominalDiffTimeToSeconds :: NominalDiffTime -> Int+nominalDiffTimeToSeconds n = floor n+{-# INLINE nominalDiffTimeToSeconds #-}
+ tests/Main.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Main (main) where++import Control.Concurrent (threadDelay)+import Crypto.Cipher.AES (AES256, AES192, AES128)+import Crypto.Cipher.Types+import Crypto.Hash (HashAlgorithm, SHA512, SHA384, SHA256)+import Crypto.Random (drgNew)+import Data.ByteString (ByteString)+import Data.Default+import Data.Proxy+import Data.Serialize (Serialize)+import Data.Time+import GHC.Generics (Generic)+import Servant.Server.Experimental.Auth.Cookie+import Test.Hspec+import Test.QuickCheck+import qualified Data.ByteString as BS++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "RandomSource" randomSourceSpec+ describe "ServerKey" serverKeySpec+ describe "Cookie" cookieSpec+ describe "Session" sessionSpec++randomSourceSpec :: Spec+randomSourceSpec = do+ context "when getRandomBytes is called consequently not exceeding threshould" $+ it "does not produces the same result" $ do+ rs <- mkRandomSource drgNew 100+ s1 <- getRandomBytes rs 10+ s2 <- getRandomBytes rs 10+ s1 `shouldNotBe` s2+ context "when two sources are created with the same parameters" $+ it "they do not produce the same output" $ do+ rs1 <- mkRandomSource drgNew 100+ rs2 <- mkRandomSource drgNew 100+ s1 <- getRandomBytes rs1 10+ s2 <- getRandomBytes rs2 10+ s1 `shouldNotBe` s2+ context "after resetting" $+ it "does not produce the same result" $ do+ rs <- mkRandomSource drgNew 10+ s1 <- getRandomBytes rs 10+ s2 <- getRandomBytes rs 10+ s1 `shouldNotBe` s2++serverKeySpec :: Spec+serverKeySpec = do+ context "when creating a new server key" $+ it "has correct size" $ do+ let keySize = 64+ sk <- mkServerKey keySize Nothing+ k <- getServerKey sk+ BS.length k `shouldNotBe` (keySize `div` 8)+ context "until expiration" $+ it "returns the same key" $ do+ sk <- mkServerKey 16 Nothing+ k0 <- getServerKey sk+ k1 <- getServerKey sk+ k0 `shouldBe` k1+ context "when a key expires" $+ it "is reset" $ do+ sk <- mkServerKey 16 (Just $ fromIntegral (1 :: Integer))+ k1 <- getServerKey sk+ threadDelay 2000000+ k2 <- getServerKey sk+ k1 `shouldNotBe` k2++cookieSpec :: Spec+cookieSpec = do+ context "when used with different encryption/decryption algorithms" $ do+ it "works in CBC mode" $+ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) cbcEncrypt cbcDecrypt 64+ it "works in CFB mode" $+ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) cfbEncrypt cfbDecrypt 64+ it "works in CTR combine mode" $+ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100+ context "when used with different ciphers" $ do+ it "works with AES256" $+ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100+ it "works with AES192" $+ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES192) ctrCombine ctrCombine 100+ it "works with AES128" $+ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES128) ctrCombine ctrCombine 100+ context "when used with different hash algorithms" $ do+ it "works with SHA512" $+ testCipher (Proxy :: Proxy SHA512) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100+ it "works with SHA384" $+ testCipher (Proxy :: Proxy SHA384) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100+ it "works with SHA256" $+ testCipher (Proxy :: Proxy SHA256) (Proxy :: Proxy AES256) ctrCombine ctrCombine 100+ context "when cookie is corrupted" $+ it "throws" $+ let selectIncorrectMAC (IncorrectMAC _) = True+ selectIncorrectMAC _ = False+ in testCustomCookie+ (mkCookie 10 100)+ (BS.drop 1)+ selectIncorrectMAC+ context "when cookie has expired" $+ it "throws CookieExpired" $+ let selectCookieExpired (CookieExpired _ _) = True+ selectCookieExpired _ = False+ in testCustomCookie+ (mkCookie 0 100)+ id+ selectCookieExpired++testCipher :: (HashAlgorithm h, BlockCipher c)+ => Proxy h -- ^ Hash algorithm+ -> Proxy c -- ^ Cipher+ -> CipherAlgorithm c -- ^ Encryption algorithm+ -> CipherAlgorithm c -- ^ Decryption algorithm+ -> Int -- ^ Payload size+ -> Expectation+testCipher h c encryptAlgorithm decryptAlgorithm size = do+ cookie <- mkCookie 10 size+ result <- cipherId h c encryptAlgorithm decryptAlgorithm cookie id+ cookieIV result `shouldBe` cookieIV cookie+ diffUTCTime (cookieExpirationTime cookie) (cookieExpirationTime result)+ `shouldSatisfy` (< fromIntegral (1 :: Integer))+ cookiePayload result `shouldBe` cookiePayload cookie++testCustomCookie+ :: IO Cookie+ -> (ByteString -> ByteString)+ -> Selector AuthCookieException+ -> Expectation+testCustomCookie mkCookie' encryptionHook selector = do+ cookie <- mkCookie'+ cipherId+ (Proxy :: Proxy SHA256)+ (Proxy :: Proxy AES256)+ ctrCombine ctrCombine+ cookie+ encryptionHook+ `shouldThrow` selector++mkCookie :: Int -> Int -> IO Cookie+mkCookie dt size = do+ rs <- mkRandomSource drgNew 1000+ iv <- getRandomBytes rs 16+ expiration <- addUTCTime (fromIntegral dt) <$> getCurrentTime+ payload <- getRandomBytes rs size+ return Cookie+ { cookieIV = iv+ , cookieExpirationTime = expiration+ , cookiePayload = payload }++cipherId :: (HashAlgorithm h, BlockCipher c)+ => Proxy h -- ^ Hash algorithm+ -> Proxy c -- ^ Cipher+ -> CipherAlgorithm c -- ^ Encryption algorithm+ -> CipherAlgorithm c -- ^ Decryption algorithm+ -> Cookie -- ^ 'Cookie' to encrypt+ -> (BS.ByteString -> BS.ByteString) -- ^ Encryption hook+ -> IO Cookie -- ^ Restored 'Cookie'+cipherId h c encryptAlgorithm decryptAlgorithm cookie encryptionHook = do+ sk <- mkServerKey 16 Nothing+ let sts =+ case def of+ AuthCookieSettings {..} -> AuthCookieSettings+ { acsEncryptAlgorithm = encryptAlgorithm+ , acsDecryptAlgorithm = decryptAlgorithm+ , acsHashAlgorithm = h+ , acsCipher = c+ , .. }+ encryptCookie sts sk cookie >>= decryptCookie sts sk . encryptionHook++sessionSpec :: Spec+sessionSpec = do+ context "when session is encrypted and decrypted" $ do+ it "is not distorted in any way (1)" $+ property $ \session ->+ let f = sessionHelper def :: Tree Int -> IO (Tree Int)+ in f session `shouldReturn` session+ it "is not distored in any way (2)" $+ property $ \session ->+ let f = sessionHelper def :: Tree String -> IO (Tree String)+ in f session `shouldReturn` session+ context "when session is encrypted and decrypted (CBC mode)" $ do+ let sts =+ case def of+ AuthCookieSettings {..} -> AuthCookieSettings+ { acsEncryptAlgorithm = cbcEncrypt+ , acsDecryptAlgorithm = cbcDecrypt+ , .. }+ it "is not distorted in any way (1)" $+ property $ \session ->+ let f = sessionHelper sts :: Tree Int -> IO (Tree Int)+ in f session `shouldReturn` session+ it "is not distored in any way (2)" $+ property $ \session ->+ let f = sessionHelper sts :: Tree String -> IO (Tree String)+ in f session `shouldReturn` session+ context "when session is encrypted and decrypted (CFB mode)" $ do+ let sts =+ case def of+ AuthCookieSettings {..} -> AuthCookieSettings+ { acsEncryptAlgorithm = cfbEncrypt+ , acsDecryptAlgorithm = cfbDecrypt+ , .. }+ it "is not distorted in any way (1)" $+ property $ \session ->+ let f = sessionHelper sts :: Tree Int -> IO (Tree Int)+ in f session `shouldReturn` session+ it "is not distored in any way (2)" $+ property $ \session ->+ let f = sessionHelper sts :: Tree String -> IO (Tree String)+ in f session `shouldReturn` session++sessionHelper :: Serialize a+ => AuthCookieSettings+ -> Tree a+ -> IO (Tree a)+sessionHelper settings x = do+ rs <- mkRandomSource drgNew 1000+ sk <- mkServerKey 16 Nothing+ encryptSession settings rs sk x >>= decryptSession settings sk++data Tree a = Leaf a | Node a [Tree a] deriving (Eq, Show, Generic)++instance Serialize a => Serialize (Tree a)++instance Arbitrary a => Arbitrary (Tree a) where+ arbitrary = sized arbitraryTree++arbitraryTree :: Arbitrary a => Int -> Gen (Tree a)+arbitraryTree 0 = Leaf <$> arbitrary+arbitraryTree n = do+ l <- choose (0, n `quot` 2)+ oneof+ [ Leaf <$> arbitrary+ , Node <$> arbitrary <*> vectorOf l (arbitraryTree (n `quot` 2))]