summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorqinka <>2017-12-01 08:07:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-12-01 08:07:00 (GMT)
commitf49575b16f681bea40f220825b8a4b8c5cd72220 (patch)
tree415a0f697ecef775ff33849388ee1ae0f5184052
version 0.1.0.00.1.0.0
-rw-r--r--ChangeLog.md5
-rw-r--r--LICENSE674
-rw-r--r--Setup.hs2
-rw-r--r--src/Yu/Core/Control.hs220
-rw-r--r--src/Yu/Core/Control/Internal.hs102
-rw-r--r--src/Yu/Core/Info.hs66
-rw-r--r--src/Yu/Core/Model.hs155
-rw-r--r--src/Yu/Core/Model/Internal.hs284
-rw-r--r--src/Yu/Core/Model/TH.hs80
-rw-r--r--src/Yu/Core/View.hs118
-rw-r--r--src/Yu/Core/View/Internal.hs135
-rw-r--r--src/Yu/Core/View/Query.hs103
-rw-r--r--src/Yu/Core/View/Query/Parsec.hs147
-rw-r--r--test-src/Internal.hs34
-rw-r--r--test-src/ModelSpec.hs549
-rw-r--r--test-src/Spec.hs1
-rw-r--r--yu-core.cabal63
17 files changed, 2738 insertions, 0 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
index 0000000..1fa4234
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,5 @@
+# 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
new file mode 100644
index 0000000..45644ff
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,674 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users. We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors. You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights. Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received. You must make sure that they, too, receive
+or can get the source code. And you must show them these terms so they
+know their rights.
+
+ Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+ For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software. For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+ Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so. This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software. The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable. Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products. If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+ Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary. To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Use with the GNU Affero General Public License.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+ <program> Copyright (C) <year> <name of author>
+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+<http://www.gnu.org/licenses/>.
+
+ The GNU General Public License does not permit incorporating your program
+into proprietary programs. If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License. But first, please read
+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/src/Yu/Core/Control.hs b/src/Yu/Core/Control.hs
new file mode 100644
index 0000000..360caab
--- /dev/null
+++ b/src/Yu/Core/Control.hs
@@ -0,0 +1,220 @@
+{-# 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
+
diff --git a/src/Yu/Core/Control/Internal.hs b/src/Yu/Core/Control/Internal.hs
new file mode 100644
index 0000000..181776a
--- /dev/null
+++ b/src/Yu/Core/Control/Internal.hs
@@ -0,0 +1,102 @@
+{-# 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"
diff --git a/src/Yu/Core/Info.hs b/src/Yu/Core/Info.hs
new file mode 100644
index 0000000..c60cbf7
--- /dev/null
+++ b/src/Yu/Core/Info.hs
@@ -0,0 +1,66 @@
+{-# 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
+-- @
diff --git a/src/Yu/Core/Model.hs b/src/Yu/Core/Model.hs
new file mode 100644
index 0000000..b0f1cfc
--- /dev/null
+++ b/src/Yu/Core/Model.hs
@@ -0,0 +1,155 @@
+{-# 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
+
diff --git a/src/Yu/Core/Model/Internal.hs b/src/Yu/Core/Model/Internal.hs
new file mode 100644
index 0000000..fe92521
--- /dev/null
+++ b/src/Yu/Core/Model/Internal.hs
@@ -0,0 +1,284 @@
+{-|
+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 =:)) =<<)
diff --git a/src/Yu/Core/Model/TH.hs b/src/Yu/Core/Model/TH.hs
new file mode 100644
index 0000000..d5e8c6e
--- /dev/null
+++ b/src/Yu/Core/Model/TH.hs
@@ -0,0 +1,80 @@
+{-|
+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]
diff --git a/src/Yu/Core/View.hs b/src/Yu/Core/View.hs
new file mode 100644
index 0000000..f404dc7
--- /dev/null
+++ b/src/Yu/Core/View.hs
@@ -0,0 +1,118 @@
+{-# 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
diff --git a/src/Yu/Core/View/Internal.hs b/src/Yu/Core/View/Internal.hs
new file mode 100644
index 0000000..9f4ec5e
--- /dev/null
+++ b/src/Yu/Core/View/Internal.hs
@@ -0,0 +1,135 @@
+{-# 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}
+ |]
+
+
diff --git a/src/Yu/Core/View/Query.hs b/src/Yu/Core/View/Query.hs
new file mode 100644
index 0000000..aca14e1
--- /dev/null
+++ b/src/Yu/Core/View/Query.hs
@@ -0,0 +1,103 @@
+{-# 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
+
diff --git a/src/Yu/Core/View/Query/Parsec.hs b/src/Yu/Core/View/Query/Parsec.hs
new file mode 100644
index 0000000..3cbd095
--- /dev/null
+++ b/src/Yu/Core/View/Query/Parsec.hs
@@ -0,0 +1,147 @@
+{-# 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
+
diff --git a/test-src/Internal.hs b/test-src/Internal.hs
new file mode 100644
index 0000000..153a9e7
--- /dev/null
+++ b/test-src/Internal.hs
@@ -0,0 +1,34 @@
+{-# 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
new file mode 100644
index 0000000..c5d677d
--- /dev/null
+++ b/test-src/ModelSpec.hs
@@ -0,0 +1,549 @@
+{-# 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
new file mode 100644
index 0000000..a824f8c
--- /dev/null
+++ b/test-src/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
diff --git a/yu-core.cabal b/yu-core.cabal
new file mode 100644
index 0000000..15f28a2
--- /dev/null
+++ b/yu-core.cabal
@@ -0,0 +1,63 @@
+-- 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
+ branch: 0.1/dev/master \ No newline at end of file