summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ChangeLog.md8
-rw-r--r--LICENSE1348
-rw-r--r--Setup.hs4
-rw-r--r--src/Yu/Core/Control.hs460
-rw-r--r--src/Yu/Core/Control/Internal.hs225
-rw-r--r--src/Yu/Core/Info.hs150
-rw-r--r--src/Yu/Core/Model.hs330
-rw-r--r--src/Yu/Core/Model/Internal.hs587
-rw-r--r--src/Yu/Core/Model/TH.hs178
-rw-r--r--src/Yu/Core/Route.hs47
-rw-r--r--src/Yu/Core/View.hs255
-rw-r--r--src/Yu/Core/View/Internal.hs291
-rw-r--r--src/Yu/Core/View/Query.hs225
-rw-r--r--src/Yu/Core/View/Query/Parsec.hs314
-rw-r--r--test-src/Internal.hs87
-rw-r--r--test-src/ModelSpec.hs1117
-rw-r--r--test-src/Spec.hs20
-rw-r--r--yu-core.cabal125
18 files changed, 3035 insertions, 2736 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index 1fa4234..e626cff 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,5 +1,5 @@
-# Revision history for yu-core
-
-## 0.1.0.0 -- 2017-12-01
-
+# Revision history for yu-core
+
+## 0.1.0.0 -- 2017-12-01
+
* First version. Rename from Glob \ No newline at end of file
diff --git a/LICENSE b/LICENSE
index 45644ff..d9acb90 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,674 +1,674 @@
- GNU GENERAL PUBLIC LICENSE
- Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
- Preamble
-
- The GNU General Public License is a free, copyleft license for
-software and other kinds of works.
-
- The licenses for most software and other practical works are designed
-to take away your freedom to share and change the works. By contrast,
-the GNU General Public License is intended to guarantee your freedom to
-share and change all versions of a program--to make sure it remains free
-software for all its users. We, the Free Software Foundation, use the
-GNU General Public License for most of our software; it applies also to
-any other work released this way by its authors. You can apply it to
-your programs, too.
-
- When we speak of free software, we are referring to freedom, not
-price. Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-them if you wish), that you receive source code or can get it if you
-want it, that you can change the software or use pieces of it in new
-free programs, and that you know you can do these things.
-
- To protect your rights, we need to prevent others from denying you
-these rights or asking you to surrender the rights. Therefore, you have
-certain responsibilities if you distribute copies of the software, or if
-you modify it: responsibilities to respect the freedom of others.
-
- For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must pass on to the recipients the same
-freedoms that you received. You must make sure that they, too, receive
-or can get the source code. And you must show them these terms so they
-know their rights.
-
- Developers that use the GNU GPL protect your rights with two steps:
-(1) assert copyright on the software, and (2) offer you this License
-giving you legal permission to copy, distribute and/or modify it.
-
- For the developers' and authors' protection, the GPL clearly explains
-that there is no warranty for this free software. For both users' and
-authors' sake, the GPL requires that modified versions be marked as
-changed, so that their problems will not be attributed erroneously to
-authors of previous versions.
-
- Some devices are designed to deny users access to install or run
-modified versions of the software inside them, although the manufacturer
-can do so. This is fundamentally incompatible with the aim of
-protecting users' freedom to change the software. The systematic
-pattern of such abuse occurs in the area of products for individuals to
-use, which is precisely where it is most unacceptable. Therefore, we
-have designed this version of the GPL to prohibit the practice for those
-products. If such problems arise substantially in other domains, we
-stand ready to extend this provision to those domains in future versions
-of the GPL, as needed to protect the freedom of users.
-
- Finally, every program is threatened constantly by software patents.
-States should not allow patents to restrict development and use of
-software on general-purpose computers, but in those that do, we wish to
-avoid the special danger that patents applied to a free program could
-make it effectively proprietary. To prevent this, the GPL assures that
-patents cannot be used to render the program non-free.
-
- The precise terms and conditions for copying, distribution and
-modification follow.
-
- TERMS AND CONDITIONS
-
- 0. Definitions.
-
- "This License" refers to version 3 of the GNU General Public License.
-
- "Copyright" also means copyright-like laws that apply to other kinds of
-works, such as semiconductor masks.
-
- "The Program" refers to any copyrightable work licensed under this
-License. Each licensee is addressed as "you". "Licensees" and
-"recipients" may be individuals or organizations.
-
- To "modify" a work means to copy from or adapt all or part of the work
-in a fashion requiring copyright permission, other than the making of an
-exact copy. The resulting work is called a "modified version" of the
-earlier work or a work "based on" the earlier work.
-
- A "covered work" means either the unmodified Program or a work based
-on the Program.
-
- To "propagate" a work means to do anything with it that, without
-permission, would make you directly or secondarily liable for
-infringement under applicable copyright law, except executing it on a
-computer or modifying a private copy. Propagation includes copying,
-distribution (with or without modification), making available to the
-public, and in some countries other activities as well.
-
- To "convey" a work means any kind of propagation that enables other
-parties to make or receive copies. Mere interaction with a user through
-a computer network, with no transfer of a copy, is not conveying.
-
- An interactive user interface displays "Appropriate Legal Notices"
-to the extent that it includes a convenient and prominently visible
-feature that (1) displays an appropriate copyright notice, and (2)
-tells the user that there is no warranty for the work (except to the
-extent that warranties are provided), that licensees may convey the
-work under this License, and how to view a copy of this License. If
-the interface presents a list of user commands or options, such as a
-menu, a prominent item in the list meets this criterion.
-
- 1. Source Code.
-
- The "source code" for a work means the preferred form of the work
-for making modifications to it. "Object code" means any non-source
-form of a work.
-
- A "Standard Interface" means an interface that either is an official
-standard defined by a recognized standards body, or, in the case of
-interfaces specified for a particular programming language, one that
-is widely used among developers working in that language.
-
- The "System Libraries" of an executable work include anything, other
-than the work as a whole, that (a) is included in the normal form of
-packaging a Major Component, but which is not part of that Major
-Component, and (b) serves only to enable use of the work with that
-Major Component, or to implement a Standard Interface for which an
-implementation is available to the public in source code form. A
-"Major Component", in this context, means a major essential component
-(kernel, window system, and so on) of the specific operating system
-(if any) on which the executable work runs, or a compiler used to
-produce the work, or an object code interpreter used to run it.
-
- The "Corresponding Source" for a work in object code form means all
-the source code needed to generate, install, and (for an executable
-work) run the object code and to modify the work, including scripts to
-control those activities. However, it does not include the work's
-System Libraries, or general-purpose tools or generally available free
-programs which are used unmodified in performing those activities but
-which are not part of the work. For example, Corresponding Source
-includes interface definition files associated with source files for
-the work, and the source code for shared libraries and dynamically
-linked subprograms that the work is specifically designed to require,
-such as by intimate data communication or control flow between those
-subprograms and other parts of the work.
-
- The Corresponding Source need not include anything that users
-can regenerate automatically from other parts of the Corresponding
-Source.
-
- The Corresponding Source for a work in source code form is that
-same work.
-
- 2. Basic Permissions.
-
- All rights granted under this License are granted for the term of
-copyright on the Program, and are irrevocable provided the stated
-conditions are met. This License explicitly affirms your unlimited
-permission to run the unmodified Program. The output from running a
-covered work is covered by this License only if the output, given its
-content, constitutes a covered work. This License acknowledges your
-rights of fair use or other equivalent, as provided by copyright law.
-
- You may make, run and propagate covered works that you do not
-convey, without conditions so long as your license otherwise remains
-in force. You may convey covered works to others for the sole purpose
-of having them make modifications exclusively for you, or provide you
-with facilities for running those works, provided that you comply with
-the terms of this License in conveying all material for which you do
-not control copyright. Those thus making or running the covered works
-for you must do so exclusively on your behalf, under your direction
-and control, on terms that prohibit them from making any copies of
-your copyrighted material outside their relationship with you.
-
- Conveying under any other circumstances is permitted solely under
-the conditions stated below. Sublicensing is not allowed; section 10
-makes it unnecessary.
-
- 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
-
- No covered work shall be deemed part of an effective technological
-measure under any applicable law fulfilling obligations under article
-11 of the WIPO copyright treaty adopted on 20 December 1996, or
-similar laws prohibiting or restricting circumvention of such
-measures.
-
- When you convey a covered work, you waive any legal power to forbid
-circumvention of technological measures to the extent such circumvention
-is effected by exercising rights under this License with respect to
-the covered work, and you disclaim any intention to limit operation or
-modification of the work as a means of enforcing, against the work's
-users, your or third parties' legal rights to forbid circumvention of
-technological measures.
-
- 4. Conveying Verbatim Copies.
-
- You may convey verbatim copies of the Program's source code as you
-receive it, in any medium, provided that you conspicuously and
-appropriately publish on each copy an appropriate copyright notice;
-keep intact all notices stating that this License and any
-non-permissive terms added in accord with section 7 apply to the code;
-keep intact all notices of the absence of any warranty; and give all
-recipients a copy of this License along with the Program.
-
- You may charge any price or no price for each copy that you convey,
-and you may offer support or warranty protection for a fee.
-
- 5. Conveying Modified Source Versions.
-
- You may convey a work based on the Program, or the modifications to
-produce it from the Program, in the form of source code under the
-terms of section 4, provided that you also meet all of these conditions:
-
- a) The work must carry prominent notices stating that you modified
- it, and giving a relevant date.
-
- b) The work must carry prominent notices stating that it is
- released under this License and any conditions added under section
- 7. This requirement modifies the requirement in section 4 to
- "keep intact all notices".
-
- c) You must license the entire work, as a whole, under this
- License to anyone who comes into possession of a copy. This
- License will therefore apply, along with any applicable section 7
- additional terms, to the whole of the work, and all its parts,
- regardless of how they are packaged. This License gives no
- permission to license the work in any other way, but it does not
- invalidate such permission if you have separately received it.
-
- d) If the work has interactive user interfaces, each must display
- Appropriate Legal Notices; however, if the Program has interactive
- interfaces that do not display Appropriate Legal Notices, your
- work need not make them do so.
-
- A compilation of a covered work with other separate and independent
-works, which are not by their nature extensions of the covered work,
-and which are not combined with it such as to form a larger program,
-in or on a volume of a storage or distribution medium, is called an
-"aggregate" if the compilation and its resulting copyright are not
-used to limit the access or legal rights of the compilation's users
-beyond what the individual works permit. Inclusion of a covered work
-in an aggregate does not cause this License to apply to the other
-parts of the aggregate.
-
- 6. Conveying Non-Source Forms.
-
- You may convey a covered work in object code form under the terms
-of sections 4 and 5, provided that you also convey the
-machine-readable Corresponding Source under the terms of this License,
-in one of these ways:
-
- a) Convey the object code in, or embodied in, a physical product
- (including a physical distribution medium), accompanied by the
- Corresponding Source fixed on a durable physical medium
- customarily used for software interchange.
-
- b) Convey the object code in, or embodied in, a physical product
- (including a physical distribution medium), accompanied by a
- written offer, valid for at least three years and valid for as
- long as you offer spare parts or customer support for that product
- model, to give anyone who possesses the object code either (1) a
- copy of the Corresponding Source for all the software in the
- product that is covered by this License, on a durable physical
- medium customarily used for software interchange, for a price no
- more than your reasonable cost of physically performing this
- conveying of source, or (2) access to copy the
- Corresponding Source from a network server at no charge.
-
- c) Convey individual copies of the object code with a copy of the
- written offer to provide the Corresponding Source. This
- alternative is allowed only occasionally and noncommercially, and
- only if you received the object code with such an offer, in accord
- with subsection 6b.
-
- d) Convey the object code by offering access from a designated
- place (gratis or for a charge), and offer equivalent access to the
- Corresponding Source in the same way through the same place at no
- further charge. You need not require recipients to copy the
- Corresponding Source along with the object code. If the place to
- copy the object code is a network server, the Corresponding Source
- may be on a different server (operated by you or a third party)
- that supports equivalent copying facilities, provided you maintain
- clear directions next to the object code saying where to find the
- Corresponding Source. Regardless of what server hosts the
- Corresponding Source, you remain obligated to ensure that it is
- available for as long as needed to satisfy these requirements.
-
- e) Convey the object code using peer-to-peer transmission, provided
- you inform other peers where the object code and Corresponding
- Source of the work are being offered to the general public at no
- charge under subsection 6d.
-
- A separable portion of the object code, whose source code is excluded
-from the Corresponding Source as a System Library, need not be
-included in conveying the object code work.
-
- A "User Product" is either (1) a "consumer product", which means any
-tangible personal property which is normally used for personal, family,
-or household purposes, or (2) anything designed or sold for incorporation
-into a dwelling. In determining whether a product is a consumer product,
-doubtful cases shall be resolved in favor of coverage. For a particular
-product received by a particular user, "normally used" refers to a
-typical or common use of that class of product, regardless of the status
-of the particular user or of the way in which the particular user
-actually uses, or expects or is expected to use, the product. A product
-is a consumer product regardless of whether the product has substantial
-commercial, industrial or non-consumer uses, unless such uses represent
-the only significant mode of use of the product.
-
- "Installation Information" for a User Product means any methods,
-procedures, authorization keys, or other information required to install
-and execute modified versions of a covered work in that User Product from
-a modified version of its Corresponding Source. The information must
-suffice to ensure that the continued functioning of the modified object
-code is in no case prevented or interfered with solely because
-modification has been made.
-
- If you convey an object code work under this section in, or with, or
-specifically for use in, a User Product, and the conveying occurs as
-part of a transaction in which the right of possession and use of the
-User Product is transferred to the recipient in perpetuity or for a
-fixed term (regardless of how the transaction is characterized), the
-Corresponding Source conveyed under this section must be accompanied
-by the Installation Information. But this requirement does not apply
-if neither you nor any third party retains the ability to install
-modified object code on the User Product (for example, the work has
-been installed in ROM).
-
- The requirement to provide Installation Information does not include a
-requirement to continue to provide support service, warranty, or updates
-for a work that has been modified or installed by the recipient, or for
-the User Product in which it has been modified or installed. Access to a
-network may be denied when the modification itself materially and
-adversely affects the operation of the network or violates the rules and
-protocols for communication across the network.
-
- Corresponding Source conveyed, and Installation Information provided,
-in accord with this section must be in a format that is publicly
-documented (and with an implementation available to the public in
-source code form), and must require no special password or key for
-unpacking, reading or copying.
-
- 7. Additional Terms.
-
- "Additional permissions" are terms that supplement the terms of this
-License by making exceptions from one or more of its conditions.
-Additional permissions that are applicable to the entire Program shall
-be treated as though they were included in this License, to the extent
-that they are valid under applicable law. If additional permissions
-apply only to part of the Program, that part may be used separately
-under those permissions, but the entire Program remains governed by
-this License without regard to the additional permissions.
-
- When you convey a copy of a covered work, you may at your option
-remove any additional permissions from that copy, or from any part of
-it. (Additional permissions may be written to require their own
-removal in certain cases when you modify the work.) You may place
-additional permissions on material, added by you to a covered work,
-for which you have or can give appropriate copyright permission.
-
- Notwithstanding any other provision of this License, for material you
-add to a covered work, you may (if authorized by the copyright holders of
-that material) supplement the terms of this License with terms:
-
- a) Disclaiming warranty or limiting liability differently from the
- terms of sections 15 and 16 of this License; or
-
- b) Requiring preservation of specified reasonable legal notices or
- author attributions in that material or in the Appropriate Legal
- Notices displayed by works containing it; or
-
- c) Prohibiting misrepresentation of the origin of that material, or
- requiring that modified versions of such material be marked in
- reasonable ways as different from the original version; or
-
- d) Limiting the use for publicity purposes of names of licensors or
- authors of the material; or
-
- e) Declining to grant rights under trademark law for use of some
- trade names, trademarks, or service marks; or
-
- f) Requiring indemnification of licensors and authors of that
- material by anyone who conveys the material (or modified versions of
- it) with contractual assumptions of liability to the recipient, for
- any liability that these contractual assumptions directly impose on
- those licensors and authors.
-
- All other non-permissive additional terms are considered "further
-restrictions" within the meaning of section 10. If the Program as you
-received it, or any part of it, contains a notice stating that it is
-governed by this License along with a term that is a further
-restriction, you may remove that term. If a license document contains
-a further restriction but permits relicensing or conveying under this
-License, you may add to a covered work material governed by the terms
-of that license document, provided that the further restriction does
-not survive such relicensing or conveying.
-
- If you add terms to a covered work in accord with this section, you
-must place, in the relevant source files, a statement of the
-additional terms that apply to those files, or a notice indicating
-where to find the applicable terms.
-
- Additional terms, permissive or non-permissive, may be stated in the
-form of a separately written license, or stated as exceptions;
-the above requirements apply either way.
-
- 8. Termination.
-
- You may not propagate or modify a covered work except as expressly
-provided under this License. Any attempt otherwise to propagate or
-modify it is void, and will automatically terminate your rights under
-this License (including any patent licenses granted under the third
-paragraph of section 11).
-
- However, if you cease all violation of this License, then your
-license from a particular copyright holder is reinstated (a)
-provisionally, unless and until the copyright holder explicitly and
-finally terminates your license, and (b) permanently, if the copyright
-holder fails to notify you of the violation by some reasonable means
-prior to 60 days after the cessation.
-
- Moreover, your license from a particular copyright holder is
-reinstated permanently if the copyright holder notifies you of the
-violation by some reasonable means, this is the first time you have
-received notice of violation of this License (for any work) from that
-copyright holder, and you cure the violation prior to 30 days after
-your receipt of the notice.
-
- Termination of your rights under this section does not terminate the
-licenses of parties who have received copies or rights from you under
-this License. If your rights have been terminated and not permanently
-reinstated, you do not qualify to receive new licenses for the same
-material under section 10.
-
- 9. Acceptance Not Required for Having Copies.
-
- You are not required to accept this License in order to receive or
-run a copy of the Program. Ancillary propagation of a covered work
-occurring solely as a consequence of using peer-to-peer transmission
-to receive a copy likewise does not require acceptance. However,
-nothing other than this License grants you permission to propagate or
-modify any covered work. These actions infringe copyright if you do
-not accept this License. Therefore, by modifying or propagating a
-covered work, you indicate your acceptance of this License to do so.
-
- 10. Automatic Licensing of Downstream Recipients.
-
- Each time you convey a covered work, the recipient automatically
-receives a license from the original licensors, to run, modify and
-propagate that work, subject to this License. You are not responsible
-for enforcing compliance by third parties with this License.
-
- An "entity transaction" is a transaction transferring control of an
-organization, or substantially all assets of one, or subdividing an
-organization, or merging organizations. If propagation of a covered
-work results from an entity transaction, each party to that
-transaction who receives a copy of the work also receives whatever
-licenses to the work the party's predecessor in interest had or could
-give under the previous paragraph, plus a right to possession of the
-Corresponding Source of the work from the predecessor in interest, if
-the predecessor has it or can get it with reasonable efforts.
-
- You may not impose any further restrictions on the exercise of the
-rights granted or affirmed under this License. For example, you may
-not impose a license fee, royalty, or other charge for exercise of
-rights granted under this License, and you may not initiate litigation
-(including a cross-claim or counterclaim in a lawsuit) alleging that
-any patent claim is infringed by making, using, selling, offering for
-sale, or importing the Program or any portion of it.
-
- 11. Patents.
-
- A "contributor" is a copyright holder who authorizes use under this
-License of the Program or a work on which the Program is based. The
-work thus licensed is called the contributor's "contributor version".
-
- A contributor's "essential patent claims" are all patent claims
-owned or controlled by the contributor, whether already acquired or
-hereafter acquired, that would be infringed by some manner, permitted
-by this License, of making, using, or selling its contributor version,
-but do not include claims that would be infringed only as a
-consequence of further modification of the contributor version. For
-purposes of this definition, "control" includes the right to grant
-patent sublicenses in a manner consistent with the requirements of
-this License.
-
- Each contributor grants you a non-exclusive, worldwide, royalty-free
-patent license under the contributor's essential patent claims, to
-make, use, sell, offer for sale, import and otherwise run, modify and
-propagate the contents of its contributor version.
-
- In the following three paragraphs, a "patent license" is any express
-agreement or commitment, however denominated, not to enforce a patent
-(such as an express permission to practice a patent or covenant not to
-sue for patent infringement). To "grant" such a patent license to a
-party means to make such an agreement or commitment not to enforce a
-patent against the party.
-
- If you convey a covered work, knowingly relying on a patent license,
-and the Corresponding Source of the work is not available for anyone
-to copy, free of charge and under the terms of this License, through a
-publicly available network server or other readily accessible means,
-then you must either (1) cause the Corresponding Source to be so
-available, or (2) arrange to deprive yourself of the benefit of the
-patent license for this particular work, or (3) arrange, in a manner
-consistent with the requirements of this License, to extend the patent
-license to downstream recipients. "Knowingly relying" means you have
-actual knowledge that, but for the patent license, your conveying the
-covered work in a country, or your recipient's use of the covered work
-in a country, would infringe one or more identifiable patents in that
-country that you have reason to believe are valid.
-
- If, pursuant to or in connection with a single transaction or
-arrangement, you convey, or propagate by procuring conveyance of, a
-covered work, and grant a patent license to some of the parties
-receiving the covered work authorizing them to use, propagate, modify
-or convey a specific copy of the covered work, then the patent license
-you grant is automatically extended to all recipients of the covered
-work and works based on it.
-
- A patent license is "discriminatory" if it does not include within
-the scope of its coverage, prohibits the exercise of, or is
-conditioned on the non-exercise of one or more of the rights that are
-specifically granted under this License. You may not convey a covered
-work if you are a party to an arrangement with a third party that is
-in the business of distributing software, under which you make payment
-to the third party based on the extent of your activity of conveying
-the work, and under which the third party grants, to any of the
-parties who would receive the covered work from you, a discriminatory
-patent license (a) in connection with copies of the covered work
-conveyed by you (or copies made from those copies), or (b) primarily
-for and in connection with specific products or compilations that
-contain the covered work, unless you entered into that arrangement,
-or that patent license was granted, prior to 28 March 2007.
-
- Nothing in this License shall be construed as excluding or limiting
-any implied license or other defenses to infringement that may
-otherwise be available to you under applicable patent law.
-
- 12. No Surrender of Others' Freedom.
-
- If conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License. If you cannot convey a
-covered work so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you may
-not convey it at all. For example, if you agree to terms that obligate you
-to collect a royalty for further conveying from those to whom you convey
-the Program, the only way you could satisfy both those terms and this
-License would be to refrain entirely from conveying the Program.
-
- 13. Use with the GNU Affero General Public License.
-
- Notwithstanding any other provision of this License, you have
-permission to link or combine any covered work with a work licensed
-under version 3 of the GNU Affero General Public License into a single
-combined work, and to convey the resulting work. The terms of this
-License will continue to apply to the part which is the covered work,
-but the special requirements of the GNU Affero General Public License,
-section 13, concerning interaction through a network will apply to the
-combination as such.
-
- 14. Revised Versions of this License.
-
- The Free Software Foundation may publish revised and/or new versions of
-the GNU General Public License from time to time. Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
-
- Each version is given a distinguishing version number. If the
-Program specifies that a certain numbered version of the GNU General
-Public License "or any later version" applies to it, you have the
-option of following the terms and conditions either of that numbered
-version or of any later version published by the Free Software
-Foundation. If the Program does not specify a version number of the
-GNU General Public License, you may choose any version ever published
-by the Free Software Foundation.
-
- If the Program specifies that a proxy can decide which future
-versions of the GNU General Public License can be used, that proxy's
-public statement of acceptance of a version permanently authorizes you
-to choose that version for the Program.
-
- Later license versions may give you additional or different
-permissions. However, no additional obligations are imposed on any
-author or copyright holder as a result of your choosing to follow a
-later version.
-
- 15. Disclaimer of Warranty.
-
- THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
-APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
-HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
-OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
-THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
-IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
-ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
-
- 16. Limitation of Liability.
-
- IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
-THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
-GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
-USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
-DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
-PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
-EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
-SUCH DAMAGES.
-
- 17. Interpretation of Sections 15 and 16.
-
- If the disclaimer of warranty and limitation of liability provided
-above cannot be given local legal effect according to their terms,
-reviewing courts shall apply local law that most closely approximates
-an absolute waiver of all civil liability in connection with the
-Program, unless a warranty or assumption of liability accompanies a
-copy of the Program in return for a fee.
-
- END OF TERMS AND CONDITIONS
-
- How to Apply These Terms to Your New Programs
-
- If you develop a new program, and you want it to be of the greatest
-possible use to the public, the best way to achieve this is to make it
-free software which everyone can redistribute and change under these terms.
-
- To do so, attach the following notices to the program. It is safest
-to attach them to the start of each source file to most effectively
-state the exclusion of warranty; and each file should have at least
-the "copyright" line and a pointer to where the full notice is found.
-
- <one line to give the program's name and a brief idea of what it does.>
- Copyright (C) <year> <name of author>
-
- This program is free software: you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-Also add information on how to contact you by electronic and paper mail.
-
- If the program does terminal interaction, make it output a short
-notice like this when it starts in an interactive mode:
-
- <program> Copyright (C) <year> <name of author>
- This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
- This is free software, and you are welcome to redistribute it
- under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License. Of course, your program's commands
-might be different; for a GUI interface, you would use an "about box".
-
- You should also get your employer (if you work as a programmer) or school,
-if any, to sign a "copyright disclaimer" for the program, if necessary.
-For more information on this, and how to apply and follow the GNU GPL, see
-<http://www.gnu.org/licenses/>.
-
- The GNU General Public License does not permit incorporating your program
-into proprietary programs. If your program is a subroutine library, you
-may consider it more useful to permit linking proprietary applications with
-the library. If this is what you want to do, use the GNU Lesser General
-Public License instead of this License. But first, please read
-<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ GNU GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users. We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors. You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights. Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received. You must make sure that they, too, receive
+or can get the source code. And you must show them these terms so they
+know their rights.
+
+ Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+ For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software. For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+ Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so. This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software. The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable. Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products. If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+ Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary. To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Use with the GNU Affero General Public License.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+ <program> Copyright (C) <year> <name of author>
+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+<http://www.gnu.org/licenses/>.
+
+ The GNU General Public License does not permit incorporating your program
+into proprietary programs. If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License. But first, please read
+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
diff --git a/Setup.hs b/Setup.hs
index 9a994af..833b4c6 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,2 @@
-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple
+main = defaultMain
diff --git a/src/Yu/Core/Control.hs b/src/Yu/Core/Control.hs
index 360caab..55ee6d2 100644
--- a/src/Yu/Core/Control.hs
+++ b/src/Yu/Core/Control.hs
@@ -1,220 +1,240 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-
-{-|
-Module : Yu.Core.Control
-Description : The view of glob
-Copyright : (C) Qinka 2017
-License : GPL3
-Maintainer : me@qinka.pro
-Stability : experimental
-Portability : unknow
-
-The control part of the glob.
--}
-
-
-module Yu.Core.Control
- ( Controly(..)
- , getUrlR
- , putUrlR
- , deleteUrlR
- ) where
-
-import Yesod.Core
-import Yu.Core.Control.Internal
-import Yu.Core.Model
-import Yu.Core.View
-import Yu.Import.Aeson
-import qualified Yu.Import.ByteString as B
-import Yu.Import.Text (Text)
-import qualified Yu.Import.Text as T
-import Yu.Utils.Handler
-
-
-
--- | get method router
-getUrlR :: Controly site
- => [T.Text] -- ^ index
- -> HandlerT site IO TypedContent
-getUrlR idx@(".query":_) = getQueryR idx =<< runDbDefault (fetchRes idx)
-getUrlR idx = do
- res <- runDbDefault $ fetchRes idx
- case rType <$> res of
- Just "post" -> getPostR res
- Just "text" -> getResourceR True res
- Just "binary" -> getResourceR False res
- Just "static" -> getStaticR res
- _ -> liftIO (print res) >> notFound
-
--- | put method router
-putUrlR :: Controly site
- => [Text] -- ^ index
- -> HandlerT site IO TypedContent
-putUrlR (".query":".nav":_) = putNavR
-putUrlR idx = do
- typ <- lookupPostParam "type"
- case typ of
- Just "post" -> putPostR idx
- Just "text" -> putResourceR True idx
- Just "binary" -> putResourceR False idx
- Just "static" -> putStaticR idx
- Just "frame" -> putFrameR idx
- Just "query" -> putQueryR idx
- _ -> notFound
-
--- | delete
-deleteUrlR :: Controly site
- => [Text] -- ^ index
- -> HandlerT site IO TypedContent
-deleteUrlR (".query":".nav":_) = delNavR
-deleteUrlR idx = do
- typ <- lookupPostParam "type"
- db <- case typ of
- Just "post" -> return "post"
- Just "text" -> return "resource"
- Just "binary" -> return "resource"
- Just "static" -> return "static"
- Just "query" -> return "query"
- Just "frame" -> return "frame"
- _ -> notFound
- rt <- tryH.runDbDefault $ deleteItem idx db
- case rt of
- Left e -> returnEH e
- Right _ -> returnSucc
-
-
--- | get post
-getPostR :: Controly site
- => Maybe ResT -- ^ index
- -> HandlerT site IO TypedContent
-getPostR (Just res@ResT{..}) = do
- html <- runDbDefault $ fetchPost res
- case html of
- Just pH -> respondPost res pH
- _ -> liftIO (putStrLn "Faile to get") >> notFound
-getPostR _ = notFound
-
--- | put post
-putPostR :: Controly site
- => [Text] -- ^ index
- -> HandlerT site IO TypedContent
-putPostR idx = do
- unR <- lookupPostUnResT idx
- html <- T.decodeUtf8 <#> getFile "html"
- putItem unR html updatePost
-
--- | get resource
-getResourceR :: Controly site
- => Bool -- ^ whether item is text
- -> Maybe ResT
- -> HandlerT site IO TypedContent
-getResourceR t (Just res@ResT{..}) = do
- ct <- runDbDefault $ fetchItem res
- case ct of
- Just (Left text) -> respondResourceT res text
- Just (Right binary) -> respondResourceB res binary
- _ -> notFound
- where
- fetchItem :: Controly site
- => ResT
- -> Action (HandlerT site IO) (Maybe (Either T.Text B.ByteString))
- fetchItem = if t
- then (Left <#>) <$> fetchResourceT
- else (Right <#>) <$> fetchResourceB
-getResourceR _ _ = notFound
-
--- | put resource
-putResourceR :: Controly site
- => Bool -- ^ whether item is text
- -> [T.Text]
- -> HandlerT site IO TypedContent
-putResourceR t idx = do
- unR <- lookupPostUnResT idx
- text <- T.decodeUtf8 <#> getFile "text"
- bin <- getFile "binary"
- if t
- then putItem unR text updateResourceT
- else putItem unR (Binary <$> bin) updateResourceB
-
--- | get static
-getStaticR :: Controly site
- => Maybe ResT
- -> HandlerT site IO TypedContent
-getStaticR (Just res@ResT{..}) = do
- url <- runDbDefault $ fetchStatic res
- case url of
- Just u -> respondStatic res u
- _ -> notFound
-getStaticR _ = notFound
-
--- | put static
-putStaticR :: Controly site
- => [Text]
- -> HandlerT site IO TypedContent
-putStaticR idx = do
- unR <- lookupPostUnResT idx
- url <- lookupPostParam "url"
- putItem unR url updateStatic
-
-
--- | put frame
-putFrameR :: Controly site
- => [T.Text]
- -> HandlerT site IO TypedContent
-putFrameR idx = do
- unR <- lookupPostUnResT idx
- html <- T.decodeUtf8 <#> getFile "html"
- putItem unR html updateFrame
-
--- | get query
-getQueryR :: Controly site
- => [Text]
- -> Maybe ResT
- -> HandlerT site IO TypedContent
-getQueryR idx r =
- case tail idx of
- ".version":"author":_ -> queryVersionAuthor
- ".version":"utils":_ -> queryVersionUtils
- ".version":"core":_ -> queryVersionCore
- ".version":_ -> queryVersion
- ".name":_ -> queryName
- ".buildinfo":_ -> queryBuildInfo
- ".servertime":_ -> queryServerTime
- ".nav":_ -> runDbDefault fetchNav >>= queryNav
- ".index":xs -> runDbDefault fetchResAll >>= queryIndex (T.unpack $ T.concat xs)
- _ -> runDbDefault (fetchMaybeR fetchQuery r)
- >>= (\t -> case t of
- Just text -> queryQuery text
- _ -> notFound
- )
-
--- | put query
-putQueryR :: Controly site
- => [T.Text]
- -> HandlerT site IO TypedContent
-putQueryR idx = do
- unR <- lookupPostUnResT idx
- var <- lookupPostParam "var"
- putItem unR var updateQuery
-
--- | put navs
-putNavR :: Controly site
- => HandlerT site IO TypedContent
-putNavR = do
- idx <- lookupPostParam "label"
- url <- lookupPostParam "url"
- order <- lookupPostParam "order"
- runDbDefault $ updateNav idx url (T.read <$> order)
- returnSucc
-
--- | delete navs
-delNavR :: Controly site
- => HandlerT site IO TypedContent
-delNavR = do
- idx <- lookupPostParam "label"
- runDbDefault $ deleteNav idx
- returnSucc
-
+{-
+
+ Copyright (C) 2017-2018 Johann Lee <me@qinka.pro>
+
+ This file is part of Yu.
+
+ Yu 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.
+
+ Yu is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+{-|
+Module : Yu.Core.Control
+Description : The view of glob
+Copyright : (C) 2017-2018 Johann Lee <me@qinka.pro>
+License : GPL3
+Maintainer : me@qinka.pro
+Stability : experimental
+Portability : unknow
+
+The control part of the glob.
+-}
+
+
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Yu.Core.Control
+ ( Controly(..)
+ , getUrlR
+ , putUrlR
+ , deleteUrlR
+ ) where
+
+import Yesod.Core
+import Yu.Core.Control.Internal
+import Yu.Core.Model
+import Yu.Core.View
+import Yu.Import.Aeson
+import qualified Yu.Import.ByteString as B
+import Yu.Import.Text (Text)
+import qualified Yu.Import.Text as T
+import Yu.Utils.Handler
+
+-- | get method router
+getUrlR :: Controly site
+ => [T.Text] -- ^ index
+ -> HandlerT site IO TypedContent
+getUrlR idx@(".query":_) = getQueryR idx =<< runDbDefault (fetchRes idx)
+getUrlR idx = do
+ res <- runDbDefault $ fetchRes idx
+ case rType <$> res of
+ Just "post" -> getPostR res
+ Just "text" -> getResourceR True res
+ Just "binary" -> getResourceR False res
+ Just "static" -> getStaticR res
+ _ -> liftIO (print res) >> notFound
+
+-- | put method router
+putUrlR :: Controly site
+ => [Text] -- ^ index
+ -> HandlerT site IO TypedContent
+putUrlR (".query":".nav":_) = putNavR
+putUrlR idx = do
+ typ <- lookupPostParam "type"
+ case typ of
+ Just "post" -> putPostR idx
+ Just "text" -> putResourceR True idx
+ Just "binary" -> putResourceR False idx
+ Just "static" -> putStaticR idx
+ Just "frame" -> putFrameR idx
+ Just "query" -> putQueryR idx
+ _ -> notFound
+
+-- | delete
+deleteUrlR :: Controly site
+ => [Text] -- ^ index
+ -> HandlerT site IO TypedContent
+deleteUrlR (".query":".nav":_) = delNavR
+deleteUrlR idx = do
+ typ <- lookupPostParam "type"
+ db <- case typ of
+ Just "post" -> return "post"
+ Just "text" -> return "resource"
+ Just "binary" -> return "resource"
+ Just "static" -> return "static"
+ Just "query" -> return "query"
+ Just "frame" -> return "frame"
+ _ -> notFound
+ rt <- tryH.runDbDefault $ deleteItem idx db
+ case rt of
+ Left e -> returnEH e
+ Right _ -> returnSucc
+
+
+-- | get post
+getPostR :: Controly site
+ => Maybe ResT -- ^ index
+ -> HandlerT site IO TypedContent
+getPostR (Just res@ResT{..}) = do
+ html <- runDbDefault $ fetchPost res
+ case html of
+ Just pH -> respondPost res pH
+ _ -> liftIO (putStrLn "Faile to get") >> notFound
+getPostR _ = notFound
+
+-- | put post
+putPostR :: Controly site
+ => [Text] -- ^ index
+ -> HandlerT site IO TypedContent
+putPostR idx = do
+ unR <- lookupPostUnResT idx
+ html <- T.decodeUtf8 <#> getFile "html"
+ putItem unR html updatePost
+
+-- | get resource
+getResourceR :: Controly site
+ => Bool -- ^ whether item is text
+ -> Maybe ResT
+ -> HandlerT site IO TypedContent
+getResourceR t (Just res@ResT{..}) = do
+ ct <- runDbDefault $ fetchItem res
+ case ct of
+ Just (Left text) -> respondResourceT res text
+ Just (Right binary) -> respondResourceB res binary
+ _ -> notFound
+ where
+ fetchItem :: Controly site
+ => ResT
+ -> Action (HandlerT site IO) (Maybe (Either T.Text B.ByteString))
+ fetchItem = if t
+ then (Left <#>) <$> fetchResourceT
+ else (Right <#>) <$> fetchResourceB
+getResourceR _ _ = notFound
+
+-- | put resource
+putResourceR :: Controly site
+ => Bool -- ^ whether item is text
+ -> [T.Text]
+ -> HandlerT site IO TypedContent
+putResourceR t idx = do
+ unR <- lookupPostUnResT idx
+ text <- T.decodeUtf8 <#> getFile "text"
+ bin <- getFile "binary"
+ if t
+ then putItem unR text updateResourceT
+ else putItem unR (Binary <$> bin) updateResourceB
+
+-- | get static
+getStaticR :: Controly site
+ => Maybe ResT
+ -> HandlerT site IO TypedContent
+getStaticR (Just res@ResT{..}) = do
+ url <- runDbDefault $ fetchStatic res
+ case url of
+ Just u -> respondStatic res u
+ _ -> notFound
+getStaticR _ = notFound
+
+-- | put static
+putStaticR :: Controly site
+ => [Text]
+ -> HandlerT site IO TypedContent
+putStaticR idx = do
+ unR <- lookupPostUnResT idx
+ url <- lookupPostParam "url"
+ putItem unR url updateStatic
+
+
+-- | put frame
+putFrameR :: Controly site
+ => [T.Text]
+ -> HandlerT site IO TypedContent
+putFrameR idx = do
+ unR <- lookupPostUnResT idx
+ html <- T.decodeUtf8 <#> getFile "html"
+ putItem unR html updateFrame
+
+-- | get query
+getQueryR :: Controly site
+ => [Text]
+ -> Maybe ResT
+ -> HandlerT site IO TypedContent
+getQueryR idx r =
+ case tail idx of
+ ".version":"author":_ -> queryVersionAuthor
+ ".version":"utils":_ -> queryVersionUtils
+ ".version":"core":_ -> queryVersionCore
+ ".version":_ -> queryVersion
+ ".name":_ -> queryName
+ ".buildinfo":_ -> queryBuildInfo
+ ".servertime":_ -> queryServerTime
+ ".nav":_ -> runDbDefault fetchNav >>= queryNav
+ ".index":xs -> runDbDefault fetchResAll >>= queryIndex (T.unpack $ T.concat xs)
+ _ -> runDbDefault (fetchMaybeR fetchQuery r)
+ >>= (\t -> case t of
+ Just text -> queryQuery text
+ _ -> notFound
+ )
+
+-- | put query
+putQueryR :: Controly site
+ => [T.Text]
+ -> HandlerT site IO TypedContent
+putQueryR idx = do
+ unR <- lookupPostUnResT idx
+ var <- lookupPostParam "var"
+ putItem unR var updateQuery
+
+-- | put navs
+putNavR :: Controly site
+ => HandlerT site IO TypedContent
+putNavR = do
+ idx <- lookupPostParam "label"
+ url <- lookupPostParam "url"
+ order <- lookupPostParam "order"
+ runDbDefault $ updateNav idx url (T.read <$> order)
+ returnSucc
+
+-- | delete navs
+delNavR :: Controly site
+ => HandlerT site IO TypedContent
+delNavR = do
+ idx <- lookupPostParam "label"
+ runDbDefault $ deleteNav idx
+ returnSucc
+
diff --git a/src/Yu/Core/Control/Internal.hs b/src/Yu/Core/Control/Internal.hs
index 181776a..ecc1533 100644
--- a/src/Yu/Core/Control/Internal.hs
+++ b/src/Yu/Core/Control/Internal.hs
@@ -1,102 +1,123 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-
-{-|
-Module : Yu.Core.Control.Internal
-Description : The view of glob
-Copyright : (C) Qinka 2017
-License : GPL3
-Maintainer : me@qinka.pro
-Stability : experimental
-Portability : unknow
-
-The control part of the glob.
--}
-
-
-module Yu.Core.Control.Internal
- ( lookupPostUnResT
- , getFile
- , getField
- , putItem
- , returnSucc
- , Controly(..)
- ) where
-
-import Data.Conduit
-import Yesod.Core
-import Yu.Core.Model
-import Yu.Core.View
-import qualified Yu.Import.ByteString as B
-import Yu.Import.Text (Text)
-import qualified Yu.Import.Text as T
-import Yu.Utils.Handler
-
-
-
--- | for control
-class (Mongodic site (HandlerT site IO), MonadHandler (HandlerT site IO), Hamletic site (HandlerT site IO), Yesod site) => Controly site
-
--- | lookup the undefined index
-lookupPostUnResT :: Controly site
- => [Text] -- ^ index
- -> HandlerT site IO (Maybe ResT)
-lookupPostUnResT idx = do
- ty <- lookupPostParam "type"
- ct <- lookupPostParam "create-time"
- ut <- lookupPostParam "update-time"
- ti <- lookupPostParam "title"
- su <- getField "summary"
- wh <- lookupPostParam "whose"
- mi <- lookupPostParam "mime"
- tg <- lookupPostParams "tag"
- ts <- T.words <#> lookupPostParams "tags"
- return $ case (ty,ct,ut,ti) of
- (Just t,Just c,Just u,Just i) -> Just . ResT
- idx undefined t (T.read c) (T.read u) i su wh mi . concat $ tg:ts
- _ -> Nothing
-
--- | get the uploaded file in ByteString
-getFilesBS :: (MonadResource m, MonadHandler m)
- => [FileInfo] -- ^ file infos
- -> m (Maybe B.ByteString)
-getFilesBS [] = return Nothing
-getFilesBS xs = Just. B.concat.concat <$>
- mapM (sourceToList.fileSource) xs
-
--- | get the file via file name
-getFile :: (MonadResource m, MonadHandler m)
- => T.Text -- ^ file name (field name)
- -> m (Maybe B.ByteString)
-getFile file = getFilesBS =<< lookupFiles file
-
--- | get the field text
-getField :: (MonadResource m, MonadHandler m)
- => T.Text -- ^ field name
- -> m (Maybe T.Text)
-getField fieled = do
- su <- T.decodeUtf8 <#> getFile fieled
- case su of
- Just s -> return su
- _ -> lookupPostParam fieled
-
--- | for upload the items
-putItem :: (Controly site, Val a)
- => Maybe ResT -- ^ resource index (maybe)
- -> Maybe a -- ^ item (maybe)
- -> (a -> ResT -> Action (HandlerT site IO) ()) -- ^ upload action for database
- -> HandlerT site IO TypedContent
-putItem unR item f = case (unR,item) of
- (Just r,Just i) -> do
- rt <- tryH.runDbDefault $ f i r
- returnI rt
- _ -> invalidArgs [" args failed"]
- where
- returnI (Left e) = returnEH e
- returnI (Right _) = respondSource "" $ sendChunkText "success"
-
--- | return sucecess
-returnSucc :: HandlerT site IO TypedContent
-returnSucc = respondSource "text/plain" $ sendChunkText "success"
+{-
+Copyright (C) 2017-2018 Johann Lee <me@qinka.pro>
+
+This file is part of Yu.
+
+Yu 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.
+
+Yu is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+
+{-|
+Module : Yu.Core.Control.Internal
+Description : The view of glob
+Copyright : (C) 2017-2018 Johann Lee <me@qinka.pro>
+License : GPL3
+Maintainer : me@qinka.pro
+Stability : experimental
+Portability : unknow
+
+The control part of the glob.
+-}
+
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Yu.Core.Control.Internal
+ ( lookupPostUnResT
+ , getFile
+ , getField
+ , putItem
+ , returnSucc
+ , Controly(..)
+ ) where
+
+import Data.Conduit
+import Yesod.Core
+import Yu.Core.Model
+import Yu.Core.View
+import qualified Yu.Import.ByteString as B
+import Yu.Import.Text (Text)
+import qualified Yu.Import.Text as T
+import Yu.Utils.Handler
+
+
+
+-- | for control
+class (Mongodic site (HandlerT site IO), MonadHandler (HandlerT site IO), Hamletic site (HandlerT site IO), Yesod site) => Controly site
+
+-- | lookup the undefined index
+lookupPostUnResT :: Controly site
+ => [Text] -- ^ index
+ -> HandlerT site IO (Maybe ResT)
+lookupPostUnResT idx = do
+ ty <- lookupPostParam "type"
+ ct <- lookupPostParam "create-time"
+ ut <- lookupPostParam "update-time"
+ ti <- lookupPostParam "title"
+ su <- getField "summary"
+ wh <- lookupPostParam "whose"
+ mi <- lookupPostParam "mime"
+ tg <- lookupPostParams "tag"
+ ts <- T.words <#> lookupPostParams "tags"
+ return $ case (ty,ct,ut,ti) of
+ (Just t,Just c,Just u,Just i) -> Just . ResT
+ idx undefined t (T.read c) (T.read u) i su wh mi . concat $ tg:ts
+ _ -> Nothing
+
+-- | get the uploaded file in ByteString
+getFilesBS :: (MonadResource m, MonadHandler m)
+ => [FileInfo] -- ^ file infos
+ -> m (Maybe B.ByteString)
+getFilesBS [] = return Nothing
+getFilesBS xs = Just. B.concat.concat <$>
+ mapM (sourceToList.fileSource) xs
+
+-- | get the file via file name
+getFile :: (MonadResource m, MonadHandler m)
+ => T.Text -- ^ file name (field name)
+ -> m (Maybe B.ByteString)
+getFile file = getFilesBS =<< lookupFiles file
+
+-- | get the field text
+getField :: (MonadResource m, MonadHandler m)
+ => T.Text -- ^ field name
+ -> m (Maybe T.Text)
+getField fieled = do
+ su <- T.decodeUtf8 <#> getFile fieled
+ case su of
+ Just s -> return su
+ _ -> lookupPostParam fieled
+
+-- | for upload the items
+putItem :: (Controly site, Val a)
+ => Maybe ResT -- ^ resource index (maybe)
+ -> Maybe a -- ^ item (maybe)
+ -> (a -> ResT -> Action (HandlerT site IO) ()) -- ^ upload action for database
+ -> HandlerT site IO TypedContent
+putItem unR item f = case (unR,item) of
+ (Just r,Just i) -> do
+ rt <- tryH.runDbDefault $ f i r
+ returnI rt
+ _ -> invalidArgs [" args failed"]
+ where
+ returnI (Left e) = returnEH e
+ returnI (Right _) = respondSource "" $ sendChunkText "success"
+
+-- | return sucecess
+returnSucc :: HandlerT site IO TypedContent
+returnSucc = respondSource "text/plain" $ sendChunkText "success"
diff --git a/src/Yu/Core/Info.hs b/src/Yu/Core/Info.hs
index c60cbf7..2921714 100644
--- a/src/Yu/Core/Info.hs
+++ b/src/Yu/Core/Info.hs
@@ -1,66 +1,84 @@
-{-# OPTIONS_HADDOCK hide #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-{-|
-Module : Yu.Core.Info
-Description : THe info of this package
-Copyright : Qinka 2017
-License : GPL-3
-Maintainer : qinka@live.com
- me@qinka.pro
-Stability : experimental
-Portability : x86/64
-
-The information of thos package, such as version, git commit-id.
--}
-
-
-
-
-
-module Yu.Core.Info
- ( -- * TemplateHaskell's variables
- yuCoreVersion
- , yuCoreVersionQuote
- , yuCoreGitBranchQuote
- , yuCoreGitCommitQuote
- , yuBuildInfoQuote
- ) where
-
-import Data.Char
-import Data.Time
-import Paths_yu_core
-import System.Info
-import Yu.Import.TH
-import Yu.Import.Version
-
--- | The version of this package, in Data.Version.Version
-yuCoreVersion :: Version -- ^ The version
-yuCoreVersion = version
--- | The version of the package, in a Q Exp
-yuCoreVersionQuote :: Q Exp -- ^ String
-yuCoreVersionQuote = stringE $ showVersion version
-
-
-
--- | The commit of the git
-yuCoreGitCommitQuote :: Q Exp -- ^ String
-yuCoreGitCommitQuote = gitHash
--- | The commit of the branch
-yuCoreGitBranchQuote :: Q Exp -- ^ String
-yuCoreGitBranchQuote = gitBranch
-
--- | build information
-yuBuildInfoQuote :: Q Exp -- ^ String
-yuBuildInfoQuote = do
- timeStr <- formatTime defaultTimeLocale "-%Y-%m-%d-%H-%M-%S" <$> runIO getCurrentTime
- stringE $ os ++ "-" ++ arch ++ "-" ++ map toUpper compilerName
- ++ "-" ++ showVersion compilerVersion ++ timeStr
- ++ "-git:" ++ $gitBranch ++ ":" ++ $gitHash
-
-
-
--- | Use these as a string
--- @
--- putStrLn $YuCoreVersionQuote ++ $YuCoreGitCommitQuote
--- @
+
+{-
+Copyright (C) 2017-2018 Johann Lee <me@qinka.pro>
+
+ This file is part of Yu.
+
+ Yu 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.
+
+ Yu is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+{-|
+Module : Yu.Core.Info
+Description : THe info of this package
+Copyright : (C) 2017-2018 Johann Lee <me@qinka.pro>
+License : GPL-3
+Maintainer : qinka@live.com
+ me@qinka.pro
+Stability : experimental
+Portability : x86/64
+
+The information of thos package, such as version, git commit-id.
+-}
+
+{-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+
+
+module Yu.Core.Info
+ ( -- * TemplateHaskell's variables
+ yuCoreVersion
+ , yuCoreVersionQuote
+ , yuCoreGitBranchQuote
+ , yuCoreGitCommitQuote
+ , yuBuildInfoQuote
+ ) where
+
+import Data.Char
+import Data.Time
+import Paths_yu_core
+import System.Info
+import Yu.Import.TH
+import Yu.Import.Version
+
+-- | The version of this package, in Data.Version.Version
+yuCoreVersion :: Version -- ^ The version
+yuCoreVersion = version
+-- | The version of the package, in a Q Exp
+yuCoreVersionQuote :: Q Exp -- ^ String
+yuCoreVersionQuote = stringE $ showVersion version
+
+
+
+-- | The commit of the git
+yuCoreGitCommitQuote :: Q Exp -- ^ String
+yuCoreGitCommitQuote = gitHash
+-- | The commit of the branch
+yuCoreGitBranchQuote :: Q Exp -- ^ String
+yuCoreGitBranchQuote = gitBranch
+
+-- | build information
+yuBuildInfoQuote :: Q Exp -- ^ String
+yuBuildInfoQuote = do
+ timeStr <- formatTime defaultTimeLocale "-%Y-%m-%d-%H-%M-%S" <$> runIO getCurrentTime
+ stringE $ os ++ "-" ++ arch ++ "-" ++ map toUpper compilerName
+ ++ "-" ++ showVersion compilerVersion ++ timeStr
+ ++ "-git:" ++ $gitBranch ++ ":" ++ $gitHash
+
+
+
+-- | Use these as a string
+-- @
+-- putStrLn $YuCoreVersionQuote ++ $YuCoreGitCommitQuote
+-- @
diff --git a/src/Yu/Core/Model.hs b/src/Yu/Core/Model.hs
index b0f1cfc..2dc3b9d 100644
--- a/src/Yu/Core/Model.hs
+++ b/src/Yu/Core/Model.hs
@@ -1,155 +1,175 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-{-|
-Module : Yu.Core.Model
-Description : The module for model
-Copyright : (C) Qinka 2017
-Maintainer : me@qinka.pro
-License : GPL3
-Stability : experimental
-Portability : unknown
-
-The codes for model
--}
-
-module Yu.Core.Model
- ( -- * run database
- runDb
- , runDbDefault
- , -- * model
- fetchFrame
- , updateFrame
- , fetchPost
- , updatePost
- , fetchResourceB
- , updateResourceB
- , fetchResourceT
- , updateResourceT
- , fetchStatic
- , updateStatic
- , fetchQuery
- , updateQuery
- , fetchMaybeI
- , fetchMaybeR
- , -- ** for navgation
- fetchNav
- , updateNav
- , deleteNav
- , -- re-export
- module Yu.Core.Model.Internal
- ) where
-
-
-import Control.Monad
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Control
-import Data.Pool
-import Text.Blaze.Html (Html (..))
-import qualified Text.Blaze.Html as TBH
-import Yu.Core.Model.Internal
-import Yu.Core.Model.TH
-import Yu.Import
-import Yu.Import.ByteString (ByteString (..))
-import Yu.Import.Text (Text (..))
-import Yu.Utils.Handler
-import Yu.Utils.Handler
-
--- | escapted to html
-preEscapedToHtml :: Text -> Html
-preEscapedToHtml = TBH.preEscapedToHtml
-
--- | about frame
-makeFetch 'preEscapedToHtml "frame" ''Html "html" "frame"
-makeUpdate "frame" ''Text "html" "frame"
-
--- | about post
-makeFetch 'preEscapedToHtml "post" ''Html "html" "post"
-makeUpdate "post" ''Text "html" "post"
-
--- | about text resource
-makeFetch 'id "resourceT" ''Text "text" "resource"
-makeUpdate "resourceT" ''Text "text" "resource"
-
--- | about binary resource
-makeFetch 'fromBinary "resourceB" ''ByteString "binary" "resource"
-makeUpdate "resourceB" ''Binary "binary" "resource"
-
--- | about static
-makeFetch 'id "static" ''Text "url" "static"
-makeUpdate "static" ''Text "url" "static"
-
--- | about query
-makeFetch 'id "query" ''Text "var" "query"
-makeUpdate "query" ''Text "var" "query"
-
-
--- | fetch maybe index
-fetchMaybeI :: MonadIO m
- => (ResT -> Action m (Maybe a)) -- ^ funcion for action
- -> [Text] -- ^ index
- -> Action m (Maybe a)
-fetchMaybeI mf idx =
- fetchRes idx >>= fetchMaybeR mf
-
--- | fetch maybe resource
-fetchMaybeR :: MonadIO m
- => (ResT -> Action m (Maybe a)) -- ^ function for action
- -> Maybe ResT -- ^ index
- -> Action m (Maybe a)
-fetchMaybeR mf (Just r) = mf r
-fetchMaybeR _ _ = return Nothing
-
--- | fetch the nav
-fetchNav :: (MonadBaseControl IO m, MonadIO m)
- => Action m [Nav]
-fetchNav = do
- cr <- find $ select [] "nav"
- navs <- map docToNav <$> rest cr
- closeCursor cr
- return $ catMaybes navs
-
--- | update nav
-updateNav :: MonadIO m
- => Maybe Text -- ^ label
- -> Maybe Text -- ^ url
- -> Maybe Int -- ^ order
- -> Action m ()
-updateNav label url order =
- void $ upsert (select ["label" =: label] "nav") $ catMaybes
- [ Just ("index" =: label)
- , "url" =@ url
- , "order" =@ order
- ]
-
--- | delete the nav
-deleteNav :: MonadIO m
- => Maybe Text -- ^ label ( if it is Nothing, the all nav item will be delete)
- -> Action m ()
-deleteNav label =
- delete $ select (catMaybes ["index" =@ label]) "nav"
-
--- | run mongo
-runDb :: Mongodic site m
- => AccessMode -- ^ access mode
- -> Database -- ^ database
- -> Action m a -- ^ action
- -> m a
-runDb am db mf = getPool >>= \pool ->
- withResource pool $ \p -> do
- (user,pass) <- getDbUP
- access p am db $ do
- auth user pass
- mf
-
--- | run mongo with default
-runDbDefault :: Mongodic site m
- => Action m a -- ^ action
- -> m a
-runDbDefault mf = do
- am <- getDefaultAccessMode
- db <- getDefaultDb
- runDb am db mf
-
+{-
+ Copyright (C) 2017-2018 Johann Lee
+
+ This file is part of Yu.
+
+ Yu 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.
+
+ Yu is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+{-|
+Module : Yu.Core.Model
+Description : The module for model
+Copyright : (C) 2017-2018 Johann Lee <me@qinka.pro>
+Maintainer : me@qinka.pro
+License : GPL3
+Stability : experimental
+Portability : unknown
+
+The codes for model
+-}
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+
+module Yu.Core.Model
+ ( -- * run database
+ runDb
+ , runDbDefault
+ , -- * model
+ fetchFrame
+ , updateFrame
+ , fetchPost
+ , updatePost
+ , fetchResourceB
+ , updateResourceB
+ , fetchResourceT
+ , updateResourceT
+ , fetchStatic
+ , updateStatic
+ , fetchQuery
+ , updateQuery
+ , fetchMaybeI
+ , fetchMaybeR
+ , -- ** for navgation
+ fetchNav
+ , updateNav
+ , deleteNav
+ , -- re-export
+ module Yu.Core.Model.Internal
+ ) where
+
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Control
+import Data.Pool
+import Text.Blaze.Html (Html (..))
+import qualified Text.Blaze.Html as TBH
+import Yu.Core.Model.Internal
+import Yu.Core.Model.TH
+import Yu.Import
+import Yu.Import.ByteString (ByteString (..))
+import Yu.Import.Text (Text (..))
+import Yu.Utils.Handler
+import Yu.Utils.Handler
+
+-- | escapted to html
+preEscapedToHtml :: Text -> Html
+preEscapedToHtml = TBH.preEscapedToHtml
+
+-- | about frame
+makeFetch 'preEscapedToHtml "frame" ''Html "html" "frame"
+makeUpdate "frame" ''Text "html" "frame"
+
+-- | about post
+makeFetch 'preEscapedToHtml "post" ''Html "html" "post"
+makeUpdate "post" ''Text "html" "post"
+
+-- | about text resource
+makeFetch 'id "resourceT" ''Text "text" "resource"
+makeUpdate "resourceT" ''Text "text" "resource"
+
+-- | about binary resource
+makeFetch 'fromBinary "resourceB" ''ByteString "binary" "resource"
+makeUpdate "resourceB" ''Binary "binary" "resource"
+
+-- | about static
+makeFetch 'id "static" ''Text "url" "static"
+makeUpdate "static" ''Text "url" "static"
+
+-- | about query
+makeFetch 'id "query" ''Text "var" "query"
+makeUpdate "query" ''Text "var" "query"
+
+
+-- | fetch maybe index
+fetchMaybeI :: MonadIO m
+ => (ResT -> Action m (Maybe a)) -- ^ funcion for action
+ -> [Text] -- ^ index
+ -> Action m (Maybe a)
+fetchMaybeI mf idx =
+ fetchRes idx >>= fetchMaybeR mf
+
+-- | fetch maybe resource
+fetchMaybeR :: MonadIO m
+ => (ResT -> Action m (Maybe a)) -- ^ function for action
+ -> Maybe ResT -- ^ index
+ -> Action m (Maybe a)
+fetchMaybeR mf (Just r) = mf r
+fetchMaybeR _ _ = return Nothing
+
+-- | fetch the nav
+fetchNav :: (MonadBaseControl IO m, MonadIO m)
+ => Action m [Nav]
+fetchNav = do
+ cr <- find $ select [] "nav"
+ navs <- map docToNav <$> rest cr
+ closeCursor cr
+ return $ catMaybes navs
+
+-- | update nav
+updateNav :: MonadIO m
+ => Maybe Text -- ^ label
+ -> Maybe Text -- ^ url
+ -> Maybe Int -- ^ order
+ -> Action m ()
+updateNav label url order =
+ void $ upsert (select ["label" =: label] "nav") $ catMaybes
+ [ Just ("index" =: label)
+ , "url" =@ url
+ , "order" =@ order
+ ]
+
+-- | delete the nav
+deleteNav :: MonadIO m
+ => Maybe Text -- ^ label ( if it is Nothing, the all nav item will be delete)
+ -> Action m ()
+deleteNav label =
+ delete $ select (catMaybes ["index" =@ label]) "nav"
+
+-- | run mongo
+runDb :: Mongodic site m
+ => AccessMode -- ^ access mode
+ -> Database -- ^ database
+ -> Action m a -- ^ action
+ -> m a
+runDb am db mf = getPool >>= \pool ->
+ withResource pool $ \p -> do
+ (user,pass) <- getDbUP
+ access p am db $ do
+ auth user pass
+ mf
+
+-- | run mongo with default
+runDbDefault :: Mongodic site m
+ => Action m a -- ^ action
+ -> m a
+runDbDefault mf = do
+ am <- getDefaultAccessMode
+ db <- getDefaultDb
+ runDb am db mf
+
diff --git a/src/Yu/Core/Model/Internal.hs b/src/Yu/Core/Model/Internal.hs
index fe92521..06b6381 100644
--- a/src/Yu/Core/Model/Internal.hs
+++ b/src/Yu/Core/Model/Internal.hs
@@ -1,284 +1,303 @@
-{-|
-Model : Yu.Core.Model.Internal
-Description : The basic methods for model and types
-Copyright : (C) Qinka 2017
-License : GPL3
-Maintainer : me@qinka.pro
-Stability : experimental
-Portability : unknown
-
-The basic method and type for model in MVC
--}
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Yu.Core.Model.Internal
- ( -- * navigation bar
- Nav(..)
- , navToDoc
- , docToNav
- , -- * the resource
- ResT(..)
- , resToDoc
- , docToRes
- , -- * transform
- fromBinary
- , -- * about mongoDB
- Mongodic(..)
- , ConnectionPool
- , fetchContext
- , fetchRes
- , fetchResAll
- , updateContext
- , updateItem
- , updateRes
- , deleteContext
- , deleteItem
- , deleteRes
- , deleteContextMaybe
- , (=@)
- , module Database.MongoDB
- , module Data.Pool
- ) where
-
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Control
-import Data.Pool
-import Database.MongoDB
-import Yu.Import
-import Yu.Import.Aeson
-import qualified Yu.Import.ByteString as B
-import qualified Yu.Import.Text as T
-import Yu.Utils.Handler
-
--- | ConnectionPool
-type ConnectionPool = Pool Pipe
-
--- | model for navigation bar
-data Nav = Nav { navUrl :: T.Text -- ^ The url of the link
- , navLabel :: T.Text -- ^ The label of the link
- , navOrder :: Int -- ^ The order of the link
- }
- deriving (Show)
-
--- | instance eq, order for nav
-instance Eq Nav where
- n1 == n2 = navOrder n1 == navOrder n2
-instance Ord Nav where
- compare n1 n2 = compare (navOrder n1) (navOrder n2)
-
--- |transform between nav and document
-navToDoc :: Nav -> Document
-navToDoc Nav{..} =
- [ "index" =: navLabel
- , "url" =: navUrl
- , "order" =: navOrder
- ]
-
--- | transform Document to nav
-docToNav :: Document -> Maybe Nav
-docToNav doc = Nav
- <$> doc !? "url"
- <*> doc !? "index"
- <*> doc !? "order"
-
--- | instance Json(to)
-instance ToJSON Nav where
- toJSON Nav{..} = object
- [ "label" .= navLabel
- , "url" .= navUrl
- , "order" .= navOrder
- ]
-
--- | the resource type for item
-data ResT = ResT
- { rIndex :: [T.Text] -- ^ the path of the url
- , rRes :: ObjectId -- ^ the id of the object in the db
- , rType :: T.Text -- ^ the type of resource
- , rCTime :: UTCTime -- ^ the time when it created
- , rUTime :: UTCTime -- ^ the time when it updated
- , rTitle :: T.Text -- ^ the title
- , rSummary :: Maybe T.Text -- ^ the summary of result
- , rWhose :: Maybe T.Text -- ^ the own of the result
- , rMIME :: Maybe T.Text -- ^ the MIME type of the result
- , rTags :: [T.Text] -- ^ the tags for result
- }
- deriving (Show)
-
-instance Eq ResT where
- res1 == res2 = and
- [ abs (rCTime res1 `diffUTCTime` rCTime res2) <= 1
- , abs (rUTime res1 `diffUTCTime` rUTime res2) <= 1
- , rIndex res1 == rIndex res2
- , rRes res1 == rRes res2
- , rType res1 == rType res2
- , rTitle res1 == rTitle res2
- , rSummary res1 == rSummary res2
- , rWhose res1 == rWhose res2
- , rMIME res1 == rMIME res2
- , rTags res1 == rTags res2
- ]
-
--- | transform between res document
-resToDoc :: ResT -> Document
-resToDoc ResT{..} =
- [ "index" =: rIndex
- , "res" =: rRes
- , "type" =: rType
- , "create-time" =: rCTime
- , "update-time" =: rUTime
- , "title" =: rTitle
- , "summary" =: rSummary
- , "whose" =: rWhose
- , "mime" =: rMIME
- , "tags" =: rTags
- ]
-
-
-
--- | transform between res document
-docToRes :: Document -> Maybe ResT
-docToRes doc = ResT
- <$> doc !? "index"
- <*> doc !? "res"
- <*> doc !? "type"
- <*> doc !? "create-time"
- <*> doc !? "update-time"
- <*> doc !? "title"
- <*> Just (doc !? "summary")
- <*> Just (doc !? "whose")
- <*> Just (doc !? "mime")
- <*> m2l (doc !? "tags")
- where
- m2l (Just xs) = Just xs
- m2l _ = Just []
-
-instance ToJSON ResT where
- toJSON ResT{..} = object
- [ "index" .= rIndex
- , "type" .= rType
- , "create-time" .= rCTime
- , "update-time" .= rUTime
- , "title" .= rTitle
- , "summary" .= rSummary
- , "whose" .= rWhose
- , "mime" .= rMIME
- , "tags" .= rTags
- ]
-
-
--- | the type-class which means mongoDB available.
-class (MonadIO m,MonadBaseControl IO m) => Mongodic a m | m -> a where
- getDefaultAccessMode :: m AccessMode -- ^ get the accedd mode
- getDefaultDb :: m Database -- ^ get the default database
- getDbUP :: m (T.Text,T.Text) -- ^ get the user and pass
- getPool :: m ConnectionPool -- ^ get the connection pool
-
-
--- | fetch context
-fetchContext :: (MonadIO m,Val a)
- => T.Text -- ^ field name
- -> ResT -- ^ resource index
- -> T.Text -- ^ collection
- -> Action m (Maybe a) -- ^ result
-fetchContext field ResT{..} = ((!? field) <%>).findOne.select ["_id" =: rRes]
-
--- | fetch resource index
-fetchRes :: MonadIO m
- => [T.Text]
- -> Action m (Maybe ResT)
-fetchRes index = (docToRes <%>) . findOne $ select ["index" =: index] "index"
-
--- | fetch all resource index
-fetchResAll :: (MonadIO m, MonadBaseControl IO m)
- => Action m [ResT]
-fetchResAll = do
- cur <- find $ select [] "index"
- rt <- rest cur
- closeCursor cur
- return . catMaybes $ docToRes <$> rt
-
--- | update context
-updateContext :: (MonadIO m, Val a)
- => T.Text -- ^ collection
- -> Maybe ObjectId -- ^ obj id of item
- -> T.Text -- ^ field name
- -> a
- -> Action m ObjectId -- ^ return id
-updateContext c oid field v = case oid of
- Just i -> upsert (select ["_id" =: i] c) [field =: v] >> return i
- _ -> (\(ObjId i) -> i) <$> insert c [field =: v]
-
--- | the update for item
-updateItem :: (MonadIO m, Val a)
- => T.Text -- ^ type, or say collection
- -> T.Text -- ^ field name
- -> a -- ^ item
- -> ResT -- ^ ``undefined'' ResT
- -> Action m ()
-updateItem t f v uR = do
- let index = rIndex uR
- res <- fetchRes index
- rr <- if (rType <$> res) /= Just t
- then deleteContextMaybe res >> return Nothing
- else return $ rRes <$> res
- rO <- updateContext t rr f v
- updateRes (uR {rRes = rO})
-
--- | the update for resource
-updateRes :: MonadIO m
- => ResT -- ^ the index
- -> Action m ()
-updateRes res@ResT{..} =
- upsert (select ["index" =: rIndex] "index") $ resToDoc res
-
--- | delete the context
-deleteContext :: MonadIO m
- => ResT -- ^ index
- -> T.Text -- ^ collection
- -> Action m ()
-deleteContext ResT{..} c =
- delete $ select ["_id" =: rRes] c
-
-
--- | delete resource
-deleteRes :: MonadIO m
- => ResT -- ^ index
- -> Action m ()
-deleteRes ResT{..} =
- delete $ select ["index" =: rIndex] "index"
-
--- | delete the resouce in maybe
-deleteContextMaybe :: MonadIO m
- => Maybe ResT -- ^ index
- -> Action m ()
-deleteContextMaybe (Just r) = deleteContext r $ rType r
-deleteContextMaybe _ = return ()
-
--- | delete item
-deleteItem :: MonadIO m
- => [T.Text] -- ^ url
- -> T.Text -- ^ collection
- -> Action m ()
-deleteItem index c = fetchRes index >>=
- (\res -> case res of
- Just r -> deleteContext r c >> deleteRes r
- _ -> return ())
-
--- | Binary to ByteString
-fromBinary :: Binary -> B.ByteString
-fromBinary (Binary b) = b
-
-
--- | update nothing
-infix 0 =@
-(=@) :: Val v
- => Label -- ^ label
- -> Maybe v -- ^ value
- -> Maybe Field -- ^ maybe field
-(=@) l = ((Just.(l =:)) =<<)
+{-
+ Copyright (C) 2017-2018 Johann Lee <me@qinka.pro>
+
+ This file is part of Yu.
+
+ Yu 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.
+
+ Yu is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+{-|
+Model : Yu.Core.Model.Internal
+Description : The basic methods for model and types
+Copyright : (C) 2017-2018 Johann Lee <me@qinka.pro>
+License : GPL3
+Maintainer : me@qinka.pro
+Stability : experimental
+Portability : unknown
+
+The basic method and type for model in MVC
+-}
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Yu.Core.Model.Internal
+ ( -- * navigation bar
+ Nav(..)
+ , navToDoc
+ , docToNav
+ , -- * the resource
+ ResT(..)
+ , resToDoc
+ , docToRes
+ , -- * transform
+ fromBinary
+ , -- * about mongoDB
+ Mongodic(..)
+ , ConnectionPool
+ , fetchContext
+ , fetchRes
+ , fetchResAll
+ , updateContext
+ , updateItem
+ , updateRes
+ , deleteContext
+ , deleteItem
+ , deleteRes
+ , deleteContextMaybe
+ , (=@)
+ , module Database.MongoDB
+ , module Data.Pool
+ ) where
+
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Control
+import Data.Pool
+import Database.MongoDB
+import Yu.Import
+import Yu.Import.Aeson
+import qualified Yu.Import.ByteString as B
+import qualified Yu.Import.Text as T
+import Yu.Utils.Handler
+
+-- | ConnectionPool
+type ConnectionPool = Pool Pipe
+
+-- | model for navigation bar
+data Nav = Nav { navUrl :: T.Text -- ^ The url of the link
+ , navLabel :: T.Text -- ^ The label of the link
+ , navOrder :: Int -- ^ The order of the link
+ }
+ deriving (Show)
+
+-- | instance eq, order for nav
+instance Eq Nav where
+ n1 == n2 = navOrder n1 == navOrder n2
+instance Ord Nav where
+ compare n1 n2 = compare (navOrder n1) (navOrder n2)
+
+-- |transform between nav and document
+navToDoc :: Nav -> Document
+navToDoc Nav{..} =
+ [ "index" =: navLabel
+ , "url" =: navUrl
+ , "order" =: navOrder
+ ]
+
+-- | transform Document to nav
+docToNav :: Document -> Maybe Nav
+docToNav doc = Nav
+ <$> doc !? "url"
+ <*> doc !? "index"
+ <*> doc !? "order"
+
+-- | instance Json(to)
+instance ToJSON Nav where
+ toJSON Nav{..} = object
+ [ "label" .= navLabel
+ , "url" .= navUrl
+ , "order" .= navOrder
+ ]
+
+-- | the resource type for item
+data ResT = ResT
+ { rIndex :: [T.Text] -- ^ the path of the url
+ , rRes :: ObjectId -- ^ the id of the object in the db
+ , rType :: T.Text -- ^ the type of resource
+ , rCTime :: UTCTime -- ^ the time when it created
+ , rUTime :: UTCTime -- ^ the time when it updated
+ , rTitle :: T.Text -- ^ the title
+ , rSummary :: Maybe T.Text -- ^ the summary of result
+ , rWhose :: Maybe T.Text -- ^ the own of the result
+ , rMIME :: Maybe T.Text -- ^ the MIME type of the result
+ , rTags :: [T.Text] -- ^ the tags for result
+ }
+ deriving (Show)
+
+instance Eq ResT where
+ res1 == res2 = and
+ [ abs (rCTime res1 `diffUTCTime` rCTime res2) <= 1
+ , abs (rUTime res1 `diffUTCTime` rUTime res2) <= 1
+ , rIndex res1 == rIndex res2
+ , rRes res1 == rRes res2
+ , rType res1 == rType res2
+ , rTitle res1 == rTitle res2
+ , rSummary res1 == rSummary res2
+ , rWhose res1 == rWhose res2
+ , rMIME res1 == rMIME res2
+ , rTags res1 == rTags res2
+ ]
+
+-- | transform between res document
+resToDoc :: ResT -> Document
+resToDoc ResT{..} =
+ [ "index" =: rIndex
+ , "res" =: rRes
+ , "type" =: rType
+ , "create-time" =: rCTime
+ , "update-time" =: rUTime
+ , "title" =: rTitle
+ , "summary" =: rSummary
+ , "whose" =: rWhose
+ , "mime" =: rMIME
+ , "tags" =: rTags
+ ]
+
+
+
+-- | transform between res document
+docToRes :: Document -> Maybe ResT
+docToRes doc = ResT
+ <$> doc !? "index"
+ <*> doc !? "res"
+ <*> doc !? "type"
+ <*> doc !? "create-time"
+ <*> doc !? "update-time"
+ <*> doc !? "title"
+ <*> Just (doc !? "summary")
+ <*> Just (doc !? "whose")
+ <*> Just (doc !? "mime")
+ <*> m2l (doc !? "tags")
+ where
+ m2l (Just xs) = Just xs
+ m2l _ = Just []
+
+instance ToJSON ResT where
+ toJSON ResT{..} = object
+ [ "index" .= rIndex
+ , "type" .= rType
+ , "create-time" .= rCTime
+ , "update-time" .= rUTime
+ , "title" .= rTitle
+ , "summary" .= rSummary
+ , "whose" .= rWhose
+ , "mime" .= rMIME
+ , "tags" .= rTags
+ ]
+
+
+-- | the type-class which means mongoDB available.
+class (MonadIO m,MonadBaseControl IO m) => Mongodic a m | m -> a where
+ getDefaultAccessMode :: m AccessMode -- ^ get the accedd mode
+ getDefaultDb :: m Database -- ^ get the default database
+ getDbUP :: m (T.Text,T.Text) -- ^ get the user and pass
+ getPool :: m ConnectionPool -- ^ get the connection pool
+
+
+-- | fetch context
+fetchContext :: (MonadIO m,Val a)
+ => T.Text -- ^ field name
+ -> ResT -- ^ resource index
+ -> T.Text -- ^ collection
+ -> Action m (Maybe a) -- ^ result
+fetchContext field ResT{..} = ((!? field) <%>).findOne.select ["_id" =: rRes]
+
+-- | fetch resource index
+fetchRes :: MonadIO m
+ => [T.Text]
+ -> Action m (Maybe ResT)
+fetchRes index = (docToRes <%>) . findOne $ select ["index" =: index] "index"
+
+-- | fetch all resource index
+fetchResAll :: (MonadIO m, MonadBaseControl IO m)
+ => Action m [ResT]
+fetchResAll = do
+ cur <- find $ select [] "index"
+ rt <- rest cur
+ closeCursor cur
+ return . catMaybes $ docToRes <$> rt
+
+-- | update context
+updateContext :: (MonadIO m, Val a)
+ => T.Text -- ^ collection
+ -> Maybe ObjectId -- ^ obj id of item
+ -> T.Text -- ^ field name
+ -> a
+ -> Action m ObjectId -- ^ return id
+updateContext c oid field v = case oid of
+ Just i -> upsert (select ["_id" =: i] c) [field =: v] >> return i
+ _ -> (\(ObjId i) -> i) <$> insert c [field =: v]
+
+-- | the update for item
+updateItem :: (MonadIO m, Val a)
+ => T.Text -- ^ type, or say collection
+ -> T.Text -- ^ field name
+ -> a -- ^ item
+ -> ResT -- ^ ``undefined'' ResT
+ -> Action m ()
+updateItem t f v uR = do
+ let index = rIndex uR
+ res <- fetchRes index
+ rr <- if (rType <$> res) /= Just t
+ then deleteContextMaybe res >> return Nothing
+ else return $ rRes <$> res
+ rO <- updateContext t rr f v
+ updateRes (uR {rRes = rO})
+
+-- | the update for resource
+updateRes :: MonadIO m
+ => ResT -- ^ the index
+ -> Action m ()
+updateRes res@ResT{..} =
+ upsert (select ["index" =: rIndex] "index") $ resToDoc res
+
+-- | delete the context
+deleteContext :: MonadIO m
+ => ResT -- ^ index
+ -> T.Text -- ^ collection
+ -> Action m ()
+deleteContext ResT{..} c =
+ delete $ select ["_id" =: rRes] c
+
+
+-- | delete resource
+deleteRes :: MonadIO m
+ => ResT -- ^ index
+ -> Action m ()
+deleteRes ResT{..} =
+ delete $ select ["index" =: rIndex] "index"
+
+-- | delete the resouce in maybe
+deleteContextMaybe :: MonadIO m
+ => Maybe ResT -- ^ index
+ -> Action m ()
+deleteContextMaybe (Just r) = deleteContext r $ rType r
+deleteContextMaybe _ = return ()
+
+-- | delete item
+deleteItem :: MonadIO m
+ => [T.Text] -- ^ url
+ -> T.Text -- ^ collection
+ -> Action m ()
+deleteItem index c = fetchRes index >>=
+ (\res -> case res of
+ Just r -> deleteContext r c >> deleteRes r
+ _ -> return ())
+
+-- | Binary to ByteString
+fromBinary :: Binary -> B.ByteString
+fromBinary (Binary b) = b
+
+
+-- | update nothing
+infix 0 =@
+(=@) :: Val v
+ => Label -- ^ label
+ -> Maybe v -- ^ value
+ -> Maybe Field -- ^ maybe field
+(=@) l = ((Just.(l =:)) =<<)
diff --git a/src/Yu/Core/Model/TH.hs b/src/Yu/Core/Model/TH.hs
index d5e8c6e..35d3951 100644
--- a/src/Yu/Core/Model/TH.hs
+++ b/src/Yu/Core/Model/TH.hs
@@ -1,80 +1,98 @@
-{-|
-Module : Yu.Core.Model.TH
-Description : To generate the codes about module
-Copyright : (C) Qinka, 2017
-Maintainer : me@qinka.pro
-License : GPL3
-Stability : experimental
-Portability : unknown
-
-The codes for generate the codes about modules
--}
-
-
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module Yu.Core.Model.TH
- ( makeFetch
- , makeUpdate
- ) where
-
-import Control.Monad.IO.Class
-import Data.Char
-import Database.MongoDB as Mongo
-import Yu.Core.Model.Internal
-import Yu.Import.TH
-
-
--- | Upper case the first letter
-firstUpper :: String -> String
-firstUpper (x:xs) = toUpper x:xs
-firstUpper xs = xs
-
--- | To create fetchXxx
-makeFetch :: Name -- ^ filter name
- -> String -- ^ function name
- -> Name -- ^ type
- -> String -- ^ field name
- -> String -- ^ collection
- -> Q [Dec]
-makeFetch func n kind field collection =
- let name = mkName $ "fetch" ++ firstUpper n
- m = mkName "m"
- dec = SigD name $ ForallT [PlainTV m] [AppT (ConT ''MonadIO) (VarT m)]
- (AppT
- (AppT ArrowT (ConT ''ResT))
- (AppT (AppT (ConT ''Action) (VarT m)) (AppT (ConT ''Maybe) (ConT kind))))
- resv = mkName "res"
- body = FunD name
- [Clause [VarP resv] (NormalB $
- (AppE
- (AppE (VarE $ mkName "<#>") (VarE func))
- (AppE (AppE (AppE (VarE 'fetchContext)
- (LitE $ StringL field))
- (VarE resv))
- (LitE $ StringL collection)))) []]
- in return [dec,body]
-
-
--- | to create updateXxx
-makeUpdate :: String -- ^ function name
- -> Name -- ^ type
- -> String -- ^ field
- -> String -- ^ collection
- -> Q [Dec]
-makeUpdate n kind f c =
- let field = LitE $ StringL f
- coll = LitE $ StringL c
- name = mkName $ "update" ++ firstUpper n
- m = mkName "m"
- dec = SigD name $ ForallT [PlainTV m] [AppT (ConT ''MonadIO) (VarT m)]
- (AppT
- (AppT ArrowT (ConT kind))
- (AppT (AppT ArrowT (ConT ''ResT))
- (AppT (AppT (ConT ''Action) (VarT m)) (ConT ''()))))
- body = FunD name
- [Clause [] (NormalB $
- (AppE (AppE (VarE 'updateItem) coll)
- field)) []]
- in return [dec,body]
+{-
+ Copyright (C) 2017-2018 Johann Lee <me@qinka.pro>
+
+ This file is part of Yu.
+
+ Yu 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.
+
+ Yu is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+{-|
+Module : Yu.Core.Model.TH
+Description : To generate the codes about module
+Copyright : (C) 2017-2018 Johann Lee <me@qinka.pro>
+Maintainer : me@qinka.pro
+License : GPL3
+Stability : experimental
+Portability : unknown
+
+The codes for generate the codes about modules
+-}
+
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Yu.Core.Model.TH
+ ( makeFetch
+ , makeUpdate
+ ) where
+
+import Control.Monad.IO.Class
+import Data.Char
+import Database.MongoDB as Mongo
+import Yu.Core.Model.Internal
+import Yu.Import.TH
+
+
+-- | Upper case the first letter
+firstUpper :: String -> String
+firstUpper (x:xs) = toUpper x:xs
+firstUpper xs = xs
+
+-- | To create fetchXxx
+makeFetch :: Name -- ^ filter name
+ -> String -- ^ function name
+ -> Name -- ^ type
+ -> String -- ^ field name
+ -> String -- ^ collection
+ -> Q [Dec]
+makeFetch func n kind field collection =
+ let name = mkName $ "fetch" ++ firstUpper n
+ m = mkName "m"
+ dec = SigD name $ ForallT [PlainTV m] [AppT (ConT ''MonadIO) (VarT m)]
+ (AppT
+ (AppT ArrowT (ConT ''ResT))
+ (AppT (AppT (ConT ''Action) (VarT m)) (AppT (ConT ''Maybe) (ConT kind))))
+ resv = mkName "res"
+ body = FunD name
+ [Clause [VarP resv] (NormalB $
+ (AppE
+ (AppE (VarE $ mkName "<#>") (VarE func))
+ (AppE (AppE (AppE (VarE 'fetchContext)
+ (LitE $ StringL field))
+ (VarE resv))
+ (LitE $ StringL collection)))) []]
+ in return [dec,body]
+
+
+-- | to create updateXxx
+makeUpdate :: String -- ^ function name
+ -> Name -- ^ type
+ -> String -- ^ field
+ -> String -- ^ collection
+ -> Q [Dec]
+makeUpdate n kind f c =
+ let field = LitE $ StringL f
+ coll = LitE $ StringL c
+ name = mkName $ "update" ++ firstUpper n
+ m = mkName "m"
+ dec = SigD name $ ForallT [PlainTV m] [AppT (ConT ''MonadIO) (VarT m)]
+ (AppT
+ (AppT ArrowT (ConT kind))
+ (AppT (AppT ArrowT (ConT ''ResT))
+ (AppT (AppT (ConT ''Action) (VarT m)) (ConT ''()))))
+ body = FunD name
+ [Clause [] (NormalB $
+ (AppE (AppE (VarE 'updateItem) coll)
+ field)) []]
+ in return [dec,body]
diff --git a/src/Yu/Core/Route.hs b/src/Yu/Core/Route.hs
new file mode 100644
index 0000000..454bf50
--- /dev/null
+++ b/src/Yu/Core/Route.hs
@@ -0,0 +1,47 @@
+{-
+ Coptright (C) 2017-2018 Johann Lee <me@qinka.pro>
+
+ This file is part of Yu.
+
+ Yu 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.
+
+ Yu is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+{-|
+
+Module : Yu.Core.Route
+Description : Export the default route configuration of Yu.
+Copyright : (C) 2017 - 2018 Johann Lee
+License : GPL3
+Maintainer : me@qinka.pro
+Stability : experimental
+Portability : unknow
+
+Export the default router of site.
+-}
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Yu.Core.Route
+ ( yuRoute
+ ) where
+
+import Yesod.Core
+import Yesod.Routes.TH.Types
+import Yu.Core.Control
+
+-- | default router
+yuRoute :: [ResourceTree String]
+yuRoute = [parseRoutes| /*Texts UrlR GET PUT DELETE |]
diff --git a/src/Yu/Core/View.hs b/src/Yu/Core/View.hs
index f404dc7..10b2afd 100644
--- a/src/Yu/Core/View.hs
+++ b/src/Yu/Core/View.hs
@@ -1,118 +1,137 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-|
-Module : Yu.Core.View
-Description : The view of Yu
-Copyright : (C) Qinka 2017
-License : GPL3
-Maintainer : me@qinka.pro
-Stability : experimental
-Portability : unknow
-
-The view part of the Yu.
--}
-
-
-module Yu.Core.View
- ( -- * responds
- respondPost
- , respondResourceT
- , respondResourceB
- , respondStatic
- , -- * reexport module
- module Yu.Core.View.Internal
- , module Yu.Core.View.Query
- ) where
-
-import Control.Monad.Writer.Lazy
-import Data.Maybe
-import Data.Monoid
-import Network.HTTP.Types (status301)
-import Text.Blaze.Html (Html, preEscapedToHtml)
-import Yesod.Core
-import Yesod.Core.Handler
-import Yesod.Core.Widget
-import Yu.Core.Model (ResT (..))
-import Yu.Core.View.Internal
-import Yu.Core.View.Query
-import Yu.Import.ByteString (ByteString)
-import qualified Yu.Import.ByteString as B
-import Yu.Import.Text (Text)
-import qualified Yu.Import.Text as T
-import Yu.Utils.Handler
-
--- | response the post with ResT and html
-respondPost :: (Yesod a, Hamletic a (HandlerT a IO))
- => ResT -- ^ resource index
- -> Html -- ^ html body
- -> HandlerT a IO TypedContent
-respondPost res@ResT{..} rawBody = do
- willRaw <- getRaw
- isRaw <- null <$> lookupHeader "YuRAW"
- body <- if willRaw == isRaw then return rawBody
- else defaultLayout $ withHtml rawBody res
- respondSource "text/html" $ do
- sendChunkHtml body
- sendFlush
-
--- | with tags, import tags to js
-withTags :: [Text] -- ^ tags
- -> WidgetT site IO ()
-withTags tags = let tagsJ = toJSON tags in toWidget [julius|tags=#{tagsJ};|]
-
--- | with summary, import summary to page when it not Nothing
-withSummary :: Maybe Html -- ^ summary html
- -> WidgetT site IO ()
-withSummary (Just summaryHtml) = [whamlet|<summary id=sum>#{summaryHtml}|]
-withSummary _ = return ()
-
--- | with whose, import the author to the js
-withWhose :: Maybe Text -- ^ author
- -> WidgetT site IO ()
-withWhose (Just whose) = let w = showJs whose in toWidget [julius|author=#{w};|]
-withWhose _ = return ()
-
--- | with html combine the parts to one
-withHtml :: Html -- ^ the html for main part
- -> ResT -- ^ resource
- -> WidgetT site IO ()
-withHtml body ResT{..} = do
- setTitle $ toHtml rTitle
- withSummary $ preEscapedToHtml <$> rSummary
- [whamlet|#{body}|]
- withWhose rWhose
- withTags rTags
-
-
--- | respond resource(text)
-respondResourceT :: (Yesod a, Hamletic a (HandlerT a IO))
- => ResT -- ^ resource index
- -> Text -- ^ text
- -> HandlerT a IO TypedContent
-respondResourceT ResT{..} text = do
- respondSource (fromMaybe "" $ fmap T.encodeUtf8 rMIME) $ do
- sendChunkText text
- sendFlush
-
--- | respond resource(binary)
-respondResourceB :: (Yesod a, Hamletic a (HandlerT a IO))
- => ResT -- ^ resource index
- -> ByteString -- ^ text
- -> HandlerT a IO TypedContent
-respondResourceB ResT{..} bin = do
- respondSource (fromMaybe "" $ fmap T.encodeUtf8 rMIME) $ do
- sendChunkBS bin
- sendFlush
-
-
--- | response the static url
-respondStatic :: (Yesod a, Hamletic a (HandlerT a IO))
- => ResT -- ^ index for resource
- -> Text -- ^ Url
- -> HandlerT a IO TypedContent
-respondStatic _ url = redirectWith status301 url
+{-
+ Copyright (C) 2017-2018 Johann Lee <me@qinka.pro>
+
+ This file is part of Yu.
+
+ Yu 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.
+
+ Yu is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+{-|
+Module : Yu.Core.View
+Description : The view of Yu
+Copyright : (C) 2017-2018 Johann Lee <me@qinka.pro>
+License : GPL3
+Maintainer : me@qinka.pro
+Stability : experimental
+Portability : unknow
+
+The view part of the Yu.
+-}
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
+
+module Yu.Core.View
+ ( -- * responds
+ respondPost
+ , respondResourceT
+ , respondResourceB
+ , respondStatic
+ , -- * reexport module
+ module Yu.Core.View.Internal
+ , module Yu.Core.View.Query
+ ) where
+
+import Control.Monad.Writer.Lazy
+import Data.Maybe
+import Data.Monoid
+import Network.HTTP.Types (status301)
+import Text.Blaze.Html (Html, preEscapedToHtml)
+import Yesod.Core
+import Yesod.Core.Handler
+import Yesod.Core.Widget
+import Yu.Core.Model (ResT (..))
+import Yu.Core.View.Internal
+import Yu.Core.View.Query
+import Yu.Import.ByteString (ByteString)
+import qualified Yu.Import.ByteString as B
+import Yu.Import.Text (Text)
+import qualified Yu.Import.Text as T
+import Yu.Utils.Handler
+
+-- | response the post with ResT and html
+respondPost :: (Yesod a, Hamletic a (HandlerT a IO))
+ => ResT -- ^ resource index
+ -> Html -- ^ html body
+ -> HandlerT a IO TypedContent
+respondPost res@ResT{..} rawBody = do
+ willRaw <- getRaw
+ isRaw <- null <$> lookupHeader "YuRAW"
+ body <- if willRaw == isRaw then return rawBody
+ else defaultLayout $ withHtml rawBody res
+ respondSource "text/html" $ do
+ sendChunkHtml body
+ sendFlush
+
+-- | with tags, import tags to js
+withTags :: [Text] -- ^ tags
+ -> WidgetT site IO ()
+withTags tags = let tagsJ = toJSON tags in toWidget [julius|tags=#{tagsJ};|]
+
+-- | with summary, import summary to page when it not Nothing
+withSummary :: Maybe Html -- ^ summary html
+ -> WidgetT site IO ()
+withSummary (Just summaryHtml) = [whamlet|<summary id=sum>#{summaryHtml}|]
+withSummary _ = return ()
+
+-- | with whose, import the author to the js
+withWhose :: Maybe Text -- ^ author
+ -> WidgetT site IO ()
+withWhose (Just whose) = let w = showJs whose in toWidget [julius|author=#{w};|]
+withWhose _ = return ()
+
+-- | with html combine the parts to one
+withHtml :: Html -- ^ the html for main part
+ -> ResT -- ^ resource
+ -> WidgetT site IO ()
+withHtml body ResT{..} = do
+ setTitle $ toHtml rTitle
+ withSummary $ preEscapedToHtml <$> rSummary
+ [whamlet|#{body}|]
+ withWhose rWhose
+ withTags rTags
+
+
+-- | respond resource(text)
+respondResourceT :: (Yesod a, Hamletic a (HandlerT a IO))
+ => ResT -- ^ resource index
+ -> Text -- ^ text
+ -> HandlerT a IO TypedContent
+respondResourceT ResT{..} text = do
+ respondSource (fromMaybe "" $ fmap T.encodeUtf8 rMIME) $ do
+ sendChunkText text
+ sendFlush
+
+-- | respond resource(binary)
+respondResourceB :: (Yesod a, Hamletic a (HandlerT a IO))
+ => ResT -- ^ resource index
+ -> ByteString -- ^ text
+ -> HandlerT a IO TypedContent
+respondResourceB ResT{..} bin = do
+ respondSource (fromMaybe "" $ fmap T.encodeUtf8 rMIME) $ do
+ sendChunkBS bin
+ sendFlush
+
+
+-- | response the static url
+respondStatic :: (Yesod a, Hamletic a (HandlerT a IO))
+ => ResT -- ^ index for resource
+ -> Text -- ^ Url
+ -> HandlerT a IO TypedContent
+respondStatic _ url = redirectWith status301 url
diff --git a/src/Yu/Core/View/Internal.hs b/src/Yu/Core/View/Internal.hs
index 9f4ec5e..fae27e6 100644
--- a/src/Yu/Core/View/Internal.hs
+++ b/src/Yu/Core/View/Internal.hs
@@ -1,135 +1,156 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-
-{-|
-Module : Yu.Core.View.Internal
-Description : The internal module for view
-Copyright : (C) Qinka 2017
-License : GPL3
-Maintainer : me@qinka.pro
-Stability : experimental
-Portability : unknown
-
-The internal party for View, including Hamletic.
--}
-
-
-module Yu.Core.View.Internal
- ( Hamletic(..)
- , yuLayout
- , yuErrorHandler
- -- * layouts
- , layoutBootstrap
- ) where
-
-import Yesod.Core
-import Yesod.Core.Handler
-import Yesod.Core.Json
-import Yu.Core.Model
-import Yu.Import.Text (Text)
-import qualified Yu.Import.Text as T
-import Yu.Utils.Handler
-
--- | Hamtletic
---
--- Limit, and test
-class (MonadHandler m, Mongodic a m) => Hamletic a m | m -> a where
- getTitle :: m Text -- ^ get title
- getFramePrefix :: m Text -- ^ get the prefix path of frame
- getVersion :: m Text -- ^ get the version of blog itself or application
- getRaw :: m Bool -- ^ return raw html
-
-
--- | layout for layout
-type YuLayout site = ( PageContent (Route site)
- -> Html -- hd
- -> Text -- title
- -> Html -- nav
- -> Html -- top
- -> Html -- bottom
- -> ((Route site -> [(Text, Text)] -> Text) -> Html)
- )
-
--- | layout with bootstrap
-layoutBootstrap :: Yesod site => YuLayout site
-layoutBootstrap pageContent hd title nav top bottom = [hamlet|
- $newline never
- $doctype 5
- <html>
- <head>
- <title> #{pageTitle pageContent} - #{title}
- <meta charset=utf-8>
- <meta name=viewport content="width=device-width,initial-scale=1.0,maximum-scale=1.0,user-scalable=no">
- #{hd}
- ^{pageHead pageContent}
- <body>
- #{nav}
- <div id="container">
- #{top}
- <div id="main-part">
- ^{pageBody pageContent}
- #{bottom}
- |]
-
-{-|
-The example, or say template for layout
-
-@
-layoutXx pageContent hd title nav top bottom = [hamlet|
- $newline never
- $doctype 5
- \<html>\
- \<head\>
- \<title\> #{pageTitle pageContent} - #{title}
- \<meta charset=utf-8\>
- \<meta name=viewport content="width=device-width,initial-scale=1.0,maximum-scale=1.0,user-scalable=no"\>
- #{hd}
- ^{pageHead pageContent}
- \<body\>
- #{nav}
- #{top}
- ^{pageBody pageContent}
- #{bottom}
- |]
-@
--}
-
--- | the default of yu with Yesod
-yuLayout :: (Hamletic a (HandlerT a IO),Yesod a)
- => YuLayout a -- ^ the layout for yu
- -> WidgetT a IO () -- ^ widget
- -> HandlerT a IO Html -- ^ return
-yuLayout layout w = do
- framePrefix <- getFramePrefix
- title <- getTitle
- pageContent <- widgetToPageContent w
- htmls <- runDbDefault $ do
- topHtml <- fetchMaybeI fetchFrame [framePrefix,"top"]
- bottomHtml <- fetchMaybeI fetchFrame [framePrefix,"bottom"]
- navHtml <- fetchMaybeI fetchFrame [framePrefix,"nav"]
- header <- fetchMaybeI fetchFrame [framePrefix,"header"]
- case (topHtml,bottomHtml,navHtml,header) of
- (Just top, Just bottom, Just nav, Just hd) -> return $ Right (top,bottom,nav,hd)
- _ -> return $ Left "cannot launch frames"
- case htmls of
- Left err -> error err
- Right (top,bottom,nav,hd) -> withUrlRenderer $ layout pageContent hd title nav top bottom
-
-
-
--- | handler the error
-yuErrorHandler :: Yesod site
- => ErrorResponse -- ^ error
- -> HandlerT site IO TypedContent
-yuErrorHandler er = selectRep $ do
- provideJson er
- provideRep $
- defaultLayout [whamlet|
- <h1> error
- <p> #{T.show er}
- |]
-
-
+{-
+ Copyright (C) 2017-2018 Johann Lee <me@qinka.pro>
+
+ This file is part of Yu.
+
+ Yu 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.
+
+ Yu is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+{-|
+Module : Yu.Core.View.Internal
+Description : The internal module for view
+Copyright : (C) 2017-2018 Johann Lee <me@qinka.pro>
+License : GPL3
+Maintainer : me@qinka.pro
+Stability : experimental
+Portability : unknown
+
+The internal party for View, including Hamletic.
+-}
+
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+
+module Yu.Core.View.Internal
+ ( Hamletic(..)
+ , yuLayout
+ , yuErrorHandler
+ -- * layouts
+ , layoutBootstrap
+ ) where
+
+import Yesod.Core
+import Yesod.Core.Handler
+import Yesod.Core.Json
+import Yu.Core.Model
+import Yu.Import.Text (Text)
+import qualified Yu.Import.Text as T
+import Yu.Utils.Handler
+
+-- | Hamtletic
+--
+-- Limit, and test
+class (MonadHandler m, Mongodic a m) => Hamletic a m | m -> a where
+ getTitle :: m Text -- ^ get title
+ getFramePrefix :: m Text -- ^ get the prefix path of frame
+ getVersion :: m Text -- ^ get the version of blog itself or application
+ getRaw :: m Bool -- ^ return raw html
+
+
+-- | layout for layout
+type YuLayout site = ( PageContent (Route site)
+ -> Html -- hd
+ -> Text -- title
+ -> Html -- nav
+ -> Html -- top
+ -> Html -- bottom
+ -> ((Route site -> [(Text, Text)] -> Text) -> Html)
+ )
+
+-- | layout with bootstrap
+layoutBootstrap :: Yesod site => YuLayout site
+layoutBootstrap pageContent hd title nav top bottom = [hamlet|
+ $newline never
+ $doctype 5
+ <html>
+ <head>
+ <title> #{pageTitle pageContent} - #{title}
+ <meta charset=utf-8>
+ <script src=prelude.js>
+ <meta name=viewport content="width=device-width,initial-scale=1.0,maximum-scale=1.0,user-scalable=no">
+ #{hd}
+ ^{pageHead pageContent}
+ <body>
+ #{nav}
+ <div id="container">
+ #{top}
+ <div id="main-part">
+ ^{pageBody pageContent}
+ #{bottom}
+ |]
+
+{-|
+The example, or say template for layout
+
+@
+layoutXx pageContent hd title nav top bottom = [hamlet|
+ $newline never
+ $doctype 5
+ \<html>\
+ \<head\>
+ \<title\> #{pageTitle pageContent} - #{title}
+ \<meta charset=utf-8\>
+ \<meta name=viewport content="width=device-width,initial-scale=1.0,maximum-scale=1.0,user-scalable=no"\>
+ #{hd}
+ ^{pageHead pageContent}
+ \<body\>
+ #{nav}
+ #{top}
+ ^{pageBody pageContent}
+ #{bottom}
+ |]
+@
+-}
+
+-- | the default of yu with Yesod
+yuLayout :: (Hamletic a (HandlerT a IO),Yesod a)
+ => YuLayout a -- ^ the layout for yu
+ -> WidgetT a IO () -- ^ widget
+ -> HandlerT a IO Html -- ^ return
+yuLayout layout w = do
+ framePrefix <- getFramePrefix
+ title <- getTitle
+ pageContent <- widgetToPageContent w
+ htmls <- runDbDefault $ do
+ topHtml <- fetchMaybeI fetchFrame [framePrefix,"top"]
+ bottomHtml <- fetchMaybeI fetchFrame [framePrefix,"bottom"]
+ navHtml <- fetchMaybeI fetchFrame [framePrefix,"nav"]
+ header <- fetchMaybeI fetchFrame [framePrefix,"header"]
+ case (topHtml,bottomHtml,navHtml,header) of
+ (Just top, Just bottom, Just nav, Just hd) -> return $ Right (top,bottom,nav,hd)
+ _ -> return $ Left "cannot launch frames"
+ case htmls of
+ Left err -> error err
+ Right (top,bottom,nav,hd) -> withUrlRenderer $ layout pageContent hd title nav top bottom
+
+
+
+-- | handler the error
+yuErrorHandler :: Yesod site
+ => ErrorResponse -- ^ error
+ -> HandlerT site IO TypedContent
+yuErrorHandler er = selectRep $ do
+ provideJson er
+ provideRep $
+ defaultLayout [whamlet|
+ <h1> error
+ <p> #{T.show er}
+ |]
+
+
diff --git a/src/Yu/Core/View/Query.hs b/src/Yu/Core/View/Query.hs
index aca14e1..73b70b7 100644
--- a/src/Yu/Core/View/Query.hs
+++ b/src/Yu/Core/View/Query.hs
@@ -1,103 +1,122 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-
-{-|
-Module : Yu.Core.View.Query
-Description : The view for query and nav
-Copyright : (C) Qinka 2017
-License : GPLv3+
-Maintainer : me@qinka.pro
-Stability : experimental
-Portability : unknown
-
-The View part for query command, nav query.
--}
-
-
-
-module Yu.Core.View.Query
- ( -- * querys
- -- ** query version
- queryVersion
- , queryVersionAuthor
- , queryVersionUtils
- , queryVersionCore
- , -- ** name
- queryName
- , -- ** build info
- queryBuildInfo
- , -- ** server time
- queryServerTime
- , -- ** navbar
- queryNav
- , -- ** index
- queryIndex
- , -- ** normal query
- queryQuery
- ) where
-
-import Data.Time
-import Yesod.Core
-import Yu.Auth.Info
-import Yu.Core.Info
-import Yu.Core.Model.Internal (Nav, ResT)
-import Yu.Core.View.Internal
-import Yu.Core.View.Query.Parsec
-import Yu.Import
-import Yu.Import.Aeson
-import Yu.Import.Text (Text)
-import qualified Yu.Import.Text as T
-import Yu.Utils.Info
-
--- | version of Blog version
-queryVersion :: Hamletic a (HandlerT a IO)
- => HandlerT a IO TypedContent
-queryVersion = getVersion >>= respondSource "text/plain" . sendChunkText
-
--- | version of yu-core
-queryVersionAuthor :: HandlerT a IO TypedContent
-queryVersionAuthor = respondSource "text/plain" $ sendChunkText $yuAuthVersionQuote
-
--- | version of yu-utils
-queryVersionUtils :: HandlerT a IO TypedContent
-queryVersionUtils = respondSource "text/plain" $ sendChunkText $yuUtilsVersionQuote
-
--- | version of glov-core
-queryVersionCore :: HandlerT a IO TypedContent
-queryVersionCore = respondSource "text/plain" $ sendChunkText $yuCoreVersionQuote
-
--- | name of this
-queryName :: HandlerT a IO TypedContent
-queryName = respondSource "text/plain" $ sendChunkText "Yu"
-
--- | build information
-queryBuildInfo :: HandlerT a IO TypedContent
-queryBuildInfo = respondSource "text/plain" $ sendChunkText $yuBuildInfoQuote
-
--- | server time
-queryServerTime :: HandlerT a IO TypedContent
-queryServerTime = T.show <$> (liftIO getCurrentTime) >>= respondSource "text/plain" . sendChunkText
-
--- | fetch the list for nav
-queryNav :: [Nav] -- ^ navs (from Model)
- -> HandlerT a IO TypedContent
-queryNav = respondSource "application/json" . sendChunkLBS . encode
-
--- | index
-queryIndex :: String -- ^ parameters
- -> [ResT] -- ^ resources index (from Model)
- -> HandlerT a IO TypedContent
-queryIndex t = respondSource "application/json" . sendChunkLBS . encode . (run $ runQp t)
- where run (Left e) = error $ show e
- run (Right i) = i
-
--- | query
-queryQuery :: Text -- ^ query value (from Model)
- -> HandlerT a IO TypedContent
-queryQuery t = respondSource "text/plain" $ do
- sendChunkText t
- sendFlush
-
+{-
+ Copyright (C) 2017-2018 Johann Lee <me@qinka.pro>
+
+ This file is part of Yu.
+
+ Yu 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.
+
+ Yu is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+
+{-|
+Module : Yu.Core.View.Query
+Description : The view for query and nav
+Copyright : (C) 2017-2018 Johann Lee <me@qinka.pro>
+License : GPLv3+
+Maintainer : me@qinka.pro
+Stability : experimental
+Portability : unknown
+
+The View part for query command, nav query.
+-}
+
+
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Yu.Core.View.Query
+ ( -- * querys
+ -- ** query version
+ queryVersion
+ , queryVersionAuthor
+ , queryVersionUtils
+ , queryVersionCore
+ , -- ** name
+ queryName
+ , -- ** build info
+ queryBuildInfo
+ , -- ** server time
+ queryServerTime
+ , -- ** navbar
+ queryNav
+ , -- ** index
+ queryIndex
+ , -- ** normal query
+ queryQuery
+ ) where
+
+import Data.Time
+import Yesod.Core
+import Yu.Auth.Info
+import Yu.Core.Info
+import Yu.Core.Model.Internal (Nav, ResT)
+import Yu.Core.View.Internal
+import Yu.Core.View.Query.Parsec
+import Yu.Import
+import Yu.Import.Aeson
+import Yu.Import.Text (Text)
+import qualified Yu.Import.Text as T
+import Yu.Utils.Info
+
+-- | version of Blog version
+queryVersion :: Hamletic a (HandlerT a IO)
+ => HandlerT a IO TypedContent
+queryVersion = getVersion >>= respondSource "text/plain" . sendChunkText
+
+-- | version of yu-core
+queryVersionAuthor :: HandlerT a IO TypedContent
+queryVersionAuthor = respondSource "text/plain" $ sendChunkText $yuAuthVersionQuote
+
+-- | version of yu-utils
+queryVersionUtils :: HandlerT a IO TypedContent
+queryVersionUtils = respondSource "text/plain" $ sendChunkText $yuUtilsVersionQuote
+
+-- | version of glov-core
+queryVersionCore :: HandlerT a IO TypedContent
+queryVersionCore = respondSource "text/plain" $ sendChunkText $yuCoreVersionQuote
+
+-- | name of this
+queryName :: HandlerT a IO TypedContent
+queryName = respondSource "text/plain" $ sendChunkText "Yu"
+
+-- | build information
+queryBuildInfo :: HandlerT a IO TypedContent
+queryBuildInfo = respondSource "text/plain" $ sendChunkText $yuBuildInfoQuote
+
+-- | server time
+queryServerTime :: HandlerT a IO TypedContent
+queryServerTime = T.show <$> (liftIO getCurrentTime) >>= respondSource "text/plain" . sendChunkText
+
+-- | fetch the list for nav
+queryNav :: [Nav] -- ^ navs (from Model)
+ -> HandlerT a IO TypedContent
+queryNav = respondSource "application/json" . sendChunkLBS . encode
+
+-- | index
+queryIndex :: String -- ^ parameters
+ -> [ResT] -- ^ resources index (from Model)
+ -> HandlerT a IO TypedContent
+queryIndex t = respondSource "application/json" . sendChunkLBS . encode . (run $ runQp t)
+ where run (Left e) = error $ show e
+ run (Right i) = i
+
+-- | query
+queryQuery :: Text -- ^ query value (from Model)
+ -> HandlerT a IO TypedContent
+queryQuery t = respondSource "text/plain" $ do
+ sendChunkText t
+ sendFlush
+
diff --git a/src/Yu/Core/View/Query/Parsec.hs b/src/Yu/Core/View/Query/Parsec.hs
index 3cbd095..9b63031 100644
--- a/src/Yu/Core/View/Query/Parsec.hs
+++ b/src/Yu/Core/View/Query/Parsec.hs
@@ -1,147 +1,167 @@
-{-# LANGUAGE RecordWildCards #-}
-
-{-|
-Module : Yu.Core.View.Query.Parsec
-Description : The parsec for query command
-Copyright : (C) Qinka 2017
-License : GPL v3+
-Maintainer : me@qinka.pro
-Stability : experimental
-Portability : unknown
-
-This module is for the query command, to parsec the query command
--}
-
-module Yu.Core.View.Query.Parsec
- ( -- | parse the query command for query
- --
- -- $query
- runQp
- ) where
-
-import Data.Time
-import Text.Parsec
-import Yu.Core.Model (ResT (..))
-import qualified Yu.Import.Text as T
-
--- $query commands
---
--- The query commands include
--- * type={t,f}={post,text,binary,query,..}
--- * take=SIZE
--- * drop=SIZE
--- * befor=DATE
--- * after=DATE
--- * tag={t,f}=TAG
--- * or
--- * and
--- * true
--- * false
-
-
--- | the ADT for parser
-data QueryParser = QPTake Int -- ^ like @take@
- | QPDrop Int -- ^ like @drop@
- | QPBefor UTCTime Bool -- ^ select those whose dates are earlier than given date
- | QPAfter UTCTime Bool -- ^ select those whose dates are later than given date
- | QPTag Bool String -- ^ select those whose tags include or not include given tag
- | QPType Bool String -- ^ select those whose content's type include or not include
- -- given type
- | QPOr [QueryParser] -- ^ like @or@
- | QPAnd [QueryParser] -- ^ like @and@
- deriving (Show)
-
-
--- | get an empty command
-qpEmpty :: Parsec String () [QueryParser]
-qpEmpty = do
- string ";"
- return []
--- | get the command type
-qpType :: Parsec String () [QueryParser]
-qpType = do
- t <- string "type=" *> oneOf ['t','f'] <* char '='
- typ <- many letter <* char ';'
- return [QPType (t=='t') typ]
--- | get command take
-qpTake :: Parsec String () [QueryParser]
-qpTake = do
- len <- string "take=" *> many (oneOf ['0'..'9']) <* char ';'
- return [QPTake (read len)]
--- | get command drop
-qpDrop :: Parsec String () [QueryParser]
-qpDrop = do
- len <- string "drop=" *> many (oneOf ['0'..'9']) <* char ';'
- return [QPDrop (read len)]
--- | get command befor
-qpBefor :: Parsec String () [QueryParser]
-qpBefor = do
- date <- parseTimeM True defaultTimeLocale "%F+%T" =<<
- (string "befor=" *> many (noneOf "@") <* char '@')
- b <- true <|> false <* char ';'
- return [QPBefor date b]
--- | get true
-true :: Parsec String () Bool
-true = string "true" >> return True
--- | get false
-false :: Parsec String () Bool
-false = string "false" >> return False
--- | get command after
-qpAfter :: Parsec String () [QueryParser]
-qpAfter = do
- date <- parseTimeM True defaultTimeLocale "%F+%T" =<<
- (string "after=" *> many (noneOf "@") <* char '@')
- b <- true <|> false <* char ';'
- return [QPAfter date b]
--- | get command tag
-qpTag :: Parsec String () [QueryParser]
-qpTag = do
- t <- string "tag=" *> oneOf ['t','f'] <* char '='
- tag <- many (noneOf ";") <* char ';'
- return [QPTag (t=='t') tag]
--- | get command and
-qpAnd :: Parsec String () [QueryParser]
-qpAnd = do
- sub <- char '[' *> many qps <* char ']'
- return [QPAnd $ concat sub]
--- | get command or
-qpOr :: Parsec String () [QueryParser]
-qpOr = do
- sub <- char '{' *> many qps <* char '}'
- return [QPOr $ concat sub]
--- | parser for query command
-qp :: Parsec String () [QueryParser]
-qp = concat <$> many qps
--- | single command
-qps :: Parsec String () [QueryParser]
-qps = foldl (<|>) qpEmpty $ try <$>
- [qpTake,qpDrop,qpBefor,qpAfter,qpTag,qpOr,qpAnd
- , qpType
- ]
-
--- | transform to filter
-toFilter :: [QueryParser] -> ([ResT] -> [ResT])
-toFilter [] = id
-toFilter (QPTake i:xs) = take i . toFilter xs
-toFilter (QPDrop i:xs) = drop i . toFilter xs
-toFilter (QPBefor i b:xs) = filter (timeFilter i (>) b) . toFilter xs
-toFilter (QPAfter i b:xs) = filter (timeFilter i (<) b) . toFilter xs
-toFilter (QPTag t i:xs) = filter ((==t) . tagFilter i) . toFilter xs
-toFilter (QPType t i:xs) = filter ((==t) . typFilter i) . toFilter xs
-toFilter (QPOr s:xs) = concat . map sg . toFilter xs
- where funcs = (\y -> toFilter [y]) <$> s
- sg y = take 1 $ concatMap (\f -> f [y]) funcs
-toFilter (QPAnd s:xs) = toFilter s . toFilter xs
-
-typFilter :: String -> ResT -> Bool
-typFilter t ResT{..} = rType == T.pack t
-tagFilter :: String -> ResT -> Bool
-tagFilter t ResT{..} = T.pack t `elem` rTags
-timeFilter :: UTCTime -> (UTCTime -> UTCTime -> Bool) -> Bool -> ResT -> Bool
-timeFilter t o b ResT{..} = t `o` resTime
- where resTime = if b then rCTime else rUTime
-
--- | transform the command to function
-runQp :: String -> Either ParseError ([ResT]->[ResT])
-runQp str = toFilter <$> runP qp () "QueryPaserError" str
-
+{-
+ Copyright (C) 2017-2018 Johann Lee <me@qinka.pro>
+
+ This file is part of Yu.
+
+ Yu 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.
+
+ Yu is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+
+{-|
+Module : Yu.Core.View.Query.Parsec
+Description : The parsec for query command
+Copyright : (C) 2017-2018 Johann Lee
+License : GPL v3+
+Maintainer : me@qinka.pro
+Stability : experimental
+Portability : unknown
+
+This module is for the query command, to parsec the query command
+-}
+
+{-# LANGUAGE RecordWildCards #-}
+
+module Yu.Core.View.Query.Parsec
+ ( -- | parse the query command for query
+ --
+ -- $query
+ runQp
+ ) where
+
+import Data.Time
+import Text.Parsec
+import Yu.Core.Model (ResT (..))
+import qualified Yu.Import.Text as T
+
+-- $query commands
+--
+-- The query commands include
+-- * type={t,f}={post,text,binary,query,..}
+-- * take=SIZE
+-- * drop=SIZE
+-- * befor=DATE
+-- * after=DATE
+-- * tag={t,f}=TAG
+-- * or
+-- * and
+-- * true
+-- * false
+
+
+-- | the ADT for parser
+data QueryParser = QPTake Int -- ^ like @take@
+ | QPDrop Int -- ^ like @drop@
+ | QPBefor UTCTime Bool -- ^ select those whose dates are earlier than given date
+ | QPAfter UTCTime Bool -- ^ select those whose dates are later than given date
+ | QPTag Bool String -- ^ select those whose tags include or not include given tag
+ | QPType Bool String -- ^ select those whose content's type include or not include
+ -- given type
+ | QPOr [QueryParser] -- ^ like @or@
+ | QPAnd [QueryParser] -- ^ like @and@
+ deriving (Show)
+
+
+-- | get an empty command
+qpEmpty :: Parsec String () [QueryParser]
+qpEmpty = do
+ string ";"
+ return []
+-- | get the command type
+qpType :: Parsec String () [QueryParser]
+qpType = do
+ t <- string "type=" *> oneOf ['t','f'] <* char '='
+ typ <- many letter <* char ';'
+ return [QPType (t=='t') typ]
+-- | get command take
+qpTake :: Parsec String () [QueryParser]
+qpTake = do
+ len <- string "take=" *> many (oneOf ['0'..'9']) <* char ';'
+ return [QPTake (read len)]
+-- | get command drop
+qpDrop :: Parsec String () [QueryParser]
+qpDrop = do
+ len <- string "drop=" *> many (oneOf ['0'..'9']) <* char ';'
+ return [QPDrop (read len)]
+-- | get command befor
+qpBefor :: Parsec String () [QueryParser]
+qpBefor = do
+ date <- parseTimeM True defaultTimeLocale "%F+%T" =<<
+ (string "befor=" *> many (noneOf "@") <* char '@')
+ b <- true <|> false <* char ';'
+ return [QPBefor date b]
+-- | get true
+true :: Parsec String () Bool
+true = string "true" >> return True
+-- | get false
+false :: Parsec String () Bool
+false = string "false" >> return False
+-- | get command after
+qpAfter :: Parsec String () [QueryParser]
+qpAfter = do
+ date <- parseTimeM True defaultTimeLocale "%F+%T" =<<
+ (string "after=" *> many (noneOf "@") <* char '@')
+ b <- true <|> false <* char ';'
+ return [QPAfter date b]
+-- | get command tag
+qpTag :: Parsec String () [QueryParser]
+qpTag = do
+ t <- string "tag=" *> oneOf ['t','f'] <* char '='
+ tag <- many (noneOf ";") <* char ';'
+ return [QPTag (t=='t') tag]
+-- | get command and
+qpAnd :: Parsec String () [QueryParser]
+qpAnd = do
+ sub <- char '[' *> many qps <* char ']'
+ return [QPAnd $ concat sub]
+-- | get command or
+qpOr :: Parsec String () [QueryParser]
+qpOr = do
+ sub <- char '{' *> many qps <* char '}'
+ return [QPOr $ concat sub]
+-- | parser for query command
+qp :: Parsec String () [QueryParser]
+qp = concat <$> many qps
+-- | single command
+qps :: Parsec String () [QueryParser]
+qps = foldl (<|>) qpEmpty $ try <$>
+ [qpTake,qpDrop,qpBefor,qpAfter,qpTag,qpOr,qpAnd
+ , qpType
+ ]
+
+-- | transform to filter
+toFilter :: [QueryParser] -> ([ResT] -> [ResT])
+toFilter [] = id
+toFilter (QPTake i:xs) = take i . toFilter xs
+toFilter (QPDrop i:xs) = drop i . toFilter xs
+toFilter (QPBefor i b:xs) = filter (timeFilter i (>) b) . toFilter xs
+toFilter (QPAfter i b:xs) = filter (timeFilter i (<) b) . toFilter xs
+toFilter (QPTag t i:xs) = filter ((==t) . tagFilter i) . toFilter xs
+toFilter (QPType t i:xs) = filter ((==t) . typFilter i) . toFilter xs
+toFilter (QPOr s:xs) = concat . map sg . toFilter xs
+ where funcs = (\y -> toFilter [y]) <$> s
+ sg y = take 1 $ concatMap (\f -> f [y]) funcs
+toFilter (QPAnd s:xs) = toFilter s . toFilter xs
+
+typFilter :: String -> ResT -> Bool
+typFilter t ResT{..} = rType == T.pack t
+tagFilter :: String -> ResT -> Bool
+tagFilter t ResT{..} = T.pack t `elem` rTags
+timeFilter :: UTCTime -> (UTCTime -> UTCTime -> Bool) -> Bool -> ResT -> Bool
+timeFilter t o b ResT{..} = t `o` resTime
+ where resTime = if b then rCTime else rUTime
+
+-- | transform the command to function
+runQp :: String -> Either ParseError ([ResT]->[ResT])
+runQp str = toFilter <$> runP qp () "QueryPaserError" str
+
diff --git a/test-src/Internal.hs b/test-src/Internal.hs
index 153a9e7..582d9d6 100644
--- a/test-src/Internal.hs
+++ b/test-src/Internal.hs
@@ -1,34 +1,53 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Internal
- ( module Database.MongoDB
- , module Control.Exception
- , runDB
- , testDBName
- ) where
-
-
-import Control.Exception
-import Database.MongoDB
-import System.Environment
-import System.IO.Error (catchIOError)
-import qualified Yu.Import.Text as T
-
-
--- | envrionment variable for mongo db url
-mongoHostEnvVar :: String
-mongoHostEnvVar = "MONGODB_URL"
-
--- | test database name
-testDBName :: T.Text
-testDBName = "test"
-
--- | run db action
-runDB :: Action IO a -> IO a
-runDB action = do
- mongodbHost <- getEnv mongoHostEnvVar `catchIOError` (\_ -> return "localhost")
- pipe <- connect (readHostPort mongodbHost)
- result <- access pipe master testDBName action
- close pipe
- return result
-
+{-
+ Copyright (C) 2017-2018 Johann Lee <me@qinka.pro>
+
+ This file is part of Yu.
+
+ Yu 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.
+
+ Yu is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Internal
+ ( module Database.MongoDB
+ , module Control.Exception
+ , runDB
+ , testDBName
+ ) where
+
+
+import Control.Exception
+import Database.MongoDB
+import System.Environment
+import System.IO.Error (catchIOError)
+import qualified Yu.Import.Text as T
+
+
+-- | envrionment variable for mongo db url
+mongoHostEnvVar :: String
+mongoHostEnvVar = "MONGODB_URL"
+
+-- | test database name
+testDBName :: T.Text
+testDBName = "test"
+
+-- | run db action
+runDB :: Action IO a -> IO a
+runDB action = do
+ mongodbHost <- getEnv mongoHostEnvVar `catchIOError` (\_ -> return "localhost")
+ pipe <- connect (readHostPort mongodbHost)
+ result <- access pipe master testDBName action
+ close pipe
+ return result
+
diff --git a/test-src/ModelSpec.hs b/test-src/ModelSpec.hs
index c5d677d..c58ebdb 100644
--- a/test-src/ModelSpec.hs
+++ b/test-src/ModelSpec.hs
@@ -1,549 +1,568 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | The test module for model for glob
-module ModelSpec
- ( spec
- ) where
-
-import Control.Monad
-import Data.IORef
-import qualified Data.Text.Lazy as TL
-import Data.Time (UTCTime, diffUTCTime, getCurrentTime)
-import Internal
-import System.IO
-import Test.Hspec
-import Text.Blaze.Renderer.Text
-import Yu.Core.Model
-import qualified Yu.Import.Text as T
-
--- | step one: get pipe
-getPipe :: IO Pipe
-getPipe = connect $ readHostPort "localhost:27017"
-
-cleanDatabase :: IO ()
-cleanDatabase = void $ runDB $ dropDatabase testDBName
-
-
-spec :: Spec
-spec = do
- runIO $ putStrLn "Test for Model part for Yu"
- describe "Nav and Document" $ do
- let navItem = Nav { navUrl = "url"
- , navLabel = "label"
- , navOrder = 0
- }
- docItem = [ "index" =: ("label" :: String)
- , "url" =: ("url" :: String)
- , "order" =: (0 :: Int)
- ]
- docItem' = [ "labsel" =: ("label" :: String)
- , "ural" =: ("url" :: String)
- , "order" =: (0 :: Int)
- ]
- it "transform nav to doc" $
- navToDoc navItem `shouldMatchList` docItem
- it "transform doc to nav (just)" $
- docToNav docItem `shouldBe` Just navItem
- it "transform doc to nav(nothing)" $
- docToNav docItem' `shouldBe` Nothing
- describe "ResT and Document" $ do
- now <- runIO $ getCurrentTime
- let resItem = ResT { rIndex = ["the","path","to","resource"]
- , rRes = Oid 233 233
- , rType = "type"
- , rCTime = now
- , rUTime = now
- , rTitle = "title"
- , rSummary = Just "summary"
- , rWhose = Just "whose"
- , rMIME = Just "mime"
- , rTags = ["tag","s"]
- }
- docItem = [ "index" =: ["the","path","to","resource" :: String]
- , "res" =: Oid 233 233
- , "type" =: ("type" :: String)
- , "create-time" =: now
- , "update-time" =: now
- , "title" =: ("title" :: String)
- , "summary" =: Just ("summary" :: String)
- , "whose" =: Just ("whose" :: String)
- , "mime" =: Just ("mime" :: String)
- , "tags" =: ["tag","s" :: String]
- ]
- docItem' = [ "inddex" =: ["the","path","to","resource" :: String]
- , "res" =: Oid 233 233
- , "type" =: ("type" :: String)
- , "create-time" =: now
- , "update-time" =: now
- , "title" =: ("title" :: String)
- , "summary" =: Just ("summary" :: String)
- , "whose" =: Just ("whose" :: String)
- , "mime" =: Just ("mime" :: String)
- , "tags" =: ["tag","s" :: String]
- ]
- it "transfrom res to doc" $
- resToDoc resItem `shouldMatchList` docItem
- it "transform doc to res(just)" $
- docToRes docItem `shouldBe` Just resItem
- it "transform doc to res(nothing)" $
- docToRes docItem' `shouldBe` Nothing
- describe "database actions" $ do
- describe "for context" $ beforeAll_ cleanDatabase $ do
- let contextTestCollection = "ctc"
- contextTestField = "ctf"
- contextTestItem = "cti" :: String
- contextTestItemNew = "ctinew" :: String
- contextTestOidBad (Oid a b) = Oid (a-1) (b-1)
- contextTestOid <- runIO $ newIORef Nothing
- it "update a context(new)" $ do
- cto <- readIORef contextTestOid
- oid <- runDB $ updateContext
- contextTestCollection
- cto
- contextTestField
- contextTestItem
- Just doc <- runDB $ findOne (select ["_id" =: oid] contextTestCollection)
- writeIORef contextTestOid $ Just oid
- doc `shouldContain` [ "_id" =: oid
- , contextTestField =: contextTestItem
- ]
- it "update context(again)" $ do
- cto <- readIORef contextTestOid
- print cto
- oid <- runDB $ updateContext
- contextTestCollection
- cto
- contextTestField
- contextTestItemNew
- Just doc <- runDB $ findOne (select ["_id" =: oid] contextTestCollection)
- writeIORef contextTestOid $ Just oid
- doc `shouldContain` [ "_id" =: oid
- , contextTestField =: contextTestItemNew
- ]
- it "fetch context(just)" $ do
- Just cto <- readIORef contextTestOid
- rt <- runDB $ fetchContext
- contextTestField
- ResT {rRes = cto}
- contextTestCollection
- rt `shouldBe` Just contextTestItemNew
- it "fetch context(nothing)" $ do
- Just cto <- readIORef contextTestOid
- rt <- runDB $ fetchContext
- contextTestField
- ResT {rRes = contextTestOidBad cto}
- contextTestCollection
- let shouldBE :: Maybe String -> Maybe String -> IO ()
- shouldBE = shouldBe
- rt `shouldBE` Nothing
- it "delete context" $ do
- Just cto <- readIORef contextTestOid
- runDB $ deleteContext ResT{rRes = cto} contextTestCollection
- rt <- runDB $ rest =<< find (select [] contextTestCollection)
- rt `shouldBe` []
- describe "for res" $ beforeAll_ cleanDatabase $ do
- now <- runIO $ getCurrentTime
- let resItem1 = ResT { rIndex = ["the","path","to","resource","1"]
- , rRes = Oid 233 233
- , rType = "type"
- , rCTime = now
- , rUTime = now
- , rTitle = "title"
- , rSummary = Just "summary"
- , rWhose = Just "whose"
- , rMIME = Just "mime"
- , rTags = ["tag","s"]
- }
- resItem2 = ResT { rIndex = ["the","path","to","resource","2"]
- , rRes = Oid 233 233
- , rType = "type"
- , rCTime = now
- , rUTime = now
- , rTitle = "title"
- , rSummary = Just "summary"
- , rWhose = Just "whose"
- , rMIME = Just "mime"
- , rTags = ["tag","s"]
- }
- docItem1 = [ "index" =: ["the","path","to","resource","1" :: String]
- , "res" =: Oid 233 233
- , "type" =: ("type" :: String)
- , "create-time" =: now
- , "update-time" =: now
- , "title" =: ("title" :: String)
- , "summary" =: Just ("summary" :: String)
- , "whose" =: Just ("whose" :: String)
- , "mime" =: Just ("mime" :: String)
- , "tags" =: ["tag","s" :: String]
- ]
- docItem2 = [ "index" =: ["the","path","to","resource","2" :: String]
- , "res" =: Oid 233 233
- , "type" =: ("type" :: String)
- , "create-time" =: now
- , "update-time" =: now
- , "title" =: ("title" :: String)
- , "summary" =: Just ("summary" :: String)
- , "whose" =: Just ("whose" :: String)
- , "mime" =: Just ("mime" :: String)
- , "tags" =: ["tag","s" :: String]
- ]
- it "update a new resource index" $ do
- runDB $ updateRes resItem1
- rt:_ <- runDB $ rest =<< find (select [] "index")
- docToRes rt `shouldBe` Just resItem1
- it "fetch a resource index" $ do
- rt1 <- runDB $ fetchRes ["the","path","to","resource","1"]
- rt2 <- runDB $ fetchRes ["the","path","to","resource","2"]
- rt1 `shouldBe` Just resItem1
- rt2 `shouldBe` Nothing
- it "fetch all inedxes, when there are indexes in database" $ do
- runDB $ updateRes resItem2
- rt <- runDB $ fetchResAll
- rt `shouldBe` [resItem1,resItem2]
- it "delete a index" $ do
- runDB $ deleteRes resItem1
- rt1:_ <- runDB $ rest =<< find (select [] "index")
- docToRes rt1 `shouldBe` Just resItem2
- runDB $ deleteRes resItem2
- rt2 <- runDB $ rest =<< find (select [] "index")
- rt2 `shouldBe` []
- it "fetch all indexes, when database is empty" $ do
- rt <- runDB $ fetchResAll
- rt `shouldBe` []
- describe "for item" $ beforeAll_ cleanDatabase $ do
- now <- runIO $ getCurrentTime
- let itemTestTypeOld = "itto"
- itemTestType = "itt" :: T.Text
- itemTestIndex = ["i","t","i"]
- itemTestField = "itf"
- itemTestItem = "item" :: T.Text
- resItemOld = ResT { rIndex = itemTestIndex
- , rRes = undefined
- , rType = itemTestTypeOld
- , rCTime = now
- , rUTime = now
- , rTitle = "title"
- , rSummary = Just "summary"
- , rWhose = Just "whose"
- , rMIME = Just "mime"
- , rTags = ["tag","s"]
- }
- resItem = ResT { rIndex = itemTestIndex
- , rRes = undefined
- , rType = itemTestType
- , rCTime = now
- , rUTime = now
- , rTitle = "title"
- , rSummary = Just "summary"
- , rWhose = Just "whose"
- , rMIME = Just "mime"
- , rTags = ["tag","s"]
- }
- docC = [ itemTestField =: itemTestItem ]
- docR = [ "index" =: itemTestIndex
- , "type" =: itemTestType
- , "create-time" =: now
- , "update-time" =: now
- , "title" =: ("title" :: String)
- , "summary" =: Just ("summary" :: String)
- , "whose" =: Just ("whose" :: String)
- , "mime" =: Just ("mime" :: String)
- , "tags" =: ["tag","s" :: String]
- ]
- it "update an old item" $ do
- runDB $ updateItem
- itemTestTypeOld
- itemTestField
- itemTestItem
- resItemOld
- rt1:_ <- runDB $ rest =<< find (select [] itemTestTypeOld)
- rt2:_ <- runDB $ rest =<< find (select [] "index")
- rt1 `shouldContain` docC
- let Just rt2' = docToRes rt2
- rt2' `shouldBe` resItemOld {rRes = rRes rt2'}
- it "update an new item" $ do
- runDB $ updateItem
- itemTestType
- itemTestField
- itemTestItem
- resItem
- rt1:_ <- runDB $ rest =<< find (select [] itemTestType)
- rt3 <- runDB $ rest =<< find (select [] itemTestTypeOld)
- rt2:_ <- runDB $ rest =<< find (select [] "index")
- rt1 `shouldContain` docC
- rt3 `shouldBe` []
- let Just rt2' = docToRes rt2
- rt2' `shouldBe` resItem {rRes = rRes rt2'}
- it "delete the item" $ do
- runDB $ deleteItem itemTestIndex itemTestType
- rt1 <- runDB $ rest =<< find (select [] itemTestType)
- rt2 <- runDB $ rest =<< find (select [] "index")
- rt1 `shouldBe` []
- rt2 `shouldBe` []
- describe "for update/fetch" $ do
- describe "for frame" $ beforeAll_ cleanDatabase $ do
- now <- runIO $ getCurrentTime
- let res = ResT { rIndex = itemIndex
- , rRes = undefined
- , rType = itemType
- , rCTime = now
- , rUTime = now
- , rTitle = "title"
- , rSummary = Just "summary"
- , rWhose = Just "whose"
- , rMIME = Just "mime"
- , rTags = ["tag","s"]
- }
- doc = [ "index" =: itemIndex
- , "type" =: itemType
- , "create-time" =: now
- , "update-time" =: now
- , "title" =: ("title" :: String)
- , "summary" =: Just ("summary" :: String)
- , "whose" =: Just ("whose" :: String)
- , "mime" =: Just ("mime" :: String)
- , "tags" =: ["tag","s" :: String]
- ]
- itemType = "frame"
- itemIndex = ["path","to","item"]
- item = "123"
- itemDoc = ["html" =: item]
- it "update" $ do
- runDB $ updateFrame item res
- rt1:_ <- runDB $ rest =<< find (select [] itemType)
- rt2:_ <- runDB $ rest =<< find (select [] "index")
- rt1 `shouldContain` itemDoc
- let Just rt2' = docToRes rt2
- rt2' `shouldBe` res {rRes = rRes rt2'}
- it "fetch" $ do
- Just r <- runDB $ fetchRes itemIndex
- Just rt <- runDB $ fetchFrame r
- renderMarkup rt `shouldBe` TL.fromStrict item
- describe "for html" $ beforeAll_ cleanDatabase $ do
- now <- runIO $ getCurrentTime
- let res = ResT { rIndex = itemIndex
- , rRes = undefined
- , rType = itemType
- , rCTime = now
- , rUTime = now
- , rTitle = "title"
- , rSummary = Just "summary"
- , rWhose = Just "whose"
- , rMIME = Just "mime"
- , rTags = ["tag","s"]
- }
- doc = [ "index" =: itemIndex
- , "type" =: itemType
- , "create-time" =: now
- , "update-time" =: now
- , "title" =: ("title" :: String)
- , "summary" =: Just ("summary" :: String)
- , "whose" =: Just ("whose" :: String)
- , "mime" =: Just ("mime" :: String)
- , "tags" =: ["tag","s" :: String]
- ]
- itemType = "post"
- itemIndex = ["path","to","item"]
- item = "123"
- itemDoc = ["html" =: item]
- it "update" $ do
- runDB $ updatePost item res
- rt1:_ <- runDB $ rest =<< find (select [] itemType)
- rt2:_ <- runDB $ rest =<< find (select [] "index")
- rt1 `shouldContain` itemDoc
- let Just rt2' = docToRes rt2
- rt2' `shouldBe` res {rRes = rRes rt2'}
- it "fetch" $ do
- Just r <- runDB $ fetchRes itemIndex
- Just rt <- runDB $ fetchPost r
- renderMarkup rt `shouldBe` TL.fromStrict item
- describe "for text" $ beforeAll_ cleanDatabase $ do
- now <- runIO $ getCurrentTime
- let res = ResT { rIndex = itemIndex
- , rRes = undefined
- , rType = itemType
- , rCTime = now
- , rUTime = now
- , rTitle = "title"
- , rSummary = Just "summary"
- , rWhose = Just "whose"
- , rMIME = Just "mime"
- , rTags = ["tag","s"]
- }
- doc = [ "index" =: itemIndex
- , "type" =: itemType
- , "create-time" =: now
- , "update-time" =: now
- , "title" =: ("title" :: String)
- , "summary" =: Just ("summary" :: String)
- , "whose" =: Just ("whose" :: String)
- , "mime" =: Just ("mime" :: String)
- , "tags" =: ["tag","s" :: String]
- ]
- itemType = "resource"
- itemIndex = ["path","to","item"]
- item = "123"
- itemDoc = ["text" =: item]
- it "update" $ do
- runDB $ updateResourceT item res
- rt1:_ <- runDB $ rest =<< find (select [] itemType)
- rt2:_ <- runDB $ rest =<< find (select [] "index")
- rt1 `shouldContain` itemDoc
- let Just rt2' = docToRes rt2
- rt2' `shouldBe` res {rRes = rRes rt2'}
- it "fetch" $ do
- Just r <- runDB $ fetchRes itemIndex
- Just rt <- runDB $ fetchResourceT r
- rt `shouldBe` item
- describe "for binary" $ beforeAll_ cleanDatabase $ do
- now <- runIO $ getCurrentTime
- let res = ResT { rIndex = itemIndex
- , rRes = undefined
- , rType = itemType
- , rCTime = now
- , rUTime = now
- , rTitle = "title"
- , rSummary = Just "summary"
- , rWhose = Just "whose"
- , rMIME = Just "mime"
- , rTags = ["tag","s"]
- }
- doc = [ "index" =: itemIndex
- , "type" =: itemType
- , "create-time" =: now
- , "update-time" =: now
- , "title" =: ("title" :: String)
- , "summary" =: Just ("summary" :: String)
- , "whose" =: Just ("whose" :: String)
- , "mime" =: Just ("mime" :: String)
- , "tags" =: ["tag","s" :: String]
- ]
- itemType = "resource"
- itemIndex = ["path","to","item"]
- item = "123"
- itemDoc = ["binary" =: Binary item]
- it "update" $ do
- runDB $ updateResourceB (Binary item) res
- rt1:_ <- runDB $ rest =<< find (select [] itemType)
- rt2:_ <- runDB $ rest =<< find (select [] "index")
- rt1 `shouldContain` itemDoc
- let Just rt2' = docToRes rt2
- rt2' `shouldBe` res {rRes = rRes rt2'}
- it "fetch" $ do
- Just r <- runDB $ fetchRes itemIndex
- Just rt <- runDB $ fetchResourceB r
- rt `shouldBe` item
- describe "for static" $ beforeAll_ cleanDatabase $ do
- now <- runIO $ getCurrentTime
- let res = ResT { rIndex = itemIndex
- , rRes = undefined
- , rType = itemType
- , rCTime = now
- , rUTime = now
- , rTitle = "title"
- , rSummary = Just "summary"
- , rWhose = Just "whose"
- , rMIME = Just "mime"
- , rTags = ["tag","s"]
- }
- doc = [ "index" =: itemIndex
- , "type" =: itemType
- , "create-time" =: now
- , "update-time" =: now
- , "title" =: ("title" :: String)
- , "summary" =: Just ("summary" :: String)
- , "whose" =: Just ("whose" :: String)
- , "mime" =: Just ("mime" :: String)
- , "tags" =: ["tag","s" :: String]
- ]
- itemType = "static"
- itemIndex = ["path","to","item"]
- item = "123"
- itemDoc = ["url" =: item]
- it "update" $ do
- runDB $ updateStatic item res
- rt1:_ <- runDB $ rest =<< find (select [] itemType)
- rt2:_ <- runDB $ rest =<< find (select [] "index")
- rt1 `shouldContain` itemDoc
- let Just rt2' = docToRes rt2
- rt2' `shouldBe` res {rRes = rRes rt2'}
- it "fetch" $ do
- Just r <- runDB $ fetchRes itemIndex
- Just rt <- runDB $ fetchStatic r
- rt `shouldBe` item
- describe "for query" $ beforeAll_ cleanDatabase $ do
- now <- runIO $ getCurrentTime
- let res = ResT { rIndex = itemIndex
- , rRes = undefined
- , rType = itemType
- , rCTime = now
- , rUTime = now
- , rTitle = "title"
- , rSummary = Just "summary"
- , rWhose = Just "whose"
- , rMIME = Just "mime"
- , rTags = ["tag","s"]
- }
- doc = [ "index" =: itemIndex
- , "type" =: itemType
- , "create-time" =: now
- , "update-time" =: now
- , "title" =: ("title" :: String)
- , "summary" =: Just ("summary" :: String)
- , "whose" =: Just ("whose" :: String)
- , "mime" =: Just ("mime" :: String)
- , "tags" =: ["tag","s" :: String]
- ]
- itemType = "query"
- itemIndex = ["path","to","item"]
- item = "123"
- itemDoc = ["var" =: item]
- it "update" $ do
- runDB $ updateQuery item res
- rt1:_ <- runDB $ rest =<< find (select [] itemType)
- rt2:_ <- runDB $ rest =<< find (select [] "index")
- rt1 `shouldContain` itemDoc
- let Just rt2' = docToRes rt2
- rt2' `shouldBe` res {rRes = rRes rt2'}
- it "fetch" $ do
- Just r <- runDB $ fetchRes itemIndex
- Just rt <- runDB $ fetchQuery r
- rt `shouldBe` item
- describe "for navigate bar" $ beforeAll_ cleanDatabase $ do
- let label = "label"
- url = "url"
- order = 0
- nav = Nav { navLabel = label
- , navUrl = url
- , navOrder = order
- }
- doc = [ "index" =: label
- , url =: url
- , "order" =: order
- ]
- it "update/add one" $ do
- runDB $ updateNav (Just label) (Just url) (Just order)
- rt:_ <- runDB $ rest =<< find (select [] "nav")
- rt `shouldContain` doc
- it "fetch" $ do
- rt:_ <- runDB $ fetchNav
- rt `shouldBe` nav
- it "delete one" $ do
- runDB $ updateNav (Just label) (Just url) (Just order)
- runDB $ updateNav (Just "345") (Just url) (Just order)
- runDB $ updateNav (Just "123") (Just url) (Just order)
- runDB $ deleteNav $ Just "123"
- rt <- runDB $ fetchNav
- length rt `shouldBe` 3
- it "delete all" $ do
- runDB $ deleteNav Nothing
- rt <- runDB $ fetchNav
- rt `shouldBe` []
-
-
-
-
-
-
-
+{-
+ Copyright (C) 2017-2018 Johann Lee <me@qinka.pro>
+
+ This file is part of Yu.
+
+ Yu 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.
+
+ Yu is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | The test module for model for glob
+module ModelSpec
+ ( spec
+ ) where
+
+import Control.Monad
+import Data.IORef
+import qualified Data.Text.Lazy as TL
+import Data.Time (UTCTime, diffUTCTime, getCurrentTime)
+import Internal
+import System.IO
+import Test.Hspec
+import Text.Blaze.Renderer.Text
+import Yu.Core.Model
+import qualified Yu.Import.Text as T
+
+-- | step one: get pipe
+getPipe :: IO Pipe
+getPipe = connect $ readHostPort "localhost:27017"
+
+cleanDatabase :: IO ()
+cleanDatabase = void $ runDB $ dropDatabase testDBName
+
+
+spec :: Spec
+spec = do
+ runIO $ putStrLn "Test for Model part for Yu"
+ describe "Nav and Document" $ do
+ let navItem = Nav { navUrl = "url"
+ , navLabel = "label"
+ , navOrder = 0
+ }
+ docItem = [ "index" =: ("label" :: String)
+ , "url" =: ("url" :: String)
+ , "order" =: (0 :: Int)
+ ]
+ docItem' = [ "labsel" =: ("label" :: String)
+ , "ural" =: ("url" :: String)
+ , "order" =: (0 :: Int)
+ ]
+ it "transform nav to doc" $
+ navToDoc navItem `shouldMatchList` docItem
+ it "transform doc to nav (just)" $
+ docToNav docItem `shouldBe` Just navItem
+ it "transform doc to nav(nothing)" $
+ docToNav docItem' `shouldBe` Nothing
+ describe "ResT and Document" $ do
+ now <- runIO $ getCurrentTime
+ let resItem = ResT { rIndex = ["the","path","to","resource"]
+ , rRes = Oid 233 233
+ , rType = "type"
+ , rCTime = now
+ , rUTime = now
+ , rTitle = "title"
+ , rSummary = Just "summary"
+ , rWhose = Just "whose"
+ , rMIME = Just "mime"
+ , rTags = ["tag","s"]
+ }
+ docItem = [ "index" =: ["the","path","to","resource" :: String]
+ , "res" =: Oid 233 233
+ , "type" =: ("type" :: String)
+ , "create-time" =: now
+ , "update-time" =: now
+ , "title" =: ("title" :: String)
+ , "summary" =: Just ("summary" :: String)
+ , "whose" =: Just ("whose" :: String)
+ , "mime" =: Just ("mime" :: String)
+ , "tags" =: ["tag","s" :: String]
+ ]
+ docItem' = [ "inddex" =: ["the","path","to","resource" :: String]
+ , "res" =: Oid 233 233
+ , "type" =: ("type" :: String)
+ , "create-time" =: now
+ , "update-time" =: now
+ , "title" =: ("title" :: String)
+ , "summary" =: Just ("summary" :: String)
+ , "whose" =: Just ("whose" :: String)
+ , "mime" =: Just ("mime" :: String)
+ , "tags" =: ["tag","s" :: String]
+ ]
+ it "transfrom res to doc" $
+ resToDoc resItem `shouldMatchList` docItem
+ it "transform doc to res(just)" $
+ docToRes docItem `shouldBe` Just resItem
+ it "transform doc to res(nothing)" $
+ docToRes docItem' `shouldBe` Nothing
+ describe "database actions" $ do
+ describe "for context" $ beforeAll_ cleanDatabase $ do
+ let contextTestCollection = "ctc"
+ contextTestField = "ctf"
+ contextTestItem = "cti" :: String
+ contextTestItemNew = "ctinew" :: String
+ contextTestOidBad (Oid a b) = Oid (a-1) (b-1)
+ contextTestOid <- runIO $ newIORef Nothing
+ it "update a context(new)" $ do
+ cto <- readIORef contextTestOid
+ oid <- runDB $ updateContext
+ contextTestCollection
+ cto
+ contextTestField
+ contextTestItem
+ Just doc <- runDB $ findOne (select ["_id" =: oid] contextTestCollection)
+ writeIORef contextTestOid $ Just oid
+ doc `shouldContain` [ "_id" =: oid
+ , contextTestField =: contextTestItem
+ ]
+ it "update context(again)" $ do
+ cto <- readIORef contextTestOid
+ print cto
+ oid <- runDB $ updateContext
+ contextTestCollection
+ cto
+ contextTestField
+ contextTestItemNew
+ Just doc <- runDB $ findOne (select ["_id" =: oid] contextTestCollection)
+ writeIORef contextTestOid $ Just oid
+ doc `shouldContain` [ "_id" =: oid
+ , contextTestField =: contextTestItemNew
+ ]
+ it "fetch context(just)" $ do
+ Just cto <- readIORef contextTestOid
+ rt <- runDB $ fetchContext
+ contextTestField
+ ResT {rRes = cto}
+ contextTestCollection
+ rt `shouldBe` Just contextTestItemNew
+ it "fetch context(nothing)" $ do
+ Just cto <- readIORef contextTestOid
+ rt <- runDB $ fetchContext
+ contextTestField
+ ResT {rRes = contextTestOidBad cto}
+ contextTestCollection
+ let shouldBE :: Maybe String -> Maybe String -> IO ()
+ shouldBE = shouldBe
+ rt `shouldBE` Nothing
+ it "delete context" $ do
+ Just cto <- readIORef contextTestOid
+ runDB $ deleteContext ResT{rRes = cto} contextTestCollection
+ rt <- runDB $ rest =<< find (select [] contextTestCollection)
+ rt `shouldBe` []
+ describe "for res" $ beforeAll_ cleanDatabase $ do
+ now <- runIO $ getCurrentTime
+ let resItem1 = ResT { rIndex = ["the","path","to","resource","1"]
+ , rRes = Oid 233 233
+ , rType = "type"
+ , rCTime = now
+ , rUTime = now
+ , rTitle = "title"
+ , rSummary = Just "summary"
+ , rWhose = Just "whose"
+ , rMIME = Just "mime"
+ , rTags = ["tag","s"]
+ }
+ resItem2 = ResT { rIndex = ["the","path","to","resource","2"]
+ , rRes = Oid 233 233
+ , rType = "type"
+ , rCTime = now
+ , rUTime = now
+ , rTitle = "title"
+ , rSummary = Just "summary"
+ , rWhose = Just "whose"
+ , rMIME = Just "mime"
+ , rTags = ["tag","s"]
+ }
+ docItem1 = [ "index" =: ["the","path","to","resource","1" :: String]
+ , "res" =: Oid 233 233
+ , "type" =: ("type" :: String)
+ , "create-time" =: now
+ , "update-time" =: now
+ , "title" =: ("title" :: String)
+ , "summary" =: Just ("summary" :: String)
+ , "whose" =: Just ("whose" :: String)
+ , "mime" =: Just ("mime" :: String)
+ , "tags" =: ["tag","s" :: String]
+ ]
+ docItem2 = [ "index" =: ["the","path","to","resource","2" :: String]
+ , "res" =: Oid 233 233
+ , "type" =: ("type" :: String)
+ , "create-time" =: now
+ , "update-time" =: now
+ , "title" =: ("title" :: String)
+ , "summary" =: Just ("summary" :: String)
+ , "whose" =: Just ("whose" :: String)
+ , "mime" =: Just ("mime" :: String)
+ , "tags" =: ["tag","s" :: String]
+ ]
+ it "update a new resource index" $ do
+ runDB $ updateRes resItem1
+ rt:_ <- runDB $ rest =<< find (select [] "index")
+ docToRes rt `shouldBe` Just resItem1
+ it "fetch a resource index" $ do
+ rt1 <- runDB $ fetchRes ["the","path","to","resource","1"]
+ rt2 <- runDB $ fetchRes ["the","path","to","resource","2"]
+ rt1 `shouldBe` Just resItem1
+ rt2 `shouldBe` Nothing
+ it "fetch all inedxes, when there are indexes in database" $ do
+ runDB $ updateRes resItem2
+ rt <- runDB $ fetchResAll
+ rt `shouldBe` [resItem1,resItem2]
+ it "delete a index" $ do
+ runDB $ deleteRes resItem1
+ rt1:_ <- runDB $ rest =<< find (select [] "index")
+ docToRes rt1 `shouldBe` Just resItem2
+ runDB $ deleteRes resItem2
+ rt2 <- runDB $ rest =<< find (select [] "index")
+ rt2 `shouldBe` []
+ it "fetch all indexes, when database is empty" $ do
+ rt <- runDB $ fetchResAll
+ rt `shouldBe` []
+ describe "for item" $ beforeAll_ cleanDatabase $ do
+ now <- runIO $ getCurrentTime
+ let itemTestTypeOld = "itto"
+ itemTestType = "itt" :: T.Text
+ itemTestIndex = ["i","t","i"]
+ itemTestField = "itf"
+ itemTestItem = "item" :: T.Text
+ resItemOld = ResT { rIndex = itemTestIndex
+ , rRes = undefined
+ , rType = itemTestTypeOld
+ , rCTime = now
+ , rUTime = now
+ , rTitle = "title"
+ , rSummary = Just "summary"
+ , rWhose = Just "whose"
+ , rMIME = Just "mime"
+ , rTags = ["tag","s"]
+ }
+ resItem = ResT { rIndex = itemTestIndex
+ , rRes = undefined
+ , rType = itemTestType
+ , rCTime = now
+ , rUTime = now
+ , rTitle = "title"
+ , rSummary = Just "summary"
+ , rWhose = Just "whose"
+ , rMIME = Just "mime"
+ , rTags = ["tag","s"]
+ }
+ docC = [ itemTestField =: itemTestItem ]
+ docR = [ "index" =: itemTestIndex
+ , "type" =: itemTestType
+ , "create-time" =: now
+ , "update-time" =: now
+ , "title" =: ("title" :: String)
+ , "summary" =: Just ("summary" :: String)
+ , "whose" =: Just ("whose" :: String)
+ , "mime" =: Just ("mime" :: String)
+ , "tags" =: ["tag","s" :: String]
+ ]
+ it "update an old item" $ do
+ runDB $ updateItem
+ itemTestTypeOld
+ itemTestField
+ itemTestItem
+ resItemOld
+ rt1:_ <- runDB $ rest =<< find (select [] itemTestTypeOld)
+ rt2:_ <- runDB $ rest =<< find (select [] "index")
+ rt1 `shouldContain` docC
+ let Just rt2' = docToRes rt2
+ rt2' `shouldBe` resItemOld {rRes = rRes rt2'}
+ it "update an new item" $ do
+ runDB $ updateItem
+ itemTestType
+ itemTestField
+ itemTestItem
+ resItem
+ rt1:_ <- runDB $ rest =<< find (select [] itemTestType)
+ rt3 <- runDB $ rest =<< find (select [] itemTestTypeOld)
+ rt2:_ <- runDB $ rest =<< find (select [] "index")
+ rt1 `shouldContain` docC
+ rt3 `shouldBe` []
+ let Just rt2' = docToRes rt2
+ rt2' `shouldBe` resItem {rRes = rRes rt2'}
+ it "delete the item" $ do
+ runDB $ deleteItem itemTestIndex itemTestType
+ rt1 <- runDB $ rest =<< find (select [] itemTestType)
+ rt2 <- runDB $ rest =<< find (select [] "index")
+ rt1 `shouldBe` []
+ rt2 `shouldBe` []
+ describe "for update/fetch" $ do
+ describe "for frame" $ beforeAll_ cleanDatabase $ do
+ now <- runIO $ getCurrentTime
+ let res = ResT { rIndex = itemIndex
+ , rRes = undefined
+ , rType = itemType
+ , rCTime = now
+ , rUTime = now
+ , rTitle = "title"
+ , rSummary = Just "summary"
+ , rWhose = Just "whose"
+ , rMIME = Just "mime"
+ , rTags = ["tag","s"]
+ }
+ doc = [ "index" =: itemIndex
+ , "type" =: itemType
+ , "create-time" =: now
+ , "update-time" =: now
+ , "title" =: ("title" :: String)
+ , "summary" =: Just ("summary" :: String)
+ , "whose" =: Just ("whose" :: String)
+ , "mime" =: Just ("mime" :: String)
+ , "tags" =: ["tag","s" :: String]
+ ]
+ itemType = "frame"
+ itemIndex = ["path","to","item"]
+ item = "123"
+ itemDoc = ["html" =: item]
+ it "update" $ do
+ runDB $ updateFrame item res
+ rt1:_ <- runDB $ rest =<< find (select [] itemType)
+ rt2:_ <- runDB $ rest =<< find (select [] "index")
+ rt1 `shouldContain` itemDoc
+ let Just rt2' = docToRes rt2
+ rt2' `shouldBe` res {rRes = rRes rt2'}
+ it "fetch" $ do
+ Just r <- runDB $ fetchRes itemIndex
+ Just rt <- runDB $ fetchFrame r
+ renderMarkup rt `shouldBe` TL.fromStrict item
+ describe "for html" $ beforeAll_ cleanDatabase $ do
+ now <- runIO $ getCurrentTime
+ let res = ResT { rIndex = itemIndex
+ , rRes = undefined
+ , rType = itemType
+ , rCTime = now
+ , rUTime = now
+ , rTitle = "title"
+ , rSummary = Just "summary"
+ , rWhose = Just "whose"
+ , rMIME = Just "mime"
+ , rTags = ["tag","s"]
+ }
+ doc = [ "index" =: itemIndex
+ , "type" =: itemType
+ , "create-time" =: now
+ , "update-time" =: now
+ , "title" =: ("title" :: String)
+ , "summary" =: Just ("summary" :: String)
+ , "whose" =: Just ("whose" :: String)
+ , "mime" =: Just ("mime" :: String)
+ , "tags" =: ["tag","s" :: String]
+ ]
+ itemType = "post"
+ itemIndex = ["path","to","item"]
+ item = "123"
+ itemDoc = ["html" =: item]
+ it "update" $ do
+ runDB $ updatePost item res
+ rt1:_ <- runDB $ rest =<< find (select [] itemType)
+ rt2:_ <- runDB $ rest =<< find (select [] "index")
+ rt1 `shouldContain` itemDoc
+ let Just rt2' = docToRes rt2
+ rt2' `shouldBe` res {rRes = rRes rt2'}
+ it "fetch" $ do
+ Just r <- runDB $ fetchRes itemIndex
+ Just rt <- runDB $ fetchPost r
+ renderMarkup rt `shouldBe` TL.fromStrict item
+ describe "for text" $ beforeAll_ cleanDatabase $ do
+ now <- runIO $ getCurrentTime
+ let res = ResT { rIndex = itemIndex
+ , rRes = undefined
+ , rType = itemType
+ , rCTime = now
+ , rUTime = now
+ , rTitle = "title"
+ , rSummary = Just "summary"
+ , rWhose = Just "whose"
+ , rMIME = Just "mime"
+ , rTags = ["tag","s"]
+ }
+ doc = [ "index" =: itemIndex
+ , "type" =: itemType
+ , "create-time" =: now
+ , "update-time" =: now
+ , "title" =: ("title" :: String)
+ , "summary" =: Just ("summary" :: String)
+ , "whose" =: Just ("whose" :: String)
+ , "mime" =: Just ("mime" :: String)
+ , "tags" =: ["tag","s" :: String]
+ ]
+ itemType = "resource"
+ itemIndex = ["path","to","item"]
+ item = "123"
+ itemDoc = ["text" =: item]
+ it "update" $ do
+ runDB $ updateResourceT item res
+ rt1:_ <- runDB $ rest =<< find (select [] itemType)
+ rt2:_ <- runDB $ rest =<< find (select [] "index")
+ rt1 `shouldContain` itemDoc
+ let Just rt2' = docToRes rt2
+ rt2' `shouldBe` res {rRes = rRes rt2'}
+ it "fetch" $ do
+ Just r <- runDB $ fetchRes itemIndex
+ Just rt <- runDB $ fetchResourceT r
+ rt `shouldBe` item
+ describe "for binary" $ beforeAll_ cleanDatabase $ do
+ now <- runIO $ getCurrentTime
+ let res = ResT { rIndex = itemIndex
+ , rRes = undefined
+ , rType = itemType
+ , rCTime = now
+ , rUTime = now
+ , rTitle = "title"
+ , rSummary = Just "summary"
+ , rWhose = Just "whose"
+ , rMIME = Just "mime"
+ , rTags = ["tag","s"]
+ }
+ doc = [ "index" =: itemIndex
+ , "type" =: itemType
+ , "create-time" =: now
+ , "update-time" =: now
+ , "title" =: ("title" :: String)
+ , "summary" =: Just ("summary" :: String)
+ , "whose" =: Just ("whose" :: String)
+ , "mime" =: Just ("mime" :: String)
+ , "tags" =: ["tag","s" :: String]
+ ]
+ itemType = "resource"
+ itemIndex = ["path","to","item"]
+ item = "123"
+ itemDoc = ["binary" =: Binary item]
+ it "update" $ do
+ runDB $ updateResourceB (Binary item) res
+ rt1:_ <- runDB $ rest =<< find (select [] itemType)
+ rt2:_ <- runDB $ rest =<< find (select [] "index")
+ rt1 `shouldContain` itemDoc
+ let Just rt2' = docToRes rt2
+ rt2' `shouldBe` res {rRes = rRes rt2'}
+ it "fetch" $ do
+ Just r <- runDB $ fetchRes itemIndex
+ Just rt <- runDB $ fetchResourceB r
+ rt `shouldBe` item
+ describe "for static" $ beforeAll_ cleanDatabase $ do
+ now <- runIO $ getCurrentTime
+ let res = ResT { rIndex = itemIndex
+ , rRes = undefined
+ , rType = itemType
+ , rCTime = now
+ , rUTime = now
+ , rTitle = "title"
+ , rSummary = Just "summary"
+ , rWhose = Just "whose"
+ , rMIME = Just "mime"
+ , rTags = ["tag","s"]
+ }
+ doc = [ "index" =: itemIndex
+ , "type" =: itemType
+ , "create-time" =: now
+ , "update-time" =: now
+ , "title" =: ("title" :: String)
+ , "summary" =: Just ("summary" :: String)
+ , "whose" =: Just ("whose" :: String)
+ , "mime" =: Just ("mime" :: String)
+ , "tags" =: ["tag","s" :: String]
+ ]
+ itemType = "static"
+ itemIndex = ["path","to","item"]
+ item = "123"
+ itemDoc = ["url" =: item]
+ it "update" $ do
+ runDB $ updateStatic item res
+ rt1:_ <- runDB $ rest =<< find (select [] itemType)
+ rt2:_ <- runDB $ rest =<< find (select [] "index")
+ rt1 `shouldContain` itemDoc
+ let Just rt2' = docToRes rt2
+ rt2' `shouldBe` res {rRes = rRes rt2'}
+ it "fetch" $ do
+ Just r <- runDB $ fetchRes itemIndex
+ Just rt <- runDB $ fetchStatic r
+ rt `shouldBe` item
+ describe "for query" $ beforeAll_ cleanDatabase $ do
+ now <- runIO $ getCurrentTime
+ let res = ResT { rIndex = itemIndex
+ , rRes = undefined
+ , rType = itemType
+ , rCTime = now
+ , rUTime = now
+ , rTitle = "title"
+ , rSummary = Just "summary"
+ , rWhose = Just "whose"
+ , rMIME = Just "mime"
+ , rTags = ["tag","s"]
+ }
+ doc = [ "index" =: itemIndex
+ , "type" =: itemType
+ , "create-time" =: now
+ , "update-time" =: now
+ , "title" =: ("title" :: String)
+ , "summary" =: Just ("summary" :: String)
+ , "whose" =: Just ("whose" :: String)
+ , "mime" =: Just ("mime" :: String)
+ , "tags" =: ["tag","s" :: String]
+ ]
+ itemType = "query"
+ itemIndex = ["path","to","item"]
+ item = "123"
+ itemDoc = ["var" =: item]
+ it "update" $ do
+ runDB $ updateQuery item res
+ rt1:_ <- runDB $ rest =<< find (select [] itemType)
+ rt2:_ <- runDB $ rest =<< find (select [] "index")
+ rt1 `shouldContain` itemDoc
+ let Just rt2' = docToRes rt2
+ rt2' `shouldBe` res {rRes = rRes rt2'}
+ it "fetch" $ do
+ Just r <- runDB $ fetchRes itemIndex
+ Just rt <- runDB $ fetchQuery r
+ rt `shouldBe` item
+ describe "for navigate bar" $ beforeAll_ cleanDatabase $ do
+ let label = "label"
+ url = "url"
+ order = 0
+ nav = Nav { navLabel = label
+ , navUrl = url
+ , navOrder = order
+ }
+ doc = [ "index" =: label
+ , url =: url
+ , "order" =: order
+ ]
+ it "update/add one" $ do
+ runDB $ updateNav (Just label) (Just url) (Just order)
+ rt:_ <- runDB $ rest =<< find (select [] "nav")
+ rt `shouldContain` doc
+ it "fetch" $ do
+ rt:_ <- runDB $ fetchNav
+ rt `shouldBe` nav
+ it "delete one" $ do
+ runDB $ updateNav (Just label) (Just url) (Just order)
+ runDB $ updateNav (Just "345") (Just url) (Just order)
+ runDB $ updateNav (Just "123") (Just url) (Just order)
+ runDB $ deleteNav $ Just "123"
+ rt <- runDB $ fetchNav
+ length rt `shouldBe` 3
+ it "delete all" $ do
+ runDB $ deleteNav Nothing
+ rt <- runDB $ fetchNav
+ rt `shouldBe` []
+
+
+
+
+
+
+
diff --git a/test-src/Spec.hs b/test-src/Spec.hs
index a824f8c..05fee03 100644
--- a/test-src/Spec.hs
+++ b/test-src/Spec.hs
@@ -1 +1,19 @@
-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+{-
+ Copyright (C) 2017-2018 Johann Lee <me@qinka.pro>
+ This file is part of Yu.
+
+ Yu 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.
+
+ Yu is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Yu. If not, see <http://www.gnu.org/licenses/>.
+-}
+
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
diff --git a/yu-core.cabal b/yu-core.cabal
index 15f28a2..a4caa2b 100644
--- a/yu-core.cabal
+++ b/yu-core.cabal
@@ -1,63 +1,64 @@
--- Initial yu-core.cabal generated by cabal init. For further
--- documentation, see http://haskell.org/cabal/users-guide/
-
-name: yu-core
-version: 0.1.0.0
-synopsis: The core of Yu.
-description: The core module for Yu.
-homepage: https://github.com/Qinka/Yu
-license: GPL-3
-license-file: LICENSE
-author: Johann Lee
-maintainer: qinka@live.com
-copyright: Copyright (C) 2017 Johann Lee
-category: Web
-build-type: Simple
-extra-source-files: ChangeLog.md
-cabal-version: >= 1.10
-
-library
- exposed-modules: Yu.Core.Model.Internal
- Yu.Core.Model.TH
- Yu.Core.Model
- Yu.Core.View.Internal
- Yu.Core.View.Query.Parsec
- Yu.Core.View.Query
- Yu.Core.View
- Yu.Core.Info
- Yu.Core.Control
- Yu.Core.Control.Internal
- other-modules: Paths_yu_core
- build-depends: base >= 4 && < 5
- , yu-utils == 0.1.0.*
- , yu-auth == 0.1.0.*
- hs-source-dirs: src
- default-language: Haskell2010
- other-extensions: FlexibleContexts
- FunctionalDependencies
- MultiParamTypeClasses
- OverloadedStrings
- QuasiQuotes
- RecordWildCards
- TemplateHaskell
- TypeFamilies
-
-test-suite test-mvc
- type: exitcode-stdio-1.0
- main-is: Spec.hs
- hs-source-dirs: test-src
- build-depends: base >= 4 && < 5
- , hspec
- , yu-utils
- , yu-core
- , blaze-markup
- other-modules: ModelSpec
- Internal
- default-language: Haskell2010
- ghc-options: -Wno-missing-fields
-
-source-repository head
- type: git
- location: https://github.com/Qinka/Yu.git
- subdir: yu-core
+-- Initial yu-core.cabal generated by cabal init. For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name: yu-core
+version: 0.1.1.2
+synopsis: The core of Yu.
+description: The core module for Yu.
+homepage: https://github.com/Qinka/Yu
+license: GPL-3
+license-file: LICENSE
+author: Johann Lee
+maintainer: qinka@live.com
+copyright: Copyright (C) 2017-2018 Johann Lee <me@qinka.pro>
+category: Web
+build-type: Simple
+extra-source-files: ChangeLog.md
+cabal-version: >= 1.10
+
+library
+ exposed-modules: Yu.Core.Model.Internal
+ Yu.Core.Model.TH
+ Yu.Core.Model
+ Yu.Core.View.Internal
+ Yu.Core.View.Query.Parsec
+ Yu.Core.View.Query
+ Yu.Core.View
+ Yu.Core.Info
+ Yu.Core.Route
+ Yu.Core.Control
+ Yu.Core.Control.Internal
+ other-modules: Paths_yu_core
+ build-depends: base >= 4 && < 5
+ , yu-utils == 0.1.1.*
+ , yu-auth == 0.1.1.*
+ hs-source-dirs: src
+ default-language: Haskell2010
+ other-extensions: FlexibleContexts
+ FunctionalDependencies
+ MultiParamTypeClasses
+ OverloadedStrings
+ QuasiQuotes
+ RecordWildCards
+ TemplateHaskell
+ TypeFamilies
+
+test-suite test-mvc
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ hs-source-dirs: test-src
+ build-depends: base >= 4 && < 5
+ , hspec
+ , yu-utils
+ , yu-core
+ , blaze-markup
+ other-modules: ModelSpec
+ Internal
+ default-language: Haskell2010
+ ghc-options: -Wno-missing-fields
+
+source-repository head
+ type: git
+ location: https://github.com/Qinka/Yu.git
+ subdir: yu-core
branch: 0.1/dev/master \ No newline at end of file