time-warp (empty) → 0.1.1
raw patch · 20 files changed
+3643/−0 lines, 20 filesdep +MonadRandomdep +QuickCheckdep +ansi-terminal
Dependencies added: MonadRandom, QuickCheck, ansi-terminal, async, base, bytestring, containers, data-default, data-msgpack, exceptions, formatting, hslogger, hspec, lens, lifted-base, monad-control, monad-loops, mtl, network-msgpack-rpc, pqueue, quickcheck-instances, random, safe, serokell-util, stm, template-haskell, text, text-format, time, time-units, time-warp, transformers, transformers-base
Files
- LICENSE +674/−0
- examples/token-ring/Main.hs +211/−0
- src/Control/TimeWarp/Logging.hs +216/−0
- src/Control/TimeWarp/Rpc.hs +61/−0
- src/Control/TimeWarp/Rpc/MonadRpc.hs +140/−0
- src/Control/TimeWarp/Rpc/MsgPackRpc.hs +79/−0
- src/Control/TimeWarp/Rpc/PureRpc.hs +246/−0
- src/Control/TimeWarp/Rpc/Restriction.hs +69/−0
- src/Control/TimeWarp/Timed.hs +52/−0
- src/Control/TimeWarp/Timed/Misc.hs +51/−0
- src/Control/TimeWarp/Timed/MonadTimed.hs +362/−0
- src/Control/TimeWarp/Timed/TimedIO.hs +84/−0
- src/Control/TimeWarp/Timed/TimedT.hs +381/−0
- test/Spec.hs +1/−0
- test/Test.hs +5/−0
- test/Test/Control/TimeWarp/Common.hs +41/−0
- test/Test/Control/TimeWarp/Rpc/MonadRpcSpec.hs +143/−0
- test/Test/Control/TimeWarp/Timed/ExceptionSpec.hs +288/−0
- test/Test/Control/TimeWarp/Timed/MonadTimedSpec.hs +402/−0
- time-warp.cabal +137/−0
+ LICENSE view
@@ -0,0 +1,674 @@+ 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/>.++Also add information on how to contact you by electronic and paper mail.++ If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++ <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.++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".++ 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/>.++ 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>.
+ examples/token-ring/Main.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}++import Control.Exception (Exception)+import Control.Monad (forever, when, forM_, unless, join)+import Control.Monad.Catch (MonadCatch, catch)+import Control.Monad.Random (StdGen, mkStdGen)+import qualified Control.Concurrent.STM.TVar as T+import Control.Concurrent.STM (atomically)+import Control.Monad.Trans (MonadIO (..), lift)+import Control.Lens (Iso', iso, (^.))+import Formatting (sformat, shown, (%))+import Data.Monoid ((<>))+import Data.Typeable (Typeable)++import Control.TimeWarp.Logging (WithNamedLogger (..), usingLoggerName,+ logInfo, initLogging, setLoggerName,+ Severity (..),+ LoggerName (..),+ logDebug, logError, LoggerNameBox)+import Control.TimeWarp.Timed (MonadTimed (..), schedule, ThreadId,+ killThread, at, for, sleepForever,+ Microsecond, sec, ms,+ interval, invoke, after, fork_)+import Control.TimeWarp.Rpc (MonadRpc (..), Port, NetworkAddress,+ Client, ServerT, call, method, runPureRpc,+ runMsgPackRpc, DelaysSpecifier,+ serverTypeRestriction1, MsgPackRpc,+ PureRpc, getRandomTR, Delays (..),+ ConnectionOutcome (..))++-- * Launch parameters.++launchDuration :: Microsecond+launchDuration = interval 20 sec++tokenPassingDelay :: Microsecond+tokenPassingDelay = interval 3 sec++nodeNumber :: Int+nodeNumber = 3++allowedProgressDelay :: Microsecond+allowedProgressDelay = interval 5 sec++networkDelay :: (Microsecond, Microsecond)+networkDelay = (interval 1 ms, interval 5 ms)++emulationMode :: Bool+emulationMode = True++-- * Starter++main :: IO ()+main = do+ initLogging ["node", "observer"] Info+ if emulationMode+ then runEmulationMode delays (mkStdGen 0) scenario+ else runRealMode scenario+ where+ scenario :: WorkMode m => m ()+ scenario = do+ setLoggerName "node" $ do+ forM_ [1 .. nodeNumber] $+ \no -> modifyLoggerName (<> LoggerName (show no)) $+ fork $ launchNode no++ setLoggerName ("observer" <> "progress") $+ fork_ $+ launchObserver+ delays = Delays $+ \dest _ -> + if dest == (observerPort ^. fullAddr)+ then return $ ConnectedIn 0+ else ConnectedIn <$> getRandomTR networkDelay++runRealMode :: LoggerNameBox MsgPackRpc () -> IO ()+runRealMode = runMsgPackRpc . usingLoggerName mempty++runEmulationMode+ :: DelaysSpecifier delays+ => delays -> StdGen -> PureRpc IO () -> IO ()+runEmulationMode delays gen = runPureRpc gen delays++nodePort :: Iso' Int Port+nodePort = iso (+2000) (subtract 2000)++fullAddr :: Iso' Port NetworkAddress+fullAddr = iso ("127.0.0.1", ) snd++type WorkMode m+ = ( MonadTimed m+ , MonadRpc m+ , WithNamedLogger m+ , MonadIO m+ , MonadCatch m)++-- * Nodes++type TokenValue = Int++launchNode :: WorkMode m => Int -> m ()+launchNode no = do+ logDebug $ sformat ("Launching node " % shown) no++ -- worker thread, which waits for signal from server thread+ -- to process token+ wtid <- modifyLoggerName (<> "worker") $+ fork $+ forever $ catch sleepForever onValueReceived++ -- server thread, which waits for token from other node and+ -- sends a signal to worker+ stid <- modifyLoggerName (<> "server") $+ fork $ do+ idr <- serverTypeRestriction1+ logDebug $ sformat ("Server up at " % shown) $ no ^. nodePort+ serve (no ^. nodePort)+ [ method "token" $ idr $ acceptToken wtid+ ]++ -- kill all when testing finishes+ modifyLoggerName (<> "killer") $+ schedule (at launchDuration) $ do+ mapM_ killThread [wtid, stid]++ logInfo "Launched"++ -- initiate first token passing+ when (no == 1) $+ invoke (after 1 sec) $ do+ logInfo "Creating token"+ initPassingToken 1+ where+ onValueReceived (ValueReceived v) = do+ logInfo $ sformat ("Got token with value " % shown) v+ execClient ("127.0.0.1", observerPort) $ noteTokenCall v+ wait (for tokenPassingDelay)+ initPassingToken $ v + 1++ initPassingToken v = do+ let targetNode = no `mod` nodeNumber + 1+ targetAddr = targetNode ^. nodePort . fullAddr+ logDebug "Passing token"+ execClient targetAddr $ passToken v++ passToken :: TokenValue -> Client ()+ passToken = call "token"++ acceptToken :: WorkMode m => ThreadId m -> TokenValue -> ServerT m ()+ acceptToken tid value = do+ lift . throwTo tid $ ValueReceived value++data SignalException = ValueReceived Int+ deriving (Show, Typeable)++instance Exception SignalException++-- * Observer, checks for global predicates.++observerPort :: Int+observerPort = 5000++launchObserver :: WorkMode m => m ()+launchObserver = do+ lastProgress <- liftIO $ T.newTVarIO (0, 0)++ -- server which listens whether token value was changed+ stid <- modifyLoggerName (<> "server") $+ fork $ do+ idr <- serverTypeRestriction1+ serve observerPort+ [method "noteToken" $ idr $ noteTokenMethod lastProgress+ ]++ -- periodically checks for progress+ ctid <- modifyLoggerName (<> "checker") $+ fork . forever $ do+ wait (for 1 sec)+ (lastTime, value) <- liftIO $ T.readTVarIO lastProgress+ time <- virtualTime+ when (time - lastTime > allowedProgressDelay) $+ logError $+ sformat ("Token value (" % shown % ") hasn't changed " %+ "since " % shown % shown) value lastTime time++ logInfo "Launched"++ -- kill all when testing finishes+ modifyLoggerName (<> "killer") $+ schedule (at launchDuration) $ do+ mapM_ killThread [stid, ctid]+++noteTokenMethod+ :: WorkMode m+ => T.TVar (Microsecond, TokenValue) -> TokenValue -> ServerT m ()+noteTokenMethod progressBox value = lift $ do+ time <- virtualTime+ join . liftIO . atomically $ do+ (_, wasValue) <- T.readTVar progressBox+ T.writeTVar progressBox (time, value)+ return $+ unless (value == wasValue + 1) $+ logError $ sformat ("Wrong token value: expected " % shown %+ " but got " % shown) (wasValue + 1) value++noteTokenCall :: TokenValue -> Client ()+noteTokenCall = call "noteToken"
+ src/Control/TimeWarp/Logging.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Control.TimeWarp.Logging+-- Copyright : (c) Serokell, 2016+-- License : GPL-3 (see the file LICENSE)+-- Maintainer : Serokell <hi@serokell.io>+-- Stability : experimental+-- Portability : POSIX, GHC+--+-- Logging functionality. This module is wrapper over+-- <http://hackage.haskell.org/package/hslogger hslogger>,+-- which allows to keep logger name in monadic context.+-- Messages are colored depending on used serverity.++module Control.TimeWarp.Logging+ ( Severity (..)+ , initLogging+ , initLoggerByName++ , LoggerName (..)++ -- * Remove boilerplate+ , WithNamedLogger (..)+ , setLoggerName+ , LoggerNameBox (..)+ , usingLoggerName++ -- * Logging functions+ , logDebug+ , logError+ , logInfo+ , logWarning+ , logMessage+ ) where++import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)+import Control.Monad.Except (ExceptT (..), runExceptT)+import Control.Monad.Reader (MonadReader (..), ReaderT, runReaderT)+import Control.Monad.State (MonadState (get), StateT, evalStateT)+import Control.Monad.Trans (MonadIO (liftIO), MonadTrans, lift)+import Control.Monad.Trans.Cont (ContT, mapContT)++import Data.String (IsString)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import GHC.Generics (Generic)++import System.Console.ANSI (Color (Blue, Green, Red, Yellow),+ ColorIntensity (Vivid),+ ConsoleLayer (Foreground),+ SGR (Reset, SetColor), setSGRCode)+import System.IO (stderr, stdout)+import System.Log.Formatter (simpleLogFormatter)+import System.Log.Handler (setFormatter)+import System.Log.Handler.Simple (streamHandler)+import System.Log.Logger (Priority (DEBUG, ERROR, INFO, WARNING), logM,+ removeHandler, rootLoggerName, setHandlers,+ setLevel, updateGlobalLogger)++-- | This type is intended to be used as command line option+-- which specifies which messages to print.+data Severity+ = Debug+ | Info+ | Warning+ | Error+ deriving (Generic, Typeable, Show, Read, Eq)++-- | Logger name to keep in context.+newtype LoggerName = LoggerName+ { loggerName :: String+ } deriving (Show, IsString)++-- | Defined such that @n1@ is parent for @(n1 <> n2)@+-- (see <http://hackage.haskell.org/package/hslogger-1.2.10/docs/System-Log-Logger.html hslogger description>).+instance Monoid LoggerName where+ mempty = ""++ LoggerName base `mappend` LoggerName suffix+ | null base = LoggerName suffix+ | otherwise = LoggerName $ base ++ "." ++ suffix++convertSeverity :: Severity -> Priority+convertSeverity Debug = DEBUG+convertSeverity Info = INFO+convertSeverity Warning = WARNING+convertSeverity Error = ERROR++-- | Initiates specified loggers, and sets severity of root logger's handler to+-- `Debug`+initLogging :: [LoggerName] -> Severity -> IO ()+initLogging predefinedLoggers sev = do+ updateGlobalLogger rootLoggerName removeHandler+ updateGlobalLogger rootLoggerName $ setLevel DEBUG+ mapM_ (initLoggerByName sev) predefinedLoggers++-- | Turns logger with specified name on.+-- All messages are printed to /stdout/, moreover messages with at least+-- `Error` severity are printed to /stderr/.+initLoggerByName :: Severity -> LoggerName -> IO ()+initLoggerByName (convertSeverity -> s) LoggerName{..} = do+ stdoutHandler <-+ (flip setFormatter) stdoutFormatter <$> streamHandler stdout s+ stderrHandler <-+ (flip setFormatter) stderrFormatter <$> streamHandler stderr ERROR+ updateGlobalLogger loggerName $ setHandlers [stdoutHandler, stderrHandler]+ where+ stderrFormatter = simpleLogFormatter+ ("[$time] " ++ colorizer ERROR "[$loggername:$prio]: " ++ "$msg")+ stdoutFormatter h r@(pr, _) n =+ simpleLogFormatter (colorizer pr "[$loggername:$prio] " ++ "$msg") h r n++-- | Defines pre- and post-printed characters for printing colorized text.+table :: Priority -> (String, String)+table priority = case priority of+ ERROR -> (setColor Red , reset)+ DEBUG -> (setColor Green , reset)+ WARNING -> (setColor Yellow, reset)+ INFO -> (setColor Blue , reset)+ _ -> ("", "")+ where+ setColor color = setSGRCode [SetColor Foreground Vivid color]+ reset = setSGRCode [Reset]++-- | Colorizes text.+colorizer :: Priority -> String -> String+colorizer pr s = before ++ s ++ after+ where+ (before, after) = table pr++-- | This type class exists to remove boilerplate logging+-- by adding the logger's name to the context in each module.+class WithNamedLogger m where+ -- | Extract logger name from context+ getLoggerName :: m LoggerName++ -- | Change logger name in context+ modifyLoggerName :: (LoggerName -> LoggerName) -> m a -> m a++-- | Set logger name in context.+setLoggerName :: WithNamedLogger m => LoggerName -> m a -> m a+setLoggerName = modifyLoggerName . const++instance (Monad m, WithNamedLogger m) =>+ WithNamedLogger (ReaderT a m) where+ getLoggerName = lift getLoggerName++ modifyLoggerName how m =+ ask >>= lift . modifyLoggerName how . runReaderT m++instance (Monad m, WithNamedLogger m) =>+ WithNamedLogger (StateT a m) where+ getLoggerName = lift getLoggerName++ modifyLoggerName how m =+ get >>= lift . modifyLoggerName how . evalStateT m++instance (Monad m, WithNamedLogger m) =>+ WithNamedLogger (ExceptT e m) where+ getLoggerName = lift getLoggerName++ modifyLoggerName how = ExceptT . modifyLoggerName how . runExceptT++instance (Monad m, WithNamedLogger m) =>+ WithNamedLogger (ContT r m) where+ getLoggerName = lift getLoggerName++ modifyLoggerName = mapContT . modifyLoggerName+++-- | Default implementation of `WithNamedLogger`.+newtype LoggerNameBox m a = LoggerNameBox+ { loggerNameBoxEntry :: ReaderT LoggerName m a+ } deriving (Functor, Applicative, Monad, MonadIO, MonadTrans,+ MonadThrow, MonadCatch, MonadMask, MonadState s)+++instance MonadReader r m => MonadReader r (LoggerNameBox m) where+ ask = lift ask+ reader = lift . reader+ local f (LoggerNameBox m) = getLoggerName >>= lift . local f . runReaderT m++-- | Runs a `LoggerNameBox` with specified initial `LoggerName`.+usingLoggerName :: LoggerName -> LoggerNameBox m a -> m a+usingLoggerName name = flip runReaderT name . loggerNameBoxEntry++instance Monad m =>+ WithNamedLogger (LoggerNameBox m) where+ getLoggerName = LoggerNameBox ask++ modifyLoggerName how = LoggerNameBox . local how . loggerNameBoxEntry++-- | Shortcut for `logMessage` to use according severity.+logDebug, logInfo, logWarning, logError+ :: (WithNamedLogger m, MonadIO m)+ => T.Text -> m ()+logDebug = logMessage Debug+logInfo = logMessage Info+logWarning = logMessage Warning+logError = logMessage Error++-- | Logs message with specified severity using logger name in context.+logMessage+ :: (WithNamedLogger m, MonadIO m)+ => Severity -> T.Text -> m ()+logMessage severity t = do+ LoggerName{..} <- getLoggerName+ liftIO . logM loggerName (convertSeverity severity) $ T.unpack t
+ src/Control/TimeWarp/Rpc.hs view
@@ -0,0 +1,61 @@+-- |+-- Module : Control.TimeWarp.Rpc+-- Copyright : (c) Serokell, 2016+-- License : GPL-3 (see the file LICENSE)+-- Maintainer : Serokell <hi@serokell.io>+-- Stability : experimental+-- Portability : POSIX, GHC+--+-- This module provides RPC capabilities. It allows to write scenarios over+-- distributed systems, which can then be launched as either real program or+-- emulation with network nastiness manually controlled.+--+-- Usage example:+--+-- @+-- sumMethod :: Monad m => Int -> Int -> ServerT m Int+-- sumMethod a b = return $ a + b+--+-- callSum :: Int -> Int -> Client Int+-- callSum = call "sum"+--+-- exampleLaunch :: (MonadRpc m, MonadTimed m, MonadIO m) => m ()+-- exampleLaunch = do+-- -- launch server+-- work (for 1 minute) $ do+-- idr <- serverTypeRestriction2+-- serve 1234 [method "sum" $ idr sumMethod]+-- -- make 3 requests with delay+-- fork_ $+-- forM_ [1..3] $+-- \\i -> do+-- wait (for 3 sec)+-- res <- execClient ("127.0.0.1", 1234) $ callSum (-1) i+-- liftIO $ timestamp $ "Answer is " ++ show res+-- @+--+-- This scenario then can be launched as real program:+--+-- >>> runTimedIO . runMsgPackRpc $ exampleLaunch+-- [3000012µs] Answer is 0+-- [6000013µs] Answer is 1+-- [9000015µs] Answer is 2+--+-- Or as emulation, which works immediately:+--+-- >>> runTimedT . runPureRpc (mkStdGen 23423) (10 :: Microsecond, 50 :: Microsecond) $ exampleLaunch+-- [3000023µs] Answer is 0+-- [6000072µs] Answer is 1+-- [90000102µs] Answer is 2++module Control.TimeWarp.Rpc+ ( module Control.TimeWarp.Rpc.MonadRpc+ , module Control.TimeWarp.Rpc.MsgPackRpc+ , module Control.TimeWarp.Rpc.Restriction+ , module Control.TimeWarp.Rpc.PureRpc+ ) where++import Control.TimeWarp.Rpc.MonadRpc+import Control.TimeWarp.Rpc.MsgPackRpc+import Control.TimeWarp.Rpc.PureRpc+import Control.TimeWarp.Rpc.Restriction
+ src/Control/TimeWarp/Rpc/MonadRpc.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Control.TimeWarp.Rpc.MonadRpc+-- Copyright : (c) Serokell, 2016+-- License : GPL-3 (see the file LICENSE)+-- Maintainer : Serokell <hi@serokell.io>+-- Stability : experimental+-- Portability : POSIX, GHC+--+-- This module contains `MonadRpc` typeclass which abstracts over+-- RPC communication.++module Control.TimeWarp.Rpc.MonadRpc+ ( Port+ , Host+ , NetworkAddress++ , MonadRpc (serve, execClient)+ , RpcType()+ , execClientTimeout+ , Method(..)+ , Client(..)+ , method+ , call+ , S.Server+ , S.ServerT+ , S.MethodType+ , C.RpcError(..)+ ) where++import Control.Monad.Catch (MonadCatch (catch),+ MonadThrow (throwM))+import Control.Monad.Reader (ReaderT (..))+import Control.Monad.Trans (lift)+import Data.ByteString (ByteString)++import Data.MessagePack (MessagePack, toObject, Object)+import Data.Time.Units (TimeUnit)++import qualified Network.MessagePack.Client as C+import qualified Network.MessagePack.Server as S++import Control.TimeWarp.Logging (WithNamedLogger, LoggerNameBox (..))+import Control.TimeWarp.Timed (MonadTimed (timeout))++-- | Port number.+type Port = Int++-- | Host address.+type Host = ByteString++-- | Full node address.+type NetworkAddress = (Host, Port)+++deriving instance WithNamedLogger m => WithNamedLogger (S.ServerT m)++-- | Defines protocol of RPC layer.+class MonadThrow r => MonadRpc r where+ -- | Executes remote method call.+ execClient :: MessagePack a => NetworkAddress -> Client a -> r a++ -- | Starts RPC server with a set of RPC methods.+ serve :: Port -> [Method r] -> r ()++-- | Same as `execClient`, but allows to set up timeout for a call (see+-- `Control.TimeWarp.Timed.MonadTimed.timeout`).+execClientTimeout+ :: (MonadTimed m, MonadRpc m, MessagePack a, TimeUnit t)+ => t -> NetworkAddress -> Client a -> m a+execClientTimeout t addr = timeout t . execClient addr++-- * Client part++-- | Creates a function call. It accepts function name and arguments.+call :: RpcType t => String -> t+call name = rpcc name []++-- | Collects function name and arguments+-- (it's <https://hackage.haskell.org/package/msgpack-rpc-1.0.0/docs/Network-MessagePack-Client.html#v:call msgpack-rpc> implementation is hidden, need our own).+class RpcType t where+ rpcc :: String -> [Object] -> t++instance (RpcType t, MessagePack p) => RpcType (p -> t) where+ rpcc name objs p = rpcc name $ toObject p : objs++-- | Keeps function name and arguments.+data Client a where+ Client :: MessagePack a => String -> [Object] -> Client a++instance MessagePack o => RpcType (Client o) where+ rpcc name args = Client name (reverse args)++-- * Server part++-- | Keeps method definition.+data Method m = Method+ { methodName :: String+ , methodBody :: [Object] -> m Object+ }++-- | Creates method available for RPC-requests.+-- It accepts method name (which would be refered by clients)+-- and it's body.+method :: S.MethodType m f => String -> f -> Method m+method name f = Method+ { methodName = name+ , methodBody = S.toBody f+ }++instance Monad m => S.MethodType m Object where+ toBody res [] = return res+ toBody _ _ = error "Too many arguments!"++instance MonadThrow m => MonadThrow (S.ServerT m) where+ throwM = lift . throwM++instance MonadCatch m =>+ MonadCatch (S.ServerT m) where+ catch (S.ServerT action) handler =+ S.ServerT $ action `catch` (S.runServerT . handler)++instance MonadRpc m => MonadRpc (ReaderT r m) where+ execClient addr cli = lift $ execClient addr cli++ serve port methods = ReaderT $+ \r -> serve port (convert r <$> methods)+ where+ convert :: r -> Method (ReaderT r m) -> Method m+ convert r Method {..} =+ Method methodName (flip runReaderT r . methodBody)++deriving instance MonadRpc m => MonadRpc (LoggerNameBox m)
+ src/Control/TimeWarp/Rpc/MsgPackRpc.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module : Control.TimeWarp.Rpc.MsgPackRpc+-- Copyright : (c) Serokell, 2016+-- License : GPL-3 (see the file LICENSE)+-- Maintainer : Serokell <hi@serokell.io>+-- Stability : experimental+-- Portability : POSIX, GHC+--+-- This module contains implementation of `MonadRpc` for real mode+-- (network, time- and thread-management capabilities provided by OS are used).++module Control.TimeWarp.Rpc.MsgPackRpc+ ( MsgPackRpc+ , runMsgPackRpc+ ) where++import qualified Control.Concurrent as C+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadCatch, MonadMask,+ MonadThrow)+import Control.Monad.Trans (MonadIO (..))+import Control.Monad.Trans.Control (MonadBaseControl, StM,+ liftBaseWith, restoreM)++import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe)++import qualified Network.MessagePack.Client as C+import qualified Network.MessagePack.Server as S++import Control.TimeWarp.Rpc.MonadRpc (Client (..), Method (..),+ MonadRpc (..))+import Control.TimeWarp.Timed (MonadTimed (..), TimedIO, ThreadId,+ runTimedIO)++-- | Wrapper over `Control.TimeWarp.Timed.TimedIO`, which implements `MonadRpc`+-- using <https://hackage.haskell.org/package/msgpack-rpc-1.0.0 msgpack-rpc>.+newtype MsgPackRpc a = MsgPackRpc+ { -- | Launches distributed scenario using real network, threads and time.+ unwrapMsgPackRpc :: TimedIO a+ } deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO,+ MonadThrow, MonadCatch, MonadMask, MonadTimed)++runMsgPackRpc :: MsgPackRpc a -> IO a+runMsgPackRpc = runTimedIO . unwrapMsgPackRpc++type instance ThreadId MsgPackRpc = C.ThreadId++instance MonadBaseControl IO MsgPackRpc where+ type StM MsgPackRpc a = a++ liftBaseWith f = MsgPackRpc $ liftBaseWith $ \g -> f $ g . unwrapMsgPackRpc++ restoreM = MsgPackRpc . restoreM++instance MonadRpc MsgPackRpc where+ execClient (addr, port) (Client name args) = liftIO $ do+ box <- newIORef Nothing+ C.execClient addr port $ do+ -- note, underlying rpc accepts a single argument - [Object]+ res <- C.call name args+ liftIO . writeIORef box $ Just res+ fromMaybe (error "execClient didn't return a value!")+ <$> readIORef box++ serve port methods = S.serve port $ convertMethod <$> methods+ where+ convertMethod :: Method MsgPackRpc -> S.Method MsgPackRpc+ convertMethod Method{..} = S.method methodName methodBody++instance S.MethodType MsgPackRpc f => S.MethodType MsgPackRpc (MsgPackRpc f)+ where+ toBody res args = res >>= flip S.toBody args
+ src/Control/TimeWarp/Rpc/PureRpc.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Control.TimeWarp.Rpc.PureRpc+-- Copyright : (c) Serokell, 2016+-- License : GPL-3 (see the file LICENSE)+-- Maintainer : Serokell <hi@serokell.io>+-- Stability : experimental+-- Portability : POSIX, GHC+--+-- Defines network-emulated implementation of `MonadRpc`. Threads and time are+-- also emulated via `Control.TimeWarp.Timed.TimedT`.+module Control.TimeWarp.Rpc.PureRpc+ ( PureRpc+ , runPureRpc+ , DelaysSpecifier (..)+ , Delays (..)+ , ConnectionOutcome (..)+ , getRandomTR+ ) where++import Control.Exception.Base (Exception)+import Control.Lens (both, makeLenses, to, use, (%%=),+ (%~), at, (?=))+import Control.Monad (forM_, when)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, throwM)+import Control.Monad.Random (MonadRandom (getRandomR), Rand, runRand)+import Control.Monad.State (MonadState (get, put, state), StateT,+ evalStateT)+import Control.Monad.Trans (MonadIO, MonadTrans, lift)+import Data.Default (Default, def)+import Data.Map as Map+import Data.Time.Units (fromMicroseconds, toMicroseconds)+import Data.Typeable (Typeable)+import System.Random (StdGen)++import Data.MessagePack (Object, MessagePack (..))++import Control.TimeWarp.Logging (WithNamedLogger)+import Control.TimeWarp.Rpc.MonadRpc (Client (..), Host, Method (..),+ MonadRpc (execClient, serve),+ Port, RpcError (..), methodBody,+ methodName, NetworkAddress)+import Control.TimeWarp.Timed (Microsecond, MonadTimed (..),+ PureThreadId, TimedT, for,+ virtualTime, runTimedT, sleepForever,+ wait, ThreadId)++localhost :: Host+localhost = "127.0.0.1"++-- | Describes obstructions occured on executing RPC request.+data ConnectionOutcome+ -- | Connection established in specified amout of time.+ = ConnectedIn Microsecond+ -- | Connection would be never established, client hangs.+ | NeverConnected++-- | Allows to describe most complicated behaviour of network.+--+-- Examples:+--+-- * Always 1 second delay:+--+-- @+-- Delays $ \\_ _ -> return $ ConnectedIn (interval 1 sec)+-- @+--+-- * Delay varies between 1 and 5 seconds (with granularity of 1 mcs):+--+-- @+-- Delays $ \\_ _ -> ConnectedIn \<$\> getRandomTR (interval 1 sec, interval 5 sec)+-- @+--+-- * For first 10 seconds after scenario start connection is established+-- with probability of 1/6:+--+-- @+-- Delays $ \\_ time -> do+-- p <- getRandomR (0, 5)+-- if (p == 0) && (time <= interval 10 sec)+-- then return $ ConnectedIn 0+-- else return NeverConnected+-- @+--+-- * Node with address `isolatedAddr` is not accessible:+--+-- @+-- Delays $ \\serverAddr _ ->+-- return if serverAddr == isolatedAddr+-- then NeverConnected+-- else ConnectedIn 0+-- @++newtype Delays = Delays+ { -- | Basing on current virtual time, rpc method server's+ -- address, returns delay after which server receives RPC request.+ evalDelay :: NetworkAddress+ -> Microsecond+ -> Rand StdGen ConnectionOutcome+ }++-- | Describes network nastiness.+class DelaysSpecifier d where+ toDelays :: d -> Delays++-- | Detailed description of network nastiness.+instance DelaysSpecifier Delays where+ toDelays = id++-- | Connection is never established.+instance DelaysSpecifier () where+ toDelays = const . Delays . const . const . return $ NeverConnected++-- | Specifies permanent connection delay.+instance DelaysSpecifier Microsecond where+ toDelays = Delays . const . const . return . ConnectedIn++-- | Connection delay varies is specified range.+instance DelaysSpecifier (Microsecond, Microsecond) where+ toDelays = Delays . const . const . fmap ConnectedIn . getRandomTR++-- This is needed for QC.+instance Show Delays where+ show _ = "Delays"++-- | Describes reliable network.+instance Default Delays where+ def = Delays . const . const . return . ConnectedIn $ 0++-- | Return a randomly-selected time value in specified range.+getRandomTR :: MonadRandom m => (Microsecond, Microsecond) -> m Microsecond+getRandomTR = fmap fromMicroseconds . getRandomR . (both %~ toMicroseconds)++-- | Keeps servers' methods.+type Listeners m = Map.Map (Port, String) ([Object] -> m Object)++-- | Keeps global network information.+data NetInfo m = NetInfo+ { _listeners :: Listeners m+ , _randSeed :: StdGen+ , _delays :: Delays+ }++$(makeLenses ''NetInfo)++-- | Implementation of RPC protocol for emulation, allows to manually define+-- network nastiness via `Delays` datatype. TCP model is used.+--+-- List of known issues:+--+-- * Method, once being declared in net, can't be removed.+-- Even `throwTo` won't help.+--+-- * In implementation, remote method is actually inlined at call position,+-- so @instance WithNamedLogger@ would refer to caller's logger name, not+-- server's one.+newtype PureRpc m a = PureRpc+ { unwrapPureRpc :: TimedT (StateT (NetInfo (PureRpc m)) m) a+ } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch,+ MonadMask, WithNamedLogger)++type instance ThreadId (PureRpc m) = PureThreadId++deriving instance (MonadIO m, MonadCatch m) => MonadTimed (PureRpc m)++instance MonadTrans PureRpc where+ lift = PureRpc . lift . lift++instance MonadState s m => MonadState s (PureRpc m) where+ get = lift get+ put = lift . put+ state = lift . state++-- | Launches distributed scenario, emulating work of network.+runPureRpc+ :: (MonadIO m, MonadCatch m, DelaysSpecifier delays)+ => StdGen -> delays -> PureRpc m a -> m a+runPureRpc _randSeed (toDelays -> _delays) rpc =+ evalStateT (runTimedT $ unwrapPureRpc rpc) net+ where+ net = NetInfo{..}+ _listeners = Map.empty++request :: (MonadThrow m, MessagePack a)+ => Client a+ -> Listeners (PureRpc m)+ -> Port+ -> PureRpc m a+request (Client name args) listeners' port =+ case Map.lookup (port, name) listeners' of+ Nothing -> throwM $ ServerError $ toObject $ mconcat+ ["method \"", name, "\" not found at port ", show port]+ Just f -> do+ res <- f args+ case fromObject res of+ Nothing -> throwM $ ResultTypeError "type mismatch" res+ Just r -> return r+++instance (MonadIO m, MonadCatch m) =>+ MonadRpc (PureRpc m) where+ execClient addr@(host, port) cli =+ if host /= localhost+ then+ error "Can't emulate for host /= localhost"+ else do+ waitDelay addr+ ls <- PureRpc $ use listeners+ request cli ls port+ serve port methods =+ PureRpc $+ do lift $+ forM_ methods $+ \Method {..} -> do+ let methodRef = (port, methodName)+ defined <- use $ listeners . to (Map.member methodRef)+ when defined $ return ()+ -- TODO:+ -- throwM $ PortAlreadyBindedError port+ listeners . at (port, methodName) ?= methodBody+ sleepForever++waitDelay+ :: (MonadThrow m, MonadIO m, MonadCatch m)+ => NetworkAddress -> PureRpc m ()+waitDelay addr =+ PureRpc $+ do delays' <- use delays+ time <- virtualTime+ delay <- randSeed %%= runRand (evalDelay delays' addr time)+ case delay of+ ConnectedIn connDelay -> wait (for connDelay)+ NeverConnected -> sleepForever++data PortAlreadyBindedError = PortAlreadyBindedError Port+ deriving (Show, Typeable)++instance Exception PortAlreadyBindedError
+ src/Control/TimeWarp/Rpc/Restriction.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE Rank2Types #-}++-- |+-- Module : Control.TimeWarp.Rpc.Restriction+-- Copyright : (c) Serokell, 2016+-- License : GPL-3 (see the file LICENSE)+-- Maintainer : Serokell <hi@serokell.io>+-- Stability : experimental+-- Portability : POSIX, GHC+--+-- This module helps abstragate from concrete instance of+-- `Control.TimeWarp.Rpc.MonadRpc`.+--+-- Consider such example:+--+-- @+-- sumMethod :: MonadRpc m => Int -> Int -> ServerT m Int+-- sumMethod a b = return $ a + b+--+-- startServer :: MonadRpc m => m ()+-- startServer = serve 1234 [method "sum" sumMethod]+-- @+--+-- This code won't compile, because compiler doesn't know that type @m@+-- in @sumMethod@ is the same @m@ as in @startServer@, so it can't apply+-- 'Control.TimeWarp.Rpc.MonadRpc.method' to @sumMethod@+-- (`Network.MessagePack.Server.MethodType` won't be deduced).+--+-- Functions @restrictServerType/N/@, where /N/ is method's arguments number,+-- help to bound the type. They are all defined like @return id@.+--+-- So the error above can be fixed in following way:+--+-- @+-- startServer :: MonadRpc m => m ()+-- startServer = do+-- idr <- restrictServerType2+-- serve 1234 [method "sum" $ idr sumMethod]+-- @++module Control.TimeWarp.Rpc.Restriction where++import Control.TimeWarp.Rpc.MonadRpc (ServerT)++type ServerRestriction m t = m (t -> t)++serverTypeRestriction0 ::+ Monad m => ServerRestriction m (ServerT m a)+serverTypeRestriction0 = return id++serverTypeRestriction1 ::+ Monad m => ServerRestriction m (b -> ServerT m a)+serverTypeRestriction1 = return id++serverTypeRestriction2 ::+ Monad m => ServerRestriction m (c -> b -> ServerT m a)+serverTypeRestriction2 = return id++serverTypeRestriction3 ::+ Monad m => ServerRestriction m (d -> c -> b -> ServerT m a)+serverTypeRestriction3 = return id++serverTypeRestriction4 ::+ Monad m => ServerRestriction m (e -> d -> c -> b -> ServerT m a)+serverTypeRestriction4 = return id++serverTypeRestriction5 ::+ Monad m => ServerRestriction m (f -> e -> d -> c -> b -> ServerT m a)+serverTypeRestriction5 = return id
+ src/Control/TimeWarp/Timed.hs view
@@ -0,0 +1,52 @@+-- |+-- Module : Control.TimeWarp.Timed+-- Copyright : (c) Serokell, 2016+-- License : GPL-3 (see the file LICENSE)+-- Maintainer : Serokell <hi@serokell.io>+-- Stability : experimental+-- Portability : POSIX, GHC+--+-- This module provides time- and thread-management capabilities.+-- It allows to write scenarios over multithreaded systems, which can+-- then be launched as either real program or emulation with no need+-- to wait for delays.+--+-- Example:+--+-- @+-- example :: MonadTimed m => m ()+-- example = do+-- schedule (at 10 minute) $ do+-- time <- toMicroseconds \<\$\> virtualTime+-- liftIO $ putStrLn $ \"Hello! It's \" ++ show time ++ " now"+-- wait (for 9 minute)+-- liftIO $ putStrLn \"One more minute...\"+-- @+--+-- Such scenario can be launched in real mode using+--+-- >>> runTimedIO example+-- <9 minutes passed>+-- One more minute...+-- <1 more minute passed>+-- Hello! It's 600000000µs now+--+-- and like emulation via+--+-- >>> runTimedT example+-- One more minute...+-- Hello! It's 600000000µs now+--+-- which works on the spot.++module Control.TimeWarp.Timed+ ( module Control.TimeWarp.Timed.MonadTimed+ , module Control.TimeWarp.Timed.TimedIO+ , module Control.TimeWarp.Timed.TimedT+ , module Control.TimeWarp.Timed.Misc+ ) where++import Control.TimeWarp.Timed.Misc+import Control.TimeWarp.Timed.MonadTimed+import Control.TimeWarp.Timed.TimedIO+import Control.TimeWarp.Timed.TimedT
+ src/Control/TimeWarp/Timed/Misc.hs view
@@ -0,0 +1,51 @@+-- | `MonadTimed` related helper functions.++module Control.TimeWarp.Timed.Misc+ ( repeatForever+ , sleepForever+ ) where++import Control.Concurrent.STM.TVar (newTVarIO, readTVarIO, writeTVar)+import Control.Exception.Base (SomeException)+import Control.Monad (forever)+import Control.Monad.Catch (MonadCatch, catch)+import Control.Monad.STM (atomically)+import Control.Monad.Trans (MonadIO, liftIO)++import Control.TimeWarp.Timed.MonadTimed (Microsecond, MonadTimed, for, fork_,+ minute, ms, startTimer, wait)++-- | Repeats an action periodically.+-- If it fails, handler is invoked, determining delay before retrying.+-- Can be interrupted with asynchronous exception.+repeatForever+ :: (MonadTimed m, MonadIO m, MonadCatch m)+ => Microsecond -- ^ Period between action launches+ -> (SomeException -> m Microsecond) -- ^ What to do on exception,+ -- returns delay before retrying+ -> m () -- ^ Action+ -> m ()+repeatForever period handler action = do+ timer <- startTimer+ nextDelay <- liftIO $ newTVarIO Nothing+ fork_ $+ let setNextDelay = liftIO . atomically . writeTVar nextDelay . Just+ action' =+ action >> timer >>= \passed -> setNextDelay (period - passed)+ handler' e = handler e >>= setNextDelay+ in action' `catch` handler'+ waitForRes nextDelay+ where+ continue = repeatForever period handler action+ waitForRes nextDelay = do+ wait $ for 10 ms+ res <- liftIO $ readTVarIO nextDelay+ case res of+ Nothing -> waitForRes nextDelay+ Just t -> wait (for t) >> continue++-- | Sleep forever.++-- TODO: would be better to use `MVar` to block thread+sleepForever :: MonadTimed m => m ()+sleepForever = forever $ wait (for 100500 minute)
+ src/Control/TimeWarp/Timed/MonadTimed.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Control.TimeWarp.Timed.MonadTimed+-- Copyright : (c) Serokell, 2016+-- License : GPL-3 (see the file LICENSE)+-- Maintainer : Serokell <hi@serokell.io>+-- Stability : experimental+-- Portability : POSIX, GHC+--+-- This module defines typeclass `MonadTimed` with basic functions+-- to manipulate time and threads.+module Control.TimeWarp.Timed.MonadTimed+ ( -- * Typeclass with basic functions+ MonadTimed (..)+ , ThreadId+ , RelativeToNow+ -- * Helper functions+ , schedule, invoke, timestamp, fork_, work, killThread+ , startTimer+ -- ** Time measures+ , hour , minute , sec , ms , mcs+ , hour', minute', sec', ms', mcs'+ -- ** Time specifiers+ -- $timespec+ , for, after, till, at, now+ , interval, timepoint+ -- * Time types+ -- | Re-export of Data.Time.Units.Microsecond+ , Microsecond+ -- | Re-export of Data.Time.Units.Millisecond+ , Millisecond+ -- | Re-export of Data.Time.Units.Second+ , Second+ -- | Re-export of Data.Time.Units.Minute+ , Minute+ -- * Time accumulators+ -- $timeacc+ , TimeAccR+ , TimeAccM+ -- * Exceptions+ , MonadTimedError (..)+ ) where++import Control.Exception (AsyncException (ThreadKilled), Exception (..))+import Control.Monad (void)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.Reader (ReaderT (..), ask, runReaderT)+import Control.Monad.State (StateT, evalStateT, get)+import Control.Monad.Trans (MonadIO, lift, liftIO)++import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Text.Buildable (Buildable (build))+import Data.Time.Units (Microsecond, Millisecond, Minute, Second,+ TimeUnit (..), convertUnit)+import Data.Typeable (Typeable)++import Control.TimeWarp.Logging (LoggerNameBox (..))++-- | Defines some time point basing on current virtual time.+type RelativeToNow = Microsecond -> Microsecond++-- | Is arisen on call of `timeout` if action wasn't executed in time.+data MonadTimedError+ = MTTimeoutError Text+ deriving (Show, Typeable)++instance Exception MonadTimedError++instance Buildable MonadTimedError where+ build (MTTimeoutError t) = "timeout error: " <> build t++-- | Allows time management. Time is specified in microseconds passed+-- from launch point (/origin/), this time is further called /virtual time/.+--+-- Instance of MonadTimed should satisfy the following law:+--+-- * when defining instance of MonadTrans for a monad,+-- information stored inside the transformer should be tied to thread, and+-- get cloned on `fork`s.+--+-- For example,+-- @instance MonadTimed m => MonadTimed (StateT s m)@+-- is declared such that:+--+-- @+-- example :: (MonadTimed m, MonadIO m) => StateT Int m ()+-- example = do+-- put 1+-- fork $ put 10 -- main thread won't be touched+-- wait $ for 1 sec -- wait for forked thread to execute+-- liftIO . print =<< get+-- @+--+-- >>> runTimedT $ runStateT undefined example+-- 1+--+-- When implement instance of this typeclass, don't forget to define `ThreadId`+-- first.+++class MonadThrow m => MonadTimed m where+ -- | Acquires virtual time.+ virtualTime :: m Microsecond++ -- | Waits for specified amount of time.+ --+ -- Use `for` to specify relative virtual time (counting from now),+ -- and `till` for absolute one.+ --+ -- >>> runTimedT $ wait (for 1 sec) >> wait (for 5 sec) >> timestamp "now"+ -- [6000000µs] now+ -- >>> runTimedT $ wait (for 1 sec) >> wait (till 5 sec) >> timestamp "now"+ -- [5000000µs] now+ -- >>> runTimedT $ wait (for 10 minute 34 sec 52 ms) >> timestamp "now"+ -- [634052000µs] now+ wait :: RelativeToNow -> m ()++ -- | Creates another thread of execution, with same point of origin.+ fork :: m () -> m (ThreadId m)++ -- | Acquires current thread id.+ myThreadId :: m (ThreadId m)++ -- | Arises specified exception in specified thread.+ throwTo :: Exception e => ThreadId m -> e -> m ()++ -- | Throws a `MTTimeoutError` exception+ -- if running action exceeds specified time.+ timeout :: TimeUnit t => t -> m a -> m a++-- | Type of thread identifier.+type family ThreadId (m :: * -> *) :: *++-- | Executes an action somewhere in future in another thread.+-- Use `after` to specify relative virtual time (counting from now),+-- and `at` for absolute one.+--+-- @+-- schedule time action ≡ fork_ $ wait time >> action+-- @+--+-- @+-- example :: (MonadTimed m, MonadIO m) => m ()+-- example = do+-- wait (for 10 sec)+-- schedule (after 3 sec) $ timestamp "This would happen at 13 sec"+-- schedule (at 15 sec) $ timestamp "This would happen at 15 sec"+-- timestamp "And this happens immediately after start"+-- @+schedule :: MonadTimed m => RelativeToNow -> m () -> m ()+schedule time action = fork_ $ invoke time action++-- | Executes an action at specified time in current thread.+-- Use `after` to specify relative virtual time (counting from now),+-- and `at` for absolute one.+--+-- @+-- invoke time action ≡ wait time >> action+-- @+--+-- @+-- example :: (MonadTimed m, MonadIO m) => m ()+-- example = do+-- wait (for 10 sec)+-- invoke (after 3 sec) $ timestamp "This would happen at 13 sec"+-- invoke (after 3 sec) $ timestamp "This would happen at 16 sec"+-- invoke (at 20 sec) $ timestamp "This would happen at 20 sec"+-- timestamp "This also happens at 20 sec"+-- @+invoke :: MonadTimed m => RelativeToNow -> m a -> m a+invoke time action = wait time >> action++-- | Prints current virtual time. For debug purposes.+--+-- >>> runTimedT $ wait (for 1 mcs) >> timestamp "Look current time here"+-- [1µs] Look current time here+timestamp :: (MonadTimed m, MonadIO m) => String -> m ()+timestamp msg = virtualTime >>= \time -> liftIO . putStrLn $+ concat [ "[", show time, "] ", msg ]++-- | Similar to `fork`, but doesn't return a result.+fork_ :: MonadTimed m => m () -> m ()+fork_ = void . fork++-- | Creates a thread, which works for specified amount of time, and then gets+-- `killThread`ed.+-- Use `for` to specify relative virtual time (counting from now),+-- and `till` for absolute one.+work :: MonadTimed m => RelativeToNow -> m () -> m ()+work rel act = fork act >>= schedule rel . killThread++-- | Arises `ThreadKilled` exception in specified thread+killThread :: MonadTimed m => ThreadId m -> m ()+killThread = flip throwTo ThreadKilled++type instance ThreadId (ReaderT r m) = ThreadId m++instance MonadTimed m => MonadTimed (ReaderT r m) where+ virtualTime = lift virtualTime++ wait = lift . wait++ fork m = lift . fork . runReaderT m =<< ask++ myThreadId = lift myThreadId++ throwTo tid = lift . throwTo tid++ timeout t m = lift . timeout t . runReaderT m =<< ask++type instance ThreadId (StateT s m) = ThreadId m++instance MonadTimed m => MonadTimed (StateT s m) where+ virtualTime = lift virtualTime++ wait = lift . wait++ fork m = lift . fork . evalStateT m =<< get++ myThreadId = lift myThreadId++ throwTo tid = lift . throwTo tid++ timeout t m = lift . timeout t . evalStateT m =<< get++type instance ThreadId (LoggerNameBox m) = ThreadId m++deriving instance MonadTimed m => MonadTimed (LoggerNameBox m)++-- | Converts a specified time to `Microsecond`.+mcs, ms, sec, minute, hour :: Int -> Microsecond+mcs = fromMicroseconds . fromIntegral+ms = fromMicroseconds . fromIntegral . (*) 1000+sec = fromMicroseconds . fromIntegral . (*) 1000000+minute = fromMicroseconds . fromIntegral . (*) 60000000+hour = fromMicroseconds . fromIntegral . (*) 3600000000++-- | Converts a specified fractional time to `Microsecond`.+mcs', ms', sec', minute', hour' :: Double -> Microsecond+mcs' = fromMicroseconds . round+ms' = fromMicroseconds . round . (*) 1000+sec' = fromMicroseconds . round . (*) 1000000+minute' = fromMicroseconds . round . (*) 60000000+hour' = fromMicroseconds . round . (*) 3600000000++-- $timespec+-- Following functions are used together with time-controlling functions+-- (`wait`, `invoke` and others) and serve for two reasons:+--+-- (1) Defines, whether time is counted from /origin point/ or+-- current time point.+--+-- (2) Allow different ways to specify time+-- (see <./Control-TimeWarp-Timed-MonadTimed.html#timeacc Time accumulators>)++at, till :: TimeAccR t => t+-- | Defines `RelativeToNow`, which refers to time point determined by specified+-- virtual time.+-- Supposed to be used with `wait` and `work`.+till = till' 0+-- | Synonym to `till`. Supposed to be used with `invoke` and `schedule`.+at = till' 0++after, for :: TimeAccR t => t+-- | Defines `RelativeToNow`, which refers to time point in specified time after+-- current time point.+-- Supposed to be used with `wait` and `work`.+for = for' 0+-- | Synonym to `for`. Supposed to be used with `invoke` and `schedule`.+after = for' 0++-- | Refers to current time point.+--+-- >>> runTimedT $ invoke now $ timestamp ""+-- [0µs]+now :: RelativeToNow+now = id++-- | Counts time since outer monad layer was unwrapped.+--+-- @+-- example :: (MonadTimed m, MonadIO m) => m ()+-- example = do+-- wait (for 10 sec)+-- timer <- startTimer+-- wait (for 5 ms)+-- passedTime <- timer+-- liftIO . print $ passedTime+-- @+--+-- >>> runTimedT example+-- 5000µs+startTimer :: MonadTimed m => m (m Microsecond)+startTimer = do+ start <- virtualTime+ return $ subtract start <$> virtualTime++-- | Returns a time in microseconds.+--+-- >>> print $ interval 1 sec+-- 1000000µs+interval :: TimeAccM t => t+interval = interval' 0++-- | Synonym to `interval`. May be more preferable in some situations.+timepoint :: TimeAccM t => t+timepoint = interval++-- * Time accumulators+-- $timeacc+-- #timeacc#+-- Time accumulators allow to specify time in pretty complicated ways.+--+-- * Some of them can accept `TimeUnit`, which fully defines result.+--+-- @+-- for (5 :: Minute)+-- @+--+-- * They can accept several numbers with time measures, which would be sumarized.+--+-- @+-- for 1 minute 15 sec 10 mcs+-- for 1.2 minute'+-- @++-- | Time accumulator, which evaluates to `RelativeToNow`.+-- It's implementation is intentionally not visible from this module.+class TimeAccR t where+ till' :: Microsecond -> t+ for' :: Microsecond -> t++instance TimeAccR RelativeToNow where+ till' = const+ for' = (+)++instance (a ~ b, TimeAccR t) => TimeAccR (a -> (b -> Microsecond) -> t) where+ till' acc t f = till' $ f t + acc+ for' acc t f = for' $ f t + acc++instance TimeUnit t => TimeAccR (t -> RelativeToNow) where+ till' acc t _ = acc + convertUnit t+ for' acc t cur = acc + convertUnit t + cur++-- | Time accumulator, which evaluates to `Microsecond`.+-- It's implementation is intentionally not visible from this module.+class TimeAccM t where+ interval' :: Microsecond -> t++instance TimeAccM Microsecond where+ interval' = id++instance (a ~ b, TimeAccM t) => TimeAccM (a -> (b -> Microsecond) -> t) where+ interval' acc t f = interval' $ f t + acc
+ src/Control/TimeWarp/Timed/TimedIO.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Control.TimeWarp.Timed.TimedIO+-- Copyright : (c) Serokell, 2016+-- License : GPL-3 (see the file LICENSE)+-- Maintainer : Serokell <hi@serokell.io>+-- Stability : experimental+-- Portability : POSIX, GHC+--+-- Real-mode implementation of `MonadTimed`.+-- Each function in inplementation refers to plain `IO`.++module Control.TimeWarp.Timed.TimedIO+ ( TimedIO+ , runTimedIO+ ) where++import qualified Control.Concurrent as C+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadCatch, MonadMask,+ MonadThrow, throwM)+import Control.Monad.Reader (ReaderT (..), ask,+ runReaderT)+import Control.Monad.Trans (MonadIO, lift, liftIO)+import Control.Monad.Trans.Control (MonadBaseControl, StM,+ liftBaseWith, restoreM)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Time.Units (toMicroseconds)+import qualified System.Timeout as T++import Control.TimeWarp.Timed.MonadTimed (Microsecond,+ MonadTimed (..),+ ThreadId,+ MonadTimedError+ (MTTimeoutError))++-- | Default implementation for `IO`, i.e. real mode.+-- `wait` refers to `Control.Concurrent.threadDelay`,+-- `fork` refers to `Control.Concurrent.forkIO`, and so on.+newtype TimedIO a = TimedIO+ { -- Reader's environment stores the /origin/ point and logger name for+ -- `WithNamedLogger` instance.+ getTimedIO :: ReaderT Microsecond IO a+ } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch,+ MonadBase IO, MonadMask)++instance MonadBaseControl IO TimedIO where+ type StM TimedIO a = a++ liftBaseWith f = TimedIO $ liftBaseWith $ \g -> f $ g . getTimedIO++ restoreM = TimedIO . restoreM++type instance ThreadId TimedIO = C.ThreadId++instance MonadTimed TimedIO where+ virtualTime = TimedIO $ (-) <$> lift curTime <*> ask++ wait relativeToNow = do+ cur <- virtualTime+ liftIO $ C.threadDelay $ fromIntegral $ relativeToNow cur - cur++ fork (TimedIO a) = TimedIO $ lift . C.forkIO . runReaderT a =<< ask++ myThreadId = TimedIO $ lift $ C.myThreadId++ throwTo tid e = TimedIO $ lift $ C.throwTo tid e++ timeout (toMicroseconds -> t) (TimedIO action) = TimedIO $ do+ res <- liftIO . T.timeout (fromIntegral t) . runReaderT action =<< ask+ maybe (throwM $ MTTimeoutError "Timeout has exceeded") return res++-- | Launches scenario using real time and threads.+runTimedIO :: TimedIO a -> IO a+runTimedIO = (curTime >>= ) . runReaderT . getTimedIO++curTime :: IO Microsecond+curTime = round . ( * 1000000) <$> getPOSIXTime
+ src/Control/TimeWarp/Timed/TimedT.hs view
@@ -0,0 +1,381 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Control.TimeWarp.Timed.TimedT+-- Copyright : (c) Serokell, 2016+-- License : GPL-3 (see the file LICENSE)+-- Maintainer : Serokell <hi@serokell.io>+-- Stability : experimental+-- Portability : POSIX, GHC+--+-- This module contains pure implementation of MonadTimed.+module Control.TimeWarp.Timed.TimedT+ ( TimedT+ , PureThreadId+ , runTimedT+ , defaultLoggerName+ ) where++import Control.Applicative ((<|>))+import Control.Exception.Base (AsyncException (ThreadKilled),+ Exception (fromException),+ SomeException (..))++import Control.Lens (makeLenses, use, view, (%=), (%~),+ (&), (.=), (<&>), (^.), at, (<<.=),+ (<<+=), (.~))+import Control.Monad (void, unless)+import Control.Monad.Catch (Handler (..), MonadCatch, MonadMask,+ MonadThrow, catch, catchAll, catches,+ mask, throwM, try, finally,+ uninterruptibleMask)+import Control.Monad.Cont (ContT (..), runContT)+import Control.Monad.Loops (whileM_)+import Control.Monad.Reader (ReaderT (..), ask, runReaderT, local)+import Control.Monad.State (MonadState (get, put, state), StateT,+ evalStateT)+import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO)+import Data.Function (on)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.List (foldl')+import Data.Ord (comparing)+import Formatting (sformat, shown, (%))++import qualified Data.Map as M+import qualified Data.PQueue.Min as PQ+import Safe (fromJustNote)++import Control.TimeWarp.Logging (WithNamedLogger (..), LoggerName,+ logDebug, logWarning)+import Control.TimeWarp.Timed.MonadTimed (Microsecond,+ MonadTimed (..),+ MonadTimedError (MTTimeoutError), for,+ virtualTime, mcs,+ timeout, ThreadId, schedule, after)++-- Summary, `TimedT` (implementation of emulation mode) consists of several+-- layers (from outer to inner):+-- * ReaderT ThreadCtx -- keeps tied-to-thread information+-- * ContT -- allows to extract not-yet-executed part of thread+ -- to perform it later+-- * StateT Scenario -- keeps global information of emulation++-- | Analogy to `Control.Concurrent.ThreadId` for emulation.+newtype PureThreadId = PureThreadId Integer+ deriving (Eq, Ord)++instance Show PureThreadId where+ show (PureThreadId tid) = "PureThreadId " ++ show tid++-- | Private context for each pure thread+data ThreadCtx c = ThreadCtx+ { -- | Thread id+ _threadId :: PureThreadId+ -- | Exception handlers stack. First is original handler,+ -- second is for continuation handler+ , _handlers :: [(Handler c (), Handler c ())]+ -- | Logger name for `WithNamedLogger` instance+ , _loggerName :: LoggerName+ }++$(makeLenses ''ThreadCtx)++-- | Timestamped action+data Event m c = Event+ { _timestamp :: Microsecond+ , _action :: m ()+ , _threadCtx :: ThreadCtx c+ }++$(makeLenses ''Event)++instance Eq (Event m c) where+ (==) = (==) `on` _timestamp++instance Ord (Event m c) where+ compare = comparing _timestamp++-- | Overall state for MonadTimed+data Scenario m c = Scenario+ { -- | Set of sleeping threads+ _events :: PQ.MinQueue (Event m c)+ -- | Current virtual time+ , _curTime :: Microsecond+ -- | For each thread, exception which has been thrown to it (if any has)+ , _asyncExceptions :: M.Map PureThreadId SomeException+ -- | Number of created threads ever+ , _threadsCounter :: Integer+ }++$(makeLenses ''Scenario)++emptyScenario :: Scenario m c+emptyScenario =+ Scenario+ { _events = PQ.empty+ , _curTime = 0+ , _asyncExceptions = M.empty+ , _threadsCounter = 0+ }++-- | Heart of TimedT monad+newtype Core m a = Core+ { getCore :: StateT (Scenario (TimedT m) (Core m)) m a+ } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow,+ MonadCatch, MonadMask,+ MonadState (Scenario (TimedT m) (Core m)))++instance MonadTrans Core where+ lift = Core . lift++-- Threads are emulated, whole execution takes place in a single thread.+-- This allows to execute whole scenarios on the spot.+--+-- Each action is considered 0-cost in performance, the only way to change+-- current virtual time is to call `wait` or derived function.+--+-- Note, that monad inside TimedT transformer is shared between all threads.+newtype TimedT m a = TimedT+ { unwrapTimedT :: ReaderT (ThreadCtx (Core m))+ ( ContT ()+ ( Core m )+ ) a+ } deriving (Functor, Applicative, Monad, MonadIO)++-- | When non-main thread dies from uncaught exception, this is reported via+-- logger (see `WithNamedLogger`). `ThreadKilled` exception is reported with+-- `Control.TimeWarp.Logging.Debug` severity, and other exceptions with+-- `Control.TimeWarp.Logging.Warn` severity.+-- Uncaught exception in main thread (the one isn't produced by `fork`)+-- is propagaded outside of the monad.+instance MonadThrow m => MonadThrow (TimedT m) where+ -- docs for derived instance declarations are not supported yet :(+ throwM = TimedT . throwM++instance MonadTrans TimedT where+ lift = TimedT . lift . lift . lift++instance MonadState s m => MonadState s (TimedT m) where+ get = lift get+ put = lift . put+ state = lift . state++instance WithNamedLogger (TimedT m) where+ getLoggerName = TimedT $ view loggerName++ modifyLoggerName how = TimedT . local (loggerName %~ how) . unwrapTimedT++newtype ContException = ContException SomeException+ deriving (Show)++instance Exception ContException++instance MonadCatch m => MonadCatch (TimedT m) where+ catch m handler =+ TimedT $+ ReaderT $+ \r ->+ ContT $+ -- Types allow us to catch only from (m + its continuation).+ -- Thus, we should avoid handling exception from continuation.+ -- It's achieved by handling any exception from continuation+ -- and rethrowing it being wrapped into ContException.+ -- Then, any catch handler should first check for ContException.+ -- If it's caught, rethrow exception inside ContException,+ -- otherwise handle any possible normal exception+ \c ->+ let safeCont x = c x `catchAll` (throwM . ContException)+ r' = r & handlers %~ (:) (Handler handler', contHandler)+ act = unwrapCore' r' $ m >>= wrapCore . safeCont+ handler' e = unwrapCore' r $ handler e >>= wrapCore . c+ in act `catches` [contHandler, Handler handler']++contHandler :: MonadThrow m => Handler m ()+contHandler = Handler $ \(ContException e) -> throwM e++-- | This instance is incorrect, i.e. `mask` and `uninterruptibleMask` do+-- nothing for now.+instance (MonadIO m, MonadCatch m) => MonadMask (TimedT m) where+ mask a = a id+ uninterruptibleMask = mask++wrapCore :: Monad m => Core m a -> TimedT m a+wrapCore = TimedT . lift . lift++unwrapCore :: ThreadCtx (Core m)+ -> (a -> Core m ())+ -> TimedT m a+ -> Core m ()+unwrapCore r c = flip runContT c+ . flip runReaderT r+ . unwrapTimedT++unwrapCore' :: Monad m => ThreadCtx (Core m) -> TimedT m () -> Core m ()+unwrapCore' r = unwrapCore r return++getTimedT :: Monad m => TimedT m a -> m ()+getTimedT t = flip evalStateT emptyScenario+ $ getCore+ $ unwrapCore vacuumCtx (void . return) t+ where+ vacuumCtx = error "Access to thread context from nowhere"++-- | Launches all the machinery of emulation.+launchTimedT :: (MonadIO m, MonadCatch m) => TimedT m () -> m ()+launchTimedT timed = getTimedT $ do+ -- execute first action (main thread)+ mainThreadCtx >>= flip runInSandbox timed+ -- event loop+ whileM_ notDone $ do+ -- take next awaiting thread+ nextEv <- wrapCore . Core $ do+ (ev, evs') <- fromJustNote "Suddenly no more events" . PQ.minView+ <$> use events+ events .= evs'+ return ev+ -- rewind current time+ TimedT $ curTime .= nextEv ^. timestamp+ -- get some thread info+ let ctx = nextEv ^. threadCtx+ tid = ctx ^. threadId+ -- extract possible exception thrown+ maybeAsyncExc <- TimedT $ asyncExceptions . at tid <<.= Nothing++ let act = do+ -- die if received async exception+ mapM_ throwInnard maybeAsyncExc+ -- execute thread+ runInSandbox ctx (nextEv ^. action)+ -- catch with handlers from handlers stack+ -- `catch` which is performed in instance MonadCatch is not enough,+ -- because on `wait` `catch`'s scope finishes, we need to catch+ -- again here+ wrapCore $ (unwrapCore' ctx act) `catchesSeq` (ctx ^. handlers)++ where+ notDone :: Monad m => TimedT m Bool+ notDone = not . PQ.null <$> TimedT (use events)++ -- put empty continuation to an action (not our own!)+ runInSandbox r = wrapCore . unwrapCore' r++ mainThreadCtx = getNextThreadId <&>+ \tid ->+ ThreadCtx+ { _threadId = tid+ , _handlers = [( Handler throwInnard+ , contHandler+ )]+ , _loggerName = defaultLoggerName+ }++ -- Apply all handlers from stack.+ -- In each layer (pair of handlers), ContException should be handled first.+ catchesSeq = foldl' $ \act (h, hc) -> act `catches` [hc, h]++ throwInnard (SomeException e) = throwM e++getNextThreadId :: Monad m => TimedT m PureThreadId+getNextThreadId = TimedT . fmap PureThreadId $ threadsCounter <<+= 1++-- | Launches the scenario emulating threads and time.+-- Finishes when no more active threads remain.+runTimedT+ :: (MonadIO m, MonadCatch m)+ => TimedT m a -> m a+runTimedT timed = do+ -- use `launchTimedT`, extracting result+ ref <- liftIO $ newIORef Nothing+ launchTimedT $ do+ m <- try timed+ liftIO . writeIORef ref . Just $ m+ res :: Either SomeException a <- fromJustNote "runTimedT: no result"+ <$> liftIO (readIORef ref)+ either throwM return res++isThreadKilled :: SomeException -> Bool+isThreadKilled = maybe False (== ThreadKilled) . fromException++threadKilledNotifier+ :: (MonadIO m, WithNamedLogger m)+ => SomeException -> m ()+threadKilledNotifier e+ | isThreadKilled e = logDebug msg+ | otherwise = logWarning msg+ where+ msg = sformat ("Thread killed by exception: " % shown) e++type instance ThreadId (TimedT m) = PureThreadId++instance (MonadIO m, MonadThrow m, MonadCatch m) =>+ MonadTimed (TimedT m) where+ virtualTime = TimedT $ use curTime+ -- | Take note, created thread may be killed by async exception+ -- only when it calls "wait"+ fork act+ -- just put new thread to event queue+ = do+ _timestamp <- virtualTime+ tid <- getNextThreadId+ logName <- getLoggerName+ let _threadCtx =+ ThreadCtx+ { _threadId = tid+ , _handlers = []+ -- [( Handler threadKilledNotifier+ -- , contHandler+ -- )]+ , _loggerName = logName+ }+ _action = act `catch` threadKilledNotifier+ TimedT $ events %= PQ.insert Event {..}+ wait $ for 1 mcs -- real `forkIO` seems to yield execution+ -- to newly created thread+ return tid+ wait relativeToNow = do+ cur <- virtualTime+ ctx <- TimedT ask+ let event following =+ Event+ { _threadCtx = ctx+ , _timestamp = max cur (relativeToNow cur)+ , _action = wrapCore following+ }+ -- grab our continuation, put it to event queue+ -- and finish execution+ TimedT . lift . ContT $+ \c -> events %= PQ.insert (event $ c ())+ myThreadId = TimedT $ view threadId+ throwTo tid e = do+ wakeUpThread+ TimedT $ asyncExceptions . at tid %= (<|> Just (SomeException e))+ where+ -- TODO: make more efficient+ wakeUpThread = TimedT $ do+ time <- use curTime+ let modifyRequired event =+ if event ^. threadCtx . threadId == tid+ then event & timestamp .~ time+ else event+ events %= PQ.fromList . map modifyRequired . PQ.toList++ timeout t action' = do+ pid <- myThreadId+ done <- liftIO $ newIORef False+ schedule (after t) $+ (liftIO (readIORef done) >>=) . flip unless $+ throwTo pid $ MTTimeoutError "Timeout exceeded"+ action' `finally` liftIO (writeIORef done True)++-- | Name which is used by logger (see `WithNamedLogger`) if no other one was specified.+defaultLoggerName :: LoggerName+defaultLoggerName = "emulation"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ test/Test.hs view
@@ -0,0 +1,5 @@+import Spec (spec)+import Test.Hspec (hspec)++main :: IO ()+main = hspec spec
+ test/Test/Control/TimeWarp/Common.hs view
@@ -0,0 +1,41 @@+-- | Common code.++module Test.Control.TimeWarp.Common+ (+ ) where++import Data.Time.Units (TimeUnit, convertUnit,+ fromMicroseconds)+import Test.QuickCheck (Arbitrary (arbitrary), choose)+import System.Random (StdGen, mkStdGen)++import Control.TimeWarp.Logging (WithNamedLogger (..))+import qualified Control.TimeWarp.Timed.MonadTimed as T+++instance WithNamedLogger IO where+ getLoggerName = pure "TimeWarp tests"++ modifyLoggerName = const id+++-- * Usefull arbitraries++convertMicroSecond :: TimeUnit t => T.Microsecond -> t+convertMicroSecond = convertUnit++instance Arbitrary T.Microsecond where+ -- no more than 10 minutes+ arbitrary = fromMicroseconds <$> choose (0, 600 * 1000 * 1000)++instance Arbitrary T.Millisecond where+ arbitrary = convertMicroSecond <$> arbitrary++instance Arbitrary T.Second where+ arbitrary = convertMicroSecond <$> arbitrary++instance Arbitrary T.Minute where+ arbitrary = convertMicroSecond <$> arbitrary++instance Arbitrary StdGen where+ arbitrary = mkStdGen <$> arbitrary
+ test/Test/Control/TimeWarp/Rpc/MonadRpcSpec.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE ViewPatterns #-}++-- | RSCoin.Test.MonadRpc specification++module Test.Control.TimeWarp.Rpc.MonadRpcSpec+ ( spec+ ) where++import Control.Monad.State (StateT, execStateT, modify)+import Network.MessagePack.Server (ServerT)+import Test.Hspec (Spec, describe, runIO)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Property, Testable (property),+ ioProperty)+import Test.QuickCheck.Monadic (PropertyM, assert, monadic, run)++import Control.TimeWarp.Rpc (Client (..), Host, MonadRpc (..),+ MsgPackRpc, NetworkAddress,+ Port, PureRpc, call, method,+ runMsgPackRpc, runPureRpc)+import Control.TimeWarp.Timed (for, fork, fork_, killThread, ms,+ wait, Microsecond)++import Test.Control.TimeWarp.Common ()++spec :: Spec+spec =+ describe "MonadRpc" $ do+ describe "MsgPackRpc" $+ describe "msgpack-rpc based implementation of RPC layer" $ do+ runIO $ runMsgPackRpc (fork_ server)+ prop "client should be able to execute server method" $+ runMsgPackRpcProp serverMethodShouldExecuteSimpleSpec+ describe "PureRpc" $+ describe "pure implementation of RPC layer" $+ prop "client should be able to execute server method" $+ runPureRpcProp serverMethodShouldExecuteSimplePureSpec++type MsgPackRpcProp = PropertyM MsgPackRpc+type PureRpcProp = PureRpc (StateT Bool IO)++assertPure :: Bool -> PureRpcProp ()+assertPure b = modify (b &&)++runMsgPackRpcProp :: MsgPackRpcProp () -> Property+runMsgPackRpcProp = monadic $ ioProperty . runMsgPackRpc++runPureRpcProp :: PureRpcProp () -> Property+runPureRpcProp test =+ property $+ \gen ->+ ioProperty $ execStateT (runPureRpc gen delays test) True+ where+ delays :: (Microsecond, Microsecond)+ delays = (0, 1000)++-- TODO: it would be useful to create an instance of Function for Client and Method;+-- see here https://hackage.haskell.org/package/QuickCheck-2.8.2/docs/Test-QuickCheck-Function.html#t:Function++port :: Port+port = 5000++host :: Host+host = "127.0.0.1"++addr :: NetworkAddress+addr = (host, port)++serverMethodShouldExecuteSimpleSpec :: PropertyM MsgPackRpc ()+serverMethodShouldExecuteSimpleSpec = client++serverMethodShouldExecuteSimplePureSpec+ :: PureRpcProp ()+serverMethodShouldExecuteSimplePureSpec = do+ serverThread <- fork server+ clientPure+ killThread serverThread++server :: MonadRpc m => m ()+server = do+ let respAdd = add+ respEcho = echo+ restrict $ respAdd 0 0+ restrict $ respEcho ""+ serve port [method "add" respAdd, method "echo" respEcho]+ where+ add+ :: Monad m+ => Int -> Int -> ServerT m Int+ add x y = return $ x + y+ echo+ :: Monad m+ => String -> ServerT m String+ echo s = return $ "***" ++ s ++ "***"++restrict :: Monad m => ServerT m a -> m ()+restrict _ = return ()++client :: PropertyM MsgPackRpc ()+client = do+ run $ wait $ for 50 ms+ r1 <- run $ execClient addr $ addC 123 456+ assert $ r1 == 123 + 456+ r2 <- run $ execClient addr $ echoC "hello"+ assert $ r2 == "***hello***"++clientPure :: PureRpcProp ()+clientPure = do+ wait $ for 50 ms+ r1 <- execClient addr $ addC 123 456+ assertPure $ r1 == 123 + 456+ r2 <- execClient addr $ echoC "hello"+ assertPure $ r2 == "***hello***"++addC :: Int -> Int -> Client Int+addC = call "add"++echoC :: String -> Client String+echoC = call "echo"++-- TODO: this method triggers some msgpack exceptions+-- | Method should execute if called correctly+-- serverMethodShouldExecuteSpec+-- :: (MonadTimed m, MonadRpc m)+-- => NonEmptyList (NonEmptyList Char)+-- -> PropertyM m ()+-- serverMethodShouldExecuteSpec (getNonEmpty -> methodNames') = do+-- mtds <- createMethods methodNames+-- let methodMap = createMethodMap mtds+-- run . fork $ serve port mtds+-- run . wait $ for 500 ms+-- name <- pick $ elements methodNames+-- res <- run . execClient addr $ call name+-- shouldBe <- run $ fromJust $ M.lookup name methodMap <*> pure []+-- assert $ shouldBe == res+-- where methodNames = nub $ map getNonEmpty methodNames'+-- -- TODO: we wouldn't need to do this if Function was defined+-- createMethods :: Monad m => [String] -> PropertyM m [Method m]+-- createMethods = mapM $ \name -> do+-- res <- toObject <$> pick (arbitrary :: Gen Int)+-- return . Method name . const $ return res+-- createMethodMap :: Monad m => [Method m] -> M.Map String ([Object] -> m Object)+-- createMethodMap = M.fromList . map (\m -> (methodName m, methodBody m))
+ test/Test/Control/TimeWarp/Timed/ExceptionSpec.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Control.TimeWarp.Timed.ExceptionSpec+ ( spec+ ) where++import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar (TVar, modifyTVar, newTVarIO,+ readTVarIO)+import Control.Exception.Base (ArithException (Overflow),+ AsyncException (ThreadKilled),+ SomeException (..))+import Control.Monad.Catch (catch, catchAll, throwM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans (MonadIO)+import Test.Hspec (Spec, before, describe)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (NonNegative (..), Property)+import Test.QuickCheck.Monadic (monadicIO)+import Test.QuickCheck.Property (Result (reason), failed,+ ioProperty, succeeded)++import Control.TimeWarp.Logging (Severity (Error), initLogging)+import Control.TimeWarp.Timed (Microsecond, TimedT, after,+ fork_, fork, invoke, runTimedT,+ sec, wait, for, throwTo)++import Test.Control.TimeWarp.Common ()++spec :: Spec+spec =+ before (initLogging ["dunno"] Error) $+ describe "WorkMode" $ do+ describe "error" $ do+ prop "should abort the execution"+ exceptionShouldAbortExecution+ prop "caught nicely"+ excCaught+ prop "exception from main thread caught outside of monad"+ excCaughtOutside+ prop "exception from main thread caught outside of monad (+ wait)"+ excCaughtOutsideWithWait+ prop "proper catch order (catch inside catch)"+ excCatchOrder+ prop "(wait + throw) - exception doesn't get lost"+ excWaitThrow+ prop "(wait + throw) in forked thread - exception doesn't get lost"+ excWaitThrowForked+ prop "catch doesn't handle future exceptions"+ excCatchScope+ prop "catch doesn't handle future exceptions (with wait inside)"+ excCatchScopeWithWait+ prop "different exceptions, catch inner"+ excDiffCatchInner+ prop "different exceptions, catch outer"+ excDiffCatchOuter+ describe "handler error" $+ prop "throws"+ handlerThrow+ describe "async error" $ do+ prop "shouldn't abort the execution"+ asyncExceptionShouldntAbortExecution+ prop "throwTo throws correct exception"+ throwToThrowsCorrectException+ prop "throwTo can kell thread"+ throwToCanKillThread++-- FIXME+exceptionShouldAbortExecution+ :: NonNegative Microsecond+ -> Property+exceptionShouldAbortExecution (getNonNegative -> t) = (const (monadicIO $ pure ())) t+ -- monadicIO $+ -- do var <- liftIO $ newTVarIO (0 :: Int)+ -- runTimedT $+ -- fork_ $+ -- do liftIO $ atomically $ writeTVar var 1+ -- wait $ for t mcs+ -- void $ throwM $ TextException "Error"+ -- liftIO $ atomically $ writeTVar var 2+ -- res <- liftIO $ readTVarIO var+ -- assert $ res == 1++-- FIXME+asyncExceptionShouldntAbortExecution+ :: NonNegative Microsecond+ -> NonNegative Microsecond+ -> Property+asyncExceptionShouldntAbortExecution (getNonNegative -> t1) (getNonNegative -> t2) = (const (const (monadicIO $ pure ()))) t1 t2+-- monadicIO $+-- do var <- liftIO $ newTVarIO (0 :: Int)+-- runTimedT $+-- do liftIO $ atomically $ writeTVar var 1+-- fork_ $+-- do wait $ for t2 mcs+-- throwM $ TextException "Error"+-- wait $ for t1 mcs+-- liftIO $ atomically $ writeTVar var 2+-- res <- liftIO $ readTVarIO var+-- assert $ res == 2++excCaught+ :: Property+excCaught =+ ioProperty . withCheckPoints $+ \checkPoint -> runEmu $+ let act = throwM ThreadKilled >> checkPoint (-1)+ hnd _ = checkPoint 1+ in act `catchAll` hnd++excCaughtOutside+ :: Property+excCaughtOutside =+ ioProperty . withCheckPoints $+ \checkPoint ->+ let act = do+ runEmu $ wait (for 1 sec) >> throwM ThreadKilled+ checkPoint (-1)+ hnd _ = checkPoint 1+ in do act `catchAll` hnd+ checkPoint 2++excCaughtOutsideWithWait+ :: Property+excCaughtOutsideWithWait =+ ioProperty . withCheckPoints $+ \checkPoint ->+ let act = do+ runEmu $ throwM ThreadKilled+ checkPoint (-1)+ hnd _ = checkPoint 1+ in do act `catchAll` hnd+ checkPoint 2++excWaitThrow+ :: Property+excWaitThrow =+ ioProperty . withCheckPoints $+ \checkPoint ->+ runEmu $+ let act = do+ wait (for 1 sec)+ throwM ThreadKilled+ hnd _ = checkPoint 1+ in do act `catchAll` hnd+ checkPoint 2++excWaitThrowForked+ :: Property+excWaitThrowForked =+ ioProperty . withCheckPoints $+ \checkPoint ->+ runEmu $+ let act = do+ wait (for 1 sec)+ throwM ThreadKilled+ hnd _ = checkPoint 1+ in do fork_ $ act `catchAll` hnd+ invoke (after 1 sec) $ checkPoint 2++excCatchOrder+ :: Property+excCatchOrder =+ ioProperty . withCheckPoints $+ \checkPoint ->+ runEmu $+ let act = throwM ThreadKilled+ hnd1 _ = checkPoint 1+ hnd2 _ = checkPoint (-1)+ in do act `catchAll` hnd1 `catchAll` hnd2+ checkPoint 2++excCatchScope+ :: Property+excCatchScope =+ ioProperty . withCheckPoints $+ \checkPoint ->+ runEmu $+ let act1 = checkPoint 1 `catchAll` const (checkPoint $ -1)+ act2 = act1 >> throwM ThreadKilled+ in do act2 `catchAll` const (checkPoint 2)+ checkPoint 3++excCatchScopeWithWait :: Property+excCatchScopeWithWait =+ ioProperty . withCheckPoints $+ \checkPoint ->+ runEmu $+ let act1 = checkPoint 1 >> wait (for 1 sec)+ act2 = act1 `catchAll` const (checkPoint $ -1)+ act3 = act2 >> wait (for 1 sec) >> throwM ThreadKilled+ in do act3 `catchAll` const (checkPoint 2)+ checkPoint 3++excDiffCatchInner+ :: Property+excDiffCatchInner =+ ioProperty . withCheckPoints $+ \checkPoint ->+ runEmu $+ let act = throwM ThreadKilled+ hnd1 (_ :: AsyncException) = checkPoint 1+ hnd2 (_ :: ArithException) = checkPoint (-1)+ in do act `catch` hnd1 `catch` hnd2+ checkPoint 2++excDiffCatchOuter+ :: Property+excDiffCatchOuter =+ ioProperty . withCheckPoints $+ \checkPoint ->+ runEmu $+ let act = throwM Overflow+ hnd1 (_ :: AsyncException) = checkPoint (-1)+ hnd2 (_ :: ArithException) = checkPoint 1+ in do act `catch` hnd1 `catch` hnd2+ checkPoint 2++handlerThrow+ :: Property+handlerThrow =+ ioProperty . withCheckPoints $+ \checkPoint ->+ runEmu $+ let act = throwM ThreadKilled+ hnd1 (_ :: SomeException) = throwM Overflow+ hnd2 (_ :: ArithException) = checkPoint 1+ in do act `catch` hnd1 `catch` hnd2+ checkPoint 2++throwToThrowsCorrectException+ :: Property+throwToThrowsCorrectException =+ ioProperty . withCheckPoints $+ \checkPoint ->+ runEmu $ do+ tid <- fork $ catch (wait $ for 1 sec) $+ \(_ :: ArithException) -> checkPoint 1+ throwTo tid $ SomeException Overflow -- should be unwrapped+ -- automatically+ wait $ for 2 sec+ checkPoint 2++throwToCanKillThread+ :: Property+throwToCanKillThread =+ ioProperty . withCheckPoints $+ \checkPoint ->+ runEmu $ do+ tid <- fork $ wait (for 1 sec) >> checkPoint (-1)+ throwTo tid Overflow++runEmu :: TimedT IO () -> IO ()+runEmu = runTimedT++-- Principle of checkpoints: every checkpoint has it's id+-- Checkpoints should be visited in according order: 1, 2, 3 ...+newtype CheckPoints = CP { getCP :: TVar (Either String Int) }++initCheckPoints :: MonadIO m => m CheckPoints+initCheckPoints = fmap CP $ liftIO $ newTVarIO $ Right 0++visitCheckPoint :: MonadIO m => CheckPoints -> Int -> m ()+visitCheckPoint cp curId = liftIO $ atomically $ modifyTVar (getCP cp) $+ \wasId ->+ if wasId == Right (curId - 1)+ then Right curId+ else Left $ either id (showError curId) wasId+ where+ showError cur was = mconcat+ ["Wrong chechpoint. Expected "+ , show (was + 1)+ , ", but visited "+ , show cur+ ]++assertCheckPoints :: MonadIO m => CheckPoints -> m Result+assertCheckPoints = fmap mkRes . liftIO . readTVarIO . getCP+ where+ mkRes (Left msg) = failed { reason = msg }+ mkRes (Right _) = succeeded++withCheckPoints :: MonadIO m => ((Int -> m ()) -> IO a) -> IO Result+withCheckPoints act = do+ cp <- initCheckPoints+ _ <- act $ liftIO . visitCheckPoint cp+ assertCheckPoints cp
+ test/Test/Control/TimeWarp/Timed/MonadTimedSpec.hs view
@@ -0,0 +1,402 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- | RSCoin.Test.MonadTimed specification++module Test.Control.TimeWarp.Timed.MonadTimedSpec+ ( spec+ , timeoutProp -- workaround warning, remove after it's used+ ) where++import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar (newTVarIO, readTVarIO, writeTVar)+import Control.Exception.Base (Exception, SomeException)+import Control.Monad (void)+import Control.Monad.Catch (MonadCatch, catch, catchAll,+ handleAll, throwM)+import Control.Monad.State (StateT, execStateT, modify, put)+import Control.Monad.Trans (MonadIO, liftIO)+import Data.Typeable (Typeable)+import Numeric.Natural (Natural)+import Test.Hspec (Spec, describe)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (NonNegative (..), Property,+ counterexample, ioProperty)+import Test.QuickCheck.Function (Fun, apply)+import Test.QuickCheck.Monadic (PropertyM, assert, monadic,+ monitor, run)+import Test.QuickCheck.Poly (A)++import Control.TimeWarp.Timed (Microsecond, MonadTimed (..),+ MonadTimedError, RelativeToNow,+ TimedIO, TimedT, TimedT, after,+ for, fork_, invoke, now,+ runTimedIO, runTimedT, schedule,+ sec, killThread)++import Test.Control.TimeWarp.Common ()++spec :: Spec+spec =+ describe "MonadTimed" $ do+ monadTimedSpec "TimedIO" runTimedIOProp+ monadTimedTSpec "TimedT" runTimedTProp++monadTimedSpec+ :: (MonadTimed m, MonadIO m, MonadCatch m)+ => String+ -> (PropertyM m () -> Property)+ -> Spec+monadTimedSpec description runProp =+ describe description $ do+ describe "virtualTime >> virtualTime" $ do+ prop "first virtualTime will run before second virtualTime" $+ runProp virtualTimePassingProp+ describe "wait t" $ do+ prop "will wait at least t" $+ runProp . waitPassingProp+ describe "fork" $ do+ prop "won't change semantics of an action" $+ \a -> runProp . forkSemanticProp a+ describe "schedule" $ do+ prop "won't change semantics of an action, will execute action in the future" $+ \a b -> runProp . scheduleSemanticProp a b+ describe "invoke" $ do+ prop "won't change semantics of an action, will execute action in the future" $+ \a b -> runProp . invokeSemanticProp a b+-- TODO: fix tests for timeout in TimedIO.+-- describe "timeout" $ do+-- prop "should throw an exception if time has exceeded" $+-- \a -> runProp . timeoutProp a+++monadTimedTSpec+ :: String+ -> (TimedTProp () -> Property)+ -> Spec+monadTimedTSpec description runProp =+ describe description $ do+ describe "virtualTime >> virtualTime" $ do+ prop "first virtualTime will run before second virtualTime" $+ runProp virtualTimePassingTimedProp+ describe "now" $ do+ prop "now is correct" $+ runProp . nowProp+ describe "wait t" $ do+ prop "will wait at least t" $+ runProp . waitPassingTimedProp+ describe "fork" $ do+ prop "won't change semantics of an action" $+ \a -> runProp . forkSemanticTimedProp a+ describe "schedule" $ do+ prop "won't change semantics of an action, will execute action in the future" $+ \a b -> runProp . scheduleSemanticTimedProp a b+ describe "invoke" $ do+ prop "won't change semantics of an action, will execute action in the future" $+ \a b -> runProp . invokeSemanticTimedProp a b+ describe "timeout" $ do+ prop "should throw an exception if time has exceeded" $+ \a -> runProp . timeoutTimedProp a+ describe "killThread" $ do+ prop "should abort the execution of a thread" $+ \a b -> runProp . killThreadTimedProp a b+ describe "exceptions" $ do+ prop "thrown nicely" $+ runProp exceptionsThrown+ prop "caught nicely" $+ runProp exceptionsThrowCaught+ prop "wait + throw caught nicely" $+ runProp exceptionsWaitThrowCaught+ prop "exceptions don't affect main thread" $+ runProp exceptionNotAffectMainThread+ prop "exceptions don't affect other threads" $+ runProp exceptionNotAffectOtherThread+++-- pure version+-- type TimedTProp = TimedT (CatchT (State Bool))+type TimedTProp = TimedT (StateT Bool IO)++assertTimedT :: Bool -> TimedTProp ()+assertTimedT b = modify (b &&)++type RelativeToNowNat = Natural++fromIntegralRTN :: RelativeToNowNat -> RelativeToNow+fromIntegralRTN = (+) . fromIntegral++-- TODO: figure out how to test recursive functions like after/at++runTimedIOProp :: PropertyM TimedIO () -> Property+runTimedIOProp = monadic $ ioProperty . runTimedIO++runTimedTProp :: TimedTProp () -> Property+runTimedTProp test = ioProperty $ execStateT (runTimedT test) True++-- TimedIO tests++timeoutProp+ :: (MonadTimed m, MonadIO m, MonadCatch m)+ => NonNegative Microsecond+ -> NonNegative Microsecond+ -> PropertyM m ()+timeoutProp (getNonNegative -> tout) (getNonNegative -> wt) = do+ let action = do+ wait $ for wt+ return $ wt <= tout+ handler (_ :: MonadTimedError) = return $ wt >= tout+ res <- run $ timeout tout action `catch` handler+ assert res++invokeSemanticProp+ :: (MonadTimed m, MonadIO m)+ => RelativeToNowNat+ -> A+ -> Fun A A+ -> PropertyM m ()+invokeSemanticProp = actionTimeSemanticProp invoke++scheduleSemanticProp+ :: (MonadTimed m, MonadIO m)+ => RelativeToNowNat+ -> A+ -> Fun A A+ -> PropertyM m ()+scheduleSemanticProp = actionTimeSemanticProp schedule++actionTimeSemanticProp+ :: (MonadTimed m, MonadIO m)+ => (RelativeToNow -> m () -> m ())+ -> RelativeToNowNat+ -> A+ -> Fun A A+ -> PropertyM m ()+actionTimeSemanticProp action relativeToNow val f = do+ actionSemanticProp action' val f+ timePassingProp relativeToNow action'+ where+ action' = action $ fromIntegralRTN relativeToNow++forkSemanticProp+ :: (MonadTimed m, MonadIO m)+ => A+ -> Fun A A+ -> PropertyM m ()+forkSemanticProp = actionSemanticProp fork_++waitPassingProp+ :: (MonadTimed m, MonadIO m)+ => RelativeToNowNat+ -> PropertyM m ()+waitPassingProp relativeToNow =+ timePassingProp relativeToNow (wait (fromIntegralRTN relativeToNow) >>)++virtualTimePassingProp :: (MonadTimed m, MonadIO m) => PropertyM m ()+virtualTimePassingProp =+ timePassingProp 0 id++-- TODO: instead of testing with MVar's we should create PropertyM an instance of MonadTimed.+-- With that we could test inside forked/waited actions+-- | Tests that action will be exececuted after relativeToNow+timePassingProp+ :: (MonadTimed m, MonadIO m)+ => RelativeToNowNat+ -> (m () -> m ())+ -> PropertyM m ()+timePassingProp relativeToNow action = do+ mvar <- liftIO newEmptyMVar+ t1 <- run virtualTime+ run . action $ virtualTime >>= liftIO . putMVar mvar+ t2 <- liftIO $ takeMVar mvar+ monitor (counterexample $ mconcat+ [ "t1: ", show t1+ , ", t2: ", show t2, ", "+ , show $ fromIntegralRTN relativeToNow t1, " <= ", show t2+ ])+ assert $ fromIntegralRTN relativeToNow t1 <= t2++-- | Tests that an action will be executed+actionSemanticProp+ :: (MonadTimed m, MonadIO m)+ => (m () -> m ())+ -> A+ -> Fun A A+ -> PropertyM m ()+actionSemanticProp action val f = do+ mvar <- liftIO newEmptyMVar+ run . action . liftIO . putMVar mvar $ apply f val+ result <- liftIO $ takeMVar mvar+ monitor (counterexample $ mconcat+ [ "f: ", show f+ , ", val: ", show val+ , ", f val: ", show $ apply f val+ , ", should be: ", show result+ ])+ assert $ apply f val == result++-- TimedT tests+-- TODO: As TimedT is an instance of MonadIO, we can now reuse tests for TimedIO instead of these tests++-- TODO: use checkpoints timeout pattern from ExceptionSpec+killThreadTimedProp+ :: NonNegative Microsecond+ -> NonNegative Microsecond+ -> NonNegative Microsecond+ -> TimedTProp ()+killThreadTimedProp+ (getNonNegative -> mTime)+ (getNonNegative -> f1Time)+ (getNonNegative -> f2Time)+ = do+ var <- liftIO $ newTVarIO (0 :: Int)+ tId <- fork $ do+ fork_ $ do -- this thread can't be killed+ wait $ for f1Time+ liftIO $ atomically $ writeTVar var 1+ wait $ for f2Time+ liftIO $ atomically $ writeTVar var 2+ wait $ for mTime+ killThread tId+ wait $ for f1Time -- wait for both threads to finish+ wait $ for f2Time+ res <- liftIO $ readTVarIO var+ assertTimedT $ check res+ where+ check 0 = mTime <= f1Time && mTime <= f2Time+ check 1 = True -- this thread can't be killed+ check 2 = f2Time <= mTime+ check _ = error "This checkpoint doesn't exist"++timeoutTimedProp+ :: NonNegative Microsecond+ -> NonNegative Microsecond+ -> TimedTProp ()+timeoutTimedProp (getNonNegative -> tout) (getNonNegative -> wt) = do+ let action = do+ wait $ for wt+ return $ wt <= tout+ handler (_ :: SomeException) = do+ return $ tout <= wt+ res <- timeout tout action `catch` handler+ assertTimedT res++invokeSemanticTimedProp+ :: RelativeToNowNat+ -> A+ -> Fun A A+ -> TimedTProp ()+invokeSemanticTimedProp = actionTimeSemanticTimedProp invoke++scheduleSemanticTimedProp+ :: RelativeToNowNat+ -> A+ -> Fun A A+ -> TimedTProp ()+scheduleSemanticTimedProp = actionTimeSemanticTimedProp schedule++actionTimeSemanticTimedProp+ :: (RelativeToNow -> TimedTProp () -> TimedTProp ())+ -> RelativeToNowNat+ -> A+ -> Fun A A+ -> TimedTProp ()+actionTimeSemanticTimedProp action relativeToNow val f = do+ actionSemanticTimedProp action' val f+ timePassingTimedProp relativeToNow action'+ where+ action' = action $ fromIntegralRTN relativeToNow++forkSemanticTimedProp+ :: A+ -> Fun A A+ -> TimedTProp ()+forkSemanticTimedProp = actionSemanticTimedProp fork_++waitPassingTimedProp+ :: RelativeToNowNat+ -> TimedTProp ()+waitPassingTimedProp relativeToNow =+ timePassingTimedProp relativeToNow (wait (fromIntegralRTN relativeToNow) >>)++virtualTimePassingTimedProp :: TimedTProp ()+virtualTimePassingTimedProp =+ timePassingTimedProp 0 id++-- | Tests that action will be exececuted after relativeToNow+timePassingTimedProp+ :: RelativeToNowNat+ -> (TimedTProp () -> TimedTProp ())+ -> TimedTProp ()+timePassingTimedProp relativeToNow action = do+ t1 <- virtualTime+ action $ virtualTime >>= assertTimedT . (fromIntegralRTN relativeToNow t1 <=)++-- | Tests that an action will be executed+actionSemanticTimedProp+ :: (TimedTProp () -> TimedTProp ())+ -> A+ -> Fun A A+ -> TimedTProp ()+actionSemanticTimedProp action val f = do+ let result = apply f val+ action $ assertTimedT $ apply f val == result++nowProp :: Microsecond -> TimedTProp ()+nowProp ms = do+ wait $ for ms+ t1 <- virtualTime+ invoke now $ return ()+ t2 <- virtualTime+ assertTimedT $ t1 == t2+++-- * Exceptions++data TestException = TestExc+ deriving (Show, Typeable)++instance Exception TestException++handleAll' :: MonadCatch m => m () -> m ()+handleAll' = handleAll $ const $ return ()+++exceptionsThrown :: TimedTProp ()+exceptionsThrown = handleAll' $ do+ void $ throwM TestExc+ put False++exceptionsThrowCaught :: TimedTProp ()+exceptionsThrowCaught =+ let act = do+ put False+ throwM TestExc+ hnd = const $ put True+ in act `catchAll` hnd++exceptionsWaitThrowCaught :: TimedTProp ()+exceptionsWaitThrowCaught =+ let act = do+ put False+ wait $ for 1 sec+ throwM TestExc+ hnd = const $ put True+ in act `catchAll` hnd++exceptionNotAffectMainThread :: TimedTProp ()+exceptionNotAffectMainThread = handleAll' $ do+ put False+ fork_ $ throwM TestExc+ wait $ for 1 sec+ put True++exceptionNotAffectOtherThread :: TimedTProp ()+exceptionNotAffectOtherThread = handleAll' $ do+ put False+ schedule (after 3 sec) $ put True+ schedule (after 1 sec) $ throwM TestExc
+ time-warp.cabal view
@@ -0,0 +1,137 @@+name: time-warp+version: 0.1.1+synopsis: distributed systems execution emulation+homepage: http://gitlab.serokell.io/serokell-team/time-warp+bug-reports: https://github.com/serokell/time-warp/issues+license: GPL-3+license-file: LICENSE+author: Serokell+maintainer: Serokell <hi@serokell.io>+copyright: 2016 Serokell+build-type: Simple+cabal-version: >=1.18+category: Control, Network+synopsis: Disctributed systems execution emulation+description: This package allows to write scenarious over distributed+ systems, which can be launched as either real program or+ fast emulation without need to wait for delays and with+ network nastiness manually controlled.++library+ exposed-modules: Control.TimeWarp.Logging++ , Control.TimeWarp.Rpc+ , Control.TimeWarp.Rpc.MonadRpc+ , Control.TimeWarp.Rpc.MsgPackRpc+ , Control.TimeWarp.Rpc.PureRpc+ , Control.TimeWarp.Rpc.Restriction++ , Control.TimeWarp.Timed+ , Control.TimeWarp.Timed.MonadTimed+ , Control.TimeWarp.Timed.Misc+ , Control.TimeWarp.Timed.TimedIO+ , Control.TimeWarp.Timed.TimedT+ build-depends: ansi-terminal+ , base >= 4.8 && < 5+ , bytestring >= 0.10.6.0+ , containers+ , data-default+ , data-msgpack >= 0.0.8+ , exceptions+ , formatting+ , hslogger+ , lens+ , lifted-base >= 0.2.3+ , mtl+ , MonadRandom+ , monad-loops+ , monad-control+ , network-msgpack-rpc == 0.0.1+ , pqueue+ , QuickCheck >= 2.8.1+ , quickcheck-instances+ , random >= 1.1+ , safe+ , serokell-util+ , stm >= 2.4.4+ , template-haskell+ , text >= 1.2.2.0+ , text-format+ , time+ , time-units >= 1.0.0+ , transformers >= 0.4.2.0+ , transformers-base+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-orphans+ default-extensions: RecordWildCards+ , OverloadedStrings+ , DeriveDataTypeable+ , GeneralizedNewtypeDeriving++test-suite time-warp-test+ main-is: Test.hs+ other-modules: Test.Control.TimeWarp.Rpc.MonadRpcSpec++ , Test.Control.TimeWarp.Timed.ExceptionSpec+ , Test.Control.TimeWarp.Timed.MonadTimedSpec++ , Test.Control.TimeWarp.Common++ , Spec+ type: exitcode-stdio-1.0+ build-depends: async >= 2.0.1+ , base >= 4.8 && < 5+ , data-default+ , data-msgpack >= 0.0.8+ , exceptions >= 0.8.2.1+ , hspec >= 2.1.10+ , lens >= 4.13+ , mtl+ , network-msgpack-rpc == 0.0.1+ , QuickCheck >= 2.8.1+ , serokell-util+ , stm >= 2.4.4.1+ , text >= 1.2.2.0+ , text-format+ , time-units >= 1.0.0+ , time-warp+ , transformers >= 0.4.2.0+ , random >= 1.1+ hs-source-dirs: test+ default-language: Haskell2010+ ghc-options: -threaded -Wall -fno-warn-orphans+ default-extensions: OverloadedStrings+ , RecordWildCards+ , DeriveDataTypeable+ , GeneralizedNewtypeDeriving++executable token-ring+ main-is: Main.hs+ build-depends: async >= 2.0.1+ , base >= 4.8 && < 5+ , data-default+ , data-msgpack >= 0.0.8+ , exceptions >= 0.8.2.1+ , formatting+ , hspec >= 2.1.10+ , lens >= 4.13+ , network-msgpack-rpc == 0.0.1+ , MonadRandom+ , mtl+ , QuickCheck >= 2.8.1+ , serokell-util+ , stm >= 2.4.4.1+ , text >= 1.2.2.0+ , text-format+ , time-units >= 1.0.0+ , time-warp+ , transformers >= 0.4.2.0+ , random >= 1.1+ hs-source-dirs: examples/token-ring+ default-language: Haskell2010 + ghc-options: -threaded -Wall -fno-warn-orphans+ default-extensions: OverloadedStrings+ , RecordWildCards+ , DeriveDataTypeable+ , GeneralizedNewtypeDeriving