simple 0.5.0 → 0.6.0
raw patch · 23 files changed
+1385/−1839 lines, 23 filesdep +setenvdep −hashtables
Dependencies added: setenv
Dependencies removed: hashtables
Files
- LICENSE +125/−635
- Web/Frank.hs +0/−58
- Web/REST.hs +0/−87
- Web/Simple.hs +0/−256
- Web/Simple/Auth.hs +0/−70
- Web/Simple/Cache.hs +0/−86
- Web/Simple/Controller.hs +0/−428
- Web/Simple/Responses.hs +0/−138
- simple.cabal +10/−9
- smpl.hs +0/−58
- src/Web/Frank.hs +58/−0
- src/Web/REST.hs +87/−0
- src/Web/Simple.hs +258/−0
- src/Web/Simple/Auth.hs +70/−0
- src/Web/Simple/Controller.hs +437/−0
- src/Web/Simple/Responses.hs +138/−0
- src/smpl.hs +103/−0
- template/Application_hs.tmpl +14/−0
- template/Common_hs.tmpl +41/−0
- template/Main_hs.tmpl +7/−10
- template/index_html.tmpl +1/−0
- template/main_html.tmpl +28/−0
- template/package_cabal.tmpl +8/−4
LICENSE view
@@ -1,675 +1,165 @@- GNU GENERAL PUBLIC LICENSE- Version 3, 29 June 2007+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. - Preamble - The GNU General Public License is a free, copyleft license for-software and other kinds of works.-- The licenses for most software and other practical works are designed-to take away your freedom to share and change the works. By contrast,-the GNU General Public License is intended to guarantee your freedom to-share and change all versions of a program--to make sure it remains free-software for all its users. We, the Free Software Foundation, use the-GNU General Public License for most of our software; it applies also to-any other work released this way by its authors. You can apply it to-your programs, too.-- When we speak of free software, we are referring to freedom, not-price. Our General Public Licenses are designed to make sure that you-have the freedom to distribute copies of free software (and charge for-them if you wish), that you receive source code or can get it if you-want it, that you can change the software or use pieces of it in new-free programs, and that you know you can do these things.-- To protect your rights, we need to prevent others from denying you-these rights or asking you to surrender the rights. Therefore, you have-certain responsibilities if you distribute copies of the software, or if-you modify it: responsibilities to respect the freedom of others.-- For example, if you distribute copies of such a program, whether-gratis or for a fee, you must pass on to the recipients the same-freedoms that you received. You must make sure that they, too, receive-or can get the source code. And you must show them these terms so they-know their rights.-- Developers that use the GNU GPL protect your rights with two steps:-(1) assert copyright on the software, and (2) offer you this License-giving you legal permission to copy, distribute and/or modify it.-- For the developers' and authors' protection, the GPL clearly explains-that there is no warranty for this free software. For both users' and-authors' sake, the GPL requires that modified versions be marked as-changed, so that their problems will not be attributed erroneously to-authors of previous versions.-- Some devices are designed to deny users access to install or run-modified versions of the software inside them, although the manufacturer-can do so. This is fundamentally incompatible with the aim of-protecting users' freedom to change the software. The systematic-pattern of such abuse occurs in the area of products for individuals to-use, which is precisely where it is most unacceptable. Therefore, we-have designed this version of the GPL to prohibit the practice for those-products. If such problems arise substantially in other domains, we-stand ready to extend this provision to those domains in future versions-of the GPL, as needed to protect the freedom of users.-- Finally, every program is threatened constantly by software patents.-States should not allow patents to restrict development and use of-software on general-purpose computers, but in those that do, we wish to-avoid the special danger that patents applied to a free program could-make it effectively proprietary. To prevent this, the GPL assures that-patents cannot be used to render the program non-free.-- The precise terms and conditions for copying, distribution and-modification follow.-- TERMS AND CONDITIONS-- 0. Definitions.-- "This License" refers to version 3 of the GNU General Public License.-- "Copyright" also means copyright-like laws that apply to other kinds of-works, such as semiconductor masks.- - "The Program" refers to any copyrightable work licensed under this-License. Each licensee is addressed as "you". "Licensees" and-"recipients" may be individuals or organizations.-- To "modify" a work means to copy from or adapt all or part of the work-in a fashion requiring copyright permission, other than the making of an-exact copy. The resulting work is called a "modified version" of the-earlier work or a work "based on" the earlier work.-- A "covered work" means either the unmodified Program or a work based-on the Program.-- To "propagate" a work means to do anything with it that, without-permission, would make you directly or secondarily liable for-infringement under applicable copyright law, except executing it on a-computer or modifying a private copy. Propagation includes copying,-distribution (with or without modification), making available to the-public, and in some countries other activities as well.-- To "convey" a work means any kind of propagation that enables other-parties to make or receive copies. Mere interaction with a user through-a computer network, with no transfer of a copy, is not conveying.-- An interactive user interface displays "Appropriate Legal Notices"-to the extent that it includes a convenient and prominently visible-feature that (1) displays an appropriate copyright notice, and (2)-tells the user that there is no warranty for the work (except to the-extent that warranties are provided), that licensees may convey the-work under this License, and how to view a copy of this License. If-the interface presents a list of user commands or options, such as a-menu, a prominent item in the list meets this criterion.-- 1. Source Code.-- The "source code" for a work means the preferred form of the work-for making modifications to it. "Object code" means any non-source-form of a work.-- A "Standard Interface" means an interface that either is an official-standard defined by a recognized standards body, or, in the case of-interfaces specified for a particular programming language, one that-is widely used among developers working in that language.-- The "System Libraries" of an executable work include anything, other-than the work as a whole, that (a) is included in the normal form of-packaging a Major Component, but which is not part of that Major-Component, and (b) serves only to enable use of the work with that-Major Component, or to implement a Standard Interface for which an-implementation is available to the public in source code form. A-"Major Component", in this context, means a major essential component-(kernel, window system, and so on) of the specific operating system-(if any) on which the executable work runs, or a compiler used to-produce the work, or an object code interpreter used to run it.-- The "Corresponding Source" for a work in object code form means all-the source code needed to generate, install, and (for an executable-work) run the object code and to modify the work, including scripts to-control those activities. However, it does not include the work's-System Libraries, or general-purpose tools or generally available free-programs which are used unmodified in performing those activities but-which are not part of the work. For example, Corresponding Source-includes interface definition files associated with source files for-the work, and the source code for shared libraries and dynamically-linked subprograms that the work is specifically designed to require,-such as by intimate data communication or control flow between those-subprograms and other parts of the work.-- The Corresponding Source need not include anything that users-can regenerate automatically from other parts of the Corresponding-Source.-- The Corresponding Source for a work in source code form is that-same work.-- 2. Basic Permissions.-- All rights granted under this License are granted for the term of-copyright on the Program, and are irrevocable provided the stated-conditions are met. This License explicitly affirms your unlimited-permission to run the unmodified Program. The output from running a-covered work is covered by this License only if the output, given its-content, constitutes a covered work. This License acknowledges your-rights of fair use or other equivalent, as provided by copyright law.-- You may make, run and propagate covered works that you do not-convey, without conditions so long as your license otherwise remains-in force. You may convey covered works to others for the sole purpose-of having them make modifications exclusively for you, or provide you-with facilities for running those works, provided that you comply with-the terms of this License in conveying all material for which you do-not control copyright. Those thus making or running the covered works-for you must do so exclusively on your behalf, under your direction-and control, on terms that prohibit them from making any copies of-your copyrighted material outside their relationship with you.-- Conveying under any other circumstances is permitted solely under-the conditions stated below. Sublicensing is not allowed; section 10-makes it unnecessary.-- 3. Protecting Users' Legal Rights From Anti-Circumvention Law.-- No covered work shall be deemed part of an effective technological-measure under any applicable law fulfilling obligations under article-11 of the WIPO copyright treaty adopted on 20 December 1996, or-similar laws prohibiting or restricting circumvention of such-measures.-- When you convey a covered work, you waive any legal power to forbid-circumvention of technological measures to the extent such circumvention-is effected by exercising rights under this License with respect to-the covered work, and you disclaim any intention to limit operation or-modification of the work as a means of enforcing, against the work's-users, your or third parties' legal rights to forbid circumvention of-technological measures.-- 4. Conveying Verbatim Copies.-- You may convey verbatim copies of the Program's source code as you-receive it, in any medium, provided that you conspicuously and-appropriately publish on each copy an appropriate copyright notice;-keep intact all notices stating that this License and any-non-permissive terms added in accord with section 7 apply to the code;-keep intact all notices of the absence of any warranty; and give all-recipients a copy of this License along with the Program.-- You may charge any price or no price for each copy that you convey,-and you may offer support or warranty protection for a fee.-- 5. Conveying Modified Source Versions.-- You may convey a work based on the Program, or the modifications to-produce it from the Program, in the form of source code under the-terms of section 4, provided that you also meet all of these conditions:-- a) The work must carry prominent notices stating that you modified- it, and giving a relevant date.-- b) The work must carry prominent notices stating that it is- released under this License and any conditions added under section- 7. This requirement modifies the requirement in section 4 to- "keep intact all notices".-- c) You must license the entire work, as a whole, under this- License to anyone who comes into possession of a copy. This- License will therefore apply, along with any applicable section 7- additional terms, to the whole of the work, and all its parts,- regardless of how they are packaged. This License gives no- permission to license the work in any other way, but it does not- invalidate such permission if you have separately received it.-- d) If the work has interactive user interfaces, each must display- Appropriate Legal Notices; however, if the Program has interactive- interfaces that do not display Appropriate Legal Notices, your- work need not make them do so.-- A compilation of a covered work with other separate and independent-works, which are not by their nature extensions of the covered work,-and which are not combined with it such as to form a larger program,-in or on a volume of a storage or distribution medium, is called an-"aggregate" if the compilation and its resulting copyright are not-used to limit the access or legal rights of the compilation's users-beyond what the individual works permit. Inclusion of a covered work-in an aggregate does not cause this License to apply to the other-parts of the aggregate.-- 6. Conveying Non-Source Forms.-- You may convey a covered work in object code form under the terms-of sections 4 and 5, provided that you also convey the-machine-readable Corresponding Source under the terms of this License,-in one of these ways:-- a) Convey the object code in, or embodied in, a physical product- (including a physical distribution medium), accompanied by the- Corresponding Source fixed on a durable physical medium- customarily used for software interchange.-- b) Convey the object code in, or embodied in, a physical product- (including a physical distribution medium), accompanied by a- written offer, valid for at least three years and valid for as- long as you offer spare parts or customer support for that product- model, to give anyone who possesses the object code either (1) a- copy of the Corresponding Source for all the software in the- product that is covered by this License, on a durable physical- medium customarily used for software interchange, for a price no- more than your reasonable cost of physically performing this- conveying of source, or (2) access to copy the- Corresponding Source from a network server at no charge.-- c) Convey individual copies of the object code with a copy of the- written offer to provide the Corresponding Source. This- alternative is allowed only occasionally and noncommercially, and- only if you received the object code with such an offer, in accord- with subsection 6b.-- d) Convey the object code by offering access from a designated- place (gratis or for a charge), and offer equivalent access to the- Corresponding Source in the same way through the same place at no- further charge. You need not require recipients to copy the- Corresponding Source along with the object code. If the place to- copy the object code is a network server, the Corresponding Source- may be on a different server (operated by you or a third party)- that supports equivalent copying facilities, provided you maintain- clear directions next to the object code saying where to find the- Corresponding Source. Regardless of what server hosts the- Corresponding Source, you remain obligated to ensure that it is- available for as long as needed to satisfy these requirements.-- e) Convey the object code using peer-to-peer transmission, provided- you inform other peers where the object code and Corresponding- Source of the work are being offered to the general public at no- charge under subsection 6d.-- A separable portion of the object code, whose source code is excluded-from the Corresponding Source as a System Library, need not be-included in conveying the object code work.-- A "User Product" is either (1) a "consumer product", which means any-tangible personal property which is normally used for personal, family,-or household purposes, or (2) anything designed or sold for incorporation-into a dwelling. In determining whether a product is a consumer product,-doubtful cases shall be resolved in favor of coverage. For a particular-product received by a particular user, "normally used" refers to a-typical or common use of that class of product, regardless of the status-of the particular user or of the way in which the particular user-actually uses, or expects or is expected to use, the product. A product-is a consumer product regardless of whether the product has substantial-commercial, industrial or non-consumer uses, unless such uses represent-the only significant mode of use of the product.-- "Installation Information" for a User Product means any methods,-procedures, authorization keys, or other information required to install-and execute modified versions of a covered work in that User Product from-a modified version of its Corresponding Source. The information must-suffice to ensure that the continued functioning of the modified object-code is in no case prevented or interfered with solely because-modification has been made.-- If you convey an object code work under this section in, or with, or-specifically for use in, a User Product, and the conveying occurs as-part of a transaction in which the right of possession and use of the-User Product is transferred to the recipient in perpetuity or for a-fixed term (regardless of how the transaction is characterized), the-Corresponding Source conveyed under this section must be accompanied-by the Installation Information. But this requirement does not apply-if neither you nor any third party retains the ability to install-modified object code on the User Product (for example, the work has-been installed in ROM).-- The requirement to provide Installation Information does not include a-requirement to continue to provide support service, warranty, or updates-for a work that has been modified or installed by the recipient, or for-the User Product in which it has been modified or installed. Access to a-network may be denied when the modification itself materially and-adversely affects the operation of the network or violates the rules and-protocols for communication across the network.-- Corresponding Source conveyed, and Installation Information provided,-in accord with this section must be in a format that is publicly-documented (and with an implementation available to the public in-source code form), and must require no special password or key for-unpacking, reading or copying.-- 7. Additional Terms.-- "Additional permissions" are terms that supplement the terms of this-License by making exceptions from one or more of its conditions.-Additional permissions that are applicable to the entire Program shall-be treated as though they were included in this License, to the extent-that they are valid under applicable law. If additional permissions-apply only to part of the Program, that part may be used separately-under those permissions, but the entire Program remains governed by-this License without regard to the additional permissions.-- When you convey a copy of a covered work, you may at your option-remove any additional permissions from that copy, or from any part of-it. (Additional permissions may be written to require their own-removal in certain cases when you modify the work.) You may place-additional permissions on material, added by you to a covered work,-for which you have or can give appropriate copyright permission.-- Notwithstanding any other provision of this License, for material you-add to a covered work, you may (if authorized by the copyright holders of-that material) supplement the terms of this License with terms:-- a) Disclaiming warranty or limiting liability differently from the- terms of sections 15 and 16 of this License; or-- b) Requiring preservation of specified reasonable legal notices or- author attributions in that material or in the Appropriate Legal- Notices displayed by works containing it; or-- c) Prohibiting misrepresentation of the origin of that material, or- requiring that modified versions of such material be marked in- reasonable ways as different from the original version; or-- d) Limiting the use for publicity purposes of names of licensors or- authors of the material; or-- e) Declining to grant rights under trademark law for use of some- trade names, trademarks, or service marks; or-- f) Requiring indemnification of licensors and authors of that- material by anyone who conveys the material (or modified versions of- it) with contractual assumptions of liability to the recipient, for- any liability that these contractual assumptions directly impose on- those licensors and authors.-- All other non-permissive additional terms are considered "further-restrictions" within the meaning of section 10. If the Program as you-received it, or any part of it, contains a notice stating that it is-governed by this License along with a term that is a further-restriction, you may remove that term. If a license document contains-a further restriction but permits relicensing or conveying under this-License, you may add to a covered work material governed by the terms-of that license document, provided that the further restriction does-not survive such relicensing or conveying.-- If you add terms to a covered work in accord with this section, you-must place, in the relevant source files, a statement of the-additional terms that apply to those files, or a notice indicating-where to find the applicable terms.-- Additional terms, permissive or non-permissive, may be stated in the-form of a separately written license, or stated as exceptions;-the above requirements apply either way.-- 8. Termination.-- You may not propagate or modify a covered work except as expressly-provided under this License. Any attempt otherwise to propagate or-modify it is void, and will automatically terminate your rights under-this License (including any patent licenses granted under the third-paragraph of section 11).-- However, if you cease all violation of this License, then your-license from a particular copyright holder is reinstated (a)-provisionally, unless and until the copyright holder explicitly and-finally terminates your license, and (b) permanently, if the copyright-holder fails to notify you of the violation by some reasonable means-prior to 60 days after the cessation.-- Moreover, your license from a particular copyright holder is-reinstated permanently if the copyright holder notifies you of the-violation by some reasonable means, this is the first time you have-received notice of violation of this License (for any work) from that-copyright holder, and you cure the violation prior to 30 days after-your receipt of the notice.-- Termination of your rights under this section does not terminate the-licenses of parties who have received copies or rights from you under-this License. If your rights have been terminated and not permanently-reinstated, you do not qualify to receive new licenses for the same-material under section 10.-- 9. Acceptance Not Required for Having Copies.-- You are not required to accept this License in order to receive or-run a copy of the Program. Ancillary propagation of a covered work-occurring solely as a consequence of using peer-to-peer transmission-to receive a copy likewise does not require acceptance. However,-nothing other than this License grants you permission to propagate or-modify any covered work. These actions infringe copyright if you do-not accept this License. Therefore, by modifying or propagating a-covered work, you indicate your acceptance of this License to do so.-- 10. Automatic Licensing of Downstream Recipients.-- Each time you convey a covered work, the recipient automatically-receives a license from the original licensors, to run, modify and-propagate that work, subject to this License. You are not responsible-for enforcing compliance by third parties with this License.-- An "entity transaction" is a transaction transferring control of an-organization, or substantially all assets of one, or subdividing an-organization, or merging organizations. If propagation of a covered-work results from an entity transaction, each party to that-transaction who receives a copy of the work also receives whatever-licenses to the work the party's predecessor in interest had or could-give under the previous paragraph, plus a right to possession of the-Corresponding Source of the work from the predecessor in interest, if-the predecessor has it or can get it with reasonable efforts.-- You may not impose any further restrictions on the exercise of the-rights granted or affirmed under this License. For example, you may-not impose a license fee, royalty, or other charge for exercise of-rights granted under this License, and you may not initiate litigation-(including a cross-claim or counterclaim in a lawsuit) alleging that-any patent claim is infringed by making, using, selling, offering for-sale, or importing the Program or any portion of it.-- 11. Patents.-- A "contributor" is a copyright holder who authorizes use under this-License of the Program or a work on which the Program is based. The-work thus licensed is called the contributor's "contributor version".-- A contributor's "essential patent claims" are all patent claims-owned or controlled by the contributor, whether already acquired or-hereafter acquired, that would be infringed by some manner, permitted-by this License, of making, using, or selling its contributor version,-but do not include claims that would be infringed only as a-consequence of further modification of the contributor version. For-purposes of this definition, "control" includes the right to grant-patent sublicenses in a manner consistent with the requirements of-this License.-- Each contributor grants you a non-exclusive, worldwide, royalty-free-patent license under the contributor's essential patent claims, to-make, use, sell, offer for sale, import and otherwise run, modify and-propagate the contents of its contributor version.+ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below. - 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.+ 0. Additional Definitions. - 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.+ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License. - 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.+ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below. - 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.+ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library. - 12. No Surrender of Others' Freedom.+ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version". - 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.+ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version. - 13. Use with the GNU Affero General Public License.+ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work. - 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.+ 1. Exception to Section 3 of the GNU GPL. - 14. Revised Versions of this License.+ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL. - 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.+ 2. Conveying Modified Versions. - 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 you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version: - 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.+ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or - 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.+ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy. - 15. Disclaimer of Warranty.+ 3. Object Code Incorporating Material from Library Header Files. - 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.+ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following: - 16. Limitation of Liability.+ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License. - 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.+ b) Accompany the object code with a copy of the GNU GPL and this license+ document. - 17. Interpretation of Sections 15 and 16.+ 4. Combined Works. - 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.+ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following: - END OF TERMS AND CONDITIONS+ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License. - How to Apply These Terms to Your New Programs+ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document. - 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.+ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document. - 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.+ d) Do one of the following: - <one line to give the program's name and a brief idea of what it does.>- Copyright (C) <year> <name of author>+ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source. - 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.+ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ 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.+ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.) - You should have received a copy of the GNU General Public License- along with this program. If not, see <http://www.gnu.org/licenses/>.+ 5. Combined Libraries. -Also add information on how to contact you by electronic and paper mail.+ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following: - If the program does terminal interaction, make it output a short-notice like this when it starts in an interactive mode:+ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License. - <program> Copyright (C) <year> <name of author>- This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.- This is free software, and you are welcome to redistribute it- under certain conditions; type `show c' for details.+ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work. -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".+ 6. Revised Versions of the GNU Lesser General Public License. - You should also get your employer (if you work as a programmer) or school,-if any, to sign a "copyright disclaimer" for the program, if necessary.-For more information on this, and how to apply and follow the GNU GPL, see-<http://www.gnu.org/licenses/>.+ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser 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. - The GNU General Public License does not permit incorporating your program-into proprietary programs. If your program is a subroutine library, you-may consider it more useful to permit linking proprietary applications with-the library. If this is what you want to do, use the GNU Lesser General-Public License instead of this License. But first, please read-<http://www.gnu.org/philosophy/why-not-lgpl.html>.+ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation. + If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
− Web/Frank.hs
@@ -1,58 +0,0 @@-{- |-Frank is a Sinatra-inspired DSL (see <http://www.sinatrarb.com>) for creating-routes. It is composable with all 'ToApplication' types, but is designed to be used-with 'Network.Wai.Controller's. Each verb ('get', 'post', 'put', etc') takes a-URL pattern of the form \"\/dir\/:paramname\/dir\" (see 'routePattern' for-details) and a 'ToApplication':--@- main :: IO ()- main = run 3000 $ controllerApp () $ do- get \"\/\" $ do- req <- request- return $ okHtml $ fromString $- \"Welcome Home \" ++ (show $ serverName req)- get \"\/user\/:id\" $ do- userId \<- queryParam \"id\" >>= fromMaybe \"\"- return $ ok \"text/json\" $ fromString $- \"{\\\"myid\\\": \" ++ (show userId) ++ \"}\"- put \"\/user\/:id\" $ do- ...-@---}-module Web.Frank- ( get- , post- , put- , delete- , options- ) where--import Network.HTTP.Types-import Web.Simple.Controller-import qualified Data.ByteString as S---- | Helper method-frankMethod :: StdMethod -> S.ByteString -> Controller r a -> Controller r ()-frankMethod method pattern = routeMethod method . routePattern pattern . routeTop---- | Matches the GET method on the given URL pattern-get :: S.ByteString -> Controller r a -> Controller r ()-get = frankMethod GET---- | Matches the POST method on the given URL pattern-post :: S.ByteString -> Controller r a -> Controller r ()-post = frankMethod POST---- | Matches the PUT method on the given URL pattern-put :: S.ByteString -> Controller r a -> Controller r ()-put = frankMethod PUT---- | Matches the DELETE method on the given URL pattern-delete :: S.ByteString -> Controller r a -> Controller r ()-delete = frankMethod DELETE---- | Matches the OPTIONS method on the given URL pattern-options :: S.ByteString -> Controller r a -> Controller r ()-options = frankMethod OPTIONS
− Web/REST.hs
@@ -1,87 +0,0 @@-{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}-module Web.REST- ( REST(..), RESTController, rest, routeREST- , index, show, create, update, delete- , edit, new- ) where--import Prelude hiding (show)--import Control.Monad-import Control.Monad.Trans.State-import Data.Functor.Identity-import Web.Simple.Responses-import Web.Simple.Controller-import Network.HTTP.Types--data REST r = REST- { restIndex :: Controller r ()- , restShow :: Controller r ()- , restCreate :: Controller r ()- , restUpdate :: Controller r ()- , restDelete :: Controller r ()- , restEdit :: Controller r ()- , restNew :: Controller r ()- }--defaultREST :: REST r-defaultREST = REST- { restIndex = respond $ notFound- , restShow = respond $ notFound- , restCreate = respond $ notFound- , restUpdate = respond $ notFound- , restDelete = respond $ notFound- , restEdit = respond $ notFound- , restNew = respond $ notFound- }--type RESTControllerM r a = StateT (REST r) Identity a--rest :: RESTControllerM r a -> REST r-rest rcontroller = snd . runIdentity $ runStateT rcontroller defaultREST--routeREST :: REST r -> Controller r ()-routeREST rst = do- routeMethod GET $ do- routeTop $ restIndex rst- routeName "new" $ restNew rst- routeVar "id" $ do- routeTop $ restShow rst- routeName "edit" $ restEdit rst-- routeMethod POST $ routeTop $ restCreate rst-- routeMethod DELETE $ routeVar "id" $ restDelete rst-- routeMethod PUT $ routeVar "id" $ restUpdate rst--type RESTController r = RESTControllerM r ()--index :: Controller r a -> RESTController r-index route = modify $ \controller ->- controller { restIndex = void route }--create :: Controller r a -> RESTController r-create route = modify $ \controller ->- controller { restCreate = void route }--edit :: Controller r a -> RESTController r-edit route = modify $ \controller ->- controller { restEdit = void route }--new :: Controller r a -> RESTController r-new route = modify $ \controller ->- controller { restNew = void route }--show :: Controller r a -> RESTController r-show route = modify $ \controller ->- controller { restShow = void route }--update :: Controller r a -> RESTController r-update route = modify $ \controller ->- controller { restUpdate = void route }--delete :: Controller r a -> RESTController r-delete route = modify $ \controller ->- controller { restDelete = void route }-
− Web/Simple.hs
@@ -1,256 +0,0 @@-{- |---/Simple/ is based on WAI - an standard interface for communicating between web-servers (like warp) and web applications. You can use /Simple/ completely-independently (and of course, use any WAI server to run it). Alternatively, you-can embed existing existing WAI applications inside an app built with /Simple/,-and embed an app built with simple in another WAI app.--All the components in /Simple/ are designed to be small and simple-enough to understand, replaceable, and work as well independantly as they do-together.---}-module Web.Simple (- module Web.Simple.Responses- , module Web.Simple.Controller- -- * Overview- -- $Overview-- -- * Tutorial- -- $Tutorial-- -- ** Controllers- -- $Controllers-- -- ** Routing- -- $Routing- ) where--import Web.Simple.Responses-import Web.Simple.Controller--{- $Overview- #overview#--WAI applications are functions of type 'Network.Wai.Application' - given a-client 'Network.Wai.Request' they return a 'Network.Wai.Response' to return to-the client (i.e. an HTTP status code, headers, body etc\'). A /Simple/-application 'Controller' -- a wrapper around WAI\'s 'Network.Wai.Application'-either returns a monadic value, or a 'Network.Wai.Response'. This allows-'Controller's to be chained together to create arbitrary complex routes. If a-'Controller' \"matches\" a route (e.g., based on the HTTP path, hostname,-cookies etc), it can 'respond' which shortcircuits the remaining execution and-immediately send the response back to the client. If none, of the 'Controller's-match, an HTTP 404 (NOT FOUND) response will be returned.--For example, this is a trivial \Simple\ app that notices whether the incoming-request was for the hostname \"hackage.haskell.org\" or \"www.haskell.org\":--@- routeHost \"hackage.haskell.org\" $ do- respond $ okHtml \"Welcome to Hackage\"-- routeHost \"www.haskell.org\" $ do- respond $ okHtml \"You\'ve reached the Haskell Language home page\"-@--'routeHost' is a combinator that matches the a request based on the \"Host\"-header and defers to the passed in 'Controller' or returns '()'. There are-other built-in combinators for matching based on the request path, the HTTP-method, and it\'s easy to write your own combinators. You can chain such-combinators together monadically or using 'mappend' (since 'Controller' is an-instance of 'Monoid'). A typical /Simple/ app looks something like this:--@- controllerApp () $ do- routeTop $ do- ... handle home page ...- routeName \"posts\" $ do- routeMethod GET $- ... get all posts ...- routeMethod POST $- ... create new post ...-@--where 'controllerApp' generates an 'Network.Wai.Application' from a 'Controller'-returning a 404 (not found) response if all routes fail.--This package also includes the "Web.Frank" module which provide an API to create-applications similar to the Sinatra framework for Ruby, and the "Web.REST"-module to create RESTful applications similar to Ruby on Rails. Neither of-these modules is \"special\", in the sense that they are merely implemented in-terms of 'Controller's. The example above could be rewritten using "Web.Frank"-as such:--@- controllerApp () $ do- get \"/\" $ do- ... display home page ...- get \"/posts\" $ do- ... get all posts ...- post \"/posts\" $ do- ... create new post ...-@--\Simple\ is broken down into the following modules:--@- Web- |-- "Web.Simple" - Re-exports most common modules- | |-- "Web.Simple.Controller" - Base monad and built-in routing combinators- | |-- "Web.Simple.Responses" - Common HTTP responses- | |-- "Web.Simple.Auth" - 'Controller's for authentication- | |-- "Web.Simple.Cache" - in memory and filesystem cache utilities- |-- "Web.Frank" - Sinatra style 'Route's- +-- "Web.REST" - Monad for creating RESTful controllers-@---}--{- $Tutorial-#tutorial#--/Simple/ comes with a utility called \smpl\ which automates some common tasks-like creating a new application, running migrations and launching a development-server. To create a new /Simple/ app in a directory called \"example_app\", run:--@- $ smpl create example_app-@--This will create a directory called \"example_app\" containing a /.cabal/ file-and and a single Haskell source file, \"Main.hs\":--@-\{\-\# LANGUAGE OverloadedStrings #\-\}--module Main where--import Web.Simple-import Network.Wai.Handler.Warp-import System.Posix.Env--app :: (Application -> IO ()) -> IO ()-app runner = runner $ do- -- TODO: App initialization code here- controllerApp () $ do- respond $ okHtml \"Hello World\"--main :: IO ()-main = do- port <- read \`fmap\` getEnvDefault \"PORT\" \"3000\"- app (run port)-@--The `app` function is the entry point to your application. The argument is a-function that knows how to run a `Network.Wai.Application` -- for example,-warp's run method. `mkRouter` transforms a `Routeable` into an-`Network.Wai.Application`. The boilerplate is just a `Response` with the body-\"Hello World\" (and content-type \"text/html\"). To run a development server-on port 3000:--@- $ cd example_app- $ smpl-@--Pointing your browser to <http://localhost:3000> should display-\"Hello World\"!--}--{- $Controllers-#controllers#--What is this 'controllerApp' business? The basic type in /Simple/ is a-'Controller' which contains both a 'Request' and app specific state.-'controllerApp' takes an initial application state (/unit/ in the example above)-and transforms a 'Controller' into a WAI 'Application' so it can be run by a-server like warp.--A 'Controller' is a 'Monad' that can perform actions in 'IO' (using 'liftIO'),-access the underlying 'request' or application state (via 'controllerState').-Finally, a 'Controller' can 'respond' to a request. 'respond' short-circuits-the rest of the computation and returns the 'Response' to the client.-'controllerApp' transforms a 'Controller' into a WAI application by running the-'Controller'. If the 'Controller' does not call 'respond', 'controllerApp'-defaults to responding to the client with a 404 not found. For example:--@-controllerApp () $ do- liftIO $ putStrLn \"Responding to request\"- respond $ okHtml \"Hello World\"- liftIO $ putStrLn \"This message is never actually printed\"-@--When run, this code will always print the first message-(\"Responding to request\") and respond with a 200 page containing \"Hello-World\", but never print the second message. Short-circuiting the computation-in this way allows us to respond in different ways based on the request:--@-controllerApp () $ do- path \<- rawPathInfo \<$> request- when (path == \"/timeofday\") $ do- timeStr \<- liftIO $ S8.pack . show \<$> getClockTime- respond $ okHtml timeStr- when (path == \"/whoami\") $- user \<- liftIO $ S8.pack \<$> getLoginName- respond $ okHtml user-@--This controller will respond with the current time if the path \"/timeofday\"-is requested, and the user running the server if the path \"/whoami\" is-requested. If neither of those paths match, it will respond with a 404-(NOT FOUND).-- -}--{- $Routing-#routing#--An app that does the same thing for every request is not very useful (well, it-might be, but if it is, even /Simple/ is not simple enough for you). We want to-build applications that do perform different actions based on properties of the-client\'s request - e.g., the path requests, GET or POST requests, the \"Host\"-header, etc\'. /Simple/\'s 'Controller's are flexible to accomplish this.-'Controller's encapsulate a function from a 'Request' to 'Either' a 'Response'-or some monadic value.--For example, let\'s extend the example using the 'Monad' syntax:--@-controllerApp () $ do- routeTop $ do- routeHost \"localhost\" $ respond $ okHtml \"Hello, localhost!\"- routeHost \"test.lvh.me\" $ respond $ okHtml \"Hello, test.lvh.me!\"- routeName \"advice\" $ okHtml \"Be excellent to each other!\"-@--Now, the app will respond differently depending on whether the client is-requesting the host name \"localhost\" or \"test.lvh.me\", or if the requested-path is \"\/advice\" rather than \"\/\". Take it for a spin in the browser (make-sure `smpl` is still running):-- * <http://localhost:3000>-- * <http://test.lvh.me:3000>-- * <http://localhost:3000/advice>--In this example, 'routeTop' matches if the 'Network.Wai.Request's-'Network.Wai.pathInfo' is empty, which means the requested path is \"\/\" (as-in this case), or the rest of the path has been consumed by previous 'Route's.-'routeName' matches if the next component in the path (specifically the 'head'-of 'Network.Wai.pathInfo') matches the argument (and if so, removes it). Check-out "Web.Simple.Router" for more complete documentation of these and other-'Route's.--For many apps it will be convenient to use even higher level routing APIs. The-modules "Web.Frank" and "Web.Sinatra" provide Sinatra-like and RESTful APIs,-respectively. Both modules are implement purely in terms of 'Route's and you-can easily implement your own patterns as well.---}-
− Web/Simple/Auth.hs
@@ -1,70 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Provides HTTP Basic Authentication.-module Web.Simple.Auth- ( AuthRouter- , basicAuthRoute, basicAuth, authRewriteReq- ) where--import Control.Monad-import Data.ByteString.Base64-import qualified Data.ByteString.Char8 as S8-import Data.Maybe-import Network.HTTP.Types-import Network.Wai-import Web.Simple.Responses-import Web.Simple.Controller---- | An 'AuthRouter' authenticates a 'Request' and, if successful, forwards the--- 'Request' to the 'Routeable'.-type AuthRouter r a = (Request -> S8.ByteString- -> S8.ByteString- -> Controller r (Maybe Request))- -> Controller r a- -> Controller r a---- | An 'AuthRouter' that uses HTTP basic authentication to authenticate a request--- in a particular realm.-basicAuthRoute :: String -> AuthRouter r a-basicAuthRoute realm testAuth next = do- req <- request- let authStr = fromMaybe "" $ lookup hAuthorization (requestHeaders req)- when (S8.take 5 authStr /= "Basic") requireAuth-- case fmap (S8.split ':') $ decode $ S8.drop 6 authStr of- Right (user:pwd:[]) -> do- mfin <- testAuth req user pwd- maybe requireAuth (\finReq -> localRequest (const finReq) next) mfin- _ -> requireAuth- where requireAuth = respond $ requireBasicAuth realm---- | Wraps an 'AuthRouter' to take a simpler authentication function (that just--- just takes a username and password, and returns 'True' or 'False'). It also--- adds an \"X-User\" header to the 'Request' with the authenticated user\'s--- name (the first argument to the authentication function).-authRewriteReq :: AuthRouter r a- -> (S8.ByteString -> S8.ByteString -> Controller r Bool)- -> Controller r a- -> Controller r a-authRewriteReq authRouter testAuth rt =- authRouter (\req user pwd -> do- success <- testAuth user pwd- if success then- return $ Just $ transReq req user- else return Nothing) rt- where transReq req user = req- { requestHeaders = ("X-User", user):(requestHeaders req)}---- | A 'Route' that uses HTTP basic authentication to authenticate a request for a realm--- with the given username ans password. The request is rewritten with an 'X-User' header--- containing the authenticated username before being passed to the next 'Route'.-basicAuth :: String- -- ^ Realm- -> S8.ByteString- -- ^ Username- -> S8.ByteString- -- ^ Password- -> Controller r a -> Controller r a-basicAuth realm user pwd = authRewriteReq (basicAuthRoute realm)- (\u p -> return $ u == user && p == pwd)-
− Web/Simple/Cache.hs
@@ -1,86 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}---- | Provides a general caching interface along with a simple in-memory--- (process only) and file based cache implementations.-module Web.Simple.Cache - ( -- * Cache Interface- Cache(..), fetchOr- -- * Cache Implementations- , FileSystemCache, newFileSystemCache- , InMemCache, newInMemCache- ) where--import Control.Monad-import Control.Monad.IO.Class-import qualified Data.ByteString.Lazy.Char8 as L8-import qualified Data.HashTable.IO as H-import System.FilePath-import System.Directory---- | A class that captures a simple key-value caching interface. The keys are--- simply 'String'\'s and values are simply 'ByteString'\'s.-class Cache c where- put :: MonadIO m => c -> String -> L8.ByteString -> m L8.ByteString- -- ^ Store a value in the cache. The returned value should be the value that- -- was just stored.- fetch :: MonadIO m => c -> String -> m (Maybe L8.ByteString)- -- ^ Retrieve a value from the cache.- invalidate :: MonadIO m => c -> String -> m ()- -- ^ Invalidate a potentially existing value in the cache. Depending on the- -- implementation this may or may not free the space used by the key-value- -- pair.--fetchOr :: (Cache c, MonadIO m)- => c- -> String- -> m L8.ByteString- -> m L8.ByteString-fetchOr c path act = do- mcached <- fetch c path- maybe (act >>= put c path) return mcached---- | A file based cache implementation. Files are stored in subdirectories of--- @fsCacheBase@.-newtype FileSystemCache = FileSystemCache { fsCacheBase :: FilePath }---- | Create a new @FileSystemCache@.-newFileSystemCache :: FilePath -> FileSystemCache-newFileSystemCache = FileSystemCache--instance Cache FileSystemCache where- put c path d = liftIO $ do- let components = splitDirectories $ dropDrive path- let fullPath = (fsCacheBase c):components- createDirectoryIfMissing True $- joinPath $ reverse $ tail $ reverse fullPath- L8.writeFile (joinPath fullPath) d- return d-- fetch c path = liftIO $ do- let components = splitDirectories $ dropDrive path- let fullPath = joinPath $ (fsCacheBase c):components- exists <- doesFileExist fullPath- if exists then- fmap Just $ L8.readFile fullPath- else return Nothing-- invalidate c path = liftIO $ do- let components = splitDirectories $ dropDrive path- let fullPath = joinPath $ (fsCacheBase c):components- exists <- doesFileExist fullPath- when exists $- removeFile fullPath---- | An in-memory cache implementation. The current processes heap space is--- simply used as the cache.-newtype InMemCache = InMemCache (H.BasicHashTable String L8.ByteString)---- | Create a new @InMemCache@.-newInMemCache :: MonadIO m => m InMemCache-newInMemCache = liftIO $ fmap InMemCache H.new--instance Cache InMemCache where- put (InMemCache h) path d = liftIO $ H.insert h path d >> return d- fetch (InMemCache h) = liftIO . (H.lookup h)- invalidate (InMemCache h) = liftIO . (H.delete h)-
− Web/Simple/Controller.hs
@@ -1,428 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}--{- | 'Controller' provides a convenient syntax for writting 'Application'- code as a Monadic action with access to an HTTP request as well as app- specific data (e.g. a database connection pool, app configuration etc.)- This module also defines some- helper functions that leverage this feature. For example, 'redirectBack'- reads the underlying request to extract the referer and returns a redirect- response:-- @- myController = do- ...- if badLogin then- redirectBack- else- ...- @--}-module Web.Simple.Controller- (- -- * Example- -- $Example- -- * Controller Monad- Controller(..), runController, runControllerIO- , controllerApp, controllerState, localState- , request, localRequest, respond- -- * Common Routes- , routeHost, routeTop, routeMethod, routeAccept- , routePattern, routeName, routeVar- -- * Inspecting query- , Parseable- , queryParam, queryParam', queryParams- , readQueryParam, readQueryParam', readQueryParams- , parseForm- -- * Redirection via referrer- , redirectBack- , redirectBackOr- -- * Exception handling- , ControllerException- , module Control.Exception.Peel- -- * Integrating other WAI components- , ToApplication(..)- , fromApp- -- * Low-level utilities- , body- -- , guard, guardM, guardReq- ) where--import Control.Applicative-import Control.Exception.Peel-import Control.Monad hiding (guard)-import Control.Monad.IO.Class-import Control.Monad.IO.Peel-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy.Char8 as L8-import Data.Conduit-import qualified Data.Conduit.List as CL-import Data.List (find)-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Typeable-import Network.HTTP.Types-import Network.Wai-import Network.Wai.Parse-import Web.Simple.Responses---- | The Controller Monad is both a Reader-like monad which, when run, computes--- either a 'Response' or a result. Within the Controller Monad, the remainder--- of the computation can be short-circuited by 'respond'ing with a 'Response'.-newtype Controller r a =- Controller ((r,Request) -> ResourceT IO (Either Response a))--instance Functor (Controller r) where- fmap f (Controller act) = Controller $ \st -> do- eaf <- act st- case eaf of- Left resp -> return $ Left resp- Right result -> return $ Right $ f result--instance Applicative (Controller r) where- pure a = Controller $ \_ -> return $ Right a- (Controller fn) <*> (Controller act) =- Controller $ \st -> do- eact <- act st- case eact of- Left resp -> return $ Left resp- Right result -> do- ef <- fn st- either (return . Left) (\f -> return . Right $ f result) ef--instance Monad (Controller r) where- return = pure- (Controller act) >>= fn = Controller $ \st -> do- eres <- act st- case eres of- Left resp -> return $ Left resp- Right result -> do- let (Controller fres) = fn result- fres st--instance MonadIO (Controller r) where- liftIO act = Controller $ \_ -> fmap Right $ liftIO act--hoistEither :: Either Response a -> Controller r a-hoistEither eith = Controller $ \_ -> return eith--instance MonadPeelIO (Controller r) where- peelIO = do- r <- controllerState- req <- request- return $ \ctrl -> do- res <- runControllerIO ctrl r req- return $ hoistEither res--ask :: Controller r (r, Request)-ask = Controller $ \rd -> return (Right rd)---- | Extract the request-request :: Controller r Request-request = liftM snd ask--local :: ((r, Request) -> (r, Request)) -> Controller r a -> Controller r a-local f (Controller act) = Controller $ \st -> act (f st)---- | Modify the request for the given computation-localRequest :: (Request -> Request) -> Controller r a -> Controller r a-localRequest f = local (\(r,req) -> (r, f req))---- | Extract the application-specific state-controllerState :: Controller r r -controllerState = liftM fst ask---- | Modify the application state for the given computation-localState :: (r -> r) -> Controller r a -> Controller r a-localState f = local (\(r,req) -> (f r, req))---- | Convert the controller into an 'Application'-controllerApp :: r -> Controller r a -> Application-controllerApp r ctrl req =- runController ctrl r req >>=- either return (const $ return notFound) --runController :: Controller r a -> r -> Request -> ResourceT IO (Either Response a)-runController (Controller fun) r req = fun (r,req)---- | Run a 'Controller' in the @IO@ monad-runControllerIO :: Controller r a -> r -> Request -> IO (Either Response a)-runControllerIO ctrl r = runResourceT . runController ctrl r---- | Decline to handle the request------ @pass >> c === c@--- @c >> pass === c@-pass :: Controller r ()-pass = Controller $ \_ -> return (Right ())---- | Provide a response------ @respond r >>= f === respond r@-respond :: Response -> Controller r a-respond resp = Controller $ \_ -> return $ Left resp----- | Lift an application to a controller-fromApp :: ToApplication a => a -> Controller r ()-fromApp app = Controller (\(_, req) -> Left `fmap` ((toApp app) req))---- | Matches on the hostname from the 'Request'. The route only succeeds on--- exact matches.-routeHost :: S.ByteString -> Controller r a -> Controller r ()-routeHost host = guardReq $ (host ==) . serverName---- | Matches if the path is empty.------ Note that this route checks that 'pathInfo'--- is empty, so it works as expected in nested contexts that have--- popped components from the 'pathInfo' list.-routeTop :: Controller r a -> Controller r ()-routeTop = guardReq $ \req -> null (pathInfo req) ||- (T.length . head $ pathInfo req) == 0---- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT')-routeMethod :: StdMethod -> Controller r a -> Controller r ()-routeMethod method = guardReq $ (renderStdMethod method ==) . requestMethod---- | Matches if the request's Content-Type exactly matches the given string-routeAccept :: S8.ByteString -> Controller r a -> Controller r ()-routeAccept contentType = guardReq (isJust . find matching . requestHeaders)- where matching hdr = fst hdr == hAccept && snd hdr == contentType---- | Routes the given URL pattern. Patterns can include--- directories as well as variable patterns (prefixed with @:@) to be added--- to 'queryString' (see 'routeVar')------ * \/posts\/:id------ * \/posts\/:id\/new------ * \/:date\/posts\/:category\/new----routePattern :: S.ByteString -> Controller r a -> Controller r ()-routePattern pattern route =- let patternParts = map T.unpack $ decodePathSegments pattern- in foldr mkRoute (route >> return ()) patternParts- where mkRoute (':':varName) = routeVar (S8.pack varName)- mkRoute name = routeName (S8.pack name)---- | Matches if the first directory in the path matches the given 'ByteString'-routeName :: S.ByteString -> Controller r a -> Controller r ()-routeName name next = do- req <- request- if (length $ pathInfo req) > 0 && S8.unpack name == (T.unpack . head . pathInfo) req- then localRequest popHdr next >> return ()- else pass- where popHdr req = req { pathInfo = (tail . pathInfo $ req) }---- | Always matches if there is at least one directory in 'pathInfo' but and--- adds a parameter to 'queryString' where the key is the first parameter and--- the value is the directory consumed from the path.-routeVar :: S.ByteString -> Controller r a -> Controller r ()-routeVar varName next = do- req <- request- case pathInfo req of- [] -> pass- x:_ | T.null x -> pass- | otherwise -> localRequest popHdr next >> return ()- where popHdr req = req {- pathInfo = (tail . pathInfo $ req)- , queryString = (varName, Just (varVal req)):(queryString req)}- varVal req = S8.pack . T.unpack . head . pathInfo $ req------- query parameters------- | Looks up the parameter name in the request's query string and returns the--- @Parseable@ value or 'Nothing'.------ For example, for a request with query string: \"?foo=bar&baz=7\",--- @queryParam \"foo\"@--- would return @Just "bar"@, but--- @queryParam \"zap\"@--- would return @Nothing@.-queryParam :: Parseable a- => S8.ByteString -- ^ Parameter name- -> Controller r (Maybe a)-queryParam varName = do- qr <- liftM queryString request- return $ case lookup varName qr of- Just p -> Just $ parse $ fromMaybe S.empty p- _ -> Nothing---- | Like 'queryParam', but throws an exception if the parameter is not present.-queryParam' :: Parseable a- => S.ByteString -> Controller r a-queryParam' varName =- queryParam varName >>= maybe (err $ "no parameter " ++ show varName) return---- | Selects all values with the given parameter name-queryParams :: Parseable a- => S.ByteString -> Controller r [a]-queryParams varName = request >>= return .- map (parse . fromMaybe S.empty . snd) .- filter ((== varName) . fst) .- queryString---- | The class of types into which query parameters may be converted-class Parseable a where- parse :: S8.ByteString -> a--instance Parseable S8.ByteString where- parse = id-instance Parseable String where- parse = S8.unpack-instance Parseable Text where- parse = T.decodeUtf8---- | Like 'queryParam', but further processes the parameter value with @read@.--- If that conversion fails, an exception is thrown.-readQueryParam :: Read a- => S8.ByteString -- ^ Parameter name- -> Controller r (Maybe a)-readQueryParam varName =- queryParam varName >>= maybe (return Nothing) (liftM Just . readParamValue varName)---- | Like 'readQueryParam', but throws an exception if the parameter is not present.-readQueryParam' :: Read a- => S8.ByteString -- ^ Parameter name- -> Controller r a-readQueryParam' varName =- queryParam' varName >>= readParamValue varName---- | Like 'queryParams', but further processes the parameter values with @read@.--- If any read-conversion fails, an exception is thrown.-readQueryParams :: Read a- => S8.ByteString -- ^ Parameter name- -> Controller r [a]-readQueryParams varName =- queryParams varName >>= mapM (readParamValue varName)--readParamValue :: Read a => S8.ByteString -> Text -> Controller r a-readParamValue varName =- maybe (err $ "cannot read parameter: " ++ show varName) return .- readMay . T.unpack- where readMay s = case [x | (x,rst) <- reads s, ("", "") <- lex rst] of- [x] -> Just x- _ -> Nothing---- | Parses a HTML form from the request body. It returns a list of 'Param's as--- well as a list of 'File's, which are pairs mapping the name of a /file/ form--- field to a 'FileInfo' pointing to a temporary file with the contents of the--- upload.------ @--- myController = do--- (prms, files) <- parseForm--- let mPicFile = lookup \"profile_pic\" files--- case mPicFile of--- Just (picFile) -> do--- sourceFile (fileContent picFile) $$--- sinkFile (\"images/\" ++ (fileName picFile))--- respond $ redirectTo \"/\"--- Nothing -> redirectBack--- @-parseForm :: Controller r ([Param], [(S.ByteString, FileInfo FilePath)])-parseForm = Controller $ \(_, req) -> do- Right `fmap` parseRequestBody tempFileBackEnd req---- | Reads and returns the body of the HTTP request.-body :: Controller r L8.ByteString-body = Controller $ \(_, req) -> do- Right `fmap` (requestBody req $$ CL.consume >>= return . L8.fromChunks)---- | Returns the value of the given request header or 'Nothing' if it is not--- present in the HTTP request.-requestHeader :: HeaderName -> Controller r (Maybe S8.ByteString)-requestHeader name = request >>= return . lookup name . requestHeaders---- | Redirect back to the referer. If the referer header is not present--- redirect to root (i.e., @\/@).-redirectBack :: Controller r ()-redirectBack = redirectBackOr (redirectTo "/")---- | Redirect back to the referer. If the referer header is not present--- fallback on the given 'Response'.-redirectBackOr :: Response -- ^ Fallback response- -> Controller r ()-redirectBackOr def = do- mrefr <- requestHeader "referer"- case mrefr of- Just refr -> respond $ redirectTo $ S8.unpack refr- Nothing -> respond def---- guard--guard :: Bool -> Controller r a -> Controller r ()-guard b c = if b then c >> return () else pass--guardM :: Controller r Bool -> Controller r a -> Controller r ()-guardM b c = b >>= flip guard c--guardReq :: (Request -> Bool) -> Controller r a -> Controller r ()-guardReq f = guardM (liftM f request)---- | The class of types that can be converted to an 'Application'-class ToApplication r where- toApp :: r -> Application--instance ToApplication Application where- toApp = id--instance ToApplication Response where- toApp = const . return--data ControllerException = ControllerException String- deriving (Typeable)--instance Show ControllerException where- show (ControllerException msg) = "Controller: " ++ msg--instance Exception ControllerException--err :: String -> Controller r a-err = throwIO . ControllerException--{- $Example- #example#--The most basic 'Routeable' types are 'Application' and 'Response'. Reaching-either of these types marks a termination in the routing lookup. This module-exposes a monadic type 'Route' which makes it easy to create routing logic-in a DSL-like fashion.--'Route's are concatenated using the '>>' operator (or using do-notation).-In the end, any 'Routeable', including a 'Route' is converted to an-'Application' and passed to the server using 'mkRoute':--@-- mainAction :: Controller () ()- mainAction = ...-- signinForm :: Controller () ()- signinForm req = ...-- login :: Controller () ()- login = ...-- updateProfile :: Controller () ()- updateProfile = ...-- main :: IO ()- main = run 3000 $ controllerApp () $ do- routeTop mainAction- routeName \"sessions\" $ do- routeMethod GET signinForm- routeMethod POST login- routeMethod PUT $ routePattern \"users/:id\" updateProfile- routeAll $ responseLBS status404 [] \"Are you in the right place?\"-@---}
− Web/Simple/Responses.hs
@@ -1,138 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | This module defines some convenience functions for creating responses.-module Web.Simple.Responses- ( ok, okHtml, okJson- , movedTo, redirectTo- , badRequest, requireBasicAuth, forbidden- , notFound- , serverError- ) where--import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy.Char8 as L8-import Network.HTTP.Types-import Network.Wai---- | Type alias for 'S8.ByteString'-type ContentType = S8.ByteString---- | Creates a 200 (OK) 'Response' with the given content-type and resposne--- body-ok :: ContentType -> L8.ByteString -> Response-ok contentType body =- responseLBS status200 [(hContentType, contentType)] body---- | Helper to make responses with content-type \"text/html\"-mkHtmlResponse :: Status -> [Header] -> L8.ByteString -> Response-mkHtmlResponse stat hdrs =- responseLBS stat ((hContentType, S8.pack "text/html"):hdrs)---- | Creates a 200 (OK) 'Response' with content-type \"text/html\" and the--- given resposne body-okHtml :: L8.ByteString -> Response-okHtml body =- mkHtmlResponse status200 [] body---- | Creates a 200 (OK) 'Response' with content-type \"application/json\" and the--- given resposne body-okJson :: L8.ByteString -> Response-okJson = ok (S8.pack "application/json")---- | Given a URL returns a 301 (Moved Permanently) 'Response' redirecting to--- that URL.-movedTo :: String -> Response-movedTo url = mkHtmlResponse status301 [(hLocation, S8.pack url)] html- where html = L8.concat- [L8.pack- "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\- \<HTML><HEAD>\n\- \<TITLE>301 Moved Permanently</TITLE>\n\- \</HEAD><BODY>\n\- \<H1>Moved Permanently</H1>\n\- \<P>The document has moved <A HREF=\""- , L8.pack url- , L8.pack "\">here</A>\n\- \</BODY></HTML>\n"]---- | Given a URL returns a 303 (See Other) 'Response' redirecting to that URL.-redirectTo :: String -> Response-redirectTo url = mkHtmlResponse status303 [(hLocation, S8.pack url)] html- where html = L8.concat- [L8.pack- "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\- \<HTML><HEAD>\n\- \<TITLE>303 See Other</TITLE>\n\- \</HEAD><BODY>\n\- \<H1>See Other</H1>\n\- \<P>The document has moved <A HREF=\""- , L8.pack url- , L8.pack "\">here</A>\n\- \</BODY></HTML>\n"]---- | Returns a 400 (Bad Request) 'Response'.-badRequest :: Response-badRequest = mkHtmlResponse status400 [] html- where html = L8.concat- [L8.pack- "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\- \<HTML><HEAD>\n\- \<TITLE>400 Bad Request</TITLE>\n\- \</HEAD><BODY>\n\- \<H1>Bad Request</H1>\n\- \<P>Your request could not be understood.</P>\n\- \</BODY></HTML>\n"]---- | Returns a 401 (Authorization Required) 'Response' requiring basic--- authentication in the given realm.-requireBasicAuth :: String -> Response-requireBasicAuth realm = mkHtmlResponse status401- [("WWW-Authenticate", S8.concat ["Basic realm=", S8.pack . show $ realm])] html- where html = L8.concat- [L8.pack- "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\- \<HTML><HEAD>\n\- \<TITLE>401 Authorization Required</TITLE>\n\- \</HEAD><BODY>\n\- \<H1>Authorization Required</H1>\n\- \</BODY></HTML>\n"]---- | Returns a 403 (Forbidden) 'Response'.-forbidden :: Response-forbidden = mkHtmlResponse status403 [] html- where html = L8.concat- [L8.pack- "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\- \<HTML><HEAD>\n\- \<TITLE>403 Forbidden</TITLE>\n\- \</HEAD><BODY>\n\- \<H1>Forbidden</H1>\n\- \<P>You don't have permission to access this page.</P>\n\- \</BODY></HTML>\n"]---- | Returns a 404 (Not Found) 'Response'.-notFound :: Response-notFound = mkHtmlResponse status404 [] html- where html = L8.concat- [L8.pack- "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\- \<HTML><HEAD>\n\- \<TITLE>404 Not Found</TITLE>\n\- \</HEAD><BODY>\n\- \<H1>Not Found</H1>\n\- \<P>The requested URL was not found on this server.</P>\n\- \</BODY></HTML>\n"]---- | Returns a 500 (Server Error) 'Response'.-serverError :: L8.ByteString -> Response-serverError message = mkHtmlResponse status500 [] html- where html = L8.concat- [L8.pack- "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\- \<HTML><HEAD>\n\- \<TITLE>500 Internal Server Error</TITLE>\n\- \</HEAD><BODY>\n\- \<H1>Internal Server Error</H1>\n\- \<P>", message,- "</P></BODY></HTML>\n"]-
simple.cabal view
@@ -1,8 +1,5 @@--- Initial wai-routes.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/- name: simple-version: 0.5.0+version: 0.6.0 synopsis: A minimalist web framework for the WAI server interface description: @@ -27,17 +24,19 @@ @ . See "Web.Simple" for a more detailed introduction.-license: GPL-3+homepage: http://simple.cx+license: LGPL-3 license-file: LICENSE author: Amit Levy, Daniel B. Giffin maintainer: amit@amitlevy.com category: Web build-type: Simple-cabal-version: >=1.9.2+cabal-version: >=1.10 data-files: template/*.tmpl executable smpl+ hs-source-dirs: src Main-Is: smpl.hs ghc-options: -Wall build-depends:@@ -50,16 +49,18 @@ , directory , filepath , process+ , setenv , stringsearch+ default-language: Haskell2010 library+ hs-source-dirs: src build-depends: base < 6 , base64-bytestring , conduit , directory , filepath- , hashtables , wai , wai-extra , http-types@@ -73,13 +74,13 @@ exposed-modules: Web.Simple, Web.Simple.Auth,- Web.Simple.Cache, Web.Simple.Controller, Web.Simple.Responses, Web.Frank, Web.REST+ default-language: Haskell2010 source-repository head type: git- location: anonymous@gitstar.com:alevy/wai-lite.git+ location: anonymous@gitstar.com:alevy/simple.git
− smpl.hs
@@ -1,58 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}---- | The `smpl` utility for helping a user setup a Simple web project.-module Main (main) where--import Prelude hiding (writeFile, FilePath)-import Control.Monad-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy.Char8 as L8-import qualified Data.ByteString.Lazy.Search as L8-import System.Console.CmdArgs-import System.Directory-import System.FilePath-import System.Environment-import System.Process--import Paths_simple--data Smpl =- Server- { port :: Int- , moduleName :: String- } |- Create { appName :: String }- deriving (Show, Data, Typeable)--main :: IO ()-main = do- myenv <- getEnvironment- let myport = maybe 3000 read $ lookup "PORT" myenv- let develMode = cmdArgsMode $ modes- [ Server { port = myport &= typ "PORT"- , moduleName = "Main" &= typ "MODULE"- &= explicit &= name "module"- } &= auto- , Create { appName = "" &= argPos 0 &= typ "APP_NAME" } ]- smpl <- cmdArgsRun develMode- case smpl of- Server p m -> void $- rawSystem "wai-handler-devel" [show p, m, "app"]- Create myAppName -> createApplication myAppName--createApplication :: String -> IO ()-createApplication myAppName = do- createDirectory myAppName- let mappings = [("pkgname", myAppName)]- copyTemplate ("template" </> "Main_hs.tmpl")- (myAppName </> "Main.hs") mappings- copyTemplate ("template" </> "package_cabal.tmpl")- (myAppName </> myAppName ++ ".cabal") mappings--copyTemplate :: FilePath -> FilePath -> [(String, String)] -> IO ()-copyTemplate orig target mappings = do- tmpl <- getDataFileName orig >>= L8.readFile- L8.writeFile target $- (flip . flip foldl) tmpl mappings $ \accm (key, val) ->- L8.replace (S8.pack $ "{{" ++ key ++ "}}") (L8.pack val) accm-
+ src/Web/Frank.hs view
@@ -0,0 +1,58 @@+{- |+Frank is a Sinatra-inspired DSL (see <http://www.sinatrarb.com>) for creating+routes. It is composable with all 'ToApplication' types, but is designed to be used+with 'Network.Wai.Controller's. Each verb ('get', 'post', 'put', etc') takes a+URL pattern of the form \"\/dir\/:paramname\/dir\" (see 'routePattern' for+details) and a 'ToApplication':++@+ main :: IO ()+ main = run 3000 $ controllerApp () $ do+ get \"\/\" $ do+ req <- request+ return $ okHtml $ fromString $+ \"Welcome Home \" ++ (show $ serverName req)+ get \"\/user\/:id\" $ do+ userId \<- queryParam \"id\" >>= fromMaybe \"\"+ return $ ok \"text/json\" $ fromString $+ \"{\\\"myid\\\": \" ++ (show userId) ++ \"}\"+ put \"\/user\/:id\" $ do+ ...+@++-}+module Web.Frank+ ( get+ , post+ , put+ , delete+ , options+ ) where++import Network.HTTP.Types+import Web.Simple.Controller+import qualified Data.ByteString as S++-- | Helper method+frankMethod :: StdMethod -> S.ByteString -> Controller r a -> Controller r ()+frankMethod method pattern = routeMethod method . routePattern pattern . routeTop++-- | Matches the GET method on the given URL pattern+get :: S.ByteString -> Controller r a -> Controller r ()+get = frankMethod GET++-- | Matches the POST method on the given URL pattern+post :: S.ByteString -> Controller r a -> Controller r ()+post = frankMethod POST++-- | Matches the PUT method on the given URL pattern+put :: S.ByteString -> Controller r a -> Controller r ()+put = frankMethod PUT++-- | Matches the DELETE method on the given URL pattern+delete :: S.ByteString -> Controller r a -> Controller r ()+delete = frankMethod DELETE++-- | Matches the OPTIONS method on the given URL pattern+options :: S.ByteString -> Controller r a -> Controller r ()+options = frankMethod OPTIONS
+ src/Web/REST.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}+module Web.REST+ ( REST(..), RESTController, rest, routeREST+ , index, show, create, update, delete+ , edit, new+ ) where++import Prelude hiding (show)++import Control.Monad+import Control.Monad.Trans.State+import Data.Functor.Identity+import Web.Simple.Responses+import Web.Simple.Controller+import Network.HTTP.Types++data REST r = REST+ { restIndex :: Controller r ()+ , restShow :: Controller r ()+ , restCreate :: Controller r ()+ , restUpdate :: Controller r ()+ , restDelete :: Controller r ()+ , restEdit :: Controller r ()+ , restNew :: Controller r ()+ }++defaultREST :: REST r+defaultREST = REST+ { restIndex = respond $ notFound+ , restShow = respond $ notFound+ , restCreate = respond $ notFound+ , restUpdate = respond $ notFound+ , restDelete = respond $ notFound+ , restEdit = respond $ notFound+ , restNew = respond $ notFound+ }++type RESTControllerM r a = StateT (REST r) Identity a++rest :: RESTControllerM r a -> REST r+rest rcontroller = snd . runIdentity $ runStateT rcontroller defaultREST++routeREST :: REST r -> Controller r ()+routeREST rst = do+ routeMethod GET $ do+ routeTop $ restIndex rst+ routeName "new" $ restNew rst+ routeVar "id" $ do+ routeTop $ restShow rst+ routeName "edit" $ restEdit rst++ routeMethod POST $ routeTop $ restCreate rst++ routeMethod DELETE $ routeVar "id" $ restDelete rst++ routeMethod PUT $ routeVar "id" $ restUpdate rst++type RESTController r = RESTControllerM r ()++index :: Controller r a -> RESTController r+index route = modify $ \controller ->+ controller { restIndex = void route }++create :: Controller r a -> RESTController r+create route = modify $ \controller ->+ controller { restCreate = void route }++edit :: Controller r a -> RESTController r+edit route = modify $ \controller ->+ controller { restEdit = void route }++new :: Controller r a -> RESTController r+new route = modify $ \controller ->+ controller { restNew = void route }++show :: Controller r a -> RESTController r+show route = modify $ \controller ->+ controller { restShow = void route }++update :: Controller r a -> RESTController r+update route = modify $ \controller ->+ controller { restUpdate = void route }++delete :: Controller r a -> RESTController r+delete route = modify $ \controller ->+ controller { restDelete = void route }+
+ src/Web/Simple.hs view
@@ -0,0 +1,258 @@+{- |+++/Simple/ is based on WAI - an standard interface for communicating between web+servers (like warp) and web applications. You can use /Simple/ completely+independently (and of course, use any WAI server to run it). Alternatively, you+can embed existing existing WAI applications inside an app built with /Simple/,+and embed an app built with simple in another WAI app.++All the components in /Simple/ are designed to be small and simple+enough to understand, replaceable, and work as well independantly as they do+together.++-}+module Web.Simple (+ module Web.Simple.Responses+ , module Web.Simple.Controller+ , module Network.Wai+ -- * Overview+ -- $Overview++ -- * Tutorial+ -- $Tutorial++ -- ** Controllers+ -- $Controllers++ -- ** Routing+ -- $Routing+ ) where++import Network.Wai+import Web.Simple.Responses+import Web.Simple.Controller++{- $Overview+ #overview#++WAI applications are functions of type 'Network.Wai.Application' - given a+client 'Network.Wai.Request' they return a 'Network.Wai.Response' to return to+the client (i.e. an HTTP status code, headers, body etc\'). A /Simple/+application 'Controller' -- a wrapper around WAI\'s 'Network.Wai.Application'+either returns a monadic value, or a 'Network.Wai.Response'. This allows+'Controller's to be chained together to create arbitrary complex routes. If a+'Controller' \"matches\" a route (e.g., based on the HTTP path, hostname,+cookies etc), it can 'respond' which shortcircuits the remaining execution and+immediately send the response back to the client. If none, of the 'Controller's+match, an HTTP 404 (NOT FOUND) response will be returned.++For example, this is a trivial \Simple\ app that notices whether the incoming+request was for the hostname \"hackage.haskell.org\" or \"www.haskell.org\":++@+ routeHost \"hackage.haskell.org\" $ do+ respond $ okHtml \"Welcome to Hackage\"++ routeHost \"www.haskell.org\" $ do+ respond $ okHtml \"You\'ve reached the Haskell Language home page\"+@++'routeHost' is a combinator that matches the a request based on the \"Host\"+header and defers to the passed in 'Controller' or returns '()'. There are+other built-in combinators for matching based on the request path, the HTTP+method, and it\'s easy to write your own combinators. You can chain such+combinators together monadically or using 'mappend' (since 'Controller' is an+instance of 'Monoid'). A typical /Simple/ app looks something like this:++@+ controllerApp () $ do+ routeTop $ do+ ... handle home page ...+ routeName \"posts\" $ do+ routeMethod GET $+ ... get all posts ...+ routeMethod POST $+ ... create new post ...+@++where 'controllerApp' generates an 'Network.Wai.Application' from a 'Controller'+returning a 404 (not found) response if all routes fail.++This package also includes the "Web.Frank" module which provide an API to create+applications similar to the Sinatra framework for Ruby, and the "Web.REST"+module to create RESTful applications similar to Ruby on Rails. Neither of+these modules is \"special\", in the sense that they are merely implemented in+terms of 'Controller's. The example above could be rewritten using "Web.Frank"+as such:++@+ controllerApp () $ do+ get \"/\" $ do+ ... display home page ...+ get \"/posts\" $ do+ ... get all posts ...+ post \"/posts\" $ do+ ... create new post ...+@++\Simple\ is broken down into the following modules:++@+ Web+ |-- "Web.Simple" - Re-exports most common modules+ | |-- "Web.Simple.Controller" - Base monad and built-in routing combinators+ | |-- "Web.Simple.Responses" - Common HTTP responses+ | |-- "Web.Simple.Auth" - 'Controller's for authentication+ | |-- "Web.Simple.Cache" - in memory and filesystem cache utilities+ |-- "Web.Frank" - Sinatra style 'Route's+ +-- "Web.REST" - Monad for creating RESTful controllers+@++-}++{- $Tutorial+#tutorial#++/Simple/ comes with a utility called \smpl\ which automates some common tasks+like creating a new application, running migrations and launching a development+server. To create a new /Simple/ app in a directory called \"example_app\", run:++@+ $ smpl create example_app+@++This will create a directory called \"example_app\" containing a /.cabal/ file+and and a single Haskell source file, \"Main.hs\":++@+\{\-\# LANGUAGE OverloadedStrings #\-\}++module Main where++import Web.Simple+import Network.Wai.Handler.Warp+import System.Posix.Env++app :: (Application -> IO ()) -> IO ()+app runner = runner $ do+ -- TODO: App initialization code here+ controllerApp () $ do+ respond $ okHtml \"Hello World\"++main :: IO ()+main = do+ port <- read \`fmap\` getEnvDefault \"PORT\" \"3000\"+ app (run port)+@++The `app` function is the entry point to your application. The argument is a+function that knows how to run a `Network.Wai.Application` -- for example,+warp's run method. `mkRouter` transforms a `Routeable` into an+`Network.Wai.Application`. The boilerplate is just a `Response` with the body+\"Hello World\" (and content-type \"text/html\"). To run a development server+on port 3000:++@+ $ cd example_app+ $ smpl+@++Pointing your browser to <http://localhost:3000> should display+\"Hello World\"!+-}++{- $Controllers+#controllers#++What is this 'controllerApp' business? The basic type in /Simple/ is a+'Controller' which contains both a 'Request' and app specific state.+'controllerApp' takes an initial application state (/unit/ in the example above)+and transforms a 'Controller' into a WAI 'Application' so it can be run by a+server like warp.++A 'Controller' is a 'Monad' that can perform actions in 'IO' (using 'liftIO'),+access the underlying 'request' or application state (via 'controllerState').+Finally, a 'Controller' can 'respond' to a request. 'respond' short-circuits+the rest of the computation and returns the 'Response' to the client.+'controllerApp' transforms a 'Controller' into a WAI application by running the+'Controller'. If the 'Controller' does not call 'respond', 'controllerApp'+defaults to responding to the client with a 404 not found. For example:++@+controllerApp () $ do+ liftIO $ putStrLn \"Responding to request\"+ respond $ okHtml \"Hello World\"+ liftIO $ putStrLn \"This message is never actually printed\"+@++When run, this code will always print the first message+(\"Responding to request\") and respond with a 200 page containing \"Hello+World\", but never print the second message. Short-circuiting the computation+in this way allows us to respond in different ways based on the request:++@+controllerApp () $ do+ path \<- rawPathInfo \<$> request+ when (path == \"/timeofday\") $ do+ timeStr \<- liftIO $ S8.pack . show \<$> getClockTime+ respond $ okHtml timeStr+ when (path == \"/whoami\") $+ user \<- liftIO $ S8.pack \<$> getLoginName+ respond $ okHtml user+@++This controller will respond with the current time if the path \"/timeofday\"+is requested, and the user running the server if the path \"/whoami\" is+requested. If neither of those paths match, it will respond with a 404+(NOT FOUND).++ -}++{- $Routing+#routing#++An app that does the same thing for every request is not very useful (well, it+might be, but if it is, even /Simple/ is not simple enough for you). We want to+build applications that do perform different actions based on properties of the+client\'s request - e.g., the path requests, GET or POST requests, the \"Host\"+header, etc\'. /Simple/\'s 'Controller's are flexible to accomplish this.+'Controller's encapsulate a function from a 'Request' to 'Either' a 'Response'+or some monadic value.++For example, let\'s extend the example using the 'Monad' syntax:++@+controllerApp () $ do+ routeTop $ do+ routeHost \"localhost\" $ respond $ okHtml \"Hello, localhost!\"+ routeHost \"test.lvh.me\" $ respond $ okHtml \"Hello, test.lvh.me!\"+ routeName \"advice\" $ okHtml \"Be excellent to each other!\"+@++Now, the app will respond differently depending on whether the client is+requesting the host name \"localhost\" or \"test.lvh.me\", or if the requested+path is \"\/advice\" rather than \"\/\". Take it for a spin in the browser (make+sure `smpl` is still running):++ * <http://localhost:3000>++ * <http://test.lvh.me:3000>++ * <http://localhost:3000/advice>++In this example, 'routeTop' matches if the 'Network.Wai.Request's+'Network.Wai.pathInfo' is empty, which means the requested path is \"\/\" (as+in this case), or the rest of the path has been consumed by previous 'Route's.+'routeName' matches if the next component in the path (specifically the 'head'+of 'Network.Wai.pathInfo') matches the argument (and if so, removes it). Check+out "Web.Simple.Router" for more complete documentation of these and other+'Route's.++For many apps it will be convenient to use even higher level routing APIs. The+modules "Web.Frank" and "Web.Sinatra" provide Sinatra-like and RESTful APIs,+respectively. Both modules are implement purely in terms of 'Route's and you+can easily implement your own patterns as well.++-}+
+ src/Web/Simple/Auth.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Provides HTTP Basic Authentication.+module Web.Simple.Auth+ ( AuthRouter+ , basicAuthRoute, basicAuth, authRewriteReq+ ) where++import Control.Monad+import Data.ByteString.Base64+import qualified Data.ByteString.Char8 as S8+import Data.Maybe+import Network.HTTP.Types+import Network.Wai+import Web.Simple.Responses+import Web.Simple.Controller++-- | An 'AuthRouter' authenticates a 'Request' and, if successful, forwards the+-- 'Request' to the 'Routeable'.+type AuthRouter r a = (Request -> S8.ByteString+ -> S8.ByteString+ -> Controller r (Maybe Request))+ -> Controller r a+ -> Controller r a++-- | An 'AuthRouter' that uses HTTP basic authentication to authenticate a request+-- in a particular realm.+basicAuthRoute :: String -> AuthRouter r a+basicAuthRoute realm testAuth next = do+ req <- request+ let authStr = fromMaybe "" $ lookup hAuthorization (requestHeaders req)+ when (S8.take 5 authStr /= "Basic") requireAuth++ case fmap (S8.split ':') $ decode $ S8.drop 6 authStr of+ Right (user:pwd:[]) -> do+ mfin <- testAuth req user pwd+ maybe requireAuth (\finReq -> localRequest (const finReq) next) mfin+ _ -> requireAuth+ where requireAuth = respond $ requireBasicAuth realm++-- | Wraps an 'AuthRouter' to take a simpler authentication function (that just+-- just takes a username and password, and returns 'True' or 'False'). It also+-- adds an \"X-User\" header to the 'Request' with the authenticated user\'s+-- name (the first argument to the authentication function).+authRewriteReq :: AuthRouter r a+ -> (S8.ByteString -> S8.ByteString -> Controller r Bool)+ -> Controller r a+ -> Controller r a+authRewriteReq authRouter testAuth rt =+ authRouter (\req user pwd -> do+ success <- testAuth user pwd+ if success then+ return $ Just $ transReq req user+ else return Nothing) rt+ where transReq req user = req+ { requestHeaders = ("X-User", user):(requestHeaders req)}++-- | A 'Route' that uses HTTP basic authentication to authenticate a request for a realm+-- with the given username ans password. The request is rewritten with an 'X-User' header+-- containing the authenticated username before being passed to the next 'Route'.+basicAuth :: String+ -- ^ Realm+ -> S8.ByteString+ -- ^ Username+ -> S8.ByteString+ -- ^ Password+ -> Controller r a -> Controller r a+basicAuth realm user pwd = authRewriteReq (basicAuthRoute realm)+ (\u p -> return $ u == user && p == pwd)+
+ src/Web/Simple/Controller.hs view
@@ -0,0 +1,437 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}++{- | 'Controller' provides a convenient syntax for writting 'Application'+ code as a Monadic action with access to an HTTP request as well as app+ specific data (e.g. a database connection pool, app configuration etc.)+ This module also defines some+ helper functions that leverage this feature. For example, 'redirectBack'+ reads the underlying request to extract the referer and returns a redirect+ response:++ @+ myController = do+ ...+ if badLogin then+ redirectBack+ else+ ...+ @+-}+module Web.Simple.Controller+ (+ -- * Example+ -- $Example+ -- * Controller Monad+ Controller(..), runController, runControllerIO+ , controllerApp, controllerState, putState+ , request, localRequest, respond+ , requestHeader+ -- * Common Routes+ , routeHost, routeTop, routeMethod, routeAccept+ , routePattern, routeName, routeVar+ -- * Inspecting query+ , Parseable+ , queryParam, queryParam', queryParams+ , readQueryParam, readQueryParam', readQueryParams+ , parseForm+ -- * Redirection via referrer+ , redirectBack+ , redirectBackOr+ -- * Exception handling+ , ControllerException+ , module Control.Exception.Peel+ -- * Integrating other WAI components+ , ToApplication(..)+ , fromApp+ -- * Low-level utilities+ , body+ -- , guard, guardM, guardReq+ ) where++import Control.Applicative+import Control.Exception.Peel+import Control.Monad hiding (guard)+import Control.Monad.IO.Class+import Control.Monad.IO.Peel+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as L8+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.List (find)+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Typeable+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Parse+import Web.Simple.Responses+++type ControllerState r = (r, Request)++-- | The Controller Monad is both a State-like monad which, when run, computes+-- either a 'Response' or a result. Within the Controller Monad, the remainder+-- of the computation can be short-circuited by 'respond'ing with a 'Response'.+newtype Controller r a =+ Controller (ControllerState r ->+ ResourceT IO (Either Response a, ControllerState r))++instance Functor (Controller r) where+ fmap f (Controller act) = Controller $ \st0 -> do+ (eaf, st) <- act st0+ case eaf of+ Left resp -> return (Left resp, st)+ Right result -> return (Right $ f result, st)++instance Applicative (Controller r) where+ pure a = Controller $ \st -> return $ (Right a, st)+ (<*>) = ap++instance Monad (Controller r) where+ return = pure+ (Controller act) >>= fn = Controller $ \st0 -> do+ (eres, st) <- act st0+ case eres of+ Left resp -> return (Left resp, st)+ Right result -> do+ let (Controller fres) = fn result+ fres st++instance MonadIO (Controller r) where+ liftIO act = Controller $ \st -> liftIO act >>= \r -> return (Right r, st)++liftResourceT :: ResourceT IO a -> Controller r a+liftResourceT act = Controller $ \st -> do+ a <- act+ return (Right a, st)++hoistEither :: Either Response a -> Controller r a+hoistEither eith = Controller $ \st -> return (eith, st)++instance MonadPeelIO (Controller r) where+ peelIO = do+ r <- controllerState+ req <- request+ return $ \ctrl -> do+ res <- runControllerIO ctrl r req+ return $ hoistEither res++ask :: Controller r (r, Request)+ask = Controller $ \rd -> return (Right rd, rd)++-- | Extract the request+request :: Controller r Request+request = liftM snd ask++local :: ((r, Request) -> (r, Request)) -> Controller r a -> Controller r a+local f (Controller act) = Controller $ \st@(_, r) -> do+ (eres, (req, _)) <- act (f st)+ return (eres, (req, r))++-- | Modify the request for the given computation+localRequest :: (Request -> Request) -> Controller r a -> Controller r a+localRequest f = local (\(r,req) -> (r, f req))++-- | Extract the application-specific state+controllerState :: Controller r r +controllerState = liftM fst ask++putState :: r -> Controller r ()+putState r = Controller $ \(_, req) -> return (Right (), (r, req))++-- | Convert the controller into an 'Application'+controllerApp :: r -> Controller r a -> Application+controllerApp r ctrl req =+ runController ctrl r req >>=+ either return (const $ return notFound) ++runController :: Controller r a -> r -> Request -> ResourceT IO (Either Response a)+runController (Controller fun) r req = fst `fmap` fun (r,req)++-- | Run a 'Controller' in the @IO@ monad+runControllerIO :: Controller r a -> r -> Request -> IO (Either Response a)+runControllerIO ctrl r = runResourceT . runController ctrl r++-- | Decline to handle the request+--+-- @pass >> c === c@+-- @c >> pass === c@+pass :: Controller r ()+pass = Controller $ \st -> return (Right (), st)++-- | Provide a response+--+-- @respond r >>= f === respond r@+respond :: Response -> Controller r a+respond resp = Controller $ \st -> return (Left resp, st)+++-- | Lift an application to a controller+fromApp :: ToApplication a => a -> Controller r ()+fromApp app = do+ req <- request+ resp <- liftResourceT $ (toApp app) req+ respond resp++-- | Matches on the hostname from the 'Request'. The route only succeeds on+-- exact matches.+routeHost :: S.ByteString -> Controller r a -> Controller r ()+routeHost host = guardReq $ (host ==) . serverName++-- | Matches if the path is empty.+--+-- Note that this route checks that 'pathInfo'+-- is empty, so it works as expected in nested contexts that have+-- popped components from the 'pathInfo' list.+routeTop :: Controller r a -> Controller r ()+routeTop = guardReq $ \req -> null (pathInfo req) ||+ (T.length . head $ pathInfo req) == 0++-- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT')+routeMethod :: StdMethod -> Controller r a -> Controller r ()+routeMethod method = guardReq $ (renderStdMethod method ==) . requestMethod++-- | Matches if the request's Content-Type exactly matches the given string+routeAccept :: S8.ByteString -> Controller r a -> Controller r ()+routeAccept contentType = guardReq (isJust . find matching . requestHeaders)+ where matching hdr = fst hdr == hAccept && snd hdr == contentType++-- | Routes the given URL pattern. Patterns can include+-- directories as well as variable patterns (prefixed with @:@) to be added+-- to 'queryString' (see 'routeVar')+--+-- * \/posts\/:id+--+-- * \/posts\/:id\/new+--+-- * \/:date\/posts\/:category\/new+--+routePattern :: S.ByteString -> Controller r a -> Controller r ()+routePattern pattern route =+ let patternParts = map T.unpack $ decodePathSegments pattern+ in foldr mkRoute (route >> return ()) patternParts+ where mkRoute (':':varName) = routeVar (S8.pack varName)+ mkRoute name = routeName (S8.pack name)++-- | Matches if the first directory in the path matches the given 'ByteString'+routeName :: S.ByteString -> Controller r a -> Controller r ()+routeName name next = do+ req <- request+ if (length $ pathInfo req) > 0 && S8.unpack name == (T.unpack . head . pathInfo) req+ then localRequest popHdr next >> return ()+ else pass+ where popHdr req = req { pathInfo = (tail . pathInfo $ req) }++-- | Always matches if there is at least one directory in 'pathInfo' but and+-- adds a parameter to 'queryString' where the key is the first parameter and+-- the value is the directory consumed from the path.+routeVar :: S.ByteString -> Controller r a -> Controller r ()+routeVar varName next = do+ req <- request+ case pathInfo req of+ [] -> pass+ x:_ | T.null x -> pass+ | otherwise -> localRequest popHdr next >> return ()+ where popHdr req = req {+ pathInfo = (tail . pathInfo $ req)+ , queryString = (varName, Just (varVal req)):(queryString req)}+ varVal req = S8.pack . T.unpack . head . pathInfo $ req++--+-- query parameters+--++-- | Looks up the parameter name in the request's query string and returns the+-- @Parseable@ value or 'Nothing'.+--+-- For example, for a request with query string: \"?foo=bar&baz=7\",+-- @queryParam \"foo\"@+-- would return @Just "bar"@, but+-- @queryParam \"zap\"@+-- would return @Nothing@.+queryParam :: Parseable a+ => S8.ByteString -- ^ Parameter name+ -> Controller r (Maybe a)+queryParam varName = do+ qr <- liftM queryString request+ return $ case lookup varName qr of+ Just p -> Just $ parse $ fromMaybe S.empty p+ _ -> Nothing++-- | Like 'queryParam', but throws an exception if the parameter is not present.+queryParam' :: Parseable a+ => S.ByteString -> Controller r a+queryParam' varName =+ queryParam varName >>= maybe (err $ "no parameter " ++ show varName) return++-- | Selects all values with the given parameter name+queryParams :: Parseable a+ => S.ByteString -> Controller r [a]+queryParams varName = request >>= return .+ map (parse . fromMaybe S.empty . snd) .+ filter ((== varName) . fst) .+ queryString++-- | The class of types into which query parameters may be converted+class Parseable a where+ parse :: S8.ByteString -> a++instance Parseable S8.ByteString where+ parse = id+instance Parseable String where+ parse = S8.unpack+instance Parseable Text where+ parse = T.decodeUtf8++-- | Like 'queryParam', but further processes the parameter value with @read@.+-- If that conversion fails, an exception is thrown.+readQueryParam :: Read a+ => S8.ByteString -- ^ Parameter name+ -> Controller r (Maybe a)+readQueryParam varName =+ queryParam varName >>= maybe (return Nothing) (liftM Just . readParamValue varName)++-- | Like 'readQueryParam', but throws an exception if the parameter is not present.+readQueryParam' :: Read a+ => S8.ByteString -- ^ Parameter name+ -> Controller r a+readQueryParam' varName =+ queryParam' varName >>= readParamValue varName++-- | Like 'queryParams', but further processes the parameter values with @read@.+-- If any read-conversion fails, an exception is thrown.+readQueryParams :: Read a+ => S8.ByteString -- ^ Parameter name+ -> Controller r [a]+readQueryParams varName =+ queryParams varName >>= mapM (readParamValue varName)++readParamValue :: Read a => S8.ByteString -> Text -> Controller r a+readParamValue varName =+ maybe (err $ "cannot read parameter: " ++ show varName) return .+ readMay . T.unpack+ where readMay s = case [x | (x,rst) <- reads s, ("", "") <- lex rst] of+ [x] -> Just x+ _ -> Nothing++-- | Parses a HTML form from the request body. It returns a list of 'Param's as+-- well as a list of 'File's, which are pairs mapping the name of a /file/ form+-- field to a 'FileInfo' pointing to a temporary file with the contents of the+-- upload.+--+-- @+-- myController = do+-- (prms, files) <- parseForm+-- let mPicFile = lookup \"profile_pic\" files+-- case mPicFile of+-- Just (picFile) -> do+-- sourceFile (fileContent picFile) $$+-- sinkFile (\"images/\" ++ (fileName picFile))+-- respond $ redirectTo \"/\"+-- Nothing -> redirectBack+-- @+parseForm :: Controller r ([Param], [(S.ByteString, FileInfo FilePath)])+parseForm = do+ req <- request+ liftResourceT $ parseRequestBody tempFileBackEnd req++-- | Reads and returns the body of the HTTP request.+body :: Controller r L8.ByteString+body = do+ req <- request+ liftResourceT $ L8.fromChunks `fmap` (requestBody req $$ CL.consume)++-- | Returns the value of the given request header or 'Nothing' if it is not+-- present in the HTTP request.+requestHeader :: HeaderName -> Controller r (Maybe S8.ByteString)+requestHeader name = request >>= return . lookup name . requestHeaders++-- | Redirect back to the referer. If the referer header is not present+-- redirect to root (i.e., @\/@).+redirectBack :: Controller r ()+redirectBack = redirectBackOr (redirectTo "/")++-- | Redirect back to the referer. If the referer header is not present+-- fallback on the given 'Response'.+redirectBackOr :: Response -- ^ Fallback response+ -> Controller r ()+redirectBackOr def = do+ mrefr <- requestHeader "referer"+ case mrefr of+ Just refr -> respond $ redirectTo refr+ Nothing -> respond def++-- guard++guard :: Bool -> Controller r a -> Controller r ()+guard b c = if b then c >> return () else pass++guardM :: Controller r Bool -> Controller r a -> Controller r ()+guardM b c = b >>= flip guard c++guardReq :: (Request -> Bool) -> Controller r a -> Controller r ()+guardReq f = guardM (liftM f request)++-- | The class of types that can be converted to an 'Application'+class ToApplication r where+ toApp :: r -> Application++instance ToApplication Application where+ toApp = id++instance ToApplication Response where+ toApp = const . return++data ControllerException = ControllerException String+ deriving (Typeable)++instance Show ControllerException where+ show (ControllerException msg) = "Controller: " ++ msg++instance Exception ControllerException++err :: String -> Controller r a+err = throwIO . ControllerException++{- $Example+ #example#++The most basic 'Routeable' types are 'Application' and 'Response'. Reaching+either of these types marks a termination in the routing lookup. This module+exposes a monadic type 'Route' which makes it easy to create routing logic+in a DSL-like fashion.++'Route's are concatenated using the '>>' operator (or using do-notation).+In the end, any 'Routeable', including a 'Route' is converted to an+'Application' and passed to the server using 'mkRoute':++@++ mainAction :: Controller () ()+ mainAction = ...++ signinForm :: Controller () ()+ signinForm req = ...++ login :: Controller () ()+ login = ...++ updateProfile :: Controller () ()+ updateProfile = ...++ main :: IO ()+ main = run 3000 $ controllerApp () $ do+ routeTop mainAction+ routeName \"sessions\" $ do+ routeMethod GET signinForm+ routeMethod POST login+ routeMethod PUT $ routePattern \"users/:id\" updateProfile+ routeAll $ responseLBS status404 [] \"Are you in the right place?\"+@++-}
+ src/Web/Simple/Responses.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings #-}++-- | This module defines some convenience functions for creating responses.+module Web.Simple.Responses+ ( ok, okHtml, okJson+ , movedTo, redirectTo+ , badRequest, requireBasicAuth, forbidden+ , notFound+ , serverError+ ) where++import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as L8+import Network.HTTP.Types+import Network.Wai++-- | Type alias for 'S8.ByteString'+type ContentType = S8.ByteString++-- | Creates a 200 (OK) 'Response' with the given content-type and resposne+-- body+ok :: ContentType -> L8.ByteString -> Response+ok contentType body =+ responseLBS status200 [(hContentType, contentType)] body++-- | Helper to make responses with content-type \"text/html\"+mkHtmlResponse :: Status -> [Header] -> L8.ByteString -> Response+mkHtmlResponse stat hdrs =+ responseLBS stat ((hContentType, S8.pack "text/html"):hdrs)++-- | Creates a 200 (OK) 'Response' with content-type \"text/html\" and the+-- given resposne body+okHtml :: L8.ByteString -> Response+okHtml body =+ mkHtmlResponse status200 [] body++-- | Creates a 200 (OK) 'Response' with content-type \"application/json\" and the+-- given resposne body+okJson :: L8.ByteString -> Response+okJson = ok (S8.pack "application/json")++-- | Given a URL returns a 301 (Moved Permanently) 'Response' redirecting to+-- that URL.+movedTo :: String -> Response+movedTo url = mkHtmlResponse status301 [(hLocation, S8.pack url)] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>301 Moved Permanently</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>Moved Permanently</H1>\n\+ \<P>The document has moved <A HREF=\""+ , L8.pack url+ , L8.pack "\">here</A>\n\+ \</BODY></HTML>\n"]++-- | Given a URL returns a 303 (See Other) 'Response' redirecting to that URL.+redirectTo :: S8.ByteString -> Response+redirectTo url = mkHtmlResponse status303 [(hLocation, url)] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>303 See Other</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>See Other</H1>\n\+ \<P>The document has moved <A HREF=\""+ , L8.fromChunks [url]+ , L8.pack "\">here</A>\n\+ \</BODY></HTML>\n"]++-- | Returns a 400 (Bad Request) 'Response'.+badRequest :: Response+badRequest = mkHtmlResponse status400 [] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>400 Bad Request</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>Bad Request</H1>\n\+ \<P>Your request could not be understood.</P>\n\+ \</BODY></HTML>\n"]++-- | Returns a 401 (Authorization Required) 'Response' requiring basic+-- authentication in the given realm.+requireBasicAuth :: String -> Response+requireBasicAuth realm = mkHtmlResponse status401+ [("WWW-Authenticate", S8.concat ["Basic realm=", S8.pack . show $ realm])] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>401 Authorization Required</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>Authorization Required</H1>\n\+ \</BODY></HTML>\n"]++-- | Returns a 403 (Forbidden) 'Response'.+forbidden :: Response+forbidden = mkHtmlResponse status403 [] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>403 Forbidden</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>Forbidden</H1>\n\+ \<P>You don't have permission to access this page.</P>\n\+ \</BODY></HTML>\n"]++-- | Returns a 404 (Not Found) 'Response'.+notFound :: Response+notFound = mkHtmlResponse status404 [] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>404 Not Found</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>Not Found</H1>\n\+ \<P>The requested URL was not found on this server.</P>\n\+ \</BODY></HTML>\n"]++-- | Returns a 500 (Server Error) 'Response'.+serverError :: L8.ByteString -> Response+serverError message = mkHtmlResponse status500 [] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>500 Internal Server Error</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>Internal Server Error</H1>\n\+ \<P>", message,+ "</P></BODY></HTML>\n"]+
+ src/smpl.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}++-- | The `smpl` utility for helping a user setup a Simple web project.+module Main (main) where++import Prelude hiding (writeFile, FilePath)+import Data.Char+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Lazy.Search as L8+import System.Console.CmdArgs+import System.Directory+import System.FilePath+import System.Environment+import System.Exit+import System.SetEnv+import System.Process++import Paths_simple++data Smpl =+ Server+ { port :: Int+ , moduleName :: String+ } |+ Create { appDir :: FilePath }+ deriving (Show, Data, Typeable)++main :: IO ()+main = do+ setEnv "ENV" "development"+ myenv <- getEnvironment+ let myport = maybe 3000 read $ lookup "PORT" myenv+ let develMode = cmdArgsMode $ modes+ [ Server { port = myport &= typ "PORT"+ , moduleName = "Application" &= typ "MODULE"+ &= explicit &= name "module"+ } &= auto+ , Create { appDir = "" &= argPos 0 &= typ "app_dir" } ]+ smpl <- cmdArgsRun develMode+ case smpl of+ Server p m -> do+ exitCode <- rawSystem "wai-handler-devel" [show p, m, "app"]+ case exitCode of+ ExitFailure 127 -> do+ putStrLn "You must install wai-handler devel first"+ exitWith $ ExitFailure 1+ _ -> exitWith exitCode+ Create dir -> createApplication dir++humanize :: String -> String+humanize = capitalize+ where go [] = []+ go ('_':xs) = ' ':(capitalize xs)+ go (x:xs) = x:(go xs)+ capitalize [] = []+ capitalize x@('_':_) = go x+ capitalize (x:xs) = (toUpper x):(go xs)++moduleCase :: String -> String+moduleCase = capitalize+ where go [] = []+ go ('_':xs) = capitalize xs+ go (x:xs) = x:(go xs)+ capitalize [] = []+ capitalize ('_':xs) = go xs+ capitalize (x:xs) = (toUpper x):(go xs)++createApplication :: FilePath -> IO ()+createApplication dir = do+ let myAppName = takeBaseName $ dropTrailingPathSeparator dir+ modName = moduleCase myAppName+ mappings = [ ("appname", myAppName)+ , ("name", humanize myAppName)+ , ("module", modName)]++ createDirectory dir+ createDirectory $ dir </> "db"+ createDirectory $ dir </> "db" </> "migrations"+ createDirectory $ dir </> "views"+ createDirectory $ dir </> "templates"+ createDirectory $ dir </> modName++ copyTemplate ("template" </> "Main_hs.tmpl")+ (dir </> "Main.hs") mappings+ copyTemplate ("template" </> "Application_hs.tmpl")+ (dir </> "Application.hs") mappings+ copyTemplate ("template" </> "package_cabal.tmpl")+ (dir </> myAppName ++ ".cabal") mappings+ copyTemplate ("template" </> "main_html.tmpl")+ (dir </> "templates" </> "main.html") mappings+ copyTemplate ("template" </> "index_html.tmpl")+ (dir </> "views" </> "index.html") mappings+ copyTemplate ("template" </> "Common_hs.tmpl")+ (dir </> modName </> "Common.hs") mappings++copyTemplate :: FilePath -> FilePath -> [(String, String)] -> IO ()+copyTemplate orig target mappings = do+ tmpl <- getDataFileName orig >>= L8.readFile+ L8.writeFile target $+ (flip . flip foldl) tmpl mappings $ \accm (key, val) ->+ L8.replace (S8.pack $ "{{" ++ key ++ "}}") (L8.pack val) accm+
+ template/Application_hs.tmpl view
@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}+module Application where++import {{module}}.Common+import Web.Simple++app :: (Application -> IO ()) -> IO ()+app runner = do+ settings <- newAppSettings++ runner $ controllerApp settings $ do+ -- TODO: routes go here+ respond $ okHtml "Hello World"+
+ template/Common_hs.tmpl view
@@ -0,0 +1,41 @@+module {{module}}.Common where++import Control.Applicative+import Web.Simple++-- Uncomment the following lines for database, templates, and session support+--import Web.Simple.PostgreSQL+--import Web.Simple.Templates+--import Web.Simple.Session++type AppSettings = ()++newAppSettings :: IO AppSettings+newAppSettings = return ()++{- Replace the above code with this comment block for database, templates and+ - session support. Don't forget to uncomment the relevant packages in the+ - cabal file and the import statements at the top of this file.++data AppSettings = AppSettings { appDB :: PostgreSQLConn+ , appSession :: Maybe Session }++newAppSettings :: IO AppSettings+newAppSettings = do+ db <- createPostgreSQLConn+ return $ AppSettings { appDB = db , appSession = Nothing }++instance HasPostgreSQL AppSettings where+ postgreSQLConn = appDB++instance HasSession AppSettings where+ getSession = appSession+ setSession sess = do+ cs <- controllerState+ putState $ cs { appSession = Just sess }++instance HasTemplates AppSettings where+ defaultLayout = Just <$> getTemplate "templates/main.html"++-}+
template/Main_hs.tmpl view
@@ -1,17 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} module Main where-import Web.Simple-import Network.Wai.Handler.Warp-import System.Posix.Env -app runner = do- -- TODO: App initialization code goes here- runner $ controllerApp () $ do- -- TODO: routes go here- respond $ okHtml "Hello World"+import Application+import Network.Wai.Handler.Warp+import Network.Wai.Middleware.RequestLogger+import System.Environment main :: IO () main = do- port <- read `fmap` getEnvDefault "PORT" "3000"- app (run port)+ env <- getEnvironment+ let port = maybe 3000 read $ lookup "PORT" env+ app (run port . logStdout)
+ template/index_html.tmpl view
@@ -0,0 +1,1 @@+Welcome to your new app! This file lives in "e;views/index.html"e;
+ template/main_html.tmpl view
@@ -0,0 +1,28 @@+<!DOCTYPE HTML>+<html>+ <head>+ <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">+ <title>{{name}}</title>+ <style>+ body {+ width: 25em;+ font-size: 13pt;+ margin: 0 auto;+ font-family: sans-serif;+ }++ h1 {+ text-align: center;+ }++ h1 a {+ color: inherit;+ text-decoration: none;+ }+ </style>+</head>+<body>+ <h1><a href="/">{{name}}</a></h1>+$yield$+</body>+</html>
template/package_cabal.tmpl view
@@ -1,4 +1,4 @@-name: {{pkgname}}+name: {{module}} version: 0.0.0.0 --author: YOUR NAME --maintainer: your@email.com@@ -6,13 +6,17 @@ build-type: Simple cabal-version: >=1.8 -executable {{pkgname}}+executable {{appname}} main-is: Main.hs ghc-options: -threaded -O2 build-depends: base- , simple >= 0.5.0- , unix+ , simple >= 0.6.0 , wai+ , wai-extra , warp+ -- uncomment for database, session and template support+ -- , simple-postgresql-orm+ -- , simple-session+ -- , simple-templates