From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 8 Nov 2017 23:47:26 +0100 Subject: Use a better project structure --- server/LICENSE | 674 +++++++++++++++++++++++++++++++ server/Setup.hs | 2 + server/server.cabal | 47 +++ server/src/Conf.hs | 39 ++ server/src/Controller/Category.hs | 53 +++ server/src/Controller/Income.hs | 48 +++ server/src/Controller/Index.hs | 86 ++++ server/src/Controller/Payment.hs | 58 +++ server/src/Controller/SignIn.hs | 47 +++ server/src/Cookie.hs | 56 +++ server/src/Design/Color.hs | 35 ++ server/src/Design/Constants.hs | 27 ++ server/src/Design/Dialog.hs | 24 ++ server/src/Design/Errors.hs | 55 +++ server/src/Design/Form.hs | 130 ++++++ server/src/Design/Global.hs | 75 ++++ server/src/Design/Helper.hs | 90 +++++ server/src/Design/Media.hs | 36 ++ server/src/Design/Tooltip.hs | 16 + server/src/Design/View/Header.hs | 78 ++++ server/src/Design/View/Payment.hs | 17 + server/src/Design/View/Payment/Header.hs | 84 ++++ server/src/Design/View/Payment/Pages.hs | 54 +++ server/src/Design/View/Payment/Table.hs | 42 ++ server/src/Design/View/SignIn.hs | 42 ++ server/src/Design/View/Stat.hs | 15 + server/src/Design/View/Table.hs | 84 ++++ server/src/Design/Views.hs | 49 +++ server/src/Job/Daemon.hs | 36 ++ server/src/Job/Frequency.hs | 13 + server/src/Job/Kind.hs | 22 + server/src/Job/Model.hs | 47 +++ server/src/Job/MonthlyPayment.hs | 26 ++ server/src/Job/WeeklyReport.hs | 28 ++ server/src/Json.hs | 19 + server/src/LoginSession.hs | 53 +++ server/src/Main.hs | 79 ++++ server/src/MimeMail.hs | 672 ++++++++++++++++++++++++++++++ server/src/Model/Category.hs | 79 ++++ server/src/Model/Frequency.hs | 22 + server/src/Model/Income.hs | 97 +++++ server/src/Model/Init.hs | 27 ++ server/src/Model/Mail.hs | 12 + server/src/Model/Payer.hs | 216 ++++++++++ server/src/Model/Payment.hs | 175 ++++++++ server/src/Model/PaymentCategory.hs | 62 +++ server/src/Model/Query.hs | 32 ++ server/src/Model/SignIn.hs | 66 +++ server/src/Model/UUID.hs | 10 + server/src/Model/User.hs | 49 +++ server/src/Resource.hs | 54 +++ server/src/Secure.hs | 47 +++ server/src/SendMail.hs | 44 ++ server/src/Utils/Time.hs | 25 ++ server/src/Validation.hs | 23 ++ server/src/View/Mail/SignIn.hs | 24 ++ server/src/View/Mail/WeeklyReport.hs | 102 +++++ server/src/View/Page.hs | 43 ++ 58 files changed, 4267 insertions(+) create mode 100644 server/LICENSE create mode 100644 server/Setup.hs create mode 100644 server/server.cabal create mode 100644 server/src/Conf.hs create mode 100644 server/src/Controller/Category.hs create mode 100644 server/src/Controller/Income.hs create mode 100644 server/src/Controller/Index.hs create mode 100644 server/src/Controller/Payment.hs create mode 100644 server/src/Controller/SignIn.hs create mode 100644 server/src/Cookie.hs create mode 100644 server/src/Design/Color.hs create mode 100644 server/src/Design/Constants.hs create mode 100644 server/src/Design/Dialog.hs create mode 100644 server/src/Design/Errors.hs create mode 100644 server/src/Design/Form.hs create mode 100644 server/src/Design/Global.hs create mode 100644 server/src/Design/Helper.hs create mode 100644 server/src/Design/Media.hs create mode 100644 server/src/Design/Tooltip.hs create mode 100644 server/src/Design/View/Header.hs create mode 100644 server/src/Design/View/Payment.hs create mode 100644 server/src/Design/View/Payment/Header.hs create mode 100644 server/src/Design/View/Payment/Pages.hs create mode 100644 server/src/Design/View/Payment/Table.hs create mode 100644 server/src/Design/View/SignIn.hs create mode 100644 server/src/Design/View/Stat.hs create mode 100644 server/src/Design/View/Table.hs create mode 100644 server/src/Design/Views.hs create mode 100644 server/src/Job/Daemon.hs create mode 100644 server/src/Job/Frequency.hs create mode 100644 server/src/Job/Kind.hs create mode 100644 server/src/Job/Model.hs create mode 100644 server/src/Job/MonthlyPayment.hs create mode 100644 server/src/Job/WeeklyReport.hs create mode 100644 server/src/Json.hs create mode 100644 server/src/LoginSession.hs create mode 100644 server/src/Main.hs create mode 100644 server/src/MimeMail.hs create mode 100644 server/src/Model/Category.hs create mode 100644 server/src/Model/Frequency.hs create mode 100644 server/src/Model/Income.hs create mode 100644 server/src/Model/Init.hs create mode 100644 server/src/Model/Mail.hs create mode 100644 server/src/Model/Payer.hs create mode 100644 server/src/Model/Payment.hs create mode 100644 server/src/Model/PaymentCategory.hs create mode 100644 server/src/Model/Query.hs create mode 100644 server/src/Model/SignIn.hs create mode 100644 server/src/Model/UUID.hs create mode 100644 server/src/Model/User.hs create mode 100644 server/src/Resource.hs create mode 100644 server/src/Secure.hs create mode 100644 server/src/SendMail.hs create mode 100644 server/src/Utils/Time.hs create mode 100644 server/src/Validation.hs create mode 100644 server/src/View/Mail/SignIn.hs create mode 100644 server/src/View/Mail/WeeklyReport.hs create mode 100644 server/src/View/Page.hs (limited to 'server') diff --git a/server/LICENSE b/server/LICENSE new file mode 100644 index 0000000..45644ff --- /dev/null +++ b/server/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/server/Setup.hs b/server/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/server/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/server/server.cabal b/server/server.cabal new file mode 100644 index 0000000..2e1f7be --- /dev/null +++ b/server/server.cabal @@ -0,0 +1,47 @@ +name: server +version: 0.0.1 +license: GPL-3 +license-file: LICENSE +author: Joris Guyonvarch +maintainer: joris@guyonvarch.me +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable server + main-is: Main.hs + ghc-options: -Wall -Werror + build-depends: aeson + , base >=4.9 && <4.11 + , base64-bytestring + , blaze-builder + , blaze-html + , bytestring + , clay + , clientsession + , common + , config-manager + , containers + , cookie + , email-validate + , filepath + , http-conduit + , http-types + , lens + , monad-logger + , mtl + , parsec + , process + , resourcet + , random + , scotty + , sqlite-simple + , text + , time + , transformers + , unordered-containers + , uuid + , wai + , wai-middleware-static + hs-source-dirs: src + default-language: Haskell2010 diff --git a/server/src/Conf.hs b/server/src/Conf.hs new file mode 100644 index 0000000..26c5c28 --- /dev/null +++ b/server/src/Conf.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Conf + ( get + , Conf(..) + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.ConfigManager as Conf +import Data.Time.Clock (NominalDiffTime) + +import Common.Model (Currency(..)) + +data Conf = Conf + { hostname :: Text + , port :: Int + , signInExpiration :: NominalDiffTime + , currency :: Currency + , noReplyMail :: Text + , https :: Bool + } deriving Show + +get :: FilePath -> IO Conf +get path = do + conf <- + (flip fmap) (Conf.readConfig path) (\configOrError -> do + conf <- configOrError + Conf <$> + Conf.lookup "hostname" conf <*> + Conf.lookup "port" conf <*> + Conf.lookup "signInExpiration" conf <*> + fmap Currency (Conf.lookup "currency" conf) <*> + Conf.lookup "noReplyMail" conf <*> + Conf.lookup "https" conf + ) + case conf of + Left msg -> error (T.unpack msg) + Right c -> return c diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs new file mode 100644 index 0000000..d6ed2f2 --- /dev/null +++ b/server/src/Controller/Category.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Category + ( create + , edit + , delete + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text.Lazy as TL +import Web.Scotty hiding (delete) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CategoryId, CreateCategory(..), EditCategory(..)) + +import Json (jsonId) +import qualified Model.Category as Category +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query +import qualified Secure + +create :: CreateCategory -> ActionM () +create (CreateCategory name color) = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ Category.create name color) >>= jsonId + ) + +edit :: EditCategory -> ActionM () +edit (EditCategory categoryId name color) = + Secure.loggedAction (\_ -> do + updated <- liftIO . Query.run $ Category.edit categoryId name color + if updated + then status ok200 + else status badRequest400 + ) + +delete :: CategoryId -> ActionM () +delete categoryId = + Secure.loggedAction (\_ -> do + deleted <- liftIO . Query.run $ do + paymentCategories <- PaymentCategory.listByCategory categoryId + if null paymentCategories + then Category.delete categoryId + else return False + if deleted + then + status ok200 + else do + status badRequest400 + text . TL.fromStrict $ Message.get Key.Category_NotDeleted + ) diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs new file mode 100644 index 0000000..148b713 --- /dev/null +++ b/server/src/Controller/Income.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Income + ( create + , editOwn + , deleteOwn + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text.Lazy as TL +import Web.Scotty + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) + +import Json (jsonId) +import qualified Model.Income as Income +import qualified Model.Query as Query +import qualified Secure + +create :: CreateIncome -> ActionM () +create (CreateIncome date amount) = + Secure.loggedAction (\user -> + (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId + ) + +editOwn :: EditIncome -> ActionM () +editOwn (EditIncome incomeId date amount) = + Secure.loggedAction (\user -> do + updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount + if updated + then status ok200 + else status badRequest400 + ) + +deleteOwn :: IncomeId -> ActionM () +deleteOwn incomeId = + Secure.loggedAction (\user -> do + deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId + if deleted + then + status ok200 + else do + status badRequest400 + text . TL.fromStrict $ Message.get Key.Income_NotDeleted + ) diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs new file mode 100644 index 0000000..8473c5c --- /dev/null +++ b/server/src/Controller/Index.hs @@ -0,0 +1,86 @@ +module Controller.Index + ( get + , signOut + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime, diffUTCTime) +import Network.HTTP.Types.Status (ok200) +import Prelude hiding (error) +import Web.Scotty hiding (get) + +import qualified Common.Message as Message +import Common.Message.Key (Key) +import qualified Common.Message.Key as Key +import Common.Model (InitResult(..), User(..)) + +import Conf (Conf(..)) +import Model.Init (getInit) +import qualified LoginSession +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User +import Secure (getUserFromToken) +import View.Page (page) + +get :: Conf -> Maybe Text -> ActionM () +get conf mbToken = do + initResult <- case mbToken of + Just token -> do + userOrError <- validateSignIn conf token + case userOrError of + Left errorKey -> + return . InitEmpty . Left . Message.get $ errorKey + Right user -> + liftIO . Query.run . fmap InitSuccess $ getInit user conf + Nothing -> do + mbLoggedUser <- getLoggedUser + case mbLoggedUser of + Nothing -> + return . InitEmpty . Right $ Nothing + Just user -> + liftIO . Query.run . fmap InitSuccess $ getInit user conf + html $ page initResult + +validateSignIn :: Conf -> Text -> ActionM (Either Key User) +validateSignIn conf textToken = do + mbLoggedUser <- getLoggedUser + case mbLoggedUser of + Just loggedUser -> + return . Right $ loggedUser + Nothing -> do + mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken + now <- liftIO getCurrentTime + case mbSignIn of + Nothing -> + return . Left $ Key.SignIn_LinkInvalid + Just signIn -> + if SignIn.isUsed signIn + then + return . Left $ Key.SignIn_LinkUsed + else + let diffTime = now `diffUTCTime` (SignIn.creation signIn) + in if diffTime > signInExpiration conf + then + return . Left $ Key.SignIn_LinkExpired + else do + LoginSession.put conf (SignIn.token signIn) + mbUser <- liftIO . Query.run $ do + SignIn.signInTokenToUsed . SignIn.id $ signIn + User.get . SignIn.email $ signIn + return $ case mbUser of + Nothing -> Left Key.Secure_Unauthorized + Just user -> Right user + +getLoggedUser :: ActionM (Maybe User) +getLoggedUser = do + mbToken <- LoginSession.get + case mbToken of + Nothing -> + return Nothing + Just token -> do + liftIO . Query.run . getUserFromToken $ token + +signOut :: Conf -> ActionM () +signOut conf = LoginSession.delete conf >> status ok200 diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs new file mode 100644 index 0000000..dc10311 --- /dev/null +++ b/server/src/Controller/Payment.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Payment + ( list + , create + , editOwn + , deleteOwn + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import Web.Scotty + +import Common.Model (PaymentId, User(..), CreatePayment(..), EditPayment(..)) + +import Json (jsonId) +import qualified Model.Payment as Payment +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query +import qualified Secure + +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ Payment.list) >>= json + ) + +create :: CreatePayment -> ActionM () +create (CreatePayment name cost date category frequency) = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + PaymentCategory.save name category + Payment.create (_user_id user) name cost date frequency + ) >>= jsonId + ) + +editOwn :: EditPayment -> ActionM () +editOwn (EditPayment paymentId name cost date category frequency) = + Secure.loggedAction (\user -> do + updated <- liftIO . Query.run $ do + edited <- Payment.editOwn (_user_id user) paymentId name cost date frequency + _ <- if edited + then PaymentCategory.save name category >> return () + else return () + return edited + if updated + then status ok200 + else status badRequest400 + ) + +deleteOwn :: PaymentId -> ActionM () +deleteOwn paymentId = + Secure.loggedAction (\user -> do + deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId + if deleted + then status ok200 + else status badRequest400 + ) diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs new file mode 100644 index 0000000..0086fa5 --- /dev/null +++ b/server/src/Controller/SignIn.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.SignIn + ( signIn + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import Web.Scotty + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (SignIn(..)) + +import Conf (Conf) +import qualified Conf +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User +import qualified SendMail +import qualified Text.Email.Validate as Email +import qualified View.Mail.SignIn as SignIn + +signIn :: Conf -> SignIn -> ActionM () +signIn conf (SignIn email) = + if Email.isValid (TE.encodeUtf8 email) + then do + maybeUser <- liftIO . Query.run $ User.get email + case maybeUser of + Just user -> do + token <- liftIO . Query.run $ SignIn.createSignInToken email + let url = T.concat [ + if Conf.https conf then "https://" else "http://", + Conf.hostname conf, + "?signInToken=", + token + ] + maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] + case maybeSentMail of + Right _ -> textKey ok200 Key.SignIn_EmailSent + Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Key.Secure_Unauthorized + else textKey badRequest400 Key.SignIn_EmailInvalid + where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/server/src/Cookie.hs b/server/src/Cookie.hs new file mode 100644 index 0000000..96d45da --- /dev/null +++ b/server/src/Cookie.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cookie + ( makeSimpleCookie + , setCookie + , setSimpleCookie + , getCookie + , getCookies + , deleteCookie + ) where + +import Control.Monad ( liftM ) + +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TS +import qualified Data.Text.Lazy.Encoding as TL + +import Conf (Conf) +import qualified Conf + +import qualified Data.Map as Map + +import qualified Data.ByteString.Lazy as BSL + +import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) + +import Blaze.ByteString.Builder ( toLazyByteString ) + +import Web.Scotty.Trans +import Web.Cookie + +makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie +makeSimpleCookie conf name value = + def + { setCookieName = TS.encodeUtf8 name + , setCookieValue = TS.encodeUtf8 value + , setCookiePath = Just $ TS.encodeUtf8 "/" + , setCookieSecure = Conf.https conf + } + +setCookie :: (Monad m) => SetCookie -> ActionT e m () +setCookie name = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie name) + +setSimpleCookie :: (Monad m) => Conf -> TS.Text -> TS.Text -> ActionT e m () +setSimpleCookie conf name value = setCookie $ makeSimpleCookie conf name value + +getCookie :: (Monad m, ScottyError e) => TS.Text -> ActionT e m (Maybe TS.Text) +getCookie name = liftM (Map.lookup name) getCookies + +getCookies :: (Monad m, ScottyError e) => ActionT e m (Map.Map TS.Text TS.Text) +getCookies = + liftM (Map.fromList . maybe [] parse) $ header "Cookie" + where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8 + +deleteCookie :: (Monad m) => Conf -> TS.Text -> ActionT e m () +deleteCookie conf name = setCookie $ (makeSimpleCookie conf name "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 } diff --git a/server/src/Design/Color.hs b/server/src/Design/Color.hs new file mode 100644 index 0000000..06c468e --- /dev/null +++ b/server/src/Design/Color.hs @@ -0,0 +1,35 @@ +module Design.Color where + +import qualified Clay.Color as C + +-- http://chir.ag/projects/name-that-color/#969696 + +white :: C.Color +white = C.white + +black :: C.Color +black = C.black + +chestnutRose :: C.Color +chestnutRose = C.rgb 207 92 86 + +unknown :: C.Color +unknown = C.rgb 86 92 207 + +mossGreen :: C.Color +mossGreen = C.rgb 159 210 165 + +gothic :: C.Color +gothic = C.rgb 108 162 164 + +negroni :: C.Color +negroni = C.rgb 255 223 196 + +wildSand :: C.Color +wildSand = C.rgb 245 245 245 + +silver :: C.Color +silver = C.rgb 200 200 200 + +dustyGray :: C.Color +dustyGray = C.rgb 150 150 150 diff --git a/server/src/Design/Constants.hs b/server/src/Design/Constants.hs new file mode 100644 index 0000000..4e2b8cc --- /dev/null +++ b/server/src/Design/Constants.hs @@ -0,0 +1,27 @@ +module Design.Constants where + +import Clay + +iconFontSize :: Size LengthUnit +iconFontSize = px 32 + +radius :: Size LengthUnit +radius = px 3 + +blockPadding :: Size LengthUnit +blockPadding = px 15 + +blockPercentWidth :: Double +blockPercentWidth = 90 + +blockPercentMargin :: Double +blockPercentMargin = (100 - blockPercentWidth) / 2 + +inputHeight :: Double +inputHeight = 40 + +focusLighten :: Color -> Color +focusLighten baseColor = baseColor +. 20 + +focusDarken :: Color -> Color +focusDarken baseColor = baseColor -. 20 diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs new file mode 100644 index 0000000..4678633 --- /dev/null +++ b/server/src/Design/Dialog.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Dialog + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +design :: Css +design = do + + ".content" ? do + minWidth (px 270) + + ".paymentDialog" & do + ".radioGroup" ? ".title" ? display none + ".selectInput" ? do + select ? width (pct 100) + marginBottom (em 1) + + ".deletePaymentDialog" <> ".deleteIncomeDialog" ? do + h1 ? marginBottom (em 1.5) diff --git a/server/src/Design/Errors.hs b/server/src/Design/Errors.hs new file mode 100644 index 0000000..57aaeee --- /dev/null +++ b/server/src/Design/Errors.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Errors + ( design + ) where + +import Clay + +import Design.Color as Color + +design :: Css +design = do + position fixed + top (px 20) + left (pct 50) + "transform" -: "translateX(-50%)" + margin (px 0) (px 0) (px 0) (px 0) + disapearKeyframes + + ".error" ? do + disapearAnimation + let errorColor = Color.chestnutRose -. 15 + color errorColor + border solid (px 2) errorColor + backgroundColor Color.white + borderRadius (px 5) (px 5) (px 5) (px 5) + padding (px 5) (px 5) (px 5) (px 5) + + before & display none + +disapearAnimation :: Css +disapearAnimation = do + animationName "disapear" + animationDelay (sec 5) + animationDuration (sec 1) + animationFillMode forwards + +disapearKeyframes :: Css +disapearKeyframes = keyframes + "disapear" + [ ( 10 + , do + opacity 0 + height (px 40) + lineHeight (px 40) + marginBottom (px 10) + ) + , ( 100 + , do + opacity 0 + height (px 0) + lineHeight (px 0) + marginBottom (px 0) + ) + ] diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs new file mode 100644 index 0000000..ebb8ac8 --- /dev/null +++ b/server/src/Design/Form.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Form + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color + +design :: Css +design = do + + let inputHeight = 30 + let inputTop = 22 + let inputPaddingBottom = 3 + let inputZIndex = 1 + + label ? do + cursor pointer + color Color.silver + + ".textInput" ? do + position relative + marginBottom (em 1.5) + paddingTop (px inputTop) + marginTop (px (-10)) + + input ? do + width (pct 100) + position relative + zIndex inputZIndex + backgroundColor transparent + paddingBottom (px inputPaddingBottom) + borderStyle none + borderBottom solid (px 1) Color.dustyGray + marginBottom (px 5) + height (px inputHeight) + lineHeight (px inputHeight) + focus & do + borderWidth (px 2) + paddingBottom (px $ inputPaddingBottom - 1) + + label ? do + lineHeight (px inputHeight) + position absolute + top (px inputTop) + left (px 0) + transition "all" (sec 0.2) easeIn (sec 0) + + button ? do + position absolute + right (px 0) + top (px 27) + zIndex inputZIndex + hover & "svg path" ? do + "fill" -: "rgb(220, 220, 220)" + + (input # ".filled" |+ label) <> (input # focus |+ label) ? do + top (px 0) + fontSize (pct 80) + + ".error" & do + input ? do + borderBottomColor Color.chestnutRose + + ".errorMessage" ? do + position absolute + color Color.chestnutRose + fontSize (pct 80) + + ".colorInput" ? do + display flex + alignItems center + marginBottom (em 1.5) + + input ? do + borderColor transparent + backgroundColor transparent + + ".radioGroup" ? do + position relative + marginBottom (em 2) + + ".title" ? do + color Color.silver + marginBottom (em 0.8) + + ".radioInputs" ? do + display flex + "justify-content" -: "center" + + ".radioInput:not(:last-child)::after" ? do + content (stringContent "/") + marginLeft (px 10) + marginRight (px 10) + + input ? do + opacity 0 + width (px 30) + margin (px 0) (px (-15)) (px 0) (px (-15)) + + "input:focus + label" ? do + textDecoration underline + + "input:checked + label" ? do + color Color.chestnutRose + fontWeight bold + + ".selectInput" ? do + label ? do + display block + marginBottom (px 10) + fontSize (pct 80) + select ? do + backgroundColor Color.white + border solid (px 1) Color.silver + sym borderRadius (px 3) + sym2 padding (px 5) (px 8) + option ? do + firstChild & display none + sym2 padding (px 5) (px 8) + ".error" & do + select ? borderColor Color.chestnutRose + ".errorMessage" ? do + color Color.chestnutRose + fontSize (pct 80) + marginTop (em 0.5) diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs new file mode 100644 index 0000000..47ea4a9 --- /dev/null +++ b/server/src/Design/Global.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Global + ( globalDesign + ) where + +import Clay + +import Data.Text.Lazy (Text) + +import qualified Design.Views as Views +import qualified Design.Form as Form +import qualified Design.Errors as Errors +import qualified Design.Dialog as Dialog +import qualified Design.Tooltip as Tooltip + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +globalDesign :: Text +globalDesign = renderWith compact [] global + +global :: Css +global = do + ".errors" ? Errors.design + ".dialog" ? Dialog.design + ".tooltip" ? Tooltip.design + Views.design + Form.design + + body ? do + minWidth (px 320) + fontFamily ["Cantarell"] [sansSerif] + Media.tablet $ do + fontSize (px 15) + button ? fontSize (px 15) + input ? fontSize (px 15) + Media.mobile $ do + fontSize (px 14) + button ? fontSize (px 14) + input ? fontSize (px 14) + + a ? cursor pointer + + input ? fontSize inherit + + h1 ? do + color Color.chestnutRose + marginBottom (em 1) + lineHeight (em 1.2) + + Media.desktop $ fontSize (px 24) + Media.tablet $ fontSize (px 22) + Media.mobile $ fontSize (px 20) + + ul ? do + "margin-bottom" -: "3vh" + "margin-left" -: "1vh" + li Color -> Size a -> (Color -> Color) -> Css +button backgroundCol textCol h focusOp = do + display flex + alignItems center + justifyContent center + backgroundColor backgroundCol + padding (px 0) (px 10) (px 0) (px 10) + color textCol + borderRadius radius radius radius radius + verticalAlign middle + cursor pointer + lineHeight h + height h + textAlign (alignSide sideCenter) + hover & backgroundColor (focusOp backgroundCol) + focus & backgroundColor (focusOp backgroundCol) + waitable + +waitable :: Css +waitable = do + svg # ".loader" ? display none + ".waiting" & do + ".content" ? do + display flex + fontSize (px 0) + opacity 0 + svg # ".loader" ? do + display block + rotateKeyframes + rotateAnimation + +input :: Double -> Css +input h = do + height (px h) + padding (px 10) (px 10) (px 10) (px 10) + borderRadius radius radius radius radius + border solid (px 1) Color.dustyGray + focus & borderColor Color.silver + verticalAlign middle + +centeredWithMargin :: Css +centeredWithMargin = do + width (pct blockPercentWidth) + marginLeft auto + marginRight auto + +verticalCentering :: Css +verticalCentering = do + position absolute + top (pct 50) + "transform" -: "translateY(-50%)" + +rotateAnimation :: Css +rotateAnimation = do + animationName "rotate" + animationDuration (sec 1) + animationTimingFunction easeOut + animationIterationCount infinite + +rotateKeyframes :: Css +rotateKeyframes = keyframes + "rotate" + [ (0, "transform" -: "rotate(0deg)") + , (100, "transform" -: "rotate(360deg)") + ] diff --git a/server/src/Design/Media.hs b/server/src/Design/Media.hs new file mode 100644 index 0000000..77220ee --- /dev/null +++ b/server/src/Design/Media.hs @@ -0,0 +1,36 @@ +module Design.Media + ( mobile + , mobileTablet + , tablet + , tabletDesktop + , desktop + ) where + +import Clay hiding (query) +import qualified Clay +import Clay.Stylesheet (Feature) +import qualified Clay.Media as Media + +mobile :: Css -> Css +mobile = query [Media.maxWidth mobileTabletLimit] + +mobileTablet :: Css -> Css +mobileTablet = query [Media.maxWidth tabletDesktopLimit] + +tablet :: Css -> Css +tablet = query [Media.minWidth mobileTabletLimit, Media.maxWidth tabletDesktopLimit] + +tabletDesktop :: Css -> Css +tabletDesktop = query [Media.minWidth mobileTabletLimit] + +desktop :: Css -> Css +desktop = query [Media.minWidth tabletDesktopLimit] + +query :: [Feature] -> Css -> Css +query = Clay.query Media.screen + +mobileTabletLimit :: Size LengthUnit +mobileTabletLimit = (px 520) + +tabletDesktopLimit :: Size LengthUnit +tabletDesktopLimit = (px 950) diff --git a/server/src/Design/Tooltip.hs b/server/src/Design/Tooltip.hs new file mode 100644 index 0000000..1da8764 --- /dev/null +++ b/server/src/Design/Tooltip.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Tooltip + ( design + ) where + +import Clay + +import Design.Color as Color + +design :: Css +design = do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + padding (px 5) (px 5) (px 5) (px 5) + color Color.white diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs new file mode 100644 index 0000000..20627e6 --- /dev/null +++ b/server/src/Design/View/Header.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Header + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Media as Media + +design :: Css +design = do + let headerPadding = "padding" -: "0 20px" + display flex + "flex-wrap" -: "wrap" + lineHeightMedia + position relative + backgroundColor Color.chestnutRose + color Color.white + Media.desktop $ marginBottom (em 3) + Media.mobileTablet $ marginBottom (em 2) + Media.mobile $ marginBottom (em 1.5) + + ".title" <> ".item" ? headerPadding + + ".title" ? do + height (pct 100) + textAlign (alignSide sideLeft) + + Media.mobile $ fontSize (px 22) + Media.mobileTablet $ width (pct 100) + Media.tabletDesktop $ do + display inlineBlock + fontSize (px 35) + + ".item" ? do + display inlineBlock + transition "background-color" (ms 50) easeIn (sec 0) + ".current" & backgroundColor (Color.chestnutRose -. 20) + Media.mobile $ fontSize (px 13) + + (".item" # hover) <> (".item" # focus) ? backgroundColor (Color.chestnutRose +. 10) + (".item.current" # hover) <> (".item.current" # focus) ? backgroundColor (Color.chestnutRose -. 10) + + ".nameSignOut" ? do + display flex + heightMedia + position absolute + top (px 0) + right (px 0) + + ".name" ? do + Media.mobile $ display none + Media.tabletDesktop $ headerPadding + + ".signOut" ? do + Helper.waitable + heightMedia + svg ? do + Media.tabletDesktop $ width (px 30) + Media.mobile $ width (px 20) + "path" ? ("fill" -: "white") + +lineHeightMedia :: Css +lineHeightMedia = do + Media.desktop $ lineHeight (px 80) + Media.tablet $ lineHeight (px 65) + Media.mobile $ lineHeight (px 50) + +heightMedia :: Css +heightMedia = do + Media.desktop $ height (px 80) + Media.tablet $ height (px 65) + Media.mobile $ height (px 50) diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs new file mode 100644 index 0000000..d3c7650 --- /dev/null +++ b/server/src/Design/View/Payment.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment + ( design + ) where + +import Clay + +import qualified Design.View.Payment.Header as Header +import qualified Design.View.Payment.Table as Table +import qualified Design.View.Payment.Pages as Pages + +design :: Css +design = do + ".header" ? Header.design + ".table" ? Table.design + ".pages" ? Pages.design diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs new file mode 100644 index 0000000..f02da8a --- /dev/null +++ b/server/src/Design/View/Payment/Header.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Header + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Constants + +import qualified Design.Helper as Helper +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + Media.desktop $ marginBottom (em 3) + Media.mobileTablet $ marginBottom (em 2) + marginLeft (pct blockPercentMargin) + marginRight (pct blockPercentMargin) + + ".payerAndAdd" ? do + Media.tabletDesktop $ display flex + marginBottom (em 1) + + ".exceedingPayers" ? do + backgroundColor Color.mossGreen + borderRadius (px 5) (px 5) (px 5) (px 5) + color Color.white + lineHeight (px Constants.inputHeight) + paddingLeft (px 10) + paddingRight (px 10) + + Media.tabletDesktop $ do + "flex-grow" -: "1" + marginRight (px 15) + + Media.mobile $ do + marginBottom (em 1) + textAlign (alignSide sideCenter) + + ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") + + ".userName" ? marginRight (px 8) + + ".addPayment" ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.mobile $ width (pct 100) + + ".searchLine" ? do + marginBottom (em 1) + form ? do + Media.mobile $ textAlign (alignSide sideCenter) + + ".textInput" ? do + display inlineBlock + marginBottom (px 0) + + Media.tabletDesktop $ marginRight (px 30) + Media.mobile $ do + marginBottom (em 1) + width (pct 100) + + ".radioGroup" ? do + display inlineBlock + marginBottom (px 0) + ".title" ? display none + + ".infos" ? do + Media.tabletDesktop $ lineHeight (px Constants.inputHeight) + Media.mobile $ lineHeight (px 25) + + ".total" <> ".partition" ? do + Media.mobileTablet $ display block + Media.mobile $ do + fontSize (pct 90) + textAlign (alignSide sideCenter) + + ".partition" ? do + color Color.dustyGray + Media.desktop $ marginLeft (px 15) diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs new file mode 100644 index 0000000..ade81a8 --- /dev/null +++ b/server/src/Design/View/Payment/Pages.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Pages + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Media as Media + +design :: Css +design = do + textAlign (alignSide sideCenter) + Helper.clearFix + + Media.desktop $ do + padding (px 40) (px 30) (px 30) (px 30) + + Media.tablet $ do + padding (px 30) (px 30) (px 30) (px 30) + + Media.mobile $ do + padding (px 20) (px 0) (px 20) (px 0) + lineHeight (px 40) + + ".page" ? do + display inlineBlock + fontWeight bold + + Media.desktop $ do + Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken + + Media.tabletDesktop $ do + border solid (px 2) Color.dustyGray + marginRight (px 10) + + Media.tablet $ do + Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken + fontSize (px 15) + + Media.mobile $ do + Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken + fontSize (px 12) + border solid (px 1) Color.dustyGray + marginRight (px 5) + + ":not(.current)" & cursor pointer + + ".current" & do + borderColor Color.chestnutRose + color Color.chestnutRose diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs new file mode 100644 index 0000000..a866b40 --- /dev/null +++ b/server/src/Design/View/Payment/Table.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Payment.Table + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + ".cell" ? do + ".name" & do + Media.tabletDesktop $ width (pct 30) + + ".cost" & do + Media.tabletDesktop $ width (pct 10) + + ".user" & do + Media.tabletDesktop $ width (pct 15) + + ".category" & do + Media.tabletDesktop $ width (pct 10) + + ".date" & do + Media.tabletDesktop $ width (pct 15) + Media.desktop $ do + ".shortDate" ? display none + ".longDate" ? display inline + Media.tablet $ do + ".shortDate" ? display inline + ".longDate" ? display none + Media.mobile $ do + ".shortDate" ? display none + ".longDate" ? display inline + marginBottom (em 0.5) + + ".button" & svg ? do + "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose)) + width (px 18) diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs new file mode 100644 index 0000000..214e663 --- /dev/null +++ b/server/src/Design/View/SignIn.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.SignIn + ( design + ) where + +import Clay +import Data.Monoid ((<>)) + +import qualified Design.Color as Color +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants + +design :: Css +design = do + let inputHeight = 50 + width (px 500) + marginTop (px 100) + marginLeft auto + marginRight auto + + input ? do + Helper.input inputHeight + display block + width (pct 100) + marginBottom (px 10) + + button ? do + Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten + display flex + alignItems center + justifyContent center + width (pct 100) + fontSize (em 1.2) + svg ? "path" ? ("fill" -: "white") + + ".success" <> ".error" ? do + marginTop (px 40) + textAlign (alignSide sideCenter) + + ".success" ? color Color.mossGreen + ".error" ? color Color.chestnutRose diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs new file mode 100644 index 0000000..0a5b258 --- /dev/null +++ b/server/src/Design/View/Stat.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Stat + ( design + ) where + +import Clay + +design :: Css +design = do + h1 ? paddingBottom (px 0) + + ".exceedingPayers" ? ".userName" ? marginRight (px 5) + + ".mean" ? marginBottom (em 1.5) diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs new file mode 100644 index 0000000..95abf90 --- /dev/null +++ b/server/src/Design/View/Table.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.View.Table + ( design + ) where + +import Data.Monoid ((<>)) + +import Clay + +import Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + ".emptyTableMsg" ? do + margin (em 2) (em 2) (em 2) (em 2) + textAlign (alignSide sideCenter) + + ".lines" ? do + Media.tabletDesktop $ display displayTable + width (pct 100) + textAlign (alignSide (sideCenter)) + + ".header" <> ".row" ? do + Media.tabletDesktop $ display tableRow + + ".header" ? do + Media.desktop $ do + fontSize (px 18) + height (px 70) + + Media.tabletDesktop $ do + backgroundColor Color.gothic + color Color.white + + Media.tablet $ do + fontSize (px 16) + height (px 60) + + Media.mobile $ do + display none + + ".row" ? do + nthChild "even" & backgroundColor Color.wildSand + + Media.desktop $ do + fontSize (px 18) + height (px 60) + + Media.tablet $ do + height (px 50) + + Media.mobile $ do + lineHeight (px 25) + paddingTop (px 10) + paddingBottom (px 10) + + ".cell" ? do + Media.tabletDesktop $ display tableCell + position relative + verticalAlign middle + + firstChild & do + Media.mobile $ do + fontSize (px 20) + lineHeight (px 30) + color Color.gothic + + ".refund" & color Color.mossGreen + + ".cell.button" & do + position relative + textAlign (alignSide sideCenter) + button ? do + padding (px 10) (px 10) (px 10) (px 10) + hover & "svg path" ? do + "fill" -: "rgb(237, 122, 116)" + + Media.tabletDesktop $ width (pct 3) + + Media.mobile $ do + display inlineBlock + button ? display flex diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs new file mode 100644 index 0000000..bc6ac83 --- /dev/null +++ b/server/src/Design/Views.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Design.Views + ( design + ) where + +import Clay + +import qualified Design.View.Header as Header +import qualified Design.View.Payment as Payment +import qualified Design.View.SignIn as SignIn +import qualified Design.View.Stat as Stat +import qualified Design.View.Table as Table + +import qualified Design.Helper as Helper +import qualified Design.Constants as Constants +import qualified Design.Color as Color +import qualified Design.Media as Media + +design :: Css +design = do + header ? Header.design + ".payment" ? Payment.design + ".signIn" ? SignIn.design + ".stat" ? Stat.design + Table.design + + ".withMargin" ? do + "margin" -: "0 2vw" + + ".titleButton" ? do + h1 ? do + Media.tabletDesktop $ float floatLeft + + button ? do + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + Media.tabletDesktop $ do + float floatRight + position relative + top (px (-8)) + Media.mobile $ do + width (pct 100) + marginBottom (px 20) + + ".tag" ? do + sym borderRadius (px 4) + sym2 padding (px 2) (px 5) + boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) + color Color.white diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs new file mode 100644 index 0000000..0bc6f6e --- /dev/null +++ b/server/src/Job/Daemon.hs @@ -0,0 +1,36 @@ +module Job.Daemon + ( runDaemons + ) where + +import Control.Concurrent (threadDelay, forkIO, ThreadId) +import Control.Monad (forever) +import Data.Time.Clock (UTCTime) + +import Conf (Conf) +import Job.Frequency (Frequency(..), microSeconds) +import Job.Kind (Kind(..)) +import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution) +import Job.MonthlyPayment (monthlyPayment) +import Job.WeeklyReport (weeklyReport) +import qualified Model.Query as Query +import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) + +runDaemons :: Conf -> IO () +runDaemons conf = do + _ <- runDaemon MonthlyPayment EveryHour (fmap not . belongToCurrentMonth) monthlyPayment + _ <- runDaemon WeeklyReport EveryHour (fmap not . belongToCurrentWeek) (weeklyReport conf) + return () + +runDaemon :: Kind -> Frequency -> (UTCTime -> IO Bool) -> (Maybe UTCTime -> IO UTCTime) -> IO ThreadId +runDaemon kind frequency isLastExecutionTooOld runJob = + forkIO . forever $ do + mbLastExecution <- Query.run $ do + actualizeLastCheck kind + getLastExecution kind + hasToRun <- case mbLastExecution of + Just lastExecution -> isLastExecutionTooOld lastExecution + Nothing -> return True + if hasToRun + then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) + else return () + threadDelay . microSeconds $ frequency diff --git a/server/src/Job/Frequency.hs b/server/src/Job/Frequency.hs new file mode 100644 index 0000000..263f6e6 --- /dev/null +++ b/server/src/Job/Frequency.hs @@ -0,0 +1,13 @@ +module Job.Frequency + ( Frequency(..) + , microSeconds + ) where + +data Frequency = + EveryHour + | EveryDay + deriving (Eq, Read, Show) + +microSeconds :: Frequency -> Int +microSeconds EveryHour = 1000000 * 60 * 60 +microSeconds EveryDay = (microSeconds EveryHour) * 24 diff --git a/server/src/Job/Kind.hs b/server/src/Job/Kind.hs new file mode 100644 index 0000000..af5d4f8 --- /dev/null +++ b/server/src/Job/Kind.hs @@ -0,0 +1,22 @@ +module Job.Kind + ( Kind(..) + ) where + +import Database.SQLite.Simple (SQLData(SQLText)) +import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) +import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) +import Database.SQLite.Simple.ToField (ToField(toField)) +import qualified Data.Text as T + +data Kind = + MonthlyPayment + | WeeklyReport + deriving (Eq, Show, Read) + +instance FromField Kind where + fromField field = case fieldData field of + SQLText text -> Ok (read (T.unpack text) :: Kind) + _ -> Errors [error "SQLText field required for job kind"] + +instance ToField Kind where + toField kind = SQLText . T.pack . show $ kind diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs new file mode 100644 index 0000000..e1a3c77 --- /dev/null +++ b/server/src/Job/Model.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Job.Model + ( Job(..) + , getLastExecution + , actualizeLastExecution + , actualizeLastCheck + ) where + +import Data.Maybe (isJust) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only(Only)) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Job.Kind +import Model.Query (Query(Query)) + +data Job = Job + { id :: String + , kind :: Kind + , lastExecution :: Maybe UTCTime + , lastCheck :: Maybe UTCTime + } deriving (Show) + +getLastExecution :: Kind -> Query (Maybe UTCTime) +getLastExecution jobKind = + Query (\conn -> do + [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)] + return time + ) + +actualizeLastExecution :: Kind -> UTCTime -> Query () +actualizeLastExecution jobKind time = + Query (\conn -> do + [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] + if isJust result + then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) + else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) + ) + +actualizeLastCheck :: Kind -> Query () +actualizeLastCheck jobKind = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute conn "UPDATE job SET kind = ? WHERE last_check = ?" (jobKind, now) + ) diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs new file mode 100644 index 0000000..ba24cca --- /dev/null +++ b/server/src/Job/MonthlyPayment.hs @@ -0,0 +1,26 @@ +module Job.MonthlyPayment + ( monthlyPayment + ) where + +import Data.Time.Clock (UTCTime, getCurrentTime) + +import Common.Model (Frequency(..), Payment(..)) + +import qualified Model.Payment as Payment +import Utils.Time (timeToDay) +import qualified Model.Query as Query + +monthlyPayment :: Maybe UTCTime -> IO UTCTime +monthlyPayment _ = do + monthlyPayments <- Query.run Payment.listMonthly + now <- getCurrentTime + actualDay <- timeToDay now + let punctualPayments = map + (\p -> p + { _payment_frequency = Punctual + , _payment_date = actualDay + , _payment_createdAt = now + }) + monthlyPayments + _ <- Query.run (Payment.createMany punctualPayments) + return now diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs new file mode 100644 index 0000000..5737c75 --- /dev/null +++ b/server/src/Job/WeeklyReport.hs @@ -0,0 +1,28 @@ +module Job.WeeklyReport + ( weeklyReport + ) where + +import Data.Time.Clock (UTCTime, getCurrentTime) + +import Conf (Conf) +import qualified Model.Income as Income +import qualified Model.Payment as Payment +import qualified Model.Query as Query +import qualified Model.User as User +import qualified SendMail +import qualified View.Mail.WeeklyReport as WeeklyReport + +weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime +weeklyReport conf mbLastExecution = do + now <- getCurrentTime + case mbLastExecution of + Nothing -> return () + Just lastExecution -> do + (payments, incomes, users) <- Query.run $ + (,,) <$> + Payment.modifiedDuring lastExecution now <*> + Income.modifiedDuring lastExecution now <*> + User.list + _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now) + return () + return now diff --git a/server/src/Json.hs b/server/src/Json.hs new file mode 100644 index 0000000..cc6327a --- /dev/null +++ b/server/src/Json.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +module Json + ( jsonObject + , jsonId + ) where + +import Data.Int (Int64) +import Data.Text (Text) +import qualified Data.Aeson.Types as Json +import qualified Data.HashMap.Strict as M +import Web.Scotty + +jsonObject :: [(Text, Json.Value)] -> ActionM () +jsonObject = json . Json.Object . M.fromList + +jsonId :: Int64 -> ActionM () +jsonId key = json . Json.Object . M.fromList $ [("id", Json.Number . fromIntegral $ key)] diff --git a/server/src/LoginSession.hs b/server/src/LoginSession.hs new file mode 100644 index 0000000..6f6d620 --- /dev/null +++ b/server/src/LoginSession.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module LoginSession + ( put + , get + , delete + ) where + +import Web.Scotty (ActionM) +import Cookie (setSimpleCookie, getCookie, deleteCookie) +import qualified Web.ClientSession as CS + +import Control.Monad.IO.Class (liftIO) + +import Data.Text (Text) +import qualified Data.Text.Encoding as TE + +import Conf (Conf) + +sessionName :: Text +sessionName = "SESSION" + +sessionKeyFile :: FilePath +sessionKeyFile = "sessionKey" + +put :: Conf -> Text -> ActionM () +put conf value = do + encrypted <- liftIO $ encrypt value + setSimpleCookie conf sessionName encrypted + +encrypt :: Text -> IO Text +encrypt value = do + iv <- CS.randomIV + key <- CS.getKey sessionKeyFile + return . TE.decodeUtf8 $ CS.encrypt key iv (TE.encodeUtf8 value) + +get :: ActionM (Maybe Text) +get = do + maybeEncrypted <- getCookie sessionName + case maybeEncrypted of + Just encrypted -> + liftIO $ decrypt encrypted + Nothing -> + return Nothing + +decrypt :: Text -> IO (Maybe Text) +decrypt encrypted = do + key <- CS.getKey sessionKeyFile + let decrypted = TE.decodeUtf8 <$> CS.decrypt key (TE.encodeUtf8 encrypted) + return decrypted + +delete :: Conf -> ActionM () +delete conf = deleteCookie conf sessionName diff --git a/server/src/Main.hs b/server/src/Main.hs new file mode 100644 index 0000000..db73474 --- /dev/null +++ b/server/src/Main.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Applicative (liftA3) +import Control.Monad.IO.Class (liftIO) + +import Network.Wai.Middleware.Static +import qualified Data.Text.Lazy as LT +import Web.Scotty + +import qualified Conf +import qualified Controller.Category as Category +import qualified Controller.Income as Income +import qualified Controller.Index as Index +import qualified Controller.Payment as Payment +import qualified Controller.SignIn as SignIn +import Job.Daemon (runDaemons) +import Model.Payer (getOrderedExceedingPayers) +import qualified Data.Time as Time +import qualified Model.User as UserM +import qualified Model.Income as IncomeM +import qualified Model.Payment as PaymentM +import qualified Model.Query as Query + +main :: IO () +main = do + conf <- Conf.get "application.conf" + _ <- runDaemons conf + scotty (Conf.port conf) $ do + middleware . staticPolicy $ noDots >-> addBase "public" + + get "/exceedingPayer" $ do + time <- liftIO Time.getCurrentTime + (users, incomes, payments) <- liftIO . Query.run $ + liftA3 (,,) UserM.list IncomeM.list PaymentM.list + let exceedingPayers = getOrderedExceedingPayers time users incomes payments + text . LT.pack . show $ exceedingPayers + + get "/" $ do + signInToken <- mbParam "signInToken" + Index.get conf signInToken + + post "/signIn" $ do + jsonData >>= SignIn.signIn conf + + post "/signOut" $ + Index.signOut conf + + post "/payment" $ + jsonData >>= Payment.create + + put "/payment" $ + jsonData >>= Payment.editOwn + + delete "/payment" $ do + paymentId <- param "id" + Payment.deleteOwn paymentId + + post "/income" $ + jsonData >>= Income.create + + put "/income" $ + jsonData >>= Income.editOwn + + delete "/income" $ do + incomeId <- param "id" + Income.deleteOwn incomeId + + post "/category" $ + jsonData >>= Category.create + + put "/category" $ + jsonData >>= Category.edit + + delete "/category" $ do + categoryId <- param "id" + Category.delete categoryId + +mbParam :: Parsable a => LT.Text -> ActionM (Maybe a) +mbParam key = (Just <$> param key) `rescue` (const . return $ Nothing) diff --git a/server/src/MimeMail.hs b/server/src/MimeMail.hs new file mode 100644 index 0000000..0faaf98 --- /dev/null +++ b/server/src/MimeMail.hs @@ -0,0 +1,672 @@ +{-# LANGUAGE OverloadedStrings #-} + +module MimeMail + ( -- * Datatypes + Boundary (..) + , Mail (..) + , emptyMail + , Address (..) + , Alternatives + , Part (..) + , Encoding (..) + , Headers + -- * Render a message + , renderMail + , renderMail' + -- * Sending messages + , sendmail + , sendmailCustom + , sendmailCustomCaptureOutput + , renderSendMail + , renderSendMailCustom + -- * High-level 'Mail' creation + , simpleMail + , simpleMail' + , simpleMailInMemory + -- * Utilities + , addPart + , addAttachment + , addAttachmentCid + , addAttachments + , addAttachmentBS + , addAttachmentBSCid + , addAttachmentsBS + , renderAddress + , htmlPart + , plainPart + , randomString + , quotedPrintable + ) where + +import qualified Data.ByteString.Lazy as L +import Blaze.ByteString.Builder.Char.Utf8 +import Blaze.ByteString.Builder +import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) +import Data.Monoid +import System.Random +import Control.Arrow +import System.Process +import System.IO +import System.Exit +import System.FilePath (takeFileName) +import qualified Data.ByteString.Base64 as Base64 +import Control.Monad ((<=<), foldM, void) +import Control.Exception (throwIO, ErrorCall (ErrorCall)) +import Data.List (intersperse) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.ByteString.Char8 () +import Data.Bits ((.&.), shiftR) +import Data.Char (isAscii, isControl) +import Data.Word (Word8) +import qualified Data.ByteString as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +-- | Generates a random sequence of alphanumerics of the given length. +randomString :: RandomGen d => Int -> d -> (String, d) +randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + where + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 + +-- | MIME boundary between parts of a message. +newtype Boundary = Boundary { unBoundary :: Text } + deriving (Eq, Show) +instance Random Boundary where + randomR = const random + random = first (Boundary . T.pack) . randomString 10 + +-- | An entire mail message. +data Mail = Mail + { mailFrom :: Address + , mailTo :: [Address] + , mailCc :: [Address] + , mailBcc :: [Address] + -- | Other headers, excluding from, to, cc and bcc. + , mailHeaders :: Headers + -- | A list of different sets of alternatives. As a concrete example: + -- + -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] + -- + -- Make sure when specifying alternatives to place the most preferred + -- version last. + , mailParts :: [Alternatives] + } + deriving Show + +-- | A mail message with the provided 'from' address and no other +-- fields filled in. +emptyMail :: Address -> Mail +emptyMail from = Mail + { mailFrom = from + , mailTo = [] + , mailCc = [] + , mailBcc = [] + , mailHeaders = [] + , mailParts = [] + } + +data Address = Address + { addressName :: Maybe Text + , addressEmail :: Text + } + deriving (Eq, Show) + +-- | How to encode a single part. You should use 'Base64' for binary data. +data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary + deriving (Eq, Show) + +-- | Multiple alternative representations of the same data. For example, you +-- could provide a plain-text and HTML version of a message. +type Alternatives = [Part] + +-- | A single part of a multipart message. +data Part = Part + { partType :: Text -- ^ content type + , partEncoding :: Encoding + -- | The filename for this part, if it is to be sent with an attachemnt + -- disposition. + , partFilename :: Maybe Text + , partHeaders :: Headers + , partContent :: L.ByteString + } + deriving (Eq, Show) + +type Headers = [(S.ByteString, Text)] +type Pair = (Headers, Builder) + +partToPair :: Part -> Pair +partToPair (Part contentType encoding disposition headers content) = + (headers', builder) + where + headers' = + ((:) ("Content-Type", contentType)) + $ (case encoding of + None -> id + Base64 -> (:) ("Content-Transfer-Encoding", "base64") + QuotedPrintableText -> + (:) ("Content-Transfer-Encoding", "quoted-printable") + QuotedPrintableBinary -> + (:) ("Content-Transfer-Encoding", "quoted-printable")) + $ (case disposition of + Nothing -> id + Just fn -> + (:) ("Content-Disposition", "attachment; filename=" + `T.append` fn)) + $ headers + builder = + case encoding of + None -> fromWriteList writeByteString $ L.toChunks content + Base64 -> base64 content + QuotedPrintableText -> quotedPrintable True content + QuotedPrintableBinary -> quotedPrintable False content + +showPairs :: RandomGen g + => Text -- ^ multipart type, eg mixed, alternative + -> [Pair] + -> g + -> (Pair, g) +showPairs _ [] _ = error "renderParts called with null parts" +showPairs _ [pair] gen = (pair, gen) +showPairs mtype parts gen = + ((headers, builder), gen') + where + (Boundary b, gen') = random gen + headers = + [ ("Content-Type", T.concat + [ "multipart/" + , mtype + , "; boundary=\"" + , b + , "\"" + ]) + ] + builder = mconcat + [ mconcat $ intersperse (fromByteString "\n") + $ map (showBoundPart $ Boundary b) parts + , showBoundEnd $ Boundary b + ] + +-- | Render a 'Mail' with a given 'RandomGen' for producing boundaries. +renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g) +renderMail g0 (Mail from to cc bcc headers parts) = + (toLazyByteString builder, g'') + where + addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)] + pairs = map (map partToPair) parts + (pairs', g') = helper g0 $ map (showPairs "alternative") pairs + helper :: g -> [g -> (x, g)] -> ([x], g) + helper g [] = ([], g) + helper g (x:xs) = + let (b, g_) = x g + (bs, g__) = helper g_ xs + in (b : bs, g__) + ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' + builder = mconcat + [ mconcat addressHeaders + , mconcat $ map showHeader headers + , showHeader ("MIME-Version", "1.0") + , mconcat $ map showHeader finalHeaders + , fromByteString "\n" + , finalBuilder + ] + +-- | Format an E-Mail address according to the name-addr form (see: RFC5322 +-- § 3.4 "Address specification", i.e: [display-name] '<'addr-spec'>') +-- This can be handy for adding custom headers that require such format. +-- +-- @since 0.4.11 +renderAddress :: Address -> Text +renderAddress address = + TE.decodeUtf8 $ toByteString $ showAddress address + +-- Only accept characters between 33 and 126, excluding colons. [RFC2822](https://tools.ietf.org/html/rfc2822#section-2.2) +sanitizeFieldName :: S.ByteString -> S.ByteString +sanitizeFieldName = S.filter (\w -> w >= 33 && w <= 126 && w /= 58) + +showHeader :: (S.ByteString, Text) -> Builder +showHeader (k, v) = mconcat + [ fromByteString (sanitizeFieldName k) + , fromByteString ": " + , encodeIfNeeded (sanitizeHeader v) + , fromByteString "\n" + ] + +showAddressHeader :: (S.ByteString, [Address]) -> Builder +showAddressHeader (k, as) = + if null as + then mempty + else mconcat + [ fromByteString k + , fromByteString ": " + , mconcat (intersperse (fromByteString ", ") . map showAddress $ as) + , fromByteString "\n" + ] + +-- | +-- +-- Since 0.4.3 +showAddress :: Address -> Builder +showAddress a = mconcat + [ maybe mempty ((<> fromByteString " ") . encodedWord) (addressName a) + , fromByteString "<" + , fromText (sanitizeHeader $ addressEmail a) + , fromByteString ">" + ] + +-- Filter out control characters to prevent CRLF injection. +sanitizeHeader :: Text -> Text +sanitizeHeader = T.filter (not . isControl) + +showBoundPart :: Boundary -> (Headers, Builder) -> Builder +showBoundPart (Boundary b) (headers, content) = mconcat + [ fromByteString "--" + , fromText b + , fromByteString "\n" + , mconcat $ map showHeader headers + , fromByteString "\n" + , content + ] + +showBoundEnd :: Boundary -> Builder +showBoundEnd (Boundary b) = mconcat + [ fromByteString "\n--" + , fromText b + , fromByteString "--" + ] + +-- | Like 'renderMail', but generates a random boundary. +renderMail' :: Mail -> IO L.ByteString +renderMail' m = do + g <- getStdGen + let (lbs, g') = renderMail g m + setStdGen g' + return lbs + +-- | Send a fully-formed email message via the default sendmail +-- executable with default options. +sendmail :: L.ByteString -> IO () +sendmail = sendmailCustom sendmailPath ["-t"] + +sendmailPath :: String +sendmailPath = "sendmail" + +-- | Render an email message and send via the default sendmail +-- executable with default options. +renderSendMail :: Mail -> IO () +renderSendMail = sendmail <=< renderMail' + +-- | Send a fully-formed email message via the specified sendmail +-- executable with specified options. +sendmailCustom :: FilePath -- ^ sendmail executable path + -> [String] -- ^ sendmail command-line options + -> L.ByteString -- ^ mail message as lazy bytestring + -> IO () +sendmailCustom sm opts lbs = void $ sendmailCustomAux False sm opts lbs + +-- | Like 'sendmailCustom', but also returns sendmail's output to stderr and +-- stdout as strict ByteStrings. +-- +-- Since 0.4.9 +sendmailCustomCaptureOutput :: FilePath + -> [String] + -> L.ByteString + -> IO (S.ByteString, S.ByteString) +sendmailCustomCaptureOutput sm opts lbs = sendmailCustomAux True sm opts lbs + +sendmailCustomAux :: Bool + -> FilePath + -> [String] + -> L.ByteString + -> IO (S.ByteString, S.ByteString) +sendmailCustomAux captureOut sm opts lbs = do + let baseOpts = (proc sm opts) { std_in = CreatePipe } + pOpts = if captureOut + then baseOpts { std_out = CreatePipe + , std_err = CreatePipe + } + else baseOpts + (Just hin, mHOut, mHErr, phandle) <- createProcess pOpts + L.hPut hin lbs + hClose hin + errMVar <- newEmptyMVar + outMVar <- newEmptyMVar + case (mHOut, mHErr) of + (Nothing, Nothing) -> return () + (Just hOut, Just hErr) -> do + void . forkIO $ S.hGetContents hOut >>= putMVar outMVar + void . forkIO $ S.hGetContents hErr >>= putMVar errMVar + _ -> error "error in sendmailCustomAux: missing a handle" + exitCode <- waitForProcess phandle + case exitCode of + ExitSuccess -> if captureOut + then do + errOutput <- takeMVar errMVar + outOutput <- takeMVar outMVar + return (outOutput, errOutput) + else return (S.empty, S.empty) + _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode) + +-- | Render an email message and send via the specified sendmail +-- executable with specified options. +renderSendMailCustom :: FilePath -- ^ sendmail executable path + -> [String] -- ^ sendmail command-line options + -> Mail -- ^ mail to render and send + -> IO () +renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail' + +-- FIXME usage of FilePath below can lead to issues with filename encoding + +-- | A simple interface for generating an email with HTML and plain-text +-- alternatives and some file attachments. +-- +-- Note that we use lazy IO for reading in the attachment contents. +simpleMail :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ plain body + -> LT.Text -- ^ HTML body + -> [(Text, FilePath)] -- ^ content type and path of attachments + -> IO Mail +simpleMail to from subject plainBody htmlBody attachments = + addAttachments attachments + . addPart [plainPart plainBody, htmlPart htmlBody] + $ mailFromToSubject from to subject + +-- | A simple interface for generating an email with only plain-text body. +simpleMail' :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ body + -> Mail +simpleMail' to from subject body = addPart [plainPart body] + $ mailFromToSubject from to subject + +-- | A simple interface for generating an email with HTML and plain-text +-- alternatives and some 'ByteString' attachments. +-- +-- Since 0.4.7 +simpleMailInMemory :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ plain body + -> LT.Text -- ^ HTML body + -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments + -> Mail +simpleMailInMemory to from subject plainBody htmlBody attachments = + addAttachmentsBS attachments + . addPart [plainPart plainBody, htmlPart htmlBody] + $ mailFromToSubject from to subject + +mailFromToSubject :: Address -- ^ from + -> Address -- ^ to + -> Text -- ^ subject + -> Mail +mailFromToSubject from to subject = + (emptyMail from) { mailTo = [to] + , mailHeaders = [("Subject", subject)] + } + +-- | Add an 'Alternative' to the 'Mail's parts. +-- +-- To e.g. add a plain text body use +-- > addPart [plainPart body] (emptyMail from) +addPart :: Alternatives -> Mail -> Mail +addPart alt mail = mail { mailParts = mailParts mail ++ [alt] } + +-- | Construct a UTF-8-encoded plain-text 'Part'. +plainPart :: LT.Text -> Part +plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body + where cType = "text/plain; charset=utf-8" + +-- | Construct a UTF-8-encoded html 'Part'. +htmlPart :: LT.Text -> Part +htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body + where cType = "text/html; charset=utf-8" + +-- | Add an attachment from a file and construct a 'Part'. +addAttachment :: Text -> FilePath -> Mail -> IO Mail +addAttachment ct fn mail = do + part <- getAttachmentPart ct fn + return $ addPart [part] mail + +-- | Add an attachment from a file and construct a 'Part' +-- with the specified content id in the Content-ID header. +-- +-- @since 0.4.12 +addAttachmentCid :: Text -- ^ content type + -> FilePath -- ^ file name + -> Text -- ^ content ID + -> Mail + -> IO Mail +addAttachmentCid ct fn cid mail = + getAttachmentPart ct fn >>= (return.addToMail.addHeader) + where + addToMail part = addPart [part] mail + addHeader part = part { partHeaders = header:ph } + where ph = partHeaders part + header = ("Content-ID", T.concat ["<", cid, ">"]) + +addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail +addAttachments xs mail = foldM fun mail xs + where fun m (c, f) = addAttachment c f m + +-- | Add an attachment from a 'ByteString' and construct a 'Part'. +-- +-- Since 0.4.7 +addAttachmentBS :: Text -- ^ content type + -> Text -- ^ file name + -> L.ByteString -- ^ content + -> Mail -> Mail +addAttachmentBS ct fn content mail = + let part = getAttachmentPartBS ct fn content + in addPart [part] mail + +-- | @since 0.4.12 +addAttachmentBSCid :: Text -- ^ content type + -> Text -- ^ file name + -> L.ByteString -- ^ content + -> Text -- ^ content ID + -> Mail -> Mail +addAttachmentBSCid ct fn content cid mail = + let part = addHeader $ getAttachmentPartBS ct fn content + in addPart [part] mail + where + addHeader part = part { partHeaders = header:ph } + where ph = partHeaders part + header = ("Content-ID", T.concat ["<", cid, ">"]) + +-- | +-- Since 0.4.7 +addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail +addAttachmentsBS xs mail = foldl fun mail xs + where fun m (ct, fn, content) = addAttachmentBS ct fn content m + +getAttachmentPartBS :: Text + -> Text + -> L.ByteString + -> Part +getAttachmentPartBS ct fn content = Part ct Base64 (Just fn) [] content + +getAttachmentPart :: Text -> FilePath -> IO Part +getAttachmentPart ct fn = do + content <- L.readFile fn + return $ getAttachmentPartBS ct (T.pack (takeFileName fn)) content + +data QP = QPPlain S.ByteString + | QPNewline + | QPTab + | QPSpace + | QPEscape S.ByteString + +data QPC = QPCCR + | QPCLF + | QPCSpace + | QPCTab + | QPCPlain + | QPCEscape + deriving Eq + +toQP :: Bool -- ^ text? + -> L.ByteString + -> [QP] +toQP isText = + go + where + go lbs = + case L.uncons lbs of + Nothing -> [] + Just (c, rest) -> + case toQPC c of + QPCCR -> go rest + QPCLF -> QPNewline : go rest + QPCSpace -> QPSpace : go rest + QPCTab -> QPTab : go rest + QPCPlain -> + let (x, y) = L.span ((== QPCPlain) . toQPC) lbs + in QPPlain (toStrict x) : go y + QPCEscape -> + let (x, y) = L.span ((== QPCEscape) . toQPC) lbs + in QPEscape (toStrict x) : go y + + toStrict = S.concat . L.toChunks + + toQPC :: Word8 -> QPC + toQPC 13 | isText = QPCCR + toQPC 10 | isText = QPCLF + toQPC 9 = QPCTab + toQPC 0x20 = QPCSpace + toQPC 46 = QPCEscape + toQPC 61 = QPCEscape + toQPC w + | 33 <= w && w <= 126 = QPCPlain + | otherwise = QPCEscape + +buildQPs :: [QP] -> Builder +buildQPs = + go (0 :: Int) + where + go _ [] = mempty + go currLine (qp:qps) = + case qp of + QPNewline -> copyByteString "\r\n" `mappend` go 0 qps + QPTab -> wsHelper (copyByteString "=09") (fromWord8 9) + QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20) + QPPlain bs -> + let toTake = 75 - currLine + (x, y) = S.splitAt toTake bs + rest + | S.null y = qps + | otherwise = QPPlain y : qps + in helper (S.length x) (copyByteString x) (S.null y) rest + QPEscape bs -> + let toTake = (75 - currLine) `div` 3 + (x, y) = S.splitAt toTake bs + rest + | S.null y = qps + | otherwise = QPEscape y : qps + in if toTake == 0 + then copyByteString "=\r\n" `mappend` go 0 (qp:qps) + else helper (S.length x * 3) (escape x) (S.null y) rest + where + escape = + S.foldl' add mempty + where + add builder w = + builder `mappend` escaped + where + escaped = fromWord8 61 `mappend` hex (w `shiftR` 4) + `mappend` hex (w .&. 15) + + helper added builder noMore rest = + builder' `mappend` go newLine rest + where + (newLine, builder') + | not noMore || (added + currLine) >= 75 = + (0, builder `mappend` copyByteString "=\r\n") + | otherwise = (added + currLine, builder) + + wsHelper enc raw + | null qps = + if currLine <= 73 + then enc + else copyByteString "\r\n=" `mappend` enc + | otherwise = helper 1 raw (currLine < 76) qps + +-- | The first parameter denotes whether the input should be treated as text. +-- If treated as text, then CRs will be stripped and LFs output as CRLFs. If +-- binary, then CRs and LFs will be escaped. +quotedPrintable :: Bool -> L.ByteString -> Builder +quotedPrintable isText = buildQPs . toQP isText + +hex :: Word8 -> Builder +hex x + | x < 10 = fromWord8 $ x + 48 + | otherwise = fromWord8 $ x + 55 + +encodeIfNeeded :: Text -> Builder +encodeIfNeeded t = + if needsEncodedWord t + then encodedWord t + else fromText t + +needsEncodedWord :: Text -> Bool +needsEncodedWord = not . T.all isAscii + +encodedWord :: Text -> Builder +encodedWord t = mconcat + [ fromByteString "=?utf-8?Q?" + , S.foldl' go mempty $ TE.encodeUtf8 t + , fromByteString "?=" + ] + where + go front w = front `mappend` go' w + go' 32 = fromWord8 95 -- space + go' 95 = go'' 95 -- _ + go' 63 = go'' 63 -- ? + go' 61 = go'' 61 -- = + + -- The special characters from RFC 2822. Not all of these always give + -- problems, but at least @[];"<>, gave problems with some mail servers + -- when used in the 'name' part of an address. + go' 34 = go'' 34 -- " + go' 40 = go'' 40 -- ( + go' 41 = go'' 41 -- ) + go' 44 = go'' 44 -- , + go' 46 = go'' 46 -- . + go' 58 = go'' 58 -- ; + go' 59 = go'' 59 -- ; + go' 60 = go'' 60 -- < + go' 62 = go'' 62 -- > + go' 64 = go'' 64 -- @ + go' 91 = go'' 91 -- [ + go' 92 = go'' 92 -- \ + go' 93 = go'' 93 -- ] + go' w + | 33 <= w && w <= 126 = fromWord8 w + | otherwise = go'' w + go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4) + `mappend` hex (w .&. 15) + +-- 57 bytes, when base64-encoded, becomes 76 characters. +-- Perform the encoding 57-bytes at a time, and then append a newline. +base64 :: L.ByteString -> Builder +base64 lbs + | L.null lbs = mempty + | otherwise = fromByteString x64 `mappend` + fromByteString "\r\n" `mappend` + base64 y + where + (x', y) = L.splitAt 57 lbs + x = S.concat $ L.toChunks x' + x64 = Base64.encode x diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs new file mode 100644 index 0000000..6b7a488 --- /dev/null +++ b/server/src/Model/Category.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Category + ( list + , create + , edit + , delete + ) where + +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import qualified Database.SQLite.Simple as SQLite +import Prelude hiding (id) + +import Common.Model (Category(..), CategoryId) + +import Model.Query (Query(Query)) + +instance FromRow Category where + fromRow = Category <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field + +list :: Query [Category] +list = + Query (\conn -> + SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" + ) + +create :: Text -> Text -> Query CategoryId +create categoryName categoryColor = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" + (categoryName, categoryColor, now) + SQLite.lastInsertRowId conn + ) + +edit :: CategoryId -> Text -> Text -> Query Bool +edit categoryId categoryName categoryColor = + Query (\conn -> do + mbCategory <- listToMaybe <$> + (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) + if isJust mbCategory + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" + (now, categoryName, categoryColor, categoryId) + return True + else + return False + ) + +delete :: CategoryId -> Query Bool +delete categoryId = + Query (\conn -> do + mbCategory <- listToMaybe <$> + (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) + if isJust mbCategory + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) + return True + else + return False + ) diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs new file mode 100644 index 0000000..b334a40 --- /dev/null +++ b/server/src/Model/Frequency.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Frequency () where + +import Database.SQLite.Simple (SQLData(SQLText)) +import Database.SQLite.Simple.FromField (fieldData, FromField(fromField)) +import Database.SQLite.Simple.Ok (Ok(Ok, Errors)) +import Database.SQLite.Simple.ToField (ToField(toField)) +import qualified Data.Text as T + +import Common.Model (Frequency) + +instance FromField Frequency where + fromField field = case fieldData field of + SQLText text -> Ok (read (T.unpack text) :: Frequency) + _ -> Errors [error "SQLText field required for frequency"] + +instance ToField Frequency where + toField frequency = SQLText . T.pack . show $ frequency diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs new file mode 100644 index 0000000..bbe7657 --- /dev/null +++ b/server/src/Model/Income.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Income + ( list + , create + , editOwn + , deleteOwn + , modifiedDuring + ) where + +import Data.Maybe (listToMaybe) +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import Prelude hiding (id) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (Income(..), IncomeId, User(..), UserId) + +import Model.Query (Query(Query)) +import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) + +instance Resource Income where + resourceCreatedAt = _income_createdAt + resourceEditedAt = _income_editedAt + resourceDeletedAt = _income_deletedAt + +instance FromRow Income where + fromRow = Income <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field + +list :: Query [Income] +list = Query (\conn -> SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL") + +create :: UserId -> Day -> Int -> Query IncomeId +create incomeUserId incomeDate incomeAmount = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" + (incomeUserId, incomeDate, incomeAmount, now) + SQLite.lastInsertRowId conn + ) + +editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool +editOwn incomeUserId incomeId incomeDate incomeAmount = + Query (\conn -> do + mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) + case mbIncome of + Just income -> + if _income_userId income == incomeUserId + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" + (now, incomeDate, incomeAmount, incomeId) + return True + else + return False + Nothing -> + return False + ) + +deleteOwn :: User -> IncomeId -> Query Bool +deleteOwn user incomeId = + Query (\conn -> do + mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) + case mbIncome of + Just income -> + if _income_userId income == _user_id user + then do + now <- getCurrentTime + SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) + return True + else + return False + Nothing -> + return False + ) + +modifiedDuring :: UTCTime -> UTCTime -> Query [Income] +modifiedDuring start end = + Query (\conn -> + SQLite.query + conn + "SELECT * FROM income WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)" + (start, end, start, end, start, end) + ) diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs new file mode 100644 index 0000000..8c6a961 --- /dev/null +++ b/server/src/Model/Init.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Model.Init + ( getInit + ) where + +import Common.Model (Init(Init), User(..)) + +import Conf (Conf) +import qualified Conf +import Model.Query (Query) +import qualified Model.Category as Category +import qualified Model.Income as Income +import qualified Model.Payment as Payment +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.User as User + +getInit :: User -> Conf -> Query Init +getInit user conf = + Init <$> + User.list <*> + (return . _user_id $ user) <*> + Payment.list <*> + Income.list <*> + Category.list <*> + PaymentCategory.list <*> + (return . Conf.currency $ conf) diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs new file mode 100644 index 0000000..9a4db73 --- /dev/null +++ b/server/src/Model/Mail.hs @@ -0,0 +1,12 @@ +module Model.Mail + ( Mail(..) + ) where + +import Data.Text (Text) + +data Mail = Mail + { from :: Text + , to :: [Text] + , subject :: Text + , plainBody :: Text + } deriving (Eq, Show) diff --git a/server/src/Model/Payer.hs b/server/src/Model/Payer.hs new file mode 100644 index 0000000..de4abd1 --- /dev/null +++ b/server/src/Model/Payer.hs @@ -0,0 +1,216 @@ +module Model.Payer + ( getOrderedExceedingPayers + ) where + +import Data.Map (Map) +import Data.Time (UTCTime(..), NominalDiffTime) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Time as Time + +import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..)) + +type Users = Map UserId User + +type Payers = Map UserId Payer + +type Incomes = Map IncomeId Income + +type Payments = [Payment] + +data Payer = Payer + { preIncomePaymentSum :: Int + , postIncomePaymentSum :: Int + , _incomes :: [Income] + } + +data PostPaymentPayer = PostPaymentPayer + { _preIncomePaymentSum :: Int + , _cumulativeIncome :: Int + , ratio :: Float + } + +data ExceedingPayer = ExceedingPayer + { _userId :: UserId + , amount :: Int + } deriving (Show) + +getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer] +getOrderedExceedingPayers currentTime users incomes payments = + let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users + incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes + payers = getPayers currentTime usersMap incomesMap payments + exceedingPayersOnPreIncome = + exceedingPayersFromAmounts + . Map.toList + . Map.map preIncomePaymentSum + $ payers + mbSince = useIncomesFrom usersMap incomesMap payments + in case mbSince of + Just since -> + let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers + mbMaxRatio = + safeMaximum + . map (ratio . snd) + . Map.toList + $ postPaymentPayers + in case mbMaxRatio of + Just maxRatio -> + exceedingPayersFromAmounts + . Map.toList + . Map.map (getFinalDiff maxRatio) + $ postPaymentPayers + Nothing -> + exceedingPayersOnPreIncome + _ -> + exceedingPayersOnPreIncome + +useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime +useIncomesFrom users incomes payments = + let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments + mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes + in case (firstPaymentTime, mbIncomeTime) of + (Just t1, Just t2) -> Just (max t1 t2) + _ -> Nothing + +paymentTime :: Payment -> UTCTime +paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date + +getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers +getPayers currentTime users incomes payments = + let userIds = Map.keys users + incomesDefined = incomeDefinedForAll userIds incomes + in Map.fromList + . map (\userId -> + ( userId + , Payer + { preIncomePaymentSum = + totalPayments + (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined)) + userId + payments + , postIncomePaymentSum = + totalPayments + (\p -> + case incomesDefined of + Nothing -> False + Just t -> paymentTime p >= t + ) + userId + payments + , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes) + } + ) + ) + $ userIds + +exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer] +exceedingPayersFromAmounts userAmounts = + case mbMinAmount of + Nothing -> + [] + Just minAmount -> + filter (\payer -> amount payer > 0) + . map (\userAmount -> + ExceedingPayer + { _userId = fst userAmount + , amount = snd userAmount - minAmount + } + ) + $ userAmounts + where mbMinAmount = safeMinimum . map snd $ userAmounts + +getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer +getPostPaymentPayer currentTime since payer = + PostPaymentPayer + { _preIncomePaymentSum = preIncomePaymentSum payer + , _cumulativeIncome = cumulativeIncome + , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome) + } + where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer) + +getFinalDiff :: Float -> PostPaymentPayer -> Int +getFinalDiff maxRatio payer = + let postIncomeDiff = + truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer) + in postIncomeDiff + _preIncomePaymentSum payer + +incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime +incomeDefinedForAll userIds incomes = + let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds + firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes + in if all Maybe.isJust firstIncomes + then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes + else Nothing + +cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int +cumulativeIncomesSince currentTime since incomes = + getCumulativeIncome currentTime (getOrderedIncomesSince since incomes) + +getOrderedIncomesSince :: UTCTime -> [Income] -> [Income] +getOrderedIncomesSince time incomes = + let mbStarterIncome = getIncomeAt time incomes + orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes + in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince + +getIncomeAt :: UTCTime -> [Income] -> Maybe Income +getIncomeAt time incomes = + case incomes of + [x] -> + if incomeTime x < time + then Just $ x { _income_date = utctDay time } + else Nothing + x1 : x2 : xs -> + if incomeTime x1 < time && incomeTime x2 >= time + then Just $ x1 { _income_date = utctDay time } + else getIncomeAt time (x2 : xs) + [] -> + Nothing + +getCumulativeIncome :: UTCTime -> [Income] -> Int +getCumulativeIncome currentTime incomes = + sum + . map durationIncome + . getIncomesWithDuration currentTime + . List.sortOn incomeTime + $ incomes + +getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)] +getIncomesWithDuration currentTime incomes = + case incomes of + [] -> + [] + [income] -> + [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)] + (income1 : income2 : xs) -> + (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs)) + +incomeTime :: Income -> UTCTime +incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date + +durationIncome :: (NominalDiffTime, Int) -> Int +durationIncome (duration, income) = + truncate $ duration * fromIntegral income / (nominalDay * 365 / 12) + +nominalDay :: NominalDiffTime +nominalDay = 86400 + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x : _) = Just x + +safeMinimum :: (Ord a) => [a] -> Maybe a +safeMinimum [] = Nothing +safeMinimum xs = Just . minimum $ xs + +safeMaximum :: (Ord a) => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum xs = Just . maximum $ xs + +totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int +totalPayments paymentFilter userId payments = + sum + . map _payment_cost + . filter (\payment -> paymentFilter payment && _payment_user payment == userId) + $ payments diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs new file mode 100644 index 0000000..14efe77 --- /dev/null +++ b/server/src/Model/Payment.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Payment + ( Payment(..) + , find + , list + , listMonthly + , create + , createMany + , editOwn + , deleteOwn + , modifiedDuring + ) where + +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow), ToRow) +import Database.SQLite.Simple.ToField (ToField(toField)) +import Prelude hiding (id) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (Frequency(..), Payment(..), PaymentId, UserId) + +import Model.Frequency () +import Model.Query (Query(Query)) +import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt) + +instance Resource Payment where + resourceCreatedAt = _payment_createdAt + resourceEditedAt = _payment_editedAt + resourceDeletedAt = _payment_deletedAt + +instance FromRow Payment where + fromRow = Payment <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field + +instance ToRow Payment where + toRow p = + [ toField (_payment_user p) + , toField (_payment_name p) + , toField (_payment_cost p) + , toField (_payment_date p) + , toField (_payment_frequency p) + , toField (_payment_createdAt p) + ] + +find :: PaymentId -> Query (Maybe Payment) +find paymentId = + Query (\conn -> listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + ) + +list :: Query [Payment] +list = + Query (\conn -> + SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" + ) + +listMonthly :: Query [Payment] +listMonthly = + Query (\conn -> + SQLite.query + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE deleted_at IS NULL AND frequency = ?" + , "ORDER BY name DESC" + ]) + (Only Monthly) + ) + +create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId +create userId paymentName paymentCost paymentDate paymentFrequency = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) + (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) + SQLite.lastInsertRowId conn + ) + +createMany :: [Payment] -> Query () +createMany payments = + Query (\conn -> + SQLite.executeMany + conn + (SQLite.Query $ T.intercalate "" + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) + payments + ) + +editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool +editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = + Query (\conn -> do + mbPayment <- listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + case mbPayment of + Just payment -> + if _payment_user payment == userId + then do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "UPDATE payment" + , "SET edited_at = ?," + , " name = ?," + , " cost = ?," + , " date = ?," + , " frequency = ?" + , "WHERE id = ?" + ]) + (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId) + return True + else + return False + Nothing -> + return False + ) + +deleteOwn :: UserId -> PaymentId -> Query Bool +deleteOwn userId paymentId = + Query (\conn -> do + mbPayment <- listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + case mbPayment of + Just payment -> + if _payment_user payment == userId + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE payment SET deleted_at = ? WHERE id = ?" + (now, paymentId) + return True + else + return False + Nothing -> + return False + ) + +modifiedDuring :: UTCTime -> UTCTime -> Query [Payment] +modifiedDuring start end = + Query (\conn -> + SQLite.query + conn + (SQLite.Query $ T.intercalate " " + [ "SELECT *" + , "FROM payment" + , "WHERE (created_at >= ? AND created_at <= ?)" + , " OR (edited_at >= ? AND edited_at <= ?)" + , " OR (deleted_at >= ? AND deleted_at <= ?)" + ]) + (start, end, start, end, start, end) + ) diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs new file mode 100644 index 0000000..6e1d304 --- /dev/null +++ b/server/src/Model/PaymentCategory.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.PaymentCategory + ( list + , listByCategory + , save + ) where + +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import qualified Data.Text as T +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (CategoryId, PaymentCategory(..)) +import qualified Common.Util.Text as T + +import Model.Query (Query(Query)) + +instance FromRow PaymentCategory where + fromRow = PaymentCategory <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field + +list :: Query [PaymentCategory] +list = Query (\conn -> SQLite.query_ conn "SELECT * from payment_category") + +listByCategory :: CategoryId -> Query [PaymentCategory] +listByCategory cat = + Query (\conn -> + SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat) + ) + +save :: Text -> CategoryId -> Query () +save newName categoryId = + Query (\conn -> do + now <- getCurrentTime + mbPaymentCategory <- listToMaybe <$> + (SQLite.query + conn + "SELECT * FROM payment_category WHERE name = ?" + (Only (formatPaymentName newName)) :: IO [PaymentCategory]) + if isJust mbPaymentCategory + then + SQLite.execute + conn + "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?" + (categoryId, now, formatPaymentName newName) + else do + SQLite.execute + conn + "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)" + (formatPaymentName newName, categoryId, now) + ) + where + formatPaymentName :: Text -> Text + formatPaymentName = T.unaccent . T.toLower diff --git a/server/src/Model/Query.hs b/server/src/Model/Query.hs new file mode 100644 index 0000000..d15fb5f --- /dev/null +++ b/server/src/Model/Query.hs @@ -0,0 +1,32 @@ +module Model.Query + ( Query(..) + , run + ) where + +import Data.Functor (Functor) +import Database.SQLite.Simple (Connection) +import qualified Database.SQLite.Simple as SQLite + +data Query a = Query (Connection -> IO a) + +instance Functor Query where + fmap f (Query call) = Query (fmap f . call) + +instance Applicative Query where + pure x = Query (const $ return x) + (Query callF) <*> (Query callX) = Query (\conn -> do + x <- callX conn + f <- callF conn + return (f x)) + +instance Monad Query where + (Query callX) >>= f = Query (\conn -> do + x <- callX conn + case f x of Query callY -> callY conn) + +run :: Query a -> IO a +run (Query call) = do + conn <- SQLite.open "database" + result <- call conn + _ <- SQLite.close conn + return result diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs new file mode 100644 index 0000000..c5182f0 --- /dev/null +++ b/server/src/Model/SignIn.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Model.SignIn + ( SignIn(..) + , createSignInToken + , getSignIn + , signInTokenToUsed + , isLastTokenValid + ) where + +import Data.Int (Int64) +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock (UTCTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import qualified Database.SQLite.Simple as SQLite + +import Model.Query (Query(Query)) +import Model.UUID (generateUUID) + +type SignInId = Int64 + +data SignIn = SignIn + { id :: SignInId + , token :: Text + , creation :: UTCTime + , email :: Text + , isUsed :: Bool + } deriving Show + +instance FromRow SignIn where + fromRow = SignIn <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field + +createSignInToken :: Text -> Query Text +createSignInToken signInEmail = + Query (\conn -> do + now <- getCurrentTime + signInToken <- generateUUID + SQLite.execute conn "INSERT INTO sign_in (token, creation, email, is_used) VALUES (?, ?, ?, ?)" (signInToken, now, signInEmail, False) + return signInToken + ) + +getSignIn :: Text -> Query (Maybe SignIn) +getSignIn signInToken = + Query (\conn -> do + listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn]) + ) + +signInTokenToUsed :: SignInId -> Query () +signInTokenToUsed tokenId = + Query (\conn -> + SQLite.execute conn "UPDATE sign_in SET is_used = ? WHERE id = ?" (True, tokenId) + ) + +isLastTokenValid :: SignIn -> Query Bool +isLastTokenValid signIn = + Query (\conn -> do + [ Only lastToken ] <- SQLite.query conn "SELECT token from sign_in WHERE email = ? AND is_used = ? ORDER BY creation DESC LIMIT 1" (email signIn, True) + return . maybe False (== (token signIn)) $ lastToken + ) diff --git a/server/src/Model/UUID.hs b/server/src/Model/UUID.hs new file mode 100644 index 0000000..6cb7ce0 --- /dev/null +++ b/server/src/Model/UUID.hs @@ -0,0 +1,10 @@ +module Model.UUID + ( generateUUID + ) where + +import Data.UUID (toString) +import Data.UUID.V4 (nextRandom) +import Data.Text (Text, pack) + +generateUUID :: IO Text +generateUUID = pack . toString <$> nextRandom diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs new file mode 100644 index 0000000..e14fcef --- /dev/null +++ b/server/src/Model/User.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.User + ( list + , get + , create + , delete + ) where + +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (Only(Only), FromRow(fromRow)) +import Prelude hiding (id) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (UserId, User(..)) + +import Model.Query (Query(Query)) + +instance FromRow User where + fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field + +list :: Query [User] +list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC") + +get :: Text -> Query (Maybe User) +get userEmail = + Query (\conn -> listToMaybe <$> + SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail) + ) + +create :: Text -> Text -> Query UserId +create userEmail userName = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO user (creation, email, name) VALUES (?, ?, ?)" + (now, userEmail, userName) + SQLite.lastInsertRowId conn + ) + +delete :: Text -> Query () +delete userEmail = + Query (\conn -> + SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail) + ) diff --git a/server/src/Resource.hs b/server/src/Resource.hs new file mode 100644 index 0000000..f52bbfa --- /dev/null +++ b/server/src/Resource.hs @@ -0,0 +1,54 @@ +module Resource + ( Resource + , resourceCreatedAt + , resourceEditedAt + , resourceDeletedAt + , Status(..) + , statuses + , groupByStatus + , statusDuring + ) where + +import Data.Maybe (fromMaybe) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Time.Clock (UTCTime) + +class Resource a where + resourceCreatedAt :: a -> UTCTime + resourceEditedAt :: a -> Maybe UTCTime + resourceDeletedAt :: a -> Maybe UTCTime + +data Status = + Created + | Edited + | Deleted + deriving (Eq, Show, Read, Ord, Enum, Bounded) + +statuses :: [Status] +statuses = [minBound..] + +groupByStatus :: Resource a => UTCTime -> UTCTime -> [a] -> Map Status [a] +groupByStatus start end resources = + foldl + (\m resource -> + case statusDuring start end resource of + Just status -> M.insertWith (++) status [resource] m + Nothing -> m + ) + M.empty + resources + +statusDuring :: Resource a => UTCTime -> UTCTime -> a -> Maybe Status +statusDuring start end resource + | created && not deleted = Just Created + | not created && edited && not deleted = Just Edited + | not created && deleted = Just Deleted + | otherwise = Nothing + where + created = belongs (resourceCreatedAt resource) start end + edited = fromMaybe False (fmap (\t -> belongs t start end) $ resourceEditedAt resource) + deleted = fromMaybe False (fmap (\t -> belongs t start end) $ resourceDeletedAt resource) + +belongs :: UTCTime -> UTCTime -> UTCTime -> Bool +belongs time start end = time >= start && time < end diff --git a/server/src/Secure.hs b/server/src/Secure.hs new file mode 100644 index 0000000..f427304 --- /dev/null +++ b/server/src/Secure.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Secure + ( loggedAction + , getUserFromToken + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Text.Lazy (fromStrict) +import Network.HTTP.Types.Status (forbidden403) +import Web.Scotty + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User) + +import Model.Query (Query) +import qualified LoginSession +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User + +loggedAction :: (User -> ActionM ()) -> ActionM () +loggedAction action = do + maybeToken <- LoginSession.get + case maybeToken of + Just token -> do + maybeUser <- liftIO . Query.run . getUserFromToken $ token + case maybeUser of + Just user -> + action user + Nothing -> do + status forbidden403 + html . fromStrict . Message.get $ Key.Secure_Unauthorized + Nothing -> do + status forbidden403 + html . fromStrict . Message.get $ Key.Secure_Forbidden + +getUserFromToken :: Text -> Query (Maybe User) +getUserFromToken token = do + mbSignIn <- SignIn.getSignIn token + case mbSignIn of + Just signIn -> + User.get (SignIn.email signIn) + Nothing -> + return Nothing diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs new file mode 100644 index 0000000..f7ba3fd --- /dev/null +++ b/server/src/SendMail.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SendMail + ( sendMail + ) where + +import Control.Arrow (left) +import Control.Exception (SomeException, try) +import Data.Either (isLeft) + +import Data.Text (Text) +import Data.Text.Lazy.Builder (toLazyText, fromText) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified MimeMail as M + +import Model.Mail (Mail(Mail)) + +sendMail :: Mail -> IO (Either Text ()) +sendMail mail = do + result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) + if isLeft result + then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result)) + else putStrLn "OK" + return result + +getMimeMail :: Mail -> M.Mail +getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) = + let fromMail = M.emptyMail (address mailFrom) + in fromMail + { M.mailTo = map address mailTo + , M.mailParts = [ [ M.plainPart . strictToLazy $ mailPlainBody ] ] + , M.mailHeaders = [("Subject", mailSubject)] + } + +address :: Text -> M.Address +address addressEmail = + M.Address + { M.addressName = Nothing + , M.addressEmail = addressEmail + } + +strictToLazy :: Text -> LT.Text +strictToLazy = toLazyText . fromText diff --git a/server/src/Utils/Time.hs b/server/src/Utils/Time.hs new file mode 100644 index 0000000..97457c7 --- /dev/null +++ b/server/src/Utils/Time.hs @@ -0,0 +1,25 @@ +module Utils.Time + ( belongToCurrentMonth + , belongToCurrentWeek + , timeToDay + ) where + +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.LocalTime +import Data.Time.Calendar +import Data.Time.Calendar.WeekDate (toWeekDate) + +belongToCurrentMonth :: UTCTime -> IO Bool +belongToCurrentMonth time = do + (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time + (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) + return (actualYear == timeYear && actualMonth == timeMonth) + +belongToCurrentWeek :: UTCTime -> IO Bool +belongToCurrentWeek time = do + (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time + (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) + return (actualYear == timeYear && actualWeek == timeWeek) + +timeToDay :: UTCTime -> IO Day +timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/server/src/Validation.hs b/server/src/Validation.hs new file mode 100644 index 0000000..1f332c9 --- /dev/null +++ b/server/src/Validation.hs @@ -0,0 +1,23 @@ +module Validation + ( nonEmpty + , number + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +nonEmpty :: Text -> Maybe Text +nonEmpty str = + if T.null str + then Nothing + else Just str + +number :: (Int -> Bool) -> Text -> Maybe Int +number numberForm str = + case reads (T.unpack str) :: [(Int, String)] of + (num, _) : _ -> + if numberForm num + then Just num + else Nothing + _ -> + Nothing diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs new file mode 100644 index 0000000..1daca1e --- /dev/null +++ b/server/src/View/Mail/SignIn.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Mail.SignIn + ( mail + ) where + +import Data.Text (Text) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (User(..)) + +import Conf (Conf) +import qualified Conf as Conf +import qualified Model.Mail as M + +mail :: Conf -> User -> Text -> [Text] -> M.Mail +mail conf user url to = + M.Mail + { M.from = Conf.noReplyMail conf + , M.to = to + , M.subject = Message.get Key.SignIn_MailTitle + , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) + } diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs new file mode 100644 index 0000000..b5f2b67 --- /dev/null +++ b/server/src/View/Mail/WeeklyReport.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Mail.WeeklyReport + ( mail + ) where + +import Data.List (sortOn) +import Data.Map (Map) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import qualified Data.Map as M +import qualified Data.Text as T + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (Payment(..), User(..), UserId, Income(..)) +import qualified Common.Model as CM +import qualified Common.View.Format as Format + +import Model.Mail (Mail(Mail)) +import Model.Payment () +import qualified Model.Income () +import qualified Model.Mail as M +import Resource (Status(..), groupByStatus, statuses) +import Conf (Conf) +import qualified Conf as Conf + +mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail +mail conf users payments incomes start end = + Mail + { M.from = Conf.noReplyMail conf + , M.to = map _user_email users + , M.subject = T.concat + [ Message.get Key.App_Title + , " − " + , Message.get Key.WeeklyReport_Title + ] + , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) + } + +body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text +body conf users paymentsByStatus incomesByStatus = + if M.null paymentsByStatus && M.null incomesByStatus + then + Message.get Key.WeeklyReport_Empty + else + T.intercalate "\n" . catMaybes . concat $ + [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses + , map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses + ] + +paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text +paymentSection status conf users payments = + section sectionTitle sectionItems + where count = length payments + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count + Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count + Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count + sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments + +payedFor :: Status -> Conf -> [User] -> Payment -> Text +payedFor status conf users payment = + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) + _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) + where name = formatUserName (_payment_user payment) users + amount = Format.price (Conf.currency conf) . _payment_cost $ payment + for = _payment_name payment + at = Format.longDay $ _payment_date payment + +incomeSection :: Status -> Conf -> [User] -> [Income] -> Text +incomeSection status conf users incomes = + section sectionTitle sectionItems + where count = length incomes + sectionTitle = Message.get $ case status of + Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count + Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count + Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count + sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes + +isPayedFrom :: Status -> Conf -> [User] -> Income -> Text +isPayedFrom status conf users income = + case status of + Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) + _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) + where name = formatUserName (_income_userId income) users + amount = Format.price (Conf.currency conf) . _income_amount $ income + for = Format.longDay $ _income_date income + +formatUserName :: UserId -> [User] -> Text +formatUserName userId = fromMaybe "−" . fmap _user_name . CM.findUser userId + +section :: Text -> [Text] -> Text +section title items = + T.concat + [ title + , "\n\n" + , T.unlines . map (" - " <>) $ items + ] diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs new file mode 100644 index 0000000..6bf9527 --- /dev/null +++ b/server/src/View/Page.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +module View.Page + ( page + ) where + +import Data.Text.Internal.Lazy (Text) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Data.Aeson (encode) +import qualified Data.Aeson.Types as Json + +import Text.Blaze.Html +import Text.Blaze.Html5 +import qualified Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes +import qualified Text.Blaze.Html5.Attributes as A +import Text.Blaze.Html.Renderer.Text (renderHtml) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (InitResult) + +import Design.Global (globalDesign) + +page :: InitResult -> Text +page initResult = + renderHtml . docTypeHtml $ do + H.head $ do + meta ! charset "UTF-8" + meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" + H.title (toHtml $ Message.get Key.App_Title) + script ! src "javascript/main.js" $ "" + jsonScript "init" initResult + link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" + link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" + H.style $ toHtml globalDesign + +jsonScript :: Json.ToJSON a => Text -> a -> Html +jsonScript scriptId json = + script + ! A.id (toValue scriptId) + ! type_ "application/json" + $ toHtml . decodeUtf8 . encode $ json -- cgit v1.2.3