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
From 30f786e277b4ece6a09311de364082691f261ca3 Mon Sep 17 00:00:00 2001
From: Joris
Date: Fri, 10 Nov 2017 01:23:49 +0100
Subject: Minify javascript in dist mode, compress served files with gzip
---
server/server.cabal | 1 +
server/src/Main.hs | 5 ++++-
2 files changed, 5 insertions(+), 1 deletion(-)
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 2e1f7be..8bbe5f2 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -42,6 +42,7 @@ executable server
, unordered-containers
, uuid
, wai
+ , wai-extra
, wai-middleware-static
hs-source-dirs: src
default-language: Haskell2010
diff --git a/server/src/Main.hs b/server/src/Main.hs
index db73474..96c13ee 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -3,8 +3,10 @@
import Control.Applicative (liftA3)
import Control.Monad.IO.Class (liftIO)
-import Network.Wai.Middleware.Static
import qualified Data.Text.Lazy as LT
+import Network.Wai.Middleware.Gzip (GzipFiles(GzipCompress))
+import qualified Network.Wai.Middleware.Gzip as W
+import Network.Wai.Middleware.Static
import Web.Scotty
import qualified Conf
@@ -26,6 +28,7 @@ main = do
conf <- Conf.get "application.conf"
_ <- runDaemons conf
scotty (Conf.port conf) $ do
+ middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress }
middleware . staticPolicy $ noDots >-> addBase "public"
get "/exceedingPayer" $ do
--
cgit v1.2.3
From 213cf7ede058b781fc957de2cd9f6a5988c08004 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 12 Nov 2017 22:58:23 +0100
Subject: Add mocked pages
---
server/server.cabal | 57 ++++++++++++++++++++++++++++++++-
server/src/Design/Color.hs | 5 +++
server/src/Design/View/Payment/Pages.hs | 6 ++--
server/src/Design/View/Payment/Table.hs | 2 +-
4 files changed, 66 insertions(+), 4 deletions(-)
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 8bbe5f2..41b2fd6 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -32,8 +32,8 @@ executable server
, mtl
, parsec
, process
- , resourcet
, random
+ , resourcet
, scotty
, sqlite-simple
, text
@@ -46,3 +46,58 @@ executable server
, wai-middleware-static
hs-source-dirs: src
default-language: Haskell2010
+ other-modules: Conf
+ , Controller.Category
+ , Controller.Income
+ , Controller.Index
+ , Controller.Payment
+ , Controller.SignIn
+ , Cookie
+ , Design.Color
+ , Design.Constants
+ , Design.Dialog
+ , Design.Errors
+ , Design.Form
+ , Design.Global
+ , Design.Helper
+ , Design.Media
+ , Design.Tooltip
+ , Design.View.Header
+ , Design.View.Payment
+ , Design.View.Payment.Header
+ , Design.View.Payment.Pages
+ , Design.View.Payment.Table
+ , Design.View.SignIn
+ , Design.View.Stat
+ , Design.View.Table
+ , Design.Views
+ , Job.Daemon
+ , Job.Frequency
+ , Job.Kind
+ , Job.Model
+ , Job.MonthlyPayment
+ , Job.WeeklyReport
+ , Json
+ , LoginSession
+ , Main
+ , MimeMail
+ , Model.Category
+ , Model.Frequency
+ , Model.Income
+ , Model.Init
+ , Model.Mail
+ , Model.Payer
+ , Model.Payment
+ , Model.PaymentCategory
+ , Model.Query
+ , Model.SignIn
+ , Model.UUID
+ , Model.User
+ , Resource
+ , Secure
+ , SendMail
+ , Utils.Time
+ , Validation
+ , View.Mail.SignIn
+ , View.Mail.WeeklyReport
+ , View.Page
diff --git a/server/src/Design/Color.hs b/server/src/Design/Color.hs
index 06c468e..9a5797f 100644
--- a/server/src/Design/Color.hs
+++ b/server/src/Design/Color.hs
@@ -1,6 +1,8 @@
module Design.Color where
+import Clay
import qualified Clay.Color as C
+import Data.Text (Text)
-- http://chir.ag/projects/name-that-color/#969696
@@ -33,3 +35,6 @@ silver = C.rgb 200 200 200
dustyGray :: C.Color
dustyGray = C.rgb 150 150 150
+
+toString :: C.Color -> Text
+toString = plain . unValue . value
diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs
index ade81a8..5fc13f0 100644
--- a/server/src/Design/View/Payment/Pages.hs
+++ b/server/src/Design/View/Payment/Pages.hs
@@ -13,8 +13,8 @@ import qualified Design.Media as Media
design :: Css
design = do
- textAlign (alignSide sideCenter)
- Helper.clearFix
+ display flex
+ justifyContent center
Media.desktop $ do
padding (px 40) (px 30) (px 30) (px 30)
@@ -26,6 +26,8 @@ design = do
padding (px 20) (px 0) (px 20) (px 0)
lineHeight (px 40)
+ svg ? "path" ? ("fill" -: Color.toString Color.dustyGray)
+
".page" ? do
display inlineBlock
fontWeight bold
diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs
index a866b40..f8326e4 100644
--- a/server/src/Design/View/Payment/Table.hs
+++ b/server/src/Design/View/Payment/Table.hs
@@ -38,5 +38,5 @@ design = do
marginBottom (em 0.5)
".button" & svg ? do
- "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose))
+ "path" ? ("fill" -: Color.toString Color.chestnutRose)
width (px 18)
--
cgit v1.2.3
From 5a63f7be9375e3ab888e4232dd7ef72c2f1ffae1 Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 13 Nov 2017 23:56:40 +0100
Subject: Setup stylish-haskell
---
server/Setup.hs | 2 +-
server/server.cabal | 211 ++++++++++++++++---------------
server/src/Conf.hs | 20 +--
server/src/Controller/Category.hs | 23 ++--
server/src/Controller/Income.hs | 21 +--
server/src/Controller/Index.hs | 36 +++---
server/src/Controller/Payment.hs | 22 ++--
server/src/Controller/SignIn.hs | 32 ++---
server/src/Cookie.hs | 22 ++--
server/src/Design/Color.hs | 4 +-
server/src/Design/Constants.hs | 2 +-
server/src/Design/Dialog.hs | 4 +-
server/src/Design/Errors.hs | 4 +-
server/src/Design/Form.hs | 6 +-
server/src/Design/Global.hs | 20 +--
server/src/Design/Helper.hs | 8 +-
server/src/Design/Media.hs | 6 +-
server/src/Design/Tooltip.hs | 4 +-
server/src/Design/View/Header.hs | 8 +-
server/src/Design/View/Payment.hs | 6 +-
server/src/Design/View/Payment/Header.hs | 12 +-
server/src/Design/View/Payment/Pages.hs | 8 +-
server/src/Design/View/Payment/Table.hs | 2 +-
server/src/Design/View/SignIn.hs | 8 +-
server/src/Design/View/Stat.hs | 2 +-
server/src/Design/View/Table.hs | 6 +-
server/src/Design/Views.hs | 20 +--
server/src/Job/Daemon.hs | 25 ++--
server/src/Job/Frequency.hs | 2 +-
server/src/Job/Kind.hs | 13 +-
server/src/Job/Model.hs | 18 +--
server/src/Job/MonthlyPayment.hs | 10 +-
server/src/Job/WeeklyReport.hs | 12 +-
server/src/Json.hs | 10 +-
server/src/LoginSession.hs | 15 ++-
server/src/Main.hs | 38 +++---
server/src/MimeMail.hs | 68 +++++-----
server/src/Model/Category.hs | 16 +--
server/src/Model/Frequency.hs | 21 +--
server/src/Model/Income.hs | 18 +--
server/src/Model/Init.hs | 14 +-
server/src/Model/Mail.hs | 8 +-
server/src/Model/Payer.hs | 31 ++---
server/src/Model/Payment.hs | 34 ++---
server/src/Model/PaymentCategory.hs | 18 +--
server/src/Model/Query.hs | 4 +-
server/src/Model/SignIn.hs | 24 ++--
server/src/Model/UUID.hs | 6 +-
server/src/Model/User.hs | 16 +--
server/src/Resource.hs | 10 +-
server/src/Secure.hs | 24 ++--
server/src/SendMail.hs | 18 +--
server/src/Utils/Time.hs | 8 +-
server/src/Validation.hs | 2 +-
server/src/View/Mail/SignIn.hs | 12 +-
server/src/View/Mail/WeeklyReport.hs | 41 +++---
server/src/View/Page.hs | 28 ++--
57 files changed, 554 insertions(+), 529 deletions(-)
(limited to 'server')
diff --git a/server/Setup.hs b/server/Setup.hs
index 9a994af..4467109 100644
--- a/server/Setup.hs
+++ b/server/Setup.hs
@@ -1,2 +1,2 @@
-import Distribution.Simple
+import Distribution.Simple
main = defaultMain
diff --git a/server/server.cabal b/server/server.cabal
index 41b2fd6..d30060b 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -1,103 +1,110 @@
-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
+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
- , random
- , resourcet
- , scotty
- , sqlite-simple
- , text
- , time
- , transformers
- , unordered-containers
- , uuid
- , wai
- , wai-extra
- , wai-middleware-static
- hs-source-dirs: src
- default-language: Haskell2010
- other-modules: Conf
- , Controller.Category
- , Controller.Income
- , Controller.Index
- , Controller.Payment
- , Controller.SignIn
- , Cookie
- , Design.Color
- , Design.Constants
- , Design.Dialog
- , Design.Errors
- , Design.Form
- , Design.Global
- , Design.Helper
- , Design.Media
- , Design.Tooltip
- , Design.View.Header
- , Design.View.Payment
- , Design.View.Payment.Header
- , Design.View.Payment.Pages
- , Design.View.Payment.Table
- , Design.View.SignIn
- , Design.View.Stat
- , Design.View.Table
- , Design.Views
- , Job.Daemon
- , Job.Frequency
- , Job.Kind
- , Job.Model
- , Job.MonthlyPayment
- , Job.WeeklyReport
- , Json
- , LoginSession
- , Main
- , MimeMail
- , Model.Category
- , Model.Frequency
- , Model.Income
- , Model.Init
- , Model.Mail
- , Model.Payer
- , Model.Payment
- , Model.PaymentCategory
- , Model.Query
- , Model.SignIn
- , Model.UUID
- , Model.User
- , Resource
- , Secure
- , SendMail
- , Utils.Time
- , Validation
- , View.Mail.SignIn
- , View.Mail.WeeklyReport
- , View.Page
+Executable server
+ Main-is: Main.hs
+ Ghc-options: -Wall -Werror
+ Hs-source-dirs: src
+ Default-language: Haskell2010
+ Extensions:
+ ExistentialQuantification
+ MultiParamTypeClasses
+
+ 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
+ , random
+ , resourcet
+ , scotty
+ , sqlite-simple
+ , text
+ , time
+ , transformers
+ , unordered-containers
+ , uuid
+ , wai
+ , wai-extra
+ , wai-middleware-static
+
+ other-modules:
+ Conf
+ Controller.Category
+ Controller.Income
+ Controller.Index
+ Controller.Payment
+ Controller.SignIn
+ Cookie
+ Design.Color
+ Design.Constants
+ Design.Dialog
+ Design.Errors
+ Design.Form
+ Design.Global
+ Design.Helper
+ Design.Media
+ Design.Tooltip
+ Design.View.Header
+ Design.View.Payment
+ Design.View.Payment.Header
+ Design.View.Payment.Pages
+ Design.View.Payment.Table
+ Design.View.SignIn
+ Design.View.Stat
+ Design.View.Table
+ Design.Views
+ Job.Daemon
+ Job.Frequency
+ Job.Kind
+ Job.Model
+ Job.MonthlyPayment
+ Job.WeeklyReport
+ Json
+ LoginSession
+ Main
+ MimeMail
+ Model.Category
+ Model.Frequency
+ Model.Income
+ Model.Init
+ Model.Mail
+ Model.Payer
+ Model.Payment
+ Model.PaymentCategory
+ Model.Query
+ Model.SignIn
+ Model.UUID
+ Model.User
+ Resource
+ Secure
+ SendMail
+ Utils.Time
+ Validation
+ View.Mail.SignIn
+ View.Mail.WeeklyReport
+ View.Page
diff --git a/server/src/Conf.hs b/server/src/Conf.hs
index 26c5c28..299f071 100644
--- a/server/src/Conf.hs
+++ b/server/src/Conf.hs
@@ -5,20 +5,20 @@ module Conf
, Conf(..)
) where
-import Data.Text (Text)
-import qualified Data.Text as T
import qualified Data.ConfigManager as Conf
-import Data.Time.Clock (NominalDiffTime)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (NominalDiffTime)
-import Common.Model (Currency(..))
+import Common.Model (Currency (..))
data Conf = Conf
- { hostname :: Text
- , port :: Int
+ { hostname :: Text
+ , port :: Int
, signInExpiration :: NominalDiffTime
- , currency :: Currency
- , noReplyMail :: Text
- , https :: Bool
+ , currency :: Currency
+ , noReplyMail :: Text
+ , https :: Bool
} deriving Show
get :: FilePath -> IO Conf
@@ -36,4 +36,4 @@ get path = do
)
case conf of
Left msg -> error (T.unpack msg)
- Right c -> return c
+ Right c -> return c
diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs
index d6ed2f2..a646496 100644
--- a/server/src/Controller/Category.hs
+++ b/server/src/Controller/Category.hs
@@ -6,19 +6,20 @@ module Controller.Category
, 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 Control.Monad.IO.Class (liftIO)
+import qualified Data.Text.Lazy as TL
+import Network.HTTP.Types.Status (badRequest400, ok200)
+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 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 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 ()
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index 148b713..c42f6a7 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -6,18 +6,19 @@ module Controller.Income
, 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 Control.Monad.IO.Class (liftIO)
+import qualified Data.Text.Lazy as TL
+import Network.HTTP.Types.Status (badRequest400, ok200)
+import Web.Scotty
-import qualified Common.Message as Message
-import qualified Common.Message.Key as Key
-import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..))
+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 Json (jsonId)
+import qualified Model.Income as Income
+import qualified Model.Query as Query
import qualified Secure
create :: CreateIncome -> ActionM ()
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index 8473c5c..bf4859d 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -3,26 +3,26 @@ module Controller.Index
, 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 Control.Monad.IO.Class (liftIO)
+import Data.Text (Text)
+import Data.Time.Clock (diffUTCTime, getCurrentTime)
+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 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 Conf (Conf (..))
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)
+import Model.Init (getInit)
+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
@@ -70,7 +70,7 @@ validateSignIn conf textToken = do
SignIn.signInTokenToUsed . SignIn.id $ signIn
User.get . SignIn.email $ signIn
return $ case mbUser of
- Nothing -> Left Key.Secure_Unauthorized
+ Nothing -> Left Key.Secure_Unauthorized
Just user -> Right user
getLoggedUser :: ActionM (Maybe User)
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index dc10311..e4104eb 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -7,16 +7,18 @@ module Controller.Payment
, 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 Control.Monad.IO.Class (liftIO)
+import Network.HTTP.Types.Status (badRequest400, ok200)
+import Web.Scotty
+
+import Common.Model (CreatePayment (..),
+ EditPayment (..), PaymentId,
+ User (..))
+
+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 ()
diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs
index 0086fa5..5552781 100644
--- a/server/src/Controller/SignIn.hs
+++ b/server/src/Controller/SignIn.hs
@@ -4,25 +4,25 @@ 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 Control.Monad.IO.Class (liftIO)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy as TL
+import Network.HTTP.Types.Status (badRequest400, ok200)
+import Web.Scotty
-import qualified Common.Message as Message
-import qualified Common.Message.Key as Key
-import Common.Model (SignIn(..))
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (SignIn (..))
-import Conf (Conf)
+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 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
+import qualified Text.Email.Validate as Email
+import qualified View.Mail.SignIn as SignIn
signIn :: Conf -> SignIn -> ActionM ()
signIn conf (SignIn email) =
@@ -41,7 +41,7 @@ signIn conf (SignIn email) =
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
+ 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
index 96d45da..511dd42 100644
--- a/server/src/Cookie.hs
+++ b/server/src/Cookie.hs
@@ -9,25 +9,25 @@ module Cookie
, deleteCookie
) where
-import Control.Monad ( liftM )
+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 qualified Data.Text as TS
+import qualified Data.Text.Encoding as TS
+import qualified Data.Text.Lazy.Encoding as TL
-import Conf (Conf)
+import Conf (Conf)
import qualified Conf
-import qualified Data.Map as Map
+import qualified Data.Map as Map
-import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Lazy as BSL
-import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
-import Blaze.ByteString.Builder ( toLazyByteString )
+import Blaze.ByteString.Builder (toLazyByteString)
-import Web.Scotty.Trans
-import Web.Cookie
+import Web.Cookie
+import Web.Scotty.Trans
makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie
makeSimpleCookie conf name value =
diff --git a/server/src/Design/Color.hs b/server/src/Design/Color.hs
index 9a5797f..e7f5aec 100644
--- a/server/src/Design/Color.hs
+++ b/server/src/Design/Color.hs
@@ -1,8 +1,8 @@
module Design.Color where
-import Clay
+import Clay
import qualified Clay.Color as C
-import Data.Text (Text)
+import Data.Text (Text)
-- http://chir.ag/projects/name-that-color/#969696
diff --git a/server/src/Design/Constants.hs b/server/src/Design/Constants.hs
index 4e2b8cc..a3123d9 100644
--- a/server/src/Design/Constants.hs
+++ b/server/src/Design/Constants.hs
@@ -1,6 +1,6 @@
module Design.Constants where
-import Clay
+import Clay
iconFontSize :: Size LengthUnit
iconFontSize = px 32
diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs
index 4678633..6759606 100644
--- a/server/src/Design/Dialog.hs
+++ b/server/src/Design/Dialog.hs
@@ -4,9 +4,9 @@ module Design.Dialog
( design
) where
-import Data.Monoid ((<>))
+import Data.Monoid ((<>))
-import Clay
+import Clay
design :: Css
design = do
diff --git a/server/src/Design/Errors.hs b/server/src/Design/Errors.hs
index 57aaeee..2c6c16b 100644
--- a/server/src/Design/Errors.hs
+++ b/server/src/Design/Errors.hs
@@ -4,9 +4,9 @@ module Design.Errors
( design
) where
-import Clay
+import Clay
-import Design.Color as Color
+import Design.Color as Color
design :: Css
design = do
diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs
index ebb8ac8..a4a1de0 100644
--- a/server/src/Design/Form.hs
+++ b/server/src/Design/Form.hs
@@ -4,11 +4,11 @@ module Design.Form
( design
) where
-import Data.Monoid ((<>))
+import Data.Monoid ((<>))
-import Clay
+import Clay
-import Design.Color as Color
+import Design.Color as Color
design :: Css
design = do
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index 47ea4a9..1fe6a80 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -4,20 +4,20 @@ module Design.Global
( globalDesign
) where
-import Clay
+import Clay
-import Data.Text.Lazy (Text)
+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.Dialog as Dialog
+import qualified Design.Errors as Errors
+import qualified Design.Form as Form
+import qualified Design.Tooltip as Tooltip
+import qualified Design.Views as Views
-import qualified Design.Color as Color
-import qualified Design.Helper as Helper
+import qualified Design.Color as Color
import qualified Design.Constants as Constants
-import qualified Design.Media as Media
+import qualified Design.Helper as Helper
+import qualified Design.Media as Media
globalDesign :: Text
globalDesign = renderWith compact [] global
diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs
index 41528ed..0913511 100644
--- a/server/src/Design/Helper.hs
+++ b/server/src/Design/Helper.hs
@@ -9,12 +9,12 @@ module Design.Helper
, verticalCentering
) where
-import Prelude hiding (span)
+import Prelude hiding (span)
-import Clay hiding (button, input)
+import Clay hiding (button, input)
-import Design.Constants
-import Design.Color as Color
+import Design.Color as Color
+import Design.Constants
clearFix :: Css
clearFix =
diff --git a/server/src/Design/Media.hs b/server/src/Design/Media.hs
index 77220ee..19a3b8c 100644
--- a/server/src/Design/Media.hs
+++ b/server/src/Design/Media.hs
@@ -6,10 +6,10 @@ module Design.Media
, desktop
) where
-import Clay hiding (query)
+import Clay hiding (query)
import qualified Clay
-import Clay.Stylesheet (Feature)
-import qualified Clay.Media as Media
+import qualified Clay.Media as Media
+import Clay.Stylesheet (Feature)
mobile :: Css -> Css
mobile = query [Media.maxWidth mobileTabletLimit]
diff --git a/server/src/Design/Tooltip.hs b/server/src/Design/Tooltip.hs
index 1da8764..57aec33 100644
--- a/server/src/Design/Tooltip.hs
+++ b/server/src/Design/Tooltip.hs
@@ -4,9 +4,9 @@ module Design.Tooltip
( design
) where
-import Clay
+import Clay
-import Design.Color as Color
+import Design.Color as Color
design :: Css
design = do
diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs
index 20627e6..d05f748 100644
--- a/server/src/Design/View/Header.hs
+++ b/server/src/Design/View/Header.hs
@@ -4,13 +4,13 @@ module Design.View.Header
( design
) where
-import Data.Monoid ((<>))
+import Data.Monoid ((<>))
-import Clay
+import Clay
-import Design.Color as Color
+import Design.Color as Color
import qualified Design.Helper as Helper
-import qualified Design.Media as Media
+import qualified Design.Media as Media
design :: Css
design = do
diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs
index d3c7650..62f7061 100644
--- a/server/src/Design/View/Payment.hs
+++ b/server/src/Design/View/Payment.hs
@@ -4,11 +4,11 @@ module Design.View.Payment
( design
) where
-import Clay
+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
+import qualified Design.View.Payment.Pages as Pages
+import qualified Design.View.Payment.Table as Table
design :: Css
design = do
diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs
index f02da8a..d87e95b 100644
--- a/server/src/Design/View/Payment/Header.hs
+++ b/server/src/Design/View/Payment/Header.hs
@@ -4,16 +4,16 @@ module Design.View.Payment.Header
( design
) where
-import Data.Monoid ((<>))
+import Data.Monoid ((<>))
-import Clay
+import Clay
-import Design.Constants
+import Design.Constants
-import qualified Design.Helper as Helper
-import qualified Design.Color as Color
+import qualified Design.Color as Color
import qualified Design.Constants as Constants
-import qualified Design.Media as Media
+import qualified Design.Helper as Helper
+import qualified Design.Media as Media
design :: Css
design = do
diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs
index 5fc13f0..f6660a1 100644
--- a/server/src/Design/View/Payment/Pages.hs
+++ b/server/src/Design/View/Payment/Pages.hs
@@ -4,12 +4,12 @@ module Design.View.Payment.Pages
( design
) where
-import Clay
+import Clay
-import qualified Design.Color as Color
-import qualified Design.Helper as Helper
+import qualified Design.Color as Color
import qualified Design.Constants as Constants
-import qualified Design.Media as Media
+import qualified Design.Helper as Helper
+import qualified Design.Media as Media
design :: Css
design = do
diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs
index f8326e4..243d7f4 100644
--- a/server/src/Design/View/Payment/Table.hs
+++ b/server/src/Design/View/Payment/Table.hs
@@ -4,7 +4,7 @@ module Design.View.Payment.Table
( design
) where
-import Clay
+import Clay
import qualified Design.Color as Color
import qualified Design.Media as Media
diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs
index 214e663..2b1252f 100644
--- a/server/src/Design/View/SignIn.hs
+++ b/server/src/Design/View/SignIn.hs
@@ -4,12 +4,12 @@ module Design.View.SignIn
( design
) where
-import Clay
-import Data.Monoid ((<>))
+import Clay
+import Data.Monoid ((<>))
-import qualified Design.Color as Color
-import qualified Design.Helper as Helper
+import qualified Design.Color as Color
import qualified Design.Constants as Constants
+import qualified Design.Helper as Helper
design :: Css
design = do
diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs
index 0a5b258..b10dd7b 100644
--- a/server/src/Design/View/Stat.hs
+++ b/server/src/Design/View/Stat.hs
@@ -4,7 +4,7 @@ module Design.View.Stat
( design
) where
-import Clay
+import Clay
design :: Css
design = do
diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs
index 95abf90..fd55656 100644
--- a/server/src/Design/View/Table.hs
+++ b/server/src/Design/View/Table.hs
@@ -4,11 +4,11 @@ module Design.View.Table
( design
) where
-import Data.Monoid ((<>))
+import Data.Monoid ((<>))
-import Clay
+import Clay
-import Design.Color as Color
+import Design.Color as Color
import qualified Design.Media as Media
design :: Css
diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs
index bc6ac83..1157b68 100644
--- a/server/src/Design/Views.hs
+++ b/server/src/Design/Views.hs
@@ -4,18 +4,18 @@ module Design.Views
( design
) where
-import Clay
+import Clay
-import qualified Design.View.Header as Header
+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
+import qualified Design.View.SignIn as SignIn
+import qualified Design.View.Stat as Stat
+import qualified Design.View.Table as Table
+
+import qualified Design.Color as Color
+import qualified Design.Constants as Constants
+import qualified Design.Helper as Helper
+import qualified Design.Media as Media
design :: Css
design = do
diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs
index 0bc6f6e..26977d1 100644
--- a/server/src/Job/Daemon.hs
+++ b/server/src/Job/Daemon.hs
@@ -2,18 +2,19 @@ module Job.Daemon
( runDaemons
) where
-import Control.Concurrent (threadDelay, forkIO, ThreadId)
-import Control.Monad (forever)
-import Data.Time.Clock (UTCTime)
+import Control.Concurrent (ThreadId, forkIO, threadDelay)
+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)
+import Conf (Conf)
+import Job.Frequency (Frequency (..), microSeconds)
+import Job.Kind (Kind (..))
+import Job.Model (actualizeLastCheck, actualizeLastExecution,
+ getLastExecution)
+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
@@ -29,7 +30,7 @@ runDaemon kind frequency isLastExecutionTooOld runJob =
getLastExecution kind
hasToRun <- case mbLastExecution of
Just lastExecution -> isLastExecutionTooOld lastExecution
- Nothing -> return True
+ Nothing -> return True
if hasToRun
then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind)
else return ()
diff --git a/server/src/Job/Frequency.hs b/server/src/Job/Frequency.hs
index 263f6e6..c5bef42 100644
--- a/server/src/Job/Frequency.hs
+++ b/server/src/Job/Frequency.hs
@@ -10,4 +10,4 @@ data Frequency =
microSeconds :: Frequency -> Int
microSeconds EveryHour = 1000000 * 60 * 60
-microSeconds EveryDay = (microSeconds EveryHour) * 24
+microSeconds EveryDay = (microSeconds EveryHour) * 24
diff --git a/server/src/Job/Kind.hs b/server/src/Job/Kind.hs
index af5d4f8..17997f7 100644
--- a/server/src/Job/Kind.hs
+++ b/server/src/Job/Kind.hs
@@ -2,11 +2,12 @@ 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
+import qualified Data.Text as T
+import Database.SQLite.Simple (SQLData (SQLText))
+import Database.SQLite.Simple.FromField (FromField (fromField),
+ fieldData)
+import Database.SQLite.Simple.Ok (Ok (Errors, Ok))
+import Database.SQLite.Simple.ToField (ToField (toField))
data Kind =
MonthlyPayment
@@ -16,7 +17,7 @@ data Kind =
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"]
+ _ -> 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
index e1a3c77..b90dca0 100644
--- a/server/src/Job/Model.hs
+++ b/server/src/Job/Model.hs
@@ -7,20 +7,20 @@ module Job.Model
, actualizeLastCheck
) where
-import Data.Maybe (isJust)
-import Data.Time.Clock (UTCTime, getCurrentTime)
-import Database.SQLite.Simple (Only(Only))
+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 Prelude hiding (id)
-import Job.Kind
-import Model.Query (Query(Query))
+import Job.Kind
+import Model.Query (Query (Query))
data Job = Job
- { id :: String
- , kind :: Kind
+ { id :: String
+ , kind :: Kind
, lastExecution :: Maybe UTCTime
- , lastCheck :: Maybe UTCTime
+ , lastCheck :: Maybe UTCTime
} deriving (Show)
getLastExecution :: Kind -> Query (Maybe UTCTime)
diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs
index ba24cca..8cb1c27 100644
--- a/server/src/Job/MonthlyPayment.hs
+++ b/server/src/Job/MonthlyPayment.hs
@@ -2,13 +2,13 @@ module Job.MonthlyPayment
( monthlyPayment
) where
-import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Clock (UTCTime, getCurrentTime)
-import Common.Model (Frequency(..), Payment(..))
+import Common.Model (Frequency (..), Payment (..))
-import qualified Model.Payment as Payment
-import Utils.Time (timeToDay)
-import qualified Model.Query as Query
+import qualified Model.Payment as Payment
+import qualified Model.Query as Query
+import Utils.Time (timeToDay)
monthlyPayment :: Maybe UTCTime -> IO UTCTime
monthlyPayment _ = do
diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs
index 5737c75..74180df 100644
--- a/server/src/Job/WeeklyReport.hs
+++ b/server/src/Job/WeeklyReport.hs
@@ -2,13 +2,13 @@ module Job.WeeklyReport
( weeklyReport
) where
-import Data.Time.Clock (UTCTime, getCurrentTime)
+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 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
diff --git a/server/src/Json.hs b/server/src/Json.hs
index cc6327a..eb5c572 100644
--- a/server/src/Json.hs
+++ b/server/src/Json.hs
@@ -1,16 +1,16 @@
+{-# LANGUAGE FlexibleContexts #-}
{-# 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.Aeson.Types as Json
import qualified Data.HashMap.Strict as M
-import Web.Scotty
+import Data.Int (Int64)
+import Data.Text (Text)
+import Web.Scotty
jsonObject :: [(Text, Json.Value)] -> ActionM ()
jsonObject = json . Json.Object . M.fromList
diff --git a/server/src/LoginSession.hs b/server/src/LoginSession.hs
index 6f6d620..beca697 100644
--- a/server/src/LoginSession.hs
+++ b/server/src/LoginSession.hs
@@ -6,16 +6,17 @@ module LoginSession
, delete
) where
-import Web.Scotty (ActionM)
-import Cookie (setSimpleCookie, getCookie, deleteCookie)
-import qualified Web.ClientSession as CS
+import Cookie (deleteCookie, getCookie,
+ setSimpleCookie)
+import qualified Web.ClientSession as CS
+import Web.Scotty (ActionM)
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.IO.Class (liftIO)
-import Data.Text (Text)
-import qualified Data.Text.Encoding as TE
+import Data.Text (Text)
+import qualified Data.Text.Encoding as TE
-import Conf (Conf)
+import Conf (Conf)
sessionName :: Text
sessionName = "SESSION"
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 96c13ee..5ac68db 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -1,27 +1,27 @@
{-# LANGUAGE OverloadedStrings #-}
-import Control.Applicative (liftA3)
-import Control.Monad.IO.Class (liftIO)
+import Control.Applicative (liftA3)
+import Control.Monad.IO.Class (liftIO)
-import qualified Data.Text.Lazy as LT
-import Network.Wai.Middleware.Gzip (GzipFiles(GzipCompress))
-import qualified Network.Wai.Middleware.Gzip as W
-import Network.Wai.Middleware.Static
-import Web.Scotty
+import qualified Data.Text.Lazy as LT
+import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress))
+import qualified Network.Wai.Middleware.Gzip as W
+import Network.Wai.Middleware.Static
+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
+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 qualified Data.Time as Time
+import Job.Daemon (runDaemons)
+import qualified Model.Income as IncomeM
+import Model.Payer (getOrderedExceedingPayers)
+import qualified Model.Payment as PaymentM
+import qualified Model.Query as Query
+import qualified Model.User as UserM
main :: IO ()
main = do
diff --git a/server/src/MimeMail.hs b/server/src/MimeMail.hs
index 0faaf98..7fe98ed 100644
--- a/server/src/MimeMail.hs
+++ b/server/src/MimeMail.hs
@@ -38,31 +38,33 @@ module MimeMail
, 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
+import Blaze.ByteString.Builder
+import Blaze.ByteString.Builder.Char.Utf8
+import Control.Arrow
+import Control.Concurrent (forkIO, newEmptyMVar,
+ putMVar, takeMVar)
+import Control.Exception (ErrorCall (ErrorCall),
+ throwIO)
+import Control.Monad (foldM, void, (<=<))
+import Data.Bits (shiftR, (.&.))
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Base64 as Base64
+import Data.ByteString.Char8 ()
+import qualified Data.ByteString.Lazy as L
+import Data.Char (isAscii, isControl)
+import Data.List (intersperse)
+import Data.Monoid
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LT
+import Data.Word (Word8)
+import System.Exit
+import System.FilePath (takeFileName)
+import System.IO
+import System.Process
+import System.Random
-- | Generates a random sequence of alphanumerics of the given length.
randomString :: RandomGen d => Int -> d -> (String, d)
@@ -88,10 +90,10 @@ instance Random Boundary where
-- | An entire mail message.
data Mail = Mail
- { mailFrom :: Address
- , mailTo :: [Address]
- , mailCc :: [Address]
- , mailBcc :: [Address]
+ { 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:
@@ -100,7 +102,7 @@ data Mail = Mail
--
-- Make sure when specifying alternatives to place the most preferred
-- version last.
- , mailParts :: [Alternatives]
+ , mailParts :: [Alternatives]
}
deriving Show
@@ -132,13 +134,13 @@ type Alternatives = [Part]
-- | A single part of a multipart message.
data Part = Part
- { partType :: Text -- ^ content type
+ { 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
+ , partHeaders :: Headers
+ , partContent :: L.ByteString
}
deriving (Eq, Show)
diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs
index 6b7a488..b972ebd 100644
--- a/server/src/Model/Category.hs
+++ b/server/src/Model/Category.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.Category
@@ -8,16 +8,16 @@ module Model.Category
, 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 Data.Maybe (isJust, listToMaybe)
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime)
+import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
-import Prelude hiding (id)
+import Prelude hiding (id)
-import Common.Model (Category(..), CategoryId)
+import Common.Model (Category (..), CategoryId)
-import Model.Query (Query(Query))
+import Model.Query (Query (Query))
instance FromRow Category where
fromRow = Category <$>
diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs
index b334a40..41a325d 100644
--- a/server/src/Model/Frequency.hs
+++ b/server/src/Model/Frequency.hs
@@ -1,22 +1,23 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# 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 qualified Data.Text as T
+import Database.SQLite.Simple (SQLData (SQLText))
+import Database.SQLite.Simple.FromField (FromField (fromField),
+ fieldData)
+import Database.SQLite.Simple.Ok (Ok (Errors, Ok))
+import Database.SQLite.Simple.ToField (ToField (toField))
-import Common.Model (Frequency)
+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"]
+ _ -> 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
index bbe7657..a69112a 100644
--- a/server/src/Model/Income.hs
+++ b/server/src/Model/Income.hs
@@ -9,17 +9,19 @@ module Model.Income
, 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 Data.Maybe (listToMaybe)
+import Data.Time.Calendar (Day)
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
+import Prelude hiding (id)
-import Common.Model (Income(..), IncomeId, User(..), UserId)
+import Common.Model (Income (..), IncomeId, User (..),
+ UserId)
-import Model.Query (Query(Query))
-import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt)
+import Model.Query (Query (Query))
+import Resource (Resource, resourceCreatedAt,
+ resourceDeletedAt, resourceEditedAt)
instance Resource Income where
resourceCreatedAt = _income_createdAt
diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs
index 8c6a961..c030c58 100644
--- a/server/src/Model/Init.hs
+++ b/server/src/Model/Init.hs
@@ -4,16 +4,16 @@ module Model.Init
( getInit
) where
-import Common.Model (Init(Init), User(..))
+import Common.Model (Init (Init), User (..))
-import Conf (Conf)
+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.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
+import Model.Query (Query)
+import qualified Model.User as User
getInit :: User -> Conf -> Query Init
getInit user conf =
diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs
index 9a4db73..a19f9ae 100644
--- a/server/src/Model/Mail.hs
+++ b/server/src/Model/Mail.hs
@@ -2,11 +2,11 @@ module Model.Mail
( Mail(..)
) where
-import Data.Text (Text)
+import Data.Text (Text)
data Mail = Mail
- { from :: Text
- , to :: [Text]
- , subject :: Text
+ { 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
index de4abd1..db3f37c 100644
--- a/server/src/Model/Payer.hs
+++ b/server/src/Model/Payer.hs
@@ -2,14 +2,15 @@ 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 qualified Data.List as List
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified Data.Maybe as Maybe
+import Data.Time (NominalDiffTime, UTCTime (..))
+import qualified Data.Time as Time
-import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..))
+import Common.Model (Income (..), IncomeId, Payment (..), User (..),
+ UserId)
type Users = Map UserId User
@@ -20,20 +21,20 @@ type Incomes = Map IncomeId Income
type Payments = [Payment]
data Payer = Payer
- { preIncomePaymentSum :: Int
+ { preIncomePaymentSum :: Int
, postIncomePaymentSum :: Int
- , _incomes :: [Income]
+ , _incomes :: [Income]
}
data PostPaymentPayer = PostPaymentPayer
{ _preIncomePaymentSum :: Int
- , _cumulativeIncome :: Int
- , ratio :: Float
+ , _cumulativeIncome :: Int
+ , ratio :: Float
}
data ExceedingPayer = ExceedingPayer
{ _userId :: UserId
- , amount :: Int
+ , amount :: Int
} deriving (Show)
getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer]
@@ -72,7 +73,7 @@ useIncomesFrom users incomes payments =
mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes
in case (firstPaymentTime, mbIncomeTime) of
(Just t1, Just t2) -> Just (max t1 t2)
- _ -> Nothing
+ _ -> Nothing
paymentTime :: Payment -> UTCTime
paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date
@@ -95,7 +96,7 @@ getPayers currentTime users incomes payments =
(\p ->
case incomesDefined of
Nothing -> False
- Just t -> paymentTime p >= t
+ Just t -> paymentTime p >= t
)
userId
payments
@@ -197,7 +198,7 @@ nominalDay :: NominalDiffTime
nominalDay = 86400
safeHead :: [a] -> Maybe a
-safeHead [] = Nothing
+safeHead [] = Nothing
safeHead (x : _) = Just x
safeMinimum :: (Ord a) => [a] -> Maybe a
diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs
index 14efe77..c1b109f 100644
--- a/server/src/Model/Payment.hs
+++ b/server/src/Model/Payment.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.Payment
@@ -13,22 +13,26 @@ module Model.Payment
, 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 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 (FromRow (fromRow), Only (Only),
+ ToRow)
+import qualified Database.SQLite.Simple as SQLite
+import Database.SQLite.Simple.ToField (ToField (toField))
+import Prelude hiding (id)
-import Common.Model (Frequency(..), Payment(..), PaymentId, UserId)
+import Common.Model (Frequency (..), Payment (..),
+ PaymentId, UserId)
-import Model.Frequency ()
-import Model.Query (Query(Query))
-import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt)
+import Model.Frequency ()
+import Model.Query (Query (Query))
+import Resource (Resource, resourceCreatedAt,
+ resourceDeletedAt,
+ resourceEditedAt)
instance Resource Payment where
resourceCreatedAt = _payment_createdAt
diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs
index 6e1d304..6d02136 100644
--- a/server/src/Model/PaymentCategory.hs
+++ b/server/src/Model/PaymentCategory.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.PaymentCategory
@@ -7,17 +7,17 @@ module Model.PaymentCategory
, 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 Data.Maybe (isJust, listToMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (getCurrentTime)
+import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
-import Common.Model (CategoryId, PaymentCategory(..))
-import qualified Common.Util.Text as T
+import Common.Model (CategoryId, PaymentCategory (..))
+import qualified Common.Util.Text as T
-import Model.Query (Query(Query))
+import Model.Query (Query (Query))
instance FromRow PaymentCategory where
fromRow = PaymentCategory <$>
diff --git a/server/src/Model/Query.hs b/server/src/Model/Query.hs
index d15fb5f..22ae95b 100644
--- a/server/src/Model/Query.hs
+++ b/server/src/Model/Query.hs
@@ -3,8 +3,8 @@ module Model.Query
, run
) where
-import Data.Functor (Functor)
-import Database.SQLite.Simple (Connection)
+import Data.Functor (Functor)
+import Database.SQLite.Simple (Connection)
import qualified Database.SQLite.Simple as SQLite
data Query a = Query (Connection -> IO a)
diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs
index c5182f0..6f38fe7 100644
--- a/server/src/Model/SignIn.hs
+++ b/server/src/Model/SignIn.hs
@@ -8,25 +8,25 @@ module Model.SignIn
, 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 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 (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
-import Model.Query (Query(Query))
-import Model.UUID (generateUUID)
+import Model.Query (Query (Query))
+import Model.UUID (generateUUID)
type SignInId = Int64
data SignIn = SignIn
- { id :: SignInId
- , token :: Text
+ { id :: SignInId
+ , token :: Text
, creation :: UTCTime
- , email :: Text
- , isUsed :: Bool
+ , email :: Text
+ , isUsed :: Bool
} deriving Show
instance FromRow SignIn where
diff --git a/server/src/Model/UUID.hs b/server/src/Model/UUID.hs
index 6cb7ce0..0959a8e 100644
--- a/server/src/Model/UUID.hs
+++ b/server/src/Model/UUID.hs
@@ -2,9 +2,9 @@ module Model.UUID
( generateUUID
) where
-import Data.UUID (toString)
-import Data.UUID.V4 (nextRandom)
-import Data.Text (Text, pack)
+import Data.Text (Text, pack)
+import Data.UUID (toString)
+import Data.UUID.V4 (nextRandom)
generateUUID :: IO Text
generateUUID = pack . toString <$> nextRandom
diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs
index e14fcef..f17f545 100644
--- a/server/src/Model/User.hs
+++ b/server/src/Model/User.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.User
@@ -8,16 +8,16 @@ module Model.User
, 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 Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime)
+import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
+import Prelude hiding (id)
-import Common.Model (UserId, User(..))
+import Common.Model (User (..), UserId)
-import Model.Query (Query(Query))
+import Model.Query (Query (Query))
instance FromRow User where
fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field
diff --git a/server/src/Resource.hs b/server/src/Resource.hs
index f52bbfa..a12a0f2 100644
--- a/server/src/Resource.hs
+++ b/server/src/Resource.hs
@@ -9,10 +9,10 @@ module Resource
, statusDuring
) where
-import Data.Maybe (fromMaybe)
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Time.Clock (UTCTime)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.Time.Clock (UTCTime)
class Resource a where
resourceCreatedAt :: a -> UTCTime
@@ -34,7 +34,7 @@ groupByStatus start end resources =
(\m resource ->
case statusDuring start end resource of
Just status -> M.insertWith (++) status [resource] m
- Nothing -> m
+ Nothing -> m
)
M.empty
resources
diff --git a/server/src/Secure.hs b/server/src/Secure.hs
index f427304..88bdcda 100644
--- a/server/src/Secure.hs
+++ b/server/src/Secure.hs
@@ -5,21 +5,21 @@ module Secure
, 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 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 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
+import Model.Query (Query)
+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
diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs
index f7ba3fd..959f21d 100644
--- a/server/src/SendMail.hs
+++ b/server/src/SendMail.hs
@@ -4,17 +4,17 @@ module SendMail
( sendMail
) where
-import Control.Arrow (left)
-import Control.Exception (SomeException, try)
-import Data.Either (isLeft)
+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 Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
+import Data.Text.Lazy.Builder (fromText, toLazyText)
+import qualified MimeMail as M
-import Model.Mail (Mail(Mail))
+import Model.Mail (Mail (Mail))
sendMail :: Mail -> IO (Either Text ())
sendMail mail = do
diff --git a/server/src/Utils/Time.hs b/server/src/Utils/Time.hs
index 97457c7..e1a94d3 100644
--- a/server/src/Utils/Time.hs
+++ b/server/src/Utils/Time.hs
@@ -4,10 +4,10 @@ module Utils.Time
, timeToDay
) where
-import Data.Time.Clock (UTCTime, getCurrentTime)
-import Data.Time.LocalTime
-import Data.Time.Calendar
-import Data.Time.Calendar.WeekDate (toWeekDate)
+import Data.Time.Calendar
+import Data.Time.Calendar.WeekDate (toWeekDate)
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.LocalTime
belongToCurrentMonth :: UTCTime -> IO Bool
belongToCurrentMonth time = do
diff --git a/server/src/Validation.hs b/server/src/Validation.hs
index 1f332c9..fd739cd 100644
--- a/server/src/Validation.hs
+++ b/server/src/Validation.hs
@@ -3,7 +3,7 @@ module Validation
, number
) where
-import Data.Text (Text)
+import Data.Text (Text)
import qualified Data.Text as T
nonEmpty :: Text -> Maybe Text
diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs
index 1daca1e..d542fd8 100644
--- a/server/src/View/Mail/SignIn.hs
+++ b/server/src/View/Mail/SignIn.hs
@@ -4,15 +4,15 @@ module View.Mail.SignIn
( mail
) where
-import Data.Text (Text)
+import Data.Text (Text)
-import qualified Common.Message as Message
+import qualified Common.Message as Message
import qualified Common.Message.Key as Key
-import Common.Model (User(..))
+import Common.Model (User (..))
-import Conf (Conf)
-import qualified Conf as Conf
-import qualified Model.Mail as M
+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 =
diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs
index b5f2b67..c0e89d5 100644
--- a/server/src/View/Mail/WeeklyReport.hs
+++ b/server/src/View/Mail/WeeklyReport.hs
@@ -4,28 +4,29 @@ 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 Data.List (sortOn)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (catMaybes, fromMaybe)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime)
-import qualified Common.Message as Message
+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 Common.Model (Income (..), Payment (..), User (..),
+ UserId)
+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
+import Conf (Conf)
+import qualified Conf as Conf
+import qualified Model.Income ()
+import Model.Mail (Mail (Mail))
+import qualified Model.Mail as M
+import Model.Payment ()
+import Resource (Status (..), groupByStatus, statuses)
mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail
mail conf users payments incomes start end =
@@ -65,7 +66,7 @@ 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)
+ _ -> 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
@@ -85,7 +86,7 @@ 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)
+ _ -> 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
diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs
index 6bf9527..ff7bdc7 100644
--- a/server/src/View/Page.hs
+++ b/server/src/View/Page.hs
@@ -4,23 +4,23 @@ 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 Data.Aeson (encode)
+import qualified Data.Aeson.Types as Json
+import Data.Text.Internal.Lazy (Text)
+import Data.Text.Lazy.Encoding (decodeUtf8)
-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 Text.Blaze.Html
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+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 qualified Common.Message as Message
-import qualified Common.Message.Key as Key
-import Common.Model (InitResult)
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (InitResult)
-import Design.Global (globalDesign)
+import Design.Global (globalDesign)
page :: InitResult -> Text
page initResult =
--
cgit v1.2.3
From 7194cddb28656c721342c2ef604f9f9fb0692960 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 19 Nov 2017 00:20:25 +0100
Subject: Show payment count and partition
- Also fixes exceedingPayer in back by using only punctual payments
---
server/server.cabal | 7 ++++---
server/src/Conf.hs | 2 --
server/src/Controller/Category.hs | 7 ++-----
server/src/Controller/Income.hs | 7 ++-----
server/src/Controller/Index.hs | 15 +++++++-------
server/src/Controller/Payment.hs | 2 --
server/src/Controller/SignIn.hs | 15 ++++++--------
server/src/Cookie.hs | 2 --
server/src/Design/Dialog.hs | 2 --
server/src/Design/Errors.hs | 2 --
server/src/Design/Form.hs | 2 --
server/src/Design/Global.hs | 2 --
server/src/Design/Helper.hs | 2 --
server/src/Design/Tooltip.hs | 2 --
server/src/Design/View/Header.hs | 2 --
server/src/Design/View/Payment.hs | 2 --
server/src/Design/View/Payment/Header.hs | 2 --
server/src/Design/View/Payment/Pages.hs | 2 --
server/src/Design/View/Payment/Table.hs | 2 --
server/src/Design/View/SignIn.hs | 2 --
server/src/Design/View/Stat.hs | 2 --
server/src/Design/View/Table.hs | 2 --
server/src/Design/Views.hs | 2 --
server/src/Job/Daemon.hs | 2 +-
server/src/Job/Model.hs | 2 --
server/src/Job/MonthlyPayment.hs | 2 +-
server/src/Json.hs | 3 ---
server/src/LoginSession.hs | 2 --
server/src/Main.hs | 7 ++++---
server/src/MimeMail.hs | 2 --
server/src/Model/Category.hs | 1 -
server/src/Model/Frequency.hs | 3 ---
server/src/Model/Income.hs | 1 -
server/src/Model/Init.hs | 2 --
server/src/Model/Payment.hs | 1 -
server/src/Model/PaymentCategory.hs | 1 -
server/src/Model/SignIn.hs | 2 --
server/src/Model/User.hs | 1 -
server/src/Secure.hs | 9 +++-----
server/src/SendMail.hs | 2 --
server/src/Util/Time.hs | 25 +++++++++++++++++++++++
server/src/Utils/Time.hs | 25 -----------------------
server/src/View/Mail/SignIn.hs | 19 ++++++++---------
server/src/View/Mail/WeeklyReport.hs | 35 +++++++++++++++-----------------
server/src/View/Page.hs | 7 ++-----
45 files changed, 81 insertions(+), 160 deletions(-)
create mode 100644 server/src/Util/Time.hs
delete mode 100644 server/src/Utils/Time.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index d30060b..e4a1730 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -13,9 +13,11 @@ Executable server
Ghc-options: -Wall -Werror
Hs-source-dirs: src
Default-language: Haskell2010
- Extensions:
+
+ Default-extensions:
ExistentialQuantification
MultiParamTypeClasses
+ OverloadedStrings
Build-depends:
aeson
@@ -86,7 +88,6 @@ Executable server
Job.WeeklyReport
Json
LoginSession
- Main
MimeMail
Model.Category
Model.Frequency
@@ -103,7 +104,7 @@ Executable server
Resource
Secure
SendMail
- Utils.Time
+ Util.Time
Validation
View.Mail.SignIn
View.Mail.WeeklyReport
diff --git a/server/src/Conf.hs b/server/src/Conf.hs
index 299f071..2422a93 100644
--- a/server/src/Conf.hs
+++ b/server/src/Conf.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Conf
( get
, Conf(..)
diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs
index a646496..5565b43 100644
--- a/server/src/Controller/Category.hs
+++ b/server/src/Controller/Category.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Controller.Category
( create
, edit
@@ -11,10 +9,9 @@ import qualified Data.Text.Lazy as TL
import Network.HTTP.Types.Status (badRequest400, ok200)
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 qualified Common.Msg as Msg
import Json (jsonId)
import qualified Model.Category as Category
@@ -50,5 +47,5 @@ delete categoryId =
status ok200
else do
status badRequest400
- text . TL.fromStrict $ Message.get Key.Category_NotDeleted
+ text . TL.fromStrict $ Msg.get Msg.Category_NotDeleted
)
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index c42f6a7..19f0cfc 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Controller.Income
( create
, editOwn
@@ -11,10 +9,9 @@ import qualified Data.Text.Lazy as TL
import Network.HTTP.Types.Status (badRequest400, ok200)
import Web.Scotty
-import qualified Common.Message as Message
-import qualified Common.Message.Key as Key
import Common.Model (CreateIncome (..), EditIncome (..),
IncomeId, User (..))
+import qualified Common.Msg as Msg
import Json (jsonId)
import qualified Model.Income as Income
@@ -45,5 +42,5 @@ deleteOwn incomeId =
status ok200
else do
status badRequest400
- text . TL.fromStrict $ Message.get Key.Income_NotDeleted
+ text . TL.fromStrict $ Msg.get Msg.Income_NotDeleted
)
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index bf4859d..f05ce6f 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -10,10 +10,9 @@ 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 Common.Msg (Key)
+import qualified Common.Msg as Msg
import Conf (Conf (..))
import qualified LoginSession
@@ -31,7 +30,7 @@ get conf mbToken = do
userOrError <- validateSignIn conf token
case userOrError of
Left errorKey ->
- return . InitEmpty . Left . Message.get $ errorKey
+ return . InitEmpty . Left . Msg.get $ errorKey
Right user ->
liftIO . Query.run . fmap InitSuccess $ getInit user conf
Nothing -> do
@@ -54,23 +53,23 @@ validateSignIn conf textToken = do
now <- liftIO getCurrentTime
case mbSignIn of
Nothing ->
- return . Left $ Key.SignIn_LinkInvalid
+ return . Left $ Msg.SignIn_LinkInvalid
Just signIn ->
if SignIn.isUsed signIn
then
- return . Left $ Key.SignIn_LinkUsed
+ return . Left $ Msg.SignIn_LinkUsed
else
let diffTime = now `diffUTCTime` (SignIn.creation signIn)
in if diffTime > signInExpiration conf
then
- return . Left $ Key.SignIn_LinkExpired
+ return . Left $ Msg.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
+ Nothing -> Left Msg.Secure_Unauthorized
Just user -> Right user
getLoggedUser :: ActionM (Maybe User)
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index e4104eb..c6c874a 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Controller.Payment
( list
, create
diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs
index 5552781..cf92c9f 100644
--- a/server/src/Controller/SignIn.hs
+++ b/server/src/Controller/SignIn.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Controller.SignIn
( signIn
) where
@@ -11,9 +9,8 @@ import qualified Data.Text.Lazy as TL
import Network.HTTP.Types.Status (badRequest400, ok200)
import Web.Scotty
-import qualified Common.Message as Message
-import qualified Common.Message.Key as Key
import Common.Model (SignIn (..))
+import qualified Common.Msg as Msg
import Conf (Conf)
import qualified Conf
@@ -40,8 +37,8 @@ signIn conf (SignIn email) =
]
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)
+ Right _ -> textKey ok200 Msg.SignIn_EmailSent
+ Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail
+ Nothing -> textKey badRequest400 Msg.Secure_Unauthorized
+ else textKey badRequest400 Msg.SignIn_EmailInvalid
+ where textKey st key = status st >> (text . TL.fromStrict $ Msg.get key)
diff --git a/server/src/Cookie.hs b/server/src/Cookie.hs
index 511dd42..f79a1fa 100644
--- a/server/src/Cookie.hs
+++ b/server/src/Cookie.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Cookie
( makeSimpleCookie
, setCookie
diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs
index 6759606..034a8b1 100644
--- a/server/src/Design/Dialog.hs
+++ b/server/src/Design/Dialog.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.Dialog
( design
) where
diff --git a/server/src/Design/Errors.hs b/server/src/Design/Errors.hs
index 2c6c16b..9f435eb 100644
--- a/server/src/Design/Errors.hs
+++ b/server/src/Design/Errors.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.Errors
( design
) where
diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs
index a4a1de0..be0e74f 100644
--- a/server/src/Design/Form.hs
+++ b/server/src/Design/Form.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.Form
( design
) where
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index 1fe6a80..34d772e 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.Global
( globalDesign
) where
diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs
index 0913511..9bf7878 100644
--- a/server/src/Design/Helper.hs
+++ b/server/src/Design/Helper.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.Helper
( clearFix
, button
diff --git a/server/src/Design/Tooltip.hs b/server/src/Design/Tooltip.hs
index 57aec33..eef804e 100644
--- a/server/src/Design/Tooltip.hs
+++ b/server/src/Design/Tooltip.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.Tooltip
( design
) where
diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs
index d05f748..792d482 100644
--- a/server/src/Design/View/Header.hs
+++ b/server/src/Design/View/Header.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.View.Header
( design
) where
diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs
index 62f7061..0d59fa0 100644
--- a/server/src/Design/View/Payment.hs
+++ b/server/src/Design/View/Payment.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.View.Payment
( design
) where
diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs
index d87e95b..36bc8d9 100644
--- a/server/src/Design/View/Payment/Header.hs
+++ b/server/src/Design/View/Payment/Header.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.View.Payment.Header
( design
) where
diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs
index f6660a1..2028c1b 100644
--- a/server/src/Design/View/Payment/Pages.hs
+++ b/server/src/Design/View/Payment/Pages.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.View.Payment.Pages
( design
) where
diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs
index 243d7f4..26dc9ed 100644
--- a/server/src/Design/View/Payment/Table.hs
+++ b/server/src/Design/View/Payment/Table.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.View.Payment.Table
( design
) where
diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs
index 2b1252f..4d4be7b 100644
--- a/server/src/Design/View/SignIn.hs
+++ b/server/src/Design/View/SignIn.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.View.SignIn
( design
) where
diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs
index b10dd7b..4d7021e 100644
--- a/server/src/Design/View/Stat.hs
+++ b/server/src/Design/View/Stat.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.View.Stat
( design
) where
diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs
index fd55656..cd406fc 100644
--- a/server/src/Design/View/Table.hs
+++ b/server/src/Design/View/Table.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.View.Table
( design
) where
diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs
index 1157b68..a73a1fa 100644
--- a/server/src/Design/Views.hs
+++ b/server/src/Design/Views.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Design.Views
( design
) where
diff --git a/server/src/Job/Daemon.hs b/server/src/Job/Daemon.hs
index 26977d1..d8cd522 100644
--- a/server/src/Job/Daemon.hs
+++ b/server/src/Job/Daemon.hs
@@ -14,7 +14,7 @@ import Job.Model (actualizeLastCheck, actualizeLastExecution,
import Job.MonthlyPayment (monthlyPayment)
import Job.WeeklyReport (weeklyReport)
import qualified Model.Query as Query
-import Utils.Time (belongToCurrentMonth, belongToCurrentWeek)
+import Util.Time (belongToCurrentMonth, belongToCurrentWeek)
runDaemons :: Conf -> IO ()
runDaemons conf = do
diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs
index b90dca0..a5fa62b 100644
--- a/server/src/Job/Model.hs
+++ b/server/src/Job/Model.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Job.Model
( Job(..)
, getLastExecution
diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs
index 8cb1c27..ca7e007 100644
--- a/server/src/Job/MonthlyPayment.hs
+++ b/server/src/Job/MonthlyPayment.hs
@@ -8,7 +8,7 @@ import Common.Model (Frequency (..), Payment (..))
import qualified Model.Payment as Payment
import qualified Model.Query as Query
-import Utils.Time (timeToDay)
+import Util.Time (timeToDay)
monthlyPayment :: Maybe UTCTime -> IO UTCTime
monthlyPayment _ = do
diff --git a/server/src/Json.hs b/server/src/Json.hs
index eb5c572..6d40305 100644
--- a/server/src/Json.hs
+++ b/server/src/Json.hs
@@ -1,6 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-
module Json
( jsonObject
, jsonId
diff --git a/server/src/LoginSession.hs b/server/src/LoginSession.hs
index beca697..86f1329 100644
--- a/server/src/LoginSession.hs
+++ b/server/src/LoginSession.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module LoginSession
( put
, get
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 5ac68db..d7b9b93 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
import Control.Applicative (liftA3)
import Control.Monad.IO.Class (liftIO)
@@ -9,6 +7,8 @@ import qualified Network.Wai.Middleware.Gzip as W
import Network.Wai.Middleware.Static
import Web.Scotty
+import Common.Model (Frequency (..), Payment (..))
+
import qualified Conf
import qualified Controller.Category as Category
import qualified Controller.Income as Income
@@ -35,7 +35,8 @@ main = 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
+ let punctualPayments = filter ((==) Punctual . _payment_frequency) payments
+ exceedingPayers = getOrderedExceedingPayers time users incomes punctualPayments
text . LT.pack . show $ exceedingPayers
get "/" $ do
diff --git a/server/src/MimeMail.hs b/server/src/MimeMail.hs
index 7fe98ed..c994905 100644
--- a/server/src/MimeMail.hs
+++ b/server/src/MimeMail.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module MimeMail
( -- * Datatypes
Boundary (..)
diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs
index b972ebd..ee406bc 100644
--- a/server/src/Model/Category.hs
+++ b/server/src/Model/Category.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.Category
diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs
index 41a325d..c29cf37 100644
--- a/server/src/Model/Frequency.hs
+++ b/server/src/Model/Frequency.hs
@@ -1,6 +1,3 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.Frequency () where
diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs
index a69112a..a6174bc 100644
--- a/server/src/Model/Income.hs
+++ b/server/src/Model/Income.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.Income
diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs
index c030c58..be44c72 100644
--- a/server/src/Model/Init.hs
+++ b/server/src/Model/Init.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Model.Init
( getInit
) where
diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs
index c1b109f..33551e5 100644
--- a/server/src/Model/Payment.hs
+++ b/server/src/Model/Payment.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.Payment
diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs
index 6d02136..c60c1a2 100644
--- a/server/src/Model/PaymentCategory.hs
+++ b/server/src/Model/PaymentCategory.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.PaymentCategory
diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs
index 6f38fe7..0cc4a03 100644
--- a/server/src/Model/SignIn.hs
+++ b/server/src/Model/SignIn.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Model.SignIn
( SignIn(..)
, createSignInToken
diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs
index f17f545..8dc1fc8 100644
--- a/server/src/Model/User.hs
+++ b/server/src/Model/User.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.User
diff --git a/server/src/Secure.hs b/server/src/Secure.hs
index 88bdcda..6e5b998 100644
--- a/server/src/Secure.hs
+++ b/server/src/Secure.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module Secure
( loggedAction
, getUserFromToken
@@ -11,9 +9,8 @@ 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 qualified Common.Msg as Msg
import qualified LoginSession
import Model.Query (Query)
@@ -32,10 +29,10 @@ loggedAction action = do
action user
Nothing -> do
status forbidden403
- html . fromStrict . Message.get $ Key.Secure_Unauthorized
+ html . fromStrict . Msg.get $ Msg.Secure_Unauthorized
Nothing -> do
status forbidden403
- html . fromStrict . Message.get $ Key.Secure_Forbidden
+ html . fromStrict . Msg.get $ Msg.Secure_Forbidden
getUserFromToken :: Text -> Query (Maybe User)
getUserFromToken token = do
diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs
index 959f21d..d00912f 100644
--- a/server/src/SendMail.hs
+++ b/server/src/SendMail.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module SendMail
( sendMail
) where
diff --git a/server/src/Util/Time.hs b/server/src/Util/Time.hs
new file mode 100644
index 0000000..3e0856d
--- /dev/null
+++ b/server/src/Util/Time.hs
@@ -0,0 +1,25 @@
+module Util.Time
+ ( belongToCurrentMonth
+ , belongToCurrentWeek
+ , timeToDay
+ ) where
+
+import Data.Time.Calendar
+import Data.Time.Calendar.WeekDate (toWeekDate)
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.LocalTime
+
+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/Utils/Time.hs b/server/src/Utils/Time.hs
deleted file mode 100644
index e1a94d3..0000000
--- a/server/src/Utils/Time.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module Utils.Time
- ( belongToCurrentMonth
- , belongToCurrentWeek
- , timeToDay
- ) where
-
-import Data.Time.Calendar
-import Data.Time.Calendar.WeekDate (toWeekDate)
-import Data.Time.Clock (UTCTime, getCurrentTime)
-import Data.Time.LocalTime
-
-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/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs
index d542fd8..22c3cb0 100644
--- a/server/src/View/Mail/SignIn.hs
+++ b/server/src/View/Mail/SignIn.hs
@@ -1,24 +1,21 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module View.Mail.SignIn
( mail
) where
-import Data.Text (Text)
+import Data.Text (Text)
-import qualified Common.Message as Message
-import qualified Common.Message.Key as Key
-import Common.Model (User (..))
+import Common.Model (User (..))
+import qualified Common.Msg as Msg
-import Conf (Conf)
-import qualified Conf as Conf
-import qualified Model.Mail as M
+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)
+ , M.subject = Msg.get Msg.SignIn_MailTitle
+ , M.plainBody = Msg.get (Msg.SignIn_MailBody (_user_name user) url)
}
diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs
index c0e89d5..4ad8b77 100644
--- a/server/src/View/Mail/WeeklyReport.hs
+++ b/server/src/View/Mail/WeeklyReport.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module View.Mail.WeeklyReport
( mail
) where
@@ -13,11 +11,10 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
-import qualified Common.Message as Message
-import qualified Common.Message.Key as Key
import Common.Model (Income (..), Payment (..), User (..),
UserId)
import qualified Common.Model as CM
+import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
import Conf (Conf)
@@ -34,9 +31,9 @@ mail conf users payments incomes start end =
{ M.from = Conf.noReplyMail conf
, M.to = map _user_email users
, M.subject = T.concat
- [ Message.get Key.App_Title
+ [ Msg.get Msg.App_Title
, " − "
- , Message.get Key.WeeklyReport_Title
+ , Msg.get Msg.WeeklyReport_Title
]
, M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes)
}
@@ -45,7 +42,7 @@ 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
+ Msg.get Msg.WeeklyReport_Empty
else
T.intercalate "\n" . catMaybes . concat $
[ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses
@@ -56,17 +53,17 @@ 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
+ sectionTitle = Msg.get $ case status of
+ Created -> if count > 1 then Msg.WeeklyReport_PaymentsCreated count else Msg.WeeklyReport_PaymentCreated count
+ Edited -> if count > 1 then Msg.WeeklyReport_PaymentsEdited count else Msg.WeeklyReport_PaymentEdited count
+ Deleted -> if count > 1 then Msg.WeeklyReport_PaymentsDeleted count else Msg.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)
+ Deleted -> Msg.get (Msg.WeeklyReport_PayedForNot name amount for at)
+ _ -> Msg.get (Msg.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
@@ -76,17 +73,17 @@ 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
+ sectionTitle = Msg.get $ case status of
+ Created -> if count > 1 then Msg.WeeklyReport_IncomesCreated count else Msg.WeeklyReport_IncomeCreated count
+ Edited -> if count > 1 then Msg.WeeklyReport_IncomesEdited count else Msg.WeeklyReport_IncomeEdited count
+ Deleted -> if count > 1 then Msg.WeeklyReport_IncomesDeleted count else Msg.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)
+ Deleted -> Msg.get (Msg.WeeklyReport_PayedFromNot name amount for)
+ _ -> Msg.get (Msg.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
diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs
index ff7bdc7..27b4f26 100644
--- a/server/src/View/Page.hs
+++ b/server/src/View/Page.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module View.Page
( page
) where
@@ -16,9 +14,8 @@ import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes
import qualified Text.Blaze.Html5.Attributes as A
-import qualified Common.Message as Message
-import qualified Common.Message.Key as Key
import Common.Model (InitResult)
+import qualified Common.Msg as Msg
import Design.Global (globalDesign)
@@ -28,7 +25,7 @@ page initResult =
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)
+ H.title (toHtml $ Msg.get Msg.App_Title)
script ! src "javascript/main.js" $ ""
jsonScript "init" initResult
link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css"
--
cgit v1.2.3
From bab2c30addf8aaed85675e2b7f7b15c97c426f74 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 19 Nov 2017 15:00:07 +0100
Subject: Add exceeding payer block
---
server/server.cabal | 1 -
server/src/Design/View/Header.hs | 2 +-
server/src/Main.hs | 4 +-
server/src/Model/Payer.hs | 217 ---------------------------------------
4 files changed, 3 insertions(+), 221 deletions(-)
delete mode 100644 server/src/Model/Payer.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index e4a1730..771a961 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -94,7 +94,6 @@ Executable server
Model.Income
Model.Init
Model.Mail
- Model.Payer
Model.Payment
Model.PaymentCategory
Model.Query
diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs
index 792d482..904a2f5 100644
--- a/server/src/Design/View/Header.hs
+++ b/server/src/Design/View/Header.hs
@@ -57,7 +57,7 @@ design = do
".signOut" ? do
Helper.waitable
- heightMedia
+ display flex
svg ? do
Media.tabletDesktop $ width (px 30)
Media.mobile $ width (px 20)
diff --git a/server/src/Main.hs b/server/src/Main.hs
index d7b9b93..c8080dc 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -8,6 +8,7 @@ import Network.Wai.Middleware.Static
import Web.Scotty
import Common.Model (Frequency (..), Payment (..))
+import qualified Common.Model as CM
import qualified Conf
import qualified Controller.Category as Category
@@ -18,7 +19,6 @@ import qualified Controller.SignIn as SignIn
import qualified Data.Time as Time
import Job.Daemon (runDaemons)
import qualified Model.Income as IncomeM
-import Model.Payer (getOrderedExceedingPayers)
import qualified Model.Payment as PaymentM
import qualified Model.Query as Query
import qualified Model.User as UserM
@@ -36,7 +36,7 @@ main = do
(users, incomes, payments) <- liftIO . Query.run $
liftA3 (,,) UserM.list IncomeM.list PaymentM.list
let punctualPayments = filter ((==) Punctual . _payment_frequency) payments
- exceedingPayers = getOrderedExceedingPayers time users incomes punctualPayments
+ exceedingPayers = CM.getExceedingPayers time users incomes punctualPayments
text . LT.pack . show $ exceedingPayers
get "/" $ do
diff --git a/server/src/Model/Payer.hs b/server/src/Model/Payer.hs
deleted file mode 100644
index db3f37c..0000000
--- a/server/src/Model/Payer.hs
+++ /dev/null
@@ -1,217 +0,0 @@
-module Model.Payer
- ( getOrderedExceedingPayers
- ) where
-
-import qualified Data.List as List
-import Data.Map (Map)
-import qualified Data.Map as Map
-import qualified Data.Maybe as Maybe
-import Data.Time (NominalDiffTime, UTCTime (..))
-import qualified Data.Time as Time
-
-import Common.Model (Income (..), IncomeId, Payment (..), User (..),
- UserId)
-
-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
--
cgit v1.2.3
From 554880727d833befab00666c7a4f95611e8370b9 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 19 Nov 2017 15:39:11 +0100
Subject: Remove local MimeMail
---
server/server.cabal | 2 +-
server/src/Design/Helper.hs | 6 +-
server/src/MimeMail.hs | 672 --------------------------------------------
server/src/SendMail.hs | 2 +-
4 files changed, 5 insertions(+), 677 deletions(-)
delete mode 100644 server/src/MimeMail.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 771a961..3715105 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -37,6 +37,7 @@ Executable server
, http-conduit
, http-types
, lens
+ , mime-mail
, monad-logger
, mtl
, parsec
@@ -88,7 +89,6 @@ Executable server
Job.WeeklyReport
Json
LoginSession
- MimeMail
Model.Category
Model.Frequency
Model.Income
diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs
index 9bf7878..89f5958 100644
--- a/server/src/Design/Helper.hs
+++ b/server/src/Design/Helper.hs
@@ -41,12 +41,12 @@ button backgroundCol textCol h focusOp = do
waitable :: Css
waitable = do
+ ".content" ? display flex
svg # ".loader" ? display none
+
".waiting" & do
".content" ? do
- display flex
- fontSize (px 0)
- opacity 0
+ display none
svg # ".loader" ? do
display block
rotateKeyframes
diff --git a/server/src/MimeMail.hs b/server/src/MimeMail.hs
deleted file mode 100644
index c994905..0000000
--- a/server/src/MimeMail.hs
+++ /dev/null
@@ -1,672 +0,0 @@
-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 Blaze.ByteString.Builder
-import Blaze.ByteString.Builder.Char.Utf8
-import Control.Arrow
-import Control.Concurrent (forkIO, newEmptyMVar,
- putMVar, takeMVar)
-import Control.Exception (ErrorCall (ErrorCall),
- throwIO)
-import Control.Monad (foldM, void, (<=<))
-import Data.Bits (shiftR, (.&.))
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Base64 as Base64
-import Data.ByteString.Char8 ()
-import qualified Data.ByteString.Lazy as L
-import Data.Char (isAscii, isControl)
-import Data.List (intersperse)
-import Data.Monoid
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-import qualified Data.Text.Lazy as LT
-import qualified Data.Text.Lazy.Encoding as LT
-import Data.Word (Word8)
-import System.Exit
-import System.FilePath (takeFileName)
-import System.IO
-import System.Process
-import System.Random
-
--- | 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/SendMail.hs b/server/src/SendMail.hs
index d00912f..c15ed62 100644
--- a/server/src/SendMail.hs
+++ b/server/src/SendMail.hs
@@ -5,12 +5,12 @@ module SendMail
import Control.Arrow (left)
import Control.Exception (SomeException, try)
import Data.Either (isLeft)
+import qualified Network.Mail.Mime as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.Text.Lazy.Builder (fromText, toLazyText)
-import qualified MimeMail as M
import Model.Mail (Mail (Mail))
--
cgit v1.2.3
From 49426740e8e0c59040f4f3721a658f225572582b Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 28 Nov 2017 09:11:19 +0100
Subject: Add search for payments
---
server/migrations/1.sql | 65 ++++++++++++++++++++++++++++++++
server/src/Design/Global.hs | 26 +++++++++++++
server/src/Design/Helper.hs | 29 --------------
server/src/Design/View/Header.hs | 8 ++--
server/src/Design/View/Payment/Header.hs | 34 +++++++++--------
server/src/Job/Model.hs | 14 ++++---
6 files changed, 121 insertions(+), 55 deletions(-)
create mode 100644 server/migrations/1.sql
(limited to 'server')
diff --git a/server/migrations/1.sql b/server/migrations/1.sql
new file mode 100644
index 0000000..d7c300e
--- /dev/null
+++ b/server/migrations/1.sql
@@ -0,0 +1,65 @@
+CREATE TABLE IF NOT EXISTS "user" (
+ "id" INTEGER PRIMARY KEY,
+ "creation" TIMESTAMP NOT NULL,
+ "email" VARCHAR NOT NULL,
+ "name" VARCHAR NOT NULL,
+ CONSTRAINT "uniq_user_email" UNIQUE ("email"),
+ CONSTRAINT "uniq_user_name" UNIQUE ("name")
+);
+
+CREATE TABLE IF NOT EXISTS "job" (
+ "id" INTEGER PRIMARY KEY,
+ "kind" VARCHAR NOT NULL,
+ "last_execution" TIMESTAMP NULL,
+ "last_check" TIMESTAMP NULL,
+ CONSTRAINT "uniq_job_kind" UNIQUE ("kind")
+);
+
+CREATE TABLE IF NOT EXISTS "sign_in"(
+ "id" INTEGER PRIMARY KEY,
+ "token" VARCHAR NOT NULL,
+ "creation" TIMESTAMP NOT NULL,
+ "email" VARCHAR NOT NULL,
+ "is_used" BOOLEAN NOT NULL,
+ CONSTRAINT "uniq_sign_in_token" UNIQUE ("token")
+);
+
+CREATE TABLE IF NOT EXISTS "payment"(
+ "id" INTEGER PRIMARY KEY,
+ "user_id" INTEGER NOT NULL REFERENCES "user",
+ "name" VARCHAR NOT NULL,
+ "cost" INTEGER NOT NULL,
+ "date" DATE NOT NULL,
+ "frequency" VARCHAR NOT NULL,
+ "created_at" TIMESTAMP NOT NULL,
+ "edited_at" TIMESTAMP NULL,
+ "deleted_at" TIMESTAMP NULL
+);
+
+CREATE TABLE IF NOT EXISTS "income"(
+ "id" INTEGER PRIMARY KEY,
+ "user_id" INTEGER NOT NULL REFERENCES "user",
+ "date" DATE NOT NULL,
+ "amount" INTEGERNOT NULL,
+ "created_at" TIMESTAMP NOT NULL,
+ "edited_at" TIMESTAMP NULL,
+ "deleted_at" TIMESTAMP NULL
+);
+
+CREATE TABLE IF NOT EXISTS "category"(
+ "id" INTEGER PRIMARY KEY,
+ "name" VARCHAR NOT NULL,
+ "color" VARCHAR NOT NULL,
+ "created_at" TIMESTAMP NOT NULL,
+ "edited_at" TIMESTAMP NULL,
+ "deleted_at" TIMESTAMP NULL
+);
+
+CREATE TABLE IF NOT EXISTS "payment_category"(
+ "id" INTEGER PRIMARY KEY,
+ "name" VARCHAR NOT NULL,
+ "category" INTEGER NOT NULL REFERENCES "category",
+ "created_at" TIMESTAMP NOT NULL,
+ "edited_at" TIMESTAMP NULL,
+ CONSTRAINT "uniq_payment_category_name" UNIQUE ("name")
+);
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index 34d772e..5e5035c 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -71,3 +71,29 @@ global = do
".undo" & Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten
svg ? height (pct 100)
+
+ button ? do
+ ".content" ? display flex
+ svg # ".loader" ? display none
+
+ ".waiting" & do
+ ".content" ? do
+ display none
+ svg # ".loader" ? do
+ display block
+ rotateKeyframes
+ rotateAnimation
+
+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/Helper.hs b/server/src/Design/Helper.hs
index 89f5958..6980c71 100644
--- a/server/src/Design/Helper.hs
+++ b/server/src/Design/Helper.hs
@@ -1,7 +1,6 @@
module Design.Helper
( clearFix
, button
- , waitable
, input
, centeredWithMargin
, verticalCentering
@@ -37,20 +36,6 @@ button backgroundCol textCol h focusOp = do
textAlign (alignSide sideCenter)
hover & backgroundColor (focusOp backgroundCol)
focus & backgroundColor (focusOp backgroundCol)
- waitable
-
-waitable :: Css
-waitable = do
- ".content" ? display flex
- svg # ".loader" ? display none
-
- ".waiting" & do
- ".content" ? do
- display none
- svg # ".loader" ? do
- display block
- rotateKeyframes
- rotateAnimation
input :: Double -> Css
input h = do
@@ -72,17 +57,3 @@ 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/View/Header.hs b/server/src/Design/View/Header.hs
index 904a2f5..97f1802 100644
--- a/server/src/Design/View/Header.hs
+++ b/server/src/Design/View/Header.hs
@@ -2,13 +2,12 @@ module Design.View.Header
( design
) where
-import Data.Monoid ((<>))
+import Data.Monoid ((<>))
import Clay
-import Design.Color as Color
-import qualified Design.Helper as Helper
-import qualified Design.Media as Media
+import Design.Color as Color
+import qualified Design.Media as Media
design :: Css
design = do
@@ -56,7 +55,6 @@ design = do
Media.tabletDesktop $ headerPadding
".signOut" ? do
- Helper.waitable
display flex
svg ? do
Media.tabletDesktop $ width (px 30)
diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs
index 36bc8d9..80c5436 100644
--- a/server/src/Design/View/Payment/Header.hs
+++ b/server/src/Design/View/Payment/Header.hs
@@ -50,22 +50,24 @@ design = do
".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
+ Media.mobile $ textAlign (alignSide sideCenter)
+
+ ".textInput" ? do
+ display inlineBlock
+ marginBottom (px 0)
+ button ? do
+ svg ? "path" ? ("fill" -: Color.toString Color.silver)
+ hover & svg ? "path" ? ("fill" -: Color.toString (Color.silver -. 25))
+
+ 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)
diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs
index a5fa62b..1dd6c63 100644
--- a/server/src/Job/Model.hs
+++ b/server/src/Job/Model.hs
@@ -5,7 +5,6 @@ module Job.Model
, 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
@@ -24,15 +23,20 @@ data Job = Job
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
+ result <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only UTCTime]
+ return $ case result of
+ [Only time] -> Just time
+ _ -> Nothing
)
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
+ result <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only Int]
+ let hasJob = case result of
+ [Only _] -> True
+ _ -> False
+ if hasJob
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)
)
--
cgit v1.2.3
From a4acc2e84158fa822f88a1d0bdddb470708b5809 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 3 Jan 2018 17:31:20 +0100
Subject: Modify weelky report and payment search interface
- Add payment balance in weekly report
- Show a message and hide pages when the search results in no results
- Go to page 1 when the search is updated / erased
---
server/server.cabal | 2 -
server/src/Conf.hs | 4 +-
server/src/Controller/Index.hs | 77 ++++++++++++++++++++++++----------
server/src/Controller/Payment.hs | 2 +-
server/src/Controller/SignIn.hs | 44 --------------------
server/src/Design/View/SignIn.hs | 2 +-
server/src/Job/MonthlyPayment.hs | 2 +-
server/src/Job/WeeklyReport.hs | 7 +---
server/src/Main.hs | 81 +++++++++++++-----------------------
server/src/Model/Income.hs | 12 +-----
server/src/Model/Init.hs | 2 +-
server/src/Model/Mail.hs | 8 ++--
server/src/Model/Payment.hs | 41 +++++++-----------
server/src/SendMail.hs | 39 +++++++++++++----
server/src/View/Mail/SignIn.hs | 2 +-
server/src/View/Mail/WeeklyReport.hs | 32 +++++++++++---
server/src/View/Page.hs | 6 +--
17 files changed, 176 insertions(+), 187 deletions(-)
delete mode 100644 server/src/Controller/SignIn.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 3715105..d1dbd50 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -36,7 +36,6 @@ Executable server
, filepath
, http-conduit
, http-types
- , lens
, mime-mail
, monad-logger
, mtl
@@ -61,7 +60,6 @@ Executable server
Controller.Income
Controller.Index
Controller.Payment
- Controller.SignIn
Cookie
Design.Color
Design.Constants
diff --git a/server/src/Conf.hs b/server/src/Conf.hs
index 2422a93..ca19c8d 100644
--- a/server/src/Conf.hs
+++ b/server/src/Conf.hs
@@ -17,6 +17,7 @@ data Conf = Conf
, currency :: Currency
, noReplyMail :: Text
, https :: Bool
+ , devMode :: Bool
} deriving Show
get :: FilePath -> IO Conf
@@ -30,7 +31,8 @@ get path = do
Conf.lookup "signInExpiration" conf <*>
fmap Currency (Conf.lookup "currency" conf) <*>
Conf.lookup "noReplyMail" conf <*>
- Conf.lookup "https" conf
+ Conf.lookup "https" conf <*>
+ Conf.lookup "devMode" conf
)
case conf of
Left msg -> error (T.unpack msg)
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index f05ce6f..9a3e2b7 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -1,16 +1,23 @@
module Controller.Index
( get
+ , askSignIn
+ , trySignIn
, signOut
) where
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy as TL
import Data.Time.Clock (diffUTCTime, getCurrentTime)
-import Network.HTTP.Types.Status (ok200)
+import Network.HTTP.Types.Status (badRequest400, ok200)
import Prelude hiding (error)
-import Web.Scotty hiding (get)
+import Web.Scotty (ActionM)
+import qualified Web.Scotty as S
-import Common.Model (InitResult (..), User (..))
+import Common.Model (InitResult (..), SignIn (..),
+ User (..))
import Common.Msg (Key)
import qualified Common.Msg as Msg
@@ -21,26 +28,52 @@ import qualified Model.Query as Query
import qualified Model.SignIn as SignIn
import qualified Model.User as User
import Secure (getUserFromToken)
+import qualified SendMail
+import qualified Text.Email.Validate as Email
+import qualified View.Mail.SignIn as SignIn
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 . Msg.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
+get :: Conf -> ActionM ()
+get conf = do
+ initResult <- do
+ mbLoggedUser <- getLoggedUser
+ case mbLoggedUser of
+ Nothing ->
+ return . InitEmpty . Right $ Nothing
+ Just user ->
+ liftIO . Query.run . fmap InitSuccess $ getInit user conf
+ S.html $ page initResult
+
+askSignIn :: Conf -> SignIn -> ActionM ()
+askSignIn 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,
+ "/signIn/",
+ token
+ ]
+ maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email]
+ case maybeSentMail of
+ Right _ -> textKey ok200 Msg.SignIn_EmailSent
+ Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail
+ Nothing -> textKey badRequest400 Msg.Secure_Unauthorized
+ else textKey badRequest400 Msg.SignIn_EmailInvalid
+ where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key)
+
+trySignIn :: Conf -> Text -> ActionM ()
+trySignIn conf token = do
+ userOrError <- validateSignIn conf token
+ case userOrError of
+ Left errorKey ->
+ S.html $ page (InitEmpty . Left . Msg.get $ errorKey)
+ Right _ ->
+ S.redirect "/"
validateSignIn :: Conf -> Text -> ActionM (Either Key User)
validateSignIn conf textToken = do
@@ -82,4 +115,4 @@ getLoggedUser = do
liftIO . Query.run . getUserFromToken $ token
signOut :: Conf -> ActionM ()
-signOut conf = LoginSession.delete conf >> status ok200
+signOut conf = LoginSession.delete conf >> S.status ok200
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index c6c874a..f2af6c9 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -22,7 +22,7 @@ import qualified Secure
list :: ActionM ()
list =
Secure.loggedAction (\_ ->
- (liftIO . Query.run $ Payment.list) >>= json
+ (liftIO . Query.run $ Payment.listActive) >>= json
)
create :: CreatePayment -> ActionM ()
diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs
deleted file mode 100644
index cf92c9f..0000000
--- a/server/src/Controller/SignIn.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-module Controller.SignIn
- ( signIn
- ) where
-
-import Control.Monad.IO.Class (liftIO)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-import qualified Data.Text.Lazy as TL
-import Network.HTTP.Types.Status (badRequest400, ok200)
-import Web.Scotty
-
-import Common.Model (SignIn (..))
-import qualified Common.Msg as Msg
-
-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 Msg.SignIn_EmailSent
- Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail
- Nothing -> textKey badRequest400 Msg.Secure_Unauthorized
- else textKey badRequest400 Msg.SignIn_EmailInvalid
- where textKey st key = status st >> (text . TL.fromStrict $ Msg.get key)
diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs
index 4d4be7b..7f5f503 100644
--- a/server/src/Design/View/SignIn.hs
+++ b/server/src/Design/View/SignIn.hs
@@ -23,7 +23,7 @@ design = do
width (pct 100)
marginBottom (px 10)
- button ? do
+ button # ".validate" ? do
Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten
display flex
alignItems center
diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs
index ca7e007..907be2b 100644
--- a/server/src/Job/MonthlyPayment.hs
+++ b/server/src/Job/MonthlyPayment.hs
@@ -12,7 +12,7 @@ import Util.Time (timeToDay)
monthlyPayment :: Maybe UTCTime -> IO UTCTime
monthlyPayment _ = do
- monthlyPayments <- Query.run Payment.listMonthly
+ monthlyPayments <- Query.run Payment.listActiveMonthlyOrderedByName
now <- getCurrentTime
actualDay <- timeToDay now
let punctualPayments = map
diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs
index 74180df..38d88b5 100644
--- a/server/src/Job/WeeklyReport.hs
+++ b/server/src/Job/WeeklyReport.hs
@@ -19,10 +19,7 @@ weeklyReport conf mbLastExecution = do
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)
+ (,,) <$> Payment.listPunctual <*> Income.list <*> User.list
+ _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now)
return ()
return now
diff --git a/server/src/Main.hs b/server/src/Main.hs
index c8080dc..e298a06 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -1,83 +1,62 @@
-import Control.Applicative (liftA3)
-import Control.Monad.IO.Class (liftIO)
-
-import qualified Data.Text.Lazy as LT
import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress))
import qualified Network.Wai.Middleware.Gzip as W
import Network.Wai.Middleware.Static
-import Web.Scotty
-
-import Common.Model (Frequency (..), Payment (..))
-import qualified Common.Model as CM
+import qualified Web.Scotty as S
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 qualified Data.Time as Time
import Job.Daemon (runDaemons)
-import qualified Model.Income as IncomeM
-import qualified Model.Payment as PaymentM
-import qualified Model.Query as Query
-import qualified Model.User as UserM
main :: IO ()
main = do
conf <- Conf.get "application.conf"
_ <- runDaemons conf
- scotty (Conf.port conf) $ do
- middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress }
- middleware . staticPolicy $ noDots >-> addBase "public"
+ S.scotty (Conf.port conf) $ do
+ S.middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress }
+ S.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 punctualPayments = filter ((==) Punctual . _payment_frequency) payments
- exceedingPayers = CM.getExceedingPayers time users incomes punctualPayments
- text . LT.pack . show $ exceedingPayers
+ S.get "/" $ do
+ Index.get conf
- get "/" $ do
- signInToken <- mbParam "signInToken"
- Index.get conf signInToken
+ S.post "/askSignIn" $ do
+ S.jsonData >>= Index.askSignIn conf
- post "/signIn" $ do
- jsonData >>= SignIn.signIn conf
+ S.get "/signIn/:signInToken" $ do
+ signInToken <- S.param "signInToken"
+ Index.trySignIn conf signInToken
- post "/signOut" $
+ S.post "/signOut" $
Index.signOut conf
- post "/payment" $
- jsonData >>= Payment.create
+ S.post "/payment" $
+ S.jsonData >>= Payment.create
- put "/payment" $
- jsonData >>= Payment.editOwn
+ S.put "/payment" $
+ S.jsonData >>= Payment.editOwn
- delete "/payment" $ do
- paymentId <- param "id"
+ S.delete "/payment" $ do
+ paymentId <- S.param "id"
Payment.deleteOwn paymentId
- post "/income" $
- jsonData >>= Income.create
+ S.post "/income" $
+ S.jsonData >>= Income.create
- put "/income" $
- jsonData >>= Income.editOwn
+ S.put "/income" $
+ S.jsonData >>= Income.editOwn
- delete "/income" $ do
- incomeId <- param "id"
+ S.delete "/income" $ do
+ incomeId <- S.param "id"
Income.deleteOwn incomeId
- post "/category" $
- jsonData >>= Category.create
+ S.post "/category" $
+ S.jsonData >>= Category.create
- put "/category" $
- jsonData >>= Category.edit
+ S.put "/category" $
+ S.jsonData >>= Category.edit
- delete "/category" $ do
- categoryId <- param "id"
+ S.delete "/category" $ do
+ categoryId <- S.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/Model/Income.hs b/server/src/Model/Income.hs
index a6174bc..4938e50 100644
--- a/server/src/Model/Income.hs
+++ b/server/src/Model/Income.hs
@@ -5,12 +5,11 @@ module Model.Income
, create
, editOwn
, deleteOwn
- , modifiedDuring
) where
import Data.Maybe (listToMaybe)
import Data.Time.Calendar (Day)
-import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
import Prelude hiding (id)
@@ -87,12 +86,3 @@ deleteOwn user incomeId =
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
index be44c72..0a0ffc7 100644
--- a/server/src/Model/Init.hs
+++ b/server/src/Model/Init.hs
@@ -18,7 +18,7 @@ getInit user conf =
Init <$>
User.list <*>
(return . _user_id $ user) <*>
- Payment.list <*>
+ Payment.listActive <*>
Income.list <*>
Category.list <*>
PaymentCategory.list <*>
diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs
index a19f9ae..780efcc 100644
--- a/server/src/Model/Mail.hs
+++ b/server/src/Model/Mail.hs
@@ -5,8 +5,8 @@ module Model.Mail
import Data.Text (Text)
data Mail = Mail
- { from :: Text
- , to :: [Text]
- , subject :: Text
- , plainBody :: Text
+ { from :: Text
+ , to :: [Text]
+ , subject :: Text
+ , body :: Text
} deriving (Eq, Show)
diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs
index 33551e5..5b29409 100644
--- a/server/src/Model/Payment.hs
+++ b/server/src/Model/Payment.hs
@@ -3,19 +3,18 @@
module Model.Payment
( Payment(..)
, find
- , list
- , listMonthly
+ , listActive
+ , listPunctual
+ , listActiveMonthlyOrderedByName
, 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 (FromRow (fromRow), Only (Only),
@@ -66,14 +65,22 @@ find paymentId =
SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
)
-list :: Query [Payment]
-list =
+listActive :: Query [Payment]
+listActive =
Query (\conn ->
SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL"
)
-listMonthly :: Query [Payment]
-listMonthly =
+listPunctual :: Query [Payment]
+listPunctual =
+ Query (\conn ->
+ SQLite.query
+ conn
+ (SQLite.Query "SELECT * FROM payment WHERE frequency = ?")
+ (Only Punctual))
+
+listActiveMonthlyOrderedByName :: Query [Payment]
+listActiveMonthlyOrderedByName =
Query (\conn ->
SQLite.query
conn
@@ -83,8 +90,7 @@ listMonthly =
, "WHERE deleted_at IS NULL AND frequency = ?"
, "ORDER BY name DESC"
])
- (Only Monthly)
- )
+ (Only Monthly))
create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId
create userId paymentName paymentCost paymentDate paymentFrequency =
@@ -161,18 +167,3 @@ deleteOwn userId paymentId =
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/SendMail.hs b/server/src/SendMail.hs
index c15ed62..3b17a0a 100644
--- a/server/src/SendMail.hs
+++ b/server/src/SendMail.hs
@@ -9,18 +9,41 @@ import qualified Network.Mail.Mime as M
import Data.Text (Text)
import qualified Data.Text as T
+import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as LT
import Data.Text.Lazy.Builder (fromText, toLazyText)
-import Model.Mail (Mail (Mail))
+import Conf (Conf)
+import qualified Conf
+import Model.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
+sendMail :: Conf -> Mail -> IO (Either Text ())
+sendMail conf mail =
+ if Conf.devMode conf
+ then
+ do
+ T.putStrLn . mockMailMessage $ mail
+ return (Right ())
+ else
+ 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 return ()
+ return result
+
+mockMailMessage :: Mail -> Text
+mockMailMessage mail = T.concat $
+ [ "[MOCK MAIL] "
+ , subject mail
+ , " (from: "
+ , from mail
+ , ") (to: "
+ , T.intercalate ", " $ to mail
+ , ")"
+ , "\n"
+ , body mail
+ ]
getMimeMail :: Mail -> M.Mail
getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) =
diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs
index 22c3cb0..3c5469f 100644
--- a/server/src/View/Mail/SignIn.hs
+++ b/server/src/View/Mail/SignIn.hs
@@ -17,5 +17,5 @@ mail conf user url to =
{ M.from = Conf.noReplyMail conf
, M.to = to
, M.subject = Msg.get Msg.SignIn_MailTitle
- , M.plainBody = Msg.get (Msg.SignIn_MailBody (_user_name user) url)
+ , M.body = Msg.get (Msg.SignIn_MailBody (_user_name user) url)
}
diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs
index 4ad8b77..5418880 100644
--- a/server/src/View/Mail/WeeklyReport.hs
+++ b/server/src/View/Mail/WeeklyReport.hs
@@ -11,8 +11,8 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
-import Common.Model (Income (..), Payment (..), User (..),
- UserId)
+import Common.Model (ExceedingPayer (..), Income (..),
+ Payment (..), User (..), UserId)
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
@@ -35,11 +35,31 @@ mail conf users payments incomes start end =
, " − "
, Msg.get Msg.WeeklyReport_Title
]
- , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes)
+ , M.body = body conf users payments incomes start end
}
-body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text
-body conf users paymentsByStatus incomesByStatus =
+body :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Text
+body conf users payments incomes start end =
+ T.intercalate "\n" $
+ [ exceedingPayers conf end users incomes (filter (null . _payment_deletedAt) payments)
+ , operations conf users (groupByStatus start end payments) (groupByStatus start end incomes)
+ ]
+
+exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> [Payment] -> Text
+exceedingPayers conf time users incomes payments =
+ T.intercalate "\n" . map formatPayer $ payers
+ where
+ payers = CM.getExceedingPayers time users incomes payments
+ formatPayer p = T.concat
+ [ " * "
+ , fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users
+ , " + "
+ , Format.price (Conf.currency conf) $ _exceedingPayer_amount p
+ , "\n"
+ ]
+
+operations :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text
+operations conf users paymentsByStatus incomesByStatus =
if M.null paymentsByStatus && M.null incomesByStatus
then
Msg.get Msg.WeeklyReport_Empty
@@ -96,5 +116,5 @@ section title items =
T.concat
[ title
, "\n\n"
- , T.unlines . map (" - " <>) $ items
+ , T.unlines . map (" * " <>) $ items
]
diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs
index 27b4f26..97b84fa 100644
--- a/server/src/View/Page.hs
+++ b/server/src/View/Page.hs
@@ -26,10 +26,10 @@ page initResult =
meta ! charset "UTF-8"
meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0"
H.title (toHtml $ Msg.get Msg.App_Title)
- script ! src "javascript/main.js" $ ""
+ 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"
+ 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
--
cgit v1.2.3
From ab17b6339d16970c3845ec4f153bfeed89eae728 Mon Sep 17 00:00:00 2001
From: Joris
Date: Fri, 5 Jan 2018 14:45:47 +0100
Subject: Add modal component
---
server/server.cabal | 2 +-
server/src/Design/Dialog.hs | 22 ----------------------
server/src/Design/Global.hs | 16 ++++++++--------
server/src/Design/Modal.hs | 43 +++++++++++++++++++++++++++++++++++++++++++
4 files changed, 52 insertions(+), 31 deletions(-)
delete mode 100644 server/src/Design/Dialog.hs
create mode 100644 server/src/Design/Modal.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index d1dbd50..ada7040 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -63,12 +63,12 @@ Executable server
Cookie
Design.Color
Design.Constants
- Design.Dialog
Design.Errors
Design.Form
Design.Global
Design.Helper
Design.Media
+ Design.Modal
Design.Tooltip
Design.View.Header
Design.View.Payment
diff --git a/server/src/Design/Dialog.hs b/server/src/Design/Dialog.hs
deleted file mode 100644
index 034a8b1..0000000
--- a/server/src/Design/Dialog.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-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/Global.hs b/server/src/Design/Global.hs
index 5e5035c..4da4ffb 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -3,19 +3,17 @@ module Design.Global
) where
import Clay
-
import Data.Text.Lazy (Text)
-import qualified Design.Dialog as Dialog
-import qualified Design.Errors as Errors
-import qualified Design.Form as Form
-import qualified Design.Tooltip as Tooltip
-import qualified Design.Views as Views
-
import qualified Design.Color as Color
import qualified Design.Constants as Constants
+import qualified Design.Errors as Errors
+import qualified Design.Form as Form
import qualified Design.Helper as Helper
import qualified Design.Media as Media
+import qualified Design.Modal as Modal
+import qualified Design.Tooltip as Tooltip
+import qualified Design.Views as Views
globalDesign :: Text
globalDesign = renderWith compact [] global
@@ -23,7 +21,7 @@ globalDesign = renderWith compact [] global
global :: Css
global = do
".errors" ? Errors.design
- ".dialog" ? Dialog.design
+ ".modal" ? Modal.design
".tooltip" ? Tooltip.design
Views.design
Form.design
@@ -84,6 +82,8 @@ global = do
rotateKeyframes
rotateAnimation
+ select ? cursor pointer
+
rotateAnimation :: Css
rotateAnimation = do
animationName "rotate"
diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs
new file mode 100644
index 0000000..2612257
--- /dev/null
+++ b/server/src/Design/Modal.hs
@@ -0,0 +1,43 @@
+module Design.Modal
+ ( design
+ ) where
+
+import Data.Monoid ((<>))
+
+import Clay
+
+design :: Css
+design = do
+
+ ".curtain" ? do
+ position fixed
+ cursor pointer
+ top (px 0)
+ left (px 0)
+ width (pct 100)
+ height (pct 100)
+ backgroundColor (rgba 0 0 0 0.5)
+ zIndex 1000
+ opacity 1
+ transition "all" (sec 0.2) ease (sec 0)
+
+ ".content" ? do
+ minWidth (px 270)
+ position fixed
+ top (pct 25)
+ left (pct 50)
+ "transform" -: "translate(-50%, -25%)"
+ zIndex 1000
+ backgroundColor white
+ sym padding (px 20)
+ sym borderRadius (px 5)
+ boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5)
+
+ ".paymentModal" & do
+ ".radioGroup" ? ".title" ? display none
+ ".selectInput" ? do
+ select ? width (pct 100)
+ marginBottom (em 1)
+
+ ".deletePaymentModal" <> ".deleteIncomeModal" ? do
+ h1 ? marginBottom (em 1.5)
--
cgit v1.2.3
From 33b85b7f12798f5762d940ed5c30f775cdd7b751 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 28 Jan 2018 12:13:09 +0100
Subject: WIP
---
server/server.cabal | 15 +--
server/src/Controller/Category.hs | 30 +++---
server/src/Controller/Income.hs | 8 +-
server/src/Controller/Index.hs | 18 ++--
server/src/Controller/Payment.hs | 40 +++----
server/src/Design/Form.hs | 12 ++-
server/src/Design/Modal.hs | 8 +-
server/src/Design/View/Payment.hs | 2 +
server/src/Design/View/Payment/Add.hs | 32 ++++++
server/src/Design/View/Payment/Header.hs | 9 +-
server/src/Job/MonthlyPayment.hs | 16 +--
server/src/Job/WeeklyReport.hs | 8 +-
server/src/Model/Category.hs | 78 --------------
server/src/Model/Frequency.hs | 20 ----
server/src/Model/Income.hs | 88 ----------------
server/src/Model/IncomeResource.hs | 15 +++
server/src/Model/Init.hs | 25 -----
server/src/Model/Payment.hs | 169 ------------------------------
server/src/Model/PaymentCategory.hs | 61 -----------
server/src/Model/PaymentResource.hs | 15 +++
server/src/Model/User.hs | 48 ---------
server/src/Persistence/Category.hs | 79 ++++++++++++++
server/src/Persistence/Frequency.hs | 23 ++++
server/src/Persistence/Income.hs | 88 ++++++++++++++++
server/src/Persistence/Init.hs | 25 +++++
server/src/Persistence/Payment.hs | 169 ++++++++++++++++++++++++++++++
server/src/Persistence/PaymentCategory.hs | 66 ++++++++++++
server/src/Persistence/User.hs | 37 +++++++
server/src/Secure.hs | 4 +-
server/src/SendMail.hs | 1 +
server/src/Util/Time.hs | 17 ++-
server/src/View/Mail/WeeklyReport.hs | 55 +++++-----
32 files changed, 670 insertions(+), 611 deletions(-)
create mode 100644 server/src/Design/View/Payment/Add.hs
delete mode 100644 server/src/Model/Category.hs
delete mode 100644 server/src/Model/Frequency.hs
delete mode 100644 server/src/Model/Income.hs
create mode 100644 server/src/Model/IncomeResource.hs
delete mode 100644 server/src/Model/Init.hs
delete mode 100644 server/src/Model/Payment.hs
delete mode 100644 server/src/Model/PaymentCategory.hs
create mode 100644 server/src/Model/PaymentResource.hs
delete mode 100644 server/src/Model/User.hs
create mode 100644 server/src/Persistence/Category.hs
create mode 100644 server/src/Persistence/Frequency.hs
create mode 100644 server/src/Persistence/Income.hs
create mode 100644 server/src/Persistence/Init.hs
create mode 100644 server/src/Persistence/Payment.hs
create mode 100644 server/src/Persistence/PaymentCategory.hs
create mode 100644 server/src/Persistence/User.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index ada7040..2bfd18d 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -72,6 +72,7 @@ Executable server
Design.Tooltip
Design.View.Header
Design.View.Payment
+ Design.View.Payment.Add
Design.View.Payment.Header
Design.View.Payment.Pages
Design.View.Payment.Table
@@ -87,17 +88,17 @@ Executable server
Job.WeeklyReport
Json
LoginSession
- Model.Category
- Model.Frequency
- Model.Income
- Model.Init
Model.Mail
- Model.Payment
- Model.PaymentCategory
Model.Query
Model.SignIn
Model.UUID
- Model.User
+ Persistence.Category
+ Persistence.Frequency
+ Persistence.Income
+ Persistence.Init
+ Persistence.Payment
+ Persistence.PaymentCategory
+ Persistence.User
Resource
Secure
SendMail
diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs
index 5565b43..37b8357 100644
--- a/server/src/Controller/Category.hs
+++ b/server/src/Controller/Category.hs
@@ -4,31 +4,31 @@ module Controller.Category
, delete
) where
-import Control.Monad.IO.Class (liftIO)
-import qualified Data.Text.Lazy as TL
-import Network.HTTP.Types.Status (badRequest400, ok200)
-import Web.Scotty hiding (delete)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Text.Lazy as TL
+import Network.HTTP.Types.Status (badRequest400, ok200)
+import Web.Scotty hiding (delete)
-import Common.Model (CategoryId, CreateCategory (..),
- EditCategory (..))
-import qualified Common.Msg as Msg
+import Common.Model (CategoryId, CreateCategory (..),
+ EditCategory (..))
+import qualified Common.Msg as Msg
-import Json (jsonId)
-import qualified Model.Category as Category
-import qualified Model.PaymentCategory as PaymentCategory
-import qualified Model.Query as Query
+import Json (jsonId)
+import qualified Model.Query as Query
+import qualified Persistence.Category as CategoryPersistence
+import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
import qualified Secure
create :: CreateCategory -> ActionM ()
create (CreateCategory name color) =
Secure.loggedAction (\_ ->
- (liftIO . Query.run $ Category.create name color) >>= jsonId
+ (liftIO . Query.run $ CategoryPersistence.create name color) >>= jsonId
)
edit :: EditCategory -> ActionM ()
edit (EditCategory categoryId name color) =
Secure.loggedAction (\_ -> do
- updated <- liftIO . Query.run $ Category.edit categoryId name color
+ updated <- liftIO . Query.run $ CategoryPersistence.edit categoryId name color
if updated
then status ok200
else status badRequest400
@@ -38,9 +38,9 @@ delete :: CategoryId -> ActionM ()
delete categoryId =
Secure.loggedAction (\_ -> do
deleted <- liftIO . Query.run $ do
- paymentCategories <- PaymentCategory.listByCategory categoryId
+ paymentCategories <- PaymentCategoryPersistence.listByCategory categoryId
if null paymentCategories
- then Category.delete categoryId
+ then CategoryPersistence.delete categoryId
else return False
if deleted
then
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index 19f0cfc..3f623e5 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -14,20 +14,20 @@ import Common.Model (CreateIncome (..), EditIncome (..),
import qualified Common.Msg as Msg
import Json (jsonId)
-import qualified Model.Income as Income
import qualified Model.Query as Query
+import qualified Persistence.Income as IncomePersistence
import qualified Secure
create :: CreateIncome -> ActionM ()
create (CreateIncome date amount) =
Secure.loggedAction (\user ->
- (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId
+ (liftIO . Query.run $ IncomePersistence.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
+ updated <- liftIO . Query.run $ IncomePersistence.editOwn (_user_id user) incomeId date amount
if updated
then status ok200
else status badRequest400
@@ -36,7 +36,7 @@ editOwn (EditIncome incomeId date amount) =
deleteOwn :: IncomeId -> ActionM ()
deleteOwn incomeId =
Secure.loggedAction (\user -> do
- deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId
+ deleted <- liftIO . Query.run $ IncomePersistence.deleteOwn user incomeId
if deleted
then
status ok200
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index 9a3e2b7..f942540 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -23,11 +23,11 @@ import qualified Common.Msg as Msg
import Conf (Conf (..))
import qualified LoginSession
-import Model.Init (getInit)
import qualified Model.Query as Query
import qualified Model.SignIn as SignIn
-import qualified Model.User as User
-import Secure (getUserFromToken)
+import qualified Persistence.Init as InitPersistence
+import qualified Persistence.User as UserPersistence
+import qualified Secure
import qualified SendMail
import qualified Text.Email.Validate as Email
import qualified View.Mail.SignIn as SignIn
@@ -39,16 +39,16 @@ get conf = do
mbLoggedUser <- getLoggedUser
case mbLoggedUser of
Nothing ->
- return . InitEmpty . Right $ Nothing
+ return InitEmpty
Just user ->
- liftIO . Query.run . fmap InitSuccess $ getInit user conf
+ liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf
S.html $ page initResult
askSignIn :: Conf -> SignIn -> ActionM ()
askSignIn conf (SignIn email) =
if Email.isValid (TE.encodeUtf8 email)
then do
- maybeUser <- liftIO . Query.run $ User.get email
+ maybeUser <- liftIO . Query.run $ UserPersistence.get email
case maybeUser of
Just user -> do
token <- liftIO . Query.run $ SignIn.createSignInToken email
@@ -71,7 +71,7 @@ trySignIn conf token = do
userOrError <- validateSignIn conf token
case userOrError of
Left errorKey ->
- S.html $ page (InitEmpty . Left . Msg.get $ errorKey)
+ S.html $ page (InitError $ Msg.get errorKey)
Right _ ->
S.redirect "/"
@@ -100,7 +100,7 @@ validateSignIn conf textToken = do
LoginSession.put conf (SignIn.token signIn)
mbUser <- liftIO . Query.run $ do
SignIn.signInTokenToUsed . SignIn.id $ signIn
- User.get . SignIn.email $ signIn
+ UserPersistence.get . SignIn.email $ signIn
return $ case mbUser of
Nothing -> Left Msg.Secure_Unauthorized
Just user -> Right user
@@ -112,7 +112,7 @@ getLoggedUser = do
Nothing ->
return Nothing
Just token -> do
- liftIO . Query.run . getUserFromToken $ token
+ liftIO . Query.run . Secure.getUserFromToken $ token
signOut :: Conf -> ActionM ()
signOut conf = LoginSession.delete conf >> S.status ok200
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index f2af6c9..e1936f0 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -5,54 +5,54 @@ module Controller.Payment
, deleteOwn
) where
-import Control.Monad.IO.Class (liftIO)
-import Network.HTTP.Types.Status (badRequest400, ok200)
+import Control.Monad.IO.Class (liftIO)
+import qualified Network.HTTP.Types.Status as Status
import Web.Scotty
-import Common.Model (CreatePayment (..),
- EditPayment (..), PaymentId,
- User (..))
+import Common.Model (CreatePayment (..),
+ EditPayment (..), PaymentId,
+ User (..))
-import Json (jsonId)
-import qualified Model.Payment as Payment
-import qualified Model.PaymentCategory as PaymentCategory
-import qualified Model.Query as Query
+import qualified Json
+import qualified Model.Query as Query
+import qualified Persistence.Payment as PaymentPersistence
+import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
import qualified Secure
list :: ActionM ()
list =
Secure.loggedAction (\_ ->
- (liftIO . Query.run $ Payment.listActive) >>= json
+ (liftIO . Query.run $ PaymentPersistence.listActive) >>= 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
+ PaymentCategoryPersistence.save name category
+ PaymentPersistence.create (_user_id user) name cost date frequency
+ ) >>= Json.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
+ edited <- PaymentPersistence.editOwn (_user_id user) paymentId name cost date frequency
_ <- if edited
- then PaymentCategory.save name category >> return ()
+ then PaymentCategoryPersistence.save name category >> return ()
else return ()
return edited
if updated
- then status ok200
- else status badRequest400
+ then status Status.ok200
+ else status Status.badRequest400
)
deleteOwn :: PaymentId -> ActionM ()
deleteOwn paymentId =
Secure.loggedAction (\user -> do
- deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId
+ deleted <- liftIO . Query.run $ PaymentPersistence.deleteOwn (_user_id user) paymentId
if deleted
- then status ok200
- else status badRequest400
+ then status Status.ok200
+ else status Status.badRequest400
)
diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs
index be0e74f..0385cb4 100644
--- a/server/src/Design/Form.hs
+++ b/server/src/Design/Form.hs
@@ -53,8 +53,10 @@ design = do
right (px 0)
top (px 27)
zIndex inputZIndex
- hover & "svg path" ? do
- "fill" -: "rgb(220, 220, 220)"
+ svg ? "path" ?
+ ("fill" -: Color.toString Color.silver)
+ hover & svg ? "path" ?
+ ("fill" -: Color.toString (Color.silver -. 25))
(input # ".filled" |+ label) <> (input # focus |+ label) ? do
top (px 0)
@@ -108,18 +110,18 @@ design = do
fontWeight bold
".selectInput" ? do
+ marginBottom (em 1)
label ? do
display block
marginBottom (px 10)
fontSize (pct 80)
select ? do
+ width (pct 100)
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)
+ option ? sym2 padding (px 5) (px 8)
".error" & do
select ? borderColor Color.chestnutRose
".errorMessage" ? do
diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs
index 2612257..ce427c0 100644
--- a/server/src/Design/Modal.hs
+++ b/server/src/Design/Modal.hs
@@ -9,19 +9,18 @@ import Clay
design :: Css
design = do
- ".curtain" ? do
+ ".modalCurtain" ? do
position fixed
- cursor pointer
top (px 0)
left (px 0)
width (pct 100)
height (pct 100)
- backgroundColor (rgba 0 0 0 0.5)
+ backgroundColor (rgba 0 0 0 0.7)
zIndex 1000
opacity 1
transition "all" (sec 0.2) ease (sec 0)
- ".content" ? do
+ ".modalContent" ? do
minWidth (px 270)
position fixed
top (pct 25)
@@ -29,7 +28,6 @@ design = do
"transform" -: "translate(-50%, -25%)"
zIndex 1000
backgroundColor white
- sym padding (px 20)
sym borderRadius (px 5)
boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5)
diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs
index 0d59fa0..2102ff8 100644
--- a/server/src/Design/View/Payment.hs
+++ b/server/src/Design/View/Payment.hs
@@ -4,6 +4,7 @@ module Design.View.Payment
import Clay
+import qualified Design.View.Payment.Add as Add
import qualified Design.View.Payment.Header as Header
import qualified Design.View.Payment.Pages as Pages
import qualified Design.View.Payment.Table as Table
@@ -11,5 +12,6 @@ import qualified Design.View.Payment.Table as Table
design :: Css
design = do
".header" ? Header.design
+ ".add" ? Add.design
".table" ? Table.design
".pages" ? Pages.design
diff --git a/server/src/Design/View/Payment/Add.hs b/server/src/Design/View/Payment/Add.hs
new file mode 100644
index 0000000..199ad36
--- /dev/null
+++ b/server/src/Design/View/Payment/Add.hs
@@ -0,0 +1,32 @@
+module Design.View.Payment.Add
+ ( design
+ ) where
+
+import Clay
+
+import qualified Design.Color as Color
+import qualified Design.Constants as Constants
+import qualified Design.Helper as Helper
+
+design :: Css
+design = do
+ ".addHeader" ? do
+ backgroundColor Color.chestnutRose
+ fontSize (px 18)
+ color Color.white
+ sym padding (px 20)
+ textAlign (alignSide sideCenter)
+ borderRadius (px 5) (px 5) (px 0) (px 0)
+
+ ".addContent" ? do
+ sym padding (px 20)
+
+ ".buttons" ? do
+ display flex
+ justifyContent spaceAround
+ marginTop (em 1.5)
+
+ ".confirm" ?
+ Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
+ ".undo" ?
+ Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten
diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs
index 80c5436..0cb5b5d 100644
--- a/server/src/Design/View/Payment/Header.hs
+++ b/server/src/Design/View/Payment/Header.hs
@@ -6,8 +6,6 @@ import Data.Monoid ((<>))
import Clay
-import Design.Constants
-
import qualified Design.Color as Color
import qualified Design.Constants as Constants
import qualified Design.Helper as Helper
@@ -17,8 +15,8 @@ design :: Css
design = do
Media.desktop $ marginBottom (em 3)
Media.mobileTablet $ marginBottom (em 2)
- marginLeft (pct blockPercentMargin)
- marginRight (pct blockPercentMargin)
+ marginLeft (pct Constants.blockPercentMargin)
+ marginRight (pct Constants.blockPercentMargin)
".payerAndAdd" ? do
Media.tabletDesktop $ display flex
@@ -55,9 +53,6 @@ design = do
".textInput" ? do
display inlineBlock
marginBottom (px 0)
- button ? do
- svg ? "path" ? ("fill" -: Color.toString Color.silver)
- hover & svg ? "path" ? ("fill" -: Color.toString (Color.silver -. 25))
Media.tabletDesktop $ marginRight (px 30)
Media.mobile $ do
diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs
index 907be2b..dfbe8b4 100644
--- a/server/src/Job/MonthlyPayment.hs
+++ b/server/src/Job/MonthlyPayment.hs
@@ -2,19 +2,19 @@ module Job.MonthlyPayment
( monthlyPayment
) where
-import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Clock (UTCTime, getCurrentTime)
-import Common.Model (Frequency (..), Payment (..))
+import Common.Model (Frequency (..), Payment (..))
+import qualified Common.Util.Time as Time
-import qualified Model.Payment as Payment
-import qualified Model.Query as Query
-import Util.Time (timeToDay)
+import qualified Model.Query as Query
+import qualified Persistence.Payment as PaymentPersistence
monthlyPayment :: Maybe UTCTime -> IO UTCTime
monthlyPayment _ = do
- monthlyPayments <- Query.run Payment.listActiveMonthlyOrderedByName
+ monthlyPayments <- Query.run PaymentPersistence.listActiveMonthlyOrderedByName
now <- getCurrentTime
- actualDay <- timeToDay now
+ actualDay <- Time.timeToDay now
let punctualPayments = map
(\p -> p
{ _payment_frequency = Punctual
@@ -22,5 +22,5 @@ monthlyPayment _ = do
, _payment_createdAt = now
})
monthlyPayments
- _ <- Query.run (Payment.createMany punctualPayments)
+ _ <- Query.run (PaymentPersistence.createMany punctualPayments)
return now
diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs
index 38d88b5..203c4e8 100644
--- a/server/src/Job/WeeklyReport.hs
+++ b/server/src/Job/WeeklyReport.hs
@@ -5,10 +5,10 @@ module Job.WeeklyReport
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 Persistence.Income as IncomePersistence
+import qualified Persistence.Payment as PaymentPersistence
+import qualified Persistence.User as UserPersistence
import qualified SendMail
import qualified View.Mail.WeeklyReport as WeeklyReport
@@ -19,7 +19,7 @@ weeklyReport conf mbLastExecution = do
Nothing -> return ()
Just lastExecution -> do
(payments, incomes, users) <- Query.run $
- (,,) <$> Payment.listPunctual <*> Income.list <*> User.list
+ (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.list <*> UserPersistence.list
_ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now)
return ()
return now
diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs
deleted file mode 100644
index ee406bc..0000000
--- a/server/src/Model/Category.hs
+++ /dev/null
@@ -1,78 +0,0 @@
-{-# 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 (FromRow (fromRow), Only (Only))
-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
deleted file mode 100644
index c29cf37..0000000
--- a/server/src/Model/Frequency.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Model.Frequency () where
-
-import qualified Data.Text as T
-import Database.SQLite.Simple (SQLData (SQLText))
-import Database.SQLite.Simple.FromField (FromField (fromField),
- fieldData)
-import Database.SQLite.Simple.Ok (Ok (Errors, Ok))
-import Database.SQLite.Simple.ToField (ToField (toField))
-
-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
deleted file mode 100644
index 4938e50..0000000
--- a/server/src/Model/Income.hs
+++ /dev/null
@@ -1,88 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Model.Income
- ( list
- , create
- , editOwn
- , deleteOwn
- ) where
-
-import Data.Maybe (listToMaybe)
-import Data.Time.Calendar (Day)
-import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
-import qualified Database.SQLite.Simple as SQLite
-import Prelude hiding (id)
-
-import Common.Model (Income (..), IncomeId, User (..),
- UserId)
-
-import Model.Query (Query (Query))
-import Resource (Resource, resourceCreatedAt,
- resourceDeletedAt, resourceEditedAt)
-
-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
- )
diff --git a/server/src/Model/IncomeResource.hs b/server/src/Model/IncomeResource.hs
new file mode 100644
index 0000000..6ab5f18
--- /dev/null
+++ b/server/src/Model/IncomeResource.hs
@@ -0,0 +1,15 @@
+module Model.IncomeResource
+ ( IncomeResource(..)
+ ) where
+
+import Common.Model (Income (..))
+
+import Resource (Resource, resourceCreatedAt, resourceDeletedAt,
+ resourceEditedAt)
+
+newtype IncomeResource = IncomeResource Income
+
+instance Resource IncomeResource where
+ resourceCreatedAt (IncomeResource i) = _income_createdAt i
+ resourceEditedAt (IncomeResource i) = _income_editedAt i
+ resourceDeletedAt (IncomeResource i) = _income_deletedAt i
diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs
deleted file mode 100644
index 0a0ffc7..0000000
--- a/server/src/Model/Init.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module Model.Init
- ( getInit
- ) where
-
-import Common.Model (Init (Init), User (..))
-
-import Conf (Conf)
-import qualified Conf
-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 Model.Query (Query)
-import qualified Model.User as User
-
-getInit :: User -> Conf -> Query Init
-getInit user conf =
- Init <$>
- User.list <*>
- (return . _user_id $ user) <*>
- Payment.listActive <*>
- Income.list <*>
- Category.list <*>
- PaymentCategory.list <*>
- (return . Conf.currency $ conf)
diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs
deleted file mode 100644
index 5b29409..0000000
--- a/server/src/Model/Payment.hs
+++ /dev/null
@@ -1,169 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Model.Payment
- ( Payment(..)
- , find
- , listActive
- , listPunctual
- , listActiveMonthlyOrderedByName
- , create
- , createMany
- , editOwn
- , deleteOwn
- ) where
-
-import Data.Maybe (listToMaybe)
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time.Calendar (Day)
-import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (FromRow (fromRow), Only (Only),
- ToRow)
-import qualified Database.SQLite.Simple as SQLite
-import Database.SQLite.Simple.ToField (ToField (toField))
-import Prelude hiding (id)
-
-import Common.Model (Frequency (..), Payment (..),
- PaymentId, UserId)
-
-import Model.Frequency ()
-import Model.Query (Query (Query))
-import Resource (Resource, resourceCreatedAt,
- resourceDeletedAt,
- resourceEditedAt)
-
-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)
- )
-
-listActive :: Query [Payment]
-listActive =
- Query (\conn ->
- SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL"
- )
-
-listPunctual :: Query [Payment]
-listPunctual =
- Query (\conn ->
- SQLite.query
- conn
- (SQLite.Query "SELECT * FROM payment WHERE frequency = ?")
- (Only Punctual))
-
-listActiveMonthlyOrderedByName :: Query [Payment]
-listActiveMonthlyOrderedByName =
- 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
- )
diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs
deleted file mode 100644
index c60c1a2..0000000
--- a/server/src/Model/PaymentCategory.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Model.PaymentCategory
- ( list
- , listByCategory
- , save
- ) where
-
-import Data.Maybe (isJust, listToMaybe)
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
-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/PaymentResource.hs b/server/src/Model/PaymentResource.hs
new file mode 100644
index 0000000..1ea978c
--- /dev/null
+++ b/server/src/Model/PaymentResource.hs
@@ -0,0 +1,15 @@
+module Model.PaymentResource
+ ( PaymentResource(..)
+ ) where
+
+import Common.Model (Payment (..))
+
+import Resource (Resource, resourceCreatedAt, resourceDeletedAt,
+ resourceEditedAt)
+
+newtype PaymentResource = PaymentResource Payment
+
+instance Resource PaymentResource where
+ resourceCreatedAt (PaymentResource p) = _payment_createdAt p
+ resourceEditedAt (PaymentResource p) = _payment_editedAt p
+ resourceDeletedAt (PaymentResource p) = _payment_deletedAt p
diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs
deleted file mode 100644
index 8dc1fc8..0000000
--- a/server/src/Model/User.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-{-# 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 (FromRow (fromRow), Only (Only))
-import qualified Database.SQLite.Simple as SQLite
-import Prelude hiding (id)
-
-import Common.Model (User (..), UserId)
-
-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/Persistence/Category.hs b/server/src/Persistence/Category.hs
new file mode 100644
index 0000000..2afe5db
--- /dev/null
+++ b/server/src/Persistence/Category.hs
@@ -0,0 +1,79 @@
+module Persistence.Category
+ ( list
+ , create
+ , edit
+ , delete
+ ) where
+
+import Data.Maybe (isJust, listToMaybe)
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime)
+import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
+import qualified Database.SQLite.Simple as SQLite
+import Prelude hiding (id)
+
+import Common.Model (Category (..), CategoryId)
+
+import Model.Query (Query (Query))
+
+newtype Row = Row Category
+
+instance FromRow Row where
+ fromRow = Row <$> (Category <$>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field)
+
+list :: Query [Category]
+list =
+ Query (\conn ->
+ map (\(Row c) -> c) <$>
+ 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 <- fmap (\(Row c) -> c) . listToMaybe <$>
+ (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
+ 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 <- fmap (\(Row c) -> c) . listToMaybe <$>
+ (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
+ 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/Persistence/Frequency.hs b/server/src/Persistence/Frequency.hs
new file mode 100644
index 0000000..edaa844
--- /dev/null
+++ b/server/src/Persistence/Frequency.hs
@@ -0,0 +1,23 @@
+module Persistence.Frequency
+ ( FrequencyField(..)
+ ) where
+
+import qualified Data.Text as T
+import Database.SQLite.Simple (SQLData (SQLText))
+import Database.SQLite.Simple.FromField (FromField (fromField),
+ fieldData)
+import Database.SQLite.Simple.Ok (Ok (Errors, Ok))
+import Database.SQLite.Simple.ToField (ToField (toField))
+
+import Common.Model (Frequency)
+
+newtype FrequencyField = FrequencyField Frequency
+
+instance FromField FrequencyField where
+ fromField field =
+ case fieldData field of
+ SQLText text -> Ok (FrequencyField (read (T.unpack text) :: Frequency))
+ _ -> Errors [error "SQLText field required for frequency"]
+
+instance ToField FrequencyField where
+ toField (FrequencyField f) = SQLText . T.pack . show $ f
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
new file mode 100644
index 0000000..a863f85
--- /dev/null
+++ b/server/src/Persistence/Income.hs
@@ -0,0 +1,88 @@
+module Persistence.Income
+ ( list
+ , create
+ , editOwn
+ , deleteOwn
+ ) where
+
+import Data.Maybe (listToMaybe)
+import Data.Time.Calendar (Day)
+import Data.Time.Clock (getCurrentTime)
+import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
+import qualified Database.SQLite.Simple as SQLite
+import Prelude hiding (id)
+
+import Common.Model (Income (..), IncomeId, User (..),
+ UserId)
+
+import Model.Query (Query (Query))
+
+newtype Row = Row Income
+
+instance FromRow Row where
+ fromRow = Row <$> (Income <$>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field)
+
+list :: Query [Income]
+list =
+ Query (\conn ->
+ map (\(Row i) -> i) <$>
+ 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 <- fmap (\(Row i) -> i) . 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 <-
+ fmap (\(Row i) -> i) . 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
+ )
diff --git a/server/src/Persistence/Init.hs b/server/src/Persistence/Init.hs
new file mode 100644
index 0000000..74d9172
--- /dev/null
+++ b/server/src/Persistence/Init.hs
@@ -0,0 +1,25 @@
+module Persistence.Init
+ ( getInit
+ ) where
+
+import Common.Model (Init (Init), User (..))
+
+import Conf (Conf)
+import qualified Conf
+import Model.Query (Query)
+import qualified Persistence.Category as CategoryPersistence
+import qualified Persistence.Income as IncomePersistence
+import qualified Persistence.Payment as PaymentPersistence
+import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
+import qualified Persistence.User as UserPersistence
+
+getInit :: User -> Conf -> Query Init
+getInit user conf =
+ Init <$>
+ UserPersistence.list <*>
+ (return . _user_id $ user) <*>
+ PaymentPersistence.listActive <*>
+ IncomePersistence.list <*>
+ CategoryPersistence.list <*>
+ PaymentCategoryPersistence.list <*>
+ (return . Conf.currency $ conf)
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
new file mode 100644
index 0000000..32600d7
--- /dev/null
+++ b/server/src/Persistence/Payment.hs
@@ -0,0 +1,169 @@
+module Persistence.Payment
+ ( Payment(..)
+ , find
+ , listActive
+ , listPunctual
+ , listActiveMonthlyOrderedByName
+ , create
+ , createMany
+ , editOwn
+ , deleteOwn
+ ) where
+
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Calendar (Day)
+import Data.Time.Clock (getCurrentTime)
+import Database.SQLite.Simple (FromRow (fromRow), Only (Only),
+ ToRow)
+import qualified Database.SQLite.Simple as SQLite
+import Database.SQLite.Simple.ToField (ToField (toField))
+import Prelude hiding (id)
+
+import Common.Model (Frequency (..), Payment (..),
+ PaymentId, UserId)
+
+import Model.Query (Query (Query))
+import Persistence.Frequency (FrequencyField (..))
+
+newtype Row = Row Payment
+
+instance FromRow Row where
+ fromRow = Row <$> (Payment <$>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ (fmap (\(FrequencyField f) -> f) $ SQLite.field) <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field)
+
+newtype InsertRow = InsertRow Payment
+
+instance ToRow InsertRow where
+ toRow (InsertRow p) =
+ [ toField (_payment_user p)
+ , toField (_payment_name p)
+ , toField (_payment_cost p)
+ , toField (_payment_date p)
+ , toField (FrequencyField (_payment_frequency p))
+ , toField (_payment_createdAt p)
+ ]
+
+find :: PaymentId -> Query (Maybe Payment)
+find paymentId =
+ Query (\conn -> do
+ fmap (\(Row p) -> p) . listToMaybe <$>
+ SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
+ )
+
+listActive :: Query [Payment]
+listActive =
+ Query (\conn -> do
+ map (\(Row p) -> p) <$>
+ SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL"
+ )
+
+listPunctual :: Query [Payment]
+listPunctual =
+ Query (\conn -> do
+ map (\(Row p) -> p) <$>
+ SQLite.query
+ conn
+ (SQLite.Query "SELECT * FROM payment WHERE frequency = ?")
+ (Only (FrequencyField Punctual))
+ )
+
+listActiveMonthlyOrderedByName :: Query [Payment]
+listActiveMonthlyOrderedByName =
+ Query (\conn -> do
+ map (\(Row p) -> p) <$>
+ SQLite.query
+ conn
+ (SQLite.Query $ T.intercalate " "
+ [ "SELECT *"
+ , "FROM payment"
+ , "WHERE deleted_at IS NULL AND frequency = ?"
+ , "ORDER BY name DESC"
+ ])
+ (Only (FrequencyField 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, FrequencyField 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 (?, ?, ?, ?, ?, ?)"
+ ])
+ (map InsertRow payments)
+ )
+
+editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool
+editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency =
+ Query (\conn -> do
+ mbPayment <- fmap (\(Row p) -> p) . 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, FrequencyField 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 (Row 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
+ )
diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs
new file mode 100644
index 0000000..1e377b1
--- /dev/null
+++ b/server/src/Persistence/PaymentCategory.hs
@@ -0,0 +1,66 @@
+module Persistence.PaymentCategory
+ ( list
+ , listByCategory
+ , save
+ ) where
+
+import Data.Maybe (isJust, listToMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (getCurrentTime)
+import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
+import qualified Database.SQLite.Simple as SQLite
+
+import Common.Model (CategoryId, PaymentCategory (..))
+import qualified Common.Util.Text as T
+
+import Model.Query (Query (Query))
+
+newtype Row = Row PaymentCategory
+
+instance FromRow Row where
+ fromRow = Row <$> (PaymentCategory <$>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field)
+
+list :: Query [PaymentCategory]
+list =
+ Query (\conn -> do
+ map (\(Row pc) -> pc) <$>
+ SQLite.query_ conn "SELECT * from payment_category"
+ )
+
+listByCategory :: CategoryId -> Query [PaymentCategory]
+listByCategory cat =
+ Query (\conn -> do
+ map (\(Row pc) -> pc) <$>
+ SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat)
+ )
+
+save :: Text -> CategoryId -> Query ()
+save newName categoryId =
+ Query (\conn -> do
+ now <- getCurrentTime
+ hasPaymentCategory <- isJust <$> listToMaybe <$>
+ (SQLite.query
+ conn
+ "SELECT * FROM payment_category WHERE name = ?"
+ (Only (formatPaymentName newName)) :: IO [Row])
+ if hasPaymentCategory
+ 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/Persistence/User.hs b/server/src/Persistence/User.hs
new file mode 100644
index 0000000..4ec2dcf
--- /dev/null
+++ b/server/src/Persistence/User.hs
@@ -0,0 +1,37 @@
+module Persistence.User
+ ( list
+ , get
+ ) where
+
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
+import qualified Database.SQLite.Simple as SQLite
+import Prelude hiding (id)
+
+import Common.Model (User (..))
+
+import Model.Query (Query (Query))
+
+newtype Row = Row User
+
+instance FromRow Row where
+ fromRow = Row <$> (User <$>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field)
+
+list :: Query [User]
+list =
+ Query (\conn -> do
+ map (\(Row u) -> u) <$>
+ SQLite.query_ conn "SELECT * from user ORDER BY creation DESC"
+ )
+
+get :: Text -> Query (Maybe User)
+get userEmail =
+ Query (\conn -> do
+ fmap (\(Row u) -> u) . listToMaybe <$>
+ SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail)
+ )
diff --git a/server/src/Secure.hs b/server/src/Secure.hs
index 6e5b998..4fb2333 100644
--- a/server/src/Secure.hs
+++ b/server/src/Secure.hs
@@ -16,7 +16,7 @@ import qualified LoginSession
import Model.Query (Query)
import qualified Model.Query as Query
import qualified Model.SignIn as SignIn
-import qualified Model.User as User
+import qualified Persistence.User as UserPersistence
loggedAction :: (User -> ActionM ()) -> ActionM ()
loggedAction action = do
@@ -39,6 +39,6 @@ getUserFromToken token = do
mbSignIn <- SignIn.getSignIn token
case mbSignIn of
Just signIn ->
- User.get (SignIn.email signIn)
+ UserPersistence.get (SignIn.email signIn)
Nothing ->
return Nothing
diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs
index 3b17a0a..13d4072 100644
--- a/server/src/SendMail.hs
+++ b/server/src/SendMail.hs
@@ -43,6 +43,7 @@ mockMailMessage mail = T.concat $
, ")"
, "\n"
, body mail
+ , "\n"
]
getMimeMail :: Mail -> M.Mail
diff --git a/server/src/Util/Time.hs b/server/src/Util/Time.hs
index 3e0856d..4a29fcc 100644
--- a/server/src/Util/Time.hs
+++ b/server/src/Util/Time.hs
@@ -1,25 +1,22 @@
module Util.Time
( belongToCurrentMonth
, belongToCurrentWeek
- , timeToDay
) where
-import Data.Time.Calendar
+import Data.Time.Calendar (toGregorian)
import Data.Time.Calendar.WeekDate (toWeekDate)
import Data.Time.Clock (UTCTime, getCurrentTime)
-import Data.Time.LocalTime
+
+import qualified Common.Util.Time as Time
belongToCurrentMonth :: UTCTime -> IO Bool
belongToCurrentMonth time = do
- (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time
- (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay)
+ (timeYear, timeMonth, _) <- toGregorian <$> Time.timeToDay time
+ (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= Time.timeToDay)
return (actualYear == timeYear && actualMonth == timeMonth)
belongToCurrentWeek :: UTCTime -> IO Bool
belongToCurrentWeek time = do
- (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time
- (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay)
+ (timeYear, timeWeek, _) <- toWeekDate <$> Time.timeToDay time
+ (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= Time.timeToDay)
return (actualYear == timeYear && actualWeek == timeWeek)
-
-timeToDay :: UTCTime -> IO Day
-timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time
diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs
index 5418880..7e88d98 100644
--- a/server/src/View/Mail/WeeklyReport.hs
+++ b/server/src/View/Mail/WeeklyReport.hs
@@ -2,28 +2,28 @@ module View.Mail.WeeklyReport
( mail
) where
-import Data.List (sortOn)
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Maybe (catMaybes, fromMaybe)
-import Data.Monoid ((<>))
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time.Clock (UTCTime)
+import Data.List (sortOn)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (catMaybes, fromMaybe)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime)
-import Common.Model (ExceedingPayer (..), Income (..),
- Payment (..), User (..), UserId)
-import qualified Common.Model as CM
-import qualified Common.Msg as Msg
-import qualified Common.View.Format as Format
+import Common.Model (ExceedingPayer (..), Income (..),
+ Payment (..), User (..), UserId)
+import qualified Common.Model as CM
+import qualified Common.Msg as Msg
+import qualified Common.View.Format as Format
-import Conf (Conf)
-import qualified Conf as Conf
-import qualified Model.Income ()
-import Model.Mail (Mail (Mail))
-import qualified Model.Mail as M
-import Model.Payment ()
-import Resource (Status (..), groupByStatus, statuses)
+import Conf (Conf)
+import qualified Conf as Conf
+import Model.IncomeResource (IncomeResource (..))
+import Model.Mail (Mail (Mail))
+import qualified Model.Mail as M
+import Model.PaymentResource (PaymentResource (..))
+import Resource (Status (..), groupByStatus, statuses)
mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail
mail conf users payments incomes start end =
@@ -42,8 +42,11 @@ body :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Text
body conf users payments incomes start end =
T.intercalate "\n" $
[ exceedingPayers conf end users incomes (filter (null . _payment_deletedAt) payments)
- , operations conf users (groupByStatus start end payments) (groupByStatus start end incomes)
+ , operations conf users paymentsGroupedByStatus incomesGroupedByStatus
]
+ where
+ paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ payments
+ incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes
exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> [Payment] -> Text
exceedingPayers conf time users incomes payments =
@@ -58,7 +61,7 @@ exceedingPayers conf time users incomes payments =
, "\n"
]
-operations :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text
+operations :: Conf -> [User] -> Map Status [PaymentResource] -> Map Status [IncomeResource] -> Text
operations conf users paymentsByStatus incomesByStatus =
if M.null paymentsByStatus && M.null incomesByStatus
then
@@ -69,7 +72,7 @@ operations conf users paymentsByStatus incomesByStatus =
, map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses
]
-paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text
+paymentSection :: Status -> Conf -> [User] -> [PaymentResource] -> Text
paymentSection status conf users payments =
section sectionTitle sectionItems
where count = length payments
@@ -77,7 +80,7 @@ paymentSection status conf users payments =
Created -> if count > 1 then Msg.WeeklyReport_PaymentsCreated count else Msg.WeeklyReport_PaymentCreated count
Edited -> if count > 1 then Msg.WeeklyReport_PaymentsEdited count else Msg.WeeklyReport_PaymentEdited count
Deleted -> if count > 1 then Msg.WeeklyReport_PaymentsDeleted count else Msg.WeeklyReport_PaymentDeleted count
- sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments
+ sectionItems = map (payedFor status conf users) . sortOn _payment_date . map (\(PaymentResource p) -> p) $ payments
payedFor :: Status -> Conf -> [User] -> Payment -> Text
payedFor status conf users payment =
@@ -89,7 +92,7 @@ payedFor status conf users payment =
for = _payment_name payment
at = Format.longDay $ _payment_date payment
-incomeSection :: Status -> Conf -> [User] -> [Income] -> Text
+incomeSection :: Status -> Conf -> [User] -> [IncomeResource] -> Text
incomeSection status conf users incomes =
section sectionTitle sectionItems
where count = length incomes
@@ -97,7 +100,7 @@ incomeSection status conf users incomes =
Created -> if count > 1 then Msg.WeeklyReport_IncomesCreated count else Msg.WeeklyReport_IncomeCreated count
Edited -> if count > 1 then Msg.WeeklyReport_IncomesEdited count else Msg.WeeklyReport_IncomeEdited count
Deleted -> if count > 1 then Msg.WeeklyReport_IncomesDeleted count else Msg.WeeklyReport_IncomeDeleted count
- sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes
+ sectionItems = map (isPayedFrom status conf users) . sortOn _income_date . map (\(IncomeResource i) -> i) $ incomes
isPayedFrom :: Status -> Conf -> [User] -> Income -> Text
isPayedFrom status conf users income =
--
cgit v1.2.3
From 40b4994797a797b1fa86cafda789a5c488730c6d Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 28 Oct 2018 17:57:58 +0100
Subject: Delete payment
---
server/server.cabal | 5 +++--
server/src/Controller/Payment.hs | 17 ++++++++++++-----
server/src/Design/Modal.hs | 9 +++++++--
server/src/Design/View/Payment.hs | 2 --
server/src/Design/View/Payment/Delete.hs | 32 ++++++++++++++++++++++++++++++++
server/src/Main.hs | 6 +++---
server/src/Validation.hs | 23 -----------------------
server/src/Validation/Atomic.hs | 32 ++++++++++++++++++++++++++++++++
server/src/Validation/CreatePayment.hs | 25 +++++++++++++++++++++++++
9 files changed, 114 insertions(+), 37 deletions(-)
create mode 100644 server/src/Design/View/Payment/Delete.hs
delete mode 100644 server/src/Validation.hs
create mode 100644 server/src/Validation/Atomic.hs
create mode 100644 server/src/Validation/CreatePayment.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 2bfd18d..2c6bef1 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -21,7 +21,7 @@ Executable server
Build-depends:
aeson
- , base >=4.9 && <4.11
+ , base >=4.9 && <5
, base64-bytestring
, blaze-builder
, blaze-html
@@ -103,7 +103,8 @@ Executable server
Secure
SendMail
Util.Time
- Validation
+ Validation.Atomic
+ Validation.CreatePayment
View.Mail.SignIn
View.Mail.WeeklyReport
View.Page
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index e1936f0..4edbf6a 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -18,6 +18,7 @@ import qualified Model.Query as Query
import qualified Persistence.Payment as PaymentPersistence
import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
import qualified Secure
+import qualified Validation.CreatePayment as CreatePaymentValidation
list :: ActionM ()
list =
@@ -26,12 +27,18 @@ list =
)
create :: CreatePayment -> ActionM ()
-create (CreatePayment name cost date category frequency) =
+create createPayment@(CreatePayment name cost date category frequency) =
Secure.loggedAction (\user ->
- (liftIO . Query.run $ do
- PaymentCategoryPersistence.save name category
- PaymentPersistence.create (_user_id user) name cost date frequency
- ) >>= Json.jsonId
+ case CreatePaymentValidation.validate createPayment of
+ Nothing ->
+ (liftIO . Query.run $ do
+ PaymentCategoryPersistence.save name category
+ PaymentPersistence.create (_user_id user) name cost date frequency
+ ) >>= Json.jsonId
+ Just validationError ->
+ do
+ status Status.badRequest400
+ json validationError
)
editOwn :: EditPayment -> ActionM ()
diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs
index ce427c0..2677fd8 100644
--- a/server/src/Design/Modal.hs
+++ b/server/src/Design/Modal.hs
@@ -2,9 +2,11 @@ module Design.Modal
( design
) where
-import Data.Monoid ((<>))
-
import Clay
+import Data.Monoid ((<>))
+
+import qualified Design.View.Payment.Add as Add
+import qualified Design.View.Payment.Delete as Delete
design :: Css
design = do
@@ -31,6 +33,9 @@ design = do
sym borderRadius (px 5)
boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5)
+ ".add" ? Add.design
+ ".delete" ? Delete.design
+
".paymentModal" & do
".radioGroup" ? ".title" ? display none
".selectInput" ? do
diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs
index 2102ff8..0d59fa0 100644
--- a/server/src/Design/View/Payment.hs
+++ b/server/src/Design/View/Payment.hs
@@ -4,7 +4,6 @@ module Design.View.Payment
import Clay
-import qualified Design.View.Payment.Add as Add
import qualified Design.View.Payment.Header as Header
import qualified Design.View.Payment.Pages as Pages
import qualified Design.View.Payment.Table as Table
@@ -12,6 +11,5 @@ import qualified Design.View.Payment.Table as Table
design :: Css
design = do
".header" ? Header.design
- ".add" ? Add.design
".table" ? Table.design
".pages" ? Pages.design
diff --git a/server/src/Design/View/Payment/Delete.hs b/server/src/Design/View/Payment/Delete.hs
new file mode 100644
index 0000000..5597f5b
--- /dev/null
+++ b/server/src/Design/View/Payment/Delete.hs
@@ -0,0 +1,32 @@
+module Design.View.Payment.Delete
+ ( design
+ ) where
+
+import Clay
+
+import qualified Design.Color as Color
+import qualified Design.Constants as Constants
+import qualified Design.Helper as Helper
+
+design :: Css
+design = do
+ ".deleteHeader" ? do
+ backgroundColor Color.chestnutRose
+ fontSize (px 18)
+ color Color.white
+ sym padding (px 20)
+ textAlign (alignSide sideCenter)
+ borderRadius (px 5) (px 5) (px 0) (px 0)
+
+ ".deleteContent" ? do
+ sym padding (px 20)
+
+ ".buttons" ? do
+ display flex
+ justifyContent spaceAround
+ marginTop (em 1.5)
+
+ ".confirm" ?
+ Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
+ ".undo" ?
+ Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten
diff --git a/server/src/Main.hs b/server/src/Main.hs
index e298a06..745071c 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -37,7 +37,7 @@ main = do
S.put "/payment" $
S.jsonData >>= Payment.editOwn
- S.delete "/payment" $ do
+ S.delete "/payment/:id" $ do
paymentId <- S.param "id"
Payment.deleteOwn paymentId
@@ -47,7 +47,7 @@ main = do
S.put "/income" $
S.jsonData >>= Income.editOwn
- S.delete "/income" $ do
+ S.delete "/income/:id" $ do
incomeId <- S.param "id"
Income.deleteOwn incomeId
@@ -57,6 +57,6 @@ main = do
S.put "/category" $
S.jsonData >>= Category.edit
- S.delete "/category" $ do
+ S.delete "/category/:id" $ do
categoryId <- S.param "id"
Category.delete categoryId
diff --git a/server/src/Validation.hs b/server/src/Validation.hs
deleted file mode 100644
index fd739cd..0000000
--- a/server/src/Validation.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-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/Validation/Atomic.hs b/server/src/Validation/Atomic.hs
new file mode 100644
index 0000000..d15ad49
--- /dev/null
+++ b/server/src/Validation/Atomic.hs
@@ -0,0 +1,32 @@
+module Validation.Atomic
+ ( nonEmpty
+ , nonNullNumber
+ -- , number
+ ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import qualified Common.Msg as Msg
+
+nonEmpty :: Text -> Maybe Text
+nonEmpty str =
+ if T.null str
+ then Just $ Msg.get Msg.Form_NonEmpty
+ else Nothing
+
+nonNullNumber :: Int -> Maybe Text
+nonNullNumber n =
+ if n == 0
+ then Just $ Msg.get Msg.Form_NonNullNumber
+ else Nothing
+
+-- 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/Validation/CreatePayment.hs b/server/src/Validation/CreatePayment.hs
new file mode 100644
index 0000000..fbcdb7c
--- /dev/null
+++ b/server/src/Validation/CreatePayment.hs
@@ -0,0 +1,25 @@
+module Validation.CreatePayment
+ ( validate
+ ) where
+
+import Data.Maybe (catMaybes)
+
+import Common.Model.CreatePayment (CreatePayment (..),
+ CreatePaymentError (..))
+import qualified Validation.Atomic as Atomic
+
+validate :: CreatePayment -> Maybe CreatePaymentError
+validate p =
+ if not . null . catMaybes $ [ nameError, costError ]
+ then Just createPaymentError
+ else Nothing
+ where
+ nameError = Atomic.nonEmpty . _createPayment_name $ p
+ costError = Atomic.nonNullNumber . _createPayment_cost $ p
+ createPaymentError = CreatePaymentError
+ { _createPaymentError_name = nameError
+ , _createPaymentError_cost = costError
+ , _createPaymentError_date = Nothing
+ , _createPaymentError_category = Nothing
+ , _createPaymentError_frequency = Nothing
+ }
--
cgit v1.2.3
From 50fb8fa48d1c4881da20b4ecf6d68a772301e713 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 30 Oct 2018 18:04:58 +0100
Subject: Update table when adding or removing a payment
---
server/src/Controller/Payment.hs | 4 +---
server/src/Design/Global.hs | 2 ++
server/src/Persistence/Payment.hs | 21 ++++++++++++++++-----
3 files changed, 19 insertions(+), 8 deletions(-)
(limited to 'server')
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index 4edbf6a..fb7fcb2 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -12,8 +12,6 @@ import Web.Scotty
import Common.Model (CreatePayment (..),
EditPayment (..), PaymentId,
User (..))
-
-import qualified Json
import qualified Model.Query as Query
import qualified Persistence.Payment as PaymentPersistence
import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
@@ -34,7 +32,7 @@ create createPayment@(CreatePayment name cost date category frequency) =
(liftIO . Query.run $ do
PaymentCategoryPersistence.save name category
PaymentPersistence.create (_user_id user) name cost date frequency
- ) >>= Json.jsonId
+ ) >>= json
Just validationError ->
do
status Status.badRequest400
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index 4da4ffb..de8dd61 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -29,6 +29,8 @@ global = do
body ? do
minWidth (px 320)
fontFamily ["Cantarell"] [sansSerif]
+ ".modal" &
+ overflowY hidden
Media.tablet $ do
fontSize (px 15)
button ? fontSize (px 15)
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index 32600d7..272cd39 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -92,18 +92,29 @@ listActiveMonthlyOrderedByName =
(Only (FrequencyField Monthly))
)
-create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId
-create userId paymentName paymentCost paymentDate paymentFrequency =
+create :: UserId -> Text -> Int -> Day -> Frequency -> Query Payment
+create userId name cost date frequency =
Query (\conn -> do
- now <- getCurrentTime
+ time <- getCurrentTime
SQLite.execute
conn
(SQLite.Query $ T.intercalate " "
[ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)"
, "VALUES (?, ?, ?, ?, ?, ?)"
])
- (userId, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, now)
- SQLite.lastInsertRowId conn
+ (userId, name, cost, date, FrequencyField frequency, time)
+ paymentId <- SQLite.lastInsertRowId conn
+ return $ Payment
+ { _payment_id = paymentId
+ , _payment_user = userId
+ , _payment_name = name
+ , _payment_cost = cost
+ , _payment_date = date
+ , _payment_frequency = frequency
+ , _payment_createdAt = time
+ , _payment_editedAt = Nothing
+ , _payment_deletedAt = Nothing
+ }
)
createMany :: [Payment] -> Query ()
--
cgit v1.2.3
From 8a28f608d8e08fba4bbe54b46804d261686c3c03 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 30 Oct 2018 20:33:17 +0100
Subject: Upgrade reflex-platform
---
server/server.cabal | 3 +++
server/src/Design/Modal.hs | 2 +-
server/src/Design/Views.hs | 2 +-
3 files changed, 5 insertions(+), 2 deletions(-)
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 2c6bef1..644f57a 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -73,6 +73,7 @@ Executable server
Design.View.Header
Design.View.Payment
Design.View.Payment.Add
+ Design.View.Payment.Delete
Design.View.Payment.Header
Design.View.Payment.Pages
Design.View.Payment.Table
@@ -88,7 +89,9 @@ Executable server
Job.WeeklyReport
Json
LoginSession
+ Model.IncomeResource
Model.Mail
+ Model.PaymentResource
Model.Query
Model.SignIn
Model.UUID
diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs
index 2677fd8..914c011 100644
--- a/server/src/Design/Modal.hs
+++ b/server/src/Design/Modal.hs
@@ -31,7 +31,7 @@ design = do
zIndex 1000
backgroundColor white
sym borderRadius (px 5)
- boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5)
+ boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15)
".add" ? Add.design
".delete" ? Delete.design
diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs
index a73a1fa..b9e3cf8 100644
--- a/server/src/Design/Views.hs
+++ b/server/src/Design/Views.hs
@@ -43,5 +43,5 @@ design = do
".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)
+ boxShadow . pure . bsColor (rgba 0 0 0 0.3) $ shadowWithBlur (px 2) (px 2) (px 5)
color Color.white
--
cgit v1.2.3
From 86957359ecf54c205aee1c09e151172c327e987a Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 31 Oct 2018 19:03:19 +0100
Subject: Various fixes
---
server/src/Controller/Index.hs | 3 ++-
server/src/Design/Global.hs | 14 ++++++++++----
server/src/Design/Helper.hs | 13 +------------
server/src/Design/View/SignIn.hs | 6 ------
4 files changed, 13 insertions(+), 23 deletions(-)
(limited to 'server')
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index f942540..0b276d3 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -6,6 +6,7 @@ module Controller.Index
) where
import Control.Monad.IO.Class (liftIO)
+import qualified Data.Aeson as Json
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
@@ -60,7 +61,7 @@ askSignIn conf (SignIn email) =
]
maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email]
case maybeSentMail of
- Right _ -> textKey ok200 Msg.SignIn_EmailSent
+ Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent)
Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail
Nothing -> textKey badRequest400 Msg.Secure_Unauthorized
else textKey badRequest400 Msg.SignIn_EmailInvalid
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index de8dd61..ba4ccb7 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -73,14 +73,20 @@ global = do
svg ? height (pct 100)
button ? do
- ".content" ? display flex
- svg # ".loader" ? display none
+ position relative
+
+ ".content" ? do
+ display flex
+
+ svg # ".loader" ? do
+ opacity 0
+ position absolute
".waiting" & do
".content" ? do
- display none
+ opacity 0
svg # ".loader" ? do
- display block
+ opacity 1
rotateKeyframes
rotateAnimation
diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs
index 6980c71..e586d56 100644
--- a/server/src/Design/Helper.hs
+++ b/server/src/Design/Helper.hs
@@ -1,16 +1,14 @@
module Design.Helper
( clearFix
, button
- , input
, centeredWithMargin
, verticalCentering
) where
import Prelude hiding (span)
-import Clay hiding (button, input)
+import Clay hiding (button)
-import Design.Color as Color
import Design.Constants
clearFix :: Css
@@ -37,15 +35,6 @@ button backgroundCol textCol h focusOp = do
hover & backgroundColor (focusOp backgroundCol)
focus & backgroundColor (focusOp backgroundCol)
-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)
diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs
index 7f5f503..2138676 100644
--- a/server/src/Design/View/SignIn.hs
+++ b/server/src/Design/View/SignIn.hs
@@ -17,12 +17,6 @@ design = do
marginLeft auto
marginRight auto
- input ? do
- Helper.input inputHeight
- display block
- width (pct 100)
- marginBottom (px 10)
-
button # ".validate" ? do
Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten
display flex
--
cgit v1.2.3
From 2741f47ef7b87255203bc2f7f7b2b9140c70b8f0 Mon Sep 17 00:00:00 2001
From: Joris
Date: Thu, 1 Nov 2018 13:14:25 +0100
Subject: Implementing client side validation
---
server/server.cabal | 5 ++-
server/src/Controller/Index.hs | 26 +++++++-------
server/src/Design/Form.hs | 10 ++++--
server/src/Design/Global.hs | 59 +++++++++++++++++++++++++++-----
server/src/Design/Modal.hs | 2 +-
server/src/Design/View/Header.hs | 2 ++
server/src/Design/View/Payment/Add.hs | 7 ++--
server/src/Design/View/Payment/Delete.hs | 3 ++
server/src/Validation/Atomic.hs | 2 +-
server/src/View/Page.hs | 3 ++
10 files changed, 87 insertions(+), 32 deletions(-)
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 644f57a..d6c4a9b 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -20,8 +20,8 @@ Executable server
OverloadedStrings
Build-depends:
- aeson
- , base >=4.9 && <5
+ aeson
+ , base >= 4.11 && < 5
, base64-bytestring
, blaze-builder
, blaze-html
@@ -32,7 +32,6 @@ Executable server
, config-manager
, containers
, cookie
- , email-validate
, filepath
, http-conduit
, http-types
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index 0b276d3..fbda527 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -9,18 +9,18 @@ import Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson as Json
import Data.Text (Text)
import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import Data.Time.Clock (diffUTCTime, getCurrentTime)
-import Network.HTTP.Types.Status (badRequest400, ok200)
+import qualified Network.HTTP.Types.Status as Status
import Prelude hiding (error)
import Web.Scotty (ActionM)
import qualified Web.Scotty as S
-import Common.Model (InitResult (..), SignIn (..),
- User (..))
+import Common.Model (Email (..), InitResult (..),
+ SignInForm (..), User (..))
import Common.Msg (Key)
import qualified Common.Msg as Msg
+import qualified Common.Validation.SignIn as SignInValidation
import Conf (Conf (..))
import qualified LoginSession
@@ -30,7 +30,6 @@ import qualified Persistence.Init as InitPersistence
import qualified Persistence.User as UserPersistence
import qualified Secure
import qualified SendMail
-import qualified Text.Email.Validate as Email
import qualified View.Mail.SignIn as SignIn
import View.Page (page)
@@ -45,10 +44,12 @@ get conf = do
liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf
S.html $ page initResult
-askSignIn :: Conf -> SignIn -> ActionM ()
-askSignIn conf (SignIn email) =
- if Email.isValid (TE.encodeUtf8 email)
- then do
+askSignIn :: Conf -> SignInForm -> ActionM ()
+askSignIn conf form =
+ case SignInValidation.signIn form of
+ Nothing ->
+ textKey Status.badRequest400 Msg.SignIn_EmailInvalid
+ Just (Email email) -> do
maybeUser <- liftIO . Query.run $ UserPersistence.get email
case maybeUser of
Just user -> do
@@ -62,9 +63,8 @@ askSignIn conf (SignIn email) =
maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email]
case maybeSentMail of
Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent)
- Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail
- Nothing -> textKey badRequest400 Msg.Secure_Unauthorized
- else textKey badRequest400 Msg.SignIn_EmailInvalid
+ Left _ -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail
+ Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized
where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key)
trySignIn :: Conf -> Text -> ActionM ()
@@ -116,4 +116,4 @@ getLoggedUser = do
liftIO . Query.run . Secure.getUserFromToken $ token
signOut :: Conf -> ActionM ()
-signOut conf = LoginSession.delete conf >> S.status ok200
+signOut conf = LoginSession.delete conf >> S.status Status.ok200
diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs
index 0385cb4..31a2127 100644
--- a/server/src/Design/Form.hs
+++ b/server/src/Design/Form.hs
@@ -22,7 +22,7 @@ design = do
".textInput" ? do
position relative
- marginBottom (em 1.5)
+ marginBottom (em 2)
paddingTop (px inputTop)
marginTop (px (-10))
@@ -46,7 +46,7 @@ design = do
position absolute
top (px inputTop)
left (px 0)
- transition "all" (sec 0.2) easeIn (sec 0)
+ transition "all" (sec 0.2) easeInOut (sec 0)
button ? do
position absolute
@@ -110,11 +110,13 @@ design = do
fontWeight bold
".selectInput" ? do
- marginBottom (em 1)
+ marginBottom (em 2)
+
label ? do
display block
marginBottom (px 10)
fontSize (pct 80)
+
select ? do
width (pct 100)
backgroundColor Color.white
@@ -122,6 +124,8 @@ design = do
sym borderRadius (px 3)
sym2 padding (px 5) (px 8)
option ? sym2 padding (px 5) (px 8)
+ focus & backgroundColor Color.wildSand
+
".error" & do
select ? borderColor Color.chestnutRose
".errorMessage" ? do
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index ba4ccb7..66e9f47 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -3,6 +3,7 @@ module Design.Global
) where
import Clay
+import Clay.Color as C
import Data.Text.Lazy (Text)
import qualified Design.Color as Color
@@ -26,8 +27,16 @@ global = do
Views.design
Form.design
+ spinKeyframes
+ appearKeyframe
+
+ html ? do
+ height (pct 100)
+
body ? do
+ position relative
minWidth (px 320)
+ height (pct 100)
fontFamily ["Cantarell"] [sansSerif]
".modal" &
overflowY hidden
@@ -40,6 +49,28 @@ global = do
button ? fontSize (px 14)
input ? fontSize (px 14)
+ ".app" ? do
+ appearAnimation
+
+ ".spinner" ? do
+ display flex
+ alignItems center
+ justifyContent center
+ width (pct 100)
+ height (pct 100)
+ paddingBottom (pct 10)
+
+ before & do
+ display block
+ content (stringContent "")
+ width (px 50)
+ height (px 50)
+ border solid (px 3) (C.setA 0.3 Color.chestnutRose)
+ sym borderRadius (pct 50)
+ borderTopColor Color.chestnutRose
+ spinKeyframes
+ spinAnimation
+
a ? cursor pointer
input ? fontSize inherit
@@ -87,21 +118,31 @@ global = do
opacity 0
svg # ".loader" ? do
opacity 1
- rotateKeyframes
- rotateAnimation
+ spinAnimation
select ? cursor pointer
-rotateAnimation :: Css
-rotateAnimation = do
+spinAnimation :: Css
+spinAnimation = do
animationName "rotate"
animationDuration (sec 1)
- animationTimingFunction easeOut
+ animationTimingFunction easeInOut
animationIterationCount infinite
-rotateKeyframes :: Css
-rotateKeyframes = keyframes
+spinKeyframes :: Css
+spinKeyframes = keyframes
"rotate"
- [ (0, "transform" -: "rotate(0deg)")
- , (100, "transform" -: "rotate(360deg)")
+ [ (100, "transform" -: "rotate(360deg)")
+ ]
+
+appearAnimation :: Css
+appearAnimation = do
+ animationName "appear"
+ animationDuration (sec 0.2)
+ animationTimingFunction easeIn
+
+appearKeyframe :: Css
+appearKeyframe = keyframes
+ "appear"
+ [ (0, "opacity" -: "0")
]
diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs
index 914c011..9c016b9 100644
--- a/server/src/Design/Modal.hs
+++ b/server/src/Design/Modal.hs
@@ -23,7 +23,7 @@ design = do
transition "all" (sec 0.2) ease (sec 0)
".modalContent" ? do
- minWidth (px 270)
+ minWidth (px 300)
position fixed
top (pct 25)
left (pct 50)
diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs
index 97f1802..2422686 100644
--- a/server/src/Design/View/Header.hs
+++ b/server/src/Design/View/Header.hs
@@ -56,6 +56,8 @@ design = do
".signOut" ? do
display flex
+ justifyContent center
+ alignItems center
svg ? do
Media.tabletDesktop $ width (px 30)
Media.mobile $ width (px 20)
diff --git a/server/src/Design/View/Payment/Add.hs b/server/src/Design/View/Payment/Add.hs
index 199ad36..5ecae7a 100644
--- a/server/src/Design/View/Payment/Add.hs
+++ b/server/src/Design/View/Payment/Add.hs
@@ -14,12 +14,12 @@ design = do
backgroundColor Color.chestnutRose
fontSize (px 18)
color Color.white
- sym padding (px 20)
+ sym2 padding (px 20) (px 30)
textAlign (alignSide sideCenter)
borderRadius (px 5) (px 5) (px 0) (px 0)
".addContent" ? do
- sym padding (px 20)
+ sym2 padding (px 20) (px 30)
".buttons" ? do
display flex
@@ -30,3 +30,6 @@ design = do
Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
".undo" ?
Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten
+
+ (".confirm" <> ".undo") ?
+ width (px 90)
diff --git a/server/src/Design/View/Payment/Delete.hs b/server/src/Design/View/Payment/Delete.hs
index 5597f5b..f3d7e3f 100644
--- a/server/src/Design/View/Payment/Delete.hs
+++ b/server/src/Design/View/Payment/Delete.hs
@@ -30,3 +30,6 @@ design = do
Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
".undo" ?
Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten
+
+ (".confirm" <> ".undo") ?
+ width (px 90)
diff --git a/server/src/Validation/Atomic.hs b/server/src/Validation/Atomic.hs
index d15ad49..7a7351a 100644
--- a/server/src/Validation/Atomic.hs
+++ b/server/src/Validation/Atomic.hs
@@ -19,7 +19,7 @@ nonNullNumber :: Int -> Maybe Text
nonNullNumber n =
if n == 0
then Just $ Msg.get Msg.Form_NonNullNumber
- else Nothing
+ else Nothing
-- number :: (Int -> Bool) -> Text -> Maybe Int
-- number numberForm str =
diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs
index 97b84fa..f47c544 100644
--- a/server/src/View/Page.hs
+++ b/server/src/View/Page.hs
@@ -31,6 +31,9 @@ page 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
+ H.body $ do
+ H.div ! A.class_ "spinner" $ ""
+
jsonScript :: Json.ToJSON a => Text -> a -> Html
jsonScript scriptId json =
--
cgit v1.2.3
From bc81084933f8ec1bfe6c2834defd12243117fdd9 Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 5 Aug 2019 21:53:30 +0200
Subject: Use updated payment categories from payment add in payment’s table
---
server/src/Controller/Payment.hs | 6 ++--
server/src/Persistence/PaymentCategory.hs | 48 ++++++++++++++++++++-----------
2 files changed, 35 insertions(+), 19 deletions(-)
(limited to 'server')
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index fb7fcb2..e82fd49 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -10,6 +10,7 @@ import qualified Network.HTTP.Types.Status as Status
import Web.Scotty
import Common.Model (CreatePayment (..),
+ CreatedPayment (..),
EditPayment (..), PaymentId,
User (..))
import qualified Model.Query as Query
@@ -30,8 +31,9 @@ create createPayment@(CreatePayment name cost date category frequency) =
case CreatePaymentValidation.validate createPayment of
Nothing ->
(liftIO . Query.run $ do
- PaymentCategoryPersistence.save name category
- PaymentPersistence.create (_user_id user) name cost date frequency
+ pc <- PaymentCategoryPersistence.save name category
+ p <- PaymentPersistence.create (_user_id user) name cost date frequency
+ return $ CreatedPayment p pc
) >>= json
Just validationError ->
do
diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs
index 1e377b1..1cfd702 100644
--- a/server/src/Persistence/PaymentCategory.hs
+++ b/server/src/Persistence/PaymentCategory.hs
@@ -4,7 +4,7 @@ module Persistence.PaymentCategory
, save
) where
-import Data.Maybe (isJust, listToMaybe)
+import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime)
@@ -40,27 +40,41 @@ listByCategory cat =
SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat)
)
-save :: Text -> CategoryId -> Query ()
+save :: Text -> CategoryId -> Query PaymentCategory
save newName categoryId =
Query (\conn -> do
now <- getCurrentTime
- hasPaymentCategory <- isJust <$> listToMaybe <$>
+ paymentCategory <- fmap (\(Row pc) -> pc) . Maybe.listToMaybe <$>
(SQLite.query
conn
"SELECT * FROM payment_category WHERE name = ?"
- (Only (formatPaymentName newName)) :: IO [Row])
- if hasPaymentCategory
- 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)
+ (Only formattedNewName))
+ case paymentCategory of
+ Just pc ->
+ do
+ SQLite.execute
+ conn
+ "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?"
+ (categoryId, now, formattedNewName)
+ return $ PaymentCategory
+ (_paymentCategory_id pc)
+ formattedNewName
+ categoryId
+ (_paymentCategory_createdAt pc)
+ (Just now)
+ Nothing ->
+ do
+ SQLite.execute
+ conn
+ "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)"
+ (formattedNewName, categoryId, now)
+ paymentCategoryId <- SQLite.lastInsertRowId conn
+ return $ PaymentCategory
+ paymentCategoryId
+ formattedNewName
+ categoryId
+ now
+ Nothing
)
where
- formatPaymentName :: Text -> Text
- formatPaymentName = T.unaccent . T.toLower
+ formattedNewName = T.unaccent . T.toLower $ newName
--
cgit v1.2.3
From fc8be14dd0089eb12b78af7aaaecd8ed57896677 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 7 Aug 2019 21:27:59 +0200
Subject: Update category according to payment in add overlay
---
server/src/Persistence/PaymentCategory.hs | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
(limited to 'server')
diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs
index 1cfd702..5fd035a 100644
--- a/server/src/Persistence/PaymentCategory.hs
+++ b/server/src/Persistence/PaymentCategory.hs
@@ -6,7 +6,6 @@ module Persistence.PaymentCategory
import qualified Data.Maybe as Maybe
import Data.Text (Text)
-import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
@@ -77,4 +76,4 @@ save newName categoryId =
Nothing
)
where
- formattedNewName = T.unaccent . T.toLower $ newName
+ formattedNewName = T.formatSearch newName
--
cgit v1.2.3
From fb8f0fe577e28dae69903413b761da50586e0099 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 10 Aug 2019 14:53:41 +0200
Subject: Remove payment category if unused after a payment is deleted
---
server/migrations/2.sql | 23 +++++++++++++++++++
server/src/Controller/Income.hs | 33 +++++++++++----------------
server/src/Controller/Payment.hs | 37 +++++++++++++++++++------------
server/src/Main.hs | 8 +++----
server/src/Persistence/Income.hs | 34 ++++++++++------------------
server/src/Persistence/Payment.hs | 34 +++++++++-------------------
server/src/Persistence/PaymentCategory.hs | 14 ++++++++++--
7 files changed, 98 insertions(+), 85 deletions(-)
create mode 100644 server/migrations/2.sql
(limited to 'server')
diff --git a/server/migrations/2.sql b/server/migrations/2.sql
new file mode 100644
index 0000000..1c829ec
--- /dev/null
+++ b/server/migrations/2.sql
@@ -0,0 +1,23 @@
+-- Add payment categories with accents from payment with accents
+
+INSERT INTO
+ payment_category (name, category, created_at)
+SELECT
+ DISTINCT lower(payment.name), payment_category.category, datetime('now')
+FROM
+ payment
+INNER JOIN
+ payment_category
+ON
+ replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(lower(payment.name), 'é', 'e'), 'è', 'e'), 'à', 'a'), 'û', 'u'), 'â', 'a'), 'ê', 'e'), 'â', 'a'), 'î', 'i'), 'ï', 'i'), 'ô', 'o'), 'ë', 'e') = payment_category.name
+WHERE
+ payment.name
+IN
+ (SELECT DISTINCT payment.name FROM payment WHERE lower(payment.name) NOT IN (SELECT payment_category.name FROM payment_category) AND payment.deleted_at IS NULL);
+
+-- Remove unused payment categories
+
+DELETE FROM
+ payment_category
+WHERE
+ name NOT IN (SELECT DISTINCT lower(name) FROM payment);
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index 3f623e5..ed58ac8 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -1,17 +1,15 @@
module Controller.Income
( create
- , editOwn
- , deleteOwn
+ , edit
+ , delete
) where
import Control.Monad.IO.Class (liftIO)
-import qualified Data.Text.Lazy as TL
-import Network.HTTP.Types.Status (badRequest400, ok200)
-import Web.Scotty
+import qualified Network.HTTP.Types.Status as Status
+import Web.Scotty hiding (delete)
import Common.Model (CreateIncome (..), EditIncome (..),
IncomeId, User (..))
-import qualified Common.Msg as Msg
import Json (jsonId)
import qualified Model.Query as Query
@@ -24,23 +22,18 @@ create (CreateIncome date amount) =
(liftIO . Query.run $ IncomePersistence.create (_user_id user) date amount) >>= jsonId
)
-editOwn :: EditIncome -> ActionM ()
-editOwn (EditIncome incomeId date amount) =
+edit :: EditIncome -> ActionM ()
+edit (EditIncome incomeId date amount) =
Secure.loggedAction (\user -> do
- updated <- liftIO . Query.run $ IncomePersistence.editOwn (_user_id user) incomeId date amount
+ updated <- liftIO . Query.run $ IncomePersistence.edit (_user_id user) incomeId date amount
if updated
- then status ok200
- else status badRequest400
+ then status Status.ok200
+ else status Status.badRequest400
)
-deleteOwn :: IncomeId -> ActionM ()
-deleteOwn incomeId =
+delete :: IncomeId -> ActionM ()
+delete incomeId =
Secure.loggedAction (\user -> do
- deleted <- liftIO . Query.run $ IncomePersistence.deleteOwn user incomeId
- if deleted
- then
- status ok200
- else do
- status badRequest400
- text . TL.fromStrict $ Msg.get Msg.Income_NotDeleted
+ _ <- liftIO . Query.run $ IncomePersistence.delete (_user_id user) incomeId
+ status Status.ok200
)
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index e82fd49..3d857be 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -1,18 +1,18 @@
module Controller.Payment
( list
, create
- , editOwn
- , deleteOwn
+ , edit
+ , delete
) where
import Control.Monad.IO.Class (liftIO)
import qualified Network.HTTP.Types.Status as Status
-import Web.Scotty
+import Web.Scotty hiding (delete)
import Common.Model (CreatePayment (..),
CreatedPayment (..),
- EditPayment (..), PaymentId,
- User (..))
+ EditPayment (..), Payment (..),
+ PaymentId, User (..))
import qualified Model.Query as Query
import qualified Persistence.Payment as PaymentPersistence
import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
@@ -41,11 +41,11 @@ create createPayment@(CreatePayment name cost date category frequency) =
json validationError
)
-editOwn :: EditPayment -> ActionM ()
-editOwn (EditPayment paymentId name cost date category frequency) =
+edit :: EditPayment -> ActionM ()
+edit (EditPayment paymentId name cost date category frequency) =
Secure.loggedAction (\user -> do
updated <- liftIO . Query.run $ do
- edited <- PaymentPersistence.editOwn (_user_id user) paymentId name cost date frequency
+ edited <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency
_ <- if edited
then PaymentCategoryPersistence.save name category >> return ()
else return ()
@@ -55,11 +55,20 @@ editOwn (EditPayment paymentId name cost date category frequency) =
else status Status.badRequest400
)
-deleteOwn :: PaymentId -> ActionM ()
-deleteOwn paymentId =
+delete :: PaymentId -> ActionM ()
+delete paymentId =
Secure.loggedAction (\user -> do
- deleted <- liftIO . Query.run $ PaymentPersistence.deleteOwn (_user_id user) paymentId
- if deleted
- then status Status.ok200
- else status Status.badRequest400
+ deleted <- liftIO . Query.run $ do
+ payment <- PaymentPersistence.find paymentId
+ case payment of
+ Just p | _payment_user p == _user_id user -> do
+ PaymentPersistence.delete (_user_id user) paymentId
+ PaymentCategoryPersistence.deleteIfUnused (_payment_name p)
+ return True
+ _ ->
+ return False
+ if deleted then
+ status Status.ok200
+ else
+ status Status.badRequest400
)
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 745071c..0ccf5e2 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -35,21 +35,21 @@ main = do
S.jsonData >>= Payment.create
S.put "/payment" $
- S.jsonData >>= Payment.editOwn
+ S.jsonData >>= Payment.edit
S.delete "/payment/:id" $ do
paymentId <- S.param "id"
- Payment.deleteOwn paymentId
+ Payment.delete paymentId
S.post "/income" $
S.jsonData >>= Income.create
S.put "/income" $
- S.jsonData >>= Income.editOwn
+ S.jsonData >>= Income.edit
S.delete "/income/:id" $ do
incomeId <- S.param "id"
- Income.deleteOwn incomeId
+ Income.delete incomeId
S.post "/category" $
S.jsonData >>= Category.create
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
index a863f85..cee9892 100644
--- a/server/src/Persistence/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -1,8 +1,8 @@
module Persistence.Income
( list
, create
- , editOwn
- , deleteOwn
+ , edit
+ , delete
) where
import Data.Maybe (listToMaybe)
@@ -12,7 +12,7 @@ import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
import Prelude hiding (id)
-import Common.Model (Income (..), IncomeId, User (..),
+import Common.Model (Income (..), IncomeId, PaymentId,
UserId)
import Model.Query (Query (Query))
@@ -47,8 +47,8 @@ create incomeUserId incomeDate incomeAmount =
SQLite.lastInsertRowId conn
)
-editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool
-editOwn incomeUserId incomeId incomeDate incomeAmount =
+edit :: UserId -> IncomeId -> Day -> Int -> Query Bool
+edit incomeUserId incomeId incomeDate incomeAmount =
Query (\conn -> do
mbIncome <- fmap (\(Row i) -> i) . listToMaybe <$>
SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId)
@@ -68,21 +68,11 @@ editOwn incomeUserId incomeId incomeDate incomeAmount =
return False
)
-deleteOwn :: User -> IncomeId -> Query Bool
-deleteOwn user incomeId =
- Query (\conn -> do
- mbIncome <-
- fmap (\(Row i) -> i) . 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
+delete :: UserId -> PaymentId -> Query ()
+delete userId paymentId =
+ Query (\conn ->
+ SQLite.execute
+ conn
+ "UPDATE income SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?"
+ (paymentId, userId)
)
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index 272cd39..3d8f129 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -6,8 +6,8 @@ module Persistence.Payment
, listActiveMonthlyOrderedByName
, create
, createMany
- , editOwn
- , deleteOwn
+ , edit
+ , delete
) where
import Data.Maybe (listToMaybe)
@@ -129,8 +129,8 @@ createMany payments =
(map InsertRow payments)
)
-editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool
-editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency =
+edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool
+edit userId paymentId paymentName paymentCost paymentDate paymentFrequency =
Query (\conn -> do
mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$>
SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
@@ -158,23 +158,11 @@ editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency =
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 (Row 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
+delete :: UserId -> PaymentId -> Query ()
+delete userId paymentId =
+ Query (\conn ->
+ SQLite.execute
+ conn
+ "UPDATE payment SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?"
+ (paymentId, userId)
)
diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs
index 5fd035a..7dc363c 100644
--- a/server/src/Persistence/PaymentCategory.hs
+++ b/server/src/Persistence/PaymentCategory.hs
@@ -2,16 +2,17 @@ module Persistence.PaymentCategory
( list
, listByCategory
, save
+ , deleteIfUnused
) where
import qualified Data.Maybe as Maybe
import Data.Text (Text)
+import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
import Common.Model (CategoryId, PaymentCategory (..))
-import qualified Common.Util.Text as T
import Model.Query (Query (Query))
@@ -76,4 +77,13 @@ save newName categoryId =
Nothing
)
where
- formattedNewName = T.formatSearch newName
+ formattedNewName = T.toLower newName
+
+deleteIfUnused :: Text -> Query ()
+deleteIfUnused name =
+ Query (\conn ->
+ SQLite.execute
+ conn
+ "DELETE FROM payment_category WHERE name = lower(?) AND name IN (SELECT DISTINCT lower(name) FROM payment WHERE name = lower(?) AND deleted_at IS NOT NULL)"
+ (name, name)
+ ) >> return ()
--
cgit v1.2.3
From 234b5b29361734656dc780148309962f932d9907 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 10 Aug 2019 15:07:11 +0200
Subject: Use select component in payment search line
---
server/src/Design/View/Payment/Header.hs | 6 ++----
1 file changed, 2 insertions(+), 4 deletions(-)
(limited to 'server')
diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs
index 0cb5b5d..9111374 100644
--- a/server/src/Design/View/Payment/Header.hs
+++ b/server/src/Design/View/Payment/Header.hs
@@ -59,10 +59,8 @@ design = do
marginBottom (em 1)
width (pct 100)
- ".radioGroup" ? do
- display inlineBlock
- marginBottom (px 0)
- ".title" ? display none
+ ".selectInput" ? do
+ Media.tabletDesktop $ display inlineBlock
".infos" ? do
Media.tabletDesktop $ lineHeight (px Constants.inputHeight)
--
cgit v1.2.3
From c542424b7b41c78a170763f6996c12f56b359860 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 10 Aug 2019 21:31:27 +0200
Subject: Add smooth transitions to modal show and hide
---
server/server.cabal | 1 +
server/src/Design/Form.hs | 33 +--------------------------------
server/src/Design/Global.hs | 7 ++++---
server/src/Design/Modal.hs | 39 ++++++++++++++++++++++++++++++++-------
4 files changed, 38 insertions(+), 42 deletions(-)
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index d6c4a9b..3bc8e42 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -16,6 +16,7 @@ Executable server
Default-extensions:
ExistentialQuantification
+ LambdaCase
MultiParamTypeClasses
OverloadedStrings
diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs
index 31a2127..0f236f7 100644
--- a/server/src/Design/Form.hs
+++ b/server/src/Design/Form.hs
@@ -14,7 +14,6 @@ design = do
let inputHeight = 30
let inputTop = 22
let inputPaddingBottom = 3
- let inputZIndex = 1
label ? do
cursor pointer
@@ -29,9 +28,9 @@ design = do
input ? do
width (pct 100)
position relative
- zIndex inputZIndex
backgroundColor transparent
paddingBottom (px inputPaddingBottom)
+ paddingRight (px 14) -- Space for the delete icon
borderStyle none
borderBottom solid (px 1) Color.dustyGray
marginBottom (px 5)
@@ -52,7 +51,6 @@ design = do
position absolute
right (px 0)
top (px 27)
- zIndex inputZIndex
svg ? "path" ?
("fill" -: Color.toString Color.silver)
hover & svg ? "path" ?
@@ -80,35 +78,6 @@ design = 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
marginBottom (em 2)
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index 66e9f47..24d999f 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -22,7 +22,7 @@ globalDesign = renderWith compact [] global
global :: Css
global = do
".errors" ? Errors.design
- ".modal" ? Modal.design
+ Modal.design
".tooltip" ? Tooltip.design
Views.design
Form.design
@@ -33,13 +33,14 @@ global = do
html ? do
height (pct 100)
+ "g-Body--Modal" ?
+ overflowY hidden
+
body ? do
position relative
minWidth (px 320)
height (pct 100)
fontFamily ["Cantarell"] [sansSerif]
- ".modal" &
- overflowY hidden
Media.tablet $ do
fontSize (px 15)
button ? fontSize (px 15)
diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs
index 9c016b9..dce2ef9 100644
--- a/server/src/Design/Modal.hs
+++ b/server/src/Design/Modal.hs
@@ -11,24 +11,37 @@ import qualified Design.View.Payment.Delete as Delete
design :: Css
design = do
- ".modalCurtain" ? do
+ appearKeyframe
+
+ ".g-Modal" ? do
+ appearAnimation
+ transition "all" (sec 0.2) ease (sec 0)
+ display none
+ opacity 0
+
+ ".g-Modal--Show" & do
+ display block
+ opacity 1
+
+ ".g-Modal--Hiding" & do
+ display block
+
+ ".g-Modal__Curtain" ? do
position fixed
top (px 0)
left (px 0)
width (pct 100)
height (pct 100)
- backgroundColor (rgba 0 0 0 0.7)
- zIndex 1000
- opacity 1
- transition "all" (sec 0.2) ease (sec 0)
+ backgroundColor (rgba 0 0 0 0.6)
+ zIndex 1
- ".modalContent" ? do
+ ".g-Modal__Content" ? do
minWidth (px 300)
position fixed
top (pct 25)
left (pct 50)
"transform" -: "translate(-50%, -25%)"
- zIndex 1000
+ zIndex 1
backgroundColor white
sym borderRadius (px 5)
boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15)
@@ -44,3 +57,15 @@ design = do
".deletePaymentModal" <> ".deleteIncomeModal" ? do
h1 ? marginBottom (em 1.5)
+
+appearAnimation :: Css
+appearAnimation = do
+ animationName "appear"
+ animationDuration (sec 0.15)
+ animationTimingFunction easeIn
+
+appearKeyframe :: Css
+appearKeyframe = keyframes
+ "appear"
+ [ (0, "opacity" -: "0")
+ ]
--
cgit v1.2.3
From 2d79ab0e0a11f55255fc21a5dfab1598d3beeba3 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 11 Aug 2019 22:40:09 +0200
Subject: Add payment clone
---
server/server.cabal | 1 +
server/src/Controller/Payment.hs | 29 ++++++++-------
server/src/Design/Modal.hs | 4 ++-
server/src/Design/View/Payment/Form.hs | 35 ++++++++++++++++++
server/src/Persistence/Payment.hs | 66 ++++++++++++++++++++++------------
5 files changed, 99 insertions(+), 36 deletions(-)
create mode 100644 server/src/Design/View/Payment/Form.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 3bc8e42..3c1c770 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -74,6 +74,7 @@ Executable server
Design.View.Payment
Design.View.Payment.Add
Design.View.Payment.Delete
+ Design.View.Payment.Form
Design.View.Payment.Header
Design.View.Payment.Pages
Design.View.Payment.Table
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index 3d857be..c700240 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -10,9 +10,9 @@ import qualified Network.HTTP.Types.Status as Status
import Web.Scotty hiding (delete)
import Common.Model (CreatePayment (..),
- CreatedPayment (..),
EditPayment (..), Payment (..),
- PaymentId, User (..))
+ PaymentId, SavedPayment (..),
+ User (..))
import qualified Model.Query as Query
import qualified Persistence.Payment as PaymentPersistence
import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
@@ -33,7 +33,7 @@ create createPayment@(CreatePayment name cost date category frequency) =
(liftIO . Query.run $ do
pc <- PaymentCategoryPersistence.save name category
p <- PaymentPersistence.create (_user_id user) name cost date frequency
- return $ CreatedPayment p pc
+ return $ SavedPayment p pc
) >>= json
Just validationError ->
do
@@ -44,15 +44,20 @@ create createPayment@(CreatePayment name cost date category frequency) =
edit :: EditPayment -> ActionM ()
edit (EditPayment paymentId name cost date category frequency) =
Secure.loggedAction (\user -> do
- updated <- liftIO . Query.run $ do
- edited <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency
- _ <- if edited
- then PaymentCategoryPersistence.save name category >> return ()
- else return ()
- return edited
- if updated
- then status Status.ok200
- else status Status.badRequest400
+ result <- liftIO . Query.run $ do
+ editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency
+ case editedPayment of
+ Just p -> do
+ pc <- PaymentCategoryPersistence.save name category
+ PaymentCategoryPersistence.deleteIfUnused name
+ return $ Just (p, pc)
+ Nothing ->
+ return Nothing
+ case result of
+ Just (p, pc) ->
+ json $ SavedPayment p pc
+ Nothing ->
+ status Status.badRequest400
)
delete :: PaymentId -> ActionM ()
diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs
index dce2ef9..4020eb0 100644
--- a/server/src/Design/Modal.hs
+++ b/server/src/Design/Modal.hs
@@ -7,6 +7,7 @@ import Data.Monoid ((<>))
import qualified Design.View.Payment.Add as Add
import qualified Design.View.Payment.Delete as Delete
+import qualified Design.View.Payment.Form as Form
design :: Css
design = do
@@ -14,9 +15,9 @@ design = do
appearKeyframe
".g-Modal" ? do
+ display none
appearAnimation
transition "all" (sec 0.2) ease (sec 0)
- display none
opacity 0
".g-Modal--Show" & do
@@ -47,6 +48,7 @@ design = do
boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15)
".add" ? Add.design
+ ".form" ? Form.design
".delete" ? Delete.design
".paymentModal" & do
diff --git a/server/src/Design/View/Payment/Form.hs b/server/src/Design/View/Payment/Form.hs
new file mode 100644
index 0000000..aada12b
--- /dev/null
+++ b/server/src/Design/View/Payment/Form.hs
@@ -0,0 +1,35 @@
+module Design.View.Payment.Form
+ ( design
+ ) where
+
+import Clay
+
+import qualified Design.Color as Color
+import qualified Design.Constants as Constants
+import qualified Design.Helper as Helper
+
+design :: Css
+design = do
+ ".formHeader" ? do
+ backgroundColor Color.chestnutRose
+ fontSize (px 18)
+ color Color.white
+ sym2 padding (px 20) (px 30)
+ textAlign (alignSide sideCenter)
+ borderRadius (px 5) (px 5) (px 0) (px 0)
+
+ ".formContent" ? do
+ sym2 padding (px 20) (px 30)
+
+ ".buttons" ? do
+ display flex
+ justifyContent spaceAround
+ marginTop (em 1.5)
+
+ ".confirm" ?
+ Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
+ ".undo" ?
+ Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten
+
+ (".confirm" <> ".undo") ?
+ width (px 90)
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index 3d8f129..b3f2b2e 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -129,33 +129,53 @@ createMany payments =
(map InsertRow payments)
)
-edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool
-edit userId paymentId paymentName paymentCost paymentDate paymentFrequency =
+edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe Payment)
+edit userId paymentId name cost date frequency =
Query (\conn -> do
mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$>
- SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
+ SQLite.query
+ conn
+ "SELECT * FROM payment WHERE id = ? and userId = ?"
+ (paymentId, userId)
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, FrequencyField paymentFrequency, paymentId)
- return True
- else
- return False
+ Just payment -> do
+ now <- getCurrentTime
+ SQLite.execute
+ conn
+ (SQLite.Query $ T.intercalate " "
+ [ "UPDATE"
+ , " payment"
+ , "SET"
+ , " edited_at = ?,"
+ , " name = ?,"
+ , " cost = ?,"
+ , " date = ?,"
+ , " frequency = ?"
+ , "WHERE"
+ , " id = ?"
+ , " AND user_id = ?"
+ ])
+ ( now
+ , name
+ , cost
+ , date
+ , FrequencyField frequency
+ , paymentId
+ , userId
+ )
+ return . Just $ Payment
+ { _payment_id = paymentId
+ , _payment_user = userId
+ , _payment_name = name
+ , _payment_cost = cost
+ , _payment_date = date
+ , _payment_frequency = frequency
+ , _payment_createdAt = _payment_createdAt payment
+ , _payment_editedAt = Just now
+ , _payment_deletedAt = Nothing
+ }
Nothing ->
- return False
+ return Nothing
)
delete :: UserId -> PaymentId -> Query ()
--
cgit v1.2.3
From f4c5df9e1b1afddeb5a482d4fbe654d0b321159c Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 6 Oct 2019 19:28:54 +0200
Subject: Make payment edition to work on the frontend
---
server/src/Controller/Payment.hs | 6 +++---
server/src/Persistence/Payment.hs | 6 +++---
server/src/Persistence/PaymentCategory.hs | 2 +-
3 files changed, 7 insertions(+), 7 deletions(-)
(limited to 'server')
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index c700240..38c1c19 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -47,10 +47,10 @@ edit (EditPayment paymentId name cost date category frequency) =
result <- liftIO . Query.run $ do
editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency
case editedPayment of
- Just p -> do
+ Just (old, new) -> do
pc <- PaymentCategoryPersistence.save name category
- PaymentCategoryPersistence.deleteIfUnused name
- return $ Just (p, pc)
+ PaymentCategoryPersistence.deleteIfUnused (_payment_name old)
+ return $ Just (new, pc)
Nothing ->
return Nothing
case result of
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index b3f2b2e..bcd7eb8 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -129,13 +129,13 @@ createMany payments =
(map InsertRow payments)
)
-edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe Payment)
+edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe (Payment, Payment))
edit userId paymentId name cost date frequency =
Query (\conn -> do
mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$>
SQLite.query
conn
- "SELECT * FROM payment WHERE id = ? and userId = ?"
+ "SELECT * FROM payment WHERE id = ? and user_id = ?"
(paymentId, userId)
case mbPayment of
Just payment -> do
@@ -163,7 +163,7 @@ edit userId paymentId name cost date frequency =
, paymentId
, userId
)
- return . Just $ Payment
+ return . Just . (,) payment $ Payment
{ _payment_id = paymentId
, _payment_user = userId
, _payment_name = name
diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs
index 7dc363c..46be7f5 100644
--- a/server/src/Persistence/PaymentCategory.hs
+++ b/server/src/Persistence/PaymentCategory.hs
@@ -84,6 +84,6 @@ deleteIfUnused name =
Query (\conn ->
SQLite.execute
conn
- "DELETE FROM payment_category WHERE name = lower(?) AND name IN (SELECT DISTINCT lower(name) FROM payment WHERE name = lower(?) AND deleted_at IS NOT NULL)"
+ "DELETE FROM payment_category WHERE name = lower(?) AND name NOT IN (SELECT DISTINCT lower(name) FROM payment WHERE lower(name) = lower(?) AND deleted_at IS NULL)"
(name, name)
) >> return ()
--
cgit v1.2.3
From 2cbd43c3a0f0640776a4e7c7425b3210d2e6632b Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 6 Oct 2019 19:41:17 +0200
Subject: Make input label clickable again
---
server/src/Design/Form.hs | 13 ++++++-------
1 file changed, 6 insertions(+), 7 deletions(-)
(limited to 'server')
diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs
index 0f236f7..506343d 100644
--- a/server/src/Design/Form.hs
+++ b/server/src/Design/Form.hs
@@ -15,10 +15,6 @@ design = do
let inputTop = 22
let inputPaddingBottom = 3
- label ? do
- cursor pointer
- color Color.silver
-
".textInput" ? do
position relative
marginBottom (em 2)
@@ -40,7 +36,9 @@ design = do
borderWidth (px 2)
paddingBottom (px $ inputPaddingBottom - 1)
- label ? do
+ ".label" ? do
+ zIndex (-1)
+ color Color.silver
lineHeight (px inputHeight)
position absolute
top (px inputTop)
@@ -56,7 +54,7 @@ design = do
hover & svg ? "path" ?
("fill" -: Color.toString (Color.silver -. 25))
- (input # ".filled" |+ label) <> (input # focus |+ label) ? do
+ (input # ".filled" |+ ".label") <> (input # focus |+ ".label") ? do
top (px 0)
fontSize (pct 80)
@@ -81,7 +79,8 @@ design = do
".selectInput" ? do
marginBottom (em 2)
- label ? do
+ ".label" ? do
+ color Color.silver
display block
marginBottom (px 10)
fontSize (pct 80)
--
cgit v1.2.3
From 7529a18ff0ac443e7f9764b5e2d0f57a5d3a850b Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 9 Oct 2019 23:16:00 +0200
Subject: Use common payment validation in the backend
Remove deprecated backend validation
---
server/server.cabal | 7 +++-
server/src/Controller/Helper.hs | 17 ++++++++
server/src/Controller/Payment.hs | 73 +++++++++++++++++++---------------
server/src/Model/CreatePayment.hs | 16 ++++++++
server/src/Model/EditPayment.hs | 17 ++++++++
server/src/Validation/Atomic.hs | 32 ---------------
server/src/Validation/CreatePayment.hs | 25 ------------
server/src/Validation/Payment.hs | 33 +++++++++++++++
8 files changed, 128 insertions(+), 92 deletions(-)
create mode 100644 server/src/Controller/Helper.hs
create mode 100644 server/src/Model/CreatePayment.hs
create mode 100644 server/src/Model/EditPayment.hs
delete mode 100644 server/src/Validation/Atomic.hs
delete mode 100644 server/src/Validation/CreatePayment.hs
create mode 100644 server/src/Validation/Payment.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 3c1c770..ea7ebed 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -50,6 +50,7 @@ Executable server
, transformers
, unordered-containers
, uuid
+ , validation
, wai
, wai-extra
, wai-middleware-static
@@ -57,6 +58,7 @@ Executable server
other-modules:
Conf
Controller.Category
+ Controller.Helper
Controller.Income
Controller.Index
Controller.Payment
@@ -90,6 +92,8 @@ Executable server
Job.WeeklyReport
Json
LoginSession
+ Model.CreatePayment
+ Model.EditPayment
Model.IncomeResource
Model.Mail
Model.PaymentResource
@@ -107,8 +111,7 @@ Executable server
Secure
SendMail
Util.Time
- Validation.Atomic
- Validation.CreatePayment
+ Validation.Payment
View.Mail.SignIn
View.Mail.WeeklyReport
View.Page
diff --git a/server/src/Controller/Helper.hs b/server/src/Controller/Helper.hs
new file mode 100644
index 0000000..fd0d2bb
--- /dev/null
+++ b/server/src/Controller/Helper.hs
@@ -0,0 +1,17 @@
+module Controller.Helper
+ ( jsonOrBadRequest
+ ) where
+
+import Data.Aeson (ToJSON)
+import Data.Text (Text)
+import qualified Data.Text.Lazy as LT
+import qualified Network.HTTP.Types.Status as Status
+import Web.Scotty (ActionM)
+import qualified Web.Scotty as S
+
+jsonOrBadRequest :: forall a. (ToJSON a) => Either Text a -> ActionM ()
+jsonOrBadRequest (Left message) = do
+ S.status Status.badRequest400
+ S.text (LT.fromStrict message)
+jsonOrBadRequest (Right a) =
+ S.json a
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index 38c1c19..ba9d1ba 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -6,18 +6,25 @@ module Controller.Payment
) where
import Control.Monad.IO.Class (liftIO)
+import Data.Validation (Validation (Failure, Success))
import qualified Network.HTTP.Types.Status as Status
import Web.Scotty hiding (delete)
-import Common.Model (CreatePayment (..),
- EditPayment (..), Payment (..),
- PaymentId, SavedPayment (..),
- User (..))
+import Common.Model (Category (..),
+ CreatePaymentForm (..),
+ EditPaymentForm (..),
+ Payment (..), PaymentId,
+ SavedPayment (..), User (..))
+import qualified Common.Msg as Msg
+import qualified Controller.Helper as ControllerHelper
+import Model.CreatePayment (CreatePayment (..))
+import Model.EditPayment (EditPayment (..))
import qualified Model.Query as Query
+import qualified Persistence.Category as CategoryPersistence
import qualified Persistence.Payment as PaymentPersistence
import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
import qualified Secure
-import qualified Validation.CreatePayment as CreatePaymentValidation
+import qualified Validation.Payment as PaymentValidation
list :: ActionM ()
list =
@@ -25,39 +32,39 @@ list =
(liftIO . Query.run $ PaymentPersistence.listActive) >>= json
)
-create :: CreatePayment -> ActionM ()
-create createPayment@(CreatePayment name cost date category frequency) =
+create :: CreatePaymentForm -> ActionM ()
+create form =
Secure.loggedAction (\user ->
- case CreatePaymentValidation.validate createPayment of
- Nothing ->
- (liftIO . Query.run $ do
+ (liftIO . Query.run $ do
+ cs <- map _category_id <$> CategoryPersistence.list
+ case PaymentValidation.createPayment cs form of
+ Success (CreatePayment name cost date category frequency) -> do
pc <- PaymentCategoryPersistence.save name category
p <- PaymentPersistence.create (_user_id user) name cost date frequency
- return $ SavedPayment p pc
- ) >>= json
- Just validationError ->
- do
- status Status.badRequest400
- json validationError
+ return . Right $ SavedPayment p pc
+ Failure validationError ->
+ return $ Left validationError
+ ) >>= ControllerHelper.jsonOrBadRequest
)
-edit :: EditPayment -> ActionM ()
-edit (EditPayment paymentId name cost date category frequency) =
- Secure.loggedAction (\user -> do
- result <- liftIO . Query.run $ do
- editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency
- case editedPayment of
- Just (old, new) -> do
- pc <- PaymentCategoryPersistence.save name category
- PaymentCategoryPersistence.deleteIfUnused (_payment_name old)
- return $ Just (new, pc)
- Nothing ->
- return Nothing
- case result of
- Just (p, pc) ->
- json $ SavedPayment p pc
- Nothing ->
- status Status.badRequest400
+edit :: EditPaymentForm -> ActionM ()
+edit form =
+ Secure.loggedAction (\user ->
+ (liftIO . Query.run $ do
+ cs <- map _category_id <$> CategoryPersistence.list
+ case PaymentValidation.editPayment cs form of
+ Success (EditPayment paymentId name cost date category frequency) -> do
+ editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency
+ case editedPayment of
+ Just (old, new) -> do
+ pc <- PaymentCategoryPersistence.save name category
+ PaymentCategoryPersistence.deleteIfUnused (_payment_name old)
+ return . Right $ SavedPayment new pc
+ Nothing ->
+ return . Left $ Msg.get Msg.Error_PaymentEdit
+ Failure validationError ->
+ return $ Left validationError
+ ) >>= ControllerHelper.jsonOrBadRequest
)
delete :: PaymentId -> ActionM ()
diff --git a/server/src/Model/CreatePayment.hs b/server/src/Model/CreatePayment.hs
new file mode 100644
index 0000000..b25d2a4
--- /dev/null
+++ b/server/src/Model/CreatePayment.hs
@@ -0,0 +1,16 @@
+module Model.CreatePayment
+ ( CreatePayment(..)
+ ) where
+
+import Data.Text (Text)
+import Data.Time.Calendar (Day)
+
+import Common.Model (CategoryId, Frequency)
+
+data CreatePayment = CreatePayment
+ { _createPayment_name :: Text
+ , _createPayment_cost :: Int
+ , _createPayment_date :: Day
+ , _createPayment_category :: CategoryId
+ , _createPayment_frequency :: Frequency
+ } deriving (Show)
diff --git a/server/src/Model/EditPayment.hs b/server/src/Model/EditPayment.hs
new file mode 100644
index 0000000..ac4c906
--- /dev/null
+++ b/server/src/Model/EditPayment.hs
@@ -0,0 +1,17 @@
+module Model.EditPayment
+ ( EditPayment(..)
+ ) where
+
+import Data.Text (Text)
+import Data.Time.Calendar (Day)
+
+import Common.Model (CategoryId, Frequency, PaymentId)
+
+data EditPayment = EditPayment
+ { _editPayment_id :: PaymentId
+ , _editPayment_name :: Text
+ , _editPayment_cost :: Int
+ , _editPayment_date :: Day
+ , _editPayment_category :: CategoryId
+ , _editPayment_frequency :: Frequency
+ } deriving (Show)
diff --git a/server/src/Validation/Atomic.hs b/server/src/Validation/Atomic.hs
deleted file mode 100644
index 7a7351a..0000000
--- a/server/src/Validation/Atomic.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module Validation.Atomic
- ( nonEmpty
- , nonNullNumber
- -- , number
- ) where
-
-import Data.Text (Text)
-import qualified Data.Text as T
-
-import qualified Common.Msg as Msg
-
-nonEmpty :: Text -> Maybe Text
-nonEmpty str =
- if T.null str
- then Just $ Msg.get Msg.Form_NonEmpty
- else Nothing
-
-nonNullNumber :: Int -> Maybe Text
-nonNullNumber n =
- if n == 0
- then Just $ Msg.get Msg.Form_NonNullNumber
- else Nothing
-
--- 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/Validation/CreatePayment.hs b/server/src/Validation/CreatePayment.hs
deleted file mode 100644
index fbcdb7c..0000000
--- a/server/src/Validation/CreatePayment.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module Validation.CreatePayment
- ( validate
- ) where
-
-import Data.Maybe (catMaybes)
-
-import Common.Model.CreatePayment (CreatePayment (..),
- CreatePaymentError (..))
-import qualified Validation.Atomic as Atomic
-
-validate :: CreatePayment -> Maybe CreatePaymentError
-validate p =
- if not . null . catMaybes $ [ nameError, costError ]
- then Just createPaymentError
- else Nothing
- where
- nameError = Atomic.nonEmpty . _createPayment_name $ p
- costError = Atomic.nonNullNumber . _createPayment_cost $ p
- createPaymentError = CreatePaymentError
- { _createPaymentError_name = nameError
- , _createPaymentError_cost = costError
- , _createPaymentError_date = Nothing
- , _createPaymentError_category = Nothing
- , _createPaymentError_frequency = Nothing
- }
diff --git a/server/src/Validation/Payment.hs b/server/src/Validation/Payment.hs
new file mode 100644
index 0000000..20e370e
--- /dev/null
+++ b/server/src/Validation/Payment.hs
@@ -0,0 +1,33 @@
+module Validation.Payment
+ ( createPayment
+ , editPayment
+ ) where
+
+import Data.Text (Text)
+import Data.Validation (Validation)
+import qualified Data.Validation as V
+
+import Common.Model (CategoryId, CreatePaymentForm (..),
+ EditPaymentForm (..))
+import qualified Common.Validation.Payment as PaymentValidation
+import Model.CreatePayment (CreatePayment (..))
+import Model.EditPayment (EditPayment (..))
+
+createPayment :: [CategoryId] -> CreatePaymentForm -> Validation Text CreatePayment
+createPayment categories form =
+ CreatePayment
+ <$> PaymentValidation.name (_createPaymentForm_name form)
+ <*> PaymentValidation.cost (_createPaymentForm_cost form)
+ <*> PaymentValidation.date (_createPaymentForm_date form)
+ <*> PaymentValidation.category categories (_createPaymentForm_category form)
+ <*> V.Success (_createPaymentForm_frequency form)
+
+editPayment :: [CategoryId] -> EditPaymentForm -> Validation Text EditPayment
+editPayment categories form =
+ EditPayment
+ <$> V.Success (_editPaymentForm_id form)
+ <*> PaymentValidation.name (_editPaymentForm_name form)
+ <*> PaymentValidation.cost (_editPaymentForm_cost form)
+ <*> PaymentValidation.date (_editPaymentForm_date form)
+ <*> PaymentValidation.category categories (_editPaymentForm_category form)
+ <*> V.Success (_editPaymentForm_frequency form)
--
cgit v1.2.3
From 52331eeadce8d250564851c25fc965172640bc55 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 12 Oct 2019 11:23:10 +0200
Subject: Implement client routing
---
server/server.cabal | 1 +
server/src/Controller/Index.hs | 2 +-
server/src/Design/View/Header.hs | 7 +++++--
server/src/Design/View/NotFound.hs | 21 +++++++++++++++++++++
server/src/Design/Views.hs | 21 +++++++++++----------
server/src/Main.hs | 36 ++++++++++++++++++++----------------
6 files changed, 59 insertions(+), 29 deletions(-)
create mode 100644 server/src/Design/View/NotFound.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index ea7ebed..75af442 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -73,6 +73,7 @@ Executable server
Design.Modal
Design.Tooltip
Design.View.Header
+ Design.View.NotFound
Design.View.Payment
Design.View.Payment.Add
Design.View.Payment.Delete
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index fbda527..5ebe921 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -57,7 +57,7 @@ askSignIn conf form =
let url = T.concat [
if Conf.https conf then "https://" else "http://",
Conf.hostname conf,
- "/signIn/",
+ "/api/signIn/",
token
]
maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email]
diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs
index 2422686..59e0e51 100644
--- a/server/src/Design/View/Header.hs
+++ b/server/src/Design/View/Header.hs
@@ -40,8 +40,11 @@ design = do
".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)
+ (".item" # hover) <> (".item" # focus) ?
+ backgroundColor (Color.chestnutRose +. 10)
+
+ (".item.current" # hover) <> (".item.current" # focus) ?
+ backgroundColor (Color.chestnutRose -. 10)
".nameSignOut" ? do
display flex
diff --git a/server/src/Design/View/NotFound.hs b/server/src/Design/View/NotFound.hs
new file mode 100644
index 0000000..150c6fc
--- /dev/null
+++ b/server/src/Design/View/NotFound.hs
@@ -0,0 +1,21 @@
+module Design.View.NotFound
+ ( design
+ ) where
+
+import Clay
+import Prelude hiding (rem)
+
+import qualified Design.Color as Color
+
+design :: Css
+design = do
+
+ marginLeft (rem 3)
+
+ ".link" ? do
+ display block
+ marginTop (rem 1)
+ color Color.chestnutRose
+ textDecoration underline
+ hover &
+ color (Color.chestnutRose +. 15)
diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs
index b9e3cf8..bf39cff 100644
--- a/server/src/Design/Views.hs
+++ b/server/src/Design/Views.hs
@@ -4,16 +4,16 @@ module Design.Views
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.Color as Color
-import qualified Design.Constants as Constants
-import qualified Design.Helper as Helper
-import qualified Design.Media as Media
+import qualified Design.Color as Color
+import qualified Design.Constants as Constants
+import qualified Design.Helper as Helper
+import qualified Design.Media as Media
+import qualified Design.View.Header as Header
+import qualified Design.View.NotFound as NotFound
+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
design :: Css
design = do
@@ -21,6 +21,7 @@ design = do
".payment" ? Payment.design
".signIn" ? SignIn.design
".stat" ? Stat.design
+ ".notfound" ? NotFound.design
Table.design
".withMargin" ? do
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 0ccf5e2..e3dad9e 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -15,48 +15,52 @@ main = do
conf <- Conf.get "application.conf"
_ <- runDaemons conf
S.scotty (Conf.port conf) $ do
- S.middleware $ W.gzip $ W.def { W.gzipFiles = GzipCompress }
- S.middleware . staticPolicy $ noDots >-> addBase "public"
- S.get "/" $ do
- Index.get conf
+ S.middleware $
+ W.gzip $ W.def { W.gzipFiles = GzipCompress }
+
+ S.middleware . staticPolicy $
+ noDots >-> addBase "public"
- S.post "/askSignIn" $ do
+ S.post "/api/askSignIn" $
S.jsonData >>= Index.askSignIn conf
- S.get "/signIn/:signInToken" $ do
+ S.get "/api/signIn/:signInToken" $ do
signInToken <- S.param "signInToken"
Index.trySignIn conf signInToken
- S.post "/signOut" $
+ S.post "/api/signOut" $
Index.signOut conf
- S.post "/payment" $
+ S.post "/api/payment" $
S.jsonData >>= Payment.create
- S.put "/payment" $
+ S.put "/api/payment" $
S.jsonData >>= Payment.edit
- S.delete "/payment/:id" $ do
+ S.delete "/api/payment/:id" $ do
paymentId <- S.param "id"
Payment.delete paymentId
- S.post "/income" $
+ S.post "/api/income" $
S.jsonData >>= Income.create
- S.put "/income" $
+ S.put "/api/income" $
S.jsonData >>= Income.edit
- S.delete "/income/:id" $ do
+ S.delete "/api/income/:id" $ do
incomeId <- S.param "id"
Income.delete incomeId
- S.post "/category" $
+ S.post "/api/category" $
S.jsonData >>= Category.create
- S.put "/category" $
+ S.put "/api/category" $
S.jsonData >>= Category.edit
- S.delete "/category/:id" $ do
+ S.delete "/api/category/:id" $ do
categoryId <- S.param "id"
Category.delete categoryId
+
+ S.notFound $
+ Index.get conf
--
cgit v1.2.3
From 6dfc1c166db387a60630eff980e330518601df5b Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 13 Oct 2019 20:58:45 +0200
Subject: Fix sign in responsiveness
---
server/src/Design/Global.hs | 6 +++---
server/src/Design/View/SignIn.hs | 4 +++-
2 files changed, 6 insertions(+), 4 deletions(-)
(limited to 'server')
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index 24d999f..5b8f2dc 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -111,14 +111,14 @@ global = do
display flex
svg # ".loader" ? do
- opacity 0
+ display none
position absolute
".waiting" & do
".content" ? do
- opacity 0
+ display none
svg # ".loader" ? do
- opacity 1
+ display block
spinAnimation
select ? cursor pointer
diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs
index 2138676..a39276e 100644
--- a/server/src/Design/View/SignIn.hs
+++ b/server/src/Design/View/SignIn.hs
@@ -4,6 +4,7 @@ module Design.View.SignIn
import Clay
import Data.Monoid ((<>))
+import Prelude hiding (rem)
import qualified Design.Color as Color
import qualified Design.Constants as Constants
@@ -12,7 +13,8 @@ import qualified Design.Helper as Helper
design :: Css
design = do
let inputHeight = 50
- width (px 500)
+ maxWidth (px 550)
+ sym2 padding (rem 0) (rem 2)
marginTop (px 100)
marginLeft auto
marginRight auto
--
cgit v1.2.3
From 0b40b6b5583b5c437f83e61bf8913f2b4c447b24 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 19 Oct 2019 09:36:03 +0200
Subject: Include pages into table component
---
server/server.cabal | 1 +
server/src/Design/View/Pages.hs | 55 +++++++++++++++++++++++++++++++++++++++++
server/src/Design/Views.hs | 2 ++
3 files changed, 58 insertions(+)
create mode 100644 server/src/Design/View/Pages.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 75af442..426f521 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -74,6 +74,7 @@ Executable server
Design.Tooltip
Design.View.Header
Design.View.NotFound
+ Design.View.Pages
Design.View.Payment
Design.View.Payment.Add
Design.View.Payment.Delete
diff --git a/server/src/Design/View/Pages.hs b/server/src/Design/View/Pages.hs
new file mode 100644
index 0000000..1482ef4
--- /dev/null
+++ b/server/src/Design/View/Pages.hs
@@ -0,0 +1,55 @@
+module Design.View.Pages
+ ( design
+ ) where
+
+import Clay
+
+import qualified Design.Color as Color
+import qualified Design.Constants as Constants
+import qualified Design.Helper as Helper
+import qualified Design.Media as Media
+
+design :: Css
+design =
+ ".pages" ? do
+ display flex
+ justifyContent center
+
+ 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)
+
+ svg ? "path" ? ("fill" -: Color.toString Color.dustyGray)
+
+ ".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/Views.hs b/server/src/Design/Views.hs
index bf39cff..73b7240 100644
--- a/server/src/Design/Views.hs
+++ b/server/src/Design/Views.hs
@@ -10,6 +10,7 @@ import qualified Design.Helper as Helper
import qualified Design.Media as Media
import qualified Design.View.Header as Header
import qualified Design.View.NotFound as NotFound
+import qualified Design.View.Pages as Pages
import qualified Design.View.Payment as Payment
import qualified Design.View.SignIn as SignIn
import qualified Design.View.Stat as Stat
@@ -23,6 +24,7 @@ design = do
".stat" ? Stat.design
".notfound" ? NotFound.design
Table.design
+ Pages.design
".withMargin" ? do
"margin" -: "0 2vw"
--
cgit v1.2.3
From 7aadcc97f9df0e2daccbe8a8726d8bc6c63d67f4 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 20 Oct 2019 12:02:21 +0200
Subject: Add income
---
server/server.cabal | 3 +++
server/src/Controller/Income.hs | 23 +++++++++++++++++------
server/src/Model/CreateIncome.hs | 10 ++++++++++
server/src/Model/EditIncome.hs | 13 +++++++++++++
server/src/Persistence/Income.hs | 19 ++++++++++++++-----
server/src/Validation/Income.hs | 27 +++++++++++++++++++++++++++
6 files changed, 84 insertions(+), 11 deletions(-)
create mode 100644 server/src/Model/CreateIncome.hs
create mode 100644 server/src/Model/EditIncome.hs
create mode 100644 server/src/Validation/Income.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 426f521..022d496 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -94,7 +94,9 @@ Executable server
Job.WeeklyReport
Json
LoginSession
+ Model.CreateIncome
Model.CreatePayment
+ Model.EditIncome
Model.EditPayment
Model.IncomeResource
Model.Mail
@@ -113,6 +115,7 @@ Executable server
Secure
SendMail
Util.Time
+ Validation.Income
Validation.Payment
View.Mail.SignIn
View.Mail.WeeklyReport
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index ed58ac8..e013849 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -5,21 +5,32 @@ module Controller.Income
) where
import Control.Monad.IO.Class (liftIO)
+import Data.Validation (Validation (Failure, Success))
import qualified Network.HTTP.Types.Status as Status
import Web.Scotty hiding (delete)
-import Common.Model (CreateIncome (..), EditIncome (..),
- IncomeId, User (..))
+import Common.Model (CreateIncomeForm (..),
+ EditIncome (..), IncomeId,
+ User (..))
-import Json (jsonId)
+import qualified Controller.Helper as ControllerHelper
+import Model.CreateIncome (CreateIncome (..))
import qualified Model.Query as Query
import qualified Persistence.Income as IncomePersistence
import qualified Secure
+import qualified Validation.Income as IncomeValidation
-create :: CreateIncome -> ActionM ()
-create (CreateIncome date amount) =
+create :: CreateIncomeForm -> ActionM ()
+create form =
Secure.loggedAction (\user ->
- (liftIO . Query.run $ IncomePersistence.create (_user_id user) date amount) >>= jsonId
+ (liftIO . Query.run $ do
+ case IncomeValidation.createIncome form of
+ Success (CreateIncome amount date) -> do
+ Right <$> (IncomePersistence.create (_user_id user) date amount)
+
+ Failure validationError ->
+ return $ Left validationError
+ ) >>= ControllerHelper.jsonOrBadRequest
)
edit :: EditIncome -> ActionM ()
diff --git a/server/src/Model/CreateIncome.hs b/server/src/Model/CreateIncome.hs
new file mode 100644
index 0000000..82451d2
--- /dev/null
+++ b/server/src/Model/CreateIncome.hs
@@ -0,0 +1,10 @@
+module Model.CreateIncome
+ ( CreateIncome(..)
+ ) where
+
+import Data.Time.Calendar (Day)
+
+data CreateIncome = CreateIncome
+ { _createIncome_amount :: Int
+ , _createIncome_date :: Day
+ } deriving (Show)
diff --git a/server/src/Model/EditIncome.hs b/server/src/Model/EditIncome.hs
new file mode 100644
index 0000000..ac3d311
--- /dev/null
+++ b/server/src/Model/EditIncome.hs
@@ -0,0 +1,13 @@
+module Model.EditIncome
+ ( EditIncome(..)
+ ) where
+
+import Data.Time.Calendar (Day)
+
+import Common.Model (IncomeId)
+
+data EditIncome = EditIncome
+ { _editIncome_id :: IncomeId
+ , _editIncome_amount :: Int
+ , _editIncome_date :: Day
+ } deriving (Show)
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
index cee9892..a0c3bbf 100644
--- a/server/src/Persistence/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -36,15 +36,24 @@ list =
SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL"
)
-create :: UserId -> Day -> Int -> Query IncomeId
-create incomeUserId incomeDate incomeAmount =
+create :: UserId -> Day -> Int -> Query Income
+create userId date amount =
Query (\conn -> do
- now <- getCurrentTime
+ createdAt <- getCurrentTime
SQLite.execute
conn
"INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)"
- (incomeUserId, incomeDate, incomeAmount, now)
- SQLite.lastInsertRowId conn
+ (userId, date, amount, createdAt)
+ incomeId <- SQLite.lastInsertRowId conn
+ return $ Income
+ { _income_id = incomeId
+ , _income_userId = userId
+ , _income_date = date
+ , _income_amount = amount
+ , _income_createdAt = createdAt
+ , _income_editedAt = Nothing
+ , _income_deletedAt = Nothing
+ }
)
edit :: UserId -> IncomeId -> Day -> Int -> Query Bool
diff --git a/server/src/Validation/Income.hs b/server/src/Validation/Income.hs
new file mode 100644
index 0000000..5e034d1
--- /dev/null
+++ b/server/src/Validation/Income.hs
@@ -0,0 +1,27 @@
+module Validation.Income
+ ( createIncome
+ , editIncome
+ ) where
+
+import Data.Text (Text)
+import Data.Validation (Validation)
+import qualified Data.Validation as V
+
+import Common.Model (CreateIncomeForm (..),
+ EditIncomeForm (..))
+import qualified Common.Validation.Income as IncomeValidation
+import Model.CreateIncome (CreateIncome (..))
+import Model.EditIncome (EditIncome (..))
+
+createIncome :: CreateIncomeForm -> Validation Text CreateIncome
+createIncome form =
+ CreateIncome
+ <$> IncomeValidation.amount (_createIncomeForm_amount form)
+ <*> IncomeValidation.date (_createIncomeForm_date form)
+
+editIncome :: EditIncomeForm -> Validation Text EditIncome
+editIncome form =
+ EditIncome
+ <$> V.Success (_editIncomeForm_id form)
+ <*> IncomeValidation.amount (_editIncomeForm_amount form)
+ <*> IncomeValidation.date (_editIncomeForm_date form)
--
cgit v1.2.3
From 602c52acfcfa494b07fec05c20b317b60ea8a6f3 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 20 Oct 2019 21:31:57 +0200
Subject: Load init data per page with AJAX
---
server/server.cabal | 2 +-
server/src/Controller/Category.hs | 9 ++++++++-
server/src/Controller/Income.hs | 9 ++++++++-
server/src/Controller/Index.hs | 11 ++++++-----
server/src/Controller/Payment.hs | 7 +++++++
server/src/Controller/User.hs | 17 +++++++++++++++++
server/src/Design/Global.hs | 12 ++++++++++++
server/src/Main.hs | 24 +++++++++++++++++++++++-
server/src/Persistence/Init.hs | 25 -------------------------
9 files changed, 82 insertions(+), 34 deletions(-)
create mode 100644 server/src/Controller/User.hs
delete mode 100644 server/src/Persistence/Init.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 022d496..eeba14f 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -62,6 +62,7 @@ Executable server
Controller.Income
Controller.Index
Controller.Payment
+ Controller.User
Cookie
Design.Color
Design.Constants
@@ -107,7 +108,6 @@ Executable server
Persistence.Category
Persistence.Frequency
Persistence.Income
- Persistence.Init
Persistence.Payment
Persistence.PaymentCategory
Persistence.User
diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs
index 37b8357..e536caa 100644
--- a/server/src/Controller/Category.hs
+++ b/server/src/Controller/Category.hs
@@ -1,5 +1,6 @@
module Controller.Category
- ( create
+ ( list
+ , create
, edit
, delete
) where
@@ -19,6 +20,12 @@ import qualified Persistence.Category as CategoryPersistence
import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
import qualified Secure
+list :: ActionM ()
+list =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ CategoryPersistence.list) >>= json
+ )
+
create :: CreateCategory -> ActionM ()
create (CreateCategory name color) =
Secure.loggedAction (\_ ->
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index e013849..b40976b 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -1,5 +1,6 @@
module Controller.Income
- ( create
+ ( list
+ , create
, edit
, delete
) where
@@ -20,6 +21,12 @@ import qualified Persistence.Income as IncomePersistence
import qualified Secure
import qualified Validation.Income as IncomeValidation
+list :: ActionM ()
+list =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ IncomePersistence.list) >>= json
+ )
+
create :: CreateIncomeForm -> ActionM ()
create form =
Secure.loggedAction (\user ->
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index 5ebe921..3788685 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -16,8 +16,9 @@ import Prelude hiding (error)
import Web.Scotty (ActionM)
import qualified Web.Scotty as S
-import Common.Model (Email (..), InitResult (..),
- SignInForm (..), User (..))
+import Common.Model (Email (..), Init (..),
+ InitResult (..), SignInForm (..),
+ User (..))
import Common.Msg (Key)
import qualified Common.Msg as Msg
import qualified Common.Validation.SignIn as SignInValidation
@@ -26,7 +27,6 @@ import Conf (Conf (..))
import qualified LoginSession
import qualified Model.Query as Query
import qualified Model.SignIn as SignIn
-import qualified Persistence.Init as InitPersistence
import qualified Persistence.User as UserPersistence
import qualified Secure
import qualified SendMail
@@ -40,8 +40,9 @@ get conf = do
case mbLoggedUser of
Nothing ->
return InitEmpty
- Just user ->
- liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf
+ Just user -> do
+ users <- liftIO . Query.run $ UserPersistence.list
+ return . InitSuccess $ Init users (_user_id user) (Conf.currency conf)
S.html $ page initResult
askSignIn :: Conf -> SignInForm -> ActionM ()
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index ba9d1ba..30b63ff 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -1,5 +1,6 @@
module Controller.Payment
( list
+ , listPaymentCategories
, create
, edit
, delete
@@ -32,6 +33,12 @@ list =
(liftIO . Query.run $ PaymentPersistence.listActive) >>= json
)
+listPaymentCategories :: ActionM ()
+listPaymentCategories =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= json
+ )
+
create :: CreatePaymentForm -> ActionM ()
create form =
Secure.loggedAction (\user ->
diff --git a/server/src/Controller/User.hs b/server/src/Controller/User.hs
new file mode 100644
index 0000000..a7bb136
--- /dev/null
+++ b/server/src/Controller/User.hs
@@ -0,0 +1,17 @@
+module Controller.User
+ ( list
+ ) where
+
+import Control.Monad.IO.Class (liftIO)
+import Web.Scotty (ActionM)
+import qualified Web.Scotty as S
+
+import qualified Model.Query as Query
+import qualified Persistence.User as UserPersistence
+import qualified Secure
+
+list :: ActionM ()
+list =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ UserPersistence.list) >>= S.json
+ )
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index 5b8f2dc..598319b 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -52,6 +52,18 @@ global = do
".app" ? do
appearAnimation
+ display flex
+ height (pct 100)
+ flexDirection column
+
+ "main" ?
+ appearAnimation
+
+ ".pageSpinner" ? do
+ display flex
+ alignItems center
+ justifyContent center
+ flexGrow 1
".spinner" ? do
display flex
diff --git a/server/src/Main.hs b/server/src/Main.hs
index e3dad9e..9882092 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -1,3 +1,8 @@
+module Main
+ ( main
+ ) where
+
+import qualified Network.HTTP.Types.Status as Status
import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress))
import qualified Network.Wai.Middleware.Gzip as W
import Network.Wai.Middleware.Static
@@ -8,6 +13,7 @@ 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.User as User
import Job.Daemon (runDaemons)
main :: IO ()
@@ -32,6 +38,12 @@ main = do
S.post "/api/signOut" $
Index.signOut conf
+ S.get "/api/users"$
+ User.list
+
+ S.get "/api/payments" $
+ Payment.list
+
S.post "/api/payment" $
S.jsonData >>= Payment.create
@@ -42,6 +54,9 @@ main = do
paymentId <- S.param "id"
Payment.delete paymentId
+ S.get "/api/incomes" $
+ Income.list
+
S.post "/api/income" $
S.jsonData >>= Income.create
@@ -52,6 +67,12 @@ main = do
incomeId <- S.param "id"
Income.delete incomeId
+ S.get "/api/paymentCategories" $
+ Payment.listPaymentCategories
+
+ S.get "/api/categories" $
+ Category.list
+
S.post "/api/category" $
S.jsonData >>= Category.create
@@ -62,5 +83,6 @@ main = do
categoryId <- S.param "id"
Category.delete categoryId
- S.notFound $
+ S.notFound $ do
+ S.status Status.ok200
Index.get conf
diff --git a/server/src/Persistence/Init.hs b/server/src/Persistence/Init.hs
deleted file mode 100644
index 74d9172..0000000
--- a/server/src/Persistence/Init.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module Persistence.Init
- ( getInit
- ) where
-
-import Common.Model (Init (Init), User (..))
-
-import Conf (Conf)
-import qualified Conf
-import Model.Query (Query)
-import qualified Persistence.Category as CategoryPersistence
-import qualified Persistence.Income as IncomePersistence
-import qualified Persistence.Payment as PaymentPersistence
-import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
-import qualified Persistence.User as UserPersistence
-
-getInit :: User -> Conf -> Query Init
-getInit user conf =
- Init <$>
- UserPersistence.list <*>
- (return . _user_id $ user) <*>
- PaymentPersistence.listActive <*>
- IncomePersistence.list <*>
- CategoryPersistence.list <*>
- PaymentCategoryPersistence.list <*>
- (return . Conf.currency $ conf)
--
cgit v1.2.3
From 80f09e8b3a5c856e60922a73c9161a8c5392e4d4 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 22 Oct 2019 21:35:03 +0200
Subject: Create ModalForm component
---
server/server.cabal | 1 +
1 file changed, 1 insertion(+)
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index eeba14f..f1105ff 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -19,6 +19,7 @@ Executable server
LambdaCase
MultiParamTypeClasses
OverloadedStrings
+ ScopedTypeVariables
Build-depends:
aeson
--
cgit v1.2.3
From 61ff1443c42def5a09f624e3df2e2520e97610d0 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 22 Oct 2019 23:25:05 +0200
Subject: Clone incomes
---
server/src/Design/View/Payment/Table.hs | 5 -----
server/src/Design/View/Table.hs | 3 +++
2 files changed, 3 insertions(+), 5 deletions(-)
(limited to 'server')
diff --git a/server/src/Design/View/Payment/Table.hs b/server/src/Design/View/Payment/Table.hs
index 26dc9ed..67828c9 100644
--- a/server/src/Design/View/Payment/Table.hs
+++ b/server/src/Design/View/Payment/Table.hs
@@ -4,7 +4,6 @@ module Design.View.Payment.Table
import Clay
-import qualified Design.Color as Color
import qualified Design.Media as Media
design :: Css
@@ -34,7 +33,3 @@ design = do
".shortDate" ? display none
".longDate" ? display inline
marginBottom (em 0.5)
-
- ".button" & svg ? do
- "path" ? ("fill" -: Color.toString Color.chestnutRose)
- width (px 18)
diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs
index cd406fc..1c4e806 100644
--- a/server/src/Design/View/Table.hs
+++ b/server/src/Design/View/Table.hs
@@ -72,6 +72,9 @@ design = do
textAlign (alignSide sideCenter)
button ? do
padding (px 10) (px 10) (px 10) (px 10)
+ svg ? do
+ "path" ? ("fill" -: Color.toString Color.chestnutRose)
+ width (px 18)
hover & "svg path" ? do
"fill" -: "rgb(237, 122, 116)"
--
cgit v1.2.3
From f968c8ce63e1aec119b1e6f414cf27e2c0294bcb Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 23 Oct 2019 21:09:54 +0200
Subject: Delete income
---
server/server.cabal | 1 +
server/src/Design/View/ConfirmDialog.hs | 36 +++++++++++++++++++++++++++++++++
server/src/Design/Views.hs | 24 ++++++++++++----------
3 files changed, 50 insertions(+), 11 deletions(-)
create mode 100644 server/src/Design/View/ConfirmDialog.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index f1105ff..c7b4f2b 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -74,6 +74,7 @@ Executable server
Design.Media
Design.Modal
Design.Tooltip
+ Design.View.ConfirmDialog
Design.View.Header
Design.View.NotFound
Design.View.Pages
diff --git a/server/src/Design/View/ConfirmDialog.hs b/server/src/Design/View/ConfirmDialog.hs
new file mode 100644
index 0000000..410d4d8
--- /dev/null
+++ b/server/src/Design/View/ConfirmDialog.hs
@@ -0,0 +1,36 @@
+module Design.View.ConfirmDialog
+ ( design
+ ) where
+
+import Clay
+
+import qualified Design.Color as Color
+import qualified Design.Constants as Constants
+import qualified Design.Helper as Helper
+
+design :: Css
+design = do
+ ".confirm" ? do
+ ".confirmHeader" ? do
+ backgroundColor Color.chestnutRose
+ fontSize (px 18)
+ color Color.white
+ sym padding (px 20)
+ textAlign (alignSide sideCenter)
+ borderRadius (px 5) (px 5) (px 0) (px 0)
+
+ ".confirmContent" ? do
+ sym padding (px 20)
+
+ ".buttons" ? do
+ display flex
+ justifyContent spaceAround
+ marginTop (em 1.5)
+
+ ".confirm" ?
+ Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
+ ".undo" ?
+ Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten
+
+ (".confirm" <> ".undo") ?
+ width (px 90)
diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs
index 73b7240..5c9e307 100644
--- a/server/src/Design/Views.hs
+++ b/server/src/Design/Views.hs
@@ -4,17 +4,18 @@ module Design.Views
import Clay
-import qualified Design.Color as Color
-import qualified Design.Constants as Constants
-import qualified Design.Helper as Helper
-import qualified Design.Media as Media
-import qualified Design.View.Header as Header
-import qualified Design.View.NotFound as NotFound
-import qualified Design.View.Pages as Pages
-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.Color as Color
+import qualified Design.Constants as Constants
+import qualified Design.Helper as Helper
+import qualified Design.Media as Media
+import qualified Design.View.ConfirmDialog as ConfirmDialog
+import qualified Design.View.Header as Header
+import qualified Design.View.NotFound as NotFound
+import qualified Design.View.Pages as Pages
+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
design :: Css
design = do
@@ -25,6 +26,7 @@ design = do
".notfound" ? NotFound.design
Table.design
Pages.design
+ ConfirmDialog.design
".withMargin" ? do
"margin" -: "0 2vw"
--
cgit v1.2.3
From e4b32ce15f8c92f3b477d3f3d4d301ba08f9b5e3 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 23 Oct 2019 22:35:27 +0200
Subject: Edit an income
---
server/src/Controller/Income.hs | 21 +++++++++++++--------
server/src/Persistence/Income.hs | 31 ++++++++++++++++++-------------
2 files changed, 31 insertions(+), 21 deletions(-)
(limited to 'server')
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index b40976b..236e032 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -11,11 +11,12 @@ import qualified Network.HTTP.Types.Status as Status
import Web.Scotty hiding (delete)
import Common.Model (CreateIncomeForm (..),
- EditIncome (..), IncomeId,
+ EditIncomeForm (..), IncomeId,
User (..))
import qualified Controller.Helper as ControllerHelper
import Model.CreateIncome (CreateIncome (..))
+import Model.EditIncome (EditIncome (..))
import qualified Model.Query as Query
import qualified Persistence.Income as IncomePersistence
import qualified Secure
@@ -40,13 +41,17 @@ create form =
) >>= ControllerHelper.jsonOrBadRequest
)
-edit :: EditIncome -> ActionM ()
-edit (EditIncome incomeId date amount) =
- Secure.loggedAction (\user -> do
- updated <- liftIO . Query.run $ IncomePersistence.edit (_user_id user) incomeId date amount
- if updated
- then status Status.ok200
- else status Status.badRequest400
+edit :: EditIncomeForm -> ActionM ()
+edit form =
+ Secure.loggedAction (\user ->
+ (liftIO . Query.run $ do
+ case IncomeValidation.editIncome form of
+ Success (EditIncome incomeId amount date) -> do
+ Right <$> (IncomePersistence.edit (_user_id user) incomeId date amount)
+
+ Failure validationError ->
+ return $ Left validationError
+ ) >>= ControllerHelper.jsonOrBadRequest
)
delete :: IncomeId -> ActionM ()
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
index a0c3bbf..2b9bf0c 100644
--- a/server/src/Persistence/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -56,25 +56,30 @@ create userId date amount =
}
)
-edit :: UserId -> IncomeId -> Day -> Int -> Query Bool
-edit incomeUserId incomeId incomeDate incomeAmount =
+edit :: UserId -> IncomeId -> Day -> Int -> Query (Maybe Income)
+edit userId incomeId incomeDate incomeAmount =
Query (\conn -> do
mbIncome <- fmap (\(Row i) -> i) . 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
+ do
+ currentTime <- getCurrentTime
+ SQLite.execute
+ conn
+ "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?"
+ (currentTime, incomeDate, incomeAmount, incomeId, userId)
+ return . Just $ Income
+ { _income_id = incomeId
+ , _income_userId = userId
+ , _income_date = incomeDate
+ , _income_amount = incomeAmount
+ , _income_createdAt = _income_createdAt income
+ , _income_editedAt = Just currentTime
+ , _income_deletedAt = Nothing
+ }
Nothing ->
- return False
+ return Nothing
)
delete :: UserId -> PaymentId -> Query ()
--
cgit v1.2.3
From 62f990c92b51aeca44d50c154cb4a18e2da3637c Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 23 Oct 2019 22:45:02 +0200
Subject: Disable appear animation on main block
---
server/src/Design/Global.hs | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
(limited to 'server')
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index 598319b..f9884bd 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -56,8 +56,8 @@ global = do
height (pct 100)
flexDirection column
- "main" ?
- appearAnimation
+ -- "main" ?
+ -- appearAnimation
".pageSpinner" ? do
display flex
--
cgit v1.2.3
From b97ad942495352c3fc1e0c820cfba82a9693ac7a Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 27 Oct 2019 20:26:29 +0100
Subject: WIP Set up server side paging for incomes
---
server/src/Controller/Income.hs | 13 ++++++++++++-
server/src/Main.hs | 5 +++++
server/src/Persistence/Income.hs | 26 +++++++++++++++++++++++++-
3 files changed, 42 insertions(+), 2 deletions(-)
(limited to 'server')
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index 236e032..3272cbf 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -1,5 +1,6 @@
module Controller.Income
( list
+ , listv2
, create
, edit
, delete
@@ -12,7 +13,7 @@ import Web.Scotty hiding (delete)
import Common.Model (CreateIncomeForm (..),
EditIncomeForm (..), IncomeId,
- User (..))
+ IncomesAndCount (..), User (..))
import qualified Controller.Helper as ControllerHelper
import Model.CreateIncome (CreateIncome (..))
@@ -28,6 +29,16 @@ list =
(liftIO . Query.run $ IncomePersistence.list) >>= json
)
+listv2 :: Int -> Int -> ActionM ()
+listv2 page perPage =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ do
+ count <- IncomePersistence.count
+ incomes <- IncomePersistence.listv2 page perPage
+ return $ IncomesAndCount incomes count
+ ) >>= json
+ )
+
create :: CreateIncomeForm -> ActionM ()
create form =
Secure.loggedAction (\user ->
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 9882092..00e8d1c 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -54,6 +54,11 @@ main = do
paymentId <- S.param "id"
Payment.delete paymentId
+ S.get "/api/v2/incomes" $ do
+ page <- S.param "page"
+ perPage <- S.param "perPage"
+ Income.listv2 page perPage
+
S.get "/api/incomes" $
Income.list
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
index 2b9bf0c..de55a18 100644
--- a/server/src/Persistence/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -1,5 +1,7 @@
module Persistence.Income
- ( list
+ ( count
+ , list
+ , listv2
, create
, edit
, delete
@@ -29,6 +31,18 @@ instance FromRow Row where
SQLite.field <*>
SQLite.field)
+data Count = Count Int
+
+instance FromRow Count where
+ fromRow = Count <$> SQLite.field
+
+count :: Query Int
+count =
+ Query (\conn ->
+ (\[Count n] -> n) <$>
+ SQLite.query_ conn "SELECT COUNT(*) FROM income WHERE deleted_at IS NULL"
+ )
+
list :: Query [Income]
list =
Query (\conn ->
@@ -36,6 +50,16 @@ list =
SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL"
)
+listv2 :: Int -> Int -> Query [Income]
+listv2 page perPage =
+ Query (\conn ->
+ map (\(Row i) -> i) <$>
+ SQLite.query
+ conn
+ "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?"
+ (perPage, (page - 1) * perPage)
+ )
+
create :: UserId -> Day -> Int -> Query Income
create userId date amount =
Query (\conn -> do
--
cgit v1.2.3
From a267f0bb4566389342c3244d3c082dc2453f4615 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 3 Nov 2019 09:22:12 +0100
Subject: Show users in income table
---
server/server.cabal | 1 +
server/src/Design/Appearing.hs | 25 +++++++++++++++++++++++++
server/src/Design/Global.hs | 2 ++
3 files changed, 28 insertions(+)
create mode 100644 server/src/Design/Appearing.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index c7b4f2b..b170a18 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -65,6 +65,7 @@ Executable server
Controller.Payment
Controller.User
Cookie
+ Design.Appearing
Design.Color
Design.Constants
Design.Errors
diff --git a/server/src/Design/Appearing.hs b/server/src/Design/Appearing.hs
new file mode 100644
index 0000000..79b94b3
--- /dev/null
+++ b/server/src/Design/Appearing.hs
@@ -0,0 +1,25 @@
+module Design.Appearing
+ ( design
+ ) where
+
+import Clay
+
+design :: Css
+design = do
+
+ appearKeyframe
+
+ ".g-Appearing" ? do
+ appearAnimation
+
+appearAnimation :: Css
+appearAnimation = do
+ animationName "appear"
+ animationDuration (sec 0.2)
+ animationTimingFunction easeIn
+
+appearKeyframe :: Css
+appearKeyframe = keyframes
+ "appear"
+ [ (0, "opacity" -: "0")
+ ]
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index f9884bd..df41cfd 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -6,6 +6,7 @@ import Clay
import Clay.Color as C
import Data.Text.Lazy (Text)
+import qualified Design.Appearing as Appearing
import qualified Design.Color as Color
import qualified Design.Constants as Constants
import qualified Design.Errors as Errors
@@ -22,6 +23,7 @@ globalDesign = renderWith compact [] global
global :: Css
global = do
".errors" ? Errors.design
+ Appearing.design
Modal.design
".tooltip" ? Tooltip.design
Views.design
--
cgit v1.2.3
From 9dbb4e6f7c2f0edc1126626e2ff498144c6b9947 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 3 Nov 2019 11:28:42 +0100
Subject: Show income header
---
server/src/Controller/Income.hs | 49 ++++++++++++++++++++++++++++------------
server/src/Job/WeeklyReport.hs | 2 +-
server/src/Main.hs | 7 ++----
server/src/Persistence/Income.hs | 23 +++++++++++--------
4 files changed, 50 insertions(+), 31 deletions(-)
(limited to 'server')
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index 3272cbf..d8d3d89 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -1,42 +1,61 @@
module Controller.Income
( list
- , listv2
, create
, edit
, delete
) where
import Control.Monad.IO.Class (liftIO)
+import qualified Data.Map as M
+import qualified Data.Time.Clock as Clock
import Data.Validation (Validation (Failure, Success))
import qualified Network.HTTP.Types.Status as Status
import Web.Scotty hiding (delete)
import Common.Model (CreateIncomeForm (..),
- EditIncomeForm (..), IncomeId,
- IncomesAndCount (..), User (..))
+ EditIncomeForm (..), Income (..),
+ IncomeHeader (..), IncomeId,
+ IncomePage (..), User (..))
+import qualified Common.Model as CM
import qualified Controller.Helper as ControllerHelper
import Model.CreateIncome (CreateIncome (..))
import Model.EditIncome (EditIncome (..))
import qualified Model.Query as Query
import qualified Persistence.Income as IncomePersistence
+import qualified Persistence.Payment as PaymentPersistence
+import qualified Persistence.User as UserPersistence
import qualified Secure
import qualified Validation.Income as IncomeValidation
-list :: ActionM ()
-list =
- Secure.loggedAction (\_ ->
- (liftIO . Query.run $ IncomePersistence.list) >>= json
- )
-
-listv2 :: Int -> Int -> ActionM ()
-listv2 page perPage =
- Secure.loggedAction (\_ ->
+list :: Int -> Int -> ActionM ()
+list page perPage =
+ Secure.loggedAction (\_ -> do
+ currentTime <- liftIO Clock.getCurrentTime
(liftIO . Query.run $ do
count <- IncomePersistence.count
- incomes <- IncomePersistence.listv2 page perPage
- return $ IncomesAndCount incomes count
- ) >>= json
+
+ users <- UserPersistence.list
+ allPayments <- PaymentPersistence.listPunctual -- TODO: get first payment defined for all
+ allIncomes <- IncomePersistence.listAll
+
+ let since =
+ CM.useIncomesFrom (map _user_id users) allIncomes allPayments
+
+ let byUser =
+ case since of
+ Just s ->
+ M.fromList . flip map users $ \user ->
+ ( _user_id user
+ , CM.cumulativeIncomesSince currentTime s $
+ filter ((==) (_user_id user) . _income_userId) allIncomes
+ )
+
+ Nothing ->
+ M.empty
+
+ incomes <- IncomePersistence.list page perPage
+ return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json
)
create :: CreateIncomeForm -> ActionM ()
diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs
index 203c4e8..1a478dc 100644
--- a/server/src/Job/WeeklyReport.hs
+++ b/server/src/Job/WeeklyReport.hs
@@ -19,7 +19,7 @@ weeklyReport conf mbLastExecution = do
Nothing -> return ()
Just lastExecution -> do
(payments, incomes, users) <- Query.run $
- (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.list <*> UserPersistence.list
+ (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.listAll <*> UserPersistence.list
_ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now)
return ()
return now
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 00e8d1c..40b53b6 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -54,13 +54,10 @@ main = do
paymentId <- S.param "id"
Payment.delete paymentId
- S.get "/api/v2/incomes" $ do
+ S.get "/api/incomes" $ do
page <- S.param "page"
perPage <- S.param "perPage"
- Income.listv2 page perPage
-
- S.get "/api/incomes" $
- Income.list
+ Income.list page perPage
S.post "/api/income" $
S.jsonData >>= Income.create
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
index de55a18..4ae3228 100644
--- a/server/src/Persistence/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -1,7 +1,7 @@
module Persistence.Income
( count
, list
- , listv2
+ , listAll
, create
, edit
, delete
@@ -43,15 +43,8 @@ count =
SQLite.query_ conn "SELECT COUNT(*) FROM income WHERE deleted_at IS NULL"
)
-list :: Query [Income]
-list =
- Query (\conn ->
- map (\(Row i) -> i) <$>
- SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL"
- )
-
-listv2 :: Int -> Int -> Query [Income]
-listv2 page perPage =
+list :: Int -> Int -> Query [Income]
+list page perPage =
Query (\conn ->
map (\(Row i) -> i) <$>
SQLite.query
@@ -60,6 +53,16 @@ listv2 page perPage =
(perPage, (page - 1) * perPage)
)
+listAll :: Query [Income]
+listAll =
+ Query (\conn ->
+ map (\(Row i) -> i) <$>
+ SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL"
+ )
+
+-- firstIncomeByUser
+-- SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id;
+
create :: UserId -> Day -> Int -> Query Income
create userId date amount =
Query (\conn -> do
--
cgit v1.2.3
From 182f3d3fea9985c0e403087fe253981c68e57102 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 3 Nov 2019 11:33:20 +0100
Subject: Fix payment page
---
server/src/Controller/Income.hs | 7 +++++++
server/src/Main.hs | 3 +++
2 files changed, 10 insertions(+)
(limited to 'server')
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index d8d3d89..4a41bd3 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -1,5 +1,6 @@
module Controller.Income
( list
+ , deprecatedList
, create
, edit
, delete
@@ -58,6 +59,12 @@ list page perPage =
return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json
)
+deprecatedList :: ActionM ()
+deprecatedList =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ IncomePersistence.listAll) >>= json
+ )
+
create :: CreateIncomeForm -> ActionM ()
create form =
Secure.loggedAction (\user ->
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 40b53b6..b2672e4 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -59,6 +59,9 @@ main = do
perPage <- S.param "perPage"
Income.list page perPage
+ S.get "/api/deprecated/incomes" $ do
+ Income.deprecatedList
+
S.post "/api/income" $
S.jsonData >>= Income.create
--
cgit v1.2.3
From 0f85cbd8ee736b1996e3966bac1f5e47ed7d27a9 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 3 Nov 2019 15:47:11 +0100
Subject: Fetch the first payment date instead of every payment to get
cumulative income
---
server/src/Controller/Income.hs | 4 ++--
server/src/Persistence/Payment.hs | 16 ++++++++++++++++
2 files changed, 18 insertions(+), 2 deletions(-)
(limited to 'server')
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index 4a41bd3..127e3b3 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -37,11 +37,11 @@ list page perPage =
count <- IncomePersistence.count
users <- UserPersistence.list
- allPayments <- PaymentPersistence.listPunctual -- TODO: get first payment defined for all
+ firstPayment <- PaymentPersistence.firstPunctualDay
allIncomes <- IncomePersistence.listAll
let since =
- CM.useIncomesFrom (map _user_id users) allIncomes allPayments
+ CM.useIncomesFrom (map _user_id users) allIncomes firstPayment
let byUser =
case since of
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index bcd7eb8..eb238d4 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -1,6 +1,7 @@
module Persistence.Payment
( Payment(..)
, find
+ , firstPunctualDay
, listActive
, listPunctual
, listActiveMonthlyOrderedByName
@@ -60,6 +61,21 @@ find paymentId =
SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
)
+data DayRow = DayRow Day
+
+instance FromRow DayRow where
+ fromRow = DayRow <$> SQLite.field
+
+firstPunctualDay :: Query (Maybe Day)
+firstPunctualDay =
+ Query (\conn -> do
+ fmap (\(DayRow d) -> d) . listToMaybe <$>
+ SQLite.query
+ conn
+ "SELECT date FROM payment WHERE frequency = ? AND deleted_at IS NULL ORDER BY date LIMIT 1"
+ (Only (FrequencyField Punctual))
+ )
+
listActive :: Query [Payment]
listActive =
Query (\conn -> do
--
cgit v1.2.3
From f4f24158a46d8c0975f1b8813bbdbbeebad8c108 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 6 Nov 2019 19:44:15 +0100
Subject: Show the payment table with server side paging
---
server/src/Controller/Payment.hs | 19 ++++++++++++++++---
server/src/Design/View/Header.hs | 1 -
server/src/Design/View/SignIn.hs | 2 +-
server/src/Design/View/Table.hs | 11 +++++++++++
server/src/Main.hs | 9 +++++++--
server/src/Persistence/Income.hs | 3 ---
server/src/Persistence/Payment.hs | 25 ++++++++++++++++++++++++-
7 files changed, 59 insertions(+), 11 deletions(-)
(limited to 'server')
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index 30b63ff..01702cb 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -1,5 +1,6 @@
module Controller.Payment
- ( list
+ ( deprecatedList
+ , list
, listPaymentCategories
, create
, edit
@@ -15,6 +16,7 @@ import Common.Model (Category (..),
CreatePaymentForm (..),
EditPaymentForm (..),
Payment (..), PaymentId,
+ PaymentPage (..),
SavedPayment (..), User (..))
import qualified Common.Msg as Msg
import qualified Controller.Helper as ControllerHelper
@@ -27,12 +29,23 @@ import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
import qualified Secure
import qualified Validation.Payment as PaymentValidation
-list :: ActionM ()
-list =
+deprecatedList :: ActionM ()
+deprecatedList =
Secure.loggedAction (\_ ->
(liftIO . Query.run $ PaymentPersistence.listActive) >>= json
)
+list :: Int -> Int -> ActionM ()
+list page perPage =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ do
+ count <- PaymentPersistence.count
+ payments <- PaymentPersistence.listActivePage page perPage
+ paymentCategories <- PaymentCategoryPersistence.list
+ return $ PaymentPage payments paymentCategories count
+ ) >>= json
+ )
+
listPaymentCategories :: ActionM ()
listPaymentCategories =
Secure.loggedAction (\_ ->
diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs
index 59e0e51..609d8fc 100644
--- a/server/src/Design/View/Header.hs
+++ b/server/src/Design/View/Header.hs
@@ -25,7 +25,6 @@ design = do
".title" <> ".item" ? headerPadding
".title" ? do
- height (pct 100)
textAlign (alignSide sideLeft)
Media.mobile $ fontSize (px 22)
diff --git a/server/src/Design/View/SignIn.hs b/server/src/Design/View/SignIn.hs
index a39276e..42c9621 100644
--- a/server/src/Design/View/SignIn.hs
+++ b/server/src/Design/View/SignIn.hs
@@ -13,7 +13,7 @@ import qualified Design.Helper as Helper
design :: Css
design = do
let inputHeight = 50
- maxWidth (px 550)
+ width (px 350)
sym2 padding (rem 0) (rem 2)
marginTop (px 100)
marginLeft auto
diff --git a/server/src/Design/View/Table.hs b/server/src/Design/View/Table.hs
index 1c4e806..c77cb7c 100644
--- a/server/src/Design/View/Table.hs
+++ b/server/src/Design/View/Table.hs
@@ -67,6 +67,17 @@ design = do
".refund" & color Color.mossGreen
+ 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)
+
".cell.button" & do
position relative
textAlign (alignSide sideCenter)
diff --git a/server/src/Main.hs b/server/src/Main.hs
index b2672e4..a4d8635 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -41,8 +41,13 @@ main = do
S.get "/api/users"$
User.list
- S.get "/api/payments" $
- Payment.list
+ S.get "/api/deprecated/payments" $
+ Payment.deprecatedList
+
+ S.get "/api/payments" $ do
+ page <- S.param "page"
+ perPage <- S.param "perPage"
+ Payment.list page perPage
S.post "/api/payment" $
S.jsonData >>= Payment.create
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
index 4ae3228..cb2ef10 100644
--- a/server/src/Persistence/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -60,9 +60,6 @@ listAll =
SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL"
)
--- firstIncomeByUser
--- SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id;
-
create :: UserId -> Day -> Int -> Query Income
create userId date amount =
Query (\conn -> do
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index eb238d4..e01753f 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -1,8 +1,9 @@
module Persistence.Payment
- ( Payment(..)
+ ( count
, find
, firstPunctualDay
, listActive
+ , listActivePage
, listPunctual
, listActiveMonthlyOrderedByName
, create
@@ -54,6 +55,18 @@ instance ToRow InsertRow where
, toField (_payment_createdAt p)
]
+data Count = Count Int
+
+instance FromRow Count where
+ fromRow = Count <$> SQLite.field
+
+count :: Query Int
+count =
+ Query (\conn ->
+ (\[Count n] -> n) <$>
+ SQLite.query_ conn "SELECT COUNT(*) FROM payment WHERE deleted_at IS NULL"
+ )
+
find :: PaymentId -> Query (Maybe Payment)
find paymentId =
Query (\conn -> do
@@ -83,6 +96,16 @@ listActive =
SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL"
)
+listActivePage :: Int -> Int -> Query [Payment]
+listActivePage page perPage =
+ Query (\conn ->
+ map (\(Row p) -> p) <$>
+ SQLite.query
+ conn
+ "SELECT * FROM payment WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?"
+ (perPage, (page - 1) * perPage)
+ )
+
listPunctual :: Query [Payment]
listPunctual =
Query (\conn -> do
--
cgit v1.2.3
From 4dc84dbda7ba3ea60d13e6f81eeec556974b7c72 Mon Sep 17 00:00:00 2001
From: Joris
Date: Thu, 7 Nov 2019 07:59:41 +0100
Subject: Show payment header infos
---
server/server.cabal | 5 +--
server/src/Controller/Payment.hs | 54 ++++++++++++++++++++++----------
server/src/Design/Modal.hs | 8 ++---
server/src/Design/View/Payment.hs | 6 +---
server/src/Design/View/Payment/Delete.hs | 35 ---------------------
server/src/Design/View/Payment/Header.hs | 45 +++++++++++---------------
server/src/Design/View/Payment/Pages.hs | 54 --------------------------------
server/src/Design/View/Payment/Table.hs | 35 ---------------------
server/src/Design/Views.hs | 2 +-
server/src/Main.hs | 3 --
server/src/Persistence/Payment.hs | 21 ++++++++++---
server/src/Util/List.hs | 13 ++++++++
12 files changed, 89 insertions(+), 192 deletions(-)
delete mode 100644 server/src/Design/View/Payment/Delete.hs
delete mode 100644 server/src/Design/View/Payment/Pages.hs
delete mode 100644 server/src/Design/View/Payment/Table.hs
create mode 100644 server/src/Util/List.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index b170a18..b4d9e08 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -80,12 +80,8 @@ Executable server
Design.View.NotFound
Design.View.Pages
Design.View.Payment
- Design.View.Payment.Add
- Design.View.Payment.Delete
Design.View.Payment.Form
Design.View.Payment.Header
- Design.View.Payment.Pages
- Design.View.Payment.Table
Design.View.SignIn
Design.View.Stat
Design.View.Table
@@ -117,6 +113,7 @@ Executable server
Resource
Secure
SendMail
+ Util.List
Util.Time
Validation.Income
Validation.Payment
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index 01702cb..f685f2e 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -1,6 +1,5 @@
module Controller.Payment
- ( deprecatedList
- , list
+ ( list
, listPaymentCategories
, create
, edit
@@ -8,48 +7,69 @@ module Controller.Payment
) where
import Control.Monad.IO.Class (liftIO)
+import qualified Data.Map as M
+import qualified Data.Time.Clock as Clock
import Data.Validation (Validation (Failure, Success))
import qualified Network.HTTP.Types.Status as Status
-import Web.Scotty hiding (delete)
+import Web.Scotty (ActionM)
+import qualified Web.Scotty as S
import Common.Model (Category (..),
CreatePaymentForm (..),
EditPaymentForm (..),
- Payment (..), PaymentId,
- PaymentPage (..),
+ Frequency (Punctual),
+ Payment (..), PaymentHeader (..),
+ PaymentId, PaymentPage (..),
SavedPayment (..), User (..))
+import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Controller.Helper as ControllerHelper
import Model.CreatePayment (CreatePayment (..))
import Model.EditPayment (EditPayment (..))
import qualified Model.Query as Query
import qualified Persistence.Category as CategoryPersistence
+import qualified Persistence.Income as IncomePersistence
import qualified Persistence.Payment as PaymentPersistence
import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
+import qualified Persistence.User as UserPersistence
import qualified Secure
+import qualified Util.List as L
import qualified Validation.Payment as PaymentValidation
-deprecatedList :: ActionM ()
-deprecatedList =
- Secure.loggedAction (\_ ->
- (liftIO . Query.run $ PaymentPersistence.listActive) >>= json
- )
-
list :: Int -> Int -> ActionM ()
list page perPage =
- Secure.loggedAction (\_ ->
+ Secure.loggedAction (\_ -> do
+ currentTime <- liftIO Clock.getCurrentTime
(liftIO . Query.run $ do
count <- PaymentPersistence.count
payments <- PaymentPersistence.listActivePage page perPage
paymentCategories <- PaymentCategoryPersistence.list
- return $ PaymentPage payments paymentCategories count
- ) >>= json
+
+ users <- UserPersistence.list
+ incomes <- IncomePersistence.listAll
+ allPayments <- PaymentPersistence.listActive Punctual
+
+ let exceedingPayers = CM.getExceedingPayers currentTime users incomes allPayments
+
+ repartition =
+ M.fromList
+ . map (\(u, xs) -> (u, sum . map snd $ xs))
+ . L.groupBy fst
+ . map (\p -> (_payment_user p, _payment_cost p))
+ $ allPayments
+
+ header = PaymentHeader
+ { _paymentHeader_exceedingPayers = exceedingPayers
+ , _paymentHeader_repartition = repartition
+ }
+
+ return $ PaymentPage header payments paymentCategories count) >>= S.json
)
listPaymentCategories :: ActionM ()
listPaymentCategories =
Secure.loggedAction (\_ ->
- (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= json
+ (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= S.json
)
create :: CreatePaymentForm -> ActionM ()
@@ -100,7 +120,7 @@ delete paymentId =
_ ->
return False
if deleted then
- status Status.ok200
+ S.status Status.ok200
else
- status Status.badRequest400
+ S.status Status.badRequest400
)
diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs
index 4020eb0..1195e10 100644
--- a/server/src/Design/Modal.hs
+++ b/server/src/Design/Modal.hs
@@ -3,11 +3,9 @@ module Design.Modal
) where
import Clay
-import Data.Monoid ((<>))
+import Data.Monoid ((<>))
-import qualified Design.View.Payment.Add as Add
-import qualified Design.View.Payment.Delete as Delete
-import qualified Design.View.Payment.Form as Form
+import qualified Design.View.Payment.Form as Form
design :: Css
design = do
@@ -47,9 +45,7 @@ design = do
sym borderRadius (px 5)
boxShadow . pure . bsColor (rgba 0 0 0 0.5) $ shadowWithBlur (px 0) (px 0) (px 15)
- ".add" ? Add.design
".form" ? Form.design
- ".delete" ? Delete.design
".paymentModal" & do
".radioGroup" ? ".title" ? display none
diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs
index 0d59fa0..27b4ef3 100644
--- a/server/src/Design/View/Payment.hs
+++ b/server/src/Design/View/Payment.hs
@@ -5,11 +5,7 @@ module Design.View.Payment
import Clay
import qualified Design.View.Payment.Header as Header
-import qualified Design.View.Payment.Pages as Pages
-import qualified Design.View.Payment.Table as Table
design :: Css
design = do
- ".header" ? Header.design
- ".table" ? Table.design
- ".pages" ? Pages.design
+ ".g-HeaderInfos" ? Header.design
diff --git a/server/src/Design/View/Payment/Delete.hs b/server/src/Design/View/Payment/Delete.hs
deleted file mode 100644
index f3d7e3f..0000000
--- a/server/src/Design/View/Payment/Delete.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-module Design.View.Payment.Delete
- ( design
- ) where
-
-import Clay
-
-import qualified Design.Color as Color
-import qualified Design.Constants as Constants
-import qualified Design.Helper as Helper
-
-design :: Css
-design = do
- ".deleteHeader" ? do
- backgroundColor Color.chestnutRose
- fontSize (px 18)
- color Color.white
- sym padding (px 20)
- textAlign (alignSide sideCenter)
- borderRadius (px 5) (px 5) (px 0) (px 0)
-
- ".deleteContent" ? do
- sym padding (px 20)
-
- ".buttons" ? do
- display flex
- justifyContent spaceAround
- marginTop (em 1.5)
-
- ".confirm" ?
- Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
- ".undo" ?
- Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten
-
- (".confirm" <> ".undo") ?
- width (px 90)
diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs
index 9111374..49c1a09 100644
--- a/server/src/Design/View/Payment/Header.hs
+++ b/server/src/Design/View/Payment/Header.hs
@@ -8,45 +8,36 @@ import Clay
import qualified Design.Color as Color
import qualified Design.Constants as Constants
-import qualified Design.Helper as Helper
import qualified Design.Media as Media
design :: Css
design = do
- Media.desktop $ marginBottom (em 3)
- Media.mobileTablet $ marginBottom (em 2)
+ Media.desktop $ marginBottom (em 2)
+ Media.mobileTablet $ marginBottom (em 1)
marginLeft (pct Constants.blockPercentMargin)
marginRight (pct Constants.blockPercentMargin)
- ".payerAndAdd" ? do
- Media.tabletDesktop $ display flex
+ ".g-HeaderInfos__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)
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.mobile $ do
+ textAlign (alignSide sideCenter)
- Media.tabletDesktop $ do
- "flex-grow" -: "1"
- marginRight (px 15)
+ ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ")
- Media.mobile $ do
- marginBottom (em 1)
- textAlign (alignSide sideCenter)
-
- ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ")
-
- ".userName" ? marginRight (px 8)
+ ".userName" ? marginRight (px 8)
- ".addPayment" ? do
- Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
- Media.mobile $ width (pct 100)
+ -- ".addPayment" ? do
+ -- Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
+ -- Media.mobile $ width (pct 100)
- ".searchLine" ? do
+ ".g-HeaderForm" ? do
marginBottom (em 1)
Media.mobile $ textAlign (alignSide sideCenter)
@@ -62,7 +53,7 @@ design = do
".selectInput" ? do
Media.tabletDesktop $ display inlineBlock
- ".infos" ? do
+ ".g-HeaderInfos__Repartition" ? do
Media.tabletDesktop $ lineHeight (px Constants.inputHeight)
Media.mobile $ lineHeight (px 25)
diff --git a/server/src/Design/View/Payment/Pages.hs b/server/src/Design/View/Payment/Pages.hs
deleted file mode 100644
index 2028c1b..0000000
--- a/server/src/Design/View/Payment/Pages.hs
+++ /dev/null
@@ -1,54 +0,0 @@
-module Design.View.Payment.Pages
- ( design
- ) where
-
-import Clay
-
-import qualified Design.Color as Color
-import qualified Design.Constants as Constants
-import qualified Design.Helper as Helper
-import qualified Design.Media as Media
-
-design :: Css
-design = do
- display flex
- justifyContent center
-
- 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)
-
- svg ? "path" ? ("fill" -: Color.toString Color.dustyGray)
-
- ".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
deleted file mode 100644
index 67828c9..0000000
--- a/server/src/Design/View/Payment/Table.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-module Design.View.Payment.Table
- ( design
- ) where
-
-import Clay
-
-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)
diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs
index 5c9e307..d36a728 100644
--- a/server/src/Design/Views.hs
+++ b/server/src/Design/Views.hs
@@ -20,7 +20,7 @@ import qualified Design.View.Table as Table
design :: Css
design = do
header ? Header.design
- ".payment" ? Payment.design
+ Payment.design
".signIn" ? SignIn.design
".stat" ? Stat.design
".notfound" ? NotFound.design
diff --git a/server/src/Main.hs b/server/src/Main.hs
index a4d8635..5068d10 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -41,9 +41,6 @@ main = do
S.get "/api/users"$
User.list
- S.get "/api/deprecated/payments" $
- Payment.deprecatedList
-
S.get "/api/payments" $ do
page <- S.param "page"
perPage <- S.param "perPage"
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index e01753f..7835c98 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -89,11 +89,14 @@ firstPunctualDay =
(Only (FrequencyField Punctual))
)
-listActive :: Query [Payment]
-listActive =
+listActive :: Frequency -> Query [Payment]
+listActive frequency =
Query (\conn -> do
map (\(Row p) -> p) <$>
- SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL"
+ SQLite.query
+ conn
+ "SELECT * FROM payment WHERE deleted_at IS NULL AND frequency = ?"
+ (Only (FrequencyField frequency))
)
listActivePage :: Int -> Int -> Query [Payment]
@@ -102,8 +105,16 @@ listActivePage page perPage =
map (\(Row p) -> p) <$>
SQLite.query
conn
- "SELECT * FROM payment WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?"
- (perPage, (page - 1) * perPage)
+ (SQLite.Query $ T.intercalate " "
+ [ "SELECT *"
+ , "FROM payment"
+ , "WHERE deleted_at IS NULL AND frequency = ?"
+ , "ORDER BY date DESC"
+ , "LIMIT ?"
+ , "OFFSET ?"
+ ]
+ )
+ (FrequencyField Punctual, perPage, (page - 1) * perPage)
)
listPunctual :: Query [Payment]
diff --git a/server/src/Util/List.hs b/server/src/Util/List.hs
new file mode 100644
index 0000000..4e22ba8
--- /dev/null
+++ b/server/src/Util/List.hs
@@ -0,0 +1,13 @@
+module Util.List
+ ( groupBy
+ ) where
+
+import Control.Arrow ((&&&))
+import Data.Function (on)
+import qualified Data.List as L
+
+groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])]
+groupBy f =
+ map (f . head &&& id)
+ . L.groupBy ((==) `on` f)
+ . L.sortBy (compare `on` f)
--
cgit v1.2.3
From c0ea63f8c1a8c7123b78798cec99726b113fb1f3 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 17 Nov 2019 18:08:28 +0100
Subject: Optimize and refactor payments
---
server/migrations/2.sql | 21 +++
server/server.cabal | 6 +-
server/src/Controller/Category.hs | 27 ++--
server/src/Controller/Income.hs | 17 +-
server/src/Controller/Payment.hs | 137 ++++++++---------
server/src/Design/Form.hs | 1 -
server/src/Design/View/Payment.hs | 6 +-
server/src/Design/View/Payment/Header.hs | 68 --------
server/src/Design/View/Payment/HeaderForm.hs | 40 +++++
server/src/Design/View/Payment/HeaderInfos.hs | 50 ++++++
server/src/Job/WeeklyReport.hs | 23 ++-
server/src/Main.hs | 14 +-
server/src/Model/SignIn.hs | 4 +-
server/src/Payer.hs | 170 ++++++++++++++++++++
server/src/Persistence/Category.hs | 10 +-
server/src/Persistence/Income.hs | 59 ++++++-
server/src/Persistence/Payment.hs | 214 +++++++++++++++++++-------
server/src/Persistence/PaymentCategory.hs | 89 -----------
server/src/Persistence/User.hs | 4 +-
server/src/Util/List.hs | 13 --
server/src/View/Mail/WeeklyReport.hs | 22 +--
21 files changed, 626 insertions(+), 369 deletions(-)
delete mode 100644 server/src/Design/View/Payment/Header.hs
create mode 100644 server/src/Design/View/Payment/HeaderForm.hs
create mode 100644 server/src/Design/View/Payment/HeaderInfos.hs
create mode 100644 server/src/Payer.hs
delete mode 100644 server/src/Persistence/PaymentCategory.hs
delete mode 100644 server/src/Util/List.hs
(limited to 'server')
diff --git a/server/migrations/2.sql b/server/migrations/2.sql
index 1c829ec..efed046 100644
--- a/server/migrations/2.sql
+++ b/server/migrations/2.sql
@@ -21,3 +21,24 @@ DELETE FROM
payment_category
WHERE
name NOT IN (SELECT DISTINCT lower(name) FROM payment);
+
+-- Add category id to payment table
+
+PRAGMA foreign_keys = 0;
+
+ALTER TABLE payment ADD COLUMN "category" INTEGER NOT NULL REFERENCES "category" DEFAULT -1;
+
+PRAGMA foreign_keys = 1;
+
+UPDATE
+ payment
+SET
+ category = (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name))
+WHERE
+ EXISTS (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name))
+
+DELETE FROM payment WHERE category = -1;
+
+-- Remove
+
+DROP TABLE payment_category
diff --git a/server/server.cabal b/server/server.cabal
index b4d9e08..7056b3f 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -81,7 +81,8 @@ Executable server
Design.View.Pages
Design.View.Payment
Design.View.Payment.Form
- Design.View.Payment.Header
+ Design.View.Payment.HeaderForm
+ Design.View.Payment.HeaderInfos
Design.View.SignIn
Design.View.Stat
Design.View.Table
@@ -104,16 +105,15 @@ Executable server
Model.Query
Model.SignIn
Model.UUID
+ Payer
Persistence.Category
Persistence.Frequency
Persistence.Income
Persistence.Payment
- Persistence.PaymentCategory
Persistence.User
Resource
Secure
SendMail
- Util.List
Util.Time
Validation.Income
Validation.Payment
diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs
index e536caa..8fbc8c8 100644
--- a/server/src/Controller/Category.hs
+++ b/server/src/Controller/Category.hs
@@ -5,19 +5,18 @@ module Controller.Category
, delete
) where
-import Control.Monad.IO.Class (liftIO)
-import qualified Data.Text.Lazy as TL
-import Network.HTTP.Types.Status (badRequest400, ok200)
-import Web.Scotty hiding (delete)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Text.Lazy as TL
+import Network.HTTP.Types.Status (badRequest400, ok200)
+import Web.Scotty hiding (delete)
-import Common.Model (CategoryId, CreateCategory (..),
- EditCategory (..))
-import qualified Common.Msg as Msg
+import Common.Model (CategoryId, CreateCategory (..),
+ EditCategory (..))
+import qualified Common.Msg as Msg
-import Json (jsonId)
-import qualified Model.Query as Query
-import qualified Persistence.Category as CategoryPersistence
-import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
+import Json (jsonId)
+import qualified Model.Query as Query
+import qualified Persistence.Category as CategoryPersistence
import qualified Secure
list :: ActionM ()
@@ -45,10 +44,8 @@ delete :: CategoryId -> ActionM ()
delete categoryId =
Secure.loggedAction (\_ -> do
deleted <- liftIO . Query.run $ do
- paymentCategories <- PaymentCategoryPersistence.listByCategory categoryId
- if null paymentCategories
- then CategoryPersistence.delete categoryId
- else return False
+ -- TODO: delete only if no payment has this category
+ CategoryPersistence.delete categoryId
if deleted
then
status ok200
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index 127e3b3..75d0133 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -1,6 +1,5 @@
module Controller.Income
( list
- , deprecatedList
, create
, edit
, delete
@@ -17,12 +16,12 @@ import Common.Model (CreateIncomeForm (..),
EditIncomeForm (..), Income (..),
IncomeHeader (..), IncomeId,
IncomePage (..), User (..))
-import qualified Common.Model as CM
import qualified Controller.Helper as ControllerHelper
import Model.CreateIncome (CreateIncome (..))
import Model.EditIncome (EditIncome (..))
import qualified Model.Query as Query
+import qualified Payer as Payer
import qualified Persistence.Income as IncomePersistence
import qualified Persistence.Payment as PaymentPersistence
import qualified Persistence.User as UserPersistence
@@ -37,18 +36,18 @@ list page perPage =
count <- IncomePersistence.count
users <- UserPersistence.list
- firstPayment <- PaymentPersistence.firstPunctualDay
- allIncomes <- IncomePersistence.listAll
+ paymentRange <- PaymentPersistence.getRange
+ allIncomes <- IncomePersistence.listAll -- TODO optimize
let since =
- CM.useIncomesFrom (map _user_id users) allIncomes firstPayment
+ Payer.useIncomesFrom (map _user_id users) allIncomes (fst <$> paymentRange)
let byUser =
case since of
Just s ->
M.fromList . flip map users $ \user ->
( _user_id user
- , CM.cumulativeIncomesSince currentTime s $
+ , Payer.cumulativeIncomesSince currentTime s $
filter ((==) (_user_id user) . _income_userId) allIncomes
)
@@ -59,12 +58,6 @@ list page perPage =
return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json
)
-deprecatedList :: ActionM ()
-deprecatedList =
- Secure.loggedAction (\_ ->
- (liftIO . Query.run $ IncomePersistence.listAll) >>= json
- )
-
create :: CreateIncomeForm -> ActionM ()
create form =
Secure.loggedAction (\user ->
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index f685f2e..d4d086e 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -1,75 +1,70 @@
module Controller.Payment
( list
- , listPaymentCategories
, create
, edit
, delete
+ , searchCategory
) where
-import Control.Monad.IO.Class (liftIO)
-import qualified Data.Map as M
-import qualified Data.Time.Clock as Clock
-import Data.Validation (Validation (Failure, Success))
-import qualified Network.HTTP.Types.Status as Status
-import Web.Scotty (ActionM)
-import qualified Web.Scotty as S
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Map as M
+import qualified Data.Maybe as Maybe
+import Data.Text (Text)
+import qualified Data.Time.Calendar as Calendar
+import qualified Data.Time.Clock as Clock
+import Data.Validation (Validation (Failure, Success))
+import Web.Scotty (ActionM)
+import qualified Web.Scotty as S
-import Common.Model (Category (..),
- CreatePaymentForm (..),
- EditPaymentForm (..),
- Frequency (Punctual),
- Payment (..), PaymentHeader (..),
- PaymentId, PaymentPage (..),
- SavedPayment (..), User (..))
-import qualified Common.Model as CM
-import qualified Common.Msg as Msg
-import qualified Controller.Helper as ControllerHelper
-import Model.CreatePayment (CreatePayment (..))
-import Model.EditPayment (EditPayment (..))
-import qualified Model.Query as Query
-import qualified Persistence.Category as CategoryPersistence
-import qualified Persistence.Income as IncomePersistence
-import qualified Persistence.Payment as PaymentPersistence
-import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
-import qualified Persistence.User as UserPersistence
+import Common.Model (Category (..), CreatePaymentForm (..),
+ EditPaymentForm (..), Frequency,
+ PaymentHeader (..), PaymentId,
+ PaymentPage (..), User (..))
+import qualified Common.Msg as Msg
+
+import qualified Controller.Helper as ControllerHelper
+import Model.CreatePayment (CreatePayment (..))
+import Model.EditPayment (EditPayment (..))
+import qualified Model.Query as Query
+import qualified Payer as Payer
+import qualified Persistence.Category as CategoryPersistence
+import qualified Persistence.Income as IncomePersistence
+import qualified Persistence.Payment as PaymentPersistence
+import qualified Persistence.User as UserPersistence
import qualified Secure
-import qualified Util.List as L
-import qualified Validation.Payment as PaymentValidation
+import qualified Validation.Payment as PaymentValidation
-list :: Int -> Int -> ActionM ()
-list page perPage =
+list :: Frequency -> Int -> Int -> Text -> ActionM ()
+list frequency page perPage search =
Secure.loggedAction (\_ -> do
currentTime <- liftIO Clock.getCurrentTime
(liftIO . Query.run $ do
- count <- PaymentPersistence.count
- payments <- PaymentPersistence.listActivePage page perPage
- paymentCategories <- PaymentCategoryPersistence.list
+ count <- PaymentPersistence.count frequency search
+ payments <- PaymentPersistence.listActivePage frequency page perPage search
users <- UserPersistence.list
- incomes <- IncomePersistence.listAll
- allPayments <- PaymentPersistence.listActive Punctual
+ incomes <- IncomePersistence.listAll -- TODO optimize
+
+ paymentRange <- PaymentPersistence.getRange
+
+ searchRepartition <-
+ case paymentRange of
+ Just (from, to) ->
+ PaymentPersistence.repartition frequency search from (Calendar.addDays 1 to)
+ Nothing ->
+ return M.empty
- let exceedingPayers = CM.getExceedingPayers currentTime users incomes allPayments
+ (preIncomeRepartition, postIncomeRepartition) <-
+ PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users
- repartition =
- M.fromList
- . map (\(u, xs) -> (u, sum . map snd $ xs))
- . L.groupBy fst
- . map (\p -> (_payment_user p, _payment_cost p))
- $ allPayments
+ let exceedingPayers = Payer.getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition (fst <$> paymentRange)
header = PaymentHeader
{ _paymentHeader_exceedingPayers = exceedingPayers
- , _paymentHeader_repartition = repartition
+ , _paymentHeader_repartition = searchRepartition
}
- return $ PaymentPage header payments paymentCategories count) >>= S.json
- )
-
-listPaymentCategories :: ActionM ()
-listPaymentCategories =
- Secure.loggedAction (\_ ->
- (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= S.json
+ return $ PaymentPage page header payments count) >>= S.json
)
create :: CreatePaymentForm -> ActionM ()
@@ -78,10 +73,8 @@ create form =
(liftIO . Query.run $ do
cs <- map _category_id <$> CategoryPersistence.list
case PaymentValidation.createPayment cs form of
- Success (CreatePayment name cost date category frequency) -> do
- pc <- PaymentCategoryPersistence.save name category
- p <- PaymentPersistence.create (_user_id user) name cost date frequency
- return . Right $ SavedPayment p pc
+ Success (CreatePayment name cost date category frequency) ->
+ Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency
Failure validationError ->
return $ Left validationError
) >>= ControllerHelper.jsonOrBadRequest
@@ -94,14 +87,11 @@ edit form =
cs <- map _category_id <$> CategoryPersistence.list
case PaymentValidation.editPayment cs form of
Success (EditPayment paymentId name cost date category frequency) -> do
- editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency
- case editedPayment of
- Just (old, new) -> do
- pc <- PaymentCategoryPersistence.save name category
- PaymentCategoryPersistence.deleteIfUnused (_payment_name old)
- return . Right $ SavedPayment new pc
- Nothing ->
- return . Left $ Msg.get Msg.Error_PaymentEdit
+ editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency
+ if Maybe.isJust editedPayment then
+ return . Right $ editedPayment
+ else
+ return . Left $ Msg.get Msg.Error_PaymentEdit
Failure validationError ->
return $ Left validationError
) >>= ControllerHelper.jsonOrBadRequest
@@ -109,18 +99,13 @@ edit form =
delete :: PaymentId -> ActionM ()
delete paymentId =
- Secure.loggedAction (\user -> do
- deleted <- liftIO . Query.run $ do
- payment <- PaymentPersistence.find paymentId
- case payment of
- Just p | _payment_user p == _user_id user -> do
- PaymentPersistence.delete (_user_id user) paymentId
- PaymentCategoryPersistence.deleteIfUnused (_payment_name p)
- return True
- _ ->
- return False
- if deleted then
- S.status Status.ok200
- else
- S.status Status.badRequest400
+ Secure.loggedAction (\user ->
+ liftIO . Query.run $ PaymentPersistence.delete (_user_id user) paymentId
+ )
+
+searchCategory :: Text -> ActionM ()
+searchCategory paymentName =
+ Secure.loggedAction (\_ -> do
+ (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName))
+ >>= S.json
)
diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs
index 506343d..5713bfe 100644
--- a/server/src/Design/Form.hs
+++ b/server/src/Design/Form.hs
@@ -77,7 +77,6 @@ design = do
backgroundColor transparent
".selectInput" ? do
- marginBottom (em 2)
".label" ? do
color Color.silver
diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs
index 27b4ef3..d563f5d 100644
--- a/server/src/Design/View/Payment.hs
+++ b/server/src/Design/View/Payment.hs
@@ -4,8 +4,10 @@ module Design.View.Payment
import Clay
-import qualified Design.View.Payment.Header as Header
+import qualified Design.View.Payment.HeaderForm as HeaderForm
+import qualified Design.View.Payment.HeaderInfos as HeaderInfos
design :: Css
design = do
- ".g-HeaderInfos" ? Header.design
+ HeaderForm.design
+ HeaderInfos.design
diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs
deleted file mode 100644
index 49c1a09..0000000
--- a/server/src/Design/View/Payment/Header.hs
+++ /dev/null
@@ -1,68 +0,0 @@
-module Design.View.Payment.Header
- ( design
- ) where
-
-import Data.Monoid ((<>))
-
-import Clay
-
-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 2)
- Media.mobileTablet $ marginBottom (em 1)
- marginLeft (pct Constants.blockPercentMargin)
- marginRight (pct Constants.blockPercentMargin)
-
- ".g-HeaderInfos__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)
- marginBottom (em 1)
-
- Media.mobile $ do
- 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)
-
- ".g-HeaderForm" ? do
- marginBottom (em 1)
- 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)
-
- ".selectInput" ? do
- Media.tabletDesktop $ display inlineBlock
-
- ".g-HeaderInfos__Repartition" ? 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/HeaderForm.hs b/server/src/Design/View/Payment/HeaderForm.hs
new file mode 100644
index 0000000..6081443
--- /dev/null
+++ b/server/src/Design/View/Payment/HeaderForm.hs
@@ -0,0 +1,40 @@
+module Design.View.Payment.HeaderForm
+ ( design
+ ) where
+
+import Clay
+
+import qualified Design.Color as Color
+import qualified Design.Constants as Constants
+import qualified Design.Helper as Helper
+import qualified Design.Media as Media
+
+design :: Css
+design = do
+
+ ".g-PaymentHeaderForm" ? do
+ marginBottom (em 2)
+ marginLeft (pct Constants.blockPercentMargin)
+ marginRight (pct Constants.blockPercentMargin)
+ display flex
+ justifyContent spaceBetween
+ alignItems center
+ Media.mobile $ flexDirection column
+
+ ".textInput" ? do
+ display inlineBlock
+ marginBottom (px 0)
+
+ Media.tabletDesktop $ marginRight (px 30)
+ Media.mobile $ do
+ marginBottom (em 1)
+ width (pct 100)
+
+ ".selectInput" ? do
+ Media.tabletDesktop $ display inlineBlock
+ Media.mobile $ marginBottom (em 2)
+
+ ".addPayment" ? do
+ Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
+ Media.mobile $ width (pct 100)
+ flexShrink 0
diff --git a/server/src/Design/View/Payment/HeaderInfos.hs b/server/src/Design/View/Payment/HeaderInfos.hs
new file mode 100644
index 0000000..acb393b
--- /dev/null
+++ b/server/src/Design/View/Payment/HeaderInfos.hs
@@ -0,0 +1,50 @@
+module Design.View.Payment.HeaderInfos
+ ( design
+ ) where
+
+import Data.Monoid ((<>))
+
+import Clay
+
+import qualified Design.Color as Color
+import qualified Design.Constants as Constants
+import qualified Design.Media as Media
+
+design :: Css
+design = do
+
+ ".g-PaymentHeaderInfos" ? do
+ Media.desktop $ marginBottom (em 2)
+ Media.mobileTablet $ marginBottom (em 1)
+ marginLeft (pct Constants.blockPercentMargin)
+ marginRight (pct Constants.blockPercentMargin)
+
+ ".g-PaymentHeaderInfos__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)
+ marginBottom (em 1)
+
+ Media.mobile $ do
+ textAlign (alignSide sideCenter)
+
+ ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ")
+
+ ".userName" ? marginRight (px 8)
+
+ ".g-PaymentHeaderInfos__Repartition" ? 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/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs
index 1a478dc..34bbd3a 100644
--- a/server/src/Job/WeeklyReport.hs
+++ b/server/src/Job/WeeklyReport.hs
@@ -15,11 +15,26 @@ import qualified View.Mail.WeeklyReport as WeeklyReport
weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime
weeklyReport conf mbLastExecution = do
now <- getCurrentTime
+
case mbLastExecution of
- Nothing -> return ()
+ Nothing ->
+ return ()
+
Just lastExecution -> do
- (payments, incomes, users) <- Query.run $
- (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.listAll <*> UserPersistence.list
- _ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now)
+ (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do
+ users <- UserPersistence.list
+ paymentRange <- PaymentPersistence.getRange
+ weekPayments <- PaymentPersistence.listModifiedSince lastExecution
+ weekIncomes <- IncomePersistence.listModifiedSince lastExecution
+ (preIncomeRepartition, postIncomeRepartition) <-
+ PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users
+ return (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users)
+
+ _ <-
+ SendMail.sendMail
+ conf
+ (WeeklyReport.mail conf users weekPayments preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) weekIncomes lastExecution now)
+
return ()
+
return now
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 5068d10..f4d75a0 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -42,9 +42,15 @@ main = do
User.list
S.get "/api/payments" $ do
+ frequency <- S.param "frequency"
page <- S.param "page"
perPage <- S.param "perPage"
- Payment.list page perPage
+ search <- S.param "search"
+ Payment.list (read frequency) page perPage search
+
+ S.get "/api/payment/category" $ do
+ name <- S.param "name"
+ Payment.searchCategory name
S.post "/api/payment" $
S.jsonData >>= Payment.create
@@ -61,9 +67,6 @@ main = do
perPage <- S.param "perPage"
Income.list page perPage
- S.get "/api/deprecated/incomes" $ do
- Income.deprecatedList
-
S.post "/api/income" $
S.jsonData >>= Income.create
@@ -74,9 +77,6 @@ main = do
incomeId <- S.param "id"
Income.delete incomeId
- S.get "/api/paymentCategories" $
- Payment.listPaymentCategories
-
S.get "/api/categories" $
Category.list
diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs
index 0cc4a03..bcdce61 100644
--- a/server/src/Model/SignIn.hs
+++ b/server/src/Model/SignIn.hs
@@ -7,7 +7,7 @@ module Model.SignIn
) where
import Data.Int (Int64)
-import Data.Maybe (listToMaybe)
+import qualified Data.Maybe as Maybe
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock (UTCTime)
@@ -47,7 +47,7 @@ createSignInToken signInEmail =
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])
+ Maybe.listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn])
)
signInTokenToUsed :: SignInId -> Query ()
diff --git a/server/src/Payer.hs b/server/src/Payer.hs
new file mode 100644
index 0000000..d913afe
--- /dev/null
+++ b/server/src/Payer.hs
@@ -0,0 +1,170 @@
+module Payer
+ ( getExceedingPayers
+ , useIncomesFrom
+ , cumulativeIncomesSince
+ ) where
+
+import qualified Data.List as List
+import Data.Map (Map)
+import qualified Data.Map as M
+import qualified Data.Maybe as Maybe
+import Data.Time (NominalDiffTime, UTCTime (..))
+import qualified Data.Time as Time
+import Data.Time.Calendar (Day)
+
+import Common.Model (ExceedingPayer (..), Income (..),
+ User (..), UserId)
+
+data Payer = Payer
+ { _payer_userId :: UserId
+ , _payer_preIncomePayments :: Int
+ , _payer_postIncomePayments :: Int
+ , _payer_incomes :: [Income]
+ }
+
+data PostPaymentPayer = PostPaymentPayer
+ { _postPaymentPayer_userId :: UserId
+ , _postPaymentPayer_preIncomePayments :: Int
+ , _postPaymentPayer_cumulativeIncome :: Int
+ , _postPaymentPayer_ratio :: Float
+ }
+
+getExceedingPayers :: UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [ExceedingPayer]
+getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition firstPayment =
+ let userIds = map _user_id users
+ payers = getPayers userIds incomes preIncomeRepartition postIncomeRepartition
+ exceedingPayersOnPreIncome =
+ exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers
+ mbSince = useIncomesFrom userIds incomes firstPayment
+ in case mbSince of
+ Just since ->
+ let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers
+ mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers
+ in case mbMaxRatio of
+ Just maxRatio ->
+ exceedingPayersFromAmounts
+ . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p))
+ $ postPaymentPayers
+ Nothing ->
+ exceedingPayersOnPreIncome
+ _ ->
+ exceedingPayersOnPreIncome
+
+useIncomesFrom :: [UserId] -> [Income] -> Maybe Day -> Maybe Day
+useIncomesFrom userIds incomes firstPayment =
+ case (firstPayment, incomeDefinedForAll userIds incomes) of
+ (Just d1, Just d2) -> Just (max d1 d2)
+ _ -> Nothing
+
+dayUTCTime :: Day -> UTCTime
+dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0)
+
+getPayers :: [UserId] -> [Income] -> Map UserId Int -> Map UserId Int -> [Payer]
+getPayers userIds incomes preIncomeRepartition postIncomeRepartition =
+ flip map userIds (\userId -> Payer
+ { _payer_userId = userId
+ , _payer_preIncomePayments = M.findWithDefault 0 userId preIncomeRepartition
+ , _payer_postIncomePayments = M.findWithDefault 0 userId postIncomeRepartition
+ , _payer_incomes = filter ((==) userId . _income_userId) incomes
+ }
+ )
+
+exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer]
+exceedingPayersFromAmounts userAmounts =
+ case mbMinAmount of
+ Nothing ->
+ []
+ Just minAmount ->
+ filter (\payer -> _exceedingPayer_amount payer > 0)
+ . map (\userAmount ->
+ ExceedingPayer
+ { _exceedingPayer_userId = fst userAmount
+ , _exceedingPayer_amount = snd userAmount - minAmount
+ }
+ )
+ $ userAmounts
+ where mbMinAmount = safeMinimum . map snd $ userAmounts
+
+getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer
+getPostPaymentPayer currentTime since payer =
+ PostPaymentPayer
+ { _postPaymentPayer_userId = _payer_userId payer
+ , _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer
+ , _postPaymentPayer_cumulativeIncome = cumulativeIncome
+ , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome)
+ }
+ where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer)
+
+getFinalDiff :: Float -> PostPaymentPayer -> Int
+getFinalDiff maxRatio payer =
+ let postIncomeDiff =
+ truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer)
+ in postIncomeDiff + _postPaymentPayer_preIncomePayments payer
+
+incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day
+incomeDefinedForAll userIds incomes =
+ let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds
+ firstIncomes = map (Maybe.listToMaybe . List.sortOn _income_date) userIncomes
+ in if all Maybe.isJust firstIncomes
+ then Maybe.listToMaybe . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes
+ else Nothing
+
+cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int
+cumulativeIncomesSince currentTime since incomes =
+ getCumulativeIncome currentTime (getOrderedIncomesSince since incomes)
+
+getOrderedIncomesSince :: Day -> [Income] -> [Income]
+getOrderedIncomesSince since incomes =
+ let mbStarterIncome = getIncomeAt since incomes
+ orderedIncomesSince = filter (\income -> _income_date income >= since) incomes
+ in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince
+
+getIncomeAt :: Day -> [Income] -> Maybe Income
+getIncomeAt day incomes =
+ case incomes of
+ [x] ->
+ if _income_date x < day
+ then Just $ x { _income_date = day }
+ else Nothing
+ x1 : x2 : xs ->
+ if _income_date x1 < day && _income_date x2 >= day
+ then Just $ x1 { _income_date = day }
+ else getIncomeAt day (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 = dayUTCTime . _income_date
+
+durationIncome :: (NominalDiffTime, Int) -> Int
+durationIncome (duration, income) =
+ truncate $ duration * fromIntegral income / (nominalDay * 365 / 12)
+
+nominalDay :: NominalDiffTime
+nominalDay = 86400
+
+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
diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs
index 2afe5db..00cf0a5 100644
--- a/server/src/Persistence/Category.hs
+++ b/server/src/Persistence/Category.hs
@@ -5,7 +5,7 @@ module Persistence.Category
, delete
) where
-import Data.Maybe (isJust, listToMaybe)
+import qualified Data.Maybe as Maybe
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
@@ -48,9 +48,9 @@ create categoryName categoryColor =
edit :: CategoryId -> Text -> Text -> Query Bool
edit categoryId categoryName categoryColor =
Query (\conn -> do
- mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$>
+ mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$>
(SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
- if isJust mbCategory
+ if Maybe.isJust mbCategory
then do
now <- getCurrentTime
SQLite.execute
@@ -65,9 +65,9 @@ edit categoryId categoryName categoryColor =
delete :: CategoryId -> Query Bool
delete categoryId =
Query (\conn -> do
- mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$>
+ mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$>
(SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
- if isJust mbCategory
+ if Maybe.isJust mbCategory
then do
now <- getCurrentTime
SQLite.execute
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
index cb2ef10..ba7ad19 100644
--- a/server/src/Persistence/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -2,17 +2,22 @@ module Persistence.Income
( count
, list
, listAll
+ , listModifiedSince
, create
, edit
, delete
+ , definedForAll
) where
-import Data.Maybe (listToMaybe)
+import qualified Data.List as L
+import qualified Data.Maybe as Maybe
+import qualified Data.Text as T
import Data.Time.Calendar (Day)
+import Data.Time.Clock (UTCTime)
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
-import Prelude hiding (id)
+import Prelude hiding (id, until)
import Common.Model (Income (..), IncomeId, PaymentId,
UserId)
@@ -31,15 +36,15 @@ instance FromRow Row where
SQLite.field <*>
SQLite.field)
-data Count = Count Int
+data CountRow = CountRow Int
-instance FromRow Count where
- fromRow = Count <$> SQLite.field
+instance FromRow CountRow where
+ fromRow = CountRow <$> SQLite.field
count :: Query Int
count =
Query (\conn ->
- (\[Count n] -> n) <$>
+ (Maybe.fromMaybe 0 . fmap (\(CountRow n) -> n) . Maybe.listToMaybe) <$>
SQLite.query_ conn "SELECT COUNT(*) FROM income WHERE deleted_at IS NULL"
)
@@ -60,6 +65,23 @@ listAll =
SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL"
)
+listModifiedSince :: UTCTime -> Query [Income]
+listModifiedSince since =
+ Query (\conn ->
+ map (\(Row i) -> i) <$>
+ SQLite.query
+ conn
+ (SQLite.Query . T.intercalate " " $
+ [ "SELECT *"
+ , "FROM income"
+ , "WHERE"
+ , "created_at >= ?"
+ , "OR edited_at >= ?"
+ , "OR deleted_at >= ?"
+ ])
+ (Only since)
+ )
+
create :: UserId -> Day -> Int -> Query Income
create userId date amount =
Query (\conn -> do
@@ -83,7 +105,7 @@ create userId date amount =
edit :: UserId -> IncomeId -> Day -> Int -> Query (Maybe Income)
edit userId incomeId incomeDate incomeAmount =
Query (\conn -> do
- mbIncome <- fmap (\(Row i) -> i) . listToMaybe <$>
+ mbIncome <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$>
SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId)
case mbIncome of
Just income ->
@@ -114,3 +136,26 @@ delete userId paymentId =
"UPDATE income SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?"
(paymentId, userId)
)
+
+data UserDayRow = UserDayRow (UserId, Day)
+
+instance FromRow UserDayRow where
+ fromRow = do
+ user <- SQLite.field
+ day <- SQLite.field
+ return $ UserDayRow (user, day)
+
+definedForAll :: [UserId] -> Query (Maybe Day)
+definedForAll users =
+ Query (\conn ->
+ (fromRows . fmap (\(UserDayRow (user, day)) -> (user, day))) <$>
+ SQLite.query_
+ conn
+ "SELECT user_id, MIN(date) FROM income WHERE deleted_at IS NULL GROUP BY user_id;"
+ )
+ where
+ fromRows rows =
+ if L.sort users == L.sort (map fst rows) then
+ Maybe.listToMaybe . L.sort . map snd $ rows
+ else
+ Nothing
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index 7835c98..f75925d 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -1,33 +1,57 @@
module Persistence.Payment
( count
, find
- , firstPunctualDay
- , listActive
+ , getRange
, listActivePage
- , listPunctual
+ , listModifiedSince
, listActiveMonthlyOrderedByName
, create
, createMany
, edit
, delete
+ , searchCategory
+ , repartition
+ , getPreAndPostPaymentRepartition
) where
-import Data.Maybe (listToMaybe)
+import Data.Map (Map)
+import qualified Data.Map as M
+import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
+import qualified Data.Time.Calendar as Calendar
+import Data.Time.Clock (UTCTime)
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (FromRow (fromRow), Only (Only),
ToRow)
import qualified Database.SQLite.Simple as SQLite
import Database.SQLite.Simple.ToField (ToField (toField))
-import Prelude hiding (id)
+import Prelude hiding (id, until)
-import Common.Model (Frequency (..), Payment (..),
- PaymentId, UserId)
+import Common.Model (CategoryId, Frequency (..),
+ Payment (..), PaymentId,
+ User (..), UserId)
import Model.Query (Query (Query))
import Persistence.Frequency (FrequencyField (..))
+import qualified Persistence.Income as IncomePersistence
+
+
+
+fields :: Text
+fields = T.intercalate "," $
+ [ "id"
+ , "user_id"
+ , "name"
+ , "cost"
+ , "date"
+ , "category"
+ , "frequency"
+ , "created_at"
+ , "edited_at"
+ , "deleted_at"
+ ]
newtype Row = Row Payment
@@ -38,6 +62,7 @@ instance FromRow Row where
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
+ SQLite.field <*>
(fmap (\(FrequencyField f) -> f) $ SQLite.field) <*>
SQLite.field <*>
SQLite.field <*>
@@ -51,6 +76,7 @@ instance ToRow InsertRow where
, toField (_payment_name p)
, toField (_payment_cost p)
, toField (_payment_date p)
+ , toField (_payment_category p)
, toField (FrequencyField (_payment_frequency p))
, toField (_payment_createdAt p)
]
@@ -60,73 +86,94 @@ data Count = Count Int
instance FromRow Count where
fromRow = Count <$> SQLite.field
-count :: Query Int
-count =
+count :: Frequency -> Text -> Query Int
+count frequency search =
Query (\conn ->
(\[Count n] -> n) <$>
- SQLite.query_ conn "SELECT COUNT(*) FROM payment WHERE deleted_at IS NULL"
+ SQLite.query
+ conn
+ (SQLite.Query $ T.intercalate " "
+ [ "SELECT COUNT(*)"
+ , "FROM payment"
+ , "WHERE"
+ , "deleted_at IS NULL"
+ , "AND frequency = ?"
+ , "AND name LIKE ?"
+ ])
+ (FrequencyField frequency, "%" <> search <> "%")
)
find :: PaymentId -> Query (Maybe Payment)
find paymentId =
Query (\conn -> do
- fmap (\(Row p) -> p) . listToMaybe <$>
- SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
+ fmap (\(Row p) -> p) . Maybe.listToMaybe <$>
+ SQLite.query
+ conn
+ (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ?")
+ (Only paymentId)
)
-data DayRow = DayRow Day
+data RangeRow = RangeRow (Day, Day)
-instance FromRow DayRow where
- fromRow = DayRow <$> SQLite.field
+instance FromRow RangeRow where
+ fromRow = (\f t -> RangeRow (f, t)) <$> SQLite.field <*> SQLite.field
-firstPunctualDay :: Query (Maybe Day)
-firstPunctualDay =
+getRange :: Query (Maybe (Day, Day))
+getRange =
Query (\conn -> do
- fmap (\(DayRow d) -> d) . listToMaybe <$>
+ fmap (\(RangeRow (f, t)) -> (f, t)) . Maybe.listToMaybe <$>
SQLite.query
conn
- "SELECT date FROM payment WHERE frequency = ? AND deleted_at IS NULL ORDER BY date LIMIT 1"
+ (SQLite.Query $ T.intercalate " "
+ [ "SELECT MIN(date), MAX(date)"
+ , "FROM payment"
+ , "WHERE"
+ , "frequency = ?"
+ , "AND deleted_at IS NULL"
+ ])
(Only (FrequencyField Punctual))
)
-listActive :: Frequency -> Query [Payment]
-listActive frequency =
- Query (\conn -> do
- map (\(Row p) -> p) <$>
- SQLite.query
- conn
- "SELECT * FROM payment WHERE deleted_at IS NULL AND frequency = ?"
- (Only (FrequencyField frequency))
- )
-
-listActivePage :: Int -> Int -> Query [Payment]
-listActivePage page perPage =
+listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment]
+listActivePage frequency page perPage search =
Query (\conn ->
map (\(Row p) -> p) <$>
SQLite.query
conn
(SQLite.Query $ T.intercalate " "
- [ "SELECT *"
+ [ "SELECT"
+ , fields
, "FROM payment"
- , "WHERE deleted_at IS NULL AND frequency = ?"
+ , "WHERE"
+ , "deleted_at IS NULL"
+ , "AND frequency = ?"
+ , "AND name LIKE ?"
, "ORDER BY date DESC"
, "LIMIT ?"
, "OFFSET ?"
]
)
- (FrequencyField Punctual, perPage, (page - 1) * perPage)
+ (FrequencyField frequency, "%" <> search <> "%", perPage, (page - 1) * perPage)
)
-listPunctual :: Query [Payment]
-listPunctual =
- Query (\conn -> do
- map (\(Row p) -> p) <$>
+listModifiedSince :: UTCTime -> Query [Payment]
+listModifiedSince since =
+ Query (\conn ->
+ map (\(Row i) -> i) <$>
SQLite.query
conn
- (SQLite.Query "SELECT * FROM payment WHERE frequency = ?")
- (Only (FrequencyField Punctual))
+ (SQLite.Query . T.intercalate " " $
+ [ "SELECT *"
+ , "FROM payment"
+ , "WHERE"
+ , "created_at >= ?"
+ , "OR edited_at >= ?"
+ , "OR deleted_at >= ?"
+ ])
+ (Only since)
)
+
listActiveMonthlyOrderedByName :: Query [Payment]
listActiveMonthlyOrderedByName =
Query (\conn -> do
@@ -134,7 +181,8 @@ listActiveMonthlyOrderedByName =
SQLite.query
conn
(SQLite.Query $ T.intercalate " "
- [ "SELECT *"
+ [ "SELECT"
+ , fields
, "FROM payment"
, "WHERE deleted_at IS NULL AND frequency = ?"
, "ORDER BY name DESC"
@@ -142,17 +190,17 @@ listActiveMonthlyOrderedByName =
(Only (FrequencyField Monthly))
)
-create :: UserId -> Text -> Int -> Day -> Frequency -> Query Payment
-create userId name cost date frequency =
+create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Payment
+create userId name cost date category frequency =
Query (\conn -> do
time <- getCurrentTime
SQLite.execute
conn
(SQLite.Query $ T.intercalate " "
- [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)"
- , "VALUES (?, ?, ?, ?, ?, ?)"
+ [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)"
+ , "VALUES (?, ?, ?, ?, ?, ?, ?)"
])
- (userId, name, cost, date, FrequencyField frequency, time)
+ (userId, name, cost, date, category, FrequencyField frequency, time)
paymentId <- SQLite.lastInsertRowId conn
return $ Payment
{ _payment_id = paymentId
@@ -160,6 +208,7 @@ create userId name cost date frequency =
, _payment_name = name
, _payment_cost = cost
, _payment_date = date
+ , _payment_category = category
, _payment_frequency = frequency
, _payment_createdAt = time
, _payment_editedAt = Nothing
@@ -173,19 +222,19 @@ createMany payments =
SQLite.executeMany
conn
(SQLite.Query $ T.intercalate ""
- [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)"
- , "VALUES (?, ?, ?, ?, ?, ?)"
+ [ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)"
+ , "VALUES (?, ?, ?, ?, ?, ?, ?)"
])
(map InsertRow payments)
)
-edit :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query (Maybe (Payment, Payment))
-edit userId paymentId name cost date frequency =
+edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query (Maybe Payment)
+edit userId paymentId name cost date category frequency =
Query (\conn -> do
- mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$>
+ mbPayment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$>
SQLite.query
conn
- "SELECT * FROM payment WHERE id = ? and user_id = ?"
+ (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ? and user_id = ?")
(paymentId, userId)
case mbPayment of
Just payment -> do
@@ -200,6 +249,7 @@ edit userId paymentId name cost date frequency =
, " name = ?,"
, " cost = ?,"
, " date = ?,"
+ , " category = ?,"
, " frequency = ?"
, "WHERE"
, " id = ?"
@@ -209,16 +259,18 @@ edit userId paymentId name cost date frequency =
, name
, cost
, date
+ , category
, FrequencyField frequency
, paymentId
, userId
)
- return . Just . (,) payment $ Payment
+ return . Just $ Payment
{ _payment_id = paymentId
, _payment_user = userId
, _payment_name = name
, _payment_cost = cost
, _payment_date = date
+ , _payment_category = category
, _payment_frequency = frequency
, _payment_createdAt = _payment_createdAt payment
, _payment_editedAt = Just now
@@ -236,3 +288,59 @@ delete userId paymentId =
"UPDATE payment SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?"
(paymentId, userId)
)
+
+data CategoryIdRow = CategoryIdRow CategoryId
+
+instance FromRow CategoryIdRow where
+ fromRow = CategoryIdRow <$> SQLite.field
+
+searchCategory :: Text -> Query (Maybe CategoryId)
+searchCategory paymentName =
+ Query (\conn ->
+ fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$>
+ SQLite.query
+ conn
+ "SELECT category FROM payment WHERE name LIKE ? LIMIT 1"
+ (Only $ "%" <> paymentName <> "%")
+ )
+
+data UserCostRow = UserCostRow (UserId, Int)
+
+instance FromRow UserCostRow where
+ fromRow = do
+ user <- SQLite.field
+ cost <- SQLite.field
+ return $ UserCostRow (user, cost)
+
+repartition :: Frequency -> Text -> Day -> Day -> Query (Map UserId Int)
+repartition frequency search from to =
+ Query (\conn ->
+ M.fromList . fmap (\(UserCostRow r) -> r) <$> SQLite.query
+ conn
+ (SQLite.Query . T.intercalate " " $
+ [ "SELECT user_id, SUM(cost)"
+ , "FROM payment"
+ , "WHERE"
+ , "deleted_at IS NULL"
+ , "AND frequency = ?"
+ , "AND name LIKE ?"
+ , "AND date >= ?"
+ , "AND date < ?"
+ , "GROUP BY user_id"
+ ])
+ (FrequencyField frequency, "%" <> search <> "%", from, to)
+ )
+
+getPreAndPostPaymentRepartition :: Maybe (Day, Day) -> [User] -> Query (Map UserId Int, Map UserId Int)
+getPreAndPostPaymentRepartition paymentRange users = do
+ case paymentRange of
+ Just (from, to) -> do
+ incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users)
+ (,)
+ <$> (repartition Punctual "" from (Maybe.fromMaybe (Calendar.addDays 1 to) incomeDefinedForAll))
+ <*> (case incomeDefinedForAll of
+ Just d -> repartition Punctual "" d (Calendar.addDays 1 to)
+ Nothing -> return M.empty)
+
+ Nothing ->
+ return (M.empty, M.empty)
diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs
deleted file mode 100644
index 46be7f5..0000000
--- a/server/src/Persistence/PaymentCategory.hs
+++ /dev/null
@@ -1,89 +0,0 @@
-module Persistence.PaymentCategory
- ( list
- , listByCategory
- , save
- , deleteIfUnused
- ) where
-
-import qualified Data.Maybe as Maybe
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
-import qualified Database.SQLite.Simple as SQLite
-
-import Common.Model (CategoryId, PaymentCategory (..))
-
-import Model.Query (Query (Query))
-
-newtype Row = Row PaymentCategory
-
-instance FromRow Row where
- fromRow = Row <$> (PaymentCategory <$>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field <*>
- SQLite.field)
-
-list :: Query [PaymentCategory]
-list =
- Query (\conn -> do
- map (\(Row pc) -> pc) <$>
- SQLite.query_ conn "SELECT * from payment_category"
- )
-
-listByCategory :: CategoryId -> Query [PaymentCategory]
-listByCategory cat =
- Query (\conn -> do
- map (\(Row pc) -> pc) <$>
- SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat)
- )
-
-save :: Text -> CategoryId -> Query PaymentCategory
-save newName categoryId =
- Query (\conn -> do
- now <- getCurrentTime
- paymentCategory <- fmap (\(Row pc) -> pc) . Maybe.listToMaybe <$>
- (SQLite.query
- conn
- "SELECT * FROM payment_category WHERE name = ?"
- (Only formattedNewName))
- case paymentCategory of
- Just pc ->
- do
- SQLite.execute
- conn
- "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?"
- (categoryId, now, formattedNewName)
- return $ PaymentCategory
- (_paymentCategory_id pc)
- formattedNewName
- categoryId
- (_paymentCategory_createdAt pc)
- (Just now)
- Nothing ->
- do
- SQLite.execute
- conn
- "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)"
- (formattedNewName, categoryId, now)
- paymentCategoryId <- SQLite.lastInsertRowId conn
- return $ PaymentCategory
- paymentCategoryId
- formattedNewName
- categoryId
- now
- Nothing
- )
- where
- formattedNewName = T.toLower newName
-
-deleteIfUnused :: Text -> Query ()
-deleteIfUnused name =
- Query (\conn ->
- SQLite.execute
- conn
- "DELETE FROM payment_category WHERE name = lower(?) AND name NOT IN (SELECT DISTINCT lower(name) FROM payment WHERE lower(name) = lower(?) AND deleted_at IS NULL)"
- (name, name)
- ) >> return ()
diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs
index 4ec2dcf..3c3a2b1 100644
--- a/server/src/Persistence/User.hs
+++ b/server/src/Persistence/User.hs
@@ -3,7 +3,7 @@ module Persistence.User
, get
) where
-import Data.Maybe (listToMaybe)
+import qualified Data.Maybe as Maybe
import Data.Text (Text)
import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
@@ -32,6 +32,6 @@ list =
get :: Text -> Query (Maybe User)
get userEmail =
Query (\conn -> do
- fmap (\(Row u) -> u) . listToMaybe <$>
+ fmap (\(Row u) -> u) . Maybe.listToMaybe <$>
SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail)
)
diff --git a/server/src/Util/List.hs b/server/src/Util/List.hs
deleted file mode 100644
index 4e22ba8..0000000
--- a/server/src/Util/List.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Util.List
- ( groupBy
- ) where
-
-import Control.Arrow ((&&&))
-import Data.Function (on)
-import qualified Data.List as L
-
-groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])]
-groupBy f =
- map (f . head &&& id)
- . L.groupBy ((==) `on` f)
- . L.sortBy (compare `on` f)
diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs
index 7e88d98..1f637bc 100644
--- a/server/src/View/Mail/WeeklyReport.hs
+++ b/server/src/View/Mail/WeeklyReport.hs
@@ -9,6 +9,7 @@ import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
+import Data.Time.Calendar (Day)
import Data.Time.Clock (UTCTime)
import Common.Model (ExceedingPayer (..), Income (..),
@@ -23,10 +24,11 @@ import Model.IncomeResource (IncomeResource (..))
import Model.Mail (Mail (Mail))
import qualified Model.Mail as M
import Model.PaymentResource (PaymentResource (..))
+import qualified Payer as Payer
import Resource (Status (..), groupByStatus, statuses)
-mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail
-mail conf users payments incomes start end =
+mail :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Mail
+mail conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end =
Mail
{ M.from = Conf.noReplyMail conf
, M.to = map _user_email users
@@ -35,24 +37,24 @@ mail conf users payments incomes start end =
, " − "
, Msg.get Msg.WeeklyReport_Title
]
- , M.body = body conf users payments incomes start end
+ , M.body = body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end
}
-body :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Text
-body conf users payments incomes start end =
+body :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Text
+body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end =
T.intercalate "\n" $
- [ exceedingPayers conf end users incomes (filter (null . _payment_deletedAt) payments)
+ [ exceedingPayers conf end users incomes preIncomeRepartition postIncomeRepartition firstPayment
, operations conf users paymentsGroupedByStatus incomesGroupedByStatus
]
where
- paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ payments
+ paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ weekPayments
incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes
-exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> [Payment] -> Text
-exceedingPayers conf time users incomes payments =
+exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> Text
+exceedingPayers conf time users incomes preIncomeRepartition postIncomeRepartition firstPayment =
T.intercalate "\n" . map formatPayer $ payers
where
- payers = CM.getExceedingPayers time users incomes payments
+ payers = Payer.getExceedingPayers time users incomes preIncomeRepartition postIncomeRepartition firstPayment
formatPayer p = T.concat
[ " * "
, fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users
--
cgit v1.2.3
From 3c67fcf1d524811a18f0c4db3ef6eed1270b9a12 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 17 Nov 2019 19:55:22 +0100
Subject: Hide date from monthly payments
---
server/src/Controller/Payment.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
(limited to 'server')
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index d4d086e..c860810 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -64,7 +64,7 @@ list frequency page perPage search =
, _paymentHeader_repartition = searchRepartition
}
- return $ PaymentPage page header payments count) >>= S.json
+ return $ PaymentPage page frequency header payments count) >>= S.json
)
create :: CreatePaymentForm -> ActionM ()
--
cgit v1.2.3
From 54628c70cb33de5e4309c35b9f6b57bbe9f7a07b Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 24 Nov 2019 16:19:53 +0100
Subject: Compute cumulative income with a DB query
---
server/server.cabal | 1 +
server/src/Controller/Income.hs | 28 +++-----
server/src/Controller/Payment.hs | 16 +++--
server/src/Design/Global.hs | 6 +-
server/src/Design/Loadable.hs | 29 ++++++++
server/src/Design/View/Table.hs | 3 +
server/src/Design/Views.hs | 16 +++--
server/src/Job/WeeklyReport.hs | 17 ++++-
server/src/Payer.hs | 135 +++++++----------------------------
server/src/Persistence/Income.hs | 58 ++++++++++++---
server/src/Persistence/Payment.hs | 12 +++-
server/src/View/Mail/WeeklyReport.hs | 21 +++---
12 files changed, 174 insertions(+), 168 deletions(-)
create mode 100644 server/src/Design/Loadable.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 7056b3f..c9ab2c7 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -72,6 +72,7 @@ Executable server
Design.Form
Design.Global
Design.Helper
+ Design.Loadable
Design.Media
Design.Modal
Design.Tooltip
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index 75d0133..784a2db 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -13,7 +13,7 @@ import qualified Network.HTTP.Types.Status as Status
import Web.Scotty hiding (delete)
import Common.Model (CreateIncomeForm (..),
- EditIncomeForm (..), Income (..),
+ EditIncomeForm (..),
IncomeHeader (..), IncomeId,
IncomePage (..), User (..))
@@ -21,7 +21,6 @@ import qualified Controller.Helper as ControllerHelper
import Model.CreateIncome (CreateIncome (..))
import Model.EditIncome (EditIncome (..))
import qualified Model.Query as Query
-import qualified Payer as Payer
import qualified Persistence.Income as IncomePersistence
import qualified Persistence.Payment as PaymentPersistence
import qualified Persistence.User as UserPersistence
@@ -36,26 +35,19 @@ list page perPage =
count <- IncomePersistence.count
users <- UserPersistence.list
- paymentRange <- PaymentPersistence.getRange
- allIncomes <- IncomePersistence.listAll -- TODO optimize
-
- let since =
- Payer.useIncomesFrom (map _user_id users) allIncomes (fst <$> paymentRange)
+ let userIds = _user_id <$> users
- let byUser =
- case since of
- Just s ->
- M.fromList . flip map users $ \user ->
- ( _user_id user
- , Payer.cumulativeIncomesSince currentTime s $
- filter ((==) (_user_id user) . _income_userId) allIncomes
- )
+ paymentRange <- PaymentPersistence.getRange
+ incomeDefinedForAll <- IncomePersistence.definedForAll userIds
+ let since = max <$> (fst <$> paymentRange) <*> incomeDefinedForAll
- Nothing ->
- M.empty
+ cumulativeIncome <-
+ case since of
+ Just s -> IncomePersistence.getCumulativeIncome s (Clock.utctDay currentTime)
+ Nothing -> return M.empty
incomes <- IncomePersistence.list page perPage
- return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json
+ return $ IncomePage page (IncomeHeader since cumulativeIncome) incomes count) >>= json
)
create :: CreateIncomeForm -> ActionM ()
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index c860810..42a4436 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -11,7 +11,6 @@ import qualified Data.Map as M
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Time.Calendar as Calendar
-import qualified Data.Time.Clock as Clock
import Data.Validation (Validation (Failure, Success))
import Web.Scotty (ActionM)
import qualified Web.Scotty as S
@@ -36,16 +35,23 @@ import qualified Validation.Payment as PaymentValidation
list :: Frequency -> Int -> Int -> Text -> ActionM ()
list frequency page perPage search =
- Secure.loggedAction (\_ -> do
- currentTime <- liftIO Clock.getCurrentTime
+ Secure.loggedAction (\_ ->
(liftIO . Query.run $ do
count <- PaymentPersistence.count frequency search
payments <- PaymentPersistence.listActivePage frequency page perPage search
users <- UserPersistence.list
- incomes <- IncomePersistence.listAll -- TODO optimize
paymentRange <- PaymentPersistence.getRange
+ incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users)
+
+ cumulativeIncome <-
+ case (incomeDefinedForAll, paymentRange) of
+ (Just incomeStart, Just (paymentStart, paymentEnd)) ->
+ IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd
+
+ _ ->
+ return M.empty
searchRepartition <-
case paymentRange of
@@ -57,7 +63,7 @@ list frequency page perPage search =
(preIncomeRepartition, postIncomeRepartition) <-
PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users
- let exceedingPayers = Payer.getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition (fst <$> paymentRange)
+ let exceedingPayers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition
header = PaymentHeader
{ _paymentHeader_exceedingPayers = exceedingPayers
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index df41cfd..ebd7084 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -12,6 +12,7 @@ import qualified Design.Constants as Constants
import qualified Design.Errors as Errors
import qualified Design.Form as Form
import qualified Design.Helper as Helper
+import qualified Design.Loadable as Loadable
import qualified Design.Media as Media
import qualified Design.Modal as Modal
import qualified Design.Tooltip as Tooltip
@@ -28,6 +29,7 @@ global = do
".tooltip" ? Tooltip.design
Views.design
Form.design
+ Loadable.design
spinKeyframes
appearKeyframe
@@ -92,14 +94,14 @@ global = do
h1 ? do
color Color.chestnutRose
- marginBottom (em 1)
- lineHeight (em 1.2)
+ lineHeight (em 1.3)
Media.desktop $ fontSize (px 24)
Media.tablet $ fontSize (px 22)
Media.mobile $ fontSize (px 20)
ul ? do
+ "margin-top" -: "1vh"
"margin-bottom" -: "3vh"
"margin-left" -: "1vh"
li do
- (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do
+ (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users) <- Query.run $ do
users <- UserPersistence.list
paymentRange <- PaymentPersistence.getRange
+ incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users)
+ cumulativeIncome <-
+ case (incomeDefinedForAll, paymentRange) of
+ (Just incomeStart, Just (paymentStart, paymentEnd)) ->
+ IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd
+
+ _ ->
+ return M.empty
weekPayments <- PaymentPersistence.listModifiedSince lastExecution
weekIncomes <- IncomePersistence.listModifiedSince lastExecution
(preIncomeRepartition, postIncomeRepartition) <-
PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users
- return (weekPayments, paymentRange, preIncomeRepartition, postIncomeRepartition, weekIncomes, users)
+ return (weekPayments, cumulativeIncome, preIncomeRepartition, postIncomeRepartition, weekIncomes, users)
_ <-
SendMail.sendMail
conf
- (WeeklyReport.mail conf users weekPayments preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) weekIncomes lastExecution now)
+ (WeeklyReport.mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition lastExecution now)
return ()
diff --git a/server/src/Payer.hs b/server/src/Payer.hs
index d913afe..ab8312e 100644
--- a/server/src/Payer.hs
+++ b/server/src/Payer.hs
@@ -1,25 +1,17 @@
module Payer
( getExceedingPayers
- , useIncomesFrom
- , cumulativeIncomesSince
) where
-import qualified Data.List as List
-import Data.Map (Map)
-import qualified Data.Map as M
-import qualified Data.Maybe as Maybe
-import Data.Time (NominalDiffTime, UTCTime (..))
-import qualified Data.Time as Time
-import Data.Time.Calendar (Day)
+import Data.Map (Map)
+import qualified Data.Map as M
-import Common.Model (ExceedingPayer (..), Income (..),
- User (..), UserId)
+import Common.Model (ExceedingPayer (..), User (..), UserId)
data Payer = Payer
{ _payer_userId :: UserId
, _payer_preIncomePayments :: Int
, _payer_postIncomePayments :: Int
- , _payer_incomes :: [Income]
+ , _payer_income :: Int
}
data PostPaymentPayer = PostPaymentPayer
@@ -29,43 +21,29 @@ data PostPaymentPayer = PostPaymentPayer
, _postPaymentPayer_ratio :: Float
}
-getExceedingPayers :: UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [ExceedingPayer]
-getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition firstPayment =
+getExceedingPayers :: [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [ExceedingPayer]
+getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition =
let userIds = map _user_id users
- payers = getPayers userIds incomes preIncomeRepartition postIncomeRepartition
- exceedingPayersOnPreIncome =
- exceedingPayersFromAmounts . map (\p -> (_payer_userId p, _payer_preIncomePayments p)) $ payers
- mbSince = useIncomesFrom userIds incomes firstPayment
- in case mbSince of
- Just since ->
- let postPaymentPayers = map (getPostPaymentPayer currentTime since) payers
- mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers
- in case mbMaxRatio of
- Just maxRatio ->
- exceedingPayersFromAmounts
- . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p))
- $ postPaymentPayers
- Nothing ->
- exceedingPayersOnPreIncome
- _ ->
- exceedingPayersOnPreIncome
-
-useIncomesFrom :: [UserId] -> [Income] -> Maybe Day -> Maybe Day
-useIncomesFrom userIds incomes firstPayment =
- case (firstPayment, incomeDefinedForAll userIds incomes) of
- (Just d1, Just d2) -> Just (max d1 d2)
- _ -> Nothing
-
-dayUTCTime :: Day -> UTCTime
-dayUTCTime = flip UTCTime (Time.secondsToDiffTime 0)
-
-getPayers :: [UserId] -> [Income] -> Map UserId Int -> Map UserId Int -> [Payer]
-getPayers userIds incomes preIncomeRepartition postIncomeRepartition =
+ payers = getPayers userIds cumulativeIncome preIncomeRepartition postIncomeRepartition
+ postPaymentPayers = map getPostPaymentPayer payers
+ mbMaxRatio = safeMaximum . map _postPaymentPayer_ratio $ postPaymentPayers
+ in case mbMaxRatio of
+ Just maxRatio ->
+ exceedingPayersFromAmounts
+ . map (\p -> (_postPaymentPayer_userId p, getFinalDiff maxRatio p))
+ $ postPaymentPayers
+ Nothing ->
+ exceedingPayersFromAmounts
+ . map (\p -> (_payer_userId p, _payer_preIncomePayments p))
+ $ payers
+
+getPayers :: [UserId] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> [Payer]
+getPayers userIds cumulativeIncome preIncomeRepartition postIncomeRepartition =
flip map userIds (\userId -> Payer
{ _payer_userId = userId
, _payer_preIncomePayments = M.findWithDefault 0 userId preIncomeRepartition
, _payer_postIncomePayments = M.findWithDefault 0 userId postIncomeRepartition
- , _payer_incomes = filter ((==) userId . _income_userId) incomes
+ , _payer_income = M.findWithDefault 0 userId cumulativeIncome
}
)
@@ -85,15 +63,14 @@ exceedingPayersFromAmounts userAmounts =
$ userAmounts
where mbMinAmount = safeMinimum . map snd $ userAmounts
-getPostPaymentPayer :: UTCTime -> Day -> Payer -> PostPaymentPayer
-getPostPaymentPayer currentTime since payer =
+getPostPaymentPayer :: Payer -> PostPaymentPayer
+getPostPaymentPayer payer =
PostPaymentPayer
{ _postPaymentPayer_userId = _payer_userId payer
, _postPaymentPayer_preIncomePayments = _payer_preIncomePayments payer
- , _postPaymentPayer_cumulativeIncome = cumulativeIncome
- , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral cumulativeIncome)
+ , _postPaymentPayer_cumulativeIncome = _payer_income payer
+ , _postPaymentPayer_ratio = (fromIntegral . _payer_postIncomePayments $ payer) / (fromIntegral $ _payer_income payer)
}
- where cumulativeIncome = cumulativeIncomesSince currentTime since (_payer_incomes payer)
getFinalDiff :: Float -> PostPaymentPayer -> Int
getFinalDiff maxRatio payer =
@@ -101,66 +78,6 @@ getFinalDiff maxRatio payer =
truncate $ -1.0 * (maxRatio - _postPaymentPayer_ratio payer) * (fromIntegral . _postPaymentPayer_cumulativeIncome $ payer)
in postIncomeDiff + _postPaymentPayer_preIncomePayments payer
-incomeDefinedForAll :: [UserId] -> [Income] -> Maybe Day
-incomeDefinedForAll userIds incomes =
- let userIncomes = map (\userId -> filter ((==) userId . _income_userId) $ incomes) userIds
- firstIncomes = map (Maybe.listToMaybe . List.sortOn _income_date) userIncomes
- in if all Maybe.isJust firstIncomes
- then Maybe.listToMaybe . reverse . List.sort . map _income_date . Maybe.catMaybes $ firstIncomes
- else Nothing
-
-cumulativeIncomesSince :: UTCTime -> Day -> [Income] -> Int
-cumulativeIncomesSince currentTime since incomes =
- getCumulativeIncome currentTime (getOrderedIncomesSince since incomes)
-
-getOrderedIncomesSince :: Day -> [Income] -> [Income]
-getOrderedIncomesSince since incomes =
- let mbStarterIncome = getIncomeAt since incomes
- orderedIncomesSince = filter (\income -> _income_date income >= since) incomes
- in (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince
-
-getIncomeAt :: Day -> [Income] -> Maybe Income
-getIncomeAt day incomes =
- case incomes of
- [x] ->
- if _income_date x < day
- then Just $ x { _income_date = day }
- else Nothing
- x1 : x2 : xs ->
- if _income_date x1 < day && _income_date x2 >= day
- then Just $ x1 { _income_date = day }
- else getIncomeAt day (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 = dayUTCTime . _income_date
-
-durationIncome :: (NominalDiffTime, Int) -> Int
-durationIncome (duration, income) =
- truncate $ duration * fromIntegral income / (nominalDay * 365 / 12)
-
-nominalDay :: NominalDiffTime
-nominalDay = 86400
-
safeMinimum :: (Ord a) => [a] -> Maybe a
safeMinimum [] = Nothing
safeMinimum xs = Just . minimum $ xs
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
index ba7ad19..e689505 100644
--- a/server/src/Persistence/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -1,21 +1,24 @@
module Persistence.Income
( count
, list
- , listAll
, listModifiedSince
, create
, edit
, delete
, definedForAll
+ , getCumulativeIncome
) where
import qualified Data.List as L
+import Data.Map (Map)
+import qualified Data.Map as M
import qualified Data.Maybe as Maybe
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
+import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)),
+ Only (Only))
import qualified Database.SQLite.Simple as SQLite
import Prelude hiding (id, until)
@@ -58,13 +61,6 @@ list page perPage =
(perPage, (page - 1) * perPage)
)
-listAll :: Query [Income]
-listAll =
- Query (\conn ->
- map (\(Row i) -> i) <$>
- SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL"
- )
-
listModifiedSince :: UTCTime -> Query [Income]
listModifiedSince since =
Query (\conn ->
@@ -79,7 +75,7 @@ listModifiedSince since =
, "OR edited_at >= ?"
, "OR deleted_at >= ?"
])
- (Only since)
+ (since, since, since)
)
create :: UserId -> Day -> Int -> Query Income
@@ -156,6 +152,46 @@ definedForAll users =
where
fromRows rows =
if L.sort users == L.sort (map fst rows) then
- Maybe.listToMaybe . L.sort . map snd $ rows
+ Maybe.listToMaybe . reverse . L.sort . map snd $ rows
else
Nothing
+
+getCumulativeIncome :: Day -> Day -> Query (Map UserId Int)
+getCumulativeIncome start end =
+ Query (\conn -> M.fromList <$> SQLite.queryNamed conn (SQLite.Query query) parameters)
+ where
+ query =
+ T.intercalate "\n" $
+ [ "SELECT user_id, CAST(ROUND(SUM(count)) AS INTEGER) FROM ("
+ , " SELECT"
+ , " I1.user_id,"
+ , " ((JULIANDAY(MIN(I2.date)) - JULIANDAY(I1.date)) * I1.amount * 12 / 365) AS count"
+ , " FROM (" <> (selectBoundedIncomes ">" ":start") <> ") AS I1"
+ , " INNER JOIN (" <> (selectBoundedIncomes "<" ":end") <> ") AS I2"
+ , " ON I2.date > I1.date AND I2.user_id == I1.user_id"
+ , " GROUP BY I1.date, I1.user_id"
+ , ") GROUP BY user_id"
+ ]
+
+ selectBoundedIncomes op param =
+ T.intercalate "\n" $
+ [ " SELECT user_id, date, amount FROM ("
+ , " SELECT"
+ , " i.user_id, " <> param <> " AS date, i.amount"
+ , " FROM"
+ , " (SELECT id, MAX(date) AS max_date"
+ , " FROM income"
+ , " WHERE date <= " <> param <> " AND deleted_at IS NULL"
+ , " GROUP BY user_id) AS m"
+ , " INNER JOIN income AS i"
+ , " ON i.id = m.id AND i.date = m.max_date"
+ , " ) UNION"
+ , " SELECT user_id, date, amount"
+ , " FROM income"
+ , " WHERE date " <> op <> " " <> param <> " AND deleted_at IS NULL"
+ ]
+
+ parameters =
+ [ ":start" := start
+ , ":end" := end
+ ]
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index f75925d..953f0ae 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -163,14 +163,14 @@ listModifiedSince since =
SQLite.query
conn
(SQLite.Query . T.intercalate " " $
- [ "SELECT *"
+ [ "SELECT " <> fields
, "FROM payment"
, "WHERE"
, "created_at >= ?"
, "OR edited_at >= ?"
, "OR deleted_at >= ?"
])
- (Only since)
+ (since, since, since)
)
@@ -300,7 +300,13 @@ searchCategory paymentName =
fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$>
SQLite.query
conn
- "SELECT category FROM payment WHERE name LIKE ? LIMIT 1"
+ (SQLite.Query . T.intercalate " " $
+ [ "SELECT category"
+ , "FROM payment"
+ , "WHERE deleted_at is NULL AND name LIKE ?"
+ , "ORDER BY edited_at, created_at"
+ , "LIMIT 1"
+ ])
(Only $ "%" <> paymentName <> "%")
)
diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs
index 1f637bc..3fe224f 100644
--- a/server/src/View/Mail/WeeklyReport.hs
+++ b/server/src/View/Mail/WeeklyReport.hs
@@ -9,7 +9,6 @@ import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
-import Data.Time.Calendar (Day)
import Data.Time.Clock (UTCTime)
import Common.Model (ExceedingPayer (..), Income (..),
@@ -27,8 +26,8 @@ import Model.PaymentResource (PaymentResource (..))
import qualified Payer as Payer
import Resource (Status (..), groupByStatus, statuses)
-mail :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Mail
-mail conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end =
+mail :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Mail
+mail conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end =
Mail
{ M.from = Conf.noReplyMail conf
, M.to = map _user_email users
@@ -37,24 +36,24 @@ mail conf users weekPayments preIncomeRepartition postIncomeRepartition firstPay
, " − "
, Msg.get Msg.WeeklyReport_Title
]
- , M.body = body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end
+ , M.body = body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end
}
-body :: Conf -> [User] -> [Payment] -> Map UserId Int -> Map UserId Int -> Maybe Day -> [Income] -> UTCTime -> UTCTime -> Text
-body conf users weekPayments preIncomeRepartition postIncomeRepartition firstPayment incomes start end =
+body :: Conf -> [User] -> [Income] -> [Payment] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> UTCTime -> UTCTime -> Text
+body conf users weekIncomes weekPayments cumulativeIncome preIncomeRepartition postIncomeRepartition start end =
T.intercalate "\n" $
- [ exceedingPayers conf end users incomes preIncomeRepartition postIncomeRepartition firstPayment
+ [ exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition
, operations conf users paymentsGroupedByStatus incomesGroupedByStatus
]
where
paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ weekPayments
- incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes
+ incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ weekIncomes
-exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> Map UserId Int -> Map UserId Int -> Maybe Day -> Text
-exceedingPayers conf time users incomes preIncomeRepartition postIncomeRepartition firstPayment =
+exceedingPayers :: Conf -> [User] -> Map UserId Int -> Map UserId Int -> Map UserId Int -> Text
+exceedingPayers conf users cumulativeIncome preIncomeRepartition postIncomeRepartition =
T.intercalate "\n" . map formatPayer $ payers
where
- payers = Payer.getExceedingPayers time users incomes preIncomeRepartition postIncomeRepartition firstPayment
+ payers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition
formatPayer p = T.concat
[ " * "
, fromMaybe "" $ _user_name <$> CM.findUser (_exceedingPayer_userId p) users
--
cgit v1.2.3
From 316bda10c6bec8b5ccc9e23f1f677c076205f046 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 8 Dec 2019 11:39:37 +0100
Subject: Add category page
---
server/server.cabal | 4 ++-
server/src/Controller/Category.hs | 66 ++++++++++++++++++++++++++++----------
server/src/Controller/Helper.hs | 11 +++----
server/src/Controller/Income.hs | 16 ++++++---
server/src/Controller/Payment.hs | 17 +++++-----
server/src/Json.hs | 16 ---------
server/src/Main.hs | 9 ++++--
server/src/Model/CreateCategory.hs | 10 ++++++
server/src/Model/EditCategory.hs | 13 ++++++++
server/src/Persistence/Category.hs | 34 +++++++++++++++++---
server/src/Persistence/Income.hs | 45 ++++++++------------------
server/src/Persistence/Payment.hs | 48 +++++++--------------------
server/src/Validation/Category.hs | 27 ++++++++++++++++
13 files changed, 187 insertions(+), 129 deletions(-)
delete mode 100644 server/src/Json.hs
create mode 100644 server/src/Model/CreateCategory.hs
create mode 100644 server/src/Model/EditCategory.hs
create mode 100644 server/src/Validation/Category.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index c9ab2c7..cc6172d 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -94,10 +94,11 @@ Executable server
Job.Model
Job.MonthlyPayment
Job.WeeklyReport
- Json
LoginSession
+ Model.CreateCategory
Model.CreateIncome
Model.CreatePayment
+ Model.EditCategory
Model.EditIncome
Model.EditPayment
Model.IncomeResource
@@ -116,6 +117,7 @@ Executable server
Secure
SendMail
Util.Time
+ Validation.Category
Validation.Income
Validation.Payment
View.Mail.SignIn
diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs
index 8fbc8c8..36ce3fc 100644
--- a/server/src/Controller/Category.hs
+++ b/server/src/Controller/Category.hs
@@ -1,5 +1,6 @@
module Controller.Category
- ( list
+ ( listAll
+ , list
, create
, edit
, delete
@@ -7,37 +8,68 @@ module Controller.Category
import Control.Monad.IO.Class (liftIO)
import qualified Data.Text.Lazy as TL
+import Data.Validation (Validation (..))
import Network.HTTP.Types.Status (badRequest400, ok200)
import Web.Scotty hiding (delete)
-import Common.Model (CategoryId, CreateCategory (..),
- EditCategory (..))
+import Common.Model (CategoryId, CategoryPage (..),
+ CreateCategoryForm (..),
+ EditCategoryForm (..))
import qualified Common.Msg as Msg
-import Json (jsonId)
+import qualified Controller.Helper as ControllerHelper
+import Model.CreateCategory (CreateCategory (..))
+import Model.EditCategory (EditCategory (..))
import qualified Model.Query as Query
import qualified Persistence.Category as CategoryPersistence
import qualified Secure
+import qualified Validation.Category as CategoryValidation
-list :: ActionM ()
-list =
+listAll :: ActionM ()
+listAll =
Secure.loggedAction (\_ ->
- (liftIO . Query.run $ CategoryPersistence.list) >>= json
+ (liftIO . Query.run $ CategoryPersistence.listAll) >>= json
)
-create :: CreateCategory -> ActionM ()
-create (CreateCategory name color) =
+list :: Int -> Int -> ActionM ()
+list page perPage =
Secure.loggedAction (\_ ->
- (liftIO . Query.run $ CategoryPersistence.create name color) >>= jsonId
+ (liftIO . Query.run $ do
+ categories <- CategoryPersistence.list page perPage
+ count <- CategoryPersistence.count
+ return $ CategoryPage page categories count
+ ) >>= json
)
-edit :: EditCategory -> ActionM ()
-edit (EditCategory categoryId name color) =
- Secure.loggedAction (\_ -> do
- updated <- liftIO . Query.run $ CategoryPersistence.edit categoryId name color
- if updated
- then status ok200
- else status badRequest400
+create :: CreateCategoryForm -> ActionM ()
+create form =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ do
+ case CategoryValidation.createCategory form of
+ Success (CreateCategory name color) -> do
+ Right <$> (CategoryPersistence.create name color)
+
+ Failure validationError ->
+ return $ Left validationError
+ ) >>= ControllerHelper.okOrBadRequest
+ )
+
+edit :: EditCategoryForm -> ActionM ()
+edit form =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ do
+ case CategoryValidation.editCategory form of
+ Success (EditCategory categoryId name color) ->
+ do
+ isSuccess <- CategoryPersistence.edit categoryId name color
+ return $ if isSuccess then
+ Right ()
+ else
+ Left $ Msg.get Msg.Error_CategoryEdit
+
+ Failure validationError ->
+ return $ Left validationError
+ ) >>= ControllerHelper.okOrBadRequest
)
delete :: CategoryId -> ActionM ()
diff --git a/server/src/Controller/Helper.hs b/server/src/Controller/Helper.hs
index fd0d2bb..dc9cbc4 100644
--- a/server/src/Controller/Helper.hs
+++ b/server/src/Controller/Helper.hs
@@ -1,17 +1,16 @@
module Controller.Helper
- ( jsonOrBadRequest
+ ( okOrBadRequest
) where
-import Data.Aeson (ToJSON)
import Data.Text (Text)
import qualified Data.Text.Lazy as LT
import qualified Network.HTTP.Types.Status as Status
import Web.Scotty (ActionM)
import qualified Web.Scotty as S
-jsonOrBadRequest :: forall a. (ToJSON a) => Either Text a -> ActionM ()
-jsonOrBadRequest (Left message) = do
+okOrBadRequest :: Either Text () -> ActionM ()
+okOrBadRequest (Left message) = do
S.status Status.badRequest400
S.text (LT.fromStrict message)
-jsonOrBadRequest (Right a) =
- S.json a
+okOrBadRequest (Right ()) =
+ S.status Status.ok200
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index 784a2db..96ccbbc 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -8,7 +8,7 @@ module Controller.Income
import Control.Monad.IO.Class (liftIO)
import qualified Data.Map as M
import qualified Data.Time.Clock as Clock
-import Data.Validation (Validation (Failure, Success))
+import Data.Validation (Validation (..))
import qualified Network.HTTP.Types.Status as Status
import Web.Scotty hiding (delete)
@@ -16,6 +16,7 @@ import Common.Model (CreateIncomeForm (..),
EditIncomeForm (..),
IncomeHeader (..), IncomeId,
IncomePage (..), User (..))
+import qualified Common.Msg as Msg
import qualified Controller.Helper as ControllerHelper
import Model.CreateIncome (CreateIncome (..))
@@ -60,7 +61,7 @@ create form =
Failure validationError ->
return $ Left validationError
- ) >>= ControllerHelper.jsonOrBadRequest
+ ) >>= ControllerHelper.okOrBadRequest
)
edit :: EditIncomeForm -> ActionM ()
@@ -68,12 +69,17 @@ edit form =
Secure.loggedAction (\user ->
(liftIO . Query.run $ do
case IncomeValidation.editIncome form of
- Success (EditIncome incomeId amount date) -> do
- Right <$> (IncomePersistence.edit (_user_id user) incomeId date amount)
+ Success (EditIncome incomeId amount date) ->
+ do
+ isSuccess <- IncomePersistence.edit (_user_id user) incomeId date amount
+ return $ if isSuccess then
+ Right ()
+ else
+ Left $ Msg.get Msg.Error_IncomeEdit
Failure validationError ->
return $ Left validationError
- ) >>= ControllerHelper.jsonOrBadRequest
+ ) >>= ControllerHelper.okOrBadRequest
)
delete :: IncomeId -> ActionM ()
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index 42a4436..d6aa34f 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -8,7 +8,6 @@ module Controller.Payment
import Control.Monad.IO.Class (liftIO)
import qualified Data.Map as M
-import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Time.Calendar as Calendar
import Data.Validation (Validation (Failure, Success))
@@ -77,30 +76,30 @@ create :: CreatePaymentForm -> ActionM ()
create form =
Secure.loggedAction (\user ->
(liftIO . Query.run $ do
- cs <- map _category_id <$> CategoryPersistence.list
+ cs <- map _category_id <$> CategoryPersistence.listAll
case PaymentValidation.createPayment cs form of
Success (CreatePayment name cost date category frequency) ->
Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency
Failure validationError ->
return $ Left validationError
- ) >>= ControllerHelper.jsonOrBadRequest
+ ) >>= ControllerHelper.okOrBadRequest
)
edit :: EditPaymentForm -> ActionM ()
edit form =
Secure.loggedAction (\user ->
(liftIO . Query.run $ do
- cs <- map _category_id <$> CategoryPersistence.list
+ cs <- map _category_id <$> CategoryPersistence.listAll
case PaymentValidation.editPayment cs form of
Success (EditPayment paymentId name cost date category frequency) -> do
- editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency
- if Maybe.isJust editedPayment then
- return . Right $ editedPayment
+ isSuccess <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency
+ return $ if isSuccess then
+ Right ()
else
- return . Left $ Msg.get Msg.Error_PaymentEdit
+ Left $ Msg.get Msg.Error_PaymentEdit
Failure validationError ->
return $ Left validationError
- ) >>= ControllerHelper.jsonOrBadRequest
+ ) >>= ControllerHelper.okOrBadRequest
)
delete :: PaymentId -> ActionM ()
diff --git a/server/src/Json.hs b/server/src/Json.hs
deleted file mode 100644
index 6d40305..0000000
--- a/server/src/Json.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module Json
- ( jsonObject
- , jsonId
- ) where
-
-import qualified Data.Aeson.Types as Json
-import qualified Data.HashMap.Strict as M
-import Data.Int (Int64)
-import Data.Text (Text)
-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/Main.hs b/server/src/Main.hs
index f4d75a0..0b80de0 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -77,8 +77,13 @@ main = do
incomeId <- S.param "id"
Income.delete incomeId
- S.get "/api/categories" $
- Category.list
+ S.get "/api/allCategories" $ do
+ Category.listAll
+
+ S.get "/api/categories" $ do
+ page <- S.param "page"
+ perPage <- S.param "perPage"
+ Category.list page perPage
S.post "/api/category" $
S.jsonData >>= Category.create
diff --git a/server/src/Model/CreateCategory.hs b/server/src/Model/CreateCategory.hs
new file mode 100644
index 0000000..dae061b
--- /dev/null
+++ b/server/src/Model/CreateCategory.hs
@@ -0,0 +1,10 @@
+module Model.CreateCategory
+ ( CreateCategory(..)
+ ) where
+
+import Data.Text (Text)
+
+data CreateCategory = CreateCategory
+ { _createCategory_name :: Text
+ , _createCategory_color :: Text
+ } deriving (Show)
diff --git a/server/src/Model/EditCategory.hs b/server/src/Model/EditCategory.hs
new file mode 100644
index 0000000..8ee26ac
--- /dev/null
+++ b/server/src/Model/EditCategory.hs
@@ -0,0 +1,13 @@
+module Model.EditCategory
+ ( EditCategory(..)
+ ) where
+
+import Data.Text (Text)
+
+import Common.Model (CategoryId)
+
+data EditCategory = EditCategory
+ { _editCategory_id :: CategoryId
+ , _editCategory_name :: Text
+ , _editCategory_color :: Text
+ } deriving (Show)
diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs
index 00cf0a5..2934b28 100644
--- a/server/src/Persistence/Category.hs
+++ b/server/src/Persistence/Category.hs
@@ -1,5 +1,7 @@
module Persistence.Category
- ( list
+ ( count
+ , list
+ , listAll
, create
, edit
, delete
@@ -27,14 +29,37 @@ instance FromRow Row where
SQLite.field <*>
SQLite.field)
-list :: Query [Category]
-list =
+data CountRow = CountRow Int
+
+instance FromRow CountRow where
+ fromRow = CountRow <$> SQLite.field
+
+count :: Query Int
+count =
+ Query (\conn ->
+ (Maybe.fromMaybe 0 . fmap (\(CountRow n) -> n) . Maybe.listToMaybe) <$>
+ SQLite.query_ conn "SELECT COUNT(*) FROM category WHERE deleted_at IS NULL"
+ )
+
+
+list :: Int -> Int -> Query [Category]
+list page perPage =
+ Query (\conn ->
+ map (\(Row c) -> c) <$>
+ SQLite.query
+ conn
+ "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY edited_at, created_at DESC LIMIT ? OFFSET ?"
+ (perPage, (page - 1) * perPage)
+ )
+
+listAll :: Query [Category]
+listAll =
Query (\conn ->
map (\(Row c) -> c) <$>
SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL"
)
-create :: Text -> Text -> Query CategoryId
+create :: Text -> Text -> Query ()
create categoryName categoryColor =
Query (\conn -> do
now <- getCurrentTime
@@ -42,7 +67,6 @@ create categoryName categoryColor =
conn
"INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)"
(categoryName, categoryColor, now)
- SQLite.lastInsertRowId conn
)
edit :: CategoryId -> Text -> Text -> Query Bool
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
index e689505..cd98814 100644
--- a/server/src/Persistence/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -78,7 +78,7 @@ listModifiedSince since =
(since, since, since)
)
-create :: UserId -> Day -> Int -> Query Income
+create :: UserId -> Day -> Int -> Query ()
create userId date amount =
Query (\conn -> do
createdAt <- getCurrentTime
@@ -86,42 +86,23 @@ create userId date amount =
conn
"INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)"
(userId, date, amount, createdAt)
- incomeId <- SQLite.lastInsertRowId conn
- return $ Income
- { _income_id = incomeId
- , _income_userId = userId
- , _income_date = date
- , _income_amount = amount
- , _income_createdAt = createdAt
- , _income_editedAt = Nothing
- , _income_deletedAt = Nothing
- }
)
-edit :: UserId -> IncomeId -> Day -> Int -> Query (Maybe Income)
+edit :: UserId -> IncomeId -> Day -> Int -> Query Bool
edit userId incomeId incomeDate incomeAmount =
Query (\conn -> do
- mbIncome <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$>
+ income <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$>
SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId)
- case mbIncome of
- Just income ->
- do
- currentTime <- getCurrentTime
- SQLite.execute
- conn
- "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?"
- (currentTime, incomeDate, incomeAmount, incomeId, userId)
- return . Just $ Income
- { _income_id = incomeId
- , _income_userId = userId
- , _income_date = incomeDate
- , _income_amount = incomeAmount
- , _income_createdAt = _income_createdAt income
- , _income_editedAt = Just currentTime
- , _income_deletedAt = Nothing
- }
- Nothing ->
- return Nothing
+ if Maybe.isJust income then
+ do
+ currentTime <- getCurrentTime
+ SQLite.execute
+ conn
+ "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?"
+ (currentTime, incomeDate, incomeAmount, incomeId, userId)
+ return True
+ else
+ return False
)
delete :: UserId -> PaymentId -> Query ()
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index 953f0ae..da877ff 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -190,30 +190,17 @@ listActiveMonthlyOrderedByName =
(Only (FrequencyField Monthly))
)
-create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Payment
+create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query ()
create userId name cost date category frequency =
Query (\conn -> do
- time <- getCurrentTime
+ currentTime <- getCurrentTime
SQLite.execute
conn
(SQLite.Query $ T.intercalate " "
[ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)"
, "VALUES (?, ?, ?, ?, ?, ?, ?)"
])
- (userId, name, cost, date, category, FrequencyField frequency, time)
- paymentId <- SQLite.lastInsertRowId conn
- return $ Payment
- { _payment_id = paymentId
- , _payment_user = userId
- , _payment_name = name
- , _payment_cost = cost
- , _payment_date = date
- , _payment_category = category
- , _payment_frequency = frequency
- , _payment_createdAt = time
- , _payment_editedAt = Nothing
- , _payment_deletedAt = Nothing
- }
+ (userId, name, cost, date, category, FrequencyField frequency, currentTime)
)
createMany :: [Payment] -> Query ()
@@ -228,17 +215,17 @@ createMany payments =
(map InsertRow payments)
)
-edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query (Maybe Payment)
+edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query Bool
edit userId paymentId name cost date category frequency =
Query (\conn -> do
- mbPayment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$>
+ payment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$>
SQLite.query
conn
(SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ? and user_id = ?")
(paymentId, userId)
- case mbPayment of
- Just payment -> do
- now <- getCurrentTime
+ if Maybe.isJust payment then
+ do
+ currentTime <- getCurrentTime
SQLite.execute
conn
(SQLite.Query $ T.intercalate " "
@@ -255,7 +242,7 @@ edit userId paymentId name cost date category frequency =
, " id = ?"
, " AND user_id = ?"
])
- ( now
+ ( currentTime
, name
, cost
, date
@@ -264,20 +251,9 @@ edit userId paymentId name cost date category frequency =
, paymentId
, userId
)
- return . Just $ Payment
- { _payment_id = paymentId
- , _payment_user = userId
- , _payment_name = name
- , _payment_cost = cost
- , _payment_date = date
- , _payment_category = category
- , _payment_frequency = frequency
- , _payment_createdAt = _payment_createdAt payment
- , _payment_editedAt = Just now
- , _payment_deletedAt = Nothing
- }
- Nothing ->
- return Nothing
+ return True
+ else
+ return False
)
delete :: UserId -> PaymentId -> Query ()
diff --git a/server/src/Validation/Category.hs b/server/src/Validation/Category.hs
new file mode 100644
index 0000000..12f2117
--- /dev/null
+++ b/server/src/Validation/Category.hs
@@ -0,0 +1,27 @@
+module Validation.Category
+ ( createCategory
+ , editCategory
+ ) where
+
+import Data.Text (Text)
+import Data.Validation (Validation)
+import qualified Data.Validation as V
+
+import Common.Model (CreateCategoryForm (..),
+ EditCategoryForm (..))
+import qualified Common.Validation.Category as CategoryValidation
+import Model.CreateCategory (CreateCategory (..))
+import Model.EditCategory (EditCategory (..))
+
+createCategory :: CreateCategoryForm -> Validation Text CreateCategory
+createCategory form =
+ CreateCategory
+ <$> CategoryValidation.name (_createCategoryForm_name form)
+ <*> CategoryValidation.color (_createCategoryForm_color form)
+
+editCategory :: EditCategoryForm -> Validation Text EditCategory
+editCategory form =
+ EditCategory
+ <$> V.Success (_editCategoryForm_id form)
+ <*> CategoryValidation.name (_editCategoryForm_name form)
+ <*> CategoryValidation.color (_editCategoryForm_color form)
--
cgit v1.2.3
From 1dfb85d3fd56d163fc854a8b3cf659d0ac39f639 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 4 Jan 2020 17:25:29 +0100
Subject: Search payments by cost too
---
server/server.cabal | 1 +
server/src/Job/WeeklyReport.hs | 2 +-
server/src/Persistence/Payment.hs | 160 ++++++++++++++++++++++----------------
server/src/Persistence/Util.hs | 11 +++
4 files changed, 107 insertions(+), 67 deletions(-)
create mode 100644 server/src/Persistence/Util.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index cc6172d..d38949d 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -113,6 +113,7 @@ Executable server
Persistence.Income
Persistence.Payment
Persistence.User
+ Persistence.Util
Resource
Secure
SendMail
diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs
index 16be396..ff80ddf 100644
--- a/server/src/Job/WeeklyReport.hs
+++ b/server/src/Job/WeeklyReport.hs
@@ -35,7 +35,7 @@ weeklyReport conf mbLastExecution = do
_ ->
return M.empty
- weekPayments <- PaymentPersistence.listModifiedSince lastExecution
+ weekPayments <- PaymentPersistence.listModifiedPunctualSince lastExecution
weekIncomes <- IncomePersistence.listModifiedSince lastExecution
(preIncomeRepartition, postIncomeRepartition) <-
PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index da877ff..a0cd580 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -3,7 +3,7 @@ module Persistence.Payment
, find
, getRange
, listActivePage
- , listModifiedSince
+ , listModifiedPunctualSince
, listActiveMonthlyOrderedByName
, create
, createMany
@@ -23,8 +23,8 @@ import Data.Time.Calendar (Day)
import qualified Data.Time.Calendar as Calendar
import Data.Time.Clock (UTCTime)
import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (FromRow (fromRow), Only (Only),
- ToRow)
+import Database.SQLite.Simple (FromRow (fromRow),
+ NamedParam ((:=)), ToRow)
import qualified Database.SQLite.Simple as SQLite
import Database.SQLite.Simple.ToField (ToField (toField))
import Prelude hiding (id, until)
@@ -32,11 +32,12 @@ import Prelude hiding (id, until)
import Common.Model (CategoryId, Frequency (..),
Payment (..), PaymentId,
User (..), UserId)
+import qualified Common.Util.Text as TextUtil
import Model.Query (Query (Query))
import Persistence.Frequency (FrequencyField (..))
import qualified Persistence.Income as IncomePersistence
-
+import qualified Persistence.Util as PersistenceUtil
fields :: Text
@@ -90,27 +91,30 @@ count :: Frequency -> Text -> Query Int
count frequency search =
Query (\conn ->
(\[Count n] -> n) <$>
- SQLite.query
+ SQLite.queryNamed
conn
(SQLite.Query $ T.intercalate " "
[ "SELECT COUNT(*)"
, "FROM payment"
, "WHERE"
, "deleted_at IS NULL"
- , "AND frequency = ?"
- , "AND name LIKE ?"
+ , "AND frequency = :frequency"
+ , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)"
])
- (FrequencyField frequency, "%" <> search <> "%")
+ [ ":frequency" := FrequencyField frequency
+ , ":search" := "%" <> TextUtil.formatSearch search <> "%"
+ ]
)
find :: PaymentId -> Query (Maybe Payment)
find paymentId =
Query (\conn -> do
fmap (\(Row p) -> p) . Maybe.listToMaybe <$>
- SQLite.query
+ SQLite.queryNamed
conn
- (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ?")
- (Only paymentId)
+ (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = :id")
+ [ "id" := paymentId
+ ]
)
data RangeRow = RangeRow (Day, Day)
@@ -122,23 +126,24 @@ getRange :: Query (Maybe (Day, Day))
getRange =
Query (\conn -> do
fmap (\(RangeRow (f, t)) -> (f, t)) . Maybe.listToMaybe <$>
- SQLite.query
+ SQLite.queryNamed
conn
(SQLite.Query $ T.intercalate " "
[ "SELECT MIN(date), MAX(date)"
, "FROM payment"
, "WHERE"
- , "frequency = ?"
+ , "frequency = :frequency"
, "AND deleted_at IS NULL"
])
- (Only (FrequencyField Punctual))
+ [ ":frequency" := FrequencyField Punctual
+ ]
)
listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment]
listActivePage frequency page perPage search =
Query (\conn ->
map (\(Row p) -> p) <$>
- SQLite.query
+ SQLite.queryNamed
conn
(SQLite.Query $ T.intercalate " "
[ "SELECT"
@@ -146,31 +151,36 @@ listActivePage frequency page perPage search =
, "FROM payment"
, "WHERE"
, "deleted_at IS NULL"
- , "AND frequency = ?"
- , "AND name LIKE ?"
+ , "AND frequency = :frequency"
+ , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)"
, "ORDER BY date DESC"
- , "LIMIT ?"
- , "OFFSET ?"
+ , "LIMIT :limit"
+ , "OFFSET :offset"
]
)
- (FrequencyField frequency, "%" <> search <> "%", perPage, (page - 1) * perPage)
+ [ ":frequency" := FrequencyField frequency
+ , ":search" := "%" <> TextUtil.formatSearch search <> "%"
+ , ":limit" := perPage
+ , ":offset" := (page - 1) * perPage
+ ]
)
-listModifiedSince :: UTCTime -> Query [Payment]
-listModifiedSince since =
+listModifiedPunctualSince :: UTCTime -> Query [Payment]
+listModifiedPunctualSince since =
Query (\conn ->
map (\(Row i) -> i) <$>
- SQLite.query
+ SQLite.queryNamed
conn
(SQLite.Query . T.intercalate " " $
[ "SELECT " <> fields
, "FROM payment"
, "WHERE"
- , "created_at >= ?"
- , "OR edited_at >= ?"
- , "OR deleted_at >= ?"
+ , "frequency = :frequency"
+ , "AND (created_at >= :since OR edited_at >= :since OR deleted_at >= :since)"
])
- (since, since, since)
+ [ ":frequency" := FrequencyField Punctual
+ , ":since" := since
+ ]
)
@@ -178,29 +188,37 @@ listActiveMonthlyOrderedByName :: Query [Payment]
listActiveMonthlyOrderedByName =
Query (\conn -> do
map (\(Row p) -> p) <$>
- SQLite.query
+ SQLite.queryNamed
conn
(SQLite.Query $ T.intercalate " "
[ "SELECT"
, fields
, "FROM payment"
- , "WHERE deleted_at IS NULL AND frequency = ?"
+ , "WHERE deleted_at IS NULL AND frequency = :frequency"
, "ORDER BY name DESC"
])
- (Only (FrequencyField Monthly))
+ [ ":frequency" := FrequencyField Monthly
+ ]
)
create :: UserId -> Text -> Int -> Day -> CategoryId -> Frequency -> Query ()
create userId name cost date category frequency =
Query (\conn -> do
currentTime <- getCurrentTime
- SQLite.execute
+ SQLite.executeNamed
conn
(SQLite.Query $ T.intercalate " "
[ "INSERT INTO payment (user_id, name, cost, date, category, frequency, created_at)"
- , "VALUES (?, ?, ?, ?, ?, ?, ?)"
+ , "VALUES (:userId, :name, :cost, :date, :category, :frequency, :currentTime)"
])
- (userId, name, cost, date, category, FrequencyField frequency, currentTime)
+ [ ":userId" := userId
+ , ":name" := name
+ , ":cost" := cost
+ , ":date" := date
+ , ":category" := category
+ , ":frequency" := FrequencyField frequency
+ , ":currentTime" := currentTime
+ ]
)
createMany :: [Payment] -> Query ()
@@ -219,38 +237,41 @@ edit :: UserId -> PaymentId -> Text -> Int -> Day -> CategoryId -> Frequency ->
edit userId paymentId name cost date category frequency =
Query (\conn -> do
payment <- fmap (\(Row p) -> p) . Maybe.listToMaybe <$>
- SQLite.query
+ SQLite.queryNamed
conn
- (SQLite.Query $ "SELECT " <> fields <> " FROM payment WHERE id = ? and user_id = ?")
- (paymentId, userId)
+ (SQLite.Query $
+ "SELECT " <> fields <> " FROM payment WHERE id = :paymentId and user_id = :userId")
+ [ ":paymentId" := paymentId
+ , ":userId" := userId
+ ]
if Maybe.isJust payment then
do
currentTime <- getCurrentTime
- SQLite.execute
+ SQLite.executeNamed
conn
(SQLite.Query $ T.intercalate " "
[ "UPDATE"
, " payment"
, "SET"
- , " edited_at = ?,"
- , " name = ?,"
- , " cost = ?,"
- , " date = ?,"
- , " category = ?,"
- , " frequency = ?"
+ , " edited_at = :editedAt,"
+ , " name = :name,"
+ , " cost = :cost,"
+ , " date = :date,"
+ , " category = :category,"
+ , " frequency = :frequency"
, "WHERE"
- , " id = ?"
- , " AND user_id = ?"
+ , " id = :id"
+ , " AND user_id = :userId"
])
- ( currentTime
- , name
- , cost
- , date
- , category
- , FrequencyField frequency
- , paymentId
- , userId
- )
+ [ ":editedAt" := currentTime
+ , ":name" := name
+ , ":cost" := cost
+ , ":date" := date
+ , ":category" := category
+ , ":frequency" := FrequencyField frequency
+ , ":id" := paymentId
+ , ":userId" := userId
+ ]
return True
else
return False
@@ -259,10 +280,12 @@ edit userId paymentId name cost date category frequency =
delete :: UserId -> PaymentId -> Query ()
delete userId paymentId =
Query (\conn ->
- SQLite.execute
+ SQLite.executeNamed
conn
- "UPDATE payment SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?"
- (paymentId, userId)
+ "UPDATE payment SET deleted_at = datetime('now') WHERE id = :id AND user_id = :userId"
+ [ ":id" := paymentId
+ , ":userId" := userId
+ ]
)
data CategoryIdRow = CategoryIdRow CategoryId
@@ -274,16 +297,17 @@ searchCategory :: Text -> Query (Maybe CategoryId)
searchCategory paymentName =
Query (\conn ->
fmap (\(CategoryIdRow d) -> d) . Maybe.listToMaybe <$>
- SQLite.query
+ SQLite.queryNamed
conn
(SQLite.Query . T.intercalate " " $
[ "SELECT category"
, "FROM payment"
- , "WHERE deleted_at is NULL AND name LIKE ?"
+ , "WHERE deleted_at is NULL AND name LIKE :name"
, "ORDER BY edited_at, created_at"
, "LIMIT 1"
])
- (Only $ "%" <> paymentName <> "%")
+ [ ":name" := "%" <> paymentName <> "%"
+ ]
)
data UserCostRow = UserCostRow (UserId, Int)
@@ -297,20 +321,24 @@ instance FromRow UserCostRow where
repartition :: Frequency -> Text -> Day -> Day -> Query (Map UserId Int)
repartition frequency search from to =
Query (\conn ->
- M.fromList . fmap (\(UserCostRow r) -> r) <$> SQLite.query
+ M.fromList . fmap (\(UserCostRow r) -> r) <$> SQLite.queryNamed
conn
(SQLite.Query . T.intercalate " " $
[ "SELECT user_id, SUM(cost)"
, "FROM payment"
, "WHERE"
, "deleted_at IS NULL"
- , "AND frequency = ?"
- , "AND name LIKE ?"
- , "AND date >= ?"
- , "AND date < ?"
+ , "AND frequency = :frequency"
+ , "AND (" <> PersistenceUtil.formatKeyForSearch "name" <> " LIKE :search OR cost LIKE :search)"
+ , "AND date >= :from"
+ , "AND date < :to"
, "GROUP BY user_id"
])
- (FrequencyField frequency, "%" <> search <> "%", from, to)
+ [ ":frequency" := FrequencyField frequency
+ , ":search" := "%" <> TextUtil.formatSearch search <> "%"
+ , ":from" := from
+ , ":to" := to
+ ]
)
getPreAndPostPaymentRepartition :: Maybe (Day, Day) -> [User] -> Query (Map UserId Int, Map UserId Int)
diff --git a/server/src/Persistence/Util.hs b/server/src/Persistence/Util.hs
new file mode 100644
index 0000000..b7496c6
--- /dev/null
+++ b/server/src/Persistence/Util.hs
@@ -0,0 +1,11 @@
+module Persistence.Util
+ ( formatKeyForSearch
+ ) where
+
+import Data.Text (Text)
+
+formatKeyForSearch :: Text -> Text
+formatKeyForSearch key =
+ "replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(replace(lower("
+ <> key
+ <> "), 'à', 'a'), 'â', 'a'), 'ç', 'c'), 'è', 'e'), 'é', 'e'), 'ê', 'e'), 'ë', 'e'), 'î', 'i'), 'ï', 'i'), 'ô', 'o'), 'ù', 'u'), 'û', 'u'), 'ü', 'u')"
--
cgit v1.2.3
From da2a0c13aa89705c65fdb9df2f496fb4eea29654 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 4 Jan 2020 19:22:45 +0100
Subject: Allow to remove only unused categories
---
server/src/Controller/Category.hs | 5 +--
server/src/Persistence/Category.hs | 64 +++++++++++++++++++++++++-------------
server/src/Persistence/Payment.hs | 14 +++++++++
3 files changed, 59 insertions(+), 24 deletions(-)
(limited to 'server')
diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs
index 36ce3fc..371ba78 100644
--- a/server/src/Controller/Category.hs
+++ b/server/src/Controller/Category.hs
@@ -22,6 +22,7 @@ import Model.CreateCategory (CreateCategory (..))
import Model.EditCategory (EditCategory (..))
import qualified Model.Query as Query
import qualified Persistence.Category as CategoryPersistence
+import qualified Persistence.Payment as PaymentPersistence
import qualified Secure
import qualified Validation.Category as CategoryValidation
@@ -36,8 +37,9 @@ list page perPage =
Secure.loggedAction (\_ ->
(liftIO . Query.run $ do
categories <- CategoryPersistence.list page perPage
+ usedCategories <- PaymentPersistence.usedCategories
count <- CategoryPersistence.count
- return $ CategoryPage page categories count
+ return $ CategoryPage page categories usedCategories count
) >>= json
)
@@ -76,7 +78,6 @@ delete :: CategoryId -> ActionM ()
delete categoryId =
Secure.loggedAction (\_ -> do
deleted <- liftIO . Query.run $ do
- -- TODO: delete only if no payment has this category
CategoryPersistence.delete categoryId
if deleted
then
diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs
index 2934b28..b0a6fca 100644
--- a/server/src/Persistence/Category.hs
+++ b/server/src/Persistence/Category.hs
@@ -10,7 +10,7 @@ module Persistence.Category
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
+import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)))
import qualified Database.SQLite.Simple as SQLite
import Prelude hiding (id)
@@ -46,10 +46,12 @@ list :: Int -> Int -> Query [Category]
list page perPage =
Query (\conn ->
map (\(Row c) -> c) <$>
- SQLite.query
+ SQLite.queryNamed
conn
- "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY edited_at, created_at DESC LIMIT ? OFFSET ?"
- (perPage, (page - 1) * perPage)
+ "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY name LIMIT :limit OFFSET :offset"
+ [ ":limit" := perPage
+ , ":offset" := (page - 1) * perPage
+ ]
)
listAll :: Query [Category]
@@ -60,43 +62,61 @@ listAll =
)
create :: Text -> Text -> Query ()
-create categoryName categoryColor =
+create name color =
Query (\conn -> do
- now <- getCurrentTime
- SQLite.execute
+ currentTime <- getCurrentTime
+ SQLite.executeNamed
conn
- "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)"
- (categoryName, categoryColor, now)
+ "INSERT INTO category (name, color, created_at) VALUES (:name, :color, :created_at)"
+ [ ":name" := name
+ , ":color" := color
+ , ":created_at" := currentTime
+ ]
)
edit :: CategoryId -> Text -> Text -> Query Bool
-edit categoryId categoryName categoryColor =
+edit id name color =
Query (\conn -> do
mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$>
- (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
+ (SQLite.queryNamed conn "SELECT * FROM category WHERE id = :id" [ ":id" := id ])
if Maybe.isJust mbCategory
then do
- now <- getCurrentTime
- SQLite.execute
+ currentTime <- getCurrentTime
+ SQLite.executeNamed
conn
- "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?"
- (now, categoryName, categoryColor, categoryId)
+ "UPDATE category SET edited_at = :editedAt, name = :name, color = :color WHERE id = :id"
+ [ ":editedAt" := currentTime
+ , ":name" := name
+ , ":color" := color
+ , ":id" := id
+ ]
return True
else
return False
)
+data BoolRow = BoolRow Int
+
+instance FromRow BoolRow where
+ fromRow = BoolRow <$> SQLite.field
+
delete :: CategoryId -> Query Bool
-delete categoryId =
+delete id =
Query (\conn -> do
- mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$>
- (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
- if Maybe.isJust mbCategory
+ mbPayment <- (fmap (\(BoolRow b) -> b) . Maybe.listToMaybe) <$>
+ (SQLite.queryNamed
+ conn
+ "SELECT true FROM payment WHERE category = :id AND deleted_at IS NULL"
+ [ ":id" := id ])
+ if Maybe.isNothing mbPayment
then do
- now <- getCurrentTime
- SQLite.execute
+ currentTime <- getCurrentTime
+ SQLite.executeNamed
conn
- "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId)
+ "UPDATE category SET deleted_at = :deletedAt WHERE id = :id AND deleted_at IS NULL"
+ [ ":deletedAt" := currentTime
+ , ":id" := id
+ ]
return True
else
return False
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index a0cd580..b3eb141 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -12,6 +12,7 @@ module Persistence.Payment
, searchCategory
, repartition
, getPreAndPostPaymentRepartition
+ , usedCategories
) where
import Data.Map (Map)
@@ -310,6 +311,19 @@ searchCategory paymentName =
]
)
+usedCategories :: Query [CategoryId]
+usedCategories =
+ Query (\conn -> do
+ map (\(CategoryIdRow p) -> p) <$>
+ SQLite.query_
+ conn
+ (SQLite.Query $ T.intercalate " "
+ [ "SELECT DISTINCT category"
+ , "FROM payment"
+ , "WHERE deleted_at IS NULL"
+ ])
+ )
+
data UserCostRow = UserCostRow (UserId, Int)
instance FromRow UserCostRow where
--
cgit v1.2.3
From fff99e6fb1c03235e219a94ce52acf5a50d3fb62 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 5 Jan 2020 16:03:48 +0100
Subject: Use named parameters instead of positional parameters in persistence
queries
---
server/src/Persistence/Income.hs | 56 ++++++++++++++++++++++++----------------
server/src/Persistence/User.hs | 9 ++++---
2 files changed, 40 insertions(+), 25 deletions(-)
(limited to 'server')
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
index cd98814..76cb952 100644
--- a/server/src/Persistence/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -17,8 +17,7 @@ import qualified Data.Text as T
import Data.Time.Calendar (Day)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)),
- Only (Only))
+import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)))
import qualified Database.SQLite.Simple as SQLite
import Prelude hiding (id, until)
@@ -55,63 +54,76 @@ list :: Int -> Int -> Query [Income]
list page perPage =
Query (\conn ->
map (\(Row i) -> i) <$>
- SQLite.query
+ SQLite.queryNamed
conn
- "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC LIMIT ? OFFSET ?"
- (perPage, (page - 1) * perPage)
+ "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC LIMIT :limit OFFSET :offset"
+ [ ":limit" := perPage
+ , ":offset" := (page - 1) * perPage
+ ]
)
listModifiedSince :: UTCTime -> Query [Income]
listModifiedSince since =
Query (\conn ->
map (\(Row i) -> i) <$>
- SQLite.query
+ SQLite.queryNamed
conn
(SQLite.Query . T.intercalate " " $
[ "SELECT *"
, "FROM income"
, "WHERE"
- , "created_at >= ?"
- , "OR edited_at >= ?"
- , "OR deleted_at >= ?"
+ , "created_at >= :since"
+ , "OR edited_at >= :since"
+ , "OR deleted_at >= :since"
])
- (since, since, since)
+ [ ":since" := since ]
)
create :: UserId -> Day -> Int -> Query ()
create userId date amount =
Query (\conn -> do
createdAt <- getCurrentTime
- SQLite.execute
+ SQLite.executeNamed
conn
- "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)"
- (userId, date, amount, createdAt)
+ "INSERT INTO income (user_id, date, amount, created_at) VALUES (:userId, :date, :amount, :createdAt)"
+ [ ":userId" := userId
+ , ":date" := date
+ , ":amount" := amount
+ , ":createdAt" := createdAt
+ ]
)
edit :: UserId -> IncomeId -> Day -> Int -> Query Bool
-edit userId incomeId incomeDate incomeAmount =
+edit userId id date amount =
Query (\conn -> do
income <- fmap (\(Row i) -> i) . Maybe.listToMaybe <$>
- SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId)
+ SQLite.queryNamed conn "SELECT * FROM income WHERE id = :id" [ ":id" := id ]
if Maybe.isJust income then
do
currentTime <- getCurrentTime
- SQLite.execute
+ SQLite.executeNamed
conn
- "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ? AND user_id = ?"
- (currentTime, incomeDate, incomeAmount, incomeId, userId)
+ "UPDATE income SET edited_at = :editedAt, date = :date, amount = :amount WHERE id = :id AND user_id = :userId"
+ [ ":editedAt" := currentTime
+ , ":date" := date
+ , ":amount" := amount
+ , ":id" := id
+ , ":userId" := userId
+ ]
return True
else
return False
)
delete :: UserId -> PaymentId -> Query ()
-delete userId paymentId =
+delete userId id =
Query (\conn ->
- SQLite.execute
+ SQLite.executeNamed
conn
- "UPDATE income SET deleted_at = datetime('now') WHERE id = ? AND user_id = ?"
- (paymentId, userId)
+ "UPDATE income SET deleted_at = datetime('now') WHERE id = :id AND user_id = :userId"
+ [ ":id" := id
+ , ":userId" := userId
+ ]
)
data UserDayRow = UserDayRow (UserId, Day)
diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs
index 3c3a2b1..89eb57d 100644
--- a/server/src/Persistence/User.hs
+++ b/server/src/Persistence/User.hs
@@ -5,7 +5,7 @@ module Persistence.User
import qualified Data.Maybe as Maybe
import Data.Text (Text)
-import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
+import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)))
import qualified Database.SQLite.Simple as SQLite
import Prelude hiding (id)
@@ -30,8 +30,11 @@ list =
)
get :: Text -> Query (Maybe User)
-get userEmail =
+get email =
Query (\conn -> do
fmap (\(Row u) -> u) . Maybe.listToMaybe <$>
- SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail)
+ SQLite.queryNamed
+ conn
+ "SELECT * FROM user WHERE email = :email LIMIT 1"
+ [ ":email" := email ]
)
--
cgit v1.2.3
From bc48d7428607c84003658d5b88d41cf923d010fd Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 18 Jan 2020 16:18:26 +0100
Subject: Add deploy command
---
server/migrations/2.sql | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
(limited to 'server')
diff --git a/server/migrations/2.sql b/server/migrations/2.sql
index efed046..c1d502f 100644
--- a/server/migrations/2.sql
+++ b/server/migrations/2.sql
@@ -35,10 +35,10 @@ UPDATE
SET
category = (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name))
WHERE
- EXISTS (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name))
+ EXISTS (SELECT category FROM payment_category WHERE payment_category.name = LOWER(payment.name));
DELETE FROM payment WHERE category = -1;
-- Remove
-DROP TABLE payment_category
+DROP TABLE payment_category;
--
cgit v1.2.3
From af8353c6164aaaaa836bfed181f883ac86bb76a5 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 19 Jan 2020 14:03:31 +0100
Subject: Sign in with email and password
---
server/migrations/3.sql | 5 ++
server/server.cabal | 4 +-
server/src/Controller/Index.hs | 128 ++++++++++++-------------------------
server/src/Main.hs | 8 +--
server/src/Model/HashedPassword.hs | 27 ++++++++
server/src/Model/SignIn.hs | 60 +----------------
server/src/Persistence/User.hs | 48 ++++++++++++--
server/src/Secure.hs | 27 ++------
server/src/Validation/SignIn.hs | 16 +++++
server/src/View/Mail/SignIn.hs | 21 ------
server/src/View/Page.hs | 9 +--
11 files changed, 153 insertions(+), 200 deletions(-)
create mode 100644 server/migrations/3.sql
create mode 100644 server/src/Model/HashedPassword.hs
create mode 100644 server/src/Validation/SignIn.hs
delete mode 100644 server/src/View/Mail/SignIn.hs
(limited to 'server')
diff --git a/server/migrations/3.sql b/server/migrations/3.sql
new file mode 100644
index 0000000..a3d8a13
--- /dev/null
+++ b/server/migrations/3.sql
@@ -0,0 +1,5 @@
+DROP TABLE sign_in;
+
+ALTER TABLE user ADD COLUMN "password" TEXT NOT NULL DEFAULT "password";
+
+ALTER TABLE user ADD COLUMN "sign_in_token" TEXT NULL;
diff --git a/server/server.cabal b/server/server.cabal
index d38949d..7ef5328 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -25,6 +25,7 @@ Executable server
aeson
, base >= 4.11 && < 5
, base64-bytestring
+ , bcrypt
, blaze-builder
, blaze-html
, bytestring
@@ -101,6 +102,7 @@ Executable server
Model.EditCategory
Model.EditIncome
Model.EditPayment
+ Model.HashedPassword
Model.IncomeResource
Model.Mail
Model.PaymentResource
@@ -121,6 +123,6 @@ Executable server
Validation.Category
Validation.Income
Validation.Payment
- View.Mail.SignIn
+ Validation.SignIn
View.Mail.WeeklyReport
View.Page
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index 3788685..4f4ae77 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -1,120 +1,76 @@
module Controller.Index
( get
- , askSignIn
- , trySignIn
+ , signIn
, signOut
) where
import Control.Monad.IO.Class (liftIO)
-import qualified Data.Aeson as Json
import Data.Text (Text)
-import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
-import Data.Time.Clock (diffUTCTime, getCurrentTime)
+import Data.Validation (Validation (..))
import qualified Network.HTTP.Types.Status as Status
-import Prelude hiding (error)
+import Prelude hiding (error, init)
import Web.Scotty (ActionM)
import qualified Web.Scotty as S
-import Common.Model (Email (..), Init (..),
- InitResult (..), SignInForm (..),
+import Common.Model (Init (..), SignInForm (..),
User (..))
-import Common.Msg (Key)
import qualified Common.Msg as Msg
-import qualified Common.Validation.SignIn as SignInValidation
import Conf (Conf (..))
import qualified LoginSession
+import Model.Query (Query)
import qualified Model.Query as Query
-import qualified Model.SignIn as SignIn
+import Model.SignIn (SignIn (..))
import qualified Persistence.User as UserPersistence
-import qualified Secure
-import qualified SendMail
-import qualified View.Mail.SignIn as SignIn
+import qualified Validation.SignIn as SignInValidation
import View.Page (page)
get :: Conf -> ActionM ()
get conf = do
- initResult <- do
- mbLoggedUser <- getLoggedUser
- case mbLoggedUser of
+ init <- do
+ mbToken <- LoginSession.get
+ case mbToken of
Nothing ->
- return InitEmpty
- Just user -> do
- users <- liftIO . Query.run $ UserPersistence.list
- return . InitSuccess $ Init users (_user_id user) (Conf.currency conf)
- S.html $ page initResult
+ return Nothing
+ Just token -> do
+ liftIO . Query.run $ getInit conf token
+ S.html $ page init
-askSignIn :: Conf -> SignInForm -> ActionM ()
-askSignIn conf form =
+signIn :: Conf -> SignInForm -> ActionM ()
+signIn conf form =
case SignInValidation.signIn form of
- Nothing ->
- textKey Status.badRequest400 Msg.SignIn_EmailInvalid
- Just (Email email) -> do
- maybeUser <- liftIO . Query.run $ UserPersistence.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,
- "/api/signIn/",
- token
- ]
- maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email]
- case maybeSentMail of
- Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent)
- Left _ -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail
- Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized
- where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key)
+ Failure _ ->
+ textKey Status.badRequest400 Msg.SignIn_InvalidCredentials
+ Success (SignIn email password) -> do
+ result <- liftIO . Query.run $ do
+ isPasswordValid <- UserPersistence.checkPassword email password
+ if isPasswordValid then
+ do
+ signInToken <- UserPersistence.createSignInToken email
+ init <- getInit conf signInToken
+ return $ Just (signInToken, init)
+ else
+ return Nothing
+ case result of
+ Just (signInToken, init) -> do
+ LoginSession.put conf signInToken
+ S.json init
-trySignIn :: Conf -> Text -> ActionM ()
-trySignIn conf token = do
- userOrError <- validateSignIn conf token
- case userOrError of
- Left errorKey ->
- S.html $ page (InitError $ Msg.get errorKey)
- Right _ ->
- S.redirect "/"
-
-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 $ Msg.SignIn_LinkInvalid
- Just signIn ->
- if SignIn.isUsed signIn
- then
- return . Left $ Msg.SignIn_LinkUsed
- else
- let diffTime = now `diffUTCTime` (SignIn.creation signIn)
- in if diffTime > signInExpiration conf
- then
- return . Left $ Msg.SignIn_LinkExpired
- else do
- LoginSession.put conf (SignIn.token signIn)
- mbUser <- liftIO . Query.run $ do
- SignIn.signInTokenToUsed . SignIn.id $ signIn
- UserPersistence.get . SignIn.email $ signIn
- return $ case mbUser of
- Nothing -> Left Msg.Secure_Unauthorized
- Just user -> Right user
+ textKey Status.badRequest400 Msg.SignIn_InvalidCredentials
+ where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key)
-getLoggedUser :: ActionM (Maybe User)
-getLoggedUser = do
- mbToken <- LoginSession.get
- case mbToken of
+getInit :: Conf -> Text -> Query (Maybe Init)
+getInit conf signInToken = do
+ user <- UserPersistence.get signInToken
+ case user of
+ Just u ->
+ do
+ users <- UserPersistence.list
+ return . Just $ Init users (_user_id u) (Conf.currency conf)
Nothing ->
return Nothing
- Just token -> do
- liftIO . Query.run . Secure.getUserFromToken $ token
signOut :: Conf -> ActionM ()
signOut conf = LoginSession.delete conf >> S.status Status.ok200
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 0b80de0..324557e 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -28,12 +28,8 @@ main = do
S.middleware . staticPolicy $
noDots >-> addBase "public"
- S.post "/api/askSignIn" $
- S.jsonData >>= Index.askSignIn conf
-
- S.get "/api/signIn/:signInToken" $ do
- signInToken <- S.param "signInToken"
- Index.trySignIn conf signInToken
+ S.post "/api/signIn" $
+ S.jsonData >>= Index.signIn conf
S.post "/api/signOut" $
Index.signOut conf
diff --git a/server/src/Model/HashedPassword.hs b/server/src/Model/HashedPassword.hs
new file mode 100644
index 0000000..c71e372
--- /dev/null
+++ b/server/src/Model/HashedPassword.hs
@@ -0,0 +1,27 @@
+module Model.HashedPassword
+ ( hash
+ , check
+ , HashedPassword(..)
+ ) where
+
+import qualified Crypto.BCrypt as BCrypt
+import Data.Text (Text)
+import qualified Data.Text.Encoding as TE
+
+import Common.Model.Password (Password (..))
+
+newtype HashedPassword = HashedPassword Text deriving (Show)
+
+hash :: Password -> IO (Maybe HashedPassword)
+hash (Password p) = do
+ hashed <- BCrypt.hashPasswordUsingPolicy BCrypt.slowerBcryptHashingPolicy (TE.encodeUtf8 p)
+ case hashed of
+ Nothing ->
+ return Nothing
+
+ Just h ->
+ return . Just . HashedPassword . TE.decodeUtf8 $ h
+
+check :: Password -> HashedPassword -> Bool
+check (Password p) (HashedPassword h) =
+ BCrypt.validatePassword (TE.encodeUtf8 h) (TE.encodeUtf8 p)
diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs
index bcdce61..a217bae 100644
--- a/server/src/Model/SignIn.hs
+++ b/server/src/Model/SignIn.hs
@@ -1,64 +1,10 @@
module Model.SignIn
( SignIn(..)
- , createSignInToken
- , getSignIn
- , signInTokenToUsed
- , isLastTokenValid
) where
-import Data.Int (Int64)
-import qualified Data.Maybe as Maybe
-import Data.Text (Text)
-import Data.Time.Clock (getCurrentTime)
-import Data.Time.Clock (UTCTime)
-import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
-import qualified Database.SQLite.Simple as SQLite
-
-import Model.Query (Query (Query))
-import Model.UUID (generateUUID)
-
-type SignInId = Int64
+import Common.Model (Email, Password)
data SignIn = SignIn
- { id :: SignInId
- , token :: Text
- , creation :: UTCTime
- , email :: Text
- , isUsed :: Bool
+ { _signIn_email :: Email
+ , _signIn_password :: Password
} 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
- Maybe.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/Persistence/User.hs b/server/src/Persistence/User.hs
index 89eb57d..12145ac 100644
--- a/server/src/Persistence/User.hs
+++ b/server/src/Persistence/User.hs
@@ -1,17 +1,21 @@
module Persistence.User
( list
, get
+ , checkPassword
+ , createSignInToken
) where
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)))
import qualified Database.SQLite.Simple as SQLite
-import Prelude hiding (id)
-import Common.Model (User (..))
+import Common.Model (Email (..), Password (..), User (..))
+import Model.HashedPassword (HashedPassword (..))
+import qualified Model.HashedPassword as HashedPassword
import Model.Query (Query (Query))
+import qualified Model.UUID as UUID
newtype Row = Row User
@@ -26,15 +30,49 @@ list :: Query [User]
list =
Query (\conn -> do
map (\(Row u) -> u) <$>
- SQLite.query_ conn "SELECT * from user ORDER BY creation DESC"
+ SQLite.query_ conn "SELECT id, creation, email, name from user ORDER BY creation DESC"
)
get :: Text -> Query (Maybe User)
-get email =
+get token =
Query (\conn -> do
fmap (\(Row u) -> u) . Maybe.listToMaybe <$>
SQLite.queryNamed
conn
- "SELECT * FROM user WHERE email = :email LIMIT 1"
+ "SELECT id, creation, email, name FROM user WHERE sign_in_token = :sign_in_token LIMIT 1"
+ [ ":sign_in_token" := token ]
+ )
+
+data HashedPasswordRow = HashedPasswordRow HashedPassword
+
+instance FromRow HashedPasswordRow where
+ fromRow = HashedPasswordRow <$> (HashedPassword <$> SQLite.field)
+
+checkPassword :: Email -> Password -> Query Bool
+checkPassword (Email email) password =
+ Query (\conn -> do
+ hashedPassword <- fmap (\(HashedPasswordRow p) -> p) . Maybe.listToMaybe <$>
+ SQLite.queryNamed
+ conn
+ "SELECT password FROM user WHERE email = :email LIMIT 1"
[ ":email" := email ]
+ case hashedPassword of
+ Just h ->
+ return (HashedPassword.check password h)
+
+ Nothing ->
+ return False
+ )
+
+createSignInToken :: Email -> Query Text
+createSignInToken (Email email) =
+ Query (\conn -> do
+ token <- UUID.generateUUID
+ SQLite.executeNamed
+ conn
+ "UPDATE user SET sign_in_token = :sign_in_token WHERE email = :email"
+ [ ":sign_in_token" := token
+ , ":email" := email
+ ]
+ return token
)
diff --git a/server/src/Secure.hs b/server/src/Secure.hs
index 4fb2333..a30941f 100644
--- a/server/src/Secure.hs
+++ b/server/src/Secure.hs
@@ -1,21 +1,17 @@
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 qualified Data.Text.Lazy as TL
+import qualified Network.HTTP.Types.Status as HTTP
import Web.Scotty
import Common.Model (User)
import qualified Common.Msg as Msg
import qualified LoginSession
-import Model.Query (Query)
import qualified Model.Query as Query
-import qualified Model.SignIn as SignIn
import qualified Persistence.User as UserPersistence
loggedAction :: (User -> ActionM ()) -> ActionM ()
@@ -23,22 +19,13 @@ loggedAction action = do
maybeToken <- LoginSession.get
case maybeToken of
Just token -> do
- maybeUser <- liftIO . Query.run . getUserFromToken $ token
+ maybeUser <- liftIO . Query.run . UserPersistence.get $ token
case maybeUser of
Just user ->
action user
Nothing -> do
- status forbidden403
- html . fromStrict . Msg.get $ Msg.Secure_Unauthorized
+ status HTTP.forbidden403
+ html . TL.fromStrict . Msg.get $ Msg.Secure_Unauthorized
Nothing -> do
- status forbidden403
- html . fromStrict . Msg.get $ Msg.Secure_Forbidden
-
-getUserFromToken :: Text -> Query (Maybe User)
-getUserFromToken token = do
- mbSignIn <- SignIn.getSignIn token
- case mbSignIn of
- Just signIn ->
- UserPersistence.get (SignIn.email signIn)
- Nothing ->
- return Nothing
+ status HTTP.forbidden403
+ html . TL.fromStrict . Msg.get $ Msg.Secure_Forbidden
diff --git a/server/src/Validation/SignIn.hs b/server/src/Validation/SignIn.hs
new file mode 100644
index 0000000..dc86122
--- /dev/null
+++ b/server/src/Validation/SignIn.hs
@@ -0,0 +1,16 @@
+module Validation.SignIn
+ ( signIn
+ ) where
+
+import Data.Text (Text)
+import Data.Validation (Validation)
+
+import Common.Model (SignInForm (..))
+import qualified Common.Validation.SignIn as SignInValidation
+import Model.SignIn (SignIn (..))
+
+signIn :: SignInForm -> Validation Text SignIn
+signIn form =
+ SignIn
+ <$> SignInValidation.email (_signInForm_email form)
+ <*> SignInValidation.password (_signInForm_password form)
diff --git a/server/src/View/Mail/SignIn.hs b/server/src/View/Mail/SignIn.hs
deleted file mode 100644
index 3c5469f..0000000
--- a/server/src/View/Mail/SignIn.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module View.Mail.SignIn
- ( mail
- ) where
-
-import Data.Text (Text)
-
-import Common.Model (User (..))
-import qualified Common.Msg as Msg
-
-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 = Msg.get Msg.SignIn_MailTitle
- , M.body = Msg.get (Msg.SignIn_MailBody (_user_name user) url)
- }
diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs
index f47c544..4ada5f7 100644
--- a/server/src/View/Page.hs
+++ b/server/src/View/Page.hs
@@ -6,6 +6,7 @@ import Data.Aeson (encode)
import qualified Data.Aeson.Types as Json
import Data.Text.Internal.Lazy (Text)
import Data.Text.Lazy.Encoding (decodeUtf8)
+import Prelude hiding (init)
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Text (renderHtml)
@@ -14,20 +15,20 @@ import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes
import qualified Text.Blaze.Html5.Attributes as A
-import Common.Model (InitResult)
+import Common.Model (Init)
import qualified Common.Msg as Msg
import Design.Global (globalDesign)
-page :: InitResult -> Text
-page initResult =
+page :: Maybe Init -> Text
+page init =
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 $ Msg.get Msg.App_Title)
script ! src "/javascript/main.js" $ ""
- jsonScript "init" initResult
+ jsonScript "init" init
link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css"
link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png"
H.style $ toHtml globalDesign
--
cgit v1.2.3
From 209008f155068835077719eeec942a9b979b3a04 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 19 Jan 2020 16:14:09 +0100
Subject: Keep button size while waiting
---
server/src/Design/Global.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
(limited to 'server')
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index ebd7084..c67db7c 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -132,7 +132,7 @@ global = do
".waiting" & do
".content" ? do
- display none
+ opacity 0
svg # ".loader" ? do
display block
spinAnimation
--
cgit v1.2.3
From 5a13317efdaa2a8594a138b07ddd45eab40a8322 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 19 Jan 2020 16:30:01 +0100
Subject: Return the css at /css/main.css instead of inlined
---
server/src/Main.hs | 5 +++++
server/src/View/Page.hs | 4 +---
2 files changed, 6 insertions(+), 3 deletions(-)
(limited to 'server')
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 324557e..999f973 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -14,6 +14,7 @@ import qualified Controller.Income as Income
import qualified Controller.Index as Index
import qualified Controller.Payment as Payment
import qualified Controller.User as User
+import qualified Design.Global as Design
import Job.Daemon (runDaemons)
main :: IO ()
@@ -28,6 +29,10 @@ main = do
S.middleware . staticPolicy $
noDots >-> addBase "public"
+ S.get "/css/main.css" $ do
+ S.setHeader "Content-Type" "text/css"
+ S.text Design.globalDesign
+
S.post "/api/signIn" $
S.jsonData >>= Index.signIn conf
diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs
index 4ada5f7..bac6b8a 100644
--- a/server/src/View/Page.hs
+++ b/server/src/View/Page.hs
@@ -18,8 +18,6 @@ import qualified Text.Blaze.Html5.Attributes as A
import Common.Model (Init)
import qualified Common.Msg as Msg
-import Design.Global (globalDesign)
-
page :: Maybe Init -> Text
page init =
renderHtml . docTypeHtml $ do
@@ -30,8 +28,8 @@ page init =
script ! src "/javascript/main.js" $ ""
jsonScript "init" init
link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css"
+ link ! rel "stylesheet" ! type_ "text/css" ! href "/css/main.css"
link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png"
- H.style $ toHtml globalDesign
H.body $ do
H.div ! A.class_ "spinner" $ ""
--
cgit v1.2.3
From d20d7ceec2a14f79ebb06555a71d424aeaa90e54 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 19 Jan 2020 16:31:55 +0100
Subject: Show conf at server startup
---
server/src/Main.hs | 1 +
1 file changed, 1 insertion(+)
(limited to 'server')
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 999f973..25fffb3 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -20,6 +20,7 @@ import Job.Daemon (runDaemons)
main :: IO ()
main = do
conf <- Conf.get "application.conf"
+ putStrLn . show $ conf
_ <- runDaemons conf
S.scotty (Conf.port conf) $ do
--
cgit v1.2.3
From 47c2a4d6b68c54eed5f7b45671b1ccaf8c0db200 Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 20 Jan 2020 19:47:23 +0100
Subject: Show payment stats
---
server/server.cabal | 2 ++
server/src/Controller/Payment.hs | 9 +++++++++
server/src/Design/View/Stat.hs | 4 ++++
server/src/Design/Views.hs | 2 +-
server/src/Main.hs | 3 +++
server/src/Persistence/Payment.hs | 19 +++++++++++++++++++
server/src/Statistics.hs | 34 ++++++++++++++++++++++++++++++++++
server/src/View/Page.hs | 1 +
8 files changed, 73 insertions(+), 1 deletion(-)
create mode 100644 server/src/Statistics.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 7ef5328..4f513f4 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -38,6 +38,7 @@ Executable server
, filepath
, http-conduit
, http-types
+ , jsaddle
, mime-mail
, monad-logger
, mtl
@@ -119,6 +120,7 @@ Executable server
Resource
Secure
SendMail
+ Statistics
Util.Time
Validation.Category
Validation.Income
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index d6aa34f..80c717f 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -4,6 +4,7 @@ module Controller.Payment
, edit
, delete
, searchCategory
+ , statistics
) where
import Control.Monad.IO.Class (liftIO)
@@ -30,6 +31,7 @@ import qualified Persistence.Income as IncomePersistence
import qualified Persistence.Payment as PaymentPersistence
import qualified Persistence.User as UserPersistence
import qualified Secure
+import qualified Statistics
import qualified Validation.Payment as PaymentValidation
list :: Frequency -> Int -> Int -> Text -> ActionM ()
@@ -114,3 +116,10 @@ searchCategory paymentName =
(liftIO $ Query.run (PaymentPersistence.searchCategory paymentName))
>>= S.json
)
+
+statistics :: ActionM ()
+statistics =
+ Secure.loggedAction (\_ -> do
+ payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual
+ S.json (Statistics.compute payments)
+ )
diff --git a/server/src/Design/View/Stat.hs b/server/src/Design/View/Stat.hs
index 4d7021e..2e4ecad 100644
--- a/server/src/Design/View/Stat.hs
+++ b/server/src/Design/View/Stat.hs
@@ -11,3 +11,7 @@ design = do
".exceedingPayers" ? ".userName" ? marginRight (px 5)
".mean" ? marginBottom (em 1.5)
+
+ ".g-Chart" ? do
+ width (pct 75)
+ sym2 margin (px 0) auto
diff --git a/server/src/Design/Views.hs b/server/src/Design/Views.hs
index 270bb8e..4552796 100644
--- a/server/src/Design/Views.hs
+++ b/server/src/Design/Views.hs
@@ -22,7 +22,7 @@ design = do
header ? Header.design
Payment.design
".signIn" ? SignIn.design
- ".stat" ? Stat.design
+ Stat.design
".notfound" ? NotFound.design
Table.design
Pages.design
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 25fffb3..64de511 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -97,6 +97,9 @@ main = do
categoryId <- S.param "id"
Category.delete categoryId
+ S.get "/api/statistics" $ do
+ Payment.statistics
+
S.notFound $ do
S.status Status.ok200
Index.get conf
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index b3eb141..573d57f 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -2,6 +2,7 @@ module Persistence.Payment
( count
, find
, getRange
+ , listAllPunctual
, listActivePage
, listModifiedPunctualSince
, listActiveMonthlyOrderedByName
@@ -140,6 +141,24 @@ getRange =
]
)
+listAllPunctual :: Query [Payment]
+listAllPunctual =
+ Query (\conn ->
+ map (\(Row p) -> p) <$>
+ SQLite.queryNamed
+ conn
+ (SQLite.Query $ T.intercalate " "
+ [ "SELECT"
+ , fields
+ , "FROM payment"
+ , "WHERE deleted_at IS NULL AND frequency = :frequency"
+ , "ORDER BY date"
+ ])
+ [ ":frequency" := FrequencyField Punctual
+ ]
+ )
+
+
listActivePage :: Frequency -> Int -> Int -> Text -> Query [Payment]
listActivePage frequency page perPage search =
Query (\conn ->
diff --git a/server/src/Statistics.hs b/server/src/Statistics.hs
new file mode 100644
index 0000000..371fba2
--- /dev/null
+++ b/server/src/Statistics.hs
@@ -0,0 +1,34 @@
+module Statistics
+ ( compute
+ ) where
+
+import qualified Data.List as L
+import qualified Data.Map as M
+import qualified Data.Time.Calendar as Calendar
+
+import Common.Model (Payment (..), PaymentStats)
+
+compute :: [Payment] -> PaymentStats
+compute payments =
+
+ M.toList $ foldl
+ (\m p -> M.alter (alter p) (startOfMonth $ _payment_date p) m)
+ M.empty
+ payments
+
+ where
+
+ initMonthStats =
+ M.fromList
+ . map (\category -> (category, 0))
+ . L.nub
+ $ map _payment_category payments
+
+ alter p Nothing = Just (addPayment p initMonthStats)
+ alter p (Just monthStats) = Just (addPayment p monthStats)
+
+ addPayment p monthStats = M.adjust ((+) (_payment_cost p)) (_payment_category p) monthStats
+
+ startOfMonth day =
+ let (y, m, _) = Calendar.toGregorian day
+ in Calendar.fromGregorian y m 1
diff --git a/server/src/View/Page.hs b/server/src/View/Page.hs
index bac6b8a..ae7a266 100644
--- a/server/src/View/Page.hs
+++ b/server/src/View/Page.hs
@@ -26,6 +26,7 @@ page init =
meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0"
H.title (toHtml $ Msg.get Msg.App_Title)
script ! src "/javascript/main.js" $ ""
+ script ! src "https://cdnjs.cloudflare.com/ajax/libs/Chart.js/2.9.3/Chart.bundle.js" $ ""
jsonScript "init" init
link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css"
link ! rel "stylesheet" ! type_ "text/css" ! href "/css/main.css"
--
cgit v1.2.3
From 79e1d8b0099d61b580a499311f1714b1b7eb07b5 Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 27 Jan 2020 22:07:18 +0100
Subject: Show total incom by month in statistics
---
server/server.cabal | 1 +
server/src/Controller/Payment.hs | 9 ---------
server/src/Controller/Statistics.hs | 21 +++++++++++++++++++++
server/src/Main.hs | 3 ++-
server/src/Persistence/Income.hs | 13 ++++++++++++-
server/src/Statistics.hs | 35 ++++++++++++++++++++++++++++++-----
6 files changed, 66 insertions(+), 16 deletions(-)
create mode 100644 server/src/Controller/Statistics.hs
(limited to 'server')
diff --git a/server/server.cabal b/server/server.cabal
index 4f513f4..5427385 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -65,6 +65,7 @@ Executable server
Controller.Income
Controller.Index
Controller.Payment
+ Controller.Statistics
Controller.User
Cookie
Design.Appearing
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index 80c717f..d6aa34f 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -4,7 +4,6 @@ module Controller.Payment
, edit
, delete
, searchCategory
- , statistics
) where
import Control.Monad.IO.Class (liftIO)
@@ -31,7 +30,6 @@ import qualified Persistence.Income as IncomePersistence
import qualified Persistence.Payment as PaymentPersistence
import qualified Persistence.User as UserPersistence
import qualified Secure
-import qualified Statistics
import qualified Validation.Payment as PaymentValidation
list :: Frequency -> Int -> Int -> Text -> ActionM ()
@@ -116,10 +114,3 @@ searchCategory paymentName =
(liftIO $ Query.run (PaymentPersistence.searchCategory paymentName))
>>= S.json
)
-
-statistics :: ActionM ()
-statistics =
- Secure.loggedAction (\_ -> do
- payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual
- S.json (Statistics.compute payments)
- )
diff --git a/server/src/Controller/Statistics.hs b/server/src/Controller/Statistics.hs
new file mode 100644
index 0000000..500c93c
--- /dev/null
+++ b/server/src/Controller/Statistics.hs
@@ -0,0 +1,21 @@
+module Controller.Statistics
+ ( paymentsAndIncomes
+ ) where
+
+import Control.Monad.IO.Class (liftIO)
+import Web.Scotty (ActionM)
+import qualified Web.Scotty as S
+
+import qualified Model.Query as Query
+import qualified Persistence.Income as IncomePersistence
+import qualified Persistence.Payment as PaymentPersistence
+import qualified Secure
+import qualified Statistics
+
+paymentsAndIncomes :: ActionM ()
+paymentsAndIncomes =
+ Secure.loggedAction (\_ -> do
+ payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual
+ incomes <- liftIO $ Query.run IncomePersistence.listAll
+ S.json (Statistics.paymentsAndIncomes payments incomes)
+ )
diff --git a/server/src/Main.hs b/server/src/Main.hs
index 64de511..659a0fa 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -13,6 +13,7 @@ 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.Statistics as Statistics
import qualified Controller.User as User
import qualified Design.Global as Design
import Job.Daemon (runDaemons)
@@ -98,7 +99,7 @@ main = do
Category.delete categoryId
S.get "/api/statistics" $ do
- Payment.statistics
+ Statistics.paymentsAndIncomes
S.notFound $ do
S.status Status.ok200
diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs
index 76cb952..1b5364c 100644
--- a/server/src/Persistence/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -1,5 +1,6 @@
module Persistence.Income
- ( count
+ ( listAll
+ , count
, list
, listModifiedSince
, create
@@ -43,6 +44,16 @@ data CountRow = CountRow Int
instance FromRow CountRow where
fromRow = CountRow <$> SQLite.field
+listAll :: Query [Income]
+listAll =
+ Query (\conn ->
+ map (\(Row i) -> i) <$>
+ SQLite.query_
+ conn
+ "SELECT * FROM income WHERE deleted_at IS NULL ORDER BY date DESC"
+ )
+
+
count :: Query Int
count =
Query (\conn ->
diff --git a/server/src/Statistics.hs b/server/src/Statistics.hs
index 371fba2..e463aac 100644
--- a/server/src/Statistics.hs
+++ b/server/src/Statistics.hs
@@ -1,23 +1,44 @@
module Statistics
- ( compute
+ ( paymentsAndIncomes
) where
+import Control.Arrow ((&&&))
import qualified Data.List as L
+import Data.Map (Map)
import qualified Data.Map as M
+import qualified Data.Maybe as Maybe
import qualified Data.Time.Calendar as Calendar
-import Common.Model (Payment (..), PaymentStats)
+import Common.Model (Income (..), MonthStats (..), Payment (..),
+ Stats)
-compute :: [Payment] -> PaymentStats
-compute payments =
+paymentsAndIncomes :: [Payment] -> [Income] -> Stats
+paymentsAndIncomes payments incomes =
- M.toList $ foldl
+ map toMonthStat . M.toList $ foldl
(\m p -> M.alter (alter p) (startOfMonth $ _payment_date p) m)
M.empty
payments
where
+ toMonthStat (start, paymentsByCategory) =
+ MonthStats start paymentsByCategory (incomesAt start)
+
+ incomesAt day =
+ M.map (incomeAt day) lastToFirstIncomesByUser
+
+ incomeAt day lastToFirstIncome =
+ Maybe.maybe 0 _income_amount
+ . Maybe.listToMaybe
+ . dropWhile (\i -> _income_date i > day)
+ $ lastToFirstIncome
+
+ lastToFirstIncomesByUser =
+ M.map (reverse . L.sortOn _income_date)
+ . groupBy _income_userId
+ $ incomes
+
initMonthStats =
M.fromList
. map (\category -> (category, 0))
@@ -32,3 +53,7 @@ compute payments =
startOfMonth day =
let (y, m, _) = Calendar.toGregorian day
in Calendar.fromGregorian y m 1
+
+groupBy :: Ord k => (a -> k) -> [a] -> Map k [a]
+groupBy key =
+ M.fromListWith (++) . map (key &&& pure)
--
cgit v1.2.3