diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU 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. + + + Copyright (C) + + 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 . + +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: + + Copyright (C) + 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 +. + + 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 +. diff --git a/examples/token-ring/Main.hs b/examples/token-ring/Main.hs new file mode 100644 --- /dev/null +++ b/examples/token-ring/Main.hs @@ -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" diff --git a/src/Control/TimeWarp/Logging.hs b/src/Control/TimeWarp/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Control/TimeWarp/Logging.hs @@ -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 +-- Stability : experimental +-- Portability : POSIX, GHC +-- +-- Logging functionality. This module is wrapper over +-- , +-- 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 ). +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 diff --git a/src/Control/TimeWarp/Rpc.hs b/src/Control/TimeWarp/Rpc.hs new file mode 100644 --- /dev/null +++ b/src/Control/TimeWarp/Rpc.hs @@ -0,0 +1,61 @@ +-- | +-- Module : Control.TimeWarp.Rpc +-- Copyright : (c) Serokell, 2016 +-- License : GPL-3 (see the file LICENSE) +-- Maintainer : Serokell +-- 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 diff --git a/src/Control/TimeWarp/Rpc/MonadRpc.hs b/src/Control/TimeWarp/Rpc/MonadRpc.hs new file mode 100644 --- /dev/null +++ b/src/Control/TimeWarp/Rpc/MonadRpc.hs @@ -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 +-- 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 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) diff --git a/src/Control/TimeWarp/Rpc/MsgPackRpc.hs b/src/Control/TimeWarp/Rpc/MsgPackRpc.hs new file mode 100644 --- /dev/null +++ b/src/Control/TimeWarp/Rpc/MsgPackRpc.hs @@ -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 +-- 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 . +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 diff --git a/src/Control/TimeWarp/Rpc/PureRpc.hs b/src/Control/TimeWarp/Rpc/PureRpc.hs new file mode 100644 --- /dev/null +++ b/src/Control/TimeWarp/Rpc/PureRpc.hs @@ -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 +-- 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 diff --git a/src/Control/TimeWarp/Rpc/Restriction.hs b/src/Control/TimeWarp/Rpc/Restriction.hs new file mode 100644 --- /dev/null +++ b/src/Control/TimeWarp/Rpc/Restriction.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE Rank2Types #-} + +-- | +-- Module : Control.TimeWarp.Rpc.Restriction +-- Copyright : (c) Serokell, 2016 +-- License : GPL-3 (see the file LICENSE) +-- Maintainer : Serokell +-- 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 diff --git a/src/Control/TimeWarp/Timed.hs b/src/Control/TimeWarp/Timed.hs new file mode 100644 --- /dev/null +++ b/src/Control/TimeWarp/Timed.hs @@ -0,0 +1,52 @@ +-- | +-- Module : Control.TimeWarp.Timed +-- Copyright : (c) Serokell, 2016 +-- License : GPL-3 (see the file LICENSE) +-- Maintainer : Serokell +-- 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 diff --git a/src/Control/TimeWarp/Timed/Misc.hs b/src/Control/TimeWarp/Timed/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Control/TimeWarp/Timed/Misc.hs @@ -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) diff --git a/src/Control/TimeWarp/Timed/MonadTimed.hs b/src/Control/TimeWarp/Timed/MonadTimed.hs new file mode 100644 --- /dev/null +++ b/src/Control/TimeWarp/Timed/MonadTimed.hs @@ -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 +-- 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 diff --git a/src/Control/TimeWarp/Timed/TimedIO.hs b/src/Control/TimeWarp/Timed/TimedIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/TimeWarp/Timed/TimedIO.hs @@ -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 +-- 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 diff --git a/src/Control/TimeWarp/Timed/TimedT.hs b/src/Control/TimeWarp/Timed/TimedT.hs new file mode 100644 --- /dev/null +++ b/src/Control/TimeWarp/Timed/TimedT.hs @@ -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 +-- 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" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,5 @@ +import Spec (spec) +import Test.Hspec (hspec) + +main :: IO () +main = hspec spec diff --git a/test/Test/Control/TimeWarp/Common.hs b/test/Test/Control/TimeWarp/Common.hs new file mode 100644 --- /dev/null +++ b/test/Test/Control/TimeWarp/Common.hs @@ -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 diff --git a/test/Test/Control/TimeWarp/Rpc/MonadRpcSpec.hs b/test/Test/Control/TimeWarp/Rpc/MonadRpcSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Control/TimeWarp/Rpc/MonadRpcSpec.hs @@ -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)) diff --git a/test/Test/Control/TimeWarp/Timed/ExceptionSpec.hs b/test/Test/Control/TimeWarp/Timed/ExceptionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Control/TimeWarp/Timed/ExceptionSpec.hs @@ -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 diff --git a/test/Test/Control/TimeWarp/Timed/MonadTimedSpec.hs b/test/Test/Control/TimeWarp/Timed/MonadTimedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Control/TimeWarp/Timed/MonadTimedSpec.hs @@ -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 diff --git a/time-warp.cabal b/time-warp.cabal new file mode 100644 --- /dev/null +++ b/time-warp.cabal @@ -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 +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