diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,674 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users. We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors. You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights. Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received. You must make sure that they, too, receive
+or can get the source code. And you must show them these terms so they
+know their rights.
+
+ Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+ For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software. For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+ Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so. This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software. The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable. Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products. If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+ Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary. To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Use with the GNU Affero General Public License.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+
+ Copyright (C)
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+ Copyright (C)
+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+.
+
+ The GNU General Public License does not permit incorporating your program
+into proprietary programs. If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License. But first, please read
+.
diff --git a/Lucienne/Args.hs b/Lucienne/Args.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Args.hs
@@ -0,0 +1,44 @@
+module Lucienne.Args
+ (Args (..), getArgs, dbConnectionString)
+where
+
+import Control.Monad (when)
+import System.Console.GetOpt
+import qualified System.Environment as Env
+import Data.List (intercalate)
+
+data Args = Args { applicationPort :: Int
+ , databaseHost :: String
+ , databasePort :: Int
+ }
+
+defaultArgs :: Args
+defaultArgs = Args 8000 "127.0.0.1" 27017
+
+options :: [OptDescr (Args -> Args)]
+options =
+ [ Option ['p'] ["port"]
+ (ReqArg (\a args -> args { applicationPort = read a }) "PORT")
+ "Port of incoming requests"
+ , Option ['d'] ["databaseHost"]
+ (ReqArg (\a args -> args { databaseHost = a }) "HOST")
+ "Database host"
+ , Option ['e'] ["databasePort"]
+ (ReqArg (\a args -> args { databasePort = read a }) "PORT")
+ "Database port"
+ , Option ['h'] ["help"]
+ (NoArg (\_ -> error $ usageInfo "" options))
+ "Print this help"
+ ]
+
+getArgs :: IO Args
+getArgs = do
+ cmdArgs <- Env.getArgs
+ case getOpt RequireOrder options cmdArgs of
+ (o,n,[]) ->
+ do when (not $ null n) $ putStrLn $ "Omitting arguments " ++ (intercalate "," n)
+ return $ foldr ($) defaultArgs o
+ (_,_,errors) -> error $ concat errors ++ usageInfo "" options
+
+dbConnectionString :: Args -> String
+dbConnectionString args = databaseHost args ++ ":" ++ (show $ databasePort args)
diff --git a/Lucienne/ConnectionReader.hs b/Lucienne/ConnectionReader.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/ConnectionReader.hs
@@ -0,0 +1,27 @@
+module Lucienne.ConnectionReader
+ (Connection, ConnectionReader, accessDb, runConnectionReader)
+where
+
+import Control.Monad.Reader (ReaderT,ask,liftIO,runReaderT)
+import Data.Char (toLower)
+import qualified Data.CompactString.UTF8 as CS
+import Database.MongoDB (Pipe,Action,Database)
+import qualified Database.MongoDB as M
+import Lucienne.Constant (programName)
+
+type Connection = Pipe
+type ConnectionReader = ReaderT Connection IO
+
+database :: Database
+database = CS.pack $ map toLower programName
+
+accessDb :: Action IO a -> ConnectionReader a
+accessDb action = do
+ connection <- ask
+ result <- liftIO $ M.access connection M.master database action
+ case result of
+ Right r -> return r
+ Left l -> error $ "while accessing database: " ++ show l
+
+runConnectionReader :: Connection -> ConnectionReader a -> IO a
+runConnectionReader connection reader = runReaderT reader connection
diff --git a/Lucienne/Constant.hs b/Lucienne/Constant.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Constant.hs
@@ -0,0 +1,7 @@
+module Lucienne.Constant
+ (programName)
+where
+
+programName :: String
+programName = "Lucienne"
+
diff --git a/Lucienne/Controller.hs b/Lucienne/Controller.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Controller.hs
@@ -0,0 +1,8 @@
+module Lucienne.Controller
+ (Controller)
+where
+
+import Happstack.Server (ServerPartT)
+import Lucienne.ConnectionReader (ConnectionReader)
+
+type Controller a = ServerPartT ConnectionReader a
diff --git a/Lucienne/Controller/AddNewFeed.hs b/Lucienne/Controller/AddNewFeed.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Controller/AddNewFeed.hs
@@ -0,0 +1,33 @@
+module Lucienne.Controller.AddNewFeed
+ (addNewFeed,doAddNewFeed)
+where
+
+import Control.Monad.Trans (liftIO)
+import Lucienne.Controller.Imports
+import qualified Lucienne.View.AddNewFeed as View
+import qualified Lucienne.Database as DB
+import Lucienne.Fetch (fetchFeedByUrl)
+import qualified Lucienne.Model.Feed as F
+import qualified Lucienne.Model.FeedItem as FI
+import qualified Lucienne.Url as Url
+
+addNewFeed :: User -> Controller Response
+addNewFeed _ = do
+ msg <- getMessages
+ ok $ toResponse $ View.addNewFeed msg
+
+doAddNewFeed :: User -> Controller Response
+doAddNewFeed user = do
+ decodeBody
+ url <- look "url"
+ alreadySubscribed <- lift $ DB.feedExists user url
+ if alreadySubscribed
+ then seeOther $ withMessage AlreadySubscribed Url.addNewFeed
+ else do
+ result <- liftIO $ fetchFeedByUrl url
+ case result of
+ Left msg -> badRequest $ toResponse $ msg
+ Right (feed,items) -> do
+ feedId <- lift $ DB.addFeed $ F.setOwner user feed
+ _ <- lift $ DB.addFeedItems $ map (FI.setOwner user . FI.setFeedId feedId) items
+ seeFeed feedId
diff --git a/Lucienne/Controller/AddNewUser.hs b/Lucienne/Controller/AddNewUser.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Controller/AddNewUser.hs
@@ -0,0 +1,40 @@
+module Lucienne.Controller.AddNewUser
+ (addNewUser,doAddNewUser)
+where
+
+import Control.Applicative ((<$>))
+import Lucienne.Controller.Imports
+import qualified Lucienne.View.AddNewUser as View
+import qualified Lucienne.Database as DB
+import qualified Lucienne.Model.User as U
+import qualified Lucienne.Url as Url
+
+addNewUser :: User -> Controller Response
+addNewUser user =
+ if U.mayAddUsers user then
+ getMessages >>= ok . toResponse . View.addNewUser
+ else
+ mzero
+
+doAddNewUser :: User -> Controller Response
+doAddNewUser user =
+ if U.mayAddUsers user then
+ do
+ decodeBody
+ Just username <- lookParameter "username"
+ Just password <- lookParameter "password"
+ Just checkPassword <- lookParameter "check_password"
+ mayAddUsers <- maybe False (const True) <$> lookParameter "may_add_users"
+
+ if password == checkPassword && not (null password)
+ then do
+ alreadyInUse <- lift $ DB.usernameExists username
+ if alreadyInUse
+ then seeOther $ withMessage UsernameExists Url.addNewUser
+ else do _ <- lift $ DB.addUser $ U.newUser username password mayAddUsers
+ seeHomeWith UserCreated
+ else seeOther $ concat [ withMessage CheckPassword Url.addNewUser
+ , "&name=",username]
+ else
+ mzero
+
diff --git a/Lucienne/Controller/BasicAuth.hs b/Lucienne/Controller/BasicAuth.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Controller/BasicAuth.hs
@@ -0,0 +1,37 @@
+module Lucienne.Controller.BasicAuth
+ (basicAuth)
+where
+
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Base64 as Base64
+import Happstack.Server.Monads (escape,getHeaderM,setHeaderM)
+import Happstack.Server.Response (unauthorized)
+import Lucienne.Controller.Imports
+import qualified Lucienne.Database as DB
+import Lucienne.Constant (programName)
+
+basicAuth :: (User -> Controller Response) -> Controller Response
+basicAuth protected = do
+ header <- getHeaderM "authorization"
+ case header of
+ Nothing -> notAuthorized
+ Just h ->
+ case parseHeader h of
+ Right (name, ':':password) -> do
+ user <- lift $ DB.userByNameAndPassword name password
+ case user of
+ Nothing -> notAuthorized
+ Just u -> protected u
+ _ -> notAuthorized
+
+ where
+ parseHeader header =
+ fmap (break (':'==) . B.unpack) $ Base64.decode $ B.drop 6 $ header
+
+ headerValue = "Basic realm=\"" ++ programName ++ "\""
+
+ notAuthorized =
+ escape $ do
+ setHeaderM "WWW-Authenticate" headerValue
+ unauthorized $ toResponse ("Not authorized" :: String)
+
diff --git a/Lucienne/Controller/ChangePassword.hs b/Lucienne/Controller/ChangePassword.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Controller/ChangePassword.hs
@@ -0,0 +1,25 @@
+module Lucienne.Controller.ChangePassword
+ (changePassword, doChangePassword)
+where
+
+import qualified Lucienne.Database as DB
+import Lucienne.Controller.Imports
+import qualified Lucienne.View.ChangePassword as View
+import qualified Lucienne.Url as Url
+
+changePassword :: User -> Controller Response
+changePassword _ = do
+ msg <- getMessages
+ ok $ toResponse $ View.changePassword msg
+
+doChangePassword :: User -> Controller Response
+doChangePassword user = do
+ decodeBody
+ Just password <- lookParameter "password"
+ Just checkPassword <- lookParameter "check_password"
+
+ if password == checkPassword && not (null password)
+ then do
+ lift $ DB.changePassword user password
+ seeHome
+ else seeOther $ withMessage CheckPassword Url.changePassword
diff --git a/Lucienne/Controller/DeleteFeed.hs b/Lucienne/Controller/DeleteFeed.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Controller/DeleteFeed.hs
@@ -0,0 +1,26 @@
+module Lucienne.Controller.DeleteFeed
+ (deleteFeed, doDeleteFeed)
+where
+
+import Lucienne.Controller.Imports
+import qualified Lucienne.View.DeleteFeed as View
+import qualified Lucienne.Database as DB
+import qualified Lucienne.Model.Feed as F
+
+deleteFeed :: String -> User -> Controller Response
+deleteFeed feedId user = do
+ mFeed <- lift $ DB.feedById user feedId
+ case mFeed of
+ Nothing -> mzero
+ Just feed -> ok $ toResponse $ View.deleteFeed feed
+
+doDeleteFeed :: String -> User -> Controller Response
+doDeleteFeed feedId user = do
+ mFeed <- lift $ DB.feedById user feedId
+ case mFeed of
+ Nothing -> mzero
+ Just feed -> do
+ lift $ do DB.deleteFeedItemsByFeedId $ F.id feed
+ DB.deleteFeedById user $ F.id feed
+ seeHome
+
diff --git a/Lucienne/Controller/DeleteUser.hs b/Lucienne/Controller/DeleteUser.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Controller/DeleteUser.hs
@@ -0,0 +1,16 @@
+module Lucienne.Controller.DeleteUser
+ (deleteUser, doDeleteUser)
+where
+
+import Lucienne.Controller.Imports
+import qualified Lucienne.View.DeleteUser as View
+import qualified Lucienne.Database as DB
+
+deleteUser :: User -> Controller Response
+deleteUser = ok . toResponse . View.deleteUser
+
+doDeleteUser :: User -> Controller Response
+doDeleteUser user = do
+ lift $ DB.deleteUser user
+ seeHome
+
diff --git a/Lucienne/Controller/Feed.hs b/Lucienne/Controller/Feed.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Controller/Feed.hs
@@ -0,0 +1,27 @@
+module Lucienne.Controller.Feed
+ (Message (..), feed, home)
+where
+
+import Data.List (find)
+import Lucienne.Controller.Imports
+import qualified Lucienne.Database as DB
+import qualified Lucienne.View.Feed as View
+import qualified Lucienne.Model.Feed as F
+
+feed :: String -> User -> Controller Response
+feed feedId user = do
+ feeds <- lift $ DB.feedsByUser user
+ items <- lift $ DB.feedItemsByFeedId user feedId
+
+ case (find (\f -> F.id f == readObjectId feedId) feeds) of
+ Nothing -> mzero
+ Just feed -> ok $ toResponse $ View.feed user feed items feeds
+
+home :: User -> Controller Response
+home user = do
+ msg <- getMessages
+ feeds <- lift $ DB.feedsByUser user
+ items <- lift $ DB.feedItems user
+
+ ok $ toResponse $ View.home user msg items feeds
+
diff --git a/Lucienne/Controller/FeedItem.hs b/Lucienne/Controller/FeedItem.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Controller/FeedItem.hs
@@ -0,0 +1,75 @@
+module Lucienne.Controller.FeedItem
+ ( feedItem, doDeleteFeedItem, doReadFeedItem, doChangeFeedItemState)
+where
+
+import Control.Applicative ((<$>))
+import Control.Monad (msum)
+import Data.Maybe (isJust,fromJust,catMaybes)
+import qualified Lucienne.Database as DB
+import Lucienne.Controller.Imports
+import qualified Lucienne.View.FeedItem as View
+import Lucienne.Model.FeedItem (FeedItem)
+import qualified Lucienne.Model.FeedItem as FI
+import Lucienne.Model.FeedItemState (FeedItemState (..))
+
+feedItem :: String -> User -> Controller Response
+feedItem feedItemId user = do
+ mFeedItem <- lift $ DB.feedItemById user feedItemId
+ case mFeedItem of
+ Nothing -> mzero
+ Just feedItem ->
+ let redirect = (null $ FI.content feedItem) && (FI.state feedItem == New)
+ in do
+ setStateOfItem feedItem Read
+
+ if redirect
+ then seeOther $ FI.url feedItem
+ else ok $ toResponse $ View.feedItem feedItem
+
+doDeleteFeedItem :: String -> User -> Controller Response
+doDeleteFeedItem feedItemId user =
+ setStateAndSeeFeed feedItemId user Deleted
+
+doReadFeedItem :: String -> User -> Controller Response
+doReadFeedItem feedItemId user =
+ setStateAndSeeFeed feedItemId user Read
+
+doChangeFeedItemState :: User -> Controller Response
+doChangeFeedItemState user = do
+ decodeBody
+ action <- msum <$> mapM lookAction ["markAsRead","delete"]
+ ids <- readParameter "numItems" >>= lookFeedItemIds . fromJust
+
+ case action of
+ Just "markAsRead" -> mapM_ (\id -> setState id user Read) ids
+ Just "delete" -> mapM_ (\id -> setState id user Deleted) ids
+
+ mFeedId <- fmap readObjectId <$> lookParameter "feedId"
+ case mFeedId of
+ Nothing -> seeHome
+ Just feedId -> seeFeed feedId
+
+ where
+ lookAction a = do
+ isAction <- isJust <$> lookParameter a
+ return $ if isAction then Just a else Nothing
+
+ lookFeedItemIds numItems =
+ catMaybes <$> mapM (\i -> lookParameter $ "feedItem" ++ show i) [0..numItems - 1]
+
+setState :: String -> User -> FeedItemState -> Controller ()
+setState feedItemId user state = do
+ Just feedItem <- lift $ DB.feedItemById user feedItemId
+ setStateOfItem feedItem state
+
+setStateOfItem :: FeedItem -> FeedItemState -> Controller ()
+setStateOfItem feedItem state =
+ case FI.state feedItem of
+ Deleted -> return ()
+ _ -> lift $ DB.upsertFeedItem $ feedItem { FI.state = state }
+
+setStateAndSeeFeed :: String -> User -> FeedItemState -> Controller Response
+setStateAndSeeFeed feedItemId user state = do
+ Just feedItem <- lift $ DB.feedItemById user feedItemId
+ setStateOfItem feedItem state
+ seeFeed $ FI.feedId feedItem
diff --git a/Lucienne/Controller/Imports.hs b/Lucienne/Controller/Imports.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Controller/Imports.hs
@@ -0,0 +1,45 @@
+{-| This is a utility module to avoid writing cumbersome import
+ statements of common modules in every controller.
+-}
+module Lucienne.Controller.Imports
+ ( stringSUri, withData
+ -- Control.Monad
+ , mzero
+ -- Control.Monad.Trans
+ , lift
+ -- Happstack.Server
+ , Response, toResponse, ok, badRequest
+ -- Happstack.Server.RqData
+ , RqData, look
+ -- Lucienne.Controller
+ , Controller
+ -- Lucienne.Controller.Util
+ , decodeBody, seeHome, seeHomeWith, seeOther, seeFeed, lookParameter, readParameter
+ -- Lucienne.Controller.Message
+ , Message (..), getMessages, withMessage
+ -- Lucienne.Model.User
+ , User
+ -- Lucienne.Model.Util
+ , readObjectId, showObjectId
+ )
+where
+
+import Control.Monad (mzero)
+import Control.Monad.Trans (lift)
+import Happstack.Server (Response,toResponse,ok,badRequest)
+import Happstack.Server.RqData (RqData,look)
+import Happstack.Server.SURI (SURI,toSURI)
+import Lucienne.Controller (Controller)
+import Lucienne.Controller.Util
+ (decodeBody,seeHome,seeHomeWith,seeOther,seeFeed,lookParameter,readParameter)
+import Lucienne.Controller.Message (Message(..), getMessages, withMessage)
+import Lucienne.Model.User (User)
+import Lucienne.Model.Util (readObjectId,showObjectId)
+
+import qualified Happstack.Server.RqData as Rq
+
+stringSUri :: String -> SURI
+stringSUri = toSURI
+
+withData :: RqData a -> (Either [String] a -> Controller b) -> Controller b
+withData rqData f = Rq.getDataFn rqData >>= f
diff --git a/Lucienne/Controller/Message.hs b/Lucienne/Controller/Message.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Controller/Message.hs
@@ -0,0 +1,34 @@
+module Lucienne.Controller.Message
+ (Message (..), getMessages, withMessage, readParameter)
+where
+
+import qualified Happstack.Server as S
+import Control.Applicative (optional,(<$>))
+import Lucienne.Controller (Controller)
+import Lucienne.Url (Url)
+
+data Message = UsernameExists
+ | CheckPassword
+ | UserCreated
+ | AlreadySubscribed
+ deriving (Read,Show)
+
+toMessage :: Message -> String
+toMessage msg = case msg of
+ UsernameExists -> "Username already in use"
+ CheckPassword -> "Check password"
+ UserCreated -> "User successfully created"
+ AlreadySubscribed -> "You've already subscribed this feed"
+
+getMessages :: Controller [String]
+getMessages = do
+ mMsg <- readParameter "msg"
+ return $ case mMsg of
+ Nothing -> [ ]
+ Just msg -> [toMessage msg]
+
+withMessage :: Message -> Url -> Url
+withMessage msg url = concat [url, "?msg=", show msg]
+
+readParameter :: Read a => String -> Controller (Maybe a)
+readParameter param = fmap read <$> (optional $ S.look param)
diff --git a/Lucienne/Controller/NotFound.hs b/Lucienne/Controller/NotFound.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Controller/NotFound.hs
@@ -0,0 +1,9 @@
+module Lucienne.Controller.NotFound
+ (notFound)
+where
+
+import qualified Happstack.Server as S
+import Lucienne.Controller.Imports
+
+notFound :: String -> Controller Response
+notFound url = S.notFound $ toResponse $ "Not found: " ++ url
diff --git a/Lucienne/Controller/Util.hs b/Lucienne/Controller/Util.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Controller/Util.hs
@@ -0,0 +1,33 @@
+module Lucienne.Controller.Util
+ ( decodeBody, seeOther, seeFeed, seeHome, seeHomeWith
+ , lookParameter, readParameter)
+where
+
+import Control.Applicative (optional)
+import qualified Happstack.Server as S
+import Lucienne.Controller (Controller)
+import Lucienne.Model.Util (showObjectId)
+import Data.Bson (ObjectId)
+import qualified Lucienne.Url as Url
+import Lucienne.Controller.Message(Message, withMessage, readParameter)
+
+decodeBody :: Controller ()
+decodeBody = S.decodeBody decodePolicy
+
+seeOther :: String -> Controller S.Response
+seeOther url = S.seeOther url $ S.toResponse ()
+
+seeFeed :: ObjectId -> Controller S.Response
+seeFeed feedId = seeOther $ Url.feed ++ "/" ++ showObjectId feedId
+
+seeHome :: Controller S.Response
+seeHome = seeOther Url.home
+
+seeHomeWith :: Message -> Controller S.Response
+seeHomeWith message = seeOther $ withMessage message Url.home
+
+decodePolicy :: S.BodyPolicy
+decodePolicy = S.defaultBodyPolicy "/tmp/" 0 10240 10240
+
+lookParameter :: String -> Controller (Maybe String)
+lookParameter = optional . S.look
diff --git a/Lucienne/Database.hs b/Lucienne/Database.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Database.hs
@@ -0,0 +1,172 @@
+module Lucienne.Database
+ ( addUser, deleteUser, users, usernameExists, userByNameAndPassword, changePassword
+ , addFeed, feedExists, feedsByUser, feedById, deleteFeedById
+ , addFeedItems, upsertFeedItem, feedItems, feedItemsByFeedId, feedItemById, feedItemExists
+ , deleteMarkedFeedItems, deleteFeedItemsByFeedId
+ , countUsers)
+where
+
+import Data.Maybe (isJust)
+import Control.Applicative ((<$>))
+import Data.CompactString.UTF8 (CompactString)
+import Data.Bson ((=:),ObjectId)
+import Database.MongoDB (Document,Value)
+import qualified Database.MongoDB as DB
+import Lucienne.ConnectionReader (ConnectionReader,accessDb)
+import Lucienne.DatabaseAble (DatabaseAble(..))
+import Lucienne.Model.Util (showValue,objectId,readObjectId)
+import Lucienne.Model.User (User,name)
+import qualified Lucienne.Model.User as U
+import Lucienne.Model.Feed (Feed)
+import qualified Lucienne.Model.Feed as F
+import Lucienne.Model.FeedItem (FeedItem)
+import qualified Lucienne.Model.FeedItem as FI
+
+type Collection = CompactString
+
+userCollection = "users"
+feedCollection = "feeds"
+feedItemCollection = "feedItems"
+
+addUser :: User -> ConnectionReader String
+addUser user =
+ showValue <$> addDatabaseAble userCollection user
+
+deleteUser :: User -> ConnectionReader ()
+deleteUser user =
+ let deleteFeedItemsQuery = FI.feedItemsQuery (name user)
+ deleteFeedsQuery = F.feedsQuery (name user)
+ deleteUserQuery = U.userByNameQuery (name user)
+ in do
+ deleteDocuments feedItemCollection deleteFeedItemsQuery
+ deleteDocuments feedCollection deleteFeedsQuery
+ deleteDocuments userCollection deleteUserQuery
+
+addFeed :: Feed -> ConnectionReader ObjectId
+addFeed feed =
+ objectId <$> addDatabaseAble feedCollection feed
+
+addFeedItems :: [FeedItem] -> ConnectionReader [ObjectId]
+addFeedItems items =
+ map objectId <$> addDatabaseAbles feedItemCollection items
+
+upsertFeedItem :: FeedItem -> ConnectionReader ()
+upsertFeedItem = upsertDatabaseAble feedItemCollection
+
+users :: ConnectionReader [User]
+users = do
+ users <- readDocuments userCollection [] [] []
+ return $ map fromDocument users
+
+usernameExists :: String -> ConnectionReader Bool
+usernameExists = querySucceeds userCollection . U.userByNameQuery
+
+userByNameAndPassword :: String -> String -> ConnectionReader (Maybe User)
+userByNameAndPassword name password = do
+ user <- readDocument userCollection (U.userByNameAndPasswordQuery name password) []
+ return $ fmap fromDocument user
+
+changePassword :: User -> String -> ConnectionReader ()
+changePassword user = upsertDatabaseAble userCollection . U.changePassword user
+
+feedExists :: User -> String -> ConnectionReader Bool
+feedExists user url =
+ querySucceeds feedCollection $ F.feedByUrlQuery (name user) url
+
+feedsByUser :: User -> ConnectionReader [Feed]
+feedsByUser user = do
+ docs <- readDocuments feedCollection (F.feedsQuery $ name user) [] []
+ return $ map fromDocument docs
+
+feedById :: User -> String -> ConnectionReader (Maybe Feed)
+feedById user feedId =
+ let queryDocument = F.feedByIdQuery (name user) (readObjectId feedId)
+ in do
+ feed <- readDocument feedCollection queryDocument []
+ return $ fmap fromDocument feed
+
+deleteFeedById :: User -> ObjectId -> ConnectionReader ()
+deleteFeedById user feedId =
+ let queryDocument = F.feedByIdQuery (name user) feedId
+ in
+ deleteDocuments feedCollection queryDocument
+
+feedItemsByFeedId :: User -> String -> ConnectionReader [FeedItem]
+feedItemsByFeedId user feedId =
+ let queryDocument = FI.feedItemsByFeedIdQuery (name user) feedId
+ in do
+ docs <- readDocuments feedItemCollection queryDocument FI.feedItemHeaderProjector FI.feedItemsSort
+ return $ map fromDocument docs
+
+feedItems :: User -> ConnectionReader [FeedItem]
+feedItems user =
+ let queryDocument = FI.readableFeedItemsQuery $ name user
+ in do
+ docs <- readDocuments feedItemCollection queryDocument FI.feedItemHeaderProjector FI.feedItemsSort
+ return $ map fromDocument docs
+
+feedItemById :: User -> String -> ConnectionReader (Maybe FeedItem)
+feedItemById user feedItemId =
+ let queryDocument = FI.feedItemByIdQuery (name user) feedItemId
+ in do
+ item <- readDocument feedItemCollection queryDocument []
+ return $ fmap fromDocument item
+
+feedItemExists :: ObjectId -> String -> String -> ConnectionReader Bool
+feedItemExists feedId title url =
+ let queryDocument = FI.feedItemExistsQuery feedId title url
+ in
+ querySucceeds feedItemCollection queryDocument
+
+deleteMarkedFeedItems :: ObjectId -> [String] -> [String] -> ConnectionReader ()
+deleteMarkedFeedItems feedId titlesToRemain urlsToRemain =
+ let queryDocument = FI.deleteMarkedFeedItemsQuery feedId titlesToRemain urlsToRemain
+ in
+ deleteDocuments feedItemCollection queryDocument
+
+deleteFeedItemsByFeedId :: ObjectId -> ConnectionReader ()
+deleteFeedItemsByFeedId feedId =
+ let queryDocument = FI.deleteFeedItemsByFeedIdQuery feedId
+ in
+ deleteDocuments feedItemCollection queryDocument
+
+countUsers :: ConnectionReader Int
+countUsers = countDocuments userCollection
+
+readDocument :: Collection -> Document -> Document -> ConnectionReader (Maybe Document)
+readDocument collection queryDocument projector =
+ let query = (DB.select queryDocument collection) {DB.project = projector}
+ in
+ accessDb $ DB.findOne query
+
+readDocuments :: Collection -> Document -> Document -> Document -> ConnectionReader [Document]
+readDocuments collection queryDocument projector sort =
+ let query = (DB.select queryDocument collection) {DB.project = projector, DB.sort = sort}
+ in
+ accessDb $ DB.find query >>= DB.rest
+
+countDocuments :: Collection -> ConnectionReader Int
+countDocuments = accessDb . DB.count . DB.select []
+
+addDatabaseAble :: (DatabaseAble a) => Collection -> a -> ConnectionReader Value
+addDatabaseAble collection =
+ accessDb . DB.insert collection . toDocument
+
+addDatabaseAbles :: (DatabaseAble a) => Collection -> [a] -> ConnectionReader [Value]
+addDatabaseAbles collection =
+ accessDb . DB.insertMany collection . map toDocument
+
+upsertDatabaseAble :: (DatabaseAble a) => Collection -> a -> ConnectionReader ()
+upsertDatabaseAble collection =
+ accessDb . DB.save collection . toDocument
+
+deleteDocuments :: Collection -> Document -> ConnectionReader ()
+deleteDocuments collection queryDocument =
+ accessDb $ DB.delete $ DB.select queryDocument collection
+
+-- |Returns @True@ when at least on result was found
+querySucceeds :: Collection -> Document -> ConnectionReader Bool
+querySucceeds collection queryDocument =
+ let query = (DB.select queryDocument collection) {DB.project = [ "_id" =: (1::Int) ]}
+ in
+ isJust <$> (accessDb $ DB.findOne query)
diff --git a/Lucienne/DatabaseAble.hs b/Lucienne/DatabaseAble.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/DatabaseAble.hs
@@ -0,0 +1,9 @@
+module Lucienne.DatabaseAble
+ (DatabaseAble (..))
+where
+
+import Data.Bson (Document)
+
+class DatabaseAble a where
+ toDocument :: a -> Document
+ fromDocument :: Document -> a
diff --git a/Lucienne/Fetch.hs b/Lucienne/Fetch.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Fetch.hs
@@ -0,0 +1,85 @@
+module Lucienne.Fetch
+ (fetchFeedByUrl,fetchFeed)
+where
+
+import Data.Maybe (fromMaybe)
+import Data.List (find)
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as E
+import qualified Network.HTTP as HTTP
+import Network.URI (URI)
+import qualified Network.URI as URI
+import qualified Text.Feed.Import as TFI
+import qualified Text.Feed.Types as TFT
+import qualified Text.Atom.Feed as TFAtom
+import qualified Text.RSS.Syntax as TFRss
+import Lucienne.Model.FeedItem (FeedItem)
+import qualified Lucienne.Model.FeedItem as FI
+import Lucienne.Model.Feed (Feed)
+import qualified Lucienne.Model.Feed as F
+
+fetchFeedByUrl :: String -> IO (Either String (Feed,[FeedItem]))
+fetchFeedByUrl url =
+ case URI.parseURI url of
+ Nothing -> return $ Left $ concat ["'",url,"' is no valid URL"]
+ Just uri -> fetchAndProcessFeed uri $ parseFeed uri
+
+fetchFeed :: Feed -> IO (Either String (Feed,[FeedItem]))
+fetchFeed = fetchFeedByUrl . F.url
+
+parseFeed :: URI -> String -> Either String (Feed,[FeedItem])
+parseFeed feedUri content =
+ let textFeed = TFI.parseFeedString content
+ in
+ case textFeed of
+ Nothing -> Left "Can not parse feed items"
+ Just (TFT.AtomFeed f) -> Right $ parseAtomFeed feedUri f
+ Just (TFT.RSSFeed f) -> Right $ parseRssFeed feedUri f
+ Just _ -> Left "Unsupported feed format"
+
+parseAtomFeed :: URI -> TFAtom.Feed -> (Feed,[FeedItem])
+parseAtomFeed feedUri feed =
+ let parseFeedItems entry =
+ let title = TFAtom.txtToString $ TFAtom.entryTitle entry
+ url = chooseAtomLink $ TFAtom.entryLinks entry
+ content = maybe "" TFAtom.txtToString $ TFAtom.entrySummary entry
+ in
+ FI.newItem title url content
+ feedTitle = TFAtom.txtToString $ TFAtom.feedTitle feed
+ in
+ ( F.newFeed feedTitle $ show feedUri
+ , map parseFeedItems $ TFAtom.feedEntries feed
+ )
+
+chooseAtomLink :: [TFAtom.Link] -> String
+chooseAtomLink links =
+ let selfLink = find (\l -> case TFAtom.linkRel l of
+ Just (Right "self") -> True
+ Just (Left "self") -> True
+ _ -> False)
+ in
+ TFAtom.linkHref $ fromMaybe (head links) $ selfLink links
+
+parseRssFeed :: URI -> TFRss.RSS -> (Feed,[FeedItem])
+parseRssFeed feedUri feed =
+ let parseFeedItems item =
+ let title = fromMaybe "" $ TFRss.rssItemTitle item
+ url = fromMaybe "" $ TFRss.rssItemLink item
+ content = fromMaybe "" $ TFRss.rssItemDescription item
+ in
+ FI.newItem title url content
+ feedTitle = TFRss.rssTitle $ TFRss.rssChannel feed
+ in
+ ( F.newFeed feedTitle $ show feedUri
+ , map parseFeedItems $ TFRss.rssItems $ TFRss.rssChannel feed
+ )
+
+fetchAndProcessFeed :: URI -> (String -> Either String a) -> IO (Either String a)
+fetchAndProcessFeed uri f = do
+ result <- HTTP.simpleHTTP request
+ return $ case result of
+ Left connectionError -> Left $ show connectionError
+ Right response -> f $ T.unpack . E.decodeUtf8 $ HTTP.rspBody response
+ where
+ request = HTTP.Request uri HTTP.GET [] BS.empty
diff --git a/Lucienne/Fetch/Main.hs b/Lucienne/Fetch/Main.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Fetch/Main.hs
@@ -0,0 +1,70 @@
+import Prelude hiding (log)
+import Control.Monad (forM_)
+import Control.Monad.Trans (liftIO)
+import Data.Time.LocalTime (getZonedTime)
+import Data.Bson (ObjectId)
+import Database.MongoDB (runIOE,readHostPort,connect,close)
+import qualified Lucienne.Database as DB
+import Lucienne.ConnectionReader (ConnectionReader,runConnectionReader)
+import Lucienne.Fetch (fetchFeed)
+import Lucienne.Fetch.Util (partitionM)
+import Lucienne.Model.User (User)
+import qualified Lucienne.Model.User as User
+import Lucienne.Model.Feed (Feed)
+import qualified Lucienne.Model.Feed as F
+import Lucienne.Model.FeedItem (FeedItem)
+import qualified Lucienne.Model.FeedItem as FI
+import Lucienne.Args (getArgs,dbConnectionString)
+
+main :: IO ()
+main = do
+ args <- getArgs
+ putStrLn $ "Connecting to database " ++ (dbConnectionString args) ++ " ..."
+ connection <- runIOE $ connect $ readHostPort $ dbConnectionString args
+ runConnectionReader connection fetch
+ close connection
+
+fetch :: ConnectionReader ()
+fetch = do
+ users <- DB.users
+ forM_ users fetchFeedsAndUpdate
+
+fetchFeedsAndUpdate :: User -> ConnectionReader ()
+fetchFeedsAndUpdate user = do
+ feeds <- DB.feedsByUser user
+ forM_ feeds $ \f -> do
+ log $ concat ["Fetching feed '",F.title f, "' for user '",User.name user,"'"]
+ fetchFeedItemsAndUpdate user f
+
+fetchFeedItemsAndUpdate :: User -> Feed -> ConnectionReader ()
+fetchFeedItemsAndUpdate user feed =
+ let fId = F.id feed
+ fUrl = F.url feed
+ in do
+ result <- liftIO $ fetchFeed feed
+ case result of
+ Left message -> log $ "Could not fetch feed '" ++ fUrl ++ "' because of: " ++ message
+ Right (_,items') ->
+ let items = map (FI.setOwner user . FI.setFeedId fId) items'
+ in do
+ (rest,toAdd) <- partitionExistentFeedItems fId items
+ log $ concat ["Fetched ", show $ length items," items (",show $ length toAdd," new)"]
+
+ forM_ toAdd DB.upsertFeedItem
+ deleteFeedItems fId rest
+
+partitionExistentFeedItems :: ObjectId -> [FeedItem] -> ConnectionReader ([FeedItem],[FeedItem])
+partitionExistentFeedItems feedId =
+ partitionM $ \i -> DB.feedItemExists feedId (FI.title i) (FI.url i)
+
+deleteFeedItems :: ObjectId -> [FeedItem] -> ConnectionReader ()
+deleteFeedItems feedId feedItems =
+ let titlesToRemain = map FI.title feedItems
+ urlsToRemain = map FI.url feedItems
+ in
+ DB.deleteMarkedFeedItems feedId titlesToRemain urlsToRemain
+
+log :: String -> ConnectionReader ()
+log s = do
+ time <- liftIO $ getZonedTime
+ liftIO $ putStrLn $ concat ["[",show time,"]\t",s]
diff --git a/Lucienne/Fetch/Util.hs b/Lucienne/Fetch/Util.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Fetch/Util.hs
@@ -0,0 +1,14 @@
+module Lucienne.Fetch.Util
+ (partitionM)
+where
+
+import Control.Monad (foldM)
+
+-- Note: order of elements is reversed in result
+partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a],[a])
+partitionM p = foldM (selectM p) ([],[])
+
+selectM :: Monad m => (a -> m Bool) -> ([a], [a]) -> a -> m ([a], [a])
+selectM p (ts,fs) x = do
+ true <- p x
+ return $ if true then (x:ts, fs) else (ts, x:fs)
diff --git a/Lucienne/Main.hs b/Lucienne/Main.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Main.hs
@@ -0,0 +1,73 @@
+import Prelude hiding (catch)
+import Control.Monad (msum,when)
+import Control.Monad.Trans (lift)
+import Control.Exception (handle,AsyncException(UserInterrupt))
+import Happstack.Server
+ (Conf(port),simpleHTTP',nullConf,dir,dirs,path,nullDir,serveFile,asContentType,uriRest)
+import Database.MongoDB (runIOE,readHostPort,connect,close)
+import Paths_lucienne (getDataFileName)
+import Lucienne.Args (Args,applicationPort,getArgs,dbConnectionString)
+import Lucienne.ConnectionReader (Connection,ConnectionReader,runConnectionReader)
+import Lucienne.Model.User (newUser)
+import qualified Lucienne.Database as DB
+import Lucienne.Controller.BasicAuth (basicAuth)
+import Lucienne.Controller.AddNewUser (addNewUser,doAddNewUser)
+import Lucienne.Controller.AddNewFeed (addNewFeed,doAddNewFeed)
+import Lucienne.Controller.DeleteFeed (deleteFeed,doDeleteFeed)
+import Lucienne.Controller.Feed (feed,home)
+import Lucienne.Controller.FeedItem
+ (feedItem,doDeleteFeedItem,doReadFeedItem,doChangeFeedItemState)
+import Lucienne.Controller.ChangePassword (changePassword,doChangePassword)
+import Lucienne.Controller.DeleteUser (deleteUser, doDeleteUser)
+import Lucienne.Controller.NotFound (notFound)
+import qualified Lucienne.Url as Url
+
+main :: IO ()
+main = do
+ args <- getArgs
+ putStrLn $ "Connecting to database " ++ (dbConnectionString args) ++ " ..."
+ connection <- runIOE $ connect $ readHostPort $ dbConnectionString args
+ serverConfig <- return $ nullConf { port = applicationPort args }
+ putStrLn $ "Running on port " ++ show (applicationPort args) ++ " ..."
+ handle (\UserInterrupt -> closeConnection connection) $ do
+ runConnectionReader connection addAdminAccountOnInit
+ simpleHTTP' (runConnectionReader connection) serverConfig $ msum
+ [ urlDir Url.addNewUser $ basicAuth addNewUser
+ , urlDir Url.doAddNewUser $ basicAuth doAddNewUser
+ , urlDir Url.addNewFeed $ basicAuth addNewFeed
+ , urlDir Url.doAddNewFeed $ basicAuth doAddNewFeed
+ , urlDir Url.deleteFeed $ path $ basicAuth . deleteFeed
+ , urlDir Url.doDeleteFeed $ path $ basicAuth . doDeleteFeed
+ , urlDir Url.feed $ path $ basicAuth . feed
+ , urlDir Url.feedItem $ path $ basicAuth . feedItem
+ , urlDirs Url.staticCss $ serveFile' "text/css" "static/css.css"
+ , urlDirs Url.staticJs $ serveFile' "application/javascript" "static/js.js"
+ , urlDir Url.doDeleteFeedItem $ path $ basicAuth . doDeleteFeedItem
+ , urlDir Url.doReadFeedItem $ path $ basicAuth . doReadFeedItem
+ , urlDir Url.doChangeFeedItemState $ basicAuth doChangeFeedItemState
+ , urlDir Url.changePassword $ basicAuth changePassword
+ , urlDir Url.doChangePassword $ basicAuth doChangePassword
+ , urlDir Url.deleteUser $ basicAuth deleteUser
+ , urlDir Url.doDeleteUser $ basicAuth doDeleteUser
+ , nullDir >> basicAuth home
+ , uriRest notFound
+ ]
+
+ where urlDir = dir . tail
+ urlDirs = dirs . tail
+ serveFile' ct filePath = do
+ filePath' <- lift $ lift $ getDataFileName filePath
+ serveFile (asContentType ct) filePath'
+
+closeConnection :: Connection -> IO ()
+closeConnection c = do
+ putStrLn "Closing connection ..."
+ close c
+
+addAdminAccountOnInit :: ConnectionReader ()
+addAdminAccountOnInit = do
+ numUsers <- DB.countUsers
+ when (0 == numUsers) $ do
+ lift $ putStrLn "Creating admin account: please change password immediately ..."
+ _ <- DB.addUser $ newUser "admin" "12345" True
+ return ()
diff --git a/Lucienne/Model/Feed.hs b/Lucienne/Model/Feed.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Model/Feed.hs
@@ -0,0 +1,60 @@
+module Lucienne.Model.Feed
+ ( Feed, id, ownerId, title, url, newFeed, setOwner
+ , feedByUrlQuery, feedByIdQuery, feedsQuery)
+where
+
+import Prelude hiding (id)
+import Data.Maybe (fromJust)
+import qualified Data.CompactString.UTF8 as CS
+import Data.Bson (Document,ObjectId,(=:),at)
+import Lucienne.DatabaseAble (DatabaseAble(..))
+import Lucienne.Model.Util (maybeAddId)
+import qualified Lucienne.Model.User as U
+
+data Feed = Feed { _id :: Maybe ObjectId
+ , _ownerId :: Maybe String
+ , title :: String
+ , url :: String
+ }
+
+newFeed :: String -> String -> Feed
+newFeed = Feed Nothing Nothing
+
+id :: Feed -> ObjectId
+id = fromJust . _id
+
+ownerId :: Feed -> String
+ownerId = fromJust . _ownerId
+
+setOwner :: U.User -> Feed -> Feed
+setOwner owner feed = feed { _ownerId = Just $ U.name owner }
+
+instance DatabaseAble Feed where
+ toDocument feed = maybeAddId _id feed $
+ [ "ownerId" =: CS.pack (ownerId feed)
+ , "title" =: CS.pack (title feed)
+ , "url" =: CS.pack (url feed)
+ ]
+
+ fromDocument document =
+ let _id = "_id" `at` document
+ ownerId = CS.unpack $ "ownerId" `at` document
+ title = CS.unpack $ "title" `at` document
+ url = CS.unpack $ "url" `at` document
+ in
+ Feed (Just _id) (Just ownerId) title url
+
+feedByUrlQuery :: String -> String -> Document
+feedByUrlQuery ownerId url =
+ [ "ownerId" =: CS.pack ownerId
+ , "url" =: CS.pack url
+ ]
+
+feedByIdQuery :: String -> ObjectId -> Document
+feedByIdQuery ownerId _id =
+ [ "ownerId" =: CS.pack ownerId
+ , "_id" =: _id
+ ]
+
+feedsQuery :: String -> Document
+feedsQuery ownerId = ["ownerId" =: CS.pack ownerId]
diff --git a/Lucienne/Model/FeedItem.hs b/Lucienne/Model/FeedItem.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Model/FeedItem.hs
@@ -0,0 +1,120 @@
+module Lucienne.Model.FeedItem
+ ( FeedItem, id, feedId, title, url, content, dateFetched, state, newItem
+ , setOwner, setFeedId
+ , feedItemsQuery, readableFeedItemsQuery, feedItemsByFeedIdQuery, feedItemByIdQuery
+ , feedItemExistsQuery
+ , deleteMarkedFeedItemsQuery, deleteFeedItemsByFeedIdQuery
+ , feedItemHeaderProjector, feedItemsSort)
+where
+
+import Prelude hiding (id)
+import System.IO.Unsafe (unsafePerformIO)
+import Data.Maybe (fromJust)
+import qualified Data.CompactString.UTF8 as CS
+import Data.Bson (Document,ObjectId,(=:),at)
+import Data.Time.Clock (UTCTime)
+import Data.Time.LocalTime (getZonedTime,zonedTimeToUTC)
+import Lucienne.DatabaseAble (DatabaseAble(..))
+import Lucienne.Model.Util (maybeAddId,readObjectId)
+import qualified Lucienne.Model.User as U
+import Lucienne.Model.FeedItemState (FeedItemState)
+import qualified Lucienne.Model.FeedItemState as S
+
+data FeedItem = FeedItem { _id :: Maybe ObjectId
+ , _ownerId :: Maybe String
+ , _feedId :: Maybe ObjectId
+ , title :: String
+ , url :: String
+ , content :: String
+ , dateFetched :: UTCTime
+ , state :: FeedItemState
+ }
+
+newItem :: String -> String -> String -> FeedItem
+newItem title url content =
+ FeedItem Nothing Nothing Nothing title url content currentTimeInUTC S.New
+
+id,feedId :: FeedItem -> ObjectId
+id = fromJust . _id
+feedId = fromJust . _feedId
+
+setOwner :: U.User -> FeedItem -> FeedItem
+setOwner owner item = item { _ownerId = Just $ U.name owner }
+
+setFeedId :: ObjectId -> FeedItem -> FeedItem
+setFeedId feedId item = item { _feedId = Just feedId }
+
+{-# NOINLINE currentTimeInUTC #-}
+currentTimeInUTC :: UTCTime
+currentTimeInUTC =
+ unsafePerformIO (getZonedTime >>= return . zonedTimeToUTC)
+
+instance DatabaseAble FeedItem where
+ toDocument item = maybeAddId _id item $
+ [ "ownerId" =: CS.pack (fromJust $ _ownerId item)
+ , "feedId" =: (fromJust $ _feedId item)
+ , "title" =: CS.pack (title item)
+ , "url" =: CS.pack (url item)
+ , "content" =: CS.pack (content item)
+ , "dateFetched" =: dateFetched item
+ , "state" =: (S.toInteger $ state item)
+ ]
+
+ fromDocument document =
+ let id = "_id" `at` document
+ ownerId = CS.unpack $ "ownerId" `at` document
+ feedId = "feedId" `at` document
+ title = CS.unpack $ "title" `at` document
+ url = CS.unpack $ "url" `at` document
+ content = CS.unpack $ "content" `at` document
+ dateFetched = "dateFetched" `at` document
+ state = S.fromInteger $ "state" `at` document
+ in
+ FeedItem (Just id) (Just ownerId) (Just feedId) title url content dateFetched state
+
+feedItemsQuery :: String -> Document
+feedItemsQuery ownerId =
+ [ "ownerId" =: CS.pack ownerId ]
+
+readableFeedItemsQuery :: String -> Document
+readableFeedItemsQuery ownerId =
+ [ "ownerId" =: CS.pack ownerId
+ , "state" =: [ "$in" =: [S.toInteger S.New, S.toInteger S.Read] ]
+ ]
+
+feedItemsByFeedIdQuery :: String -> String -> Document
+feedItemsByFeedIdQuery ownerId feedId =
+ [ "ownerId" =: CS.pack ownerId
+ , "feedId" =: readObjectId feedId
+ , "state" =: [ "$in" =: [S.toInteger S.New, S.toInteger S.Read] ]
+ ]
+
+feedItemByIdQuery :: String -> String -> Document
+feedItemByIdQuery ownerId id =
+ [ "ownerId" =: CS.pack ownerId
+ , "_id" =: readObjectId id
+ ]
+
+feedItemExistsQuery :: ObjectId -> String -> String -> Document
+feedItemExistsQuery feedId title url =
+ [ "feedId" =: feedId
+ , "title" =: CS.pack title
+ , "url" =: CS.pack url
+ ]
+
+deleteMarkedFeedItemsQuery :: ObjectId -> [String] -> [String] -> Document
+deleteMarkedFeedItemsQuery feedId titlesToMaintain urlsToMaintain =
+ [ "state" =: S.toInteger S.Deleted
+ , "feedId" =: feedId
+ , "title" =: [ "$not" =: [ "$in" =: map CS.pack titlesToMaintain ] ]
+ , "url" =: [ "$not" =: [ "$in" =: map CS.pack urlsToMaintain ] ]
+ ]
+
+deleteFeedItemsByFeedIdQuery :: ObjectId -> Document
+deleteFeedItemsByFeedIdQuery feedId = [ "feedId" =: feedId ]
+
+feedItemHeaderProjector :: Document
+feedItemHeaderProjector = ["content" =: (0 :: Int)]
+
+feedItemsSort :: Document
+feedItemsSort = [ "dateFetched" =: (1 :: Int) ]
diff --git a/Lucienne/Model/FeedItemState.hs b/Lucienne/Model/FeedItemState.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Model/FeedItemState.hs
@@ -0,0 +1,21 @@
+module Lucienne.Model.FeedItemState
+ (FeedItemState(..), fromInteger, toInteger)
+where
+
+import Prelude hiding (fromInteger,toInteger)
+
+data FeedItemState = New | Read | Deleted deriving Eq
+
+fromInteger :: Integer -> FeedItemState
+fromInteger i =
+ case i of
+ 0 -> New
+ 1 -> Read
+ 2 -> Deleted
+
+toInteger :: FeedItemState -> Integer
+toInteger state =
+ case state of
+ New -> 0
+ Read -> 1
+ Deleted -> 2
diff --git a/Lucienne/Model/User.hs b/Lucienne/Model/User.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Model/User.hs
@@ -0,0 +1,48 @@
+module Lucienne.Model.User
+ ( User, newUser, name, mayAddUsers, changePassword
+ , userByNameQuery, userByNameAndPasswordQuery)
+where
+
+import qualified Data.ByteString.Lazy.Char8 as BS
+import Data.Digest.Pure.SHA (showDigest,sha1)
+import Data.Bson (Document,(=:),at)
+import qualified Data.CompactString.UTF8 as CS
+import Lucienne.DatabaseAble (DatabaseAble(..))
+
+data User = User { name :: String
+ , password :: String
+ , mayAddUsers :: Bool
+ } deriving (Show)
+
+newUser :: String -> String -> Bool -> User
+newUser name password mayAddUsers =
+ User name (hashPassword password) mayAddUsers
+
+hashPassword :: String -> String
+hashPassword = showDigest . sha1 . BS.pack
+
+changePassword :: User -> String -> User
+changePassword user newPassword =
+ user { password = hashPassword newPassword }
+
+instance DatabaseAble User where
+ toDocument user = [ "_id" =: CS.pack (name user)
+ , "password" =: CS.pack (password user)
+ , "mayAddUsers" =: mayAddUsers user
+ ]
+
+ fromDocument document =
+ let name = CS.unpack $ "_id" `at` document
+ password = CS.unpack $ "password" `at` document
+ mayAddUsers = "mayAddUsers" `at` document
+ in
+ User name password mayAddUsers
+
+userByNameQuery :: String -> Document
+userByNameQuery name = [ "_id" =: CS.pack name ]
+
+userByNameAndPasswordQuery :: String -> String -> Document
+userByNameAndPasswordQuery name password =
+ [ "_id" =: CS.pack name
+ , "password" =: CS.pack (hashPassword password)
+ ]
diff --git a/Lucienne/Model/Util.hs b/Lucienne/Model/Util.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Model/Util.hs
@@ -0,0 +1,29 @@
+module Lucienne.Model.Util
+ (maybeAddId, showObjectId, readObjectId, showValue, objectId)
+where
+
+import Data.Bson (Document,Value(ObjId,String),(=:),ObjectId(Oid))
+import Numeric (showHex,readHex)
+import qualified Data.CompactString.UTF8 as CS
+
+maybeAddId :: (a -> Maybe ObjectId) -> a -> Document -> Document
+maybeAddId getId a document =
+ case getId a of
+ Nothing -> document
+ Just id -> ("_id" =: id) : document
+
+showObjectId :: ObjectId -> String
+showObjectId (Oid a b) = showHex a $ showHex b ""
+
+readObjectId :: String -> ObjectId
+readObjectId s = Oid (fst $ head $ readHex $ take 8 s)
+ (fst $ head $ readHex $ drop 8 s)
+
+showValue :: Value -> String
+showValue value =
+ case value of
+ ObjId objId -> showObjectId objId
+ String s -> CS.unpack s
+
+objectId :: Value -> ObjectId
+objectId (ObjId objId) = objId
diff --git a/Lucienne/Url.hs b/Lucienne/Url.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/Url.hs
@@ -0,0 +1,31 @@
+module Lucienne.Url
+where
+
+type Url = String
+
+home = "/"
+
+addNewUser = "/addNewUser"
+doAddNewUser = "/doAddNewUser"
+
+addNewFeed = "/addNewFeed"
+doAddNewFeed = "/doAddNewFeed"
+
+deleteFeed = "/deleteFeed"
+doDeleteFeed = "/doDeleteFeed"
+
+feed = "/feed"
+feedItem = "/feedItem"
+
+staticCss = "/static/css.css"
+staticJs = "/static/js.js"
+
+doDeleteFeedItem = "/doDeleteFeedItem"
+doReadFeedItem = "/doReadFeedItem"
+doChangeFeedItemState = "/doChangeFeedItemState"
+
+changePassword = "/changePassword"
+doChangePassword = "/doChangePassword"
+
+deleteUser = "/deleteUser"
+doDeleteUser = "/doDeleteUser"
diff --git a/Lucienne/View/AddNewFeed.hs b/Lucienne/View/AddNewFeed.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/View/AddNewFeed.hs
@@ -0,0 +1,22 @@
+module Lucienne.View.AddNewFeed
+ (addNewFeed)
+where
+
+import Text.Blaze ((!))
+import qualified Text.Blaze.Html4.Strict as H
+import qualified Text.Blaze.Html4.Strict.Attributes as A
+import Lucienne.View.Common (Errors,template,stringHtml,form)
+import qualified Lucienne.Url as Url
+
+addNewFeed :: Errors -> H.Html
+addNewFeed errors =
+ template "Add new feed" [] errors $
+ form Url.doAddNewFeed $
+ H.fieldset $
+ do H.legend "Add new feed"
+ H.table $
+ do H.tr $
+ do H.td $ H.label ! A.for "url" $ stringHtml "URL"
+ H.td $ (H.input ! A.type_ "input" ! A.name "url" ! A.value "" ! A.size "64")
+ H.tr $ H.td ! A.colspan "2" $
+ H.input ! A.type_ "submit" ! A.value "Add"
diff --git a/Lucienne/View/AddNewUser.hs b/Lucienne/View/AddNewUser.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/View/AddNewUser.hs
@@ -0,0 +1,32 @@
+module Lucienne.View.AddNewUser
+ (addNewUser)
+where
+
+import Text.Blaze ((!))
+import qualified Text.Blaze.Html4.Strict as H
+import qualified Text.Blaze.Html4.Strict.Attributes as A
+import Lucienne.View.Common (Errors,template,stringHtml,form)
+import qualified Lucienne.Url as Url
+
+addNewUser :: Errors -> H.Html
+addNewUser errors =
+ template "Add new user" [] errors $
+ form Url.doAddNewUser $
+ H.fieldset $
+ do H.legend "Add new user"
+ H.table $
+ do H.tr $
+ do H.td $ H.label ! A.for "username" $ stringHtml "Username"
+ H.td $ H.input ! A.type_ "input" ! A.name "username" ! A.value ""
+ H.tr $
+ do H.td $ H.label ! A.for "password" $ stringHtml "Password"
+ H.td $ H.input ! A.type_ "password" ! A.name "password" ! A.value ""
+ H.tr $
+ do H.td $ H.label ! A.for "check_password" $ stringHtml "Password check"
+ H.td $ H.input ! A.type_ "password" ! A.name "check_password" ! A.value ""
+ H.tr $
+ do H.td $ H.label ! A.for "may_add_users" $ stringHtml "May add new users"
+ H.td $ H.input ! A.type_ "checkbox" ! A.name "may_add_users"
+
+ H.tr $ H.td ! A.colspan "2" $
+ H.input ! A.type_ "submit" ! A.value "Add"
diff --git a/Lucienne/View/AreYouSure.hs b/Lucienne/View/AreYouSure.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/View/AreYouSure.hs
@@ -0,0 +1,18 @@
+module Lucienne.View.AreYouSure
+ (areYouSure)
+where
+
+import Text.Blaze ((!))
+import qualified Text.Blaze.Html4.Strict as H
+import qualified Text.Blaze.Html4.Strict.Attributes as A
+import Lucienne.View.Common (template,stringHtml)
+import qualified Lucienne.View.Link as L
+
+areYouSure :: String -> String -> (H.Html -> H.Html) -> H.Html
+areYouSure caption question link =
+ template caption [] [] $
+ H.table $
+ do H.tr $ H.td ! A.colspan "2" $ stringHtml question
+ H.tr $ do
+ H.td $ link $ stringHtml "Yes"
+ H.td $ L.toHome $ stringHtml "No"
diff --git a/Lucienne/View/ChangePassword.hs b/Lucienne/View/ChangePassword.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/View/ChangePassword.hs
@@ -0,0 +1,25 @@
+module Lucienne.View.ChangePassword
+ (changePassword)
+where
+
+import Text.Blaze ((!))
+import qualified Text.Blaze.Html4.Strict as H
+import qualified Text.Blaze.Html4.Strict.Attributes as A
+import Lucienne.View.Common (Errors,template,stringHtml,form)
+import qualified Lucienne.Url as Url
+
+changePassword :: Errors -> H.Html
+changePassword errors =
+ template "Change password" [] errors $
+ form Url.doChangePassword $
+ H.fieldset $
+ do H.legend "Change password"
+ H.table $
+ do H.tr $
+ do H.td $ H.label ! A.for "password" $ stringHtml "Password"
+ H.td $ H.input ! A.type_ "password" ! A.name "password" ! A.value ""
+ H.tr $
+ do H.td $ H.label ! A.for "check_password" $ stringHtml "Password check"
+ H.td $ H.input ! A.type_ "password" ! A.name "check_password" ! A.value ""
+ H.tr $ H.td ! A.colspan "2" $
+ H.input ! A.type_ "submit" ! A.value "Change"
diff --git a/Lucienne/View/Common.hs b/Lucienne/View/Common.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/View/Common.hs
@@ -0,0 +1,84 @@
+module Lucienne.View.Common
+ ( Infos, Errors, template, stringHtml, cstringHtml, stringValue, preescapedStringHtml
+ , symbol, form, hidden, button, setTitle)
+where
+
+import Control.Monad (when)
+import Data.CompactString.UTF8 (CompactString,unpack)
+import Text.Blaze ((!))
+import qualified Text.Blaze.Html4.Strict as H
+import qualified Text.Blaze.Html4.Strict.Attributes as A
+import Lucienne.Constant (programName)
+
+type Infos = [String]
+type Errors = [String]
+
+template :: String -> Infos -> Errors -> H.Html -> H.Html
+template title infos errors body =
+ H.docTypeHtml $
+ do H.head $
+ do H.title $ stringHtml title'
+ H.meta ! A.httpEquiv "Content-Type" ! A.content "text/html;charset=utf-8"
+ H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/static/css.css"
+ H.script ! A.src "/static/js.js" ! A.type_ "text/javascript" $ return ()
+ H.body $ do
+ when (not . null $ errors) $ showErrors errors
+ when (not . null $ infos) $ showInfos infos
+ body
+
+ where
+ title' = if null title then programName else unwords [programName,"-",title]
+
+showInfos :: Infos -> H.Html
+showInfos infos =
+ H.div ! A.class_ "infoBox" $ do
+ H.strong $ H.toHtml ("Information" :: String)
+ H.br
+ H.ul $ mapM_ showInfo infos
+
+showErrors :: Errors -> H.Html
+showErrors errors =
+ H.div ! A.class_ "errorBox" $ do
+ H.strong $ H.toHtml ("Error" :: String)
+ H.br
+ H.ul $ mapM_ showError errors
+
+showInfo :: String -> H.Html
+showInfo = H.li . H.toHtml
+
+showError :: String -> H.Html
+showError = H.li . H.toHtml
+
+stringHtml :: String -> H.Html
+stringHtml = H.toHtml
+
+cstringHtml :: CompactString -> H.Html
+cstringHtml = H.toHtml . unpack
+
+stringValue :: String -> H.AttributeValue
+stringValue = H.toValue
+
+preescapedStringHtml :: String -> H.Html
+preescapedStringHtml = H.preEscapedString
+
+symbol :: String -> H.Html
+symbol code = H.span ! A.class_ "symbol" $ preescapedStringHtml code
+
+form :: String -> H.Html -> H.Html
+form destination nested =
+ H.form ! A.action (stringValue destination)
+ ! A.method "post" ! A.enctype "multipart/form-data" $ nested
+
+hidden :: String -> String -> H.Html
+hidden name value =
+ H.input ! A.type_ "hidden" ! A.name (stringValue name) ! A.value (stringValue value)
+
+button :: String -> String -> Maybe String -> H.Html
+button name label =
+ let b = H.input ! A.type_ "submit" ! A.name (stringValue name)
+ ! A.value (stringValue label)
+ in
+ maybe b (\accessKey -> b ! A.accesskey (stringValue accessKey))
+
+setTitle :: String -> H.Html -> H.Html
+setTitle title html = html ! A.title (stringValue title)
diff --git a/Lucienne/View/DeleteFeed.hs b/Lucienne/View/DeleteFeed.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/View/DeleteFeed.hs
@@ -0,0 +1,16 @@
+module Lucienne.View.DeleteFeed
+ (deleteFeed)
+where
+
+import qualified Text.Blaze.Html4.Strict as H
+import Lucienne.View.AreYouSure (areYouSure)
+import Lucienne.Model.Feed (Feed)
+import qualified Lucienne.Model.Feed as F
+import Lucienne.View.Link (toDoDeleteFeed)
+
+deleteFeed :: Feed -> H.Html
+deleteFeed feed =
+ areYouSure "Delete feed"
+ ("Do you really want to delete the feed '" ++ (F.title feed) ++ "'?")
+ (toDoDeleteFeed feed)
+
diff --git a/Lucienne/View/DeleteUser.hs b/Lucienne/View/DeleteUser.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/View/DeleteUser.hs
@@ -0,0 +1,16 @@
+module Lucienne.View.DeleteUser
+ (deleteUser)
+where
+
+import qualified Text.Blaze.Html4.Strict as H
+import qualified Lucienne.Model.User as U
+import Lucienne.Model.User (User)
+import Lucienne.View.AreYouSure (areYouSure)
+import Lucienne.View.Link (to)
+import Lucienne.Url (doDeleteUser)
+
+deleteUser :: User -> H.Html
+deleteUser user =
+ areYouSure "Delete User"
+ ("Are you sure you want to delete user '" ++ U.name user ++ "'?")
+ (to doDeleteUser)
diff --git a/Lucienne/View/Feed.hs b/Lucienne/View/Feed.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/View/Feed.hs
@@ -0,0 +1,106 @@
+module Lucienne.View.Feed
+ (feed, home)
+where
+
+import Control.Monad (when)
+import Text.Blaze ((!))
+import qualified Text.Blaze.Html4.Strict as H
+import qualified Text.Blaze.Html4.Strict.Attributes as A
+import Lucienne.Constant (programName)
+import Lucienne.View.Common
+ (Infos,template,stringHtml,stringValue,symbol,form,hidden,button,setTitle)
+import qualified Lucienne.View.Link as L
+import Lucienne.Model.Feed (Feed)
+import qualified Lucienne.Model.Feed as F
+import Lucienne.Model.FeedItem (FeedItem)
+import qualified Lucienne.Model.FeedItem as FI
+import qualified Lucienne.Model.FeedItemState as S
+import Lucienne.Model.Util (showObjectId)
+import Lucienne.Model.User (User)
+import qualified Lucienne.Model.User as U
+import qualified Lucienne.Url as Url
+
+feed :: User -> Feed -> [FeedItem] -> [Feed] -> H.Html
+feed user feed fItems allFeeds =
+ template (F.title feed) [] [] $ do
+ H.div ! A.class_ "leftMenu" $ do
+ feedsOverview (Just feed) allFeeds
+ controlPanel user $ Just feed
+ feedItems (Just feed) fItems
+
+home :: User -> Infos -> [FeedItem] -> [Feed] -> H.Html
+home user infos fItems allFeeds =
+ template programName infos [] $ do
+ H.div ! A.class_ "leftMenu" $ do
+ feedsOverview Nothing allFeeds
+ controlPanel user Nothing
+ feedItems Nothing fItems
+
+feedsOverview :: Maybe Feed -> [Feed] -> H.Html
+feedsOverview viewed items =
+ let feedLink False feed = H.li . L.toFeed feed L.Default . stringHtml
+ feedLink True feed = H.li . L.toFeed feed L.Highlight . stringHtml
+ overview feed = case viewed of
+ Nothing -> feedLink False feed (F.title feed)
+ Just v -> feedLink (F.id v == F.id feed) feed (F.title feed)
+ in
+ H.ul $ do
+ H.li $ L.toHome $ stringHtml "All feeds"
+ mapM_ overview items
+
+controlPanel :: User -> Maybe Feed -> H.Html
+controlPanel user mFeed =
+ H.ul $ do
+ H.li $ L.to Url.addNewFeed $ stringHtml "Add new feed"
+ when (U.mayAddUsers user) $ H.li $ L.to Url.addNewUser $ stringHtml "Add new user"
+ H.li $ L.to Url.changePassword $ stringHtml "Change password"
+ H.li $ L.to Url.deleteUser $ stringHtml "Delete user"
+ case mFeed of
+ Nothing -> return ()
+ Just feed -> H.li $ L.toDeleteFeed feed $ stringHtml "Delete feed"
+
+feedItems :: Maybe Feed -> [FeedItem] -> H.Html
+feedItems mFeed items =
+ form Url.doChangeFeedItemState $ do
+ hidden "numItems" $ show $ length items
+ maybe (return ()) (hidden "feedId" . showObjectId . F.id) mFeed
+ H.table $ do
+ H.tr $ H.th ! A.colspan "2" ! A.class_ "feedTitle" $ header
+
+ H.tr $ do H.td ""
+ H.td $ markAsReadButton >> symbol " " >> deleteButton
+ mapM_ feedItemHeader $ zip [0..] items
+ H.tr $ do H.td ""
+ H.td $ markAsReadButton >> symbol " " >> deleteButton
+ where
+ header = maybe (stringHtml programName)
+ (\f -> stringHtml (F.title f) >> (L.toFeedUrl f $ symbol "↗")
+ ) mFeed
+ markAsReadButton = button "markAsRead" "Mark as read [r]" (Just "r")
+ deleteButton = button "delete" "Delete [d]" (Just "d")
+
+feedItemHeader :: (Integer,FeedItem) -> H.Html
+feedItemHeader (index,item) =
+ H.tr $ do H.td ! A.class_ "feedItemHeaderSymbols" $ feedItemHeaderSymbols index item
+ H.td $ L.toFeedItem item style !
+ A.title (stringValue $ show $ FI.dateFetched item) $
+ (stringHtml $ FI.title item)
+ where
+ style = case FI.state item of
+ S.Read -> L.Inactive
+ _ -> L.Active
+
+feedItemHeaderSymbols :: Integer -> FeedItem -> H.Html
+feedItemHeaderSymbols index item = do
+
+ setTitle "Toggle mark for all older items" $ L.to runJS $ symbol "↑"
+ symbol " "
+
+ H.input ! A.type_ "checkbox"
+ ! A.name (stringValue $ "feedItem" ++ show index)
+ ! A.value (stringValue $ showObjectId $ FI.id item)
+
+ symbol " "
+ symbol " "
+ where
+ runJS = "javascript:toggleMarkOlder (" ++ show index ++ ")"
diff --git a/Lucienne/View/FeedItem.hs b/Lucienne/View/FeedItem.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/View/FeedItem.hs
@@ -0,0 +1,30 @@
+module Lucienne.View.FeedItem
+ (feedItem)
+where
+
+import qualified Text.Blaze.Html4.Strict as H
+import Lucienne.View.Common (template,stringHtml,preescapedStringHtml,symbol)
+import qualified Lucienne.View.Link as L
+import Lucienne.Model.FeedItem (FeedItem)
+import qualified Lucienne.Model.FeedItem as FI
+
+feedItem :: FeedItem -> H.Html
+feedItem item =
+ template (FI.title item) [] [] $ do
+ H.table $ do
+ H.tr $ H.td $ feedItemSymbols item
+ H.tr $ H.td $ H.strong $ stringHtml $ FI.title item
+ H.tr $ H.td $ H.small $ stringHtml $ show $ FI.dateFetched item
+ H.tr $ H.td $ L.toFeedItemUrl item $ stringHtml $ FI.url item
+ H.p $ preescapedStringHtml $ FI.content item
+ H.hr
+ H.p $ feedItemSymbols item
+
+feedItemSymbols :: FeedItem -> H.Html
+feedItemSymbols item = do
+ L.toFeed' item $ symbol "↶"
+ symbol " "
+ L.toDoDeleteFeedItem item $ symbol "✗"
+ symbol " "
+ L.toFeedItemUrl item $ symbol "↗"
+
diff --git a/Lucienne/View/Link.hs b/Lucienne/View/Link.hs
new file mode 100644
--- /dev/null
+++ b/Lucienne/View/Link.hs
@@ -0,0 +1,69 @@
+module Lucienne.View.Link
+ ( Style (..)
+ , to, toHome, toFeedUrl, toFeedItemUrl, toFeed, toFeed', toDeleteFeed, toDoDeleteFeed
+ , toFeedItem, toDoDeleteFeedItem, toDoReadFeedItem)
+where
+
+import Text.Blaze ((!))
+import qualified Text.Blaze.Html4.Strict as H
+import qualified Text.Blaze.Html4.Strict.Attributes as A
+import Data.Bson (ObjectId)
+import Lucienne.View.Common (stringValue,setTitle)
+import Lucienne.Model.Feed (Feed)
+import qualified Lucienne.Model.Feed as F
+import Lucienne.Model.FeedItem (FeedItem)
+import qualified Lucienne.Model.FeedItem as FI
+import Lucienne.Model.Util (showObjectId)
+import qualified Lucienne.Url as Url
+
+data Style = Default | Highlight | Active | Inactive
+
+to :: String -> H.Html -> H.Html
+to url = to' url Default
+
+to' :: String -> Style -> H.Html -> H.Html
+to' url style nested =
+ H.a ! toAttribute style ! A.href (stringValue url) $ nested
+
+toAttribute :: Style -> H.Attribute
+toAttribute style =
+ case style of
+ Default -> A.class_ "default"
+ Highlight -> A.class_ "highlight"
+ Active -> A.class_ "active"
+ Inactive -> A.class_ "inactive"
+
+toFeedUrl :: Feed -> H.Html -> H.Html
+toFeedUrl feed = setTitle "Go to feed URL" . (to $ F.url feed)
+
+toHome :: H.Html -> H.Html
+toHome = to Url.home
+
+toDoDeleteFeed,toDeleteFeed :: Feed -> H.Html -> H.Html
+toDeleteFeed feed = toId Url.deleteFeed (F.id feed) Default
+toDoDeleteFeed feed = toId Url.doDeleteFeed (F.id feed) Default
+
+toFeed :: Feed -> Style -> H.Html -> H.Html
+toFeed feed style = toId Url.feed (F.id feed) style
+
+toFeedItem :: FeedItem -> Style -> H.Html -> H.Html
+toFeedItem item = toId Url.feedItem (FI.id item)
+
+toFeedItemUrl,toFeed',toDoDeleteFeedItem,toDoReadFeedItem :: FeedItem -> H.Html -> H.Html
+toFeedItemUrl item = setTitle "Go to URL" . to (FI.url item)
+
+toFeed' item = toId Url.feed (FI.feedId item) Default
+
+toDoDeleteFeedItem item =
+ setTitle "Delete" . toId Url.doDeleteFeedItem (FI.id item) Default
+
+toDoReadFeedItem item =
+ setTitle "Mark as read" . toId Url.doReadFeedItem (FI.id item) Default
+
+toId :: Url.Url -> ObjectId -> Style -> H.Html -> H.Html
+toId url objId style nested =
+ H.a !
+ toAttribute style !
+ A.href (stringValue $ url ++ "/" ++ (showObjectId objId)) $
+ nested
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/lucienne.cabal b/lucienne.cabal
new file mode 100644
--- /dev/null
+++ b/lucienne.cabal
@@ -0,0 +1,113 @@
+Name: lucienne
+Version: 0.0.1
+Synopsis: Server side feed aggregator/reader
+License: GPL
+License-file: LICENSE
+Author: Alexander Bau
+Maintainer: Alexander Bau
+Build-Type: Simple
+Cabal-Version: >= 1.9.2
+Category: Web
+Homepage: http://www.imn.htwk-leipzig.de/~abau/lucienne
+Description: Lucienne is a simple server side feed aggregator/reader that helps you managing your subscribed feeds.
+ It provides multi user support using basic access authentication. A running mongoDB () serves as database backend.
+ .
+ /Installing instructions:/
+ .
+ 1. Run a mongoDB instance
+ .
+ 2. @cabal install@ this package. This will result in two executables: @lucienne@ and @lucienne-fetch@.
+ .
+ 3. Run @lucienne@. You might want to limit the maximum heap size,
+ e.g. @lucienne +RTS -M30m@
+ .
+ 4. Run @lucienne-fetch@ periodically (e.g. by a cron job)
+ .
+ Lucienne accepts the following options:
+ .
+ > lucienne:
+ > -p PORT --port=PORT Port of incoming requests
+ > -d HOST --databaseHost=HOST Database host
+ > -e PORT --databasePort=PORT Database port
+ > -h --help Print this help
+
+Data-Files: static/js.js
+ , static/css.css
+
+
+Executable lucienne
+ Main-is: Lucienne/Main.hs
+ Extensions: OverloadedStrings
+ Ghc-options: -W -fno-warn-incomplete-patterns
+ Build-Depends: base >= 3 && < 5
+ , mongoDB == 1.2.*
+ , compact-string-fix == 0.3.*
+ , happstack == 7.0.*
+ , happstack-server == 7.0.*
+ , blaze-html == 0.4.*
+ , mtl == 2.1.*
+ , bson == 0.1.*
+ , SHA == 1.5.*
+ , bytestring == 0.9.*
+ , HTTP == 4000.2.*
+ , feed == 0.3.*
+ , time == 1.4.*
+ , network == 2.3.*
+ , text == 0.11.*
+ , base64-bytestring == 0.1.*
+
+ Other-Modules: Lucienne.Args
+ , Lucienne.ConnectionReader
+ , Lucienne.Constant
+ , Lucienne.Controller
+ , Lucienne.Controller.AddNewFeed
+ , Lucienne.Controller.AddNewUser
+ , Lucienne.Controller.BasicAuth
+ , Lucienne.Controller.ChangePassword
+ , Lucienne.Controller.DeleteFeed
+ , Lucienne.Controller.DeleteUser
+ , Lucienne.Controller.Feed
+ , Lucienne.Controller.FeedItem
+ , Lucienne.Controller.Imports
+ , Lucienne.Controller.Message
+ , Lucienne.Controller.NotFound
+ , Lucienne.Controller.Util
+ , Lucienne.DatabaseAble
+ , Lucienne.Database
+ , Lucienne.Fetch
+ , Lucienne.Model.Feed
+ , Lucienne.Model.FeedItem
+ , Lucienne.Model.FeedItemState
+ , Lucienne.Model.User
+ , Lucienne.Model.Util
+ , Lucienne.Url
+ , Lucienne.View.AddNewFeed
+ , Lucienne.View.AddNewUser
+ , Lucienne.View.AreYouSure
+ , Lucienne.View.ChangePassword
+ , Lucienne.View.Common
+ , Lucienne.View.DeleteFeed
+ , Lucienne.View.DeleteUser
+ , Lucienne.View.Feed
+ , Lucienne.View.FeedItem
+ , Lucienne.View.Link
+ , Paths_lucienne
+
+Executable lucienne-fetch
+ Main-is: Lucienne/Fetch/Main.hs
+ Extensions: OverloadedStrings
+ Ghc-options: -W -fno-warn-incomplete-patterns
+ Build-Depends: base >= 3 && < 5
+ , mongoDB == 1.2.*
+ , compact-string-fix == 0.3.*
+ , mtl == 2.1.*
+ , bson == 0.1.*
+ , SHA == 1.5.*
+ , bytestring == 0.9.*
+ , HTTP == 4000.2.*
+ , feed == 0.3.*
+ , time == 1.4.*
+ , network == 2.3.*
+ , text == 0.11.*
+ Other-Modules: Lucienne.Fetch.Util
+
diff --git a/static/css.css b/static/css.css
new file mode 100644
--- /dev/null
+++ b/static/css.css
@@ -0,0 +1,35 @@
+body {
+ font-family : sans-serif ;
+}
+
+span.symbol {
+ font-size: larger ;
+}
+
+div.leftMenu {
+ float : left ;
+ font-size : smaller ;
+ margin-right : 3em;
+}
+
+th.feedTitle {
+ font-size : larger ;
+ padding-bottom : 1em;
+}
+
+td.feedItemHeaderSymbols {
+ white-space: nowrap ;
+}
+
+a.default { color: #000000 ; font-weight: normal ; }
+a.highlight { color: #000000 ; font-weight: bold ; }
+
+a.active:link { color: #000000 ; font-weight: normal ; }
+a.active:visited { color: #cccccc ; font-weight: normal ; }
+a.active:focus { font-weight: normal ; }
+a.active:hover { font-weight: normal ; }
+a.active:active { font-weight: normal ; }
+a.inactive { color: #cccccc ; font-weight: normal ; }
+
+div.infoBox { background-color: #eeeeee ; }
+div.errorBox { background-color: #eeeeee ; }
diff --git a/static/js.js b/static/js.js
new file mode 100644
--- /dev/null
+++ b/static/js.js
@@ -0,0 +1,9 @@
+function toggleMarkOlder (index) {
+ for (var i = index ; i >= 0; i--) {
+ var checkBox = document.getElementsByName("feedItem" + i)[0];
+ if (checkBox.checked)
+ checkBox.checked = false;
+ else
+ checkBox.checked = true;
+ }
+}