diff --git a/CHANGELOG.org b/CHANGELOG.org deleted file mode 100644 --- a/CHANGELOG.org +++ /dev/null @@ -1,12 +0,0 @@ -* Changelog for `wikimusic-api` - -All notable changes to this project will be documented in this file. - -The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), -and this project adheres to the -[Haskell Package Versioning Policy](https://pvp.haskell.org/). - -** Releases -*** v0.3.0.0 -- Using ~Hasql.Pool~ package across the entire system when doing database queries. -- Implemented the typeclasses for ~Command~ and ~Query~ for the entities ~Artist~ and ~Song~. This means that the Handlers have become lean as f*ck and we have 100% loose coupling between the persistence layer and the domain and handler layers. In principle this is actually a typeclass dependency injection, very elegant. diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,595 @@ +GNU General Public License +========================== + +_Version 3, 29 June 2007_ +_Copyright © 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/README.org b/README.org --- a/README.org +++ b/README.org @@ -1,17 +1,15 @@ #+title: WikiMusic API -#+options: toc:nil -API and Persistence layer to PostgreSQL for WikiMusic, the invite-only private knowledge sharing of music community. +API and Persistence layer to SQLite for WikiMusic, the invite-only private knowledge sharing of music community. /WikiMusic/ #+begin_html
Haskell -PostgreSQL -GNU Emacs +SQLite NixOS -Redis +GNU Emacs
#+end_html @@ -36,15 +34,15 @@ - ~Free~ is a package with free monadic definitions of the possible interactions with the WikiMusic system. - ~Interaction~ is a package with the implementation agnostic "business logic" of the WikiMusic system. - ~Model~ is a package with common data models to the entire system. -- ~PostgreSQL~ is a package with the PostgreSQL implementation of several ~Command~ and ~Query~ interactions. -- ~SMTP~ is a package that contains SMTP Mail related implementations. +- ~Persistence~ is a package with the Persistence implementation of several ~Command~ and ~Query~ interactions. +- ~Smtp~ is a package that contains Smtp Mail related implementations. - ~Servant~ is a package that contains the API definition, routes and wiring of HTTP. - ~Boot.hs~ is the entry point to start this REST API. - ~Protolude.hs~ contains a custom tailor-made standard library (prelude) for WikiMusic, which helps developing. ** Implementation details -WikiMusic API is made using Haskell and free(er) monad techniques, along with great libraries made by the brilliant Haskell community. Some worthy mentions include servant, hasql, rio, free-alacarte, wai, keuringsdienst, optics. +WikiMusic API is made using Haskell and free(er) monad techniques, along with great libraries made by the brilliant Haskell community. Some worthy mentions include servant, free-alacarte, wai, keuringsdienst, optics. Using free(er) monads means that we can describe the business logic of certain layers at a very high abstraction level, and we are free to interpret this logic as we see fit, depending on the use case. This helps testing, decoupling, and maintaining code. @@ -56,10 +54,10 @@ Otherwise, on systems like Void Linux : #+begin_src -sudo xbps-install zlib zlib-devel libpqxx-devel postgresql-libs postgresql-libs-devel ncurses-libtinfo-devel +sudo xbps-install zlib zlib-devel ncurses-libtinfo-devel #+end_src -You will also need a PostgreSQL database and a Redis instance (to rate limit certain requests) to be accessible from WikiMusic API and running. +You will also need a SQLite database to be accessible from WikiMusic API and running. WikiMusic will take care of the database schema migrations for you. @@ -110,9 +108,6 @@ It can be needed, if you want to run bare metal without direnv, to do things like this sometimes in the ~cabal.project~ (find by ~find /nix -name "zlib.h*"~): #+begin_src nix -package postgresql-libpq - extra-include-dirs: /nix/store/ahb6l0carh3yc6a5d4zdxsxf69sdhnhh-postgresql-15.4/include - package zlib extra-include-dirs: /nix/store/686lhcz4bwg3wk09pi1xxjgzbxv7ys5q-zlib-1.3-dev/include extra-lib-dirs: /nix/store/4rx3vkkd91wkbhpflsplfga603cp1l1c-zlib-1.3/lib @@ -139,7 +134,7 @@ I1 [ label="api.wikimusic.jointhefreeworld.org via HTTPS" ] I2 [ label="AWS Cloudfront" ] I3 [ label="AWS EC2 t3.small instance\nrunning NixOS" ] - I4 [ label="Haskell + Servant + PostgreSQL + Redis" ] + I4 [ label="Haskell + Servant + SQLite" ] I5 [ label="GitLab CI/CD" ] I6 [ label="AWS SQS queue" ] @@ -156,3 +151,44 @@ #+RESULTS: [[file:resources/images/production-env-diagram.png]] + + +* Project management + +Find below a list ideas and work being done on this project by all our contributors. + +** Work in progress +*** WIP Finish cleaning persistence layer by using only Beam for all queries + + +** Project backlog +*** TODO Automated Cabal Hackage release in CI and version bumps +*** TODO Recently viewed functionality +*** TODO Add optional lyrics for song textfield +*** TODO Clock and identifier generation as free monads, take things to a higher level +*** TODO Create and optimize custom Prelude, and clean all files imports +*** TODO Improve reusability in ~fromString . T.unpack $ x~ +*** TODO Liked items list view (liked songs, liked genres) + +*** TODO Create "for profit" version (premium offline pre-rendered) of WikiMusic, as app (read-only) +*** TODO Ensure all data models are validated in requests +*** TODO Use more non-empty types and sets if possible +*** TODO Remove unused dependencies +*** TODO Create black box tests for basic system functioning (with SQLite ) +**** Create SQLite assertion DSL for tests with Beam (check row exists) +*** TODO Genre <> Song <> Artist relation +*** TODO Drop SQL tables of user favourites, since opinions table will be used for it +*** TODO Add forums +*** TODO Validate and limit size and type of files being uploaded +**** TODO GP5 support (song file upload) +*** TODO extract mail monad, service, templates and views into its own microservices, communicate via grpc if possible, otherwise REST and ensure retries and good logging +*** TODO Prometheus metrics and visualizations, use Grafana in Docker, also in production server +*** TODO wikimusic marketing emails, asking for donation, recommending last added and last edited top 10 items +*** TODO WikiMusic email about new website and its changelog, every commit automatic mail users?, new capabilities to all users marketing + + +** Done +*** DONE Migration to GitHub +CLOSED: [2024-09-04 wo 22:05] +*** DONE fix email, do not expose Smtp credentials on GitHub +CLOSED: [2024-09-04 wo 17:23] diff --git a/src/WikiMusic/Beam/Artist.hs b/src/WikiMusic/Beam/Artist.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Beam/Artist.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Beam.Artist where + +import Data.Map qualified as Map +import Data.UUID qualified as UUID +import Database.Beam +import Optics +import Relude +import WikiMusic.Beam.Util +import WikiMusic.Model.Artist +import WikiMusic.Protolude + +data ArtistT f = Artist' + { identifier :: C f Text, + displayName :: C f Text, + createdBy :: C f Text, + visibilityStatus :: C f Int64, + approvedBy :: C f (Maybe Text), + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime), + viewCount :: C f Int64, + description :: C f (Maybe Text) + } + deriving (Generic, Beamable) + +makeFieldLabelsNoPrefix ''ArtistT + +type Artist' = ArtistT Identity + +instance Table ArtistT where + data PrimaryKey ArtistT f = ArtistId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = ArtistId . (^. #identifier) + +fromArtistPk :: PrimaryKey ArtistT f -> Columnar f Text +fromArtistPk (ArtistId i) = i + +toArtist :: Artist' -> ExternalSources -> (UUID, Artist) +toArtist x ex = + ( textToUUID $ x ^. #identifier, + Artist + { identifier = textToUUID $ x ^. #identifier, + displayName = x ^. #displayName, + createdBy = textToUUID $ x ^. #createdBy, + visibilityStatus = fromIntegral $ x ^. #visibilityStatus, + approvedBy = fmap (textToUUID) (x ^. #approvedBy), + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt, + viewCount = fromIntegral $ x ^. #viewCount, + description = x ^. #description, + artworks = Map.empty, + comments = [], + opinions = Map.empty, + spotifyUrl = ex ^. #spotifyUrl, + youtubeUrl = ex ^. #youtubeUrl, + soundcloudUrl = ex ^. #soundcloudUrl, + wikipediaUrl = ex ^. #wikipediaUrl + } + ) + +toPersistenceArtist :: Artist -> Artist' +toPersistenceArtist x = + Artist' + { identifier = UUID.toText $ x ^. #identifier, + displayName = x ^. #displayName, + createdBy = UUID.toText $ x ^. #createdBy, + visibilityStatus = fromIntegral $ x ^. #visibilityStatus, + approvedBy = fmap (UUID.toText) (x ^. #approvedBy), + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt, + viewCount = fromIntegral $ x ^. #viewCount, + description = x ^. #description + } + +data ArtistCommentT f = ArtistComment' + { identifier :: C f Text, + parentIdentifier :: C f (Maybe Text), + artistIdentifier :: PrimaryKey ArtistT f, + createdBy :: C f Text, + visibilityStatus :: C f Int64, + contents :: C f Text, + approvedBy :: C f (Maybe Text), + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime) + } + deriving (Generic, Beamable) + +type ArtistComment' = ArtistCommentT Identity + +instance Table ArtistCommentT where + data PrimaryKey ArtistCommentT f = ArtistCommentId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = ArtistCommentId . (^. #identifier) + +makeFieldLabelsNoPrefix ''ArtistCommentT + +toArtistComment :: ArtistComment' -> (UUID, ArtistComment) +toArtistComment x = + ( textToUUID $ x ^. #identifier, + ArtistComment + { artistIdentifier = textToUUID $ fromArtistPk $ x ^. #artistIdentifier, + comment = fromPersistenceComment x + } + ) + +toPersistenceArtistComment :: ArtistComment -> ArtistComment' +toPersistenceArtistComment x = + ArtistComment' + { identifier = UUID.toText $ x ^. #comment % #identifier, + parentIdentifier = fmap UUID.toText (x ^. #comment % #parentIdentifier), + artistIdentifier = ArtistId . UUID.toText $ x ^. #artistIdentifier, + createdBy = UUID.toText $ x ^. #comment % #createdBy, + visibilityStatus = fromIntegral $ x ^. #comment % #visibilityStatus, + contents = x ^. #comment % #contents, + approvedBy = fmap (UUID.toText) (x ^. #comment % #approvedBy), + createdAt = x ^. #comment % #createdAt, + lastEditedAt = x ^. #comment % #lastEditedAt + } + +data ArtistArtworkT f = ArtistArtwork' + { identifier :: C f Text, + artistIdentifier :: PrimaryKey ArtistT f, + createdBy :: C f Text, + visibilityStatus :: C f Int64, + approvedBy :: C f (Maybe Text), + contentUrl :: C f Text, + contentCaption :: C f (Maybe Text), + orderValue :: C f Int64, + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime) + } + deriving (Generic, Beamable) + +type ArtistArtwork' = ArtistArtworkT Identity + +instance Table ArtistArtworkT where + data PrimaryKey ArtistArtworkT f = ArtistArtworkId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = ArtistArtworkId . (^. #identifier) + +makeFieldLabelsNoPrefix ''ArtistArtworkT + +toArtistArtwork :: ArtistArtwork' -> (UUID, ArtistArtwork) +toArtistArtwork x = + ( textToUUID $ x ^. #identifier, + ArtistArtwork + { artistIdentifier = textToUUID $ fromArtistPk $ x ^. #artistIdentifier, + artwork = fromPersistenceArtwork x + } + ) + +mkArtistArtworkP :: ArtistArtwork -> ArtistArtwork' +mkArtistArtworkP x = + ArtistArtwork' + { identifier = UUID.toText $ x ^. #artwork % #identifier, + artistIdentifier = ArtistId $ UUID.toText $ x ^. #artistIdentifier, + createdBy = UUID.toText $ x ^. #artwork % #createdBy, + visibilityStatus = fromIntegral $ x ^. #artwork % #visibilityStatus, + contentUrl = x ^. #artwork % #contentUrl, + contentCaption = x ^. #artwork % #contentCaption, + orderValue = fromIntegral $ x ^. #artwork % #orderValue, + approvedBy = fmap (UUID.toText) (x ^. #artwork % #approvedBy), + createdAt = x ^. #artwork % #createdAt, + lastEditedAt = x ^. #artwork % #lastEditedAt + } + +data ArtistOpinionT f = ArtistOpinion' + { identifier :: C f Text, + artistIdentifier :: PrimaryKey ArtistT f, + createdBy :: C f Text, + isLike :: C f Bool, + isDislike :: C f Bool, + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime) + } + deriving (Generic, Beamable) + +type ArtistOpinion' = ArtistOpinionT Identity + +instance Table ArtistOpinionT where + data PrimaryKey ArtistOpinionT f = ArtistOpinionId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = ArtistOpinionId . (^. #identifier) + +makeFieldLabelsNoPrefix ''ArtistOpinionT + +toArtistOpinion :: ArtistOpinion' -> (UUID, ArtistOpinion) +toArtistOpinion x = + ( textToUUID $ x ^. #identifier, + ArtistOpinion + { artistIdentifier = textToUUID $ fromArtistPk $ x ^. #artistIdentifier, + opinion = fromPersistenceOpinion x + } + ) + +data ArtistExternalSourcesT f = ArtistExternalSources' + { identifier :: C f Text, + artistIdentifier :: PrimaryKey ArtistT f, + createdBy :: C f Text, + spotifyUrl :: C f (Maybe Text), + youtubeUrl :: C f (Maybe Text), + soundcloudUrl :: C f (Maybe Text), + wikipediaUrl :: C f (Maybe Text), + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime) + } + deriving (Generic, Beamable) + +type ArtistExternalSources' = ArtistExternalSourcesT Identity + +instance Table ArtistExternalSourcesT where + data PrimaryKey ArtistExternalSourcesT f = ArtistExternalSourcesId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = ArtistExternalSourcesId . (^. #identifier) + +makeFieldLabelsNoPrefix ''ArtistExternalSourcesT + +toPersistenceArtistExternalContents :: Artist -> UUID -> ArtistExternalSources' +toPersistenceArtistExternalContents x newIdentifier = + ArtistExternalSources' + { identifier = UUID.toText $ newIdentifier, + artistIdentifier = ArtistId $ UUID.toText $ x ^. #identifier, + createdBy = UUID.toText $ x ^. #createdBy, + spotifyUrl = x ^. #spotifyUrl, + youtubeUrl = x ^. #youtubeUrl, + soundcloudUrl = x ^. #soundcloudUrl, + wikipediaUrl = x ^. #wikipediaUrl, + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt + } + +mkArtistExSourcesP :: ArtistExternalSources -> ArtistExternalSources' +mkArtistExSourcesP x = + ArtistExternalSources' + { identifier = UUID.toText $ x ^. #identifier, + artistIdentifier = ArtistId $ UUID.toText $ x ^. #artistIdentifier, + createdBy = UUID.toText $ x ^. #createdBy, + spotifyUrl = x ^. #spotifyUrl, + youtubeUrl = x ^. #youtubeUrl, + soundcloudUrl = x ^. #soundcloudUrl, + wikipediaUrl = x ^. #wikipediaUrl, + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt + } + +artistTModification :: ArtistT (FieldModification (TableField ArtistT)) +artistTModification = + tableModification + { identifier = "identifier", + displayName = "display_name", + createdBy = "created_by", + visibilityStatus = "visibility_status", + approvedBy = "approved_by", + createdAt = "created_at", + lastEditedAt = "last_edited_at", + viewCount = "views", + description = "description" + } + +artistCommentTModification :: ArtistCommentT (FieldModification (TableField ArtistCommentT)) +artistCommentTModification = + tableModification + { identifier = "identifier", + artistIdentifier = ArtistId "artist_identifier", + parentIdentifier = "parent_identifier", + createdBy = "created_by", + visibilityStatus = "visibility_status", + contents = "contents", + approvedBy = "approved_by", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } + +artistArtworkTModification :: ArtistArtworkT (FieldModification (TableField ArtistArtworkT)) +artistArtworkTModification = + tableModification + { identifier = "identifier", + artistIdentifier = ArtistId "artist_identifier", + createdBy = "created_by", + visibilityStatus = "visibility_status", + approvedBy = "approved_by", + contentUrl = "content_url", + contentCaption = "content_caption", + orderValue = "order_value", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } + +artistOpinionTModification :: ArtistOpinionT (FieldModification (TableField ArtistOpinionT)) +artistOpinionTModification = + tableModification + { identifier = "identifier", + artistIdentifier = ArtistId "artist_identifier", + createdBy = "created_by", + isLike = "is_like", + isDislike = "is_dislike", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } + +artistExternalSourcesTModification :: ArtistExternalSourcesT (FieldModification (TableField ArtistExternalSourcesT)) +artistExternalSourcesTModification = + tableModification + { identifier = "identifier", + artistIdentifier = ArtistId "artist_identifier", + createdBy = "created_by", + spotifyUrl = "spotify_url", + youtubeUrl = "youtube_url", + soundcloudUrl = "soundcloud_url", + wikipediaUrl = "wikipedia_url", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } + +mkArtistOpinionP :: ArtistOpinion -> ArtistOpinion' +mkArtistOpinionP x = + ArtistOpinion' + { identifier = UUID.toText $ x ^. #opinion % #identifier, + artistIdentifier = ArtistId $ UUID.toText $ x ^. #artistIdentifier, + createdBy = UUID.toText $ x ^. #opinion % #createdBy, + isLike = x ^. #opinion % #isLike, + isDislike = x ^. #opinion % #isDislike, + createdAt = x ^. #opinion % #createdAt, + lastEditedAt = x ^. #opinion % #lastEditedAt + } diff --git a/src/WikiMusic/Beam/Database.hs b/src/WikiMusic/Beam/Database.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Beam/Database.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Beam.Database where + +import Database.Beam +import Optics +import WikiMusic.Beam.Artist +import WikiMusic.Beam.Genre +import WikiMusic.Beam.Relations +import WikiMusic.Beam.Song +import WikiMusic.Beam.User +import WikiMusic.Protolude + +data WikiMusicDatabase f = WikiMusicDatabase + { songs :: f (TableEntity SongT), + songComments :: f (TableEntity SongCommentT), + songArtworks :: f (TableEntity SongArtworkT), + songOpinions :: f (TableEntity SongOpinionT), + songExternalSources :: f (TableEntity SongExternalSourcesT), + songContents :: f (TableEntity SongContentsT), + genres :: f (TableEntity GenreT), + genreComments :: f (TableEntity GenreCommentT), + genreArtworks :: f (TableEntity GenreArtworkT), + genreOpinions :: f (TableEntity GenreOpinionT), + genreExternalSources :: f (TableEntity GenreExternalSourcesT), + artists :: f (TableEntity ArtistT), + artistComments :: f (TableEntity ArtistCommentT), + artistArtworks :: f (TableEntity ArtistArtworkT), + artistOpinions :: f (TableEntity ArtistOpinionT), + artistExternalSources :: f (TableEntity ArtistExternalSourcesT), + users :: f (TableEntity UserT), + userRoles :: f (TableEntity UserRoleT), + songArtists :: f (TableEntity SongArtistT), + songGenres :: f (TableEntity SongGenreT), + artistGenres :: f (TableEntity ArtistGenreT) + } + deriving (Generic, Database be) + +makeFieldLabelsNoPrefix ''WikiMusicDatabase + +wikiMusicDatabase :: DatabaseSettings be WikiMusicDatabase +wikiMusicDatabase = + defaultDbSettings + `withDbModification` dbModification + { songs = + setEntityName "songs" + <> modifyTableFields + songTModification, + songComments = + setEntityName "song_comments" + <> modifyTableFields + songCommentTModification, + songArtworks = + setEntityName "song_artworks" + <> modifyTableFields + songArtworkTModification, + songOpinions = + setEntityName "song_opinions" + <> modifyTableFields + songOpinionTModification, + songExternalSources = + setEntityName "song_external_sources" + <> modifyTableFields + songExternalSourcesTModification, + songContents = + setEntityName "song_contents" + <> modifyTableFields songContentsTModification, + genres = + setEntityName "genres" + <> modifyTableFields + genreTModification, + genreComments = + setEntityName "genre_comments" + <> modifyTableFields + genreCommentTModification, + genreArtworks = + setEntityName "genre_artworks" + <> modifyTableFields + genreArtworkTModification, + genreOpinions = + setEntityName "genre_opinions" + <> modifyTableFields + genreOpinionTModification, + genreExternalSources = + setEntityName "genre_external_sources" + <> modifyTableFields + genreExternalSourcesTModification, + artists = + setEntityName "artists" + <> modifyTableFields + artistTModification, + artistComments = + setEntityName "artist_comments" + <> modifyTableFields + artistCommentTModification, + artistArtworks = + setEntityName "artist_artworks" + <> modifyTableFields + artistArtworkTModification, + artistOpinions = + setEntityName "artist_opinions" + <> modifyTableFields + artistOpinionTModification, + artistExternalSources = + setEntityName "artist_external_sources" + <> modifyTableFields + artistExternalSourcesTModification, + users = + setEntityName "users" + <> modifyTableFields + userTModification, + userRoles = + setEntityName "user_roles" + <> modifyTableFields + userRoleTModification, + songArtists = + setEntityName "song_artists" + <> modifyTableFields songArtistTModification, + songGenres = + setEntityName "song_genres" + <> modifyTableFields songGenreTModification, + artistGenres = + setEntityName "artist_genres" + <> modifyTableFields artistGenreTModification + } diff --git a/src/WikiMusic/Beam/Genre.hs b/src/WikiMusic/Beam/Genre.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Beam/Genre.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Beam.Genre where + +import Data.Map qualified as Map +import Data.UUID qualified as UUID +import Database.Beam +import Optics +import WikiMusic.Beam.Util +import WikiMusic.Model.Genre +import WikiMusic.Protolude + +data GenreT f = Genre' + { identifier :: C f Text, + parentIdentifier :: C f (Maybe Text), + displayName :: C f Text, + createdBy :: C f Text, + visibilityStatus :: C f Int64, + approvedBy :: C f (Maybe Text), + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime), + viewCount :: C f Int64, + description :: C f (Maybe Text) + } + deriving (Generic, Beamable) + +makeFieldLabelsNoPrefix ''GenreT + +type Genre' = GenreT Identity + +instance Table GenreT where + data PrimaryKey GenreT f = GenreId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = GenreId . (^. #identifier) + +fromGenrePk :: PrimaryKey GenreT f -> Columnar f Text +fromGenrePk (GenreId i) = i + +toGenre :: Genre' -> ExternalSources -> (UUID, Genre) +toGenre x ex = + ( textToUUID $ x ^. #identifier, + Genre + { identifier = textToUUID $ x ^. #identifier, + parentIdentifier = fmap textToUUID $ x ^. #parentIdentifier, + displayName = x ^. #displayName, + createdBy = textToUUID $ x ^. #createdBy, + visibilityStatus = fromIntegral $ x ^. #visibilityStatus, + approvedBy = fmap textToUUID $ x ^. #approvedBy, + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt, + viewCount = fromIntegral $ x ^. #viewCount, + description = x ^. #description, + artworks = Map.empty, + comments = [], + opinions = Map.empty, + spotifyUrl = ex ^. #spotifyUrl, + youtubeUrl = ex ^. #youtubeUrl, + soundcloudUrl = ex ^. #soundcloudUrl, + wikipediaUrl = ex ^. #wikipediaUrl + } + ) + +toPersistenceGenre :: Genre -> Genre' +toPersistenceGenre x = + Genre' + { identifier = UUID.toText $ x ^. #identifier, + parentIdentifier = fmap UUID.toText $ x ^. #parentIdentifier, + displayName = x ^. #displayName, + createdBy = UUID.toText $ x ^. #createdBy, + visibilityStatus = fromIntegral $ x ^. #visibilityStatus, + approvedBy = fmap UUID.toText $ x ^. #approvedBy, + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt, + viewCount = fromIntegral $ x ^. #viewCount, + description = x ^. #description + } + +data GenreCommentT f = GenreComment' + { identifier :: C f Text, + parentIdentifier :: C f (Maybe Text), + genreIdentifier :: PrimaryKey GenreT f, + createdBy :: C f Text, + visibilityStatus :: C f Int64, + contents :: C f Text, + approvedBy :: C f (Maybe Text), + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime) + } + deriving (Generic, Beamable) + +type GenreComment' = GenreCommentT Identity + +instance Table GenreCommentT where + data PrimaryKey GenreCommentT f = GenreCommentId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = GenreCommentId . (^. #identifier) + +makeFieldLabelsNoPrefix ''GenreCommentT + +toGenreComment :: GenreComment' -> (UUID, GenreComment) +toGenreComment x = + ( textToUUID $ x ^. #identifier, + GenreComment + { genreIdentifier = textToUUID $ fromGenrePk $ x ^. #genreIdentifier, + comment = fromPersistenceComment x + } + ) + +mkGenreCommentP :: GenreComment -> GenreComment' +mkGenreCommentP x = + GenreComment' + { identifier = UUID.toText $ x ^. #comment % #identifier, + parentIdentifier = fmap UUID.toText $ x ^. #comment % #parentIdentifier, + genreIdentifier = GenreId $ UUID.toText $ x ^. #genreIdentifier, + createdBy = UUID.toText $ x ^. #comment % #createdBy, + visibilityStatus = fromIntegral $ x ^. #comment % #visibilityStatus, + contents = x ^. #comment % #contents, + approvedBy = fmap UUID.toText $ x ^. #comment % #approvedBy, + createdAt = x ^. #comment % #createdAt, + lastEditedAt = x ^. #comment % #lastEditedAt + } + +data GenreArtworkT f = GenreArtwork' + { identifier :: C f Text, + genreIdentifier :: PrimaryKey GenreT f, + createdBy :: C f Text, + visibilityStatus :: C f Int64, + approvedBy :: C f (Maybe Text), + contentUrl :: C f Text, + contentCaption :: C f (Maybe Text), + orderValue :: C f Int64, + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime) + } + deriving (Generic, Beamable) + +type GenreArtwork' = GenreArtworkT Identity + +instance Table GenreArtworkT where + data PrimaryKey GenreArtworkT f = GenreArtworkId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = GenreArtworkId . (^. #identifier) + +makeFieldLabelsNoPrefix ''GenreArtworkT + +toGenreArtwork :: GenreArtwork' -> (UUID, GenreArtwork) +toGenreArtwork x = + ( textToUUID $ x ^. #identifier, + GenreArtwork + { genreIdentifier = textToUUID $ fromGenrePk $ x ^. #genreIdentifier, + artwork = fromPersistenceArtwork x + } + ) + +mkGenreArtworkP :: GenreArtwork -> GenreArtwork' +mkGenreArtworkP x = + GenreArtwork' + { identifier = UUID.toText $ x ^. #artwork % #identifier, + genreIdentifier = GenreId $ UUID.toText $ x ^. #genreIdentifier, + createdBy = UUID.toText $ x ^. #artwork % #createdBy, + visibilityStatus = fromIntegral $ x ^. #artwork % #visibilityStatus, + contentUrl = x ^. #artwork % #contentUrl, + contentCaption = x ^. #artwork % #contentCaption, + orderValue = fromIntegral $ x ^. #artwork % #orderValue, + approvedBy = fmap UUID.toText $ x ^. #artwork % #approvedBy, + createdAt = x ^. #artwork % #createdAt, + lastEditedAt = x ^. #artwork % #lastEditedAt + } + +data GenreOpinionT f = GenreOpinion' + { identifier :: C f Text, + genreIdentifier :: PrimaryKey GenreT f, + createdBy :: C f Text, + isLike :: C f Bool, + isDislike :: C f Bool, + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime) + } + deriving (Generic, Beamable) + +type GenreOpinion' = GenreOpinionT Identity + +instance Table GenreOpinionT where + data PrimaryKey GenreOpinionT f = GenreOpinionId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = GenreOpinionId . (^. #identifier) + +makeFieldLabelsNoPrefix ''GenreOpinionT + +toGenreOpinion :: GenreOpinion' -> (UUID, GenreOpinion) +toGenreOpinion x = + ( textToUUID $ x ^. #identifier, + GenreOpinion + { genreIdentifier = textToUUID $ fromGenrePk $ x ^. #genreIdentifier, + opinion = fromPersistenceOpinion x + } + ) + +mkGenreOpinionP :: GenreOpinion -> GenreOpinion' +mkGenreOpinionP x = + GenreOpinion' + { identifier = UUID.toText $ x ^. #opinion % #identifier, + genreIdentifier = GenreId $ UUID.toText $ x ^. #genreIdentifier, + createdBy = UUID.toText $ x ^. #opinion % #createdBy, + isLike = x ^. #opinion % #isLike, + isDislike = x ^. #opinion % #isDislike, + createdAt = x ^. #opinion % #createdAt, + lastEditedAt = x ^. #opinion % #lastEditedAt + } + +data GenreExternalSourcesT f = GenreExternalSources' + { identifier :: C f Text, + genreIdentifier :: PrimaryKey GenreT f, + createdBy :: C f Text, + spotifyUrl :: C f (Maybe Text), + youtubeUrl :: C f (Maybe Text), + soundcloudUrl :: C f (Maybe Text), + wikipediaUrl :: C f (Maybe Text), + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime) + } + deriving (Generic, Beamable) + +type GenreExternalSources' = GenreExternalSourcesT Identity + +instance Table GenreExternalSourcesT where + data PrimaryKey GenreExternalSourcesT f = GenreExternalSourcesId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = GenreExternalSourcesId . (^. #identifier) + +makeFieldLabelsNoPrefix ''GenreExternalSourcesT + +toPersistenceGenreExternalContents :: Genre -> UUID -> GenreExternalSources' +toPersistenceGenreExternalContents x newIdentifier = + GenreExternalSources' + { identifier = UUID.toText $ newIdentifier, + genreIdentifier = GenreId $ UUID.toText $ x ^. #identifier, + createdBy = UUID.toText $ x ^. #createdBy, + spotifyUrl = x ^. #spotifyUrl, + youtubeUrl = x ^. #youtubeUrl, + soundcloudUrl = x ^. #soundcloudUrl, + wikipediaUrl = x ^. #wikipediaUrl, + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt + } + +toPersistenceGenreExternalSources :: GenreExternalSources -> GenreExternalSources' +toPersistenceGenreExternalSources x = + GenreExternalSources' + { identifier = UUID.toText $ x ^. #identifier, + genreIdentifier = GenreId $ UUID.toText $ x ^. #genreIdentifier, + createdBy = UUID.toText $ x ^. #createdBy, + spotifyUrl = x ^. #spotifyUrl, + youtubeUrl = x ^. #youtubeUrl, + soundcloudUrl = x ^. #soundcloudUrl, + wikipediaUrl = x ^. #wikipediaUrl, + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt + } + +genreTModification :: GenreT (FieldModification (TableField GenreT)) +genreTModification = + tableModification + { identifier = "identifier", + parentIdentifier = "parent_identifier", + displayName = "display_name", + createdBy = "created_by", + visibilityStatus = "visibility_status", + approvedBy = "approved_by", + createdAt = "created_at", + lastEditedAt = "last_edited_at", + viewCount = "views", + description = "description" + } + +genreCommentTModification :: GenreCommentT (FieldModification (TableField GenreCommentT)) +genreCommentTModification = + tableModification + { identifier = "identifier", + genreIdentifier = GenreId "genre_identifier", + parentIdentifier = "parent_identifier", + createdBy = "created_by", + visibilityStatus = "visibility_status", + contents = "contents", + approvedBy = "approved_by", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } + +genreArtworkTModification :: GenreArtworkT (FieldModification (TableField GenreArtworkT)) +genreArtworkTModification = + tableModification + { identifier = "identifier", + genreIdentifier = GenreId "genre_identifier", + createdBy = "created_by", + visibilityStatus = "visibility_status", + approvedBy = "approved_by", + contentUrl = "content_url", + contentCaption = "content_caption", + orderValue = "order_value", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } + +genreOpinionTModification :: GenreOpinionT (FieldModification (TableField GenreOpinionT)) +genreOpinionTModification = + tableModification + { identifier = "identifier", + genreIdentifier = GenreId "genre_identifier", + createdBy = "created_by", + isLike = "is_like", + isDislike = "is_dislike", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } + +genreExternalSourcesTModification :: GenreExternalSourcesT (FieldModification (TableField GenreExternalSourcesT)) +genreExternalSourcesTModification = + tableModification + { identifier = "identifier", + genreIdentifier = GenreId "genre_identifier", + createdBy = "created_by", + spotifyUrl = "spotify_url", + youtubeUrl = "youtube_url", + soundcloudUrl = "soundcloud_url", + wikipediaUrl = "wikipedia_url", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } diff --git a/src/WikiMusic/Beam/Relations.hs b/src/WikiMusic/Beam/Relations.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Beam/Relations.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Beam.Relations where + +import Data.UUID qualified as UUID +import Database.Beam +import Optics +import WikiMusic.Beam.Artist +import WikiMusic.Beam.Genre +import WikiMusic.Beam.Song +import WikiMusic.Model.Song +import WikiMusic.Protolude + +data SongArtistT f = SongArtist' + { identifier :: C f Text, + songIdentifier :: PrimaryKey SongT f, + artistIdentifier :: PrimaryKey ArtistT f, + createdBy :: C f Text, + createdAt :: C f UTCTime + } + deriving (Generic, Beamable) + +type SongArtist' = SongArtistT Identity + +instance Table SongArtistT where + data PrimaryKey SongArtistT f = SongArtistId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = SongArtistId . (^. #identifier) + +makeFieldLabelsNoPrefix ''SongArtistT + +songArtistTModification :: SongArtistT (FieldModification (TableField SongArtistT)) +songArtistTModification = + tableModification + { identifier = "identifier", + songIdentifier = SongId "song_identifier", + artistIdentifier = ArtistId "artist_identifier", + createdBy = "created_by", + createdAt = "created_at" + } + +data SongGenreT f = SongGenre' + { identifier :: C f Text, + songIdentifier :: PrimaryKey SongT f, + genreIdentifier :: PrimaryKey GenreT f, + createdBy :: C f Text, + createdAt :: C f UTCTime + } + deriving (Generic, Beamable) + +type SongGenre' = SongGenreT Identity + +instance Table SongGenreT where + data PrimaryKey SongGenreT f = SongGenreId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = SongGenreId . (^. #identifier) + +makeFieldLabelsNoPrefix ''SongGenreT + +songGenreTModification :: SongGenreT (FieldModification (TableField SongGenreT)) +songGenreTModification = + tableModification + { identifier = "identifier", + songIdentifier = SongId "song_identifier", + genreIdentifier = GenreId "genre_identifier", + createdBy = "created_by", + createdAt = "created_at" + } + +data ArtistGenreT f = ArtistGenre' + { identifier :: C f Text, + artistIdentifier :: PrimaryKey ArtistT f, + genreIdentifier :: PrimaryKey GenreT f, + createdBy :: C f Text, + createdAt :: C f UTCTime + } + deriving (Generic, Beamable) + +type ArtistGenre' = ArtistGenreT Identity + +instance Table ArtistGenreT where + data PrimaryKey ArtistGenreT f = ArtistGenreId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = ArtistGenreId . (^. #identifier) + +makeFieldLabelsNoPrefix ''ArtistGenreT + +artistGenreTModification :: ArtistGenreT (FieldModification (TableField ArtistGenreT)) +artistGenreTModification = + tableModification + { identifier = "identifier", + artistIdentifier = ArtistId "artist_identifier", + genreIdentifier = GenreId "genre_identifier", + createdBy = "created_by", + createdAt = "created_at" + } + +mkSongArtistP :: ArtistOfSong -> SongArtist' +mkSongArtistP x = + SongArtist' + { identifier = UUID.toText $ x ^. #identifier, + songIdentifier = SongId $ UUID.toText $ x ^. #songIdentifier, + artistIdentifier = ArtistId $ UUID.toText $ x ^. #artistIdentifier, + createdBy = UUID.toText $ x ^. #createdBy, + createdAt = x ^. #createdAt + } + +mkSongGenreP x = + SongGenre' + { identifier = x ^. #identifier, + songIdentifier = SongId $ x ^. #songIdentifier, + genreIdentifier = GenreId $ x ^. #genreIdentifier, + createdBy = x ^. #createdBy, + createdAt = x ^. #createdAt + } + +mkArtistGenreP x = + ArtistGenre' + { identifier = x ^. #identifier, + artistIdentifier = ArtistId $ x ^. #artistIdentifier, + genreIdentifier = GenreId $ x ^. #genreIdentifier, + createdBy = x ^. #createdBy, + createdAt = x ^. #createdAt + } diff --git a/src/WikiMusic/Beam/Song.hs b/src/WikiMusic/Beam/Song.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Beam/Song.hs @@ -0,0 +1,440 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Beam.Song where + +import Data.Map qualified as Map +import Data.UUID qualified as UUID +import Database.Beam +import Optics +import Relude +import WikiMusic.Beam.Util +import WikiMusic.Model.Song +import WikiMusic.Protolude + +data SongT f = Song' + { identifier :: C f Text, + displayName :: C f Text, + musicKey :: C f (Maybe Text), + musicTuning :: C f (Maybe Text), + musicCreationDate :: C f (Maybe Text), + albumName :: C f (Maybe Text), + albumInfoLink :: C f (Maybe Text), + createdBy :: C f Text, + visibilityStatus :: C f Int64, + approvedBy :: C f (Maybe Text), + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime), + viewCount :: C f Int64, + description :: C f (Maybe Text) + } + deriving (Generic, Beamable) + +makeFieldLabelsNoPrefix ''SongT + +type Song' = SongT Identity + +instance Table SongT where + data PrimaryKey SongT f = SongId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = SongId . (^. #identifier) + +fromSongPk :: PrimaryKey SongT f -> Columnar f Text +fromSongPk (SongId i) = i + +toSong :: Song' -> ExternalSources -> (UUID, Song) +toSong x ex = + ( textToUUID $ x ^. #identifier, + Song + { identifier = textToUUID $ x ^. #identifier, + musicKey = x ^. #musicKey, + musicTuning = x ^. #musicTuning, + musicCreationDate = x ^. #musicCreationDate, + albumName = x ^. #albumName, + albumInfoLink = x ^. #albumInfoLink, + displayName = x ^. #displayName, + createdBy = textToUUID $ x ^. #createdBy, + visibilityStatus = fromIntegral $ x ^. #visibilityStatus, + approvedBy = fmap (textToUUID) (x ^. #approvedBy), + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt, + viewCount = fromIntegral $ x ^. #viewCount, + description = x ^. #description, + artworks = Map.empty, + comments = [], + opinions = Map.empty, + artists = Map.empty, + contents = Map.empty, + spotifyUrl = ex ^. #spotifyUrl, + youtubeUrl = ex ^. #youtubeUrl, + soundcloudUrl = ex ^. #soundcloudUrl, + wikipediaUrl = ex ^. #wikipediaUrl + } + ) + +toPersistenceSong :: Song -> Song' +toPersistenceSong x = + Song' + { identifier = UUID.toText $ x ^. #identifier, + musicKey = x ^. #musicKey, + musicTuning = x ^. #musicTuning, + musicCreationDate = x ^. #musicCreationDate, + albumName = x ^. #albumName, + albumInfoLink = x ^. #albumInfoLink, + displayName = x ^. #displayName, + createdBy = UUID.toText $ x ^. #createdBy, + visibilityStatus = fromIntegral $ x ^. #visibilityStatus, + approvedBy = fmap UUID.toText (x ^. #approvedBy), + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt, + viewCount = fromIntegral $ x ^. #viewCount, + description = x ^. #description + } + +data SongCommentT f = SongComment' + { identifier :: C f Text, + parentIdentifier :: C f (Maybe Text), + songIdentifier :: PrimaryKey SongT f, + createdBy :: C f Text, + visibilityStatus :: C f Int64, + contents :: C f Text, + approvedBy :: C f (Maybe Text), + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime) + } + deriving (Generic, Beamable) + +type SongComment' = SongCommentT Identity + +instance Table SongCommentT where + data PrimaryKey SongCommentT f = SongCommentId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = SongCommentId . (^. #identifier) + +makeFieldLabelsNoPrefix ''SongCommentT + +toPersistenceSongComment :: SongComment -> SongComment' +toPersistenceSongComment x = + SongComment' + { identifier = UUID.toText $ x ^. #comment % #identifier, + parentIdentifier = fmap (UUID.toText) (x ^. #comment % #parentIdentifier), + songIdentifier = SongId . UUID.toText $ x ^. #songIdentifier, + createdBy = UUID.toText $ x ^. #comment % #createdBy, + visibilityStatus = fromIntegral $ x ^. #comment % #visibilityStatus, + contents = x ^. #comment % #contents, + approvedBy = fmap (UUID.toText) (x ^. #comment % #approvedBy), + createdAt = x ^. #comment % #createdAt, + lastEditedAt = x ^. #comment % #lastEditedAt + } + +toSongComment :: SongComment' -> (UUID, SongComment) +toSongComment x = + ( textToUUID $ x ^. #identifier, + SongComment + { songIdentifier = textToUUID $ fromSongPk $ x ^. #songIdentifier, + comment = fromPersistenceComment $ x + } + ) + +data SongArtworkT f = SongArtwork' + { identifier :: C f Text, + songIdentifier :: PrimaryKey SongT f, + createdBy :: C f Text, + visibilityStatus :: C f Int64, + approvedBy :: C f (Maybe Text), + contentUrl :: C f Text, + contentCaption :: C f (Maybe Text), + orderValue :: C f Int64, + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime) + } + deriving (Generic, Beamable) + +type SongArtwork' = SongArtworkT Identity + +instance Table SongArtworkT where + data PrimaryKey SongArtworkT f = SongArtworkId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = SongArtworkId . (^. #identifier) + +makeFieldLabelsNoPrefix ''SongArtworkT + +toSongArtwork :: SongArtwork' -> (UUID, SongArtwork) +toSongArtwork x = + ( textToUUID $ x ^. #identifier, + SongArtwork + { songIdentifier = textToUUID $ fromSongPk $ x ^. #songIdentifier, + artwork = fromPersistenceArtwork x + } + ) + +mkSongArtworkP :: SongArtwork -> SongArtwork' +mkSongArtworkP x = + SongArtwork' + { identifier = UUID.toText $ x ^. #artwork % #identifier, + songIdentifier = SongId $ UUID.toText $ x ^. #songIdentifier, + createdBy = UUID.toText $ x ^. #artwork % #createdBy, + visibilityStatus = fromIntegral $ x ^. #artwork % #visibilityStatus, + contentUrl = x ^. #artwork % #contentUrl, + contentCaption = x ^. #artwork % #contentCaption, + orderValue = fromIntegral $ x ^. #artwork % #orderValue, + approvedBy = fmap UUID.toText $ x ^. #artwork % #approvedBy, + createdAt = x ^. #artwork % #createdAt, + lastEditedAt = x ^. #artwork % #lastEditedAt + } + +data SongOpinionT f = SongOpinion' + { identifier :: C f Text, + songIdentifier :: PrimaryKey SongT f, + createdBy :: C f Text, + isLike :: C f Bool, + isDislike :: C f Bool, + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime) + } + deriving (Generic, Beamable) + +type SongOpinion' = SongOpinionT Identity + +instance Table SongOpinionT where + data PrimaryKey SongOpinionT f = SongOpinionId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = SongOpinionId . (^. #identifier) + +makeFieldLabelsNoPrefix ''SongOpinionT + +toSongOpinion :: SongOpinion' -> (UUID, SongOpinion) +toSongOpinion x = + ( textToUUID $ x ^. #identifier, + SongOpinion + { songIdentifier = textToUUID $ fromSongPk $ x ^. #songIdentifier, + opinion = fromPersistenceOpinion x + } + ) + +data SongExternalSourcesT f = SongExternalSources' + { identifier :: C f Text, + songIdentifier :: PrimaryKey SongT f, + createdBy :: C f Text, + spotifyUrl :: C f (Maybe Text), + youtubeUrl :: C f (Maybe Text), + soundcloudUrl :: C f (Maybe Text), + wikipediaUrl :: C f (Maybe Text), + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime) + } + deriving (Generic, Beamable) + +type SongExternalSources' = SongExternalSourcesT Identity + +instance Table SongExternalSourcesT where + data PrimaryKey SongExternalSourcesT f = SongExternalSourcesId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = SongExternalSourcesId . (^. #identifier) + +makeFieldLabelsNoPrefix ''SongExternalSourcesT + +toPersistenceSongExternalContents :: Song -> UUID -> SongExternalSources' +toPersistenceSongExternalContents x newIdentifier = + SongExternalSources' + { identifier = UUID.toText $ newIdentifier, + songIdentifier = SongId $ UUID.toText $ x ^. #identifier, + createdBy = UUID.toText $ x ^. #createdBy, + spotifyUrl = x ^. #spotifyUrl, + youtubeUrl = x ^. #youtubeUrl, + soundcloudUrl = x ^. #soundcloudUrl, + wikipediaUrl = x ^. #wikipediaUrl, + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt + } + +toPersistenceSongExternalSources :: SongExternalSources -> SongExternalSources' +toPersistenceSongExternalSources x = + SongExternalSources' + { identifier = UUID.toText $ x ^. #identifier, + songIdentifier = SongId $ UUID.toText $ x ^. #songIdentifier, + createdBy = UUID.toText $ x ^. #createdBy, + spotifyUrl = x ^. #spotifyUrl, + youtubeUrl = x ^. #youtubeUrl, + soundcloudUrl = x ^. #soundcloudUrl, + wikipediaUrl = x ^. #wikipediaUrl, + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt + } + +songTModification :: SongT (FieldModification (TableField SongT)) +songTModification = + tableModification + { identifier = "identifier", + displayName = "display_name", + createdBy = "created_by", + musicKey = "music_key", + musicTuning = "music_tuning", + musicCreationDate = "music_creation_date", + albumName = "album_name", + albumInfoLink = "album_info_link", + visibilityStatus = "visibility_status", + approvedBy = "approved_by", + createdAt = "created_at", + lastEditedAt = "last_edited_at", + viewCount = "views", + description = "description" + } + +songCommentTModification :: SongCommentT (FieldModification (TableField SongCommentT)) +songCommentTModification = + tableModification + { identifier = "identifier", + songIdentifier = SongId "song_identifier", + parentIdentifier = "parent_identifier", + createdBy = "created_by", + visibilityStatus = "visibility_status", + contents = "contents", + approvedBy = "approved_by", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } + +songArtworkTModification :: SongArtworkT (FieldModification (TableField SongArtworkT)) +songArtworkTModification = + tableModification + { identifier = "identifier", + songIdentifier = SongId "song_identifier", + createdBy = "created_by", + visibilityStatus = "visibility_status", + approvedBy = "approved_by", + contentUrl = "content_url", + contentCaption = "content_caption", + orderValue = "order_value", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } + +songOpinionTModification :: SongOpinionT (FieldModification (TableField SongOpinionT)) +songOpinionTModification = + tableModification + { identifier = "identifier", + songIdentifier = SongId "song_identifier", + createdBy = "created_by", + isLike = "is_like", + isDislike = "is_dislike", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } + +songExternalSourcesTModification :: SongExternalSourcesT (FieldModification (TableField SongExternalSourcesT)) +songExternalSourcesTModification = + tableModification + { identifier = "identifier", + songIdentifier = SongId "song_identifier", + createdBy = "created_by", + spotifyUrl = "spotify_url", + youtubeUrl = "youtube_url", + soundcloudUrl = "soundcloud_url", + wikipediaUrl = "wikipedia_url", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } + +mkSongOpinionP :: SongOpinion -> SongOpinion' +mkSongOpinionP x = + SongOpinion' + { identifier = UUID.toText $ x ^. #opinion % #identifier, + songIdentifier = SongId $ UUID.toText $ x ^. #songIdentifier, + createdBy = UUID.toText $ x ^. #opinion % #createdBy, + isLike = x ^. #opinion % #isLike, + isDislike = x ^. #opinion % #isDislike, + createdAt = x ^. #opinion % #createdAt, + lastEditedAt = x ^. #opinion % #lastEditedAt + } + +data SongContentsT f = SongContents' + { identifier :: C f Text, + songIdentifier :: PrimaryKey SongT f, + versionName :: C f Text, + createdBy :: C f Text, + visibilityStatus :: C f Int64, + approvedBy :: C f (Maybe Text), + instrumentType :: C f Text, + asciiLegend :: C f (Maybe Text), + asciiContents :: C f (Maybe Text), + pdfContents :: C f (Maybe Text), + guitarProContents :: C f (Maybe Text), + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime) + } + deriving (Generic, Beamable) + +type SongContents' = SongContentsT Identity + +instance Table SongContentsT where + data PrimaryKey SongContentsT f = SongContentsId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = SongContentsId . (^. #identifier) + +makeFieldLabelsNoPrefix ''SongContentsT + +songContentsTModification :: SongContentsT (FieldModification (TableField SongContentsT)) +songContentsTModification = + tableModification + { identifier = "identifier", + songIdentifier = SongId "song_identifier", + versionName = "version_name", + createdBy = "created_by", + visibilityStatus = "visibility_status", + approvedBy = "approved_by", + instrumentType = "instrument_type", + asciiLegend = "ascii_legend", + asciiContents = "ascii_contents", + pdfContents = "pdf_contents", + guitarProContents = "guitarpro_contents", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } + +mkSongContentsP :: SongContent -> SongContents' +mkSongContentsP x = + SongContents' + { identifier = UUID.toText $ x ^. #identifier, + songIdentifier = SongId $ UUID.toText $ x ^. #songIdentifier, + versionName = x ^. #versionName, + createdBy = UUID.toText $ x ^. #createdBy, + visibilityStatus = fromIntegral $ x ^. #visibilityStatus, + approvedBy = fmap UUID.toText $ x ^. #approvedBy, + instrumentType = x ^. #instrumentType, + asciiLegend = x ^. #asciiLegend, + asciiContents = x ^. #asciiContents, + pdfContents = x ^. #pdfContents, + guitarProContents = x ^. #guitarProContents, + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt + } + +mkSongContentsM :: SongContents' -> SongContent +mkSongContentsM x = + SongContent + { identifier = textToUUID $ x ^. #identifier, + songIdentifier = textToUUID $ fromSongPk $ x ^. #songIdentifier, + versionName = x ^. #versionName, + createdBy = textToUUID $ x ^. #createdBy, + visibilityStatus = fromIntegral $ x ^. #visibilityStatus, + approvedBy = fmap textToUUID $ x ^. #approvedBy, + instrumentType = x ^. #instrumentType, + asciiLegend = x ^. #asciiLegend, + asciiContents = x ^. #asciiContents, + pdfContents = x ^. #pdfContents, + guitarProContents = x ^. #guitarProContents, + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt + } diff --git a/src/WikiMusic/Beam/User.hs b/src/WikiMusic/Beam/User.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Beam/User.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Beam.User where + +import Data.Text qualified as T +import Database.Beam +import Optics +import WikiMusic.Beam.Util +import WikiMusic.Model.Genre +import WikiMusic.Protolude + +data UserT f = User' + { identifier :: C f Text, + displayName :: C f Text, + emailAddress :: C f Text, + passwordHash :: C f (Maybe Text), + passwordResetToken :: C f (Maybe Text), + authToken :: C f (Maybe Text), + latestLoginAt :: C f (Maybe UTCTime), + latestLoginDevice :: C f (Maybe Text), + avatarUrl :: C f (Maybe Text), + createdAt :: C f UTCTime, + lastEditedAt :: C f (Maybe UTCTime), + description :: C f (Maybe Text) + } + deriving (Generic, Beamable) + +makeFieldLabelsNoPrefix ''UserT + +type User' = UserT Identity + +instance Table UserT where + data PrimaryKey UserT f = UserId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = UserId . (^. #identifier) + +userTModification :: UserT (FieldModification (TableField UserT)) +userTModification = + tableModification + { identifier = "identifier", + displayName = "display_name", + emailAddress = "email_address", + passwordHash = "password_hash", + passwordResetToken = "password_reset_token", + authToken = "auth_token", + latestLoginAt = "latest_login_at", + latestLoginDevice = "latest_login_device", + avatarUrl = "avatar_url", + createdAt = "created_at", + lastEditedAt = "last_edited_at" + } + +data UserRoleT f = UserRole' + { identifier :: C f Text, + userIdentifier :: PrimaryKey UserT f, + roleId :: C f Text, + createdAt :: C f UTCTime + } + deriving (Generic, Beamable) + +makeFieldLabelsNoPrefix ''UserRoleT + +type UserRole' = UserRoleT Identity + +instance Table UserRoleT where + data PrimaryKey UserRoleT f = UserRoleId (Columnar f Text) deriving (Generic, Beamable) + primaryKey = UserRoleId . (^. #identifier) + +userRoleTModification :: UserRoleT (FieldModification (TableField UserRoleT)) +userRoleTModification = + tableModification + { identifier = "identifier", + userIdentifier = UserId "user_identifier", + roleId = "role_id", + createdAt = "created_at" + } + +userRole :: Text -> UserRole +userRole = read . T.unpack + +mkUserM :: [Text] -> User' -> WikiMusicUser +mkUserM roles x = + WikiMusicUser + { identifier = textToUUID $ x ^. #identifier, + displayName = x ^. #displayName, + emailAddress = x ^. #emailAddress, + passwordHash = x ^. #passwordHash, + roles = map userRole roles, + authToken = x ^. #authToken + } diff --git a/src/WikiMusic/Beam/Util.hs b/src/WikiMusic/Beam/Util.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Beam/Util.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module WikiMusic.Beam.Util where + +import Data.UUID qualified as UUID +import Database.Beam +import Optics +import Relude +import Relude.Unsafe qualified as Unsafe +import WikiMusic.Model.Artwork +import WikiMusic.Model.Comment +import WikiMusic.Model.Opinion + +textToUUID :: Text -> UUID.UUID +textToUUID = Unsafe.fromJust . UUID.fromText + +fromPersistenceArtwork x = + Artwork + { identifier = textToUUID $ x ^. #identifier, + createdBy = textToUUID $ x ^. #createdBy, + visibilityStatus = fromIntegral $ x ^. #visibilityStatus, + approvedBy = fmap textToUUID $ x ^. #approvedBy, + contentUrl = x ^. #contentUrl, + contentCaption = x ^. #contentCaption, + orderValue = fromIntegral $ x ^. #orderValue, + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt + } + +fromPersistenceComment x = + Comment + { identifier = textToUUID $ x ^. #identifier, + parentIdentifier = fmap textToUUID $ x ^. #parentIdentifier, + createdBy = textToUUID $ x ^. #createdBy, + visibilityStatus = fromIntegral $ x ^. #visibilityStatus, + contents = x ^. #contents, + approvedBy = fmap textToUUID $ x ^. #approvedBy, + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt + } + +fromPersistenceOpinion x = + Opinion + { identifier = textToUUID $ x ^. #identifier, + createdBy = textToUUID $ x ^. #createdBy, + isLike = x ^. #isLike, + isDislike = x ^. #isDislike, + createdAt = x ^. #createdAt, + lastEditedAt = x ^. #lastEditedAt + } + +fromPersistenceExternalSource x = + ExternalSources + { spotifyUrl = x ^. #spotifyUrl, + youtubeUrl = x ^. #youtubeUrl, + soundcloudUrl = x ^. #soundcloudUrl, + wikipediaUrl = x ^. #wikipediaUrl + } + +data ExternalSources = ExternalSources + { spotifyUrl :: Maybe Text, + youtubeUrl :: Maybe Text, + soundcloudUrl :: Maybe Text, + wikipediaUrl :: Maybe Text + } + deriving (Generic, Eq, Show) + +makeFieldLabelsNoPrefix ''ExternalSources + +emptyExternalSources :: ExternalSources +emptyExternalSources = + ExternalSources + { spotifyUrl = Nothing, + youtubeUrl = Nothing, + soundcloudUrl = Nothing, + wikipediaUrl = Nothing + } diff --git a/src/WikiMusic/Boot.hs b/src/WikiMusic/Boot.hs --- a/src/WikiMusic/Boot.hs +++ b/src/WikiMusic/Boot.hs @@ -2,80 +2,52 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoFieldSelectors #-} -module WikiMusic.Boot - ( boot, - ) -where +module WikiMusic.Boot where +import Control.Concurrent import Control.Monad -import Data.ByteString.Lazy qualified as BL -import Data.Text (pack, unpack) -import Database.Redis qualified as Redis -import Hasql.Connection qualified -import Hasql.Pool qualified -import Hasql.Session qualified +import Data.Text qualified as T +import Database.Beam import Network.Wai.Handler.Warp +import Network.Wai.Logger (ApacheLogger, withStdoutLogger) import Optics +import Prometheus qualified as P +import Prometheus.Metric.GHC qualified as P import Relude import WikiMusic.Config import WikiMusic.Model.Config -import WikiMusic.PostgreSQL.Migration import WikiMusic.Servant.ApiSetup +import Yggdrasil boot :: (MonadIO m) => m () -boot = do - args <- liftIO getArgs - case nonEmpty args of - Just (x :| []) -> do - cfg <- readConfig (pack x) - liftIO $ either crashWithBadConfig doRun cfg - _ -> crashWithNoConfigFile args +boot = liftIO $ withStdoutLogger $ \logger' -> + ( do + _ <- liftIO $ P.register P.ghcMetrics + args <- liftIO getArgs + maybeCfg <- readConfig (configPathFromArgs args) + liftIO $ either crashWithBadConfig (doRun logger') maybeCfg + ) where - crashWithNoConfigFile args = error $ "No path to a config file was specified! Args: " <> show args crashWithBadConfig e = error ("Bad config could not be parsed! " <> show e) - doRun cfg = do - pool <- makePostgresPool cfg - redisConn <- makeRedisConn cfg - startWikiMusicAPI cfg pool redisConn - -startWikiMusicAPI :: (MonadIO m) => AppConfig -> Hasql.Pool.Pool -> Redis.Connection -> m () -startWikiMusicAPI cfg pool redisConn = do - maybeRunMigrations - liftIO . BL.putStr $ "Starting REST API ..." - liftIO $ runSettings apiSettings =<< mkApp cfg pool redisConn - where - apiSettings = setPort (cfg ^. #servant % #port) defaultSettings - maybeRunMigrations = do - when (cfg ^. #postgresql % #runMigrations) $ do - liftIO . BL.putStr $ "Starting database migrations ..." - ex <- liftIO . runWikiMusicMigrations $ pool - liftIO . BL.putStr . fromString . show $ ex - pure () - -makeRedisConn :: (MonadIO m) => AppConfig -> m Redis.Connection -makeRedisConn cfg = liftIO $ Redis.checkedConnect redisConnectionSettings - where - redisConnectionSettings = - Redis.defaultConnectInfo - { Redis.connectPort = Redis.PortNumber (fromIntegral $ cfg ^. #redis % #port), - Redis.connectAuth = fmap (fromString . unpack) (cfg ^. #redis % #password) + doRun logger' cfg = do + liftIO . putText $ "Starting Yggdrasil migrations ..." + _ <- forkIO $ runYggdrasil (yggdrasil cfg) + _ <- startWikiMusicAPI logger' cfg + pure () + yggdrasil cfg = + Yggdrasil + { databaseFilePath = cfg ^. #sqlite % #path, + migrationsDirectoryPath = "./resources/migrations/sqlite/", + runMigrations = True, + engine = SQLite } - -makePostgresPool :: (MonadIO m) => AppConfig -> m Hasql.Pool.Pool -makePostgresPool cfg = do - pool <- liftIO $ Hasql.Pool.acquire poolSize 10 10 10 dbConnectionSettings - - let healthSess = Hasql.Session.sql "SELECT 1" - s <- liftIO $ Hasql.Pool.use pool healthSess - either (liftIO . BL.putStr . fromString . show) pure s + configPathFromArgs args = case nonEmpty args of + Just (x :| []) -> T.pack x + _ -> "resources/config/run-local.toml" - pure pool +startWikiMusicAPI :: (MonadIO m) => ApacheLogger -> AppConfig -> m () +startWikiMusicAPI logger' cfg = do + liftIO . putText $ "Starting REST API ..." + liftIO $ runSettings apiSettings =<< mkApp logger' cfg where - poolSize = cfg ^. #postgresql % #poolSize - dbConnectionSettings = - Hasql.Connection.settings - (fromString . unpack $ cfg ^. #postgresql % #host) - (fromIntegral $ cfg ^. #postgresql % #port) - (fromString . unpack $ cfg ^. #postgresql % #user) - (maybe "" (fromString . unpack) (cfg ^. #postgresql % #password)) - (fromString . unpack $ cfg ^. #postgresql % #name) + apiSettings = setPort (cfg ^. #servant % #port) defaultSettings diff --git a/src/WikiMusic/Config.hs b/src/WikiMusic/Config.hs --- a/src/WikiMusic/Config.hs +++ b/src/WikiMusic/Config.hs @@ -20,18 +20,18 @@ readSecrets :: (MonadIO m) => AppConfig -> m AppConfig readSecrets cfg = do - postgresqlPassword <- readSecretFromFile cfg (^. #postgresql % #passwordFile) - redisPassword <- readSecretFromFile cfg (^. #redis % #passwordFile) mailPassword <- readSecretFromFile cfg (^. #mail % #passwordFile) - let withRedisCfg = cfg & #redis .~ ((cfg ^. #redis) & #password ?~ redisPassword) - withPostgresCfg = - withRedisCfg - & #postgresql - .~ ((withRedisCfg ^. #postgresql) & #password ?~ postgresqlPassword) - finalCfg = - withPostgresCfg - & #mail - .~ ((withPostgresCfg ^. #mail) & #password ?~ mailPassword) + mailUser <- readSecretFromFile cfg (^. #mail % #userFile) + let mailConfig = cfg ^. #mail + let finalCfg = + cfg + { mail = + mailConfig + { password = Just mailPassword, + user = Just mailUser + } + } + pure finalCfg readSecretFromFile :: (MonadIO m) => t -> (t -> Text) -> m Text diff --git a/src/WikiMusic/Free/ArtistCommand.hs b/src/WikiMusic/Free/ArtistCommand.hs --- a/src/WikiMusic/Free/ArtistCommand.hs +++ b/src/WikiMusic/Free/ArtistCommand.hs @@ -34,8 +34,8 @@ type ArtistCommand :: Type -> Type data ArtistCommand a - = InsertArtists Env [Artist] (Map UUID Artist -> a) - | InsertArtistComments Env [ArtistComment] (Map UUID ArtistComment -> a) + = InsertArtists Env [Artist] (() -> a) + | InsertArtistComments Env [ArtistComment] (() -> a) | InsertArtistArtworks Env [ArtistArtwork] (Map UUID ArtistArtwork -> a) | UpsertArtistOpinions Env [ArtistOpinion] (Map UUID ArtistOpinion -> a) | InsertArtistExternalSources Env [ArtistExternalSources] (Map UUID ArtistExternalSources -> a) @@ -57,10 +57,10 @@ | IncrementViewsByOne Env [UUID] (Either ArtistCommandError () -> a) deriving (Functor) -insertArtists :: (ArtistCommand :<: f) => Env -> [Artist] -> Free f (Map UUID Artist) +insertArtists :: (ArtistCommand :<: f) => Env -> [Artist] -> Free f () insertArtists env artists = injectFree (InsertArtists env artists Pure) -insertArtistComments :: (ArtistCommand :<: f) => Env -> [ArtistComment] -> Free f (Map UUID ArtistComment) +insertArtistComments :: (ArtistCommand :<: f) => Env -> [ArtistComment] -> Free f () insertArtistComments env artistComments = injectFree (InsertArtistComments env artistComments Pure) insertArtistArtworks :: (ArtistCommand :<: f) => Env -> [ArtistArtwork] -> Free f (Map UUID ArtistArtwork) diff --git a/src/WikiMusic/Free/SongCommand.hs b/src/WikiMusic/Free/SongCommand.hs --- a/src/WikiMusic/Free/SongCommand.hs +++ b/src/WikiMusic/Free/SongCommand.hs @@ -52,7 +52,7 @@ type SongCommand :: Type -> Type data SongCommand a = InsertSongs Env [Song] (Map UUID Song -> a) - | InsertSongComments Env [SongComment] (Map UUID SongComment -> a) + | InsertSongComments Env [SongComment] (Either SongCommandError () -> a) | InsertSongArtworks Env [SongArtwork] (Map UUID SongArtwork -> a) | InsertArtistsOfSongs Env [ArtistOfSong] (Map UUID ArtistOfSong -> a) | InsertSongExternalSources Env [SongExternalSources] (Map UUID SongExternalSources -> a) @@ -87,7 +87,7 @@ insertSongs :: (SongCommand :<: f) => Env -> [Song] -> Free f (Map UUID Song) insertSongs env songs = injectFree (InsertSongs env songs Pure) -insertSongComments :: (SongCommand :<: f) => Env -> [SongComment] -> Free f (Map UUID SongComment) +insertSongComments :: (SongCommand :<: f) => Env -> [SongComment] -> Free f (Either SongCommandError ()) insertSongComments env songComments = injectFree (InsertSongComments env songComments Pure) insertSongArtworks :: (SongCommand :<: f) => Env -> [SongArtwork] -> Free f (Map UUID SongArtwork) diff --git a/src/WikiMusic/Interaction/Artist.hs b/src/WikiMusic/Interaction/Artist.hs --- a/src/WikiMusic/Interaction/Artist.hs +++ b/src/WikiMusic/Interaction/Artist.hs @@ -25,9 +25,9 @@ import WikiMusic.Interaction.Model.Artist import WikiMusic.Model.Artist import WikiMusic.Model.Other -import WikiMusic.PostgreSQL.ArtistCommand () -import WikiMusic.PostgreSQL.ArtistQuery () import WikiMusic.Protolude +import WikiMusic.Sqlite.ArtistCommand () +import WikiMusic.Sqlite.ArtistQuery () fetchArtistsAction :: (ArtistQuery :<: f, ArtistCommand :<: f) => @@ -140,11 +140,11 @@ validationResults = fromList $ map entityValidation newComments ifAllValid validationResults $ do - insertedComments <- insertArtistComments env newComments + _ <- insertArtistComments env newComments pure . Right $ InsertArtistCommentsCommandResponse - { artistComments = insertedComments, + { artistComments = Map.empty, validationResults = validationResults } @@ -247,8 +247,8 @@ let artistArtworkOrderUpdates = request ^. #artistArtworkOrders entityValidation x = (x ^. #identifier, validateArtistArtworkOrderUpdate x) validationResults = - fromList $ - map (first (pack . Relude.show) . entityValidation) artistArtworkOrderUpdates + fromList + $ map (first (pack . Relude.show) . entityValidation) artistArtworkOrderUpdates ifAllValid validationResults $ do operationResults <- updateArtistArtworkOrder env artistArtworkOrderUpdates diff --git a/src/WikiMusic/Interaction/Auth.hs b/src/WikiMusic/Interaction/Auth.hs --- a/src/WikiMusic/Interaction/Auth.hs +++ b/src/WikiMusic/Interaction/Auth.hs @@ -10,8 +10,8 @@ import WikiMusic.Free.AuthQuery import WikiMusic.Interaction.Model.Auth -import WikiMusic.PostgreSQL.AuthQuery () import WikiMusic.Protolude +import WikiMusic.Sqlite.AuthQuery () fetchMeAction :: (AuthQuery :<: f) => Env -> UUID -> Free f (Maybe GetMeQueryResponse) fetchMeAction env identifier = do diff --git a/src/WikiMusic/Interaction/Genre.hs b/src/WikiMusic/Interaction/Genre.hs --- a/src/WikiMusic/Interaction/Genre.hs +++ b/src/WikiMusic/Interaction/Genre.hs @@ -25,9 +25,9 @@ import WikiMusic.Interaction.Model.Genre import WikiMusic.Model.Genre import WikiMusic.Model.Other -import WikiMusic.PostgreSQL.GenreCommand () -import WikiMusic.PostgreSQL.GenreQuery () import WikiMusic.Protolude +import WikiMusic.Sqlite.GenreCommand () +import WikiMusic.Sqlite.GenreQuery () fetchGenresAction :: (GenreQuery :<: f, GenreCommand :<: f) => @@ -260,13 +260,13 @@ Free f (Either GenreError ()) updateGenreAction env authUser request = doWithRoles' authUser isAtLeastLowRank AccessUnauthorizedError $ do - let deltas = request ^. #genreDeltas + let δ = request ^. #genreDeltas entityValidation x = (x ^. #identifier, validateGenreDelta x) - validationResults = fromList . map (first (pack . Relude.show) . entityValidation) $ deltas + validationResults = fromList . map (first (pack . Relude.show) . entityValidation) $ δ ifAllValid validationResults $ do - let genreIds = map (^. #identifier) deltas - deltaMap = fromList $ map (\x -> (x ^. #identifier, x)) deltas + let genreIds = map (^. #identifier) δ + deltaMap = fromList $ map (\x -> (x ^. #identifier, x)) δ genreRecords <- fst <$> fetchGenresByUUID env DescCreatedAt genreIds diff --git a/src/WikiMusic/Interaction/Song.hs b/src/WikiMusic/Interaction/Song.hs --- a/src/WikiMusic/Interaction/Song.hs +++ b/src/WikiMusic/Interaction/Song.hs @@ -148,11 +148,11 @@ validationResults = fromList $ map (first (pack . Relude.show) . entityValidation) newComments ifAllValid validationResults $ do - insertedComments <- insertSongComments env newComments + _ <- insertSongComments env newComments pure . Right $ InsertSongCommentsCommandResponse - { songComments = insertedComments, + { songComments = Map.empty, validationResults = validationResults } @@ -319,8 +319,9 @@ Just songArtists -> do let r = head songArtists operationResults <- deleteArtistOfSong env (r ^. #songIdentifier, r ^. #artistIdentifier) - pure . first (SomeError . pack . Relude.show) $ - operationResults + pure + . first (SomeError . pack . Relude.show) + $ operationResults updateSongContentsAction :: (SongCommand :<: f) => diff --git a/src/WikiMusic/Interaction/User.hs b/src/WikiMusic/Interaction/User.hs --- a/src/WikiMusic/Interaction/User.hs +++ b/src/WikiMusic/Interaction/User.hs @@ -87,12 +87,16 @@ case maybeToken of Left e -> pure . Left . SomeError . pack . show $ e Right token -> do + let mailCss = env ^. #mailCss let resetLink = (env ^. #cfg % #webFrontend % #baseUrl) - <> "/#/user/reset-password/token?" + <> "/passwords/do-reset?" <> (pack . Network.HTTP.Base.urlEncodeVars $ [("token", unpack token)]) mailBody = [trimming| +

Reset your password on WikiMusic

We have received a request to reset the password for your user on WikiMusic.

Go reset your password on WikiMusic! diff --git a/src/WikiMusic/Model/Config.hs b/src/WikiMusic/Model/Config.hs --- a/src/WikiMusic/Model/Config.hs +++ b/src/WikiMusic/Model/Config.hs @@ -4,60 +4,25 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoFieldSelectors #-} -module WikiMusic.Model.Config - ( AppConfig (..), - PostgreSQLConfig (..), - RedisConfig (..), - ServantConfig (..), - CorsConfig (..), - -- CookieConfig (..), - MailConfig (..), - WebFrontendConfig (..), - appConfigCodec, - ) -where +module WikiMusic.Model.Config where import Optics import Relude import Toml -data PostgreSQLConfig = PostgreSQLConfig - { user :: Text, - passwordFile :: Text, - password :: Maybe Text, - port :: Int, - name :: Text, - poolSize :: Int, - host :: Text, +data SqliteConfig = SqliteConfig + { path :: Text, runMigrations :: Bool } deriving (Generic, Eq, Show) -postgreSQLConfigCodec :: TomlCodec PostgreSQLConfig -postgreSQLConfigCodec = - PostgreSQLConfig - <$> Toml.text "user" .= (^. #user) - <*> Toml.text "password-file" .= (^. #passwordFile) - <*> Toml.dioptional (Toml.text "password") .= (^. #password) - <*> Toml.int "port" .= (^. #port) - <*> Toml.text "name" .= (^. #name) - <*> Toml.int "pool-size" .= (^. #poolSize) - <*> Toml.text "host" .= (^. #host) - <*> Toml.bool "run-migrations" .= (^. #runMigrations) - -data RedisConfig = RedisConfig - { port :: Int, - passwordFile :: Text, - password :: Maybe Text - } - deriving (Generic, Eq, Show) - -redisConfigCodec :: TomlCodec RedisConfig -redisConfigCodec = - RedisConfig - <$> Toml.int "port" .= (^. #port) - <*> Toml.text "password-file" .= (^. #passwordFile) - <*> Toml.dioptional (Toml.text "password") .= (^. #password) +sqliteConfigCodec :: TomlCodec SqliteConfig +sqliteConfigCodec = + SqliteConfig + <$> Toml.text "path" + .= (^. #path) + <*> Toml.bool "run-migrations" + .= (^. #runMigrations) data ServantConfig = ServantConfig { port :: Int, @@ -68,8 +33,10 @@ servantConfigCodec :: TomlCodec ServantConfig servantConfigCodec = ServantConfig - <$> Toml.int "port" .= (^. #port) - <*> Toml.text "host" .= (^. #host) + <$> Toml.int "port" + .= (^. #port) + <*> Toml.text "host" + .= (^. #host) data CorsConfig = CorsConfig { origins :: [Text], @@ -81,34 +48,18 @@ corsConfigCodec :: TomlCodec CorsConfig corsConfigCodec = CorsConfig - <$> Toml.arrayOf Toml._Text "origins" .= (^. #origins) - <*> Toml.arrayOf Toml._Text "methods" .= (^. #methods) - <*> Toml.arrayOf Toml._Text "request-headers" .= (^. #requestHeaders) - --- data CookieConfig = CookieConfig --- { maxAge :: Int, --- path :: Text, --- domain :: Text, --- sessionCookieName :: Text, --- secure :: Text, --- sameSite :: Text --- } --- deriving (Generic, Eq, Show) - --- cookieConfigCodec :: TomlCodec CookieConfig --- cookieConfigCodec = --- CookieConfig --- <$> Toml.int "max-age" .= (^. #maxAge) --- <*> Toml.text "path" .= (^. #path) --- <*> Toml.text "domain" .= (^. #domain) --- <*> Toml.text "session-cookie-name" .= (^. #sessionCookieName) --- <*> Toml.text "secure" .= (^. #secure) --- <*> Toml.text "same-site" .= (^. #sameSite) + <$> Toml.arrayOf Toml._Text "origins" + .= (^. #origins) + <*> Toml.arrayOf Toml._Text "methods" + .= (^. #methods) + <*> Toml.arrayOf Toml._Text "request-headers" + .= (^. #requestHeaders) data MailConfig = MailConfig { sendTimeoutSeconds :: Int, host :: Text, - user :: Text, + userFile :: Text, + user :: Maybe Text, passwordFile :: Text, password :: Maybe Text, senderName :: Text, @@ -119,13 +70,22 @@ mailConfigCodec :: TomlCodec MailConfig mailConfigCodec = MailConfig - <$> Toml.int "send-timeout-seconds" .= (^. #sendTimeoutSeconds) - <*> Toml.text "host" .= (^. #host) - <*> Toml.text "user" .= (^. #user) - <*> Toml.text "password-file" .= (^. #passwordFile) - <*> Toml.dioptional (Toml.text "password") .= (^. #password) - <*> Toml.text "sender-name" .= (^. #senderName) - <*> Toml.text "sender-mail" .= (^. #senderMail) + <$> Toml.int "send-timeout-seconds" + .= (^. #sendTimeoutSeconds) + <*> Toml.text "host" + .= (^. #host) + <*> Toml.text "user-file" + .= (^. #userFile) + <*> Toml.dioptional (Toml.text "user") + .= (^. #user) + <*> Toml.text "password-file" + .= (^. #passwordFile) + <*> Toml.dioptional (Toml.text "password") + .= (^. #password) + <*> Toml.text "sender-name" + .= (^. #senderName) + <*> Toml.text "sender-mail" + .= (^. #senderMail) newtype WebFrontendConfig = WebFrontendConfig { baseUrl :: Text @@ -135,7 +95,8 @@ webFrontendConfigCodec :: TomlCodec WebFrontendConfig webFrontendConfigCodec = WebFrontendConfig - <$> Toml.text "base-url" .= (^. #baseUrl) + <$> Toml.text "base-url" + .= (^. #baseUrl) newtype DevConfig = DevConfig { reportedVersion :: Text @@ -147,10 +108,8 @@ data AppConfig = AppConfig { servant :: ServantConfig, - postgresql :: PostgreSQLConfig, - redis :: RedisConfig, + sqlite :: SqliteConfig, cors :: CorsConfig, - -- cookie :: CookieConfig, mail :: MailConfig, webFrontend :: WebFrontendConfig, dev :: DevConfig @@ -160,22 +119,23 @@ appConfigCodec :: TomlCodec AppConfig appConfigCodec = AppConfig - <$> Toml.table servantConfigCodec "servant" .= (^. #servant) - <*> Toml.table postgreSQLConfigCodec "postgresql" .= (^. #postgresql) - <*> Toml.table redisConfigCodec "redis" .= (^. #redis) - <*> Toml.table corsConfigCodec "cors" .= (^. #cors) - -- <*> Toml.table cookieConfigCodec "cookie" .= (^. #cookie) - <*> Toml.table mailConfigCodec "mail" .= (^. #mail) - <*> Toml.table webFrontendConfigCodec "web-frontend" .= (^. #webFrontend) - <*> Toml.table devCodec "dev" .= (^. #dev) + <$> Toml.table servantConfigCodec "servant" + .= (^. #servant) + <*> Toml.table sqliteConfigCodec "sqlite" + .= (^. #sqlite) + <*> Toml.table corsConfigCodec "cors" + .= (^. #cors) + <*> Toml.table mailConfigCodec "mail" + .= (^. #mail) + <*> Toml.table webFrontendConfigCodec "web-frontend" + .= (^. #webFrontend) + <*> Toml.table devCodec "dev" + .= (^. #dev) makeFieldLabelsNoPrefix ''AppConfig -makeFieldLabelsNoPrefix ''PostgreSQLConfig -makeFieldLabelsNoPrefix ''RedisConfig +makeFieldLabelsNoPrefix ''SqliteConfig makeFieldLabelsNoPrefix ''ServantConfig makeFieldLabelsNoPrefix ''CorsConfig - --- makeFieldLabelsNoPrefix ''CookieConfig makeFieldLabelsNoPrefix ''MailConfig makeFieldLabelsNoPrefix ''WebFrontendConfig makeFieldLabelsNoPrefix ''DevConfig diff --git a/src/WikiMusic/Model/Env.hs b/src/WikiMusic/Model/Env.hs --- a/src/WikiMusic/Model/Env.hs +++ b/src/WikiMusic/Model/Env.hs @@ -9,14 +9,18 @@ where import Data.Time -import Hasql.Pool qualified +import Database.SQLite.Simple +import Network.Wai.Logger (ApacheLogger) import Optics +import Relude import WikiMusic.Model.Config data Env = Env - { pool :: Hasql.Pool.Pool, - cfg :: AppConfig, - processStartedAt :: UTCTime + { cfg :: AppConfig, + processStartedAt :: UTCTime, + logger :: ApacheLogger, + conn :: Connection, + mailCss :: Text } makeFieldLabelsNoPrefix ''Env diff --git a/src/WikiMusic/PostgreSQL/ArtistCommand.hs b/src/WikiMusic/PostgreSQL/ArtistCommand.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/ArtistCommand.hs +++ /dev/null @@ -1,449 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module WikiMusic.PostgreSQL.ArtistCommand () where - -import Data.Text (pack) -import Hasql.Decoders as D -import Hasql.Encoders as E -import Hasql.Pool qualified -import Hasql.Statement (Statement (..)) -import Relude -import WikiMusic.Free.ArtistCommand -import WikiMusic.Interaction.Model.Artist -import WikiMusic.Model.Artist -import WikiMusic.Model.Artwork -import WikiMusic.Model.Comment -import WikiMusic.Model.Opinion -import WikiMusic.PostgreSQL.ReadAbstraction -import WikiMusic.PostgreSQL.WriteAbstraction -import WikiMusic.Protolude - -insertArtists' :: (MonadIO m) => Env -> [Artist] -> m (Map UUID Artist) -insertArtists' env artists = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) artists - now <- liftIO getCurrentTime - mapM_ - ( \x -> do - newUUID <- liftIO nextRandom - liftIO $ exec @ArtistCommand $ insertArtistExternalSources env [toExternalSource x now newUUID] - ) - artists - pure . fromList . map (\x -> (x ^. #identifier, x)) $ artists - where - toExternalSource x now newUUID = - ArtistExternalSources - { identifier = newUUID, - artistIdentifier = x ^. #identifier, - spotifyUrl = x ^. #spotifyUrl, - youtubeUrl = x ^. #youtubeUrl, - soundcloudUrl = x ^. #soundcloudUrl, - wikipediaUrl = x ^. #wikipediaUrl, - createdAt = now, - createdBy = x ^. #createdBy, - lastEditedAt = Nothing - } - toRow x = - ( x ^. #identifier, - x ^. #displayName, - x ^. #createdBy, - fromIntegral $ x ^. #visibilityStatus, - x ^. #approvedBy, - x ^. #createdAt, - x ^. #lastEditedAt, - x ^. #description - ) - encoder = - contrazip8 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nullable E.uuid)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - (E.param (E.nullable E.text)) - stmt = Statement query encoder D.noResult True - bindParams' = bindParams 8 - query = - encodeUtf8 - [trimming| - INSERT INTO artists - (identifier, display_name, created_by, visibility_status, - approved_by, created_at, last_edited_at, description) - VALUES ( $bindParams' ) - |] - -insertArtistComments' :: (MonadIO m) => Env -> [ArtistComment] -> m (Map UUID ArtistComment) -insertArtistComments' env comments = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) comments - pure . fromList . map (\x -> (x ^. #comment % #identifier, x)) $ comments - where - toRow x = - ( x ^. #comment % #identifier, - x ^. #artistIdentifier, - x ^. #comment % #parentIdentifier, - x ^. #comment % #createdBy, - fromIntegral $ x ^. #comment % #visibilityStatus, - x ^. #comment % #contents, - x ^. #comment % #approvedBy, - x ^. #comment % #createdAt, - x ^. #comment % #lastEditedAt - ) - encoder = - contrazip9 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.text)) - (E.param (E.nullable E.uuid)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - stmt = Statement query encoder D.noResult True - bindParams' = bindParams 9 - query = - encodeUtf8 - [trimming| - INSERT INTO artist_comments - (identifier, artist_identifier, parent_identifier, created_by, - visibility_status, contents, approved_by, created_at, last_edited_at) - VALUES ( $bindParams' ) - |] - -insertArtistExternalSources' :: (MonadIO m) => Env -> [ArtistExternalSources] -> m (Map UUID ArtistExternalSources) -insertArtistExternalSources' env externalSources = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) externalSources - pure . fromList . map (\x -> (x ^. #identifier, x)) $ externalSources - where - stmt = Statement query encoder D.noResult True - encoder = - contrazip9 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - (E.param (E.nonNullable E.uuid)) - bindParams' = bindParams 9 - query = - encodeUtf8 - [trimming| - INSERT INTO artist_external_sources - (identifier, artist_identifier, spotify_url, youtube_url, - soundcloud_url, wikipedia_url, created_at, last_edited_at, created_by) - VALUES ( $bindParams' ) - |] - toRow x = - ( x ^. #identifier, - x ^. #artistIdentifier, - x ^. #spotifyUrl, - x ^. #youtubeUrl, - x ^. #soundcloudUrl, - x ^. #wikipediaUrl, - x ^. #createdAt, - x ^. #lastEditedAt, - x ^. #createdBy - ) - -insertArtistArtworks' :: (MonadIO m) => Env -> [ArtistArtwork] -> m (Map UUID ArtistArtwork) -insertArtistArtworks' env artworks = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) artworks - pure . fromList . map (\x -> (x ^. #artwork % #identifier, x)) $ artworks - where - toRow x = - ( x ^. #artwork % #identifier, - x ^. #artistIdentifier, - x ^. #artwork % #createdBy, - fromIntegral $ x ^. #artwork % #visibilityStatus, - x ^. #artwork % #approvedBy, - x ^. #artwork % #contentUrl, - x ^. #artwork % #createdAt, - x ^. #artwork % #lastEditedAt, - x ^. #artwork % #contentCaption, - fromIntegral $ x ^. #artwork % #orderValue - ) - stmt = Statement query encoder D.noResult True - encoder = - contrazip10 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - (E.param (E.nullable E.text)) - (E.param (E.nonNullable E.int8)) - bindParams' = bindParams 10 - query = - encodeUtf8 - [trimming| - INSERT INTO artist_artworks - (identifier, artist_identifier, created_by, visibility_status, - approved_by, content_url, created_at, last_edited_at, content_caption, order_value) - VALUES ( $bindParams' ) - |] - -upsertArtistOpinions' :: (MonadIO m) => Env -> [ArtistOpinion] -> m (Map UUID ArtistOpinion) -upsertArtistOpinions' env opinions = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) opinions - pure . fromList . map (\x -> (x ^. #opinion % #identifier, x)) $ opinions - where - bindParams' = bindParams 7 - query = - encodeUtf8 - [trimming| - INSERT INTO artist_opinions - (identifier, artist_identifier, created_by, is_like, is_dislike, - created_at, last_edited_at) - VALUES ( $bindParams' ) - ON CONFLICT (artist_identifier, created_by) DO - UPDATE SET is_like = $$4, is_dislike = $$5, - last_edited_at = $$6 - |] - stmt = Statement query encoder D.noResult True - encoder = - contrazip7 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.bool)) - (E.param (E.nonNullable E.bool)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - toRow x = do - ( x ^. #opinion % #identifier, - x ^. #artistIdentifier, - x ^. #opinion % #createdBy, - x ^. #opinion % #isLike, - not $ x ^. #opinion % #isLike, - x ^. #opinion % #createdAt, - x ^. #opinion % #lastEditedAt - ) - -deleteArtists' :: (MonadIO m) => Env -> [UUID] -> m (Either ArtistCommandError ()) -deleteArtists' env identifiers = do - deleteArtworksOfArtistsResult <- liftIO . exec @ArtistCommand $ deleteArtworksOfArtists env identifiers - deleteOpinionsOfArtistsResult <- liftIO . exec @ArtistCommand $ deleteOpinionsOfArtists env identifiers - deleteCommentsOfArtistsResult <- liftIO . exec @ArtistCommand $ deleteCommentsOfArtists env identifiers - deleteArtistExternalSourcesResult <- liftIO . exec @ArtistCommand $ deleteArtistExternalSources env identifiers - deleteArtistsResult <- deleteStuffByUUID (env ^. #pool) "artists" "identifier" identifiers - pure $ - deleteArtworksOfArtistsResult - <> deleteOpinionsOfArtistsResult - <> deleteArtistExternalSourcesResult - <> deleteCommentsOfArtistsResult - <> first fromHasqlUsageError deleteArtistsResult - -updateArtistArtworkOrder' :: (MonadIO m) => Env -> [ArtistArtworkOrderUpdate] -> m (Either a ()) -updateArtistArtworkOrder' env orderUpdates = - Right <$> mapM_ performUpdate orderUpdates - where - stmt = Statement query encoder D.noResult True - query = - encodeUtf8 - [trimming| - UPDATE artist_artworks SET order_value = $$2 WHERE identifier = $$1 - |] - encoder = - contrazip2 (E.param . E.nonNullable $ E.uuid) (E.param . E.nonNullable $ E.int8) - toRow x = (x ^. #identifier, fromIntegral $ x ^. #orderValue) - performUpdate x = do - operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow x) - pure $ first (pack . Relude.show) operationResults - -updateArtists' :: (MonadIO m) => Env -> Map UUID (Artist, Maybe ArtistDelta) -> m (Either Text ()) -updateArtists' env deltas = do - liftIO $ mapM_ performUpdate deltas - exUpdate <- liftIO $ exec @ArtistCommand $ updateArtistExternalSources env deltas - pure $ exUpdate <> Right () - where - stmt = Statement query encoder D.noResult True - query = - encodeUtf8 - [trimming| - UPDATE artists SET display_name = $$2, last_edited_at = $$3, description = $$4 WHERE identifier = $$1 - |] - encoder = - contrazip4 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nullable E.timestamptz)) - (E.param (E.nullable E.text)) - toRow x xDelta now = - ( x ^. #identifier, - fromMaybe (x ^. #displayName) (xDelta ^. #displayName), - Just now, - xDelta ^. #description - ) - performUpdate (_, Nothing) = pure $ Right () - performUpdate (x, Just xDelta) = do - now <- getCurrentTime - operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow x xDelta now) - pure $ first (pack . Relude.show) operationResults - -updateArtistExternalSources' :: (MonadIO m) => Env -> Map UUID (Artist, Maybe ArtistDelta) -> m (Either Text ()) -updateArtistExternalSources' env deltas = - Right <$> mapM_ performUpdate deltas - where - stmt = Statement query encoder D.noResult True - query = - encodeUtf8 - [trimming| - UPDATE artist_external_sources SET - spotify_url = $$2, - youtube_url = $$3, - wikipedia_url = $$4, - soundcloud_url = $$5 - WHERE artist_identifier = $$1 - |] - - encoder = - contrazip5 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - toRow x xDelta = - ( x ^. #identifier, - xDelta ^. #spotifyUrl, - xDelta ^. #youtubeUrl, - xDelta ^. #wikipediaUrl, - xDelta ^. #soundcloudUrl - ) - performUpdate (_, Nothing) = pure $ Right () - performUpdate (x, Just xDelta) = do - operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow x xDelta) - pure $ first (pack . Relude.show) operationResults - -newArtistArtworkFromRequest' :: (MonadIO m) => UUID -> InsertArtistArtworksRequestItem -> m ArtistArtwork -newArtistArtworkFromRequest' createdBy req = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - ArtistArtwork - { artistIdentifier = req ^. #artistIdentifier, - artwork = - Artwork - { identifier = newUUID, - createdBy = createdBy, - contentUrl = req ^. #contentUrl, - contentCaption = req ^. #contentCaption, - createdAt = now, - lastEditedAt = Nothing, - visibilityStatus = 0, - approvedBy = Nothing, - orderValue = req ^. #orderValue - } - } - -newArtistOpinionFromRequest' :: (MonadIO m) => UUID -> UpsertArtistOpinionsRequestItem -> m ArtistOpinion -newArtistOpinionFromRequest' createdBy req = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - ArtistOpinion - { artistIdentifier = req ^. #artistIdentifier, - opinion = - Opinion - { identifier = newUUID, - createdBy = createdBy, - isLike = req ^. #isLike, - isDislike = not $ req ^. #isLike, - createdAt = now, - lastEditedAt = Nothing - } - } - -newArtistFromRequest' :: (MonadIO m) => UUID -> InsertArtistsRequestItem -> m Artist -newArtistFromRequest' createdBy req = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - Artist - { identifier = newUUID, - displayName = req ^. #displayName, - createdBy = createdBy, - visibilityStatus = 0, - approvedBy = Nothing, - createdAt = now, - lastEditedAt = Nothing, - artworks = fromList [], - comments = [], - opinions = fromList [], - spotifyUrl = req ^. #spotifyUrl, - youtubeUrl = req ^. #youtubeUrl, - soundcloudUrl = req ^. #soundcloudUrl, - wikipediaUrl = req ^. #wikipediaUrl, - viewCount = 0, - description = req ^. #description - } - -newArtistCommentFromRequest' :: (MonadIO m) => UUID -> InsertArtistCommentsRequestItem -> m ArtistComment -newArtistCommentFromRequest' createdBy x = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - ArtistComment - { artistIdentifier = x ^. #artistIdentifier, - comment = - Comment - { identifier = newUUID, - parentIdentifier = x ^. #parentIdentifier, - createdBy = createdBy, - visibilityStatus = 0, - contents = x ^. #contents, - approvedBy = Nothing, - createdAt = now, - lastEditedAt = Nothing - } - } - -instance Exec ArtistCommand where - execAlgebra (IncrementViewsByOne env identifiers next) = next =<< incrementViewsByOne' env identifiers "artists" - execAlgebra (InsertArtists env artists next) = next =<< insertArtists' env artists - execAlgebra (InsertArtistComments env comments next) = next =<< insertArtistComments' env comments - execAlgebra (InsertArtistExternalSources env externalSources next) = next =<< insertArtistExternalSources' env externalSources - execAlgebra (InsertArtistArtworks env artworks next) = next =<< insertArtistArtworks' env artworks - execAlgebra (UpsertArtistOpinions env opinions next) = next =<< upsertArtistOpinions' env opinions - execAlgebra (DeleteArtists env identifiers next) = next =<< deleteArtists' env identifiers - execAlgebra (DeleteArtistComments env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_comments" "identifier" identifiers - execAlgebra (DeleteArtistArtworks env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_artworks" "identifier" identifiers - execAlgebra (DeleteArtistOpinions env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_opinions" "identifier" identifiers - execAlgebra (DeleteCommentsOfArtists env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_comments" "artist_identifier" identifiers - execAlgebra (DeleteArtistExternalSources env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_external_sources" "artist_identifier" identifiers - execAlgebra (DeleteArtworksOfArtists env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_artworks" "artist_identifier" identifiers - execAlgebra (DeleteOpinionsOfArtists env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "artist_opinions" "artist_identifier" identifiers - execAlgebra (UpdateArtistArtworkOrder env orderUpdates next) = next =<< updateArtistArtworkOrder' env orderUpdates - execAlgebra (UpdateArtists env deltas next) = next =<< updateArtists' env deltas - execAlgebra (UpdateArtistExternalSources env deltas next) = next =<< updateArtistExternalSources' env deltas - execAlgebra (NewArtistFromRequest createdBy req next) = next =<< newArtistFromRequest' createdBy req - execAlgebra (NewArtistCommentFromRequest createdBy req next) = next =<< newArtistCommentFromRequest' createdBy req - execAlgebra (NewArtistOpinionFromRequest createdBy req next) = next =<< newArtistOpinionFromRequest' createdBy req - execAlgebra (NewArtistArtworkFromRequest createdBy req next) = next =<< newArtistArtworkFromRequest' createdBy req - -fromHasqlUsageError :: Hasql.Pool.UsageError -> ArtistCommandError -fromHasqlUsageError = PersistenceError . pack . Relude.show diff --git a/src/WikiMusic/PostgreSQL/ArtistQuery.hs b/src/WikiMusic/PostgreSQL/ArtistQuery.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/ArtistQuery.hs +++ /dev/null @@ -1,280 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module WikiMusic.PostgreSQL.ArtistQuery () where - -import Control.Concurrent.Async -import Data.Map (elems, keys) -import Data.Map qualified as Map -import Data.Text (pack) -import Hasql.Decoders as D -import Hasql.Encoders as E -import Hasql.Session qualified as Session -import Hasql.Statement (Statement (..)) -import WikiMusic.Free.ArtistQuery -import WikiMusic.Model.Artist -import WikiMusic.Model.Artwork -import WikiMusic.Model.Comment -import WikiMusic.Model.Opinion -import WikiMusic.Model.Other -import WikiMusic.Model.Thread as CommentThread -import WikiMusic.PostgreSQL.Model.Artist -import WikiMusic.PostgreSQL.ReadAbstraction qualified as ReadAbstraction -import WikiMusic.Protolude - -instance Exec ArtistQuery where - execAlgebra (FetchArtists env sortOrder limit offset next) = - next =<< fetchArtists' env sortOrder limit offset - execAlgebra (FetchArtistsByUUID env sortOrder identifiers next) = - next =<< fetchArtistsByUUID' env sortOrder identifiers - execAlgebra (EnrichedArtistResponse env artistMap enrichArtistParams next) = - next =<< enrichedArtistResponse' env artistMap enrichArtistParams - execAlgebra (FetchArtistComments env identifiers next) = - next =<< fetchArtistComments' env identifiers - execAlgebra (FetchArtistOpinions env identifiers next) = - next =<< fetchArtistOpinions' env identifiers - execAlgebra (SearchArtists env searchInput sortOrder limit offset next) = - next =<< searchArtists' env searchInput sortOrder limit offset - execAlgebra (FetchArtistArtworks env identifiers next) = - next =<< fetchArtistArtworks' env identifiers - --- | PostgreSQL artist row Hasql decoder for reading from `artists` table -artistRowDecoder :: Result [ArtistRow] -artistRowDecoder = - D.rowList $ - (,,,,,,,,,,,,) - <$> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nullable D.uuid) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nullable D.timestamptz) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nullable D.text) - --- | Parse a PostgreSQL Hasql row to a domain representation of artist -parseArtistRows :: [ArtistRow] -> [(UUID, Artist)] -parseArtistRows = map parser - where - parser row = let artist = artistFromRow row in (artist ^. #identifier, artist) - --- | Fetch artists from storage, according to a sort order, limit and offset -fetchArtists' :: (MonadIO m) => Env -> ArtistSortOrder -> Limit -> Offset -> m (Map UUID Artist, [UUID]) -fetchArtists' env sortOrder (Limit limit) (Offset offset) = - ReadAbstraction.persistenceReadCall - (env ^. #pool) - (Session.statement (fromIntegral limit, fromIntegral offset) stmt) - (\xs -> (fromList xs, map fst xs)) - parseArtistRows - where - stmt = Statement query encoder artistRowDecoder True - sortOrder' = fromString . WikiMusic.Model.Artist.show $ sortOrder - query = - encodeUtf8 - [untrimming| - SELECT artists.identifier, artists.display_name, artists.created_by, - artists.visibility_status, artists.approved_by, artists.created_at, artists.last_edited_at, - spotify_url, youtube_url, soundcloud_url, wikipedia_url, artists.views, artists.description - FROM artists - LEFT JOIN artist_external_sources ON artist_external_sources.artist_identifier = artists.identifier - ORDER BY $sortOrder' - LIMIT ($$1) OFFSET $$2 - |] - encoder = - contrazip2 - (E.param . E.nonNullable $ E.int8) - (E.param . E.nonNullable $ E.int8) - --- | Fetch artists by UUID from storage, according to a sort order -fetchArtistsByUUID' :: (MonadIO m) => Env -> ArtistSortOrder -> [UUID] -> m (Map UUID Artist, [UUID]) -fetchArtistsByUUID' env sortOrder identifiers = - ReadAbstraction.persistenceReadCall - (env ^. #pool) - (Session.statement identifiers stmt) - (\xs -> (fromList xs, map fst xs)) - parseArtistRows - where - stmt = Statement query encoder artistRowDecoder True - sortOrder' = fromString . WikiMusic.Model.Artist.show $ sortOrder - query = - encodeUtf8 - [untrimming| - SELECT artists.identifier, artists.display_name, artists.created_by, - artists.visibility_status, artists.approved_by, artists.created_at, artists.last_edited_at, - spotify_url, youtube_url, soundcloud_url, wikipedia_url, artists.views, artists.description - FROM artists - LEFT JOIN artist_external_sources ON artist_external_sources.artist_identifier = artists.identifier - WHERE artists.identifier = ANY($$1) ORDER BY $sortOrder' - |] - encoder = E.param . E.nonNullable $ E.foldableArray . E.nonNullable $ E.uuid - --- | Fetch artist artworks from storage -fetchArtistArtworks' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID ArtistArtwork) -fetchArtistArtworks' env identifiers = - ReadAbstraction.fetchArtworks - (env ^. #pool) - (parseArtworkRows fromRow) - "artist_artworks" - "artist_identifier" - (vectorFromList identifiers) - where - fromRow - ( identifier, - artistIdentifier, - createdBy, - visibilityStatus, - approvedBy, - contentUrl, - contentCaption, - createdAt, - lastEditedAt, - orderValue - ) = - let artwork = - Artwork - { identifier = identifier, - createdBy = createdBy, - visibilityStatus = fromIntegral visibilityStatus, - approvedBy = approvedBy, - contentUrl = contentUrl, - contentCaption = contentCaption, - createdAt = createdAt, - lastEditedAt = lastEditedAt, - orderValue = fromIntegral orderValue - } - in ArtistArtwork {..} - --- | Enrich artists with related information, according to enrichment parameters -enrichedArtistResponse' :: (MonadIO m) => Env -> Map UUID Artist -> EnrichArtistParams -> m (Map UUID Artist) -enrichedArtistResponse' env artistMap enrichArtistParams = do - (artworkMap, (opinionMap, commentMap)) <- liftIO $ concurrently getArtwork (concurrently getOpinion getComment) - let enrichedArtists = - mapMap - ( \artist -> do - let rawCommentMap = Map.filter (matchesArtistIdentifier artist) commentMap - allComments = elems rawCommentMap - commentThreads = map renderThread $ mkThreads allComments isChildOf' (^. #comment % #parentIdentifier) - - artist - { comments = commentThreads, - artworks = filterMap (matchesArtistIdentifier artist) artworkMap, - opinions = filterMap (matchesArtistIdentifier artist) opinionMap - } - ) - artistMap - - pure enrichedArtists - where - matchesArtistIdentifier artist = (== artist ^. #identifier) . (^. #artistIdentifier) - isChildOf' p x = Just (p ^. #comment % #identifier) == x ^. #comment % #parentIdentifier - artistIds = keys artistMap - getComment = - if enrichArtistParams ^. #includeComments - then exec @ArtistQuery $ fetchArtistComments env artistIds - else pure $ fromList [] - getArtwork = - if enrichArtistParams ^. #includeArtworks - then exec @ArtistQuery $ fetchArtistArtworks env artistIds - else pure $ fromList [] - getOpinion = - if enrichArtistParams ^. #includeOpinions - then exec @ArtistQuery $ fetchArtistOpinions env artistIds - else pure $ fromList [] - --- | Fetch artist comments from storage -fetchArtistComments' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID ArtistComment) -fetchArtistComments' env identifiers = - ReadAbstraction.fetchComments - (env ^. #pool) - (parseCommentRows fromRow) - "artist_comments" - "artist_identifier" - (vectorFromList identifiers) - where - fromRow - ( identifier, - artistIdentifier, - parentIdentifier, - createdBy, - visibilityStatus, - contents, - approvedBy, - createdAt, - lastEditedAt - ) = - let comment = - Comment - { identifier = identifier, - parentIdentifier = parentIdentifier, - createdBy = createdBy, - visibilityStatus = fromIntegral visibilityStatus, - contents = contents, - approvedBy = approvedBy, - createdAt = createdAt, - lastEditedAt = lastEditedAt - } - in ArtistComment {..} - --- | Search artists by keywords from storage, according to a sort order, limit and offset -searchArtists' :: (MonadIO m) => Env -> SearchInput -> ArtistSortOrder -> Limit -> Offset -> m (Map UUID Artist, [UUID]) -searchArtists' env searchInput sortOrder (Limit limit) (Offset offset) = - ReadAbstraction.persistenceReadCall - (env ^. #pool) - (Session.statement (fromIntegral limit, fromIntegral offset) stmt) - (\xs -> (fromList xs, map fst xs)) - parseArtistRows - where - sortOrder' = pack . WikiMusic.Model.Artist.show $ sortOrder - searchConstraints = ReadAbstraction.mkSearchConstraints (searchInput ^. #value) - query = - encodeUtf8 - [untrimming| - SELECT artists.identifier, artists.display_name, artists.created_by, - artists.visibility_status, artists.approved_by, artists.created_at, artists.last_edited_at, - spotify_url, youtube_url, soundcloud_url, wikipedia_url, artists.views, artists.description - FROM artists - LEFT JOIN artist_external_sources ON artist_external_sources.artist_identifier = artists.identifier - WHERE $searchConstraints - ORDER BY $sortOrder' - LIMIT ($$1) OFFSET $$2 - |] - - encoder = - contrazip2 - (E.param . E.nonNullable $ E.int8) - (E.param . E.nonNullable $ E.int8) - stmt = Statement query encoder artistRowDecoder True - --- | Fetch artist opinions from storage -fetchArtistOpinions' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID ArtistOpinion) -fetchArtistOpinions' env identifiers = - ReadAbstraction.fetchOpinions - (env ^. #pool) - (parseOpinionRows fromRow) - "artist_opinions" - "artist_identifier" - (vectorFromList identifiers) - where - fromRow - ( identifier, - artistIdentifier, - createdBy, - isLike, - isDislike, - createdAt, - lastEditedAt - ) = - let opinion = Opinion {..} - in ArtistOpinion {..} diff --git a/src/WikiMusic/PostgreSQL/AuthQuery.hs b/src/WikiMusic/PostgreSQL/AuthQuery.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/AuthQuery.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module WikiMusic.PostgreSQL.AuthQuery () where - -import Data.Text (pack, unpack) -import Hasql.Decoders as D -import Hasql.Encoders as E -import Hasql.Pool qualified -import Hasql.Session qualified as Session -import Hasql.Statement (Statement (..)) -import Relude -import WikiMusic.Free.AuthQuery -import WikiMusic.Protolude - -instance Exec AuthQuery where - execAlgebra (FetchUserForAuthCheck env email next) = do - next =<< fetchUserForAuthCheck' env email - execAlgebra (FetchUserFromToken env t next) = do - next =<< fetchUserFromToken' env t - execAlgebra (FetchMe env identifier next) = do - next =<< fetchMe' env identifier - execAlgebra (FetchUserRoles env identifier next) = do - next =<< fetchUserRoles' env identifier - -fetchMe' :: (MonadIO m) => Env -> UUID -> m (Either AuthQueryError (Maybe WikiMusicUser)) -fetchMe' env identifier = do - stmtResult <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement identifier stmt) - let u = first fromHasqlUsageError . fmap maybeFromRow $ stmtResult - case u of - Left e -> pure . Left $ e - Right Nothing -> pure . Left $ AuthError "User did not exist" - Right (Just usr) -> do - u' <- withRoles env usr - pure . Right . Just $ u' - where - stmt = Statement query encoder decoder True - query = - encodeUtf8 - [trimming| - SELECT identifier, display_name, email_address, password_hash, auth_token FROM users - WHERE identifier = $$1 LIMIT 1 - |] - encoder = E.param . E.nonNullable $ E.uuid - decoder = - D.rowMaybe $ - (,,,,) - <$> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - -fetchAuthUserDecoder :: Result (Maybe (UUID, Text, Text, Maybe Text, Maybe Text)) -fetchAuthUserDecoder = - D.rowMaybe $ - (,,,,) - <$> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - -fetchUserForAuthCheck' :: (MonadIO m) => Env -> Text -> m (Either AuthQueryError (Maybe WikiMusicUser)) -fetchUserForAuthCheck' env email = do - stmtResult <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement email stmt) - let maybeUsr = first fromHasqlUsageError . fmap maybeFromRow $ stmtResult - case maybeUsr of - Left e -> pure . Left $ e - Right Nothing -> pure . Left $ AuthError "User did not exist" - Right (Just usr) -> do - u <- withRoles env usr - pure . Right . Just $ u - where - stmt = Statement query encoder fetchAuthUserDecoder True - query = - encodeUtf8 - [trimming| - SELECT identifier, display_name, email_address, password_hash, auth_token - FROM users - WHERE email_address = $$1 - LIMIT 1 - |] - encoder = E.param . E.nonNullable $ E.text - -fetchUserFromToken' :: (MonadIO m) => Env -> Text -> m (Either AuthQueryError (Maybe WikiMusicUser)) -fetchUserFromToken' env t = do - stmtResult <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement t stmt) - let maybeUsr = first fromHasqlUsageError . fmap maybeFromRow $ stmtResult - case maybeUsr of - Left e -> pure . Left $ e - Right Nothing -> pure . Left $ AuthError "User did not exist" - Right (Just usr) -> do - u <- withRoles env usr - pure . Right . Just $ u - where - stmt = Statement query encoder fetchAuthUserDecoder True - query = - encodeUtf8 - [trimming| - SELECT identifier, display_name, email_address, password_hash, auth_token - FROM users - WHERE auth_token = $$1 - LIMIT 1 - |] - encoder = E.param . E.nonNullable $ E.text - -fetchUserRoles' :: (MonadIO m) => Env -> UUID -> m (Either AuthQueryError [UserRole]) -fetchUserRoles' env identifier = do - rolesStmtResult <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement identifier stmt) - let roles' = either (const []) (map userRole) rolesStmtResult - pure . Right $ roles' - where - stmt = Statement query encoder decoder True - query = - encodeUtf8 - [trimming| - SELECT role_id FROM user_roles WHERE user_identifier = $$1 - |] - encoder = E.param . E.nonNullable $ E.uuid - decoder = D.rowList . D.column . D.nonNullable $ D.text - -userRole :: Text -> UserRole -userRole = read . unpack - -maybeFromRow :: Maybe (UUID, Text, Text, Maybe Text, Maybe Text) -> Maybe WikiMusicUser -maybeFromRow = - fmap - ( \(identifierr, displayName, emailAddress, passwordHash, authToken) -> - WikiMusicUser - { identifier = identifierr, - displayName = displayName, - emailAddress = emailAddress, - passwordHash = passwordHash, - roles = [], - authToken = authToken - } - ) - -fromHasqlUsageError :: Hasql.Pool.UsageError -> AuthQueryError -fromHasqlUsageError = PersistenceError . pack . show - -withRoles :: (MonadIO m) => Env -> WikiMusicUser -> m WikiMusicUser -withRoles env usr = do - roles' <- fetchUserRoles' env (usr ^. #identifier) - pure $ usr {roles = fromRight [] roles'} diff --git a/src/WikiMusic/PostgreSQL/GenreCommand.hs b/src/WikiMusic/PostgreSQL/GenreCommand.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/GenreCommand.hs +++ /dev/null @@ -1,449 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module WikiMusic.PostgreSQL.GenreCommand () where - -import Data.Text (pack) -import Hasql.Decoders as D -import Hasql.Encoders as E -import Hasql.Pool qualified -import Hasql.Statement (Statement (..)) -import Relude -import WikiMusic.Free.GenreCommand -import WikiMusic.Interaction.Model.Genre -import WikiMusic.Model.Artwork -import WikiMusic.Model.Comment -import WikiMusic.Model.Genre -import WikiMusic.Model.Opinion -import WikiMusic.PostgreSQL.ReadAbstraction -import WikiMusic.PostgreSQL.WriteAbstraction -import WikiMusic.Protolude - -insertGenres' :: (MonadIO m) => Env -> [Genre] -> m (Map UUID Genre) -insertGenres' env genres = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) genres - now <- liftIO getCurrentTime - mapM_ - ( \x -> do - newUUID <- liftIO nextRandom - liftIO $ exec @GenreCommand $ insertGenreExternalSources env [toExternalSource x now newUUID] - ) - genres - pure . fromList . map (\x -> (x ^. #identifier, x)) $ genres - where - toExternalSource x now newUUID = - GenreExternalSources - { identifier = newUUID, - genreIdentifier = x ^. #identifier, - spotifyUrl = x ^. #spotifyUrl, - youtubeUrl = x ^. #youtubeUrl, - soundcloudUrl = x ^. #soundcloudUrl, - wikipediaUrl = x ^. #wikipediaUrl, - createdAt = now, - createdBy = x ^. #createdBy, - lastEditedAt = Nothing - } - toRow x = - ( x ^. #identifier, - x ^. #displayName, - x ^. #createdBy, - fromIntegral $ x ^. #visibilityStatus, - x ^. #approvedBy, - x ^. #createdAt, - x ^. #lastEditedAt, - x ^. #description - ) - encoder = - contrazip8 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nullable E.uuid)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - (E.param (E.nullable E.text)) - stmt = Statement query encoder D.noResult True - bindParams' = bindParams 8 - query = - encodeUtf8 - [trimming| - INSERT INTO genres - (identifier, display_name, created_by, visibility_status, - approved_by, created_at, last_edited_at, description) - VALUES ($bindParams') - |] - -insertGenreComments' :: (MonadIO m) => Env -> [GenreComment] -> m (Map UUID GenreComment) -insertGenreComments' env comments = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) comments - pure . fromList . map (\x -> (x ^. #comment % #identifier, x)) $ comments - where - toRow x = - ( x ^. #comment % #identifier, - x ^. #genreIdentifier, - x ^. #comment % #parentIdentifier, - x ^. #comment % #createdBy, - fromIntegral $ x ^. #comment % #visibilityStatus, - x ^. #comment % #contents, - x ^. #comment % #approvedBy, - x ^. #comment % #createdAt, - x ^. #comment % #lastEditedAt - ) - encoder = - contrazip9 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.text)) - (E.param (E.nullable E.uuid)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - stmt = Statement query encoder D.noResult True - bindParams' = bindParams 9 - query = - encodeUtf8 - [trimming| - INSERT INTO genre_comments - (identifier, genre_identifier, parent_identifier, created_by, - visibility_status, contents, approved_by, created_at, last_edited_at) - VALUES ( $bindParams' ) - |] - -insertGenreExternalSources' :: (MonadIO m) => Env -> [GenreExternalSources] -> m (Map UUID GenreExternalSources) -insertGenreExternalSources' env externalSources = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) externalSources - pure . fromList . map (\x -> (x ^. #identifier, x)) $ externalSources - where - stmt = Statement query encoder D.noResult True - encoder = - contrazip9 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - (E.param (E.nonNullable E.uuid)) - bindParams' = bindParams 9 - query = - encodeUtf8 - [trimming| - INSERT INTO genre_external_sources - (identifier, genre_identifier, spotify_url, youtube_url, - soundcloud_url, wikipedia_url, created_at, last_edited_at, created_by) - VALUES ( $bindParams' ) - |] - toRow x = - ( x ^. #identifier, - x ^. #genreIdentifier, - x ^. #spotifyUrl, - x ^. #youtubeUrl, - x ^. #soundcloudUrl, - x ^. #wikipediaUrl, - x ^. #createdAt, - x ^. #lastEditedAt, - x ^. #createdBy - ) - -insertGenreArtworks' :: (MonadIO m) => Env -> [GenreArtwork] -> m (Map UUID GenreArtwork) -insertGenreArtworks' env artworks = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) artworks - pure . fromList . map (\x -> (x ^. #artwork % #identifier, x)) $ artworks - where - toRow x = - ( x ^. #artwork % #identifier, - x ^. #genreIdentifier, - x ^. #artwork % #createdBy, - fromIntegral $ x ^. #artwork % #visibilityStatus, - x ^. #artwork % #approvedBy, - x ^. #artwork % #contentUrl, - x ^. #artwork % #createdAt, - x ^. #artwork % #lastEditedAt, - x ^. #artwork % #contentCaption, - fromIntegral $ x ^. #artwork % #orderValue - ) - stmt = Statement query encoder D.noResult True - encoder = - contrazip10 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - (E.param (E.nullable E.text)) - (E.param (E.nonNullable E.int8)) - query = - encodeUtf8 - [trimming| - INSERT INTO genre_artworks - (identifier, genre_identifier, created_by, visibility_status, - approved_by, content_url, created_at, last_edited_at, content_caption, order_value) - VALUES ($$1, $$2, $$3, $$4, $$5, $$6, $$7, $$8, $$9, $$10) - |] - -upsertGenreOpinions' :: (MonadIO m) => Env -> [GenreOpinion] -> m (Map UUID GenreOpinion) -upsertGenreOpinions' env opinions = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) opinions - pure . fromList . map (\x -> (x ^. #opinion % #identifier, x)) $ opinions - where - bindParams' = bindParams 7 - query = - encodeUtf8 - [trimming| - INSERT INTO genre_opinions - (identifier, genre_identifier, created_by, is_like, is_dislike, - created_at, last_edited_at) - VALUES ( $bindParams' ) - ON CONFLICT (genre_identifier, created_by) DO - UPDATE SET is_like = $$4, is_dislike = $$5, - last_edited_at = $$6 - |] - stmt = Statement query encoder D.noResult True - encoder = - contrazip7 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.bool)) - (E.param (E.nonNullable E.bool)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - toRow x = do - ( x ^. #opinion % #identifier, - x ^. #genreIdentifier, - x ^. #opinion % #createdBy, - x ^. #opinion % #isLike, - not $ x ^. #opinion % #isLike, - x ^. #opinion % #createdAt, - x ^. #opinion % #lastEditedAt - ) - -deleteGenres' :: (MonadIO m) => Env -> [UUID] -> m (Either GenreCommandError ()) -deleteGenres' env identifiers = do - deleteArtworksOfGenresResult <- liftIO . exec @GenreCommand $ deleteArtworksOfGenres env identifiers - deleteOpinionsOfGenresResult <- liftIO . exec @GenreCommand $ deleteOpinionsOfGenres env identifiers - deleteCommentsOfGenresResult <- liftIO . exec @GenreCommand $ deleteCommentsOfGenres env identifiers - deleteGenreExternalSourcesResult <- liftIO . exec @GenreCommand $ deleteGenreExternalSources env identifiers - deleteGenresResult <- deleteStuffByUUID (env ^. #pool) "genres" "identifier" identifiers - pure $ - deleteArtworksOfGenresResult - <> deleteOpinionsOfGenresResult - <> deleteGenreExternalSourcesResult - <> deleteCommentsOfGenresResult - <> first fromHasqlUsageError deleteGenresResult - -updateGenreArtworkOrder' :: (MonadIO m) => Env -> [GenreArtworkOrderUpdate] -> m (Either a ()) -updateGenreArtworkOrder' env orderUpdates = - Right <$> mapM_ performUpdate orderUpdates - where - stmt = Statement query encoder D.noResult True - query = - encodeUtf8 - [trimming| - UPDATE genre_artworks SET order_value = $$2 WHERE identifier = $$1 - |] - encoder = - contrazip2 (E.param . E.nonNullable $ E.uuid) (E.param . E.nonNullable $ E.int8) - toRow x = (x ^. #identifier, fromIntegral $ x ^. #orderValue) - performUpdate x = do - operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow x) - pure $ first (pack . Relude.show) operationResults - -updateGenres' :: (MonadIO m) => Env -> Map UUID (Genre, Maybe GenreDelta) -> m (Either Text ()) -updateGenres' env deltas = do - liftIO $ mapM_ performUpdate deltas - exUpdate <- liftIO $ exec @GenreCommand $ updateGenreExternalSources env deltas - pure $ exUpdate <> Right () - where - stmt = Statement query encoder D.noResult True - query = - encodeUtf8 - [trimming| - UPDATE genres SET display_name = $$2, last_edited_at = $$3, description = $$4 WHERE identifier = $$1 - |] - encoder = - contrazip4 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nullable E.timestamptz)) - (E.param (E.nullable E.text)) - toRow x xDelta now = - ( x ^. #identifier, - fromMaybe (x ^. #displayName) (xDelta ^. #displayName), - Just now, - xDelta ^. #description - ) - performUpdate (_, Nothing) = pure $ Right () - performUpdate (x, Just xDelta) = do - now <- getCurrentTime - operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow x xDelta now) - pure $ first (pack . Relude.show) operationResults - -updateGenreExternalSources' :: (MonadIO m) => Env -> Map UUID (Genre, Maybe GenreDelta) -> m (Either Text ()) -updateGenreExternalSources' env deltas = - Right <$> mapM_ performUpdate deltas - where - stmt = Statement query encoder D.noResult True - query = - encodeUtf8 - [trimming| - UPDATE genre_external_sources SET - spotify_url = $$2, - youtube_url = $$3, - wikipedia_url = $$4, - soundcloud_url = $$5 - WHERE genre_identifier = $$1 - |] - - encoder = - contrazip5 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - toRow x xDelta = - ( x ^. #identifier, - xDelta ^. #spotifyUrl, - xDelta ^. #youtubeUrl, - xDelta ^. #wikipediaUrl, - xDelta ^. #soundcloudUrl - ) - performUpdate (_, Nothing) = pure $ Right () - performUpdate (x, Just xDelta) = do - operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow x xDelta) - pure $ first (pack . Relude.show) operationResults - -newGenreArtworkFromRequest' :: (MonadIO m) => UUID -> InsertGenreArtworksRequestItem -> m GenreArtwork -newGenreArtworkFromRequest' createdBy req = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - GenreArtwork - { genreIdentifier = req ^. #genreIdentifier, - artwork = - Artwork - { identifier = newUUID, - createdBy = createdBy, - contentUrl = req ^. #contentUrl, - contentCaption = req ^. #contentCaption, - createdAt = now, - lastEditedAt = Nothing, - visibilityStatus = 0, - approvedBy = Nothing, - orderValue = req ^. #orderValue - } - } - -newGenreOpinionFromRequest' :: (MonadIO m) => UUID -> UpsertGenreOpinionsRequestItem -> m GenreOpinion -newGenreOpinionFromRequest' createdBy req = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - GenreOpinion - { genreIdentifier = req ^. #genreIdentifier, - opinion = - Opinion - { identifier = newUUID, - createdBy = createdBy, - isLike = req ^. #isLike, - isDislike = not $ req ^. #isLike, - createdAt = now, - lastEditedAt = Nothing - } - } - -newGenreFromRequest' :: (MonadIO m) => UUID -> InsertGenresRequestItem -> m Genre -newGenreFromRequest' createdBy req = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - Genre - { identifier = newUUID, - parentIdentifier = Nothing, - displayName = req ^. #displayName, - createdBy = createdBy, - visibilityStatus = 0, - approvedBy = Nothing, - createdAt = now, - lastEditedAt = Nothing, - artworks = fromList [], - comments = [], - opinions = fromList [], - spotifyUrl = req ^. #spotifyUrl, - youtubeUrl = req ^. #youtubeUrl, - soundcloudUrl = req ^. #soundcloudUrl, - wikipediaUrl = req ^. #wikipediaUrl, - viewCount = 0, - description = req ^. #description - } - -newGenreCommentFromRequest' :: (MonadIO m) => UUID -> InsertGenreCommentsRequestItem -> m GenreComment -newGenreCommentFromRequest' createdBy x = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - GenreComment - { genreIdentifier = x ^. #genreIdentifier, - comment = - Comment - { identifier = newUUID, - parentIdentifier = x ^. #parentIdentifier, - createdBy = createdBy, - visibilityStatus = 0, - contents = x ^. #contents, - approvedBy = Nothing, - createdAt = now, - lastEditedAt = Nothing - } - } - -instance Exec GenreCommand where - execAlgebra (IncrementViewsByOne env identifiers next) = next =<< incrementViewsByOne' env identifiers "genres" - execAlgebra (InsertGenres env genres next) = next =<< insertGenres' env genres - execAlgebra (InsertGenreComments env comments next) = next =<< insertGenreComments' env comments - execAlgebra (InsertGenreExternalSources env externalSources next) = next =<< insertGenreExternalSources' env externalSources - execAlgebra (InsertGenreArtworks env artworks next) = next =<< insertGenreArtworks' env artworks - execAlgebra (UpsertGenreOpinions env opinions next) = next =<< upsertGenreOpinions' env opinions - execAlgebra (DeleteGenres env identifiers next) = next =<< deleteGenres' env identifiers - execAlgebra (DeleteGenreComments env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_comments" "identifier" identifiers - execAlgebra (DeleteGenreArtworks env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_artworks" "identifier" identifiers - execAlgebra (DeleteGenreOpinions env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_opinions" "identifier" identifiers - execAlgebra (DeleteCommentsOfGenres env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_comments" "genre_identifier" identifiers - execAlgebra (DeleteGenreExternalSources env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_external_sources" "genre_identifier" identifiers - execAlgebra (DeleteArtworksOfGenres env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_artworks" "genre_identifier" identifiers - execAlgebra (DeleteOpinionsOfGenres env identifiers next) = do - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "genre_opinions" "genre_identifier" identifiers - execAlgebra (UpdateGenreArtworkOrder env orderUpdates next) = next =<< updateGenreArtworkOrder' env orderUpdates - execAlgebra (UpdateGenres env deltas next) = next =<< updateGenres' env deltas - execAlgebra (UpdateGenreExternalSources env deltas next) = next =<< updateGenreExternalSources' env deltas - execAlgebra (NewGenreFromRequest createdBy req next) = next =<< newGenreFromRequest' createdBy req - execAlgebra (NewGenreCommentFromRequest createdBy req next) = next =<< newGenreCommentFromRequest' createdBy req - execAlgebra (NewGenreOpinionFromRequest createdBy req next) = next =<< newGenreOpinionFromRequest' createdBy req - execAlgebra (NewGenreArtworkFromRequest createdBy req next) = next =<< newGenreArtworkFromRequest' createdBy req - -fromHasqlUsageError :: Hasql.Pool.UsageError -> GenreCommandError -fromHasqlUsageError = PersistenceError . pack . Relude.show diff --git a/src/WikiMusic/PostgreSQL/GenreQuery.hs b/src/WikiMusic/PostgreSQL/GenreQuery.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/GenreQuery.hs +++ /dev/null @@ -1,281 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module WikiMusic.PostgreSQL.GenreQuery () where - -import Control.Concurrent.Async -import Data.Map (elems, keys) -import Data.Map qualified as Map -import Data.Text (pack) -import Hasql.Decoders as D -import Hasql.Encoders as E -import Hasql.Session qualified as Session -import Hasql.Statement (Statement (..)) -import WikiMusic.Free.GenreQuery -import WikiMusic.Model.Artwork -import WikiMusic.Model.Comment -import WikiMusic.Model.Genre -import WikiMusic.Model.Opinion -import WikiMusic.Model.Other -import WikiMusic.Model.Thread as CommentThread -import WikiMusic.PostgreSQL.Model.Genre -import WikiMusic.PostgreSQL.ReadAbstraction qualified as ReadAbstraction -import WikiMusic.Protolude - -instance Exec GenreQuery where - execAlgebra (FetchGenres env sortOrder limit offset next) = - next =<< fetchGenres' env sortOrder limit offset - execAlgebra (FetchGenresByUUID env sortOrder identifiers next) = - next =<< fetchGenresByUUID' env sortOrder identifiers - execAlgebra (EnrichedGenreResponse env genreMap enrichGenreParams next) = - next =<< enrichedGenreResponse' env genreMap enrichGenreParams - execAlgebra (FetchGenreComments env identifiers next) = - next =<< fetchGenreComments' env identifiers - execAlgebra (FetchGenreOpinions env identifiers next) = - next =<< fetchGenreOpinions' env identifiers - execAlgebra (SearchGenres env searchInput sortOrder limit offset next) = - next =<< searchGenres' env searchInput sortOrder limit offset - execAlgebra (FetchGenreArtworks env identifiers next) = - next =<< fetchGenreArtworks' env identifiers - --- | PostgreSQL genre row Hasql decoder for reading from `genres` table -genreRowDecoder :: Result [GenreRow] -genreRowDecoder = - D.rowList $ - (,,,,,,,,,,,,,) - <$> D.column (D.nonNullable D.uuid) - <*> D.column (D.nullable D.uuid) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nullable D.uuid) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nullable D.timestamptz) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nullable D.text) - --- | Parse a PostgreSQL Hasql row to a domain representation of genre -parseGenreRows :: [GenreRow] -> [(UUID, Genre)] -parseGenreRows = map parser - where - parser row = let genre = genreFromRow row in (genre ^. #identifier, genre) - --- | Fetch genres from storage, according to a sort order, limit and offset -fetchGenres' :: (MonadIO m) => Env -> GenreSortOrder -> Limit -> Offset -> m (Map UUID Genre, [UUID]) -fetchGenres' env sortOrder (Limit limit) (Offset offset) = - ReadAbstraction.persistenceReadCall - (env ^. #pool) - (Session.statement (fromIntegral limit, fromIntegral offset) stmt) - (\xs -> (fromList xs, map fst xs)) - parseGenreRows - where - stmt = Statement query encoder genreRowDecoder True - sortOrder' = fromString . WikiMusic.Model.Genre.show $ sortOrder - query = - encodeUtf8 - [untrimming| - SELECT genres.identifier, genres.parent_identifier, genres.display_name, genres.created_by, - genres.visibility_status, genres.approved_by, genres.created_at, genres.last_edited_at, - spotify_url, youtube_url, soundcloud_url, wikipedia_url, genres.views, genres.description - FROM genres - LEFT JOIN genre_external_sources ON genre_external_sources.genre_identifier = genres.identifier - ORDER BY $sortOrder' - LIMIT ($$1) OFFSET $$2 - |] - encoder = - contrazip2 - (E.param . E.nonNullable $ E.int8) - (E.param . E.nonNullable $ E.int8) - --- | Fetch genres by UUID from storage, according to a sort order -fetchGenresByUUID' :: (MonadIO m) => Env -> GenreSortOrder -> [UUID] -> m (Map UUID Genre, [UUID]) -fetchGenresByUUID' env sortOrder identifiers = - ReadAbstraction.persistenceReadCall - (env ^. #pool) - (Session.statement identifiers stmt) - (\xs -> (fromList xs, map fst xs)) - parseGenreRows - where - stmt = Statement query encoder genreRowDecoder True - sortOrder' = fromString . WikiMusic.Model.Genre.show $ sortOrder - query = - encodeUtf8 - [untrimming| - SELECT genres.identifier, genres.parent_identifier, genres.display_name, genres.created_by, - genres.visibility_status, genres.approved_by, genres.created_at, genres.last_edited_at, - spotify_url, youtube_url, soundcloud_url, wikipedia_url, genres.views, genres.description - FROM genres - LEFT JOIN genre_external_sources ON genre_external_sources.genre_identifier = genres.identifier - WHERE genres.identifier = ANY($$1) ORDER BY $sortOrder' - |] - encoder = E.param . E.nonNullable $ E.foldableArray . E.nonNullable $ E.uuid - --- | Fetch genre artworks from storage -fetchGenreArtworks' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID GenreArtwork) -fetchGenreArtworks' env identifiers = - ReadAbstraction.fetchArtworks - (env ^. #pool) - (parseArtworkRows fromRow) - "genre_artworks" - "genre_identifier" - (vectorFromList identifiers) - where - fromRow - ( identifier, - genreIdentifier, - createdBy, - visibilityStatus, - approvedBy, - contentUrl, - contentCaption, - createdAt, - lastEditedAt, - orderValue - ) = - let artwork = - Artwork - { identifier = identifier, - createdBy = createdBy, - visibilityStatus = fromIntegral visibilityStatus, - approvedBy = approvedBy, - contentUrl = contentUrl, - contentCaption = contentCaption, - createdAt = createdAt, - lastEditedAt = lastEditedAt, - orderValue = fromIntegral orderValue - } - in GenreArtwork {..} - --- | Enrich genres with related information, according to enrichment parameters -enrichedGenreResponse' :: (MonadIO m) => Env -> Map UUID Genre -> EnrichGenreParams -> m (Map UUID Genre) -enrichedGenreResponse' env genreMap enrichGenreParams = do - (artworkMap, (opinionMap, commentMap)) <- liftIO $ concurrently getArtwork (concurrently getOpinion getComment) - let enrichedGenres = - mapMap - ( \genre -> do - let rawCommentMap = Map.filter (matchesGenreIdentifier genre) commentMap - allComments = elems rawCommentMap - commentThreads = map renderThread $ mkThreads allComments isChildOf' (^. #comment % #parentIdentifier) - - genre - { comments = commentThreads, - artworks = filterMap (matchesGenreIdentifier genre) artworkMap, - opinions = filterMap (matchesGenreIdentifier genre) opinionMap - } - ) - genreMap - - pure enrichedGenres - where - matchesGenreIdentifier genre = (== genre ^. #identifier) . (^. #genreIdentifier) - isChildOf' p x = Just (p ^. #comment % #identifier) == x ^. #comment % #parentIdentifier - genreIds = keys genreMap - getComment = - if enrichGenreParams ^. #includeComments - then exec @GenreQuery $ fetchGenreComments env genreIds - else pure $ fromList [] - getArtwork = - if enrichGenreParams ^. #includeArtworks - then exec @GenreQuery $ fetchGenreArtworks env genreIds - else pure $ fromList [] - getOpinion = - if enrichGenreParams ^. #includeOpinions - then exec @GenreQuery $ fetchGenreOpinions env genreIds - else pure $ fromList [] - --- | Fetch genre comments from storage -fetchGenreComments' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID GenreComment) -fetchGenreComments' env identifiers = - ReadAbstraction.fetchComments - (env ^. #pool) - (parseCommentRows fromRow) - "genre_comments" - "genre_identifier" - (vectorFromList identifiers) - where - fromRow - ( identifier, - genreIdentifier, - parentIdentifier, - createdBy, - visibilityStatus, - contents, - approvedBy, - createdAt, - lastEditedAt - ) = - let comment = - Comment - { identifier = identifier, - parentIdentifier = parentIdentifier, - createdBy = createdBy, - visibilityStatus = fromIntegral visibilityStatus, - contents = contents, - approvedBy = approvedBy, - createdAt = createdAt, - lastEditedAt = lastEditedAt - } - in GenreComment {..} - --- | Search genres by keywords from storage, according to a sort order, limit and offset -searchGenres' :: (MonadIO m) => Env -> SearchInput -> GenreSortOrder -> Limit -> Offset -> m (Map UUID Genre, [UUID]) -searchGenres' env searchInput sortOrder (Limit limit) (Offset offset) = - ReadAbstraction.persistenceReadCall - (env ^. #pool) - (Session.statement (fromIntegral limit, fromIntegral offset) stmt) - (\xs -> (fromList xs, map fst xs)) - parseGenreRows - where - sortOrder' = pack . WikiMusic.Model.Genre.show $ sortOrder - searchConstraints = ReadAbstraction.mkSearchConstraints (searchInput ^. #value) - query = - encodeUtf8 - [untrimming| - SELECT genres.identifier, genres.parent_identifier, genres.display_name, genres.created_by, - genres.visibility_status, genres.approved_by, genres.created_at, genres.last_edited_at, - spotify_url, youtube_url, soundcloud_url, wikipedia_url, genres.views, genres.description - FROM genres - LEFT JOIN genre_external_sources ON genre_external_sources.genre_identifier = genres.identifier - WHERE $searchConstraints - ORDER BY $sortOrder' - LIMIT ($$1) OFFSET $$2 - |] - - encoder = - contrazip2 - (E.param . E.nonNullable $ E.int8) - (E.param . E.nonNullable $ E.int8) - stmt = Statement query encoder genreRowDecoder True - --- | Fetch genre opinions from storage -fetchGenreOpinions' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID GenreOpinion) -fetchGenreOpinions' env identifiers = - ReadAbstraction.fetchOpinions - (env ^. #pool) - (parseOpinionRows fromRow) - "genre_opinions" - "genre_identifier" - (vectorFromList identifiers) - where - fromRow - ( identifier, - genreIdentifier, - createdBy, - isLike, - isDislike, - createdAt, - lastEditedAt - ) = - let opinion = Opinion {..} - in GenreOpinion {..} diff --git a/src/WikiMusic/PostgreSQL/Migration.hs b/src/WikiMusic/PostgreSQL/Migration.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/Migration.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} - -module WikiMusic.PostgreSQL.Migration - ( runWikiMusicMigrations, - ) -where - -import Hasql.Migration -import Hasql.Pool qualified -import Hasql.Transaction -import Hasql.Transaction.Sessions qualified as TransactionSessions -import WikiMusic.Protolude - -initializeSchema :: Transaction () -initializeSchema = do - sql $ - encodeUtf8 - [trimming| - CREATE TABLE IF NOT EXISTS schema_migrations - (filename varchar(512) NOT NULL, - checksum varchar(32) NOT NULL, - executed_at timestamptz NOT NULL DEFAULT now() - ); - |] - -runMigrationFile :: (MonadIO m) => Hasql.Pool.Pool -> MigrationCommand -> m (Either Hasql.Pool.UsageError (Maybe MigrationError)) -runMigrationFile pool migrationFile = - liftIO $ - Hasql.Pool.use - pool - ( TransactionSessions.transaction - TransactionSessions.Serializable - TransactionSessions.Write - migrationCommand - ) - where - migrationCommand = runMigration migrationFile - -runWikiMusicMigrations :: (MonadIO m) => Hasql.Pool.Pool -> m [Either Hasql.Pool.UsageError (Maybe MigrationError)] -runWikiMusicMigrations pool = do - _ <- - liftIO $ - Hasql.Pool.use - pool - ( TransactionSessions.transaction - TransactionSessions.Serializable - TransactionSessions.Write - initializeSchema - ) - - migrations <- liftIO $ loadMigrationsFromDirectory "resources/postgresql/migrations" - mapM (liftIO . runMigrationFile pool) migrations diff --git a/src/WikiMusic/PostgreSQL/Model/Artist.hs b/src/WikiMusic/PostgreSQL/Model/Artist.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/Model/Artist.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} - -module WikiMusic.PostgreSQL.Model.Artist - ( ArtistRow, - ArtistCommentRow, - ArtistArtworkRow, - InsertArtistRow, - ArtistOpinionRow, - InsertArtistCommentRow, - UpsertArtistOpinionRow, - InsertArtistArtworkRow, - InsertArtistExternalSourcesRow, - artistFromRow, - ) -where - -import WikiMusic.Model.Artist -import WikiMusic.Protolude - -type ArtistRow = (UUID, Text, UUID, Int64, Maybe UUID, UTCTime, Maybe UTCTime, Maybe Text, Maybe Text, Maybe Text, Maybe Text, Int64, Maybe Text) - -type InsertArtistCommentRow = (Text, Text, Maybe Text, Text, Int64, Text, Maybe Text, UTCTime, Maybe UTCTime) - -type InsertArtistArtworkRow = (Text, Text, Text, Int64, Maybe Text, Text, UTCTime, Maybe UTCTime, Maybe Text, Int64) - -type UpsertArtistOpinionRow = (Text, Text, Text, Bool, Bool, UTCTime, Maybe UTCTime) - -type InsertArtistRow = (Text, Text, Text, Int64, Maybe Text, UTCTime, Maybe UTCTime) - -type ArtistArtworkRow = (UUID, UUID, UUID, Int64, Maybe UUID, Text, Maybe Text, UTCTime, Maybe UTCTime, Int64) - -type ArtistCommentRow = (UUID, UUID, Maybe UUID, UUID, Int64, Text, Maybe Text, UTCTime, Maybe UTCTime) - -type ArtistOpinionRow = (UUID, UUID, UUID, Bool, Bool, UTCTime, Maybe UTCTime) - -type InsertArtistExternalSourcesRow = (Text, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text, UTCTime, Maybe UTCTime) - -artistFromRow :: ArtistRow -> Artist -artistFromRow - ( identifier, - displayName, - createdBy, - visibilityStatus, - approvedBy, - createdAt, - lastEditedAt, - spotifyUrl, - youtubeUrl, - soundcloudUrl, - wikipediaUrl, - viewCount, - description - ) = - Artist - { identifier = identifier, - displayName = displayName, - createdBy = createdBy, - visibilityStatus = fromIntegral visibilityStatus, - approvedBy = approvedBy, - createdAt = createdAt, - lastEditedAt = lastEditedAt, - artworks = fromList [], - comments = [], - opinions = fromList [], - spotifyUrl = spotifyUrl, - youtubeUrl = youtubeUrl, - soundcloudUrl = soundcloudUrl, - wikipediaUrl = wikipediaUrl, - viewCount = fromIntegral viewCount, - description = description - } diff --git a/src/WikiMusic/PostgreSQL/Model/Genre.hs b/src/WikiMusic/PostgreSQL/Model/Genre.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/Model/Genre.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} - -module WikiMusic.PostgreSQL.Model.Genre - ( GenreRow, - GenreCommentRow, - GenreArtworkRow, - InsertGenreRow, - GenreOpinionRow, - InsertGenreCommentRow, - UpsertGenreOpinionRow, - InsertGenreExternalSourcesRow, - InsertGenreArtworkRow, - genreFromRow, - ) -where - -import WikiMusic.Model.Genre -import WikiMusic.Protolude - -type GenreRow = (UUID, Maybe UUID, Text, UUID, Int64, Maybe UUID, UTCTime, Maybe UTCTime, Maybe Text, Maybe Text, Maybe Text, Maybe Text, Int64, Maybe Text) - -type InsertGenreCommentRow = (Text, Text, Maybe Text, Text, Int64, Text, Maybe Text, UTCTime, Maybe UTCTime) - -type InsertGenreArtworkRow = (Text, Text, Text, Int64, Maybe Text, Text, UTCTime, Maybe UTCTime, Maybe Text, Int64) - -type UpsertGenreOpinionRow = (Text, Text, Text, Bool, Bool, UTCTime, Maybe UTCTime) - -type InsertGenreRow = (Text, Text, Text, Int64, Maybe Text, UTCTime, Maybe UTCTime) - -type GenreArtworkRow = (UUID, UUID, UUID, Int64, Maybe UUID, Text, UTCTime, Maybe UTCTime) - -type GenreCommentRow = (UUID, UUID, Maybe UUID, UUID, Int64, Text, Maybe Text, UTCTime, Maybe UTCTime) - -type GenreOpinionRow = (UUID, UUID, UUID, Bool, Bool, UTCTime, Maybe UTCTime) - -type InsertGenreExternalSourcesRow = (Text, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text, UTCTime, Maybe UTCTime) - -genreFromRow :: GenreRow -> Genre -genreFromRow - ( identifier, - parentIdentifier, - displayName, - createdBy, - visibilityStatus, - approvedBy, - createdAt, - lastEditedAt, - spotifyUrl, - youtubeUrl, - soundcloudUrl, - wikipediaUrl, - viewCount, - description - ) = - Genre - { identifier = identifier, - parentIdentifier = parentIdentifier, - displayName = displayName, - createdBy = createdBy, - visibilityStatus = fromIntegral visibilityStatus, - approvedBy = approvedBy, - createdAt = createdAt, - lastEditedAt = lastEditedAt, - artworks = fromList [], - comments = [], - opinions = fromList [], - spotifyUrl = spotifyUrl, - youtubeUrl = youtubeUrl, - soundcloudUrl = soundcloudUrl, - wikipediaUrl = wikipediaUrl, - viewCount = fromIntegral viewCount, - description = description - } diff --git a/src/WikiMusic/PostgreSQL/Model/Other.hs b/src/WikiMusic/PostgreSQL/Model/Other.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/Model/Other.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} - -module WikiMusic.PostgreSQL.Model.Other - ( UserRow, - toUserRow, - ) -where - -import WikiMusic.Model.Other -import WikiMusic.Protolude - -type UserRow = - ( Text, - Text, - Text, - Text, - Maybe Text, - Maybe UTCTime, - Maybe Text, - Maybe Text, - UTCTime, - Maybe UTCTime - ) - -toUserRow :: User -> UserRow -toUserRow user = - ( user ^. #identifier, - user ^. #displayName, - user ^. #emailAddress, - user ^. #passwordHash, - user ^. #passwordResetToken, - user ^. #latestLoginAt, - user ^. #latestLoginDevice, - user ^. #avatarUrl, - user ^. #createdAt, - user ^. #lastEditedAt - ) diff --git a/src/WikiMusic/PostgreSQL/Model/Song.hs b/src/WikiMusic/PostgreSQL/Model/Song.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/Model/Song.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} - -module WikiMusic.PostgreSQL.Model.Song - ( SongRow, - SongCommentRow, - SongArtworkRow, - InsertSongRow, - SongOpinionRow, - InsertSongCommentRow, - UpsertSongOpinionRow, - InsertSongArtworkRow, - SongContentRow, - UpdateArtistsOfSongRow, - InsertSongExternalSourcesRow, - songFromRow, - ) -where - -import WikiMusic.Model.Song -import WikiMusic.Protolude - -type SongRow = - ( UUID, - Text, - Maybe Text, - Maybe Text, - Maybe Text, - Maybe Text, - Maybe Text, - UUID, - Int64, - Maybe UUID, - UTCTime, - Maybe UTCTime, - Maybe Text, - Maybe Text, - Maybe Text, - Maybe Text, - Int64, - Maybe Text - ) - -type InsertSongCommentRow = (Text, Text, Maybe Text, Text, Int64, Text, Maybe Text, UTCTime, Maybe UTCTime) - -type InsertSongArtworkRow = (Text, Text, Text, Int64, Maybe Text, Text, UTCTime, Maybe UTCTime, Maybe Text, Int64) - -type UpsertSongOpinionRow = (Text, Text, Text, Bool, Bool, UTCTime, Maybe UTCTime) - -type InsertSongRow = (UUID, Text, UUID, Maybe Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text, Text, Int64, Maybe Text, UTCTime, Maybe UTCTime) - -type SongArtworkRow = (Text, Text, Text, Int64, Maybe Text, Text, UTCTime, Maybe UTCTime) - -type SongCommentRow = (Text, Text, Maybe Text, Text, Int64, Text, Maybe Text, UTCTime, Maybe UTCTime) - -type SongOpinionRow = (Text, Text, Text, Bool, Bool, UTCTime, Maybe UTCTime) - -type SongContentRow = (UUID, UUID, Text, UUID, Int64, Maybe UUID, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text, UTCTime, Maybe UTCTime) - -type UpdateArtistsOfSongRow = (UUID, UUID, UUID, UTCTime) - -type InsertSongExternalSourcesRow = (Text, Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text, UTCTime, Maybe UTCTime) - -songFromRow :: SongRow -> Song -songFromRow - ( identifier, - displayName, - musicKey, - musicTuning, - musicCreationDate, - albumName, - albumInfoLink, - createdBy, - visibilityStatus, - approvedBy, - createdAt, - lastEditedAt, - spotifyUrl, - youtubeUrl, - soundcloudUrl, - wikipediaUrl, - viewCount, - description - ) = - Song - { identifier = identifier, - displayName = displayName, - musicKey = musicKey, - musicTuning = musicTuning, - musicCreationDate = musicCreationDate, - albumName = albumName, - albumInfoLink = albumInfoLink, - createdBy = createdBy, - visibilityStatus = fromIntegral visibilityStatus, - approvedBy = approvedBy, - createdAt = createdAt, - lastEditedAt = lastEditedAt, - artworks = fromList [], - comments = [], - opinions = fromList [], - contents = fromList [], - spotifyUrl = spotifyUrl, - youtubeUrl = youtubeUrl, - soundcloudUrl = soundcloudUrl, - wikipediaUrl = wikipediaUrl, - artists = fromList [], - viewCount = fromIntegral viewCount, - description = description - } diff --git a/src/WikiMusic/PostgreSQL/ReadAbstraction.hs b/src/WikiMusic/PostgreSQL/ReadAbstraction.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/ReadAbstraction.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} - -module WikiMusic.PostgreSQL.ReadAbstraction - ( persistenceReadCall, - fetchOpinions, - fetchArtworks, - fetchComments, - mkSearchConstraints, - bindParams, - ) -where - -import Data.ByteString.Lazy qualified as BL -import Data.Map qualified as Map -import Data.Text hiding (map) -import Data.Time -import Data.UUID hiding (fromString) -import Data.Vector qualified as V -import Hasql.Decoders as D -import Hasql.Encoders as E -import Hasql.Pool qualified -import Hasql.Session qualified -import Hasql.Statement (Statement (..)) -import NeatInterpolation -import Relude - -bindParams :: Int -> Text -bindParams size = Data.Text.intercalate ", " (["$" <> show x | x <- [1 .. size]]) - -persistenceReadCall :: - (MonadIO m) => - Hasql.Pool.Pool -> - Hasql.Session.Session b1 -> - ([a] -> b2) -> - (b1 -> [a]) -> - m b2 -persistenceReadCall pool sessionCreateF responseCreateF vectorParseF = do - eitherItems <- liftIO $ Hasql.Pool.use pool sessionCreateF - either - ( \err -> do - liftIO . BL.putStr . fromString . show $ err - pure $ responseCreateF [] - ) - (pure . responseCreateF . vectorParseF) - eitherItems - -fetchOpinions :: - (MonadIO m, Ord k, Foldable foldable) => - Hasql.Pool.Pool -> - ( [ ( UUID, - UUID, - UUID, - Bool, - Bool, - UTCTime, - Maybe UTCTime - ) - ] -> - [(k, a)] - ) -> - Text -> - Text -> - foldable UUID -> - m (Map k a) -fetchOpinions pool parseRow entityTable entityIdentifier identifiers = do - persistenceReadCall - pool - (Hasql.Session.statement identifiers preparedStmt) - Map.fromList - (parseRow . V.toList) - where - preparedStmt = Statement query encoder decoder True - query = - encodeUtf8 - [untrimming| - SELECT identifier, $entityIdentifier, created_by, is_like, is_dislike, - created_at, last_edited_at FROM $entityTable WHERE $entityIdentifier = ANY($$1) - |] - encoder = - E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid) - - decoder = D.rowVector vector - where - vector = - (,,,,,,) - <$> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.bool) - <*> D.column (D.nonNullable D.bool) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nullable D.timestamptz) - -fetchArtworks :: - (MonadIO m, Ord k, Foldable foldable) => - Hasql.Pool.Pool -> - ( [ ( UUID, - UUID, - UUID, - Int64, - Maybe UUID, - Text, - Maybe Text, - UTCTime, - Maybe UTCTime, - Int64 - ) - ] -> - [(k, a)] - ) -> - Text -> - Text -> - foldable UUID -> - m (Map k a) -fetchArtworks pool parseRow entityTable entityIdentifier identifiers = do - persistenceReadCall - pool - (Hasql.Session.statement identifiers preparedStmt) - Map.fromList - (parseRow . V.toList) - where - preparedStmt = Statement query encoder decoder True - query = - encodeUtf8 - [untrimming| - SELECT identifier, $entityIdentifier, created_by, visibility_status, approved_by, content_url, content_caption, - created_at, last_edited_at, order_value FROM $entityTable WHERE $entityIdentifier = ANY($$1) ORDER BY ${entityTable}.order_value ASC - |] - encoder = E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid) - decoder = D.rowVector vector - where - vector = - (,,,,,,,,,) - <$> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nullable D.uuid) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nullable D.timestamptz) - <*> D.column (D.nonNullable D.int8) - -fetchComments :: - (MonadIO m, Ord k, Foldable foldable) => - Hasql.Pool.Pool -> - ( [ ( UUID, - UUID, - Maybe UUID, - UUID, - Int64, - Text, - Maybe UUID, - UTCTime, - Maybe UTCTime - ) - ] -> - [(k, a)] - ) -> - Text -> - Text -> - foldable UUID -> - m (Map k a) -fetchComments pool parseRow entityTable entityIdentifier identifiers = do - persistenceReadCall - pool - (Hasql.Session.statement identifiers preparedStmt) - Map.fromList - (parseRow . V.toList) - where - preparedStmt = Statement query encoder decoder True - query = - encodeUtf8 - [untrimming| - SELECT identifier, $entityIdentifier, parent_identifier, created_by, visibility_status, - contents, approved_by, created_at, last_edited_at FROM $entityTable - WHERE $entityIdentifier = ANY($$1) ORDER BY ${entityTable}.created_at ASC - |] - encoder = - E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid) - decoder = D.rowVector vector - where - vector = - (,,,,,,,,) - <$> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.uuid) - <*> D.column (D.nullable D.uuid) - <*> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nullable D.uuid) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nullable D.timestamptz) - -mkSearchConstraints :: Text -> Text -mkSearchConstraints searchInput = Data.Text.intercalate " AND " inputs - where - cleanWords = map (Data.Text.filter (\x -> x /= '\'' && x /= '%' && x /= ';' && x /= '"') . strip) (Data.Text.words searchInput) - inputs = map (\x -> [untrimming|artists.display_name ILIKE '%$x%'|]) cleanWords diff --git a/src/WikiMusic/PostgreSQL/SongCommand.hs b/src/WikiMusic/PostgreSQL/SongCommand.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/SongCommand.hs +++ /dev/null @@ -1,653 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module WikiMusic.PostgreSQL.SongCommand () where - -import Data.Map qualified as Map -import Data.Text (pack) -import Hasql.Decoders as D -import Hasql.Encoders as E -import Hasql.Pool qualified -import Hasql.Statement (Statement (..)) -import Relude -import WikiMusic.Free.SongCommand -import WikiMusic.Interaction.Model.Song -import WikiMusic.Model.Artwork -import WikiMusic.Model.Comment -import WikiMusic.Model.Opinion -import WikiMusic.Model.Song -import WikiMusic.PostgreSQL.ReadAbstraction -import WikiMusic.PostgreSQL.WriteAbstraction -import WikiMusic.Protolude - -insertArtistsOfSongs' :: (MonadIO m) => Env -> [ArtistOfSong] -> m (Map UUID ArtistOfSong) -insertArtistsOfSongs' env items = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) items - pure $ Map.fromList $ map (\x -> (x ^. #identifier, x)) items - where - toRow x = - ( x ^. #identifier, - x ^. #songIdentifier, - x ^. #artistIdentifier, - x ^. #createdAt, - x ^. #createdBy - ) - bindParams' = bindParams 5 - encoder = - contrazip5 - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.timestamptz) - (E.param . E.nonNullable $ E.uuid) - stmt = Statement query encoder D.noResult True - query = - encodeUtf8 - [trimming| - INSERT INTO song_artists - (identifier, song_identifier, artist_identifier, created_at, created_by) - VALUES ($bindParams') - |] - -insertSongs' :: (MonadIO m) => Env -> [Song] -> m (Map UUID Song) -insertSongs' env songs = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) songs - now <- liftIO getCurrentTime - mapM_ - ( \x -> do - newUUID <- liftIO nextRandom - liftIO $ exec @SongCommand $ insertSongExternalSources env [toExternalSource x now newUUID] - ) - songs - pure $ Map.fromList $ map (\x -> (x ^. #identifier, x)) songs - where - toExternalSource x now newUUID = - SongExternalSources - { identifier = newUUID, - songIdentifier = x ^. #identifier, - spotifyUrl = x ^. #spotifyUrl, - youtubeUrl = x ^. #youtubeUrl, - soundcloudUrl = x ^. #soundcloudUrl, - wikipediaUrl = x ^. #wikipediaUrl, - createdAt = now, - createdBy = x ^. #createdBy, - lastEditedAt = Nothing - } - toRow x = - ( x ^. #identifier, - x ^. #displayName, - x ^. #musicKey, - x ^. #musicTuning, - x ^. #musicCreationDate, - x ^. #albumName, - x ^. #albumInfoLink, - x ^. #createdBy, - fromIntegral $ x ^. #visibilityStatus, - x ^. #approvedBy, - x ^. #createdAt, - x ^. #lastEditedAt, - x ^. #description - ) - bindParams' = bindParams 13 - stmt = Statement query encoder D.noResult True - encoder = - contrazip13 - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.text) - (E.param . E.nullable $ E.text) - (E.param . E.nullable $ E.text) - (E.param . E.nullable $ E.text) - (E.param . E.nullable $ E.text) - (E.param . E.nullable $ E.text) - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.int8) - (E.param . E.nullable $ E.uuid) - (E.param . E.nonNullable $ E.timestamptz) - (E.param . E.nullable $ E.timestamptz) - (E.param . E.nullable $ E.text) - query = - encodeUtf8 - [trimming| - INSERT INTO songs - (identifier, display_name, music_key, music_tuning, - music_creation_date, album_name, album_info_link, created_by, visibility_status, - approved_by, created_at, last_edited_at, description) - VALUES ($bindParams') - |] - -insertSongComments' :: (MonadIO m) => Env -> [SongComment] -> m (Map UUID SongComment) -insertSongComments' env comments = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) comments - pure . fromList . map (\x -> (x ^. #comment % #identifier, x)) $ comments - where - toRow x = - ( x ^. #comment % #identifier, - x ^. #songIdentifier, - x ^. #comment % #parentIdentifier, - x ^. #comment % #createdBy, - fromIntegral $ x ^. #comment % #visibilityStatus, - x ^. #comment % #contents, - x ^. #comment % #approvedBy, - x ^. #comment % #createdAt, - x ^. #comment % #lastEditedAt - ) - encoder = - contrazip9 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nonNullable E.text)) - (E.param (E.nullable E.uuid)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - stmt = Statement query encoder D.noResult True - bindParams' = bindParams 9 - query = - encodeUtf8 - [trimming| - INSERT INTO song_comments - (identifier, song_identifier, parent_identifier, created_by, - visibility_status, contents, approved_by, created_at, last_edited_at) - VALUES ($bindParams') - |] - -insertSongExternalSources' :: (MonadIO m) => Env -> [SongExternalSources] -> m (Map UUID SongExternalSources) -insertSongExternalSources' env externalSources = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) externalSources - pure . fromList . map (\x -> (x ^. #identifier, x)) $ externalSources - where - stmt = Statement query encoder D.noResult True - encoder = - contrazip9 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - (E.param (E.nonNullable E.uuid)) - bindParams' = bindParams 9 - query = - encodeUtf8 - [trimming| - INSERT INTO song_external_sources - (identifier, song_identifier, spotify_url, youtube_url, - soundcloud_url, wikipedia_url, created_at, last_edited_at, created_by) - VALUES ($bindParams') - |] - toRow x = - ( x ^. #identifier, - x ^. #songIdentifier, - x ^. #spotifyUrl, - x ^. #youtubeUrl, - x ^. #soundcloudUrl, - x ^. #wikipediaUrl, - x ^. #createdAt, - x ^. #lastEditedAt, - x ^. #createdBy - ) - -insertSongArtworks' :: (MonadIO m) => Env -> [SongArtwork] -> m (Map UUID SongArtwork) -insertSongArtworks' env artworks = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) artworks - pure . fromList . map (\x -> (x ^. #artwork % #identifier, x)) $ artworks - where - toRow x = - ( x ^. #artwork % #identifier, - x ^. #songIdentifier, - x ^. #artwork % #createdBy, - fromIntegral $ x ^. #artwork % #visibilityStatus, - x ^. #artwork % #approvedBy, - x ^. #artwork % #contentUrl, - x ^. #artwork % #createdAt, - x ^. #artwork % #lastEditedAt, - x ^. #artwork % #contentCaption, - fromIntegral $ x ^. #artwork % #orderValue - ) - stmt = Statement query encoder D.noResult True - encoder = - contrazip10 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.int8)) - (E.param (E.nullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - (E.param (E.nullable E.text)) - (E.param (E.nonNullable E.int8)) - bindParams' = bindParams 10 - query = - encodeUtf8 - [trimming| - INSERT INTO song_artworks - (identifier, song_identifier, created_by, visibility_status, - approved_by, content_url, created_at, last_edited_at, content_caption, order_value) - VALUES ($bindParams') - |] - -upsertSongOpinions' :: (MonadIO m) => Env -> [SongOpinion] -> m (Map UUID SongOpinion) -upsertSongOpinions' env opinions = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) opinions - pure . fromList . map (\x -> (x ^. #opinion % #identifier, x)) $ opinions - where - bindParams' = bindParams 7 - query = - encodeUtf8 - [trimming| - INSERT INTO song_opinions - (identifier, song_identifier, created_by, is_like, is_dislike, - created_at, last_edited_at) - VALUES ( $bindParams' ) - ON CONFLICT (song_identifier, created_by) DO - UPDATE SET is_like = $$4, is_dislike = $$5, - last_edited_at = $$6 - |] - stmt = Statement query encoder D.noResult True - encoder = - contrazip7 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.bool)) - (E.param (E.nonNullable E.bool)) - (E.param (E.nonNullable E.timestamptz)) - (E.param (E.nullable E.timestamptz)) - toRow x = do - ( x ^. #opinion % #identifier, - x ^. #songIdentifier, - x ^. #opinion % #createdBy, - x ^. #opinion % #isLike, - not $ x ^. #opinion % #isLike, - x ^. #opinion % #createdAt, - x ^. #opinion % #lastEditedAt - ) - -deleteSongs' :: (MonadIO m) => Env -> [UUID] -> m (Either SongCommandError ()) -deleteSongs' env identifiers = do - deleteArtworksOfSongsResult <- liftIO . exec @SongCommand $ deleteArtworksOfSongs env identifiers - deleteOpinionsOfSongsResult <- liftIO . exec @SongCommand $ deleteOpinionsOfSongs env identifiers - deleteCommentsOfSongsResult <- liftIO . exec @SongCommand $ deleteCommentsOfSongs env identifiers - deleteSongExternalSourcesResult <- liftIO . exec @SongCommand $ deleteSongExternalSources env identifiers - deleteSongsResult <- deleteStuffByUUID (env ^. #pool) "songs" "identifier" identifiers - deleteArtistsOfSongResult <- liftIO . exec @SongCommand $ deleteArtistsOfSongs env identifiers - deleteContentsOfSongResult <- liftIO . exec @SongCommand $ deleteContentsOfSongs env identifiers - pure $ - deleteArtworksOfSongsResult - <> deleteOpinionsOfSongsResult - <> deleteSongExternalSourcesResult - <> deleteCommentsOfSongsResult - <> deleteArtistsOfSongResult - <> deleteContentsOfSongResult - <> first fromHasqlUsageError deleteSongsResult - -updateSongArtworkOrder' :: (MonadIO m) => Env -> [SongArtworkOrderUpdate] -> m (Either a ()) -updateSongArtworkOrder' env orderUpdates = - Right <$> mapM_ performUpdate orderUpdates - where - stmt = Statement query encoder D.noResult True - query = - encodeUtf8 - [trimming| - UPDATE song_artworks SET order_value = $$2 WHERE identifier = $$1 - |] - encoder = - contrazip2 (E.param . E.nonNullable $ E.uuid) (E.param . E.nonNullable $ E.int8) - toRow x = (x ^. #identifier, fromIntegral $ x ^. #orderValue) - performUpdate x = do - operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow x) - pure $ first (pack . Relude.show) operationResults - -updateSongs' :: (MonadIO m) => Env -> Map UUID (Song, Maybe SongDelta) -> m (Either Text ()) -updateSongs' env deltas = do - liftIO $ mapM_ performUpdate deltas - exUpdate <- liftIO $ exec @SongCommand $ updateSongExternalSources env deltas - pure $ exUpdate <> Right () - where - stmt = Statement query encoder D.noResult True - query = - encodeUtf8 - [trimming| - UPDATE songs SET display_name = $$2, last_edited_at = $$3, description = $$4 WHERE identifier = $$1 - |] - encoder = - contrazip4 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nullable E.timestamptz)) - (E.param (E.nullable E.text)) - toRow x xDelta now = - ( x ^. #identifier, - fromMaybe (x ^. #displayName) (xDelta ^. #displayName), - Just now, - xDelta ^. #description - ) - performUpdate (_, Nothing) = pure $ Right () - performUpdate (x, Just xDelta) = do - now <- getCurrentTime - operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow x xDelta now) - pure $ first (pack . Relude.show) operationResults - -updateSongExternalSources' :: (MonadIO m) => Env -> Map UUID (Song, Maybe SongDelta) -> m (Either Text ()) -updateSongExternalSources' env deltas = - Right <$> mapM_ performUpdate deltas - where - stmt = Statement query encoder D.noResult True - query = - encodeUtf8 - [trimming| - UPDATE song_external_sources SET - spotify_url = $$2, - youtube_url = $$3, - wikipedia_url = $$4, - soundcloud_url = $$5 - WHERE song_identifier = $$1 - |] - - encoder = - contrazip5 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - toRow x xDelta = - ( x ^. #identifier, - xDelta ^. #spotifyUrl, - xDelta ^. #youtubeUrl, - xDelta ^. #wikipediaUrl, - xDelta ^. #soundcloudUrl - ) - performUpdate (_, Nothing) = pure $ Right () - performUpdate (x, Just xDelta) = do - operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow x xDelta) - pure $ first (pack . Relude.show) operationResults - -newSongArtworkFromRequest' :: (MonadIO m) => UUID -> InsertSongArtworksRequestItem -> m SongArtwork -newSongArtworkFromRequest' createdBy req = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - SongArtwork - { songIdentifier = req ^. #songIdentifier, - artwork = - Artwork - { identifier = newUUID, - createdBy = createdBy, - contentUrl = req ^. #contentUrl, - contentCaption = req ^. #contentCaption, - createdAt = now, - lastEditedAt = Nothing, - visibilityStatus = 0, - approvedBy = Nothing, - orderValue = req ^. #orderValue - } - } - -newSongOpinionFromRequest' :: (MonadIO m) => UUID -> UpsertSongOpinionsRequestItem -> m SongOpinion -newSongOpinionFromRequest' createdBy req = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - SongOpinion - { songIdentifier = req ^. #songIdentifier, - opinion = - Opinion - { identifier = newUUID, - createdBy = createdBy, - isLike = req ^. #isLike, - isDislike = not $ req ^. #isLike, - createdAt = now, - lastEditedAt = Nothing - } - } - -updateSongContents' :: (MonadIO m) => Env -> [SongContentDelta] -> m (Either Text ()) -updateSongContents' env songContentDeltas = do - now <- liftIO getCurrentTime - out <- mapM (performUpdate now) songContentDeltas - let outt = lefts out - if null outt - then pure . Right $ () - else pure . Left $ unlines outt - where - stmt = Statement query encoder decoder True - query = - encodeUtf8 - [trimming| - UPDATE song_contents SET version_name = $$2, instrument_type = $$3, ascii_legend = $$4, ascii_contents = $$5, - pdf_contents = $$6, guitarpro_contents = $$7, last_edited_at = $$8 WHERE identifier = $$1 - |] - encoder = - contrazip8 - (E.param (E.nonNullable E.uuid)) - (E.param (E.nonNullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.text)) - (E.param (E.nullable E.timestamptz)) - decoder = D.noResult - toRow now x = - ( x ^. #identifier, - x ^. #versionName, - x ^. #instrumentType, - x ^. #asciiLegend, - x ^. #asciiContents, - x ^. #pdfContents, - x ^. #guitarProContents, - Just now - ) - performUpdate now x = do - operationResults <- hasqlTransaction (env ^. #pool) stmt (toRow now x) - pure $ first (pack . WikiMusic.Model.Song.show) operationResults - -deleteArtistOfSong' :: (MonadIO m) => Env -> (UUID, UUID) -> m (Either SongCommandError ()) -deleteArtistOfSong' env identifiers = do - stmtResult <- hasqlTransaction (env ^. #pool) stmt identifiers - pure $ first fromHasqlUsageError stmtResult - where - query = - encodeUtf8 - [trimming| - DELETE FROM song_artists WHERE song_identifier = $$1 AND artist_identifier = $$2 - |] - encoder = - contrazip2 - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.uuid) - stmt = Statement query encoder D.noResult True - -newSongCommentFromRequest' :: (MonadIO m) => UUID -> InsertSongCommentsRequestItem -> m SongComment -newSongCommentFromRequest' createdBy x = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - SongComment - { songIdentifier = x ^. #songIdentifier, - comment = - Comment - { identifier = newUUID, - parentIdentifier = x ^. #parentIdentifier, - createdBy = createdBy, - visibilityStatus = 0, - contents = x ^. #contents, - approvedBy = Nothing, - createdAt = now, - lastEditedAt = Nothing - } - } - -insertSongContents' :: (MonadIO m) => Env -> [SongContent] -> m (Map UUID SongContent) -insertSongContents' env contents = do - mapM_ (hasqlTransaction (env ^. #pool) stmt . toRow) contents - pure $ Map.fromList $ map (\x -> (x ^. #identifier, x)) contents - where - decoder = D.noResult - encoder = - contrazip13 - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.text) - (E.param . E.nonNullable $ E.uuid) - (E.param (E.nonNullable E.int8)) - (E.param . E.nullable $ E.uuid) - (E.param . E.nonNullable $ E.text) - (E.param . E.nullable $ E.text) - (E.param . E.nullable $ E.text) - (E.param . E.nullable $ E.text) - (E.param . E.nullable $ E.text) - (E.param . E.nonNullable $ E.timestamptz) - (E.param . E.nullable $ E.timestamptz) - - stmt = Statement query encoder decoder True - bindParams' = bindParams 13 - toRow x = - ( x ^. #identifier, - x ^. #songIdentifier, - x ^. #versionName, - x ^. #createdBy, - fromIntegral $ x ^. #visibilityStatus, - x ^. #approvedBy, - x ^. #instrumentType, - x ^. #asciiLegend, - x ^. #asciiContents, - x ^. #pdfContents, - x ^. #guitarProContents, - x ^. #createdAt, - x ^. #lastEditedAt - ) - - query = - encodeUtf8 - [trimming| - INSERT INTO song_contents - (identifier, song_identifier, version_name, created_by, visibility_status, approved_by, - instrument_type, ascii_legend, ascii_contents, pdf_contents, guitarpro_contents, created_at, last_edited_at) - VALUES ($bindParams') - |] - -newSongFromRequest' :: (MonadIO m) => UUID -> InsertSongsRequestItem -> m Song -newSongFromRequest' createdBy song = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - Song - { identifier = newUUID, - displayName = song ^. #displayName, - musicKey = song ^. #musicKey, - musicTuning = song ^. #musicTuning, - musicCreationDate = song ^. #musicCreationDate, - albumName = song ^. #albumName, - albumInfoLink = song ^. #albumInfoLink, - createdBy = createdBy, - visibilityStatus = 0, - approvedBy = Nothing, - createdAt = now, - lastEditedAt = Nothing, - artworks = Map.empty, - comments = [], - opinions = Map.empty, - contents = Map.empty, - spotifyUrl = song ^. #spotifyUrl, - youtubeUrl = song ^. #youtubeUrl, - soundcloudUrl = song ^. #soundcloudUrl, - wikipediaUrl = song ^. #wikipediaUrl, - artists = Map.empty, - viewCount = 0, - description = song ^. #description - } - -newArtistOfSongFromRequest' :: (MonadIO m) => UUID -> InsertArtistsOfSongsRequestItem -> m ArtistOfSong -newArtistOfSongFromRequest' createdBy x = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - ArtistOfSong - { identifier = newUUID, - songIdentifier = x ^. #songIdentifier, - artistIdentifier = x ^. #artistIdentifier, - createdAt = now, - createdBy = createdBy - } - -newSongContentFromRequest' :: (MonadIO m) => UUID -> InsertSongContentsRequestItem -> m SongContent -newSongContentFromRequest' createdBy x = do - newUUID <- liftIO nextRandom - now <- liftIO getCurrentTime - pure $ - SongContent - { identifier = newUUID, - songIdentifier = x ^. #songIdentifier, - versionName = x ^. #versionName, - visibilityStatus = 0, - approvedBy = Nothing, - instrumentType = x ^. #instrumentType, - asciiLegend = x ^. #asciiLegend, - asciiContents = x ^. #asciiContents, - pdfContents = x ^. #pdfContents, - guitarProContents = x ^. #guitarProContents, - createdAt = now, - createdBy = createdBy, - lastEditedAt = Nothing - } - -instance Exec SongCommand where - execAlgebra (IncrementViewsByOne env identifiers next) = next =<< incrementViewsByOne' env identifiers "songs" - execAlgebra (InsertSongs env songs next) = next =<< insertSongs' env songs - execAlgebra (InsertSongComments env comments next) = next =<< insertSongComments' env comments - execAlgebra (InsertSongExternalSources env externalSources next) = next =<< insertSongExternalSources' env externalSources - execAlgebra (InsertSongArtworks env artworks next) = next =<< insertSongArtworks' env artworks - execAlgebra (UpsertSongOpinions env opinions next) = next =<< upsertSongOpinions' env opinions - execAlgebra (DeleteSongs env identifiers next) = next =<< deleteSongs' env identifiers - execAlgebra (DeleteSongComments env identifiers next) = - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_comments" "identifier" identifiers - execAlgebra (DeleteSongArtworks env identifiers next) = - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_artworks" "identifier" identifiers - execAlgebra (DeleteSongOpinions env identifiers next) = - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_opinions" "identifier" identifiers - execAlgebra (DeleteCommentsOfSongs env identifiers next) = - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_comments" "song_identifier" identifiers - execAlgebra (DeleteSongExternalSources env identifiers next) = - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_external_sources" "song_identifier" identifiers - execAlgebra (DeleteArtworksOfSongs env identifiers next) = - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_artworks" "song_identifier" identifiers - execAlgebra (DeleteOpinionsOfSongs env identifiers next) = - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_opinions" "song_identifier" identifiers - execAlgebra (UpdateSongArtworkOrder env orderUpdates next) = next =<< updateSongArtworkOrder' env orderUpdates - execAlgebra (UpdateSongs env deltas next) = next =<< updateSongs' env deltas - execAlgebra (UpdateSongContents env deltas next) = next =<< updateSongContents' env deltas - execAlgebra (UpdateSongExternalSources env deltas next) = next =<< updateSongExternalSources' env deltas - execAlgebra (NewSongCommentFromRequest createdBy req next) = next =<< newSongCommentFromRequest' createdBy req - execAlgebra (NewSongOpinionFromRequest createdBy req next) = next =<< newSongOpinionFromRequest' createdBy req - execAlgebra (NewSongArtworkFromRequest createdBy req next) = next =<< newSongArtworkFromRequest' createdBy req - execAlgebra (InsertSongContents env contents next) = next =<< insertSongContents' env contents - execAlgebra (InsertArtistsOfSongs env items next) = next =<< insertArtistsOfSongs' env items - execAlgebra (DeleteArtistsOfSongs env identifiers next) = - next . first fromHasqlUsageError =<< deleteStuffByUUID (env ^. #pool) "song_artists" "song_identifier" identifiers - execAlgebra (DeleteArtistOfSong env identifiers next) = next =<< deleteArtistOfSong' env identifiers - execAlgebra (NewSongFromRequest createdBy song next) = next =<< newSongFromRequest' createdBy song - execAlgebra (NewArtistOfSongFromRequest createdBy x next) = next =<< newArtistOfSongFromRequest' createdBy x - execAlgebra (NewSongContentFromRequest createdBy x next) = next =<< newSongContentFromRequest' createdBy x - execAlgebra (DeleteContentsOfSongs env identifiers next) = do - stmtResult <- deleteStuffByUUID (env ^. #pool) "song_contents" "song_identifier" identifiers - next $ first fromHasqlUsageError stmtResult - execAlgebra (DeleteSongContents env identifiers next) = do - stmtResult <- deleteStuffByUUID (env ^. #pool) "song_contents" "identifier" identifiers - next $ first fromHasqlUsageError stmtResult - -fromHasqlUsageError :: Hasql.Pool.UsageError -> SongCommandError -fromHasqlUsageError = PersistenceError . pack . Relude.show diff --git a/src/WikiMusic/PostgreSQL/SongQuery.hs b/src/WikiMusic/PostgreSQL/SongQuery.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/SongQuery.hs +++ /dev/null @@ -1,380 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module WikiMusic.PostgreSQL.SongQuery () where - -import Control.Concurrent.Async -import Data.ByteString.Lazy qualified as BL -import Data.Map (elems, keys) -import Data.Map qualified as Map -import Data.Text (intercalate, pack, strip) -import Data.Vector qualified as V -import Hasql.Decoders as D -import Hasql.Encoders as E -import Hasql.Session qualified as Session -import Hasql.Statement (Statement (..)) -import WikiMusic.Free.SongQuery -import WikiMusic.Model.Artwork -import WikiMusic.Model.Comment -import WikiMusic.Model.Opinion -import WikiMusic.Model.Other -import WikiMusic.Model.Song -import WikiMusic.Model.Thread as CommentThread -import WikiMusic.PostgreSQL.Model.Song -import WikiMusic.PostgreSQL.ReadAbstraction qualified as ReadAbstraction -import WikiMusic.Protolude - -fetchSongContents' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID SongContent) -fetchSongContents' env identifiers = do - let fromRow - ( identifier, - songIdentifier, - versionName, - createdBy, - visibilityStatus, - approvedBy, - instrumentType, - asciiLegend, - asciiContents, - pdfContents, - guitarProContents, - createdAt, - lastEditedAt - ) = - SongContent - { identifier = identifier, - songIdentifier = songIdentifier, - versionName = versionName, - createdBy = createdBy, - visibilityStatus = fromIntegral visibilityStatus, - approvedBy = approvedBy, - instrumentType = instrumentType, - asciiLegend = asciiLegend, - asciiContents = asciiContents, - pdfContents = pdfContents, - guitarProContents = guitarProContents, - createdAt = createdAt, - lastEditedAt = lastEditedAt - } - stmt = Statement query encoder decoder True - query = - encodeUtf8 - [trimming| - SELECT identifier, song_identifier, version_name, created_by, visibility_status, - approved_by, instrument_type, ascii_legend, - ascii_contents, pdf_contents, guitarpro_contents, created_at, last_edited_at - FROM song_contents - WHERE song_identifier = ANY($$1) - |] - encoder = - E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid) - decoder = D.rowVector vector - vector = - (,,,,,,,,,,,,) - <$> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nullable D.uuid) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nullable D.timestamptz) - parseSongContentRows = - map - ( \row -> - let songContent :: SongContent = fromRow row - in (songContent ^. #identifier, songContent) - ) - - ReadAbstraction.persistenceReadCall - (env ^. #pool) - (Session.statement identifiers stmt) - fromList - (parseSongContentRows . V.toList) - --- | PostgreSQL song row Hasql decoder for reading from `songs` table -songRowDecoder :: Result [SongRow] -songRowDecoder = - D.rowList $ - (,,,,,,,,,,,,,,,,,) - <$> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nullable D.uuid) - <*> D.column (D.nonNullable D.timestamptz) - <*> D.column (D.nullable D.timestamptz) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nullable D.text) - <*> D.column (D.nonNullable D.int8) - <*> D.column (D.nullable D.text) - --- | Parse a PostgreSQL Hasql row to a domain representation of song -parseSongRows :: [SongRow] -> [(UUID, Song)] -parseSongRows = map parser - where - parser row = let song = songFromRow row in (song ^. #identifier, song) - --- | Fetch song artworks from storage -fetchSongArtworks' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID SongArtwork) -fetchSongArtworks' env identifiers = - ReadAbstraction.fetchArtworks - (env ^. #pool) - (parseArtworkRows fromRow) - "song_artworks" - "song_identifier" - (vectorFromList identifiers) - where - fromRow - ( identifier, - songIdentifier, - createdBy, - visibilityStatus, - approvedBy, - contentUrl, - contentCaption, - createdAt, - lastEditedAt, - orderValue - ) = - let artwork = - Artwork - { identifier = identifier, - createdBy = createdBy, - visibilityStatus = fromIntegral visibilityStatus, - approvedBy = approvedBy, - contentUrl = contentUrl, - contentCaption = contentCaption, - createdAt = createdAt, - lastEditedAt = lastEditedAt, - orderValue = fromIntegral orderValue - } - in SongArtwork {..} - --- | Fetch song comments from storage -fetchSongComments' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID SongComment) -fetchSongComments' env identifiers = - ReadAbstraction.fetchComments - (env ^. #pool) - (parseCommentRows fromRow) - "song_comments" - "song_identifier" - (vectorFromList identifiers) - where - fromRow - ( identifier, - songIdentifier, - parentIdentifier, - createdBy, - visibilityStatus, - contents, - approvedBy, - createdAt, - lastEditedAt - ) = - let comment = - Comment - { identifier = identifier, - parentIdentifier = parentIdentifier, - createdBy = createdBy, - visibilityStatus = fromIntegral visibilityStatus, - contents = contents, - approvedBy = approvedBy, - createdAt = createdAt, - lastEditedAt = lastEditedAt - } - in SongComment {..} - --- | Fetch song opinions from storage -fetchSongOpinions' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID SongOpinion) -fetchSongOpinions' env identifiers = - ReadAbstraction.fetchOpinions - (env ^. #pool) - (parseOpinionRows fromRow) - "song_opinions" - "song_identifier" - (vectorFromList identifiers) - where - fromRow - ( identifier, - songIdentifier, - createdBy, - isLike, - isDislike, - createdAt, - lastEditedAt - ) = - let opinion = Opinion {..} - in SongOpinion {..} - -fetchSongs' :: (MonadIO m) => Env -> SongSortOrder -> Limit -> Offset -> m (Map UUID Song, [UUID]) -fetchSongs' env sortOrder (Limit limit) (Offset offset) = do - ReadAbstraction.persistenceReadCall - (env ^. #pool) - (Session.statement (fromIntegral limit, fromIntegral offset) stmt) - (\queryResults -> (fromList queryResults, map fst queryResults)) - parseSongRows - where - sortOrder' = pack . WikiMusic.Model.Song.show $ sortOrder - query = - encodeUtf8 - [trimming| - SELECT songs.identifier, songs.display_name, songs.music_key, - songs.music_tuning, songs.music_creation_date, songs.album_name, songs.album_info_link, - songs.created_by, songs.visibility_status, songs.approved_by, songs.created_at, songs.last_edited_at, - spotify_url, youtube_url, soundcloud_url, wikipedia_url, songs.views, songs.description - FROM songs - LEFT JOIN song_external_sources ON song_external_sources.song_identifier = songs.identifier - ORDER BY ${sortOrder'} - LIMIT ($$1) OFFSET $$2 - |] - encoder = contrazip2 (E.param . E.nonNullable $ E.int8) (E.param . E.nonNullable $ E.int8) - stmt = Statement query encoder songRowDecoder True - -fetchSongsByUUID' :: (MonadIO m) => Env -> SongSortOrder -> [UUID] -> m (Map UUID Song, [UUID]) -fetchSongsByUUID' env sortOrder identifiers = do - ReadAbstraction.persistenceReadCall - (env ^. #pool) - (Session.statement identifiers stmt) - (\queryResults -> (fromList queryResults, map fst queryResults)) - parseSongRows - where - stmt = Statement (BL.toStrict query) encoder songRowDecoder True - sortOrder' = fromString . WikiMusic.Model.Song.show $ sortOrder - query = - encodeUtf8 - [trimming| - SELECT songs.identifier, songs.display_name, songs.music_key, - songs.music_tuning, songs.music_creation_date, songs.album_name, songs.album_info_link, - songs.created_by, songs.visibility_status, songs.approved_by, songs.created_at, songs.last_edited_at, - spotify_url, youtube_url, soundcloud_url, wikipedia_url, songs.views, songs.description - FROM songs - LEFT JOIN song_external_sources ON song_external_sources.song_identifier = songs.identifier - WHERE songs.identifier = ANY($$1) ORDER BY $sortOrder' - |] - encoder = E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid) - -instance Exec SongQuery where - execAlgebra (FetchSongs env sortOrder limit offset next) = next =<< fetchSongs' env sortOrder limit offset - execAlgebra (FetchSongsByUUID env sortOrder identifiers next) = next =<< fetchSongsByUUID' env sortOrder identifiers - execAlgebra (EnrichedSongResponse env songMap enrichSongParams next) = do - let isChildOf' p x = Just (p ^. #comment % #identifier) == (x ^. #comment % #parentIdentifier) - songIds = keys songMap - getComment = - if enrichSongParams ^. #includeComments - then exec @SongQuery $ fetchSongComments env songIds - else pure $ fromList [] - getArtwork = - if enrichSongParams ^. #includeArtworks - then exec @SongQuery $ fetchSongArtworks env songIds - else pure $ fromList [] - getOpinion = - if enrichSongParams ^. #includeOpinions - then exec @SongQuery $ fetchSongOpinions env songIds - else pure $ fromList [] - getArtist = - if enrichSongParams ^. #includeArtists - then exec @SongQuery $ fetchSongArtists env songIds - else pure $ fromList [] - getContent = - if enrichSongParams ^. #includeContents - then exec @SongQuery $ fetchSongContents env songIds - else pure $ fromList [] - - (commentMap, artworkMap) <- concurrently getComment getArtwork - (contentMap, opinionMap) <- concurrently getContent getOpinion - artistPerSongList <- getArtist - let matchesSongIdentifier song = (== song ^. #identifier) . (^. #songIdentifier) - let enrichedSongs = - mapMap - ( \song -> do - let rawCommentMap = Map.filter (matchesSongIdentifier song) commentMap - allComments = elems rawCommentMap - commentThreads = map renderThread $ mkThreads allComments isChildOf' (^. #comment % #parentIdentifier) - relevantArtists = filter (\(songId, _, _) -> songId == song ^. #identifier) artistPerSongList - - song - { comments = commentThreads, - contents = filterMap (matchesSongIdentifier song) contentMap, - artworks = filterMap (matchesSongIdentifier song) artworkMap, - opinions = filterMap (matchesSongIdentifier song) opinionMap, - artists = Map.fromList $ map (\(_, artistId, artistName) -> (artistId, artistName)) relevantArtists - } - ) - songMap - next enrichedSongs - execAlgebra (FetchSongComments env identifiers next) = - next =<< fetchSongComments' env identifiers - execAlgebra (FetchSongOpinions env identifiers next) = - next =<< fetchSongOpinions' env identifiers - execAlgebra (FetchSongArtworks env identifiers next) = - next =<< fetchSongArtworks' env identifiers - execAlgebra (FetchSongArtists env identifiers next) = do - let stmt = Statement query encoder decoder True - query = - "SELECT song_artists.song_identifier, artists.identifier, artists.display_name FROM song_artists \ - \ INNER JOIN artists ON song_artists.artist_identifier = artists.identifier \ - \ WHERE song_identifier = ANY($1)" - encoder = - E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid) - decoder = D.rowVector vector - vector = - (,,) - <$> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.uuid) - <*> D.column (D.nonNullable D.text) - r <- - ReadAbstraction.persistenceReadCall - (env ^. #pool) - (Session.statement identifiers stmt) - fromList - V.toList - next r - execAlgebra (SearchSongs env searchInput sortOrder (Limit limit) (Offset offset) next) = do - let sortOrder' = pack . WikiMusic.Model.Song.show $ sortOrder - cleanWords = map (filterText (\x -> x /= '\'' && x /= '%' && x /= ';' && x /= '"') . strip) (words $ searchInput ^. #value) - inputs = map (\x -> [untrimming|songs.display_name ILIKE '%$x%' OR songs.album_name ILIKE '%$x%'|]) cleanWords - search' = Data.Text.intercalate " AND " inputs - query = - [untrimming| - SELECT songs.identifier, songs.display_name, songs.music_key, - songs.music_tuning, songs.music_creation_date, songs.album_name, songs.album_info_link, - songs.created_by, songs.visibility_status, songs.approved_by, songs.created_at, songs.last_edited_at, - spotify_url, youtube_url, soundcloud_url, wikipedia_url, songs.views, songs.description - FROM songs - LEFT JOIN song_external_sources ON song_external_sources.song_identifier = songs.identifier - WHERE ${search'} - ORDER BY ${sortOrder'} - LIMIT ($$1) OFFSET $$2 - |] - - encoder = contrazip2 (E.param . E.nonNullable $ E.int8) (E.param . E.nonNullable $ E.int8) - stmt = Statement (encodeUtf8 query) encoder songRowDecoder True - - r <- - ReadAbstraction.persistenceReadCall - (env ^. #pool) - (Session.statement (fromIntegral limit, fromIntegral offset) stmt) - (\queryResults -> (fromList queryResults, map fst queryResults)) - parseSongRows - next r - execAlgebra (FetchSongContents env identifiers next) = next =<< fetchSongContents' env identifiers diff --git a/src/WikiMusic/PostgreSQL/UserCommand.hs b/src/WikiMusic/PostgreSQL/UserCommand.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/UserCommand.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module WikiMusic.PostgreSQL.UserCommand () where - -import Data.ByteString.Base64 qualified -import Data.Password.Bcrypt -import Data.Text (pack) -import Data.UUID.V4 -import Hasql.Decoders as D -import Hasql.Encoders as E -import Hasql.Pool qualified -import Hasql.Session qualified as Session -import Hasql.Statement (Statement (..)) -import Relude -import WikiMusic.Free.UserCommand -import WikiMusic.Model.Auth -import WikiMusic.Model.Env -import WikiMusic.PostgreSQL.ReadAbstraction -import WikiMusic.PostgreSQL.WriteAbstraction -import WikiMusic.Protolude - -instance Exec UserCommand where - execAlgebra (MakeResetPasswordLink env email next) = doIfUserFoundByEmail env email (makeToken env) >>= next - execAlgebra (ChangePasswordByEmail env email password next) = do - next =<< doIfUserFoundByEmail env email (changePassword env password) - execAlgebra (InvalidateResetTokenByEmail env email next) = next =<< doIfUserFoundByEmail env email (invalidateToken env) - execAlgebra (InviteUser env _ email name' role desc next) = next =<< addUser env email name' role desc - execAlgebra (DeleteUser env _ email next) = next =<< doIfUserFoundByEmail env email (deleteU env) - -makeToken :: (MonadIO m) => Env -> UUID -> m (Either UserCommandError Text) -makeToken env identifier = do - now <- liftIO getCurrentTime - maybeToken <- maybeGenToken - first (PersistenceError . pack . Relude.show) maybeToken & either (pure . Left) (doWithToken now) - where - doWithToken now token = do - maybeRowsAff <- hasqlTransaction (env ^. #pool) stmt (identifier, token, now) - pure $ first fromHasqlUsageError $ token <$ maybeRowsAff - encoder = - contrazip3 - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.text) - (E.param . E.nonNullable $ E.timestamptz) - stmt = Statement query encoder D.noResult True - query = - encodeUtf8 - [trimming| - UPDATE users SET password_reset_token = $$2, last_edited_at = $$3 - WHERE identifier = $$1 - |] - -maybeGenToken :: (MonadIO m) => m (Either UnicodeException Text) -maybeGenToken = do - l <- pack . Relude.show <$> liftIO nextRandom - r <- pack . Relude.show <$> liftIO nextRandom - pure $ decodeUtf8' . Data.ByteString.Base64.encode . encodeUtf8 $ tokenConcat l r - where - tokenConcat l r = l <> "$" <> r - -invalidateToken :: (MonadIO m) => Env -> UUID -> m (Either UserCommandError ()) -invalidateToken env identifier = do - now <- liftIO getCurrentTime - maybeRowsAff <- liftIO $ hasqlTransaction (env ^. #pool) stmt (identifier, now) - pure $ bimap fromHasqlUsageError (const ()) maybeRowsAff - where - stmt = Statement query encoder D.noResult True - encoder = - contrazip2 - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.timestamptz) - query = - encodeUtf8 - [trimming| - UPDATE users SET password_reset_token = NULL, - last_edited_at = $$2 WHERE identifier = $$1 - |] - -fromHasqlUsageError :: Hasql.Pool.UsageError -> UserCommandError -fromHasqlUsageError = PersistenceError . pack . Relude.show - -changePassword :: (MonadIO m) => Env -> UserPassword -> UUID -> m (Either UserCommandError ()) -changePassword env password identifier = do - hashed <- hashPassword (mkPassword (password ^. #value)) - now <- liftIO getCurrentTime - new <- liftIO nextRandom - - maybeRowsAff <- liftIO $ hasqlTransaction (env ^. #pool) stmt (unPasswordHash hashed, identifier, now, newToken now new) - pure $ bimap fromHasqlUsageError (const ()) maybeRowsAff - where - stmt = Statement query encoder D.noResult True - encoder = - contrazip4 - (E.param . E.nonNullable $ E.text) - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.timestamptz) - (E.param . E.nonNullable $ E.text) - query = - encodeUtf8 - [trimming| - UPDATE users SET password_hash = $$1, last_edited_at = $$3, - auth_token = $$4 WHERE identifier = $$2 - |] - -newToken :: UTCTime -> UUID -> Text -newToken now new = - decodeUtf8 - . Data.ByteString.Base64.encode - . encodeUtf8 - $ (pack . WikiMusic.Protolude.show $ now) - <> "--" - <> (pack . WikiMusic.Protolude.show $ new) - -addUser :: (MonadIO m) => Env -> UserEmail -> UserName -> UserRole -> Maybe Text -> m (Either UserCommandError Text) -addUser env email name' role desc = do - now <- liftIO getCurrentTime - identifier <- liftIO nextRandom - new <- liftIO nextRandom - maybeRowsAff <- - liftIO $ - hasqlTransaction (env ^. #pool) stmt (identifier, name' ^. #value, email ^. #value, Nothing, now, Just (newToken now new), desc) - let creation = bimap fromHasqlUsageError (const ()) maybeRowsAff - case creation of - Left e -> pure . Left $ e - Right _ -> do - someUUID <- liftIO nextRandom - maybeRowsAff' <- - liftIO $ - hasqlTransaction (env ^. #pool) roleStmt (someUUID, identifier, pack . Relude.show $ role, now) - let rol = bimap fromHasqlUsageError (const ()) maybeRowsAff' - case rol of - Left e -> pure . Left $ e - Right _ -> doIfUserFoundByEmail env email (makeToken env) - where - stmt = Statement query encoder D.noResult True - roleStmt = Statement roleQuery roleEncoder D.noResult True - encoder = - contrazip7 - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.text) - (E.param . E.nonNullable $ E.text) - (E.param . E.nullable $ E.text) - (E.param . E.nonNullable $ E.timestamptz) - (E.param . E.nullable $ E.text) - (E.param . E.nullable $ E.text) - roleEncoder = - contrazip4 - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.text) - (E.param . E.nonNullable $ E.timestamptz) - bindParams' = bindParams 7 - roleBindParams' = bindParams 4 - query = - encodeUtf8 - [trimming| - INSERT INTO users (identifier, display_name, email_address, password_hash, created_at, auth_token, description) - VALUES ( $bindParams' ) - |] - roleQuery = - encodeUtf8 - [trimming| - INSERT INTO user_roles (identifier, user_identifier, role_id, created_at) - VALUES( $roleBindParams' ) - |] - -doIfUserFoundByEmail :: (MonadIO m) => Env -> UserEmail -> (UUID -> m (Either UserCommandError a)) -> m (Either UserCommandError a) -doIfUserFoundByEmail env email eff = do - maybeFoundByEmail <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement (email ^. #value) stmt) - first fromHasqlUsageError maybeFoundByEmail & either (pure . Left) doWithMaybeIdentifier - where - doWithMaybeIdentifier = maybe (pure . Left . LogicError $ "User could not be found!") eff - encoder = E.param . E.nonNullable $ E.text - stmt = Statement query encoder (D.rowMaybe . D.column . D.nonNullable $ D.uuid) True - query = - encodeUtf8 - [trimming| - SELECT identifier FROM users WHERE email_address = $$1 LIMIT 1 - |] - -deleteU :: (MonadIO m) => Env -> UUID -> m (Either UserCommandError ()) -deleteU env identifier = do - newUid <- liftIO nextRandom - maybeRowsAff <- liftIO $ hasqlTransaction (env ^. #pool) stmt (identifier, Relude.show newUid) - pure $ bimap fromHasqlUsageError (const ()) maybeRowsAff - where - encoder = - contrazip2 - (E.param . E.nonNullable $ E.uuid) - (E.param . E.nonNullable $ E.text) - stmt = Statement query encoder D.noResult True - query = - encodeUtf8 - [trimming| - UPDATE users SET password_hash = '', auth_token = '', email_address = $$2 - WHERE identifier = $$1 - |] diff --git a/src/WikiMusic/PostgreSQL/UserQuery.hs b/src/WikiMusic/PostgreSQL/UserQuery.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/UserQuery.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module WikiMusic.PostgreSQL.UserQuery () where - -import Data.Text qualified as T -import Hasql.Decoders as D -import Hasql.Encoders as E -import Hasql.Pool qualified -import Hasql.Session qualified as Session -import Hasql.Statement (Statement (..)) -import NeatInterpolation -import Optics -import Relude -import WikiMusic.Free.UserQuery -import WikiMusic.Protolude - -instance Exec UserQuery where - execAlgebra (DoesTokenMatchByEmail env email token next) = next =<< doesTokenMatchByEmail' env email token - -doesTokenMatchByEmail' :: (MonadIO m) => Env -> UserEmail -> UserToken -> m (Either UserQueryError Bool) -doesTokenMatchByEmail' env email token = do - maybeFoundByEmail <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement (email ^. #value) stmt) - let maybeTokenToCompare = first (PersistenceError . T.pack . show) maybeFoundByEmail - maybeTokenToCompare & either (pure . Left) (pure . Right . (Just (token ^. #value) ==)) - where - stmt = Statement query encoder decoder True - encoder = E.param . E.nonNullable $ E.text - decoder = D.rowMaybe $ D.column . D.nonNullable $ D.text - query = - encodeUtf8 - [trimming| - SELECT password_reset_token FROM users WHERE email_address = $$1 LIMIT 1 - |] diff --git a/src/WikiMusic/PostgreSQL/WriteAbstraction.hs b/src/WikiMusic/PostgreSQL/WriteAbstraction.hs deleted file mode 100644 --- a/src/WikiMusic/PostgreSQL/WriteAbstraction.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} - -module WikiMusic.PostgreSQL.WriteAbstraction - ( deleteStuffByUUID, - hasqlTransaction, - incrementViewsByOne', - ) -where - -import Control.Concurrent -import Data.Text -import Data.UUID hiding (fromString) -import Data.Vector qualified as V -import Hasql.Decoders as D -import Hasql.Encoders as E -import Hasql.Pool qualified -import Hasql.Statement (Statement (..)) -import Hasql.Transaction -import Hasql.Transaction.Sessions -import NeatInterpolation -import Relude -import WikiMusic.Protolude - -deleteStuffByUUID :: (MonadIO m) => Hasql.Pool.Pool -> Text -> Text -> [UUID] -> m (Either Hasql.Pool.UsageError ()) -deleteStuffByUUID pool entityTable entityIdentifier identifiers = do - hasqlTransaction pool stmt (V.fromList identifiers) - where - stmt = Statement query encoder decoder True - query = - encodeUtf8 - [trimming| - DELETE FROM $entityTable WHERE ${entityTable}.${entityIdentifier} = ANY($$1) - |] - encoder = E.param . E.nonNullable $ (E.foldableArray . E.nonNullable $ E.uuid) - decoder = D.noResult - -hasqlTransaction :: - (MonadIO m) => - Hasql.Pool.Pool -> - Statement row model -> - row -> - m (Either Hasql.Pool.UsageError model) -hasqlTransaction pool stmt row = liftIO $ Hasql.Pool.use pool transaction' - where - stmt' = Hasql.Transaction.statement row stmt - transaction' = transaction Serializable Write stmt' - -incrementViewsByOne' :: (MonadIO m) => Env -> [UUID] -> Text -> m (Either a ()) -incrementViewsByOne' env identifiers entityTable = do - Right <$> (void . liftIO . forkIO $ mapM_ performUpdate identifiers) - where - stmt = Statement query encoder D.noResult True - encoder = E.param . E.nonNullable $ E.uuid - performUpdate x = do - operationResults <- hasqlTransaction (env ^. #pool) stmt x - pure $ first (pack . show) operationResults - query = - encodeUtf8 - [trimming| - UPDATE $entityTable SET views = views + 1 WHERE identifier = $$1 - |] diff --git a/src/WikiMusic/Protolude.hs b/src/WikiMusic/Protolude.hs --- a/src/WikiMusic/Protolude.hs +++ b/src/WikiMusic/Protolude.hs @@ -12,28 +12,21 @@ filterMap, filterText, module NeatInterpolation, - vectorToList, - V.Vector, - vectorFromList, ) where import Contravariant.Extras.Contrazip -import Data.Map (Map, elems, filter, filterWithKey, fromList, keys, mapWithKey, toList, (!?)) import Data.Map qualified as Map -import Data.Text (intercalate, pack, splitAt, strip, take, unpack, unwords, words) import Data.Text qualified as T import Data.Time (UTCTime (..), ZonedTime, getCurrentTime, secondsToDiffTime) import Data.UUID (UUID) import Data.UUID.V4 (nextRandom) -import Data.Vector qualified as V import Free.AlaCarte import NeatInterpolation import Optics hiding (uncons) import Relude import WikiMusic.Model.Auth hiding (show) import WikiMusic.Model.Env -import Prelude qualified mapMap :: (a -> b) -> Map k a -> Map k b mapMap = Map.map @@ -41,11 +34,5 @@ filterMap :: (a -> Bool) -> Map k a -> Map k a filterMap = Map.filter -vectorToList :: V.Vector a -> [a] -vectorToList = V.toList - filterText :: (Char -> Bool) -> Text -> Text filterText = T.filter - -vectorFromList :: [a] -> V.Vector a -vectorFromList = V.fromList diff --git a/src/WikiMusic/SMTP/MailCommandSES.hs b/src/WikiMusic/SMTP/MailCommandSES.hs deleted file mode 100644 --- a/src/WikiMusic/SMTP/MailCommandSES.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoFieldSelectors #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module WikiMusic.SMTP.MailCommandSES () where - -import Data.Text qualified as T -import Network.Mail.Mime hiding (simpleMail) -import Network.Mail.SMTP hiding (htmlPart) -import Optics -import Relude -import System.Timeout -import WikiMusic.Free.MailCommand -import WikiMusic.Model.Env -import WikiMusic.Model.Mail -import WikiMusic.Protolude - -instance Exec MailCommand where - execAlgebra (SendMail env req next) = mailSend env req >>= next - -mailSend :: (MonadIO m) => Env -> MailSendRequest -> m (Either MailCommandError MailCommandOutcome) -mailSend env req = do - mailSendingResult <- liftIO $ timeout timeoutSeconds doSendMail - case mailSendingResult of - Nothing -> pure . Left $ MailError "" - Just _ -> pure $ Right MailSent - where - mailCfg = env ^. #cfg % #mail - timeoutSeconds = (mailCfg ^. #sendTimeoutSeconds) * 1000000 - preparedMail = - simpleMail - (Address (Just (mailCfg ^. #senderName)) (mailCfg ^. #senderMail)) - [Address (req ^. #name) (req ^. #email)] -- to - [] -- cc - [] -- bcc - (req ^. #subject) - [ htmlPart (fromString . T.unpack $ req ^. #body) - ] -- body - doSendMail = - sendMailWithLoginSTARTTLS - (T.unpack $ mailCfg ^. #host) - (T.unpack $ mailCfg ^. #user) - (maybe "" T.unpack (mailCfg ^. #password)) - preparedMail diff --git a/src/WikiMusic/Servant/ApiSetup.hs b/src/WikiMusic/Servant/ApiSetup.hs --- a/src/WikiMusic/Servant/ApiSetup.hs +++ b/src/WikiMusic/Servant/ApiSetup.hs @@ -4,25 +4,27 @@ module WikiMusic.Servant.ApiSetup ( mkApp, - WikiMusicPrivateAPI, - WikiMusicPublicAPI, + PrivateAPI, + PublicAPI, WikiMusicAPIServer, wiredUpPrivateServer, wiredUpPublicServer, ) where -import Data.ByteString.Char8 qualified as C8 import Data.OpenApi qualified import Data.Proxy import Data.Text (unpack) -import Database.Redis qualified as Redis -import Hasql.Pool qualified +import Data.Text qualified as T +import Database.Beam +import Database.SQLite.Simple qualified as Sqlite import Network.Wai +import Network.Wai.Logger (ApacheLogger) import Network.Wai.Middleware.Cors -import Network.Wai.RateLimit -import Network.Wai.RateLimit.Redis -import Network.Wai.RateLimit.Strategy +import Network.Wai.Middleware.Prometheus qualified as P +import Network.Wai.Middleware.RequestLogger +import Prometheus qualified as P +import Prometheus.Metric.GHC qualified as P import Relude import Servant import Servant.OpenApi @@ -43,7 +45,7 @@ apiProxy :: Proxy WikiMusicAPIServer apiProxy = Proxy -docsProxy :: Proxy WikiMusicAPIDocsServer +docsProxy :: Proxy APIDocsServer docsProxy = Proxy myCors :: CorsConfig -> Middleware @@ -72,24 +74,20 @@ corsIgnoreFailures = False } --- cookieSettings :: CookieConfig -> CookieSettings --- cookieSettings cfg = --- CookieSettings --- { cookieIsSecure = fromMaybe NotSecure $ readMaybe (unpack $ cfg ^. #secure), --- cookieMaxAge = Just $ secondsToDiffTime (fromIntegral $ cfg ^. #maxAge), --- cookieExpires = Nothing, --- cookiePath = Just (fromString . unpack $ cfg ^. #path), --- cookieDomain = Just (fromString . unpack $ cfg ^. #domain), --- cookieSameSite = fromMaybe AnySite $ readMaybe (unpack $ cfg ^. #sameSite), --- sessionCookieName = fromString . unpack $ cfg ^. #sessionCookieName, --- cookieXsrfSetting = Nothing --- } - -mkApp :: AppConfig -> Hasql.Pool.Pool -> Redis.Connection -> IO Application -mkApp cfg pool redisConn = do - now <- getCurrentTime +mkApp :: (MonadIO m) => ApacheLogger -> AppConfig -> m Application +mkApp logger' cfg = do + now <- liftIO getCurrentTime + conn <- liftIO $ Sqlite.open (T.unpack $ cfg ^. #sqlite % #path) + mailCss <- liftIO $ readFileBS "resources/css/mail.css" - let env = Env {pool = pool, cfg = cfg, processStartedAt = now} + let env = + Env + { cfg = cfg, + processStartedAt = now, + logger = logger', + conn = conn, + mailCss = T.filter (\x -> x /= '\n' && x /= '\t') . decodeUtf8 $ mailCss + } authCfg = authCheckIO env apiCfg = authCfg :. EmptyContext apiItself = @@ -99,49 +97,68 @@ ) pure + . (if (cfg ^. #dev % #reportedVersion) == "dev" then logStdoutDev else logStdout) . myCors (cfg ^. #cors) - . rateLimitingMiddleware redisConn + . P.prometheus P.def $ serveWithContext apiProxy apiCfg apiItself -wiredUpPrivateServer :: Env -> Server WikiMusicPrivateAPI +wiredUpPrivateServer :: Env -> Server PrivateAPI wiredUpPrivateServer env = artistHandlers env :<|> genreHandlers env :<|> songHandlers env :<|> authHandlers env -artistHandlers :: Env -> Server WikiMusicPrivateArtistsAPI -artistHandlers env = - fetchArtistsRoute env - :<|> searchArtistsRoute env - :<|> fetchArtistRoute env - :<|> insertArtistsRoute env - :<|> insertArtistCommentsRoute env - :<|> upsertArtistOpinionsRoute env - :<|> insertArtistArtworksRoute env - :<|> deleteArtistsByIdentifierRoute env +artistBase :: Env -> Server WithBaseEntityRoutes +artistBase env = + deleteArtistsByIdentifierRoute env :<|> deleteArtistCommentsByIdentifierRoute env :<|> deleteArtistOpinionsByIdentifierRoute env :<|> deleteArtistArtworksByIdentifierRoute env - :<|> updateArtistArtworksOrderRoute env - :<|> updateArtistRoute env -genreHandlers :: Env -> Server WikiMusicPrivateGenresAPI -genreHandlers env = - fetchGenresRoute env - :<|> searchGenresRoute env - :<|> fetchGenreRoute env - :<|> insertGenresRoute env - :<|> insertGenreCommentsRoute env - :<|> upsertGenreOpinionsRoute env - :<|> insertGenreArtworksRoute env - :<|> deleteGenresByIdentifierRoute env +artistHandlers :: Env -> Server ArtistsAPI +artistHandlers env = + artistBase env + :<|> ( fetchArtistsRoute env + :<|> searchArtistsRoute env + :<|> fetchArtistRoute env + :<|> insertArtistsRoute env + :<|> insertArtistCommentsRoute env + :<|> upsertArtistOpinionsRoute env + :<|> insertArtistArtworksRoute env + :<|> updateArtistArtworksOrderRoute env + :<|> updateArtistRoute env + ) + +genreBase :: Env -> Server WithBaseEntityRoutes +genreBase env = + deleteGenresByIdentifierRoute env :<|> deleteGenreCommentsByIdentifierRoute env :<|> deleteGenreOpinionsByIdentifierRoute env :<|> deleteGenreArtworksByIdentifierRoute env - :<|> updateGenreArtworksOrderRoute env - :<|> updateGenreRoute env -songHandlers :: Env -> Server WikiMusicPrivateSongsAPI +genreHandlers :: Env -> Server GenresAPI +genreHandlers env = + genreBase env + :<|> ( fetchGenresRoute env + :<|> searchGenresRoute env + :<|> fetchGenreRoute env + :<|> insertGenresRoute env + :<|> insertGenreCommentsRoute env + :<|> upsertGenreOpinionsRoute env + :<|> insertGenreArtworksRoute env + :<|> updateGenreArtworksOrderRoute env + :<|> updateGenreRoute env + ) + +songBase :: Env -> Server WithBaseEntityRoutes +songBase env = + deleteSongsByIdentifierRoute env + :<|> deleteSongCommentsByIdentifierRoute env + :<|> deleteSongOpinionsByIdentifierRoute env + :<|> deleteSongArtworksByIdentifierRoute env + +songHandlers :: Env -> Server SongsAPI songHandlers env = - fetchSongsRoute env + songBase env + :<|> fetchSongsRoute env :<|> searchSongsRoute env :<|> fetchSongRoute env :<|> insertSongsRoute env @@ -150,36 +167,22 @@ :<|> insertSongArtworksRoute env :<|> insertArtistOfSongRoute env :<|> deleteArtistOfSongRoute env - :<|> deleteSongsByIdentifierRoute env - :<|> deleteSongCommentsByIdentifierRoute env - :<|> deleteSongOpinionsByIdentifierRoute env - :<|> deleteSongArtworksByIdentifierRoute env :<|> updateSongArtworksOrderRoute env :<|> updateSongRoute env :<|> insertSongContentsRoute env :<|> deleteSongContentsByIdentifierRoute env :<|> updateSongContentsRoute env -authHandlers :: Env -> Server WikiMusicPrivateAuthAPI +authHandlers :: Env -> Server AuthAPI authHandlers env = fetchMeRoute env :<|> inviteUserRoute env :<|> deleteUserRoute env -wiredUpPublicServer :: Env -> Server WikiMusicPublicAPI +wiredUpPublicServer :: Env -> Server PublicAPI wiredUpPublicServer env = loginRoute env - :<|> makeResetPasswordLinkRoute env - :<|> doPasswordResetRoute env + :<|> ( makeResetPasswordLinkRoute env + :<|> doPasswordResetRoute env + ) :<|> systemInformationRoute env - -rateLimitingMiddleware :: Redis.Connection -> Middleware -rateLimitingMiddleware conn = rateLimiting strategy {strategyOnRequest = customController} - where - backend = redisBackend conn - getKey = pure . C8.pack . Relude.show . remoteHost - strategy = slidingWindow backend 30 15 getKey - customController req = - if rawPathInfo req == "/login" - then strategyOnRequest strategy req - else pure True diff --git a/src/WikiMusic/Servant/ArtistRoutes.hs b/src/WikiMusic/Servant/ArtistRoutes.hs --- a/src/WikiMusic/Servant/ArtistRoutes.hs +++ b/src/WikiMusic/Servant/ArtistRoutes.hs @@ -24,10 +24,10 @@ import WikiMusic.Interaction.Artist import WikiMusic.Interaction.Model.Artist import WikiMusic.Model.Other -import WikiMusic.PostgreSQL.ArtistCommand () -import WikiMusic.PostgreSQL.ArtistQuery () import WikiMusic.Protolude import WikiMusic.Servant.Utilities +import WikiMusic.Sqlite.ArtistCommand () +import WikiMusic.Sqlite.ArtistQuery () fetchArtistsRoute :: Env -> Maybe Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> Handler GetArtistsQueryResponse fetchArtistsRoute env authToken limit offset sort' include = @@ -35,7 +35,7 @@ env authToken ( \authUser -> - liftIO (exec @(ArtistQuery :+: ArtistCommand) $ fetchArtistsAction env authUser (maybe (Limit 10) Limit limit) (maybe (Offset 0) Offset offset) sort' include) >>= maybe200 + liftIO (exec @(ArtistQuery :+: ArtistCommand) $ fetchArtistsAction env authUser (maybe (Limit 25) Limit limit) (maybe (Offset 0) Offset offset) sort' include) >>= maybe200 ) searchArtistsRoute :: Env -> Maybe Text -> Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> Handler GetArtistsQueryResponse @@ -44,16 +44,16 @@ env authToken ( \authUser -> - liftIO (exec @(ArtistQuery :+: ArtistCommand) $ searchArtistsAction env authUser (maybe (Limit 10) Limit limit) (maybe (Offset 0) Offset offset) sort' include searchInput) >>= maybe200 + liftIO (exec @(ArtistQuery :+: ArtistCommand) $ searchArtistsAction env authUser (maybe (Limit 25) Limit limit) (maybe (Offset 0) Offset offset) sort' include searchInput) >>= maybe200 ) -fetchArtistRoute :: Env -> Maybe Text -> UUID -> Maybe Text -> Maybe Text -> Handler GetArtistsQueryResponse -fetchArtistRoute env authToken identifier sort' include = +fetchArtistRoute :: Env -> Maybe Text -> UUID -> Handler GetArtistsQueryResponse +fetchArtistRoute env authToken identifier = doWithAuth env authToken ( \authUser -> - liftIO (exec @(ArtistQuery :+: ArtistCommand) $ fetchArtistAction env authUser identifier sort' include) >>= maybe200 + liftIO (exec @(ArtistQuery :+: ArtistCommand) $ fetchArtistAction env authUser identifier (Just "created-at-desc") (Just "artworks,opinions,comments")) >>= maybe200 ) insertArtistsRoute :: Env -> Maybe Text -> InsertArtistsRequest -> Handler InsertArtistsCommandResponse diff --git a/src/WikiMusic/Servant/AuthRoutes.hs b/src/WikiMusic/Servant/AuthRoutes.hs --- a/src/WikiMusic/Servant/AuthRoutes.hs +++ b/src/WikiMusic/Servant/AuthRoutes.hs @@ -12,9 +12,9 @@ import WikiMusic.Interaction.Auth import WikiMusic.Interaction.Model.Auth import WikiMusic.Model.Env -import WikiMusic.PostgreSQL.AuthQuery () import WikiMusic.Protolude import WikiMusic.Servant.Utilities +import WikiMusic.Sqlite.AuthQuery () fetchMeRoute :: Env -> Maybe Text -> Handler GetMeQueryResponse fetchMeRoute env authToken = do diff --git a/src/WikiMusic/Servant/GenreRoutes.hs b/src/WikiMusic/Servant/GenreRoutes.hs --- a/src/WikiMusic/Servant/GenreRoutes.hs +++ b/src/WikiMusic/Servant/GenreRoutes.hs @@ -24,10 +24,10 @@ import WikiMusic.Interaction.Genre import WikiMusic.Interaction.Model.Genre import WikiMusic.Model.Other -import WikiMusic.PostgreSQL.GenreCommand () -import WikiMusic.PostgreSQL.GenreQuery () import WikiMusic.Protolude import WikiMusic.Servant.Utilities +import WikiMusic.Sqlite.GenreCommand () +import WikiMusic.Sqlite.GenreQuery () fetchGenresRoute :: Env -> Maybe Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> Handler GetGenresQueryResponse fetchGenresRoute env authToken limit offset sort' include = @@ -35,7 +35,7 @@ env authToken ( \authUser -> - liftIO (exec @(GenreQuery :+: GenreCommand) $ fetchGenresAction env authUser (maybe (Limit 10) Limit limit) (maybe (Offset 0) Offset offset) sort' include) >>= maybe200 + liftIO (exec @(GenreQuery :+: GenreCommand) $ fetchGenresAction env authUser (maybe (Limit 25) Limit limit) (maybe (Offset 0) Offset offset) sort' include) >>= maybe200 ) searchGenresRoute :: Env -> Maybe Text -> Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> Handler GetGenresQueryResponse @@ -44,16 +44,16 @@ env authToken ( \authUser -> - liftIO (exec @(GenreQuery :+: GenreCommand) $ searchGenresAction env authUser (maybe (Limit 10) Limit limit) (maybe (Offset 0) Offset offset) sort' include searchInput) >>= maybe200 + liftIO (exec @(GenreQuery :+: GenreCommand) $ searchGenresAction env authUser (maybe (Limit 25) Limit limit) (maybe (Offset 0) Offset offset) sort' include searchInput) >>= maybe200 ) -fetchGenreRoute :: Env -> Maybe Text -> UUID -> Maybe Text -> Maybe Text -> Handler GetGenresQueryResponse -fetchGenreRoute env authToken identifier sort' include = +fetchGenreRoute :: Env -> Maybe Text -> UUID -> Handler GetGenresQueryResponse +fetchGenreRoute env authToken identifier = doWithAuth env authToken ( \authUser -> - liftIO (exec @(GenreQuery :+: GenreCommand) $ fetchGenreAction env authUser identifier sort' include) >>= maybe200 + liftIO (exec @(GenreQuery :+: GenreCommand) $ fetchGenreAction env authUser identifier (Just "created-at-desc") (Just "artworks,opinions,comments")) >>= maybe200 ) insertGenresRoute :: Env -> Maybe Text -> InsertGenresRequest -> Handler InsertGenresCommandResponse diff --git a/src/WikiMusic/Servant/SongRoutes.hs b/src/WikiMusic/Servant/SongRoutes.hs --- a/src/WikiMusic/Servant/SongRoutes.hs +++ b/src/WikiMusic/Servant/SongRoutes.hs @@ -32,10 +32,10 @@ import WikiMusic.Interaction.Song import WikiMusic.Model.Env import WikiMusic.Model.Other -import WikiMusic.PostgreSQL.SongCommand () -import WikiMusic.PostgreSQL.SongQuery () import WikiMusic.Protolude import WikiMusic.Servant.Utilities +import WikiMusic.Sqlite.SongCommand () +import WikiMusic.Sqlite.SongQuery () fetchSongsRoute :: Env -> Maybe Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> Handler GetSongsQueryResponse fetchSongsRoute env authToken limit offset sort' include = @@ -43,7 +43,7 @@ env authToken ( \authUser -> - liftIO (exec @(SongQuery :+: SongCommand) $ fetchSongsAction env authUser (maybe (Limit 10) Limit limit) (maybe (Offset 0) Offset offset) sort' include) >>= maybe200 + liftIO (exec @(SongQuery :+: SongCommand) $ fetchSongsAction env authUser (maybe (Limit 25) Limit limit) (maybe (Offset 0) Offset offset) sort' include) >>= maybe200 ) searchSongsRoute :: Env -> Maybe Text -> Text -> Maybe Int -> Maybe Int -> Maybe Text -> Maybe Text -> Handler GetSongsQueryResponse @@ -52,16 +52,16 @@ env authToken ( \authUser -> - liftIO (exec @(SongQuery :+: SongCommand) $ searchSongsAction env authUser (maybe (Limit 10) Limit limit) (maybe (Offset 0) Offset offset) sort' include searchInput) >>= maybe200 + liftIO (exec @(SongQuery :+: SongCommand) $ searchSongsAction env authUser (maybe (Limit 25) Limit limit) (maybe (Offset 0) Offset offset) sort' include searchInput) >>= maybe200 ) -fetchSongRoute :: Env -> Maybe Text -> UUID -> Maybe Text -> Maybe Text -> Handler GetSongsQueryResponse -fetchSongRoute env authToken identifier sort' include = +fetchSongRoute :: Env -> Maybe Text -> UUID -> Handler GetSongsQueryResponse +fetchSongRoute env authToken identifier = doWithAuth env authToken ( \authUser -> - liftIO (exec @(SongQuery :+: SongCommand) $ fetchSongAction env authUser identifier sort' include) >>= maybe200 + liftIO (exec @(SongQuery :+: SongCommand) $ fetchSongAction env authUser identifier (Just "created-at-desc") (Just "artworks,opinions,comments,contents")) >>= maybe200 ) insertSongsRoute :: Env -> Maybe Text -> InsertSongsRequest -> Handler InsertSongsCommandResponse diff --git a/src/WikiMusic/Servant/UserRoutes.hs b/src/WikiMusic/Servant/UserRoutes.hs --- a/src/WikiMusic/Servant/UserRoutes.hs +++ b/src/WikiMusic/Servant/UserRoutes.hs @@ -16,11 +16,11 @@ import WikiMusic.Interaction.Model.User import WikiMusic.Interaction.User import WikiMusic.Model.Env -import WikiMusic.PostgreSQL.UserCommand () -import WikiMusic.PostgreSQL.UserQuery () import WikiMusic.Protolude -import WikiMusic.SMTP.MailCommandSES () import WikiMusic.Servant.Utilities +import WikiMusic.Smtp.MailCommandSES () +import WikiMusic.Sqlite.UserCommand () +import WikiMusic.Sqlite.UserQuery () makeResetPasswordLinkRoute :: Env -> Text -> Handler MakeResetPasswordLinkResponse makeResetPasswordLinkRoute env userEmail = liftIO (exec @(UserCommand :+: MailCommand) $ makeResetPasswordLinkAction env userEmail) >>= maybe200 diff --git a/src/WikiMusic/Servant/Utilities.hs b/src/WikiMusic/Servant/Utilities.hs --- a/src/WikiMusic/Servant/Utilities.hs +++ b/src/WikiMusic/Servant/Utilities.hs @@ -20,8 +20,8 @@ import WikiMusic.Model.Auth import WikiMusic.Model.Env import WikiMusic.Model.Other -import WikiMusic.PostgreSQL.AuthQuery () import WikiMusic.Protolude +import WikiMusic.Sqlite.AuthQuery () loginRoute :: Env -> @@ -71,8 +71,8 @@ doAfterPasswordCheck _ PasswordCheckFail = throwError err401 doAfterPasswordCheck wikimusicUser' PasswordCheckSuccess = do let tok = fromMaybe "" (wikimusicUser' ^. #authToken) - throwError $ - ServerError + throwError + $ ServerError { errHTTPCode = 204, errReasonPhrase = "No Content", errBody = "", @@ -116,16 +116,28 @@ } maybe204 :: (Show s) => Either s b -> Handler b -maybe204 (Left err) = throwError $ err500 {errBody = fromString . WikiMusic.Protolude.show $ err} +maybe204 (Left err) = + throwError + $ err500 + { errBody = fromString . WikiMusic.Protolude.show $ err + } maybe204 _ = throwError err204 maybe200 :: (Show s) => Either s b -> Handler b -maybe200 (Left err) = throwError $ err500 {errBody = fromString . WikiMusic.Protolude.show $ err} +maybe200 (Left err) = + throwError + $ err500 + { errBody = fromString . WikiMusic.Protolude.show $ err + } maybe200 (Right x) = pure x doWithAuth :: Env -> Maybe Text -> (WikiMusicUser -> Handler a) -> Handler a doWithAuth env authToken eff = do - authUser <- liftIO $ authCheckIO env (fromMaybe "" authToken) - case authUser of + case authToken of Nothing -> throwError err401 - Just auth -> eff auth + Just "" -> throwError err401 + Just t -> do + authUser <- liftIO $ authCheckIO env t + case authUser of + Nothing -> throwError err401 + Just auth -> eff auth diff --git a/src/WikiMusic/Smtp/MailCommandSES.hs b/src/WikiMusic/Smtp/MailCommandSES.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Smtp/MailCommandSES.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Smtp.MailCommandSES () where + +import Data.Text qualified as T +import Network.Mail.Mime hiding (simpleMail) +import Network.Mail.SMTP hiding (htmlPart) +import Optics +import Relude +import System.Timeout +import WikiMusic.Free.MailCommand +import WikiMusic.Model.Env +import WikiMusic.Model.Mail +import WikiMusic.Protolude + +instance Exec MailCommand where + execAlgebra (SendMail env req next) = mailSend env req >>= next + +mailSend :: (MonadIO m) => Env -> MailSendRequest -> m (Either MailCommandError MailCommandOutcome) +mailSend env req = do + mailSendingResult <- liftIO $ timeout timeoutSeconds doSendMail + case mailSendingResult of + Nothing -> pure . Left $ MailError "" + Just _ -> pure $ Right MailSent + where + mailCfg = env ^. #cfg % #mail + timeoutSeconds = (mailCfg ^. #sendTimeoutSeconds) * 1000000 + preparedMail = + simpleMail + (Address (Just (mailCfg ^. #senderName)) (mailCfg ^. #senderMail)) + [Address (req ^. #name) (req ^. #email)] -- to + [] -- cc + [] -- bcc + (req ^. #subject) + [ htmlPart (fromString . T.unpack $ req ^. #body) + ] -- body + doSendMail = + sendMailWithLoginSTARTTLS + (T.unpack $ mailCfg ^. #host) + (maybe "" T.unpack $ mailCfg ^. #user) + (maybe "" T.unpack $ mailCfg ^. #password) + preparedMail diff --git a/src/WikiMusic/Sqlite/ArtistCommand.hs b/src/WikiMusic/Sqlite/ArtistCommand.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Sqlite/ArtistCommand.hs @@ -0,0 +1,404 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Sqlite.ArtistCommand () where + +import Data.Map qualified as Map +import Data.UUID qualified as UUID +import Database.Beam +import Database.Beam.Sqlite +import Relude +import WikiMusic.Beam.Artist +import WikiMusic.Beam.Database +import WikiMusic.Free.ArtistCommand +import WikiMusic.Interaction.Model.Artist +import WikiMusic.Model.Artist +import WikiMusic.Model.Artwork +import WikiMusic.Model.Comment +import WikiMusic.Model.Opinion +import WikiMusic.Protolude + +insertArtists' :: (MonadIO m) => Env -> [Artist] -> m () +insertArtists' env artists = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #artists) wikiMusicDatabase) + $ insertValues (map toPersistenceArtist artists) + + externalContents <- + mapM + ( \s -> do + newIdentifier <- liftIO nextRandom + pure $ toPersistenceArtistExternalContents s newIdentifier + ) + artists + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #artistExternalSources) wikiMusicDatabase) + $ insertValues externalContents + +insertArtistComments' :: (MonadIO m) => Env -> [ArtistComment] -> m () +insertArtistComments' env comments = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #artistComments) wikiMusicDatabase) + $ insertValues (map toPersistenceArtistComment comments) + +insertArtistExternalSources' :: (MonadIO m) => Env -> [ArtistExternalSources] -> m (Map UUID ArtistExternalSources) +insertArtistExternalSources' env externalSources = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #artistExternalSources) wikiMusicDatabase) + $ insertValues (map mkArtistExSourcesP externalSources) + pure Map.empty + +insertArtistArtworks' :: (MonadIO m) => Env -> [ArtistArtwork] -> m (Map UUID ArtistArtwork) +insertArtistArtworks' env artworks = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #artistArtworks) wikiMusicDatabase) + $ insertValues (map mkArtistArtworkP artworks) + pure Map.empty + +upsertArtistOpinions' :: (MonadIO m) => Env -> [ArtistOpinion] -> m (Map UUID ArtistOpinion) +upsertArtistOpinions' env opinions = do + mapM_ + ( \o -> do + exOpinion <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + ( \s -> + (s ^. #artistIdentifier) + ==. val_ (ArtistId $ UUID.toText $ o ^. #artistIdentifier) + &&. (s ^. #createdBy) + ==. val_ (UUID.toText $ o ^. #opinion % #createdBy) + ) + $ all_ ((^. #artistOpinions) wikiMusicDatabase) + case exOpinion of + Nothing -> + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #artistOpinions) wikiMusicDatabase) + $ insertValues [mkArtistOpinionP o] + Just oo -> do + let newO = + ( oo + { isLike = o ^. #opinion % #isLike, + isDislike = o ^. #opinion % #isDislike, + lastEditedAt = o ^. #opinion % #lastEditedAt + } + ) :: + ArtistOpinion' + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runUpdate + $ save ((^. #artistOpinions) wikiMusicDatabase) newO + pure () + ) + opinions + + pure Map.empty + +deleteArtists' :: (MonadIO m) => Env -> [UUID] -> m (Either ArtistCommandError ()) +deleteArtists' env identifiers = do + deleteArtworksOfArtistsResult <- liftIO . exec @ArtistCommand $ deleteArtworksOfArtists env identifiers + deleteOpinionsOfArtistsResult <- liftIO . exec @ArtistCommand $ deleteOpinionsOfArtists env identifiers + deleteCommentsOfArtistsResult <- liftIO . exec @ArtistCommand $ deleteCommentsOfArtists env identifiers + deleteArtistExternalSourcesResult <- liftIO . exec @ArtistCommand $ deleteArtistExternalSources env identifiers + deleteArtistsResult <- doDeleteArtists' env identifiers + pure + $ deleteArtworksOfArtistsResult + <> deleteOpinionsOfArtistsResult + <> deleteArtistExternalSourcesResult + <> deleteCommentsOfArtistsResult + <> deleteArtistsResult + +doDeleteArtists' :: (MonadIO m) => Env -> [UUID] -> m (Either ArtistCommandError ()) +doDeleteArtists' env identifiers = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #artists) wikiMusicDatabase) + (\c -> (c ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + pure . Right $ () + +updateArtistArtworkOrder' :: (MonadIO m) => Env -> [ArtistArtworkOrderUpdate] -> m (Either a ()) +updateArtistArtworkOrder' env orderUpdates = do + mapM_ + ( \ou -> do + art <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + (\s -> (s ^. #identifier) ==. val_ (UUID.toText $ ou ^. #identifier)) + $ all_ ((^. #artistArtworks) wikiMusicDatabase) + case art of + Nothing -> pure () + Just foundArt -> do + let a = foundArt {orderValue = fromIntegral $ ou ^. #orderValue} :: ArtistArtwork' + liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runUpdate . save ((^. #artistArtworks) wikiMusicDatabase) $ a + ) + orderUpdates + pure . Right $ () + +updateArtists' :: (MonadIO m) => Env -> Map UUID (Artist, Maybe ArtistDelta) -> m (Either Text ()) +updateArtists' env deltas = do + now <- liftIO getCurrentTime + mapM_ (save'' . toPersistenceArtist . doDelta now) (Map.elems deltas) + exUpdate <- liftIO $ exec @ArtistCommand $ updateArtistExternalSources env deltas + pure $ exUpdate <> Right () + where + save'' x = liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runUpdate $ save ((^. #artists) wikiMusicDatabase) x + doDelta now (x, xDelta') = + case xDelta' of + Nothing -> x + Just xDelta -> + x + { displayName = fromMaybe (x ^. #displayName) (xDelta ^. #displayName), + description = xDelta ^. #description, + lastEditedAt = Just now + } :: + Artist + +updateArtistExternalSources' :: (MonadIO m) => Env -> Map UUID (Artist, Maybe ArtistDelta) -> m (Either Text ()) +updateArtistExternalSources' env deltas = do + now <- liftIO getCurrentTime + mapM_ + ( \(artist, xDelta) -> do + ex <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + (\s -> (s ^. #artistIdentifier) ==. val_ (ArtistId $ UUID.toText $ artist ^. #identifier)) + $ all_ ((^. #artistExternalSources) wikiMusicDatabase) + case ex of + Nothing -> pure () + Just foundEx -> do + let a = + foundEx + { spotifyUrl = (^. #spotifyUrl) =<< xDelta, + wikipediaUrl = (^. #wikipediaUrl) =<< xDelta, + soundcloudUrl = (^. #soundcloudUrl) =<< xDelta, + youtubeUrl = (^. #youtubeUrl) =<< xDelta, + lastEditedAt = Just now + } :: + ArtistExternalSources' + liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runUpdate . save ((^. #artistExternalSources) wikiMusicDatabase) $ a + ) + deltas + pure . Right $ () + +newArtistArtworkFromRequest' :: (MonadIO m) => UUID -> InsertArtistArtworksRequestItem -> m ArtistArtwork +newArtistArtworkFromRequest' createdBy req = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ ArtistArtwork + { artistIdentifier = req ^. #artistIdentifier, + artwork = + Artwork + { identifier = newUUID, + createdBy = createdBy, + contentUrl = req ^. #contentUrl, + contentCaption = req ^. #contentCaption, + createdAt = now, + lastEditedAt = Nothing, + visibilityStatus = 0, + approvedBy = Nothing, + orderValue = req ^. #orderValue + } + } + +newArtistOpinionFromRequest' :: (MonadIO m) => UUID -> UpsertArtistOpinionsRequestItem -> m ArtistOpinion +newArtistOpinionFromRequest' createdBy req = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ ArtistOpinion + { artistIdentifier = req ^. #artistIdentifier, + opinion = + Opinion + { identifier = newUUID, + createdBy = createdBy, + isLike = req ^. #isLike, + isDislike = not $ req ^. #isLike, + createdAt = now, + lastEditedAt = Nothing + } + } + +newArtistFromRequest' :: (MonadIO m) => UUID -> InsertArtistsRequestItem -> m Artist +newArtistFromRequest' createdBy req = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ Artist + { identifier = newUUID, + displayName = req ^. #displayName, + createdBy = createdBy, + visibilityStatus = 0, + approvedBy = Nothing, + createdAt = now, + lastEditedAt = Nothing, + artworks = fromList [], + comments = [], + opinions = fromList [], + spotifyUrl = req ^. #spotifyUrl, + youtubeUrl = req ^. #youtubeUrl, + soundcloudUrl = req ^. #soundcloudUrl, + wikipediaUrl = req ^. #wikipediaUrl, + viewCount = 0, + description = req ^. #description + } + +newArtistCommentFromRequest' :: (MonadIO m) => UUID -> InsertArtistCommentsRequestItem -> m ArtistComment +newArtistCommentFromRequest' createdBy x = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ ArtistComment + { artistIdentifier = x ^. #artistIdentifier, + comment = + Comment + { identifier = newUUID, + parentIdentifier = x ^. #parentIdentifier, + createdBy = createdBy, + visibilityStatus = 0, + contents = x ^. #contents, + approvedBy = Nothing, + createdAt = now, + lastEditedAt = Nothing + } + } + +deleteArtistComments' :: (MonadIO m) => Env -> [UUID] -> m (Either ArtistCommandError ()) +deleteArtistComments' env identifiers = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #artistComments) wikiMusicDatabase) + (\c -> (c ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + pure . Right $ () + +deleteArtistArtworks' :: (MonadIO m) => Env -> [UUID] -> m (Either ArtistCommandError ()) +deleteArtistArtworks' env identifiers = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #artistArtworks) wikiMusicDatabase) + (\c -> (c ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + pure . Right $ () + +deleteArtistOpinions' :: (MonadIO m) => Env -> [UUID] -> m (Either ArtistCommandError ()) +deleteArtistOpinions' env identifiers = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #artistOpinions) wikiMusicDatabase) + (\c -> (c ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + pure . Right $ () + +incrementViewsByOne' :: (MonadIO m) => Env -> [UUID] -> m (Either ArtistCommandError ()) +incrementViewsByOne' env identifiers = do + mapM_ doUpdate identifiers + pure $ Right () + where + doUpdate x = do + ex <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + (\s -> (s ^. #identifier) ==. (val_ . UUID.toText $ x)) + $ all_ ((^. #artists) wikiMusicDatabase) + case ex of + Nothing -> pure () + Just foundEx -> do + let a = + foundEx + { viewCount = (foundEx ^. #viewCount) + 1 + } :: + Artist' + liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runUpdate . save ((^. #artists) wikiMusicDatabase) $ a + +instance Exec ArtistCommand where + execAlgebra (IncrementViewsByOne env identifiers next) = + next =<< incrementViewsByOne' env identifiers + execAlgebra (InsertArtists env artists next) = + next =<< insertArtists' env artists + execAlgebra (InsertArtistComments env comments next) = + next =<< insertArtistComments' env comments + execAlgebra (InsertArtistExternalSources env externalSources next) = + next =<< insertArtistExternalSources' env externalSources + execAlgebra (InsertArtistArtworks env artworks next) = + next =<< insertArtistArtworks' env artworks + execAlgebra (UpsertArtistOpinions env opinions next) = + next =<< upsertArtistOpinions' env opinions + execAlgebra (DeleteArtists env identifiers next) = + next =<< deleteArtists' env identifiers + execAlgebra (DeleteArtistComments env identifiers next) = do + next =<< deleteArtistComments' env identifiers + execAlgebra (DeleteArtistArtworks env identifiers next) = do + next =<< deleteArtistArtworks' env identifiers + execAlgebra (DeleteArtistOpinions env identifiers next) = do + next =<< deleteArtistOpinions' env identifiers + execAlgebra (DeleteCommentsOfArtists env identifiers next) = do + let ids = map UUID.toText identifiers + + mapM_ + ( \y -> + runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete ((^. #artistComments) wikiMusicDatabase) (\c -> c ^. #artistIdentifier ==. (val_ . ArtistId $ y)) + ) + ids + + next $ Right () + execAlgebra (DeleteArtistExternalSources env identifiers next) = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #artistExternalSources) wikiMusicDatabase) + (\c -> (c ^. #artistIdentifier) `in_` map (val_ . ArtistId . UUID.toText) identifiers) + next . Right $ () + execAlgebra (DeleteArtworksOfArtists env identifiers next) = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #artistArtworks) wikiMusicDatabase) + (\c -> (c ^. #artistIdentifier) `in_` map (val_ . ArtistId . UUID.toText) identifiers) + next . Right $ () + execAlgebra (DeleteOpinionsOfArtists env identifiers next) = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #artistOpinions) wikiMusicDatabase) + (\c -> (c ^. #artistIdentifier) `in_` map (val_ . ArtistId . UUID.toText) identifiers) + next . Right $ () + execAlgebra (UpdateArtistArtworkOrder env orderUpdates next) = + next =<< updateArtistArtworkOrder' env orderUpdates + execAlgebra (UpdateArtists env deltas next) = + next =<< updateArtists' env deltas + execAlgebra (UpdateArtistExternalSources env deltas next) = + next =<< updateArtistExternalSources' env deltas + execAlgebra (NewArtistFromRequest createdBy req next) = + next =<< newArtistFromRequest' createdBy req + execAlgebra (NewArtistCommentFromRequest createdBy req next) = + next =<< newArtistCommentFromRequest' createdBy req + execAlgebra (NewArtistOpinionFromRequest createdBy req next) = + next =<< newArtistOpinionFromRequest' createdBy req + execAlgebra (NewArtistArtworkFromRequest createdBy req next) = + next =<< newArtistArtworkFromRequest' createdBy req diff --git a/src/WikiMusic/Sqlite/ArtistQuery.hs b/src/WikiMusic/Sqlite/ArtistQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Sqlite/ArtistQuery.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Sqlite.ArtistQuery () where + +import Data.Map (elems, keys) +import Data.Map qualified as Map +import Data.UUID qualified as UUID +import Database.Beam +import Database.Beam.Sqlite +import WikiMusic.Beam.Artist +import WikiMusic.Beam.Database +import WikiMusic.Beam.Util +import WikiMusic.Free.ArtistQuery +import WikiMusic.Model.Artist +import WikiMusic.Model.Other +import WikiMusic.Model.Thread as CommentThread +import WikiMusic.Protolude + +instance Exec ArtistQuery where + execAlgebra (FetchArtists env sortOrder limit offset next) = + next =<< fetchArtists' env sortOrder limit offset + execAlgebra (FetchArtistsByUUID env sortOrder identifiers next) = + next =<< fetchArtistsByUUID' env sortOrder identifiers + execAlgebra (EnrichedArtistResponse env artistMap enrichArtistParams next) = + next =<< enrichedArtistResponse' env artistMap enrichArtistParams + execAlgebra (FetchArtistComments env identifiers next) = + next =<< fetchArtistComments' env identifiers + execAlgebra (FetchArtistOpinions env identifiers next) = + next =<< fetchArtistOpinions' env identifiers + execAlgebra (SearchArtists env searchInput sortOrder limit offset next) = + next =<< searchArtists' env searchInput sortOrder limit offset + execAlgebra (FetchArtistArtworks env identifiers next) = + next =<< fetchArtistArtworks' env identifiers + +mkOrderBy AscCreatedAt = orderBy_ (asc_ . (^. #createdAt)) +mkOrderBy DescCreatedAt = orderBy_ (desc_ . (^. #createdAt)) +mkOrderBy AscDisplayName = orderBy_ (asc_ . (^. #displayName)) +mkOrderBy DescDisplayName = orderBy_ (desc_ . (^. #displayName)) +mkOrderBy AscLastEditedAt = orderBy_ (asc_ . (^. #lastEditedAt)) +mkOrderBy DescLastEditedAt = orderBy_ (desc_ . (^. #lastEditedAt)) + +-- | Fetch artists from storage, according to a sort order, limit and offset +fetchArtists' :: (MonadIO m) => Env -> ArtistSortOrder -> Limit -> Offset -> m (Map UUID Artist, [UUID]) +fetchArtists' env sortOrder (Limit limit) (Offset offset) = do + artists <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningList + . select + . limit_ (fromIntegral limit) + . offset_ (fromIntegral offset) + . mkOrderBy sortOrder + $ all_ ((^. #artists) wikiMusicDatabase) + filledArtists env artists + +-- | Fetch artists by UUID from storage, according to a sort order +fetchArtistsByUUID' :: (MonadIO m) => Env -> ArtistSortOrder -> [UUID] -> m (Map UUID Artist, [UUID]) +fetchArtistsByUUID' env sortOrder identifiers = do + artists <- + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runSelectReturningList + . select + . filter_ (\s -> (s ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + . mkOrderBy sortOrder + $ all_ ((^. #artists) wikiMusicDatabase) + filledArtists env artists + +-- | Fetch artist artworks from storage +fetchArtistArtworks' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID ArtistArtwork) +fetchArtistArtworks' env identifiers = do + artworks <- liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runSelectReturningList + . select + . orderBy_ (asc_ . (^. #orderValue)) + $ do + songs <- + filter_ (\s -> (s ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + $ all_ ((^. #artists) wikiMusicDatabase) + oneToMany_ ((^. #artistArtworks) wikiMusicDatabase) (^. #artistIdentifier) songs + pure . Map.fromList . map toArtistArtwork $ artworks + +-- | Enrich artists with related information, according to enrichment parameters +enrichedArtistResponse' :: (MonadIO m) => Env -> Map UUID Artist -> EnrichArtistParams -> m (Map UUID Artist) +enrichedArtistResponse' env artistMap enrichArtistParams = do + artworkMap <- liftIO getArtwork + opinionMap <- liftIO getOpinion + commentMap <- liftIO getComment + + let enrichedArtists = + mapMap + ( \artist -> do + let rawCommentMap = Map.filter (matchesArtistIdentifier artist) commentMap + allComments = elems rawCommentMap + commentThreads = map renderThread $ mkThreads allComments isChildOf' (^. #comment % #parentIdentifier) + + artist + { comments = commentThreads, + artworks = filterMap (matchesArtistIdentifier artist) artworkMap, + opinions = filterMap (matchesArtistIdentifier artist) opinionMap + } + ) + artistMap + + pure enrichedArtists + where + matchesArtistIdentifier artist = (== artist ^. #identifier) . (^. #artistIdentifier) + isChildOf' p x = Just (p ^. #comment % #identifier) == x ^. #comment % #parentIdentifier + artistIds = keys artistMap + getComment = + if enrichArtistParams ^. #includeComments + then exec @ArtistQuery $ fetchArtistComments env artistIds + else pure $ fromList [] + getArtwork = + if enrichArtistParams ^. #includeArtworks + then exec @ArtistQuery $ fetchArtistArtworks env artistIds + else pure $ fromList [] + getOpinion = + if enrichArtistParams ^. #includeOpinions + then exec @ArtistQuery $ fetchArtistOpinions env artistIds + else pure $ fromList [] + +-- | Fetch artist comments from storage +fetchArtistComments' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID ArtistComment) +fetchArtistComments' env identifiers = do + comments <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningList $ select $ do + artists <- + filter_ (\s -> (s ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + $ all_ ((^. #artists) wikiMusicDatabase) + oneToMany_ ((^. #artistComments) wikiMusicDatabase) (^. #artistIdentifier) artists + + pure . Map.fromList . map toArtistComment $ comments + +searchArtists' :: (MonadIO m) => Env -> SearchInput -> ArtistSortOrder -> Limit -> Offset -> m (Map UUID Artist, [UUID]) +searchArtists' env searchInput sortOrder (Limit limit) (Offset offset) = do + artists <- + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runSelectReturningList + . select + . filter_ (\s -> (s ^. #displayName) `like_` val_ ("%" <> searchInput ^. #value <> "%")) + . limit_ (fromIntegral limit) + . offset_ (fromIntegral offset) + . mkOrderBy sortOrder + $ all_ ((^. #artists) wikiMusicDatabase) + filledArtists env artists + +-- | Fetch artist opinions from storage +fetchArtistOpinions' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID ArtistOpinion) +fetchArtistOpinions' env identifiers = do + opinions <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningList $ select $ do + artists <- + filter_ (\s -> (s ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + $ all_ ((^. #artists) wikiMusicDatabase) + oneToMany_ ((^. #artistOpinions) wikiMusicDatabase) (^. #artistIdentifier) artists + + pure . Map.fromList . map toArtistOpinion $ opinions + +filledArtists :: (MonadIO m) => Env -> [Artist'] -> m (Map UUID Artist, [UUID]) +filledArtists env artists = do + externalSources <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningList + . select + . filter_ (\s -> (s ^. #artistIdentifier) `in_` map (val_ . (\x -> ArtistId $ x ^. #identifier)) artists) + $ all_ ((^. #artistExternalSources) wikiMusicDatabase) + let filledArtists' = map (withExternalSources externalSources) artists + pure (Map.fromList filledArtists', map (textToUUID . (^. #identifier)) artists) + where + withExternalSources externalSources artist = + let maybeFoundExternal = + fmap + (fromPersistenceExternalSource . head) + (nonEmpty $ filter (\x -> fromArtistPk (x ^. #artistIdentifier) == (artist ^. #identifier)) externalSources) + in toArtist artist (fromMaybe emptyExternalSources maybeFoundExternal) diff --git a/src/WikiMusic/Sqlite/AuthQuery.hs b/src/WikiMusic/Sqlite/AuthQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Sqlite/AuthQuery.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Sqlite.AuthQuery () where + +import Data.Text qualified as T +import Data.UUID qualified as UUID +import Database.Beam +import Database.Beam.Sqlite +import Relude +import WikiMusic.Beam.Database +import WikiMusic.Beam.User +import WikiMusic.Free.AuthQuery +import WikiMusic.Protolude + +instance Exec AuthQuery where + execAlgebra (FetchUserForAuthCheck env email next) = do + next =<< fetchUserForAuthCheck' env email + execAlgebra (FetchUserFromToken env t next) = do + next =<< fetchUserFromToken' env t + execAlgebra (FetchMe env identifier next) = do + next =<< fetchMe' env identifier + execAlgebra (FetchUserRoles env identifier next) = do + next =<< fetchUserRoles' env identifier + +fetchMe' :: (MonadIO m) => Env -> UUID -> m (Either AuthQueryError (Maybe WikiMusicUser)) +fetchMe' env identifier = do + maybeUser <- liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runSelectReturningFirst . select $ do + filter_ (\s -> (s ^. #identifier) ==. val_ (T.pack . show $ identifier)) + $ all_ ((^. #users) wikiMusicDatabase) + case maybeUser of + Nothing -> pure . Left $ AuthError "User did not exist" + (Just usr) -> do + u' <- withRoles env (mkUserM [] usr) + pure . Right . Just $ u' + +fetchUserForAuthCheck' :: (MonadIO m) => Env -> Text -> m (Either AuthQueryError (Maybe WikiMusicUser)) +fetchUserForAuthCheck' env email = do + maybeUser <- liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runSelectReturningFirst . select $ do + filter_ (\s -> (s ^. #emailAddress) ==. val_ email) + $ all_ ((^. #users) wikiMusicDatabase) + + case maybeUser of + Nothing -> pure . Left $ AuthError "User did not exist" + (Just usr) -> do + u <- withRoles env (mkUserM [] usr) + pure . Right . Just $ u + +fetchUserFromToken' :: (MonadIO m) => Env -> Text -> m (Either AuthQueryError (Maybe WikiMusicUser)) +fetchUserFromToken' env t = do + maybeUser <- liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runSelectReturningFirst . select $ do + filter_ (\s -> (s ^. #authToken) ==. val_ (Just t)) + $ all_ ((^. #users) wikiMusicDatabase) + + case maybeUser of + Nothing -> pure . Left $ AuthError "User did not exist" + (Just usr) -> do + u <- withRoles env (mkUserM [] usr) + pure . Right . Just $ u + +fetchUserRoles' :: (MonadIO m) => Env -> UUID -> m (Either AuthQueryError [UserRole]) +fetchUserRoles' env identifier = do + userRoles <- liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runSelectReturningList . select $ do + filter_ (\s -> (s ^. #userIdentifier) ==. (val_ . UserId $ UUID.toText identifier)) + $ all_ ((^. #userRoles) wikiMusicDatabase) + + let roles' = map (userRole . (^. #roleId)) userRoles + pure . Right $ roles' + +withRoles :: (MonadIO m) => Env -> WikiMusicUser -> m WikiMusicUser +withRoles env usr = do + roles' <- fetchUserRoles' env (usr ^. #identifier) + pure $ usr {roles = fromRight [] roles'} diff --git a/src/WikiMusic/Sqlite/GenreCommand.hs b/src/WikiMusic/Sqlite/GenreCommand.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Sqlite/GenreCommand.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Sqlite.GenreCommand () where + +import Data.Map qualified as Map +import Data.UUID qualified as UUID +import Database.Beam +import Database.Beam.Sqlite +import Relude +import WikiMusic.Beam.Database +import WikiMusic.Beam.Genre +import WikiMusic.Free.GenreCommand +import WikiMusic.Interaction.Model.Genre +import WikiMusic.Model.Artwork +import WikiMusic.Model.Comment +import WikiMusic.Model.Genre +import WikiMusic.Model.Opinion +import WikiMusic.Protolude + +insertGenres' :: (MonadIO m) => Env -> [Genre] -> m (Map UUID Genre) +insertGenres' env genres = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #genres) wikiMusicDatabase) + $ insertValues (map toPersistenceGenre genres) + + externalContents <- + mapM + ( \s -> do + newIdentifier <- liftIO nextRandom + pure $ toPersistenceGenreExternalContents s newIdentifier + ) + genres + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #genreExternalSources) wikiMusicDatabase) + $ insertValues externalContents + pure Map.empty + +insertGenreComments' :: (MonadIO m) => Env -> [GenreComment] -> m (Map UUID GenreComment) +insertGenreComments' env comments = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #genreComments) wikiMusicDatabase) + $ insertValues (map mkGenreCommentP comments) + pure Map.empty + +insertGenreExternalSources' :: (MonadIO m) => Env -> [GenreExternalSources] -> m (Map UUID GenreExternalSources) +insertGenreExternalSources' env externalSources = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #genreExternalSources) wikiMusicDatabase) + $ insertValues (map toPersistenceGenreExternalSources externalSources) + pure Map.empty + +insertGenreArtworks' :: (MonadIO m) => Env -> [GenreArtwork] -> m (Map UUID GenreArtwork) +insertGenreArtworks' env artworks = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #genreArtworks) wikiMusicDatabase) + $ insertValues (map mkGenreArtworkP artworks) + pure Map.empty + +upsertGenreOpinions' :: (MonadIO m) => Env -> [GenreOpinion] -> m (Map UUID GenreOpinion) +upsertGenreOpinions' env opinions = do + mapM_ + ( \o -> do + exOpinion <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + ( \s -> + (s ^. #genreIdentifier) + ==. val_ (GenreId $ UUID.toText $ o ^. #genreIdentifier) + &&. (s ^. #createdBy) + ==. val_ (UUID.toText $ o ^. #opinion % #createdBy) + ) + $ all_ ((^. #genreOpinions) wikiMusicDatabase) + case exOpinion of + Nothing -> + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #genreOpinions) wikiMusicDatabase) + $ insertValues [mkGenreOpinionP o] + Just oo -> do + let newO = + ( oo + { isLike = o ^. #opinion % #isLike, + isDislike = o ^. #opinion % #isDislike, + lastEditedAt = o ^. #opinion % #lastEditedAt + } + ) :: + GenreOpinion' + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runUpdate + $ save ((^. #genreOpinions) wikiMusicDatabase) newO + pure () + ) + opinions + + pure Map.empty + +uberDeleteGenres :: (MonadIO m) => Env -> [UUID] -> m (Either GenreCommandError ()) +uberDeleteGenres env identifiers = do + deleteArtworksOfGenresResult <- liftIO . exec @GenreCommand $ deleteArtworksOfGenres env identifiers + deleteOpinionsOfGenresResult <- liftIO . exec @GenreCommand $ deleteOpinionsOfGenres env identifiers + deleteCommentsOfGenresResult <- liftIO . exec @GenreCommand $ deleteCommentsOfGenres env identifiers + deleteGenreExternalSourcesResult <- liftIO . exec @GenreCommand $ deleteGenreExternalSources env identifiers + deleteGenresResult <- doDeleteGenres' env identifiers + pure + $ deleteArtworksOfGenresResult + <> deleteOpinionsOfGenresResult + <> deleteGenreExternalSourcesResult + <> deleteCommentsOfGenresResult + <> deleteGenresResult + +doDeleteGenres' :: (MonadIO m) => Env -> [UUID] -> m (Either GenreCommandError ()) +doDeleteGenres' env identifiers = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #genres) wikiMusicDatabase) + (\c -> (c ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + pure . Right $ () + +updateGenreArtworkOrder' :: (MonadIO m) => Env -> [GenreArtworkOrderUpdate] -> m (Either a ()) +updateGenreArtworkOrder' env orderUpdates = do + mapM_ + ( \ou -> do + art <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + (\s -> (s ^. #identifier) ==. val_ (UUID.toText $ ou ^. #identifier)) + $ all_ ((^. #genreArtworks) wikiMusicDatabase) + case art of + Nothing -> pure () + Just foundArt -> do + let a = foundArt {orderValue = fromIntegral $ ou ^. #orderValue} :: GenreArtwork' + liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runUpdate . save ((^. #genreArtworks) wikiMusicDatabase) $ a + ) + orderUpdates + pure . Right $ () + +updateGenres' :: (MonadIO m) => Env -> Map UUID (Genre, Maybe GenreDelta) -> m (Either Text ()) +updateGenres' env deltas = do + now <- liftIO getCurrentTime + mapM_ (save'' . toPersistenceGenre . doDelta now) (Map.elems deltas) + exUpdate <- liftIO $ exec @GenreCommand $ updateGenreExternalSources env deltas + pure $ exUpdate <> Right () + where + save'' x = liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runUpdate $ save ((^. #genres) wikiMusicDatabase) x + doDelta :: UTCTime -> (Genre, Maybe GenreDelta) -> Genre + doDelta now (x, xDelta') = + case xDelta' of + Nothing -> x + Just xDelta -> + x + { displayName = fromMaybe (x ^. #displayName) (xDelta ^. #displayName), + description = xDelta ^. #description, + lastEditedAt = Just now + } + +updateGenreExternalSources' :: (MonadIO m) => Env -> Map UUID (Genre, Maybe GenreDelta) -> m (Either Text ()) +updateGenreExternalSources' env deltas = do + now <- liftIO getCurrentTime + mapM_ + ( \(genre, xDelta) -> do + ex <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + (\s -> (s ^. #genreIdentifier) ==. val_ (GenreId $ UUID.toText $ genre ^. #identifier)) + $ all_ ((^. #genreExternalSources) wikiMusicDatabase) + case ex of + Nothing -> pure () + Just foundEx -> do + let a = + foundEx + { spotifyUrl = (^. #spotifyUrl) =<< xDelta, + wikipediaUrl = (^. #wikipediaUrl) =<< xDelta, + soundcloudUrl = (^. #soundcloudUrl) =<< xDelta, + youtubeUrl = (^. #youtubeUrl) =<< xDelta, + lastEditedAt = Just now + } :: + GenreExternalSources' + liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runUpdate . save ((^. #genreExternalSources) wikiMusicDatabase) $ a + ) + deltas + pure . Right $ () + +newGenreArtworkFromRequest' :: (MonadIO m) => UUID -> InsertGenreArtworksRequestItem -> m GenreArtwork +newGenreArtworkFromRequest' createdBy req = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ GenreArtwork + { genreIdentifier = req ^. #genreIdentifier, + artwork = + Artwork + { identifier = newUUID, + createdBy = createdBy, + contentUrl = req ^. #contentUrl, + contentCaption = req ^. #contentCaption, + createdAt = now, + lastEditedAt = Nothing, + visibilityStatus = 0, + approvedBy = Nothing, + orderValue = req ^. #orderValue + } + } + +newGenreOpinionFromRequest' :: (MonadIO m) => UUID -> UpsertGenreOpinionsRequestItem -> m GenreOpinion +newGenreOpinionFromRequest' createdBy req = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ GenreOpinion + { genreIdentifier = req ^. #genreIdentifier, + opinion = + Opinion + { identifier = newUUID, + createdBy = createdBy, + isLike = req ^. #isLike, + isDislike = not $ req ^. #isLike, + createdAt = now, + lastEditedAt = Nothing + } + } + +newGenreFromRequest' :: (MonadIO m) => UUID -> InsertGenresRequestItem -> m Genre +newGenreFromRequest' createdBy req = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ Genre + { identifier = newUUID, + parentIdentifier = Nothing, + displayName = req ^. #displayName, + createdBy = createdBy, + visibilityStatus = 0, + approvedBy = Nothing, + createdAt = now, + lastEditedAt = Nothing, + artworks = fromList [], + comments = [], + opinions = fromList [], + spotifyUrl = req ^. #spotifyUrl, + youtubeUrl = req ^. #youtubeUrl, + soundcloudUrl = req ^. #soundcloudUrl, + wikipediaUrl = req ^. #wikipediaUrl, + viewCount = 0, + description = req ^. #description + } + +newGenreCommentFromRequest' :: (MonadIO m) => UUID -> InsertGenreCommentsRequestItem -> m GenreComment +newGenreCommentFromRequest' createdBy x = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ GenreComment + { genreIdentifier = x ^. #genreIdentifier, + comment = + Comment + { identifier = newUUID, + parentIdentifier = x ^. #parentIdentifier, + createdBy = createdBy, + visibilityStatus = 0, + contents = x ^. #contents, + approvedBy = Nothing, + createdAt = now, + lastEditedAt = Nothing + } + } + +deleteGenreComments' :: (MonadIO m) => Env -> [UUID] -> m (Either GenreCommandError ()) +deleteGenreComments' env identifiers = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #genreComments) wikiMusicDatabase) + (\c -> (c ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + pure . Right $ () + +deleteGenreArtworks' :: (MonadIO m) => Env -> [UUID] -> m (Either GenreCommandError ()) +deleteGenreArtworks' env identifiers = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #genreArtworks) wikiMusicDatabase) + (\c -> (c ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + pure . Right $ () + +deleteGenreOpinions' :: (MonadIO m) => Env -> [UUID] -> m (Either GenreCommandError ()) +deleteGenreOpinions' env identifiers = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #genreOpinions) wikiMusicDatabase) + (\c -> (c ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + pure . Right $ () + +incrementViewsByOne' :: (MonadIO m) => Env -> [UUID] -> m (Either GenreCommandError ()) +incrementViewsByOne' env identifiers = do + mapM_ doUpdate identifiers + pure $ Right () + where + doUpdate x = do + ex <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + (\s -> (s ^. #identifier) ==. (val_ . UUID.toText $ x)) + $ all_ ((^. #genres) wikiMusicDatabase) + case ex of + Nothing -> pure () + Just foundEx -> do + let a = + foundEx + { viewCount = (foundEx ^. #viewCount) + 1 + } :: + Genre' + liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runUpdate . save ((^. #genres) wikiMusicDatabase) $ a + +instance Exec GenreCommand where + execAlgebra (IncrementViewsByOne env identifiers next) = + next =<< incrementViewsByOne' env identifiers + execAlgebra (InsertGenres env genres next) = + next =<< insertGenres' env genres + execAlgebra (InsertGenreComments env comments next) = + next =<< insertGenreComments' env comments + execAlgebra (InsertGenreExternalSources env externalSources next) = + next =<< insertGenreExternalSources' env externalSources + execAlgebra (InsertGenreArtworks env artworks next) = + next =<< insertGenreArtworks' env artworks + execAlgebra (UpsertGenreOpinions env opinions next) = + next =<< upsertGenreOpinions' env opinions + execAlgebra (DeleteGenres env identifiers next) = + next =<< uberDeleteGenres env identifiers + execAlgebra (DeleteGenreComments env identifiers next) = + next =<< deleteGenreComments' env identifiers + execAlgebra (DeleteGenreArtworks env identifiers next) = + next =<< deleteGenreArtworks' env identifiers + execAlgebra (DeleteGenreOpinions env identifiers next) = + next =<< deleteGenreOpinions' env identifiers + execAlgebra (DeleteCommentsOfGenres env identifiers next) = do + let ids = map UUID.toText identifiers + + mapM_ + ( \y -> + runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete ((^. #genreComments) wikiMusicDatabase) (\c -> c ^. #genreIdentifier ==. (val_ . GenreId $ y)) + ) + ids + + next $ Right () + execAlgebra (DeleteGenreExternalSources env identifiers next) = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #genreExternalSources) wikiMusicDatabase) + (\c -> (c ^. #genreIdentifier) `in_` map (val_ . GenreId . UUID.toText) identifiers) + next . Right $ () + execAlgebra (DeleteArtworksOfGenres env identifiers next) = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #genreArtworks) wikiMusicDatabase) + (\c -> (c ^. #genreIdentifier) `in_` map (val_ . GenreId . UUID.toText) identifiers) + next . Right $ () + execAlgebra (DeleteOpinionsOfGenres env identifiers next) = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #genreOpinions) wikiMusicDatabase) + (\c -> (c ^. #genreIdentifier) `in_` map (val_ . GenreId . UUID.toText) identifiers) + next . Right $ () + execAlgebra (UpdateGenreArtworkOrder env orderUpdates next) = + next =<< updateGenreArtworkOrder' env orderUpdates + execAlgebra (UpdateGenres env deltas next) = + next =<< updateGenres' env deltas + execAlgebra (UpdateGenreExternalSources env deltas next) = + next =<< updateGenreExternalSources' env deltas + execAlgebra (NewGenreFromRequest createdBy req next) = + next =<< newGenreFromRequest' createdBy req + execAlgebra (NewGenreCommentFromRequest createdBy req next) = + next =<< newGenreCommentFromRequest' createdBy req + execAlgebra (NewGenreOpinionFromRequest createdBy req next) = + next =<< newGenreOpinionFromRequest' createdBy req + execAlgebra (NewGenreArtworkFromRequest createdBy req next) = + next =<< newGenreArtworkFromRequest' createdBy req diff --git a/src/WikiMusic/Sqlite/GenreQuery.hs b/src/WikiMusic/Sqlite/GenreQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Sqlite/GenreQuery.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Sqlite.GenreQuery () where + +import Data.Map (elems, keys) +import Data.Map qualified as Map +import Data.UUID qualified as UUID +import Database.Beam +import Database.Beam.Sqlite +import WikiMusic.Beam.Database +import WikiMusic.Beam.Genre +import WikiMusic.Beam.Util +import WikiMusic.Free.GenreQuery +import WikiMusic.Model.Genre +import WikiMusic.Model.Other +import WikiMusic.Model.Thread as CommentThread +import WikiMusic.Protolude + +instance Exec GenreQuery where + execAlgebra (FetchGenres env sortOrder limit offset next) = + next =<< fetchGenres' env sortOrder limit offset + execAlgebra (FetchGenresByUUID env sortOrder identifiers next) = + next =<< fetchGenresByUUID' env sortOrder identifiers + execAlgebra (EnrichedGenreResponse env genreMap enrichGenreParams next) = + next =<< enrichedGenreResponse' env genreMap enrichGenreParams + execAlgebra (FetchGenreComments env identifiers next) = + next =<< fetchGenreComments' env identifiers + execAlgebra (FetchGenreOpinions env identifiers next) = + next =<< fetchGenreOpinions' env identifiers + execAlgebra (SearchGenres env searchInput sortOrder limit offset next) = + next =<< searchGenres' env searchInput sortOrder limit offset + execAlgebra (FetchGenreArtworks env identifiers next) = + next =<< fetchGenreArtworks' env identifiers + +mkOrderBy AscCreatedAt = orderBy_ (asc_ . (^. #createdAt)) +mkOrderBy DescCreatedAt = orderBy_ (desc_ . (^. #createdAt)) +mkOrderBy AscDisplayName = orderBy_ (asc_ . (^. #displayName)) +mkOrderBy DescDisplayName = orderBy_ (desc_ . (^. #displayName)) +mkOrderBy AscLastEditedAt = orderBy_ (asc_ . (^. #lastEditedAt)) +mkOrderBy DescLastEditedAt = orderBy_ (desc_ . (^. #lastEditedAt)) + +-- | Fetch genres from storage, according to a sort order, limit and offset +fetchGenres' :: (MonadIO m) => Env -> GenreSortOrder -> Limit -> Offset -> m (Map UUID Genre, [UUID]) +fetchGenres' env sortOrder (Limit limit) (Offset offset) = do + genres <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningList + . select + . limit_ (fromIntegral limit) + . offset_ (fromIntegral offset) + . mkOrderBy sortOrder + $ all_ ((^. #genres) wikiMusicDatabase) + filledGenres env genres + +-- | Fetch genres by UUID from storage, according to a sort order +fetchGenresByUUID' :: (MonadIO m) => Env -> GenreSortOrder -> [UUID] -> m (Map UUID Genre, [UUID]) +fetchGenresByUUID' env sortOrder identifiers = do + genres <- + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runSelectReturningList + . select + . filter_ (\s -> (s ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + . mkOrderBy sortOrder + $ all_ ((^. #genres) wikiMusicDatabase) + filledGenres env genres + +-- | Fetch genre artworks from storage +fetchGenreArtworks' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID GenreArtwork) +fetchGenreArtworks' env identifiers = do + artworks <- liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runSelectReturningList + . select + . orderBy_ (asc_ . (^. #orderValue)) + $ do + songs <- + filter_ (\s -> (s ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + $ all_ ((^. #genres) wikiMusicDatabase) + oneToMany_ ((^. #genreArtworks) wikiMusicDatabase) (^. #genreIdentifier) songs + pure . Map.fromList . map toGenreArtwork $ artworks + +-- | Enrich genres with related information, according to enrichment parameters +enrichedGenreResponse' :: (MonadIO m) => Env -> Map UUID Genre -> EnrichGenreParams -> m (Map UUID Genre) +enrichedGenreResponse' env genreMap enrichGenreParams = do + artworkMap <- liftIO getArtwork + opinionMap <- liftIO getOpinion + commentMap <- liftIO getComment + + let enrichedGenres = + mapMap + ( \genre -> do + let rawCommentMap = Map.filter (matchesGenreIdentifier genre) commentMap + allComments = elems rawCommentMap + commentThreads = map renderThread $ mkThreads allComments isChildOf' (^. #comment % #parentIdentifier) + + genre + { comments = commentThreads, + artworks = filterMap (matchesGenreIdentifier genre) artworkMap, + opinions = filterMap (matchesGenreIdentifier genre) opinionMap + } + ) + genreMap + + pure enrichedGenres + where + matchesGenreIdentifier genre = (== genre ^. #identifier) . (^. #genreIdentifier) + isChildOf' p x = Just (p ^. #comment % #identifier) == x ^. #comment % #parentIdentifier + genreIds = keys genreMap + getComment = + if enrichGenreParams ^. #includeComments + then exec @GenreQuery $ fetchGenreComments env genreIds + else pure $ fromList [] + getArtwork = + if enrichGenreParams ^. #includeArtworks + then exec @GenreQuery $ fetchGenreArtworks env genreIds + else pure $ fromList [] + getOpinion = + if enrichGenreParams ^. #includeOpinions + then exec @GenreQuery $ fetchGenreOpinions env genreIds + else pure $ fromList [] + +-- | Fetch genre comments from storage +fetchGenreComments' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID GenreComment) +fetchGenreComments' env identifiers = do + comments <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningList $ select $ do + genres <- + filter_ (\s -> (s ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + $ all_ ((^. #genres) wikiMusicDatabase) + oneToMany_ ((^. #genreComments) wikiMusicDatabase) (^. #genreIdentifier) genres + + pure . Map.fromList . map toGenreComment $ comments + +-- | Search genres by keywords from storage, according to a sort order, limit and offset +searchGenres' :: (MonadIO m) => Env -> SearchInput -> GenreSortOrder -> Limit -> Offset -> m (Map UUID Genre, [UUID]) +searchGenres' env searchInput sortOrder (Limit limit) (Offset offset) = do + genres <- + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runSelectReturningList + . select + . filter_ (\s -> (s ^. #displayName) `like_` val_ ("%" <> searchInput ^. #value <> "%")) + . limit_ (fromIntegral limit) + . offset_ (fromIntegral offset) + . mkOrderBy sortOrder + $ all_ ((^. #genres) wikiMusicDatabase) + filledGenres env genres + +-- | Fetch genre opinions from storage +fetchGenreOpinions' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID GenreOpinion) +fetchGenreOpinions' env identifiers = do + opinions <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningList $ select $ do + genres <- + filter_ (\s -> (s ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + $ all_ ((^. #genres) wikiMusicDatabase) + oneToMany_ ((^. #genreOpinions) wikiMusicDatabase) (^. #genreIdentifier) genres + + pure . Map.fromList . map toGenreOpinion $ opinions + +filledGenres :: (MonadIO m) => Env -> [Genre'] -> m (Map UUID Genre, [UUID]) +filledGenres env genres = do + externalSources <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningList + . select + . filter_ (\s -> (s ^. #genreIdentifier) `in_` map (val_ . (\x -> GenreId $ x ^. #identifier)) genres) + $ all_ ((^. #genreExternalSources) wikiMusicDatabase) + let filledGenres' = map (withExternalSources externalSources) genres + pure (Map.fromList filledGenres', map (textToUUID . (^. #identifier)) genres) + where + withExternalSources externalSources genre = + let maybeFoundExternal = + fmap + (fromPersistenceExternalSource . head) + (nonEmpty $ filter (\x -> fromGenrePk (x ^. #genreIdentifier) == (genre ^. #identifier)) externalSources) + in toGenre genre (fromMaybe emptyExternalSources maybeFoundExternal) diff --git a/src/WikiMusic/Sqlite/SongCommand.hs b/src/WikiMusic/Sqlite/SongCommand.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Sqlite/SongCommand.hs @@ -0,0 +1,574 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Sqlite.SongCommand () where + +import Data.Map qualified as Map +import Data.UUID qualified as UUID +import Database.Beam +import Database.Beam.Sqlite +import Relude +import WikiMusic.Beam.Artist +import WikiMusic.Beam.Database +import WikiMusic.Beam.Relations +import WikiMusic.Beam.Song +import WikiMusic.Free.SongCommand +import WikiMusic.Interaction.Model.Song +import WikiMusic.Model.Artwork +import WikiMusic.Model.Comment +import WikiMusic.Model.Opinion +import WikiMusic.Model.Song +import WikiMusic.Protolude + +insertArtistsOfSongs' :: (MonadIO m) => Env -> [ArtistOfSong] -> m (Map UUID ArtistOfSong) +insertArtistsOfSongs' env items = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #songArtists) wikiMusicDatabase) + $ insertValues (map mkSongArtistP items) + pure Map.empty + +insertSongs' :: (MonadIO m) => Env -> [Song] -> m (Map UUID Song) +insertSongs' env songs = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #songs) wikiMusicDatabase) + $ insertValues (map toPersistenceSong songs) + + externalContents <- + mapM + ( \s -> do + newIdentifier <- liftIO nextRandom + pure $ toPersistenceSongExternalContents s newIdentifier + ) + songs + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #songExternalSources) wikiMusicDatabase) + $ insertValues externalContents + pure Map.empty + +insertSongComments' :: (MonadIO m) => Env -> [SongComment] -> m (Either SongCommandError ()) +insertSongComments' env comments = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #songComments) wikiMusicDatabase) + $ insertValues (map toPersistenceSongComment comments) + pure . Right $ () + +insertSongExternalSources' :: (MonadIO m) => Env -> [SongExternalSources] -> m (Map UUID SongExternalSources) +insertSongExternalSources' env externalSources = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #songExternalSources) wikiMusicDatabase) + $ insertValues (map toPersistenceSongExternalSources externalSources) + pure Map.empty + +insertSongArtworks' :: (MonadIO m) => Env -> [SongArtwork] -> m (Map UUID SongArtwork) +insertSongArtworks' env artworks = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #songArtworks) wikiMusicDatabase) + $ insertValues (map mkSongArtworkP artworks) + pure Map.empty + +upsertSongOpinions' :: (MonadIO m) => Env -> [SongOpinion] -> m (Map UUID SongOpinion) +upsertSongOpinions' env opinions = do + mapM_ + ( \o -> do + exOpinion <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + ( \s -> + (s ^. #songIdentifier) + ==. val_ (SongId $ UUID.toText $ o ^. #songIdentifier) + &&. (s ^. #createdBy) + ==. val_ (UUID.toText $ o ^. #opinion % #createdBy) + ) + $ all_ ((^. #songOpinions) wikiMusicDatabase) + case exOpinion of + Nothing -> + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #songOpinions) wikiMusicDatabase) + $ insertValues [mkSongOpinionP o] + Just oo -> do + let newO = + ( oo + { isLike = o ^. #opinion % #isLike, + isDislike = o ^. #opinion % #isDislike, + lastEditedAt = o ^. #opinion % #lastEditedAt + } + ) :: + SongOpinion' + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runUpdate + $ save ((^. #songOpinions) wikiMusicDatabase) newO + pure () + ) + opinions + + pure Map.empty + +uberDeleteSongs' :: (MonadIO m) => Env -> [UUID] -> m (Either SongCommandError ()) +uberDeleteSongs' env identifiers = + do + deleteArtworksOfSongsResult <- liftIO . exec @SongCommand $ deleteArtworksOfSongs env identifiers + deleteOpinionsOfSongsResult <- liftIO . exec @SongCommand $ deleteOpinionsOfSongs env identifiers + deleteCommentsOfSongsResult <- liftIO . exec @SongCommand $ deleteCommentsOfSongs env identifiers + deleteSongExternalSourcesResult <- liftIO . exec @SongCommand $ deleteSongExternalSources env identifiers + deleteSongsResult <- doDeleteSongs' env identifiers + deleteArtistsOfSongResult <- liftIO . exec @SongCommand $ deleteArtistsOfSongs env identifiers + deleteContentsOfSongResult <- liftIO . exec @SongCommand $ deleteContentsOfSongs env identifiers + pure + $ deleteArtworksOfSongsResult + <> deleteOpinionsOfSongsResult + <> deleteSongExternalSourcesResult + <> deleteCommentsOfSongsResult + <> deleteArtistsOfSongResult + <> deleteContentsOfSongResult + <> deleteSongsResult + +doDeleteSongs' :: (MonadIO m) => Env -> [UUID] -> m (Either SongCommandError ()) +doDeleteSongs' env identifiers = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #songs) wikiMusicDatabase) + (\c -> (c ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + pure . Right $ () + +updateSongArtworkOrder' :: (MonadIO m) => Env -> [SongArtworkOrderUpdate] -> m (Either a ()) +updateSongArtworkOrder' env orderUpdates = do + mapM_ + ( \ou -> do + art <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + (\s -> (s ^. #identifier) ==. val_ (UUID.toText $ ou ^. #identifier)) + $ all_ ((^. #songArtworks) wikiMusicDatabase) + case art of + Nothing -> pure () + Just foundArt -> do + let a = foundArt {orderValue = fromIntegral $ ou ^. #orderValue} :: SongArtwork' + liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runUpdate . save ((^. #songArtworks) wikiMusicDatabase) $ a + ) + orderUpdates + pure . Right $ () + +updateSongs' :: (MonadIO m) => Env -> Map UUID (Song, Maybe SongDelta) -> m (Either Text ()) +updateSongs' env deltas = do + now <- liftIO getCurrentTime + mapM_ (save'' . toPersistenceSong . doDelta now) (Map.elems deltas) + exUpdate <- liftIO $ exec @SongCommand $ updateSongExternalSources env deltas + pure $ exUpdate <> Right () + where + save'' x = + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runUpdate + $ save ((^. #songs) wikiMusicDatabase) x + doDelta :: UTCTime -> (Song, Maybe SongDelta) -> Song + doDelta now (x, xDelta') = + case xDelta' of + Nothing -> x + Just xDelta -> + x + { musicKey = xDelta ^. #musicKey, + musicTuning = xDelta ^. #musicTuning, + musicCreationDate = xDelta ^. #musicCreationDate, + albumName = xDelta ^. #albumName, + albumInfoLink = xDelta ^. #albumInfoLink, + displayName = fromMaybe (x ^. #displayName) (xDelta ^. #displayName), + description = xDelta ^. #description, + lastEditedAt = Just now + } + +updateSongExternalSources' :: (MonadIO m) => Env -> Map UUID (Song, Maybe SongDelta) -> m (Either Text ()) +updateSongExternalSources' env deltas = do + now <- liftIO getCurrentTime + mapM_ + ( \(song, xDelta) -> do + ex <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + (\s -> (s ^. #songIdentifier) ==. val_ (SongId $ UUID.toText $ song ^. #identifier)) + $ all_ ((^. #songExternalSources) wikiMusicDatabase) + case ex of + Nothing -> pure () + Just foundEx -> do + let a = + foundEx + { spotifyUrl = (^. #spotifyUrl) =<< xDelta, + wikipediaUrl = (^. #wikipediaUrl) =<< xDelta, + soundcloudUrl = (^. #soundcloudUrl) =<< xDelta, + youtubeUrl = (^. #youtubeUrl) =<< xDelta, + lastEditedAt = Just now + } :: + SongExternalSources' + liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runUpdate . save ((^. #songExternalSources) wikiMusicDatabase) $ a + ) + deltas + pure . Right $ () + +newSongArtworkFromRequest' :: (MonadIO m) => UUID -> InsertSongArtworksRequestItem -> m SongArtwork +newSongArtworkFromRequest' createdBy req = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ SongArtwork + { songIdentifier = req ^. #songIdentifier, + artwork = + Artwork + { identifier = newUUID, + createdBy = createdBy, + contentUrl = req ^. #contentUrl, + contentCaption = req ^. #contentCaption, + createdAt = now, + lastEditedAt = Nothing, + visibilityStatus = 0, + approvedBy = Nothing, + orderValue = req ^. #orderValue + } + } + +newSongOpinionFromRequest' :: (MonadIO m) => UUID -> UpsertSongOpinionsRequestItem -> m SongOpinion +newSongOpinionFromRequest' createdBy req = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ SongOpinion + { songIdentifier = req ^. #songIdentifier, + opinion = + Opinion + { identifier = newUUID, + createdBy = createdBy, + isLike = req ^. #isLike, + isDislike = not $ req ^. #isLike, + createdAt = now, + lastEditedAt = Nothing + } + } + +updateSongContents' :: (MonadIO m) => Env -> [SongContentDelta] -> m (Either Text ()) +updateSongContents' env songContentDeltas = do + songContentsP <- + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runSelectReturningList + . select + . filter_ (\s -> (s ^. #identifier) `in_` map (val_ . (\z -> UUID.toText $ z ^. #identifier)) songContentDeltas) + $ all_ ((^. #songContents) wikiMusicDatabase) + + _ <- liftIO . putStrLn . Relude.show $ songContentDeltas + now <- liftIO getCurrentTime + let updatedP = + map + ( \songContentDelta -> do + fmap (updatedSongContent songContentDelta now . head) + $ nonEmpty + $ filter + ( \songContentP -> songContentP ^. #identifier == UUID.toText (songContentDelta ^. #identifier) + ) + songContentsP + ) + songContentDeltas + mapM_ + ( liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runUpdate + . save ((^. #songContents) wikiMusicDatabase) + ) + (catMaybes updatedP) + pure . Right $ () + +updatedSongContent :: SongContentDelta -> UTCTime -> SongContents' -> SongContents' +updatedSongContent songContentDelta now x = + x + { versionName = songContentDelta ^. #versionName, + instrumentType = fromMaybe "" (songContentDelta ^. #instrumentType), + asciiLegend = songContentDelta ^. #asciiLegend, + asciiContents = songContentDelta ^. #asciiContents, + pdfContents = songContentDelta ^. #pdfContents, + guitarProContents = songContentDelta ^. #guitarProContents, + lastEditedAt = Just now + } :: + SongContents' + +deleteArtistOfSong' :: (MonadIO m) => Env -> (UUID, UUID) -> m (Either SongCommandError ()) +deleteArtistOfSong' env (songId, artistId) = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #songArtists) wikiMusicDatabase) + (\c -> (c ^. #songIdentifier) ==. (val_ . SongId . UUID.toText $ songId) &&. (c ^. #artistIdentifier) ==. (val_ . ArtistId . UUID.toText $ artistId)) + + pure . Right $ () + +newSongCommentFromRequest' :: (MonadIO m) => UUID -> InsertSongCommentsRequestItem -> m SongComment +newSongCommentFromRequest' createdBy x = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ SongComment + { songIdentifier = x ^. #songIdentifier, + comment = + Comment + { identifier = newUUID, + parentIdentifier = x ^. #parentIdentifier, + createdBy = createdBy, + visibilityStatus = 0, + contents = x ^. #contents, + approvedBy = Nothing, + createdAt = now, + lastEditedAt = Nothing + } + } + +insertSongContents' :: (MonadIO m) => Env -> [SongContent] -> m (Map UUID SongContent) +insertSongContents' env contents = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #songContents) wikiMusicDatabase) + $ insertValues (map mkSongContentsP contents) + pure Map.empty + +newSongFromRequest' :: (MonadIO m) => UUID -> InsertSongsRequestItem -> m Song +newSongFromRequest' createdBy song = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ Song + { identifier = newUUID, + displayName = song ^. #displayName, + musicKey = song ^. #musicKey, + musicTuning = song ^. #musicTuning, + musicCreationDate = song ^. #musicCreationDate, + albumName = song ^. #albumName, + albumInfoLink = song ^. #albumInfoLink, + createdBy = createdBy, + visibilityStatus = 0, + approvedBy = Nothing, + createdAt = now, + lastEditedAt = Nothing, + artworks = Map.empty, + comments = [], + opinions = Map.empty, + contents = Map.empty, + spotifyUrl = song ^. #spotifyUrl, + youtubeUrl = song ^. #youtubeUrl, + soundcloudUrl = song ^. #soundcloudUrl, + wikipediaUrl = song ^. #wikipediaUrl, + artists = Map.empty, + viewCount = 0, + description = song ^. #description + } + +newArtistOfSongFromRequest' :: (MonadIO m) => UUID -> InsertArtistsOfSongsRequestItem -> m ArtistOfSong +newArtistOfSongFromRequest' createdBy x = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ ArtistOfSong + { identifier = newUUID, + songIdentifier = x ^. #songIdentifier, + artistIdentifier = x ^. #artistIdentifier, + createdAt = now, + createdBy = createdBy + } + +newSongContentFromRequest' :: (MonadIO m) => UUID -> InsertSongContentsRequestItem -> m SongContent +newSongContentFromRequest' createdBy x = do + newUUID <- liftIO nextRandom + now <- liftIO getCurrentTime + pure + $ SongContent + { identifier = newUUID, + songIdentifier = x ^. #songIdentifier, + versionName = x ^. #versionName, + visibilityStatus = 0, + approvedBy = Nothing, + instrumentType = x ^. #instrumentType, + asciiLegend = x ^. #asciiLegend, + asciiContents = x ^. #asciiContents, + pdfContents = x ^. #pdfContents, + guitarProContents = x ^. #guitarProContents, + createdAt = now, + createdBy = createdBy, + lastEditedAt = Nothing + } + +deleteSongComments' :: (MonadIO m) => Env -> [UUID] -> m (Either SongCommandError ()) +deleteSongComments' env identifiers = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #songComments) wikiMusicDatabase) + (\c -> (c ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + pure . Right $ () + +deleteSongArtworks' :: (MonadIO m) => Env -> [UUID] -> m (Either SongCommandError ()) +deleteSongArtworks' env identifiers = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #songArtworks) wikiMusicDatabase) + (\c -> (c ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + pure . Right $ () + +deleteSongOpinions' :: (MonadIO m) => Env -> [UUID] -> m (Either SongCommandError ()) +deleteSongOpinions' env identifiers = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #songOpinions) wikiMusicDatabase) + (\c -> (c ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + pure . Right $ () + +incrementViewsByOne' :: (MonadIO m) => Env -> [UUID] -> m (Either SongCommandError ()) +incrementViewsByOne' env identifiers = do + mapM_ doUpdate identifiers + pure $ Right () + where + doUpdate x = do + ex <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + (\s -> (s ^. #identifier) ==. (val_ . UUID.toText $ x)) + $ all_ ((^. #songs) wikiMusicDatabase) + case ex of + Nothing -> pure () + Just foundEx -> do + let a = + foundEx + { viewCount = (foundEx ^. #viewCount) + 1 + } :: + Song' + liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runUpdate . save ((^. #songs) wikiMusicDatabase) $ a + +instance Exec SongCommand where + execAlgebra (IncrementViewsByOne env identifiers next) = + next =<< incrementViewsByOne' env identifiers + execAlgebra (InsertSongs env songs next) = + next =<< insertSongs' env songs + execAlgebra (InsertSongComments env comments next) = + next =<< insertSongComments' env comments + execAlgebra (InsertSongExternalSources env externalSources next) = + next =<< insertSongExternalSources' env externalSources + execAlgebra (InsertSongArtworks env artworks next) = + next =<< insertSongArtworks' env artworks + execAlgebra (UpsertSongOpinions env opinions next) = + next =<< upsertSongOpinions' env opinions + execAlgebra (DeleteSongs env identifiers next) = + next =<< uberDeleteSongs' env identifiers + execAlgebra (DeleteSongComments env identifiers next) = do + next =<< deleteSongComments' env identifiers + execAlgebra (DeleteSongArtworks env identifiers next) = do + next =<< deleteSongArtworks' env identifiers + execAlgebra (DeleteSongOpinions env identifiers next) = do + next =<< deleteSongOpinions' env identifiers + execAlgebra (DeleteCommentsOfSongs env identifiers next) = do + let ids = map UUID.toText identifiers + + mapM_ + ( \y -> + runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete ((^. #songComments) wikiMusicDatabase) (\c -> c ^. #songIdentifier ==. (val_ . SongId $ y)) + ) + ids + + next $ Right () + execAlgebra (DeleteSongExternalSources env identifiers next) = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #songExternalSources) wikiMusicDatabase) + (\c -> (c ^. #songIdentifier) `in_` map (val_ . SongId . UUID.toText) identifiers) + next . Right $ () + execAlgebra (DeleteArtworksOfSongs env identifiers next) = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #songArtworks) wikiMusicDatabase) + (\c -> (c ^. #songIdentifier) `in_` map (val_ . SongId . UUID.toText) identifiers) + next . Right $ () + execAlgebra (DeleteOpinionsOfSongs env identifiers next) = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #songOpinions) wikiMusicDatabase) + (\c -> (c ^. #songIdentifier) `in_` map (val_ . SongId . UUID.toText) identifiers) + next . Right $ () + execAlgebra (UpdateSongArtworkOrder env orderUpdates next) = + next =<< updateSongArtworkOrder' env orderUpdates + execAlgebra (UpdateSongs env deltas next) = + next =<< updateSongs' env deltas + execAlgebra (UpdateSongContents env deltas next) = + next =<< updateSongContents' env deltas + execAlgebra (UpdateSongExternalSources env deltas next) = + next =<< updateSongExternalSources' env deltas + execAlgebra (NewSongCommentFromRequest createdBy req next) = + next =<< newSongCommentFromRequest' createdBy req + execAlgebra (NewSongOpinionFromRequest createdBy req next) = + next =<< newSongOpinionFromRequest' createdBy req + execAlgebra (NewSongArtworkFromRequest createdBy req next) = + next =<< newSongArtworkFromRequest' createdBy req + execAlgebra (InsertSongContents env contents next) = + next =<< insertSongContents' env contents + execAlgebra (InsertArtistsOfSongs env items next) = + next =<< insertArtistsOfSongs' env items + execAlgebra (DeleteArtistsOfSongs env identifiers next) = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #songArtists) wikiMusicDatabase) + (\c -> (c ^. #songIdentifier) `in_` map (val_ . SongId . UUID.toText) identifiers) + + next . Right $ () + execAlgebra (DeleteArtistOfSong env identifiers next) = + next =<< deleteArtistOfSong' env identifiers + execAlgebra (NewSongFromRequest createdBy song next) = + next =<< newSongFromRequest' createdBy song + execAlgebra (NewArtistOfSongFromRequest createdBy x next) = + next =<< newArtistOfSongFromRequest' createdBy x + execAlgebra (NewSongContentFromRequest createdBy x next) = + next =<< newSongContentFromRequest' createdBy x + execAlgebra (DeleteContentsOfSongs env identifiers next) = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #songContents) wikiMusicDatabase) + (\c -> (c ^. #songIdentifier) `in_` map (val_ . SongId . UUID.toText) identifiers) + next . Right $ () + execAlgebra (DeleteSongContents env identifiers next) = do + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runDelete + $ delete + ((^. #songContents) wikiMusicDatabase) + (\c -> (c ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + next . Right $ () diff --git a/src/WikiMusic/Sqlite/SongQuery.hs b/src/WikiMusic/Sqlite/SongQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Sqlite/SongQuery.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Sqlite.SongQuery () where + +import Data.Map (elems, keys) +import Data.Map qualified as Map +import Data.UUID +import Data.UUID qualified as UUID +import Database.Beam +import Database.Beam.Sqlite +import Free.AlaCarte +import Optics +import Relude +import WikiMusic.Beam.Artist +import WikiMusic.Beam.Database +import WikiMusic.Beam.Song +import WikiMusic.Beam.Util +import WikiMusic.Free.SongQuery +import WikiMusic.Model.Env +import WikiMusic.Model.Other +import WikiMusic.Model.Song +import WikiMusic.Model.Thread as CommentThread + +instance Exec SongQuery where + execAlgebra (FetchSongs env sortOrder limit offset next) = + next =<< fetchSongs' env sortOrder limit offset + execAlgebra (FetchSongsByUUID env sortOrder identifiers next) = + next =<< fetchSongsByUUID' env sortOrder identifiers + execAlgebra (EnrichedSongResponse env songMap enrichSongParams next) = next =<< enrichedSongResponse' env songMap enrichSongParams + execAlgebra (FetchSongComments env identifiers next) = + next =<< fetchSongComments' env identifiers + execAlgebra (FetchSongOpinions env identifiers next) = + next =<< fetchSongOpinions' env identifiers + execAlgebra (FetchSongArtworks env identifiers next) = + next =<< fetchSongArtworks' env identifiers + execAlgebra (FetchSongArtists env identifiers next) = next =<< fetchSongArtists' env identifiers + execAlgebra (SearchSongs env searchInput sortOrder limit offset next) = next =<< searchSongs' env searchInput sortOrder limit offset + execAlgebra (FetchSongContents env identifiers next) = + next =<< fetchSongContents' env identifiers + +mkOrderBy AscCreatedAt = orderBy_ (asc_ . (^. #createdAt)) +mkOrderBy DescCreatedAt = orderBy_ (desc_ . (^. #createdAt)) +mkOrderBy AscDisplayName = orderBy_ (asc_ . (^. #displayName)) +mkOrderBy DescDisplayName = orderBy_ (desc_ . (^. #displayName)) +mkOrderBy AscLastEditedAt = orderBy_ (asc_ . (^. #lastEditedAt)) +mkOrderBy DescLastEditedAt = orderBy_ (desc_ . (^. #lastEditedAt)) + +fetchSongs' :: (MonadIO m) => Env -> SongSortOrder -> Limit -> Offset -> m (Map UUID Song, [UUID]) +fetchSongs' env sortOrder (Limit limit) (Offset offset) = do + songs <- + liftIO + $ runBeamSqliteDebug putStrLn (env ^. #conn) + $ runSelectReturningList + . select + . limit_ (toInteger limit) + . offset_ (toInteger offset) + . mkOrderBy sortOrder + $ all_ ((^. #songs) wikiMusicDatabase) + + filledSongs env songs + +fetchSongsByUUID' :: (MonadIO m) => Env -> SongSortOrder -> [UUID] -> m (Map UUID Song, [UUID]) +fetchSongsByUUID' env sortOrder identifiers = do + songs <- + liftIO + . runBeamSqlite (env ^. #conn) + . runSelectReturningList + . select + . filter_ (\s -> (s ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + . mkOrderBy sortOrder + $ all_ ((^. #songs) wikiMusicDatabase) + filledSongs env songs + +-- | Fetch song artworks from storage +fetchSongArtworks' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID SongArtwork) +fetchSongArtworks' env identifiers = do + artworks <- liftIO + . runBeamSqlite (env ^. #conn) + . runSelectReturningList + . select + . orderBy_ (asc_ . (^. #orderValue)) + $ do + songs <- + filter_ (\s -> (s ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + $ all_ ((^. #songs) wikiMusicDatabase) + oneToMany_ ((^. #songArtworks) wikiMusicDatabase) (^. #songIdentifier) songs + pure . Map.fromList . map toSongArtwork $ artworks + +-- | Fetch song comments from storage +fetchSongComments' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID SongComment) +fetchSongComments' env identifiers = do + comments <- liftIO $ runBeamSqlite (env ^. #conn) $ runSelectReturningList $ select $ do + songs <- + filter_ (\s -> (s ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + $ all_ ((^. #songs) wikiMusicDatabase) + oneToMany_ ((^. #songComments) wikiMusicDatabase) (^. #songIdentifier) songs + + pure . Map.fromList . map toSongComment $ comments + +-- | Fetch song opinions from storage +fetchSongOpinions' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID SongOpinion) +fetchSongOpinions' env identifiers = do + opinions <- liftIO $ runBeamSqlite (env ^. #conn) $ runSelectReturningList $ select $ do + songs <- + filter_ (\s -> (s ^. #identifier) `in_` map (val_ . UUID.toText) identifiers) + $ all_ ((^. #songs) wikiMusicDatabase) + oneToMany_ ((^. #songOpinions) wikiMusicDatabase) (^. #songIdentifier) songs + + pure . Map.fromList . map toSongOpinion $ opinions + +enrichedSongResponse' :: (MonadIO m) => Env -> Map UUID Song -> EnrichSongParams -> m (Map UUID Song) +enrichedSongResponse' env songMap enrichSongParams = do + let isChildOf' p x = Just (p ^. #comment % #identifier) == x ^. #comment % #parentIdentifier + songIds = keys songMap + getComment = + if enrichSongParams ^. #includeComments + then exec @SongQuery $ fetchSongComments env songIds + else pure $ fromList [] + getArtwork = + if enrichSongParams ^. #includeArtworks + then exec @SongQuery $ fetchSongArtworks env songIds + else pure $ fromList [] + getOpinion = + if enrichSongParams ^. #includeOpinions + then exec @SongQuery $ fetchSongOpinions env songIds + else pure $ fromList [] + getArtist = + if enrichSongParams ^. #includeArtists + then exec @SongQuery $ fetchSongArtists env songIds + else pure $ fromList [] + getContent = + if enrichSongParams ^. #includeContents + then exec @SongQuery $ fetchSongContents env songIds + else pure $ fromList [] + + artworkMap <- liftIO getArtwork + opinionMap <- liftIO getOpinion + commentMap <- liftIO getComment + contentMap <- liftIO getContent + artistPerSongList <- liftIO getArtist + + let matchesSongIdentifier song = (== song ^. #identifier) . (^. #songIdentifier) + let enrichedSongs = + Map.map + ( \song -> do + let rawCommentMap = Map.filter (matchesSongIdentifier song) commentMap + allComments = elems rawCommentMap + commentThreads = map renderThread $ mkThreads allComments isChildOf' (^. #comment % #parentIdentifier) + relevantArtists = filter (\(songId, _, _) -> songId == song ^. #identifier) artistPerSongList + + song + { comments = commentThreads, + contents = Map.filter (matchesSongIdentifier song) contentMap, + artworks = Map.filter (matchesSongIdentifier song) artworkMap, + opinions = Map.filter (matchesSongIdentifier song) opinionMap, + artists = Map.fromList $ map (\(_, artistId, artistName) -> (artistId, artistName)) relevantArtists + } + ) + songMap + pure enrichedSongs + +fetchSongArtists' :: (MonadIO m) => Env -> [UUID] -> m [(UUID, UUID, Text)] +fetchSongArtists' env identifiers = do + songArtists <- + liftIO + . runBeamSqlite (env ^. #conn) + . runSelectReturningList + . select + . orderBy_ (asc_ . (^. #createdAt)) + $ filter_ (\s -> (s ^. #songIdentifier) `in_` map (val_ . SongId . UUID.toText) identifiers) + $ all_ ((^. #songArtists) wikiMusicDatabase) + + artists <- + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runSelectReturningList + . select + . orderBy_ (asc_ . (^. #displayName)) + $ filter_ (\s -> (s ^. #identifier) `in_` map (val_ . fromArtistPk . (^. #artistIdentifier)) songArtists) + $ all_ ((^. #artists) wikiMusicDatabase) + let artistMap = Map.fromList $ map (\a -> (a ^. #identifier, a ^. #displayName)) artists + pure + $ map + ( \sa -> + ( textToUUID $ fromSongPk $ sa ^. #songIdentifier, + textToUUID $ fromArtistPk $ sa ^. #artistIdentifier, + fromMaybe "" $ artistMap Map.!? fromArtistPk (sa ^. #artistIdentifier) + ) + ) + songArtists + +searchSongs' :: (MonadIO m) => Env -> SearchInput -> SongSortOrder -> Limit -> Offset -> m (Map UUID Song, [UUID]) +searchSongs' env searchInput sortOrder (Limit limit) (Offset offset) = do + songs <- + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runSelectReturningList + . select + . filter_ (\s -> (s ^. #displayName) `like_` val_ ("%" <> searchInput ^. #value <> "%")) + . limit_ (fromIntegral limit) + . offset_ (fromIntegral offset) + . mkOrderBy sortOrder + $ all_ ((^. #songs) wikiMusicDatabase) + + filledSongs env songs + +fetchSongContents' :: (MonadIO m) => Env -> [UUID] -> m (Map UUID SongContent) +fetchSongContents' env identifiers = do + contents <- + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runSelectReturningList + . select + . filter_ (\s -> (s ^. #songIdentifier) `in_` map (val_ . SongId . UUID.toText) identifiers) + $ all_ ((^. #songContents) wikiMusicDatabase) + pure $ Map.fromList $ map (\x -> (textToUUID $ x ^. #identifier, mkSongContentsM x)) contents + +filledSongs :: (MonadIO m) => Env -> [Song'] -> m (Map UUID Song, [UUID]) +filledSongs env songs = do + externalSources <- + liftIO + $ runBeamSqliteDebug putStrLn (env ^. #conn) + $ runSelectReturningList + . select + . filter_ (\s -> (s ^. #songIdentifier) `in_` map (val_ . (\x -> SongId $ x ^. #identifier)) songs) + $ all_ ((^. #songExternalSources) wikiMusicDatabase) + let filledSongs' = map (withExternalSources externalSources) songs + pure (Map.fromList filledSongs', map (textToUUID . (^. #identifier)) songs) + where + withExternalSources externalSources song = + let maybeFoundExternal = + fmap + (fromPersistenceExternalSource . head) + (nonEmpty $ filter (\x -> fromSongPk (x ^. #songIdentifier) == song ^. #identifier) externalSources) + in toSong song (fromMaybe emptyExternalSources maybeFoundExternal) diff --git a/src/WikiMusic/Sqlite/UserCommand.hs b/src/WikiMusic/Sqlite/UserCommand.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Sqlite/UserCommand.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Sqlite.UserCommand () where + +import Data.ByteString.Base64 qualified +import Data.Password.Bcrypt +import Data.Text (pack) +import Data.Text qualified as T +import Data.UUID qualified as UUID +import Data.UUID.V4 +import Database.Beam +import Database.Beam.Sqlite +import Relude +import WikiMusic.Beam.Database +import WikiMusic.Beam.User +import WikiMusic.Beam.Util +import WikiMusic.Free.UserCommand +import WikiMusic.Model.Auth +import WikiMusic.Model.Env +import WikiMusic.Protolude + +instance Exec UserCommand where + execAlgebra (MakeResetPasswordLink env email next) = doIfUserFoundByEmail env email (makeToken env) >>= next + execAlgebra (ChangePasswordByEmail env email password next) = do + next =<< doIfUserFoundByEmail env email (changePassword env password) + execAlgebra (InvalidateResetTokenByEmail env email next) = next =<< doIfUserFoundByEmail env email (invalidateToken env) + execAlgebra (InviteUser env _ email name' role desc next) = next =<< addUser env email name' role desc + execAlgebra (DeleteUser env _ email next) = next =<< doIfUserFoundByEmail env email (deleteU env) + +makeToken :: (MonadIO m) => Env -> UUID -> m (Either UserCommandError Text) +makeToken env identifier = do + maybeUser <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningFirst $ select $ do + filter_ + ( \s -> + (s ^. #identifier) + ==. val_ (UUID.toText identifier) + ) + $ all_ ((^. #users) wikiMusicDatabase) + now <- liftIO getCurrentTime + maybeToken <- maybeGenToken + case maybeUser of + Nothing -> pure . Left $ PersistenceError "" + Just x -> do + case maybeToken of + Left l -> pure . Left . PersistenceError . Relude.show $ l + Right t -> do + _ <- + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runUpdate + $ save + ((^. #users) wikiMusicDatabase) + (x {passwordResetToken = Just t, lastEditedAt = Just now} :: User') + pure . Right $ t + +maybeGenToken :: (MonadIO m) => m (Either UnicodeException Text) +maybeGenToken = do + l <- pack . Relude.show <$> liftIO nextRandom + r <- pack . Relude.show <$> liftIO nextRandom + pure $ decodeUtf8' . Data.ByteString.Base64.encode . encodeUtf8 $ tokenConcat l r + where + tokenConcat l r = l <> "$" <> r + +invalidateToken :: (MonadIO m) => Env -> UUID -> m (Either UserCommandError ()) +invalidateToken env identifier = do + now <- liftIO getCurrentTime + art <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + (\s -> (s ^. #identifier) ==. val_ (UUID.toText identifier)) + $ all_ ((^. #users) wikiMusicDatabase) + case art of + Nothing -> pure . Right $ () + Just foundArt -> do + let a = foundArt {passwordResetToken = Nothing, lastEditedAt = Just now} :: User' + liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runUpdate . save ((^. #users) wikiMusicDatabase) $ a + pure . Right $ () + +changePassword :: (MonadIO m) => Env -> UserPassword -> UUID -> m (Either UserCommandError ()) +changePassword env password identifier = do + hashed <- hashPassword (mkPassword (password ^. #value)) + now <- liftIO getCurrentTime + new <- liftIO nextRandom + art <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningOne $ select $ do + filter_ + (\s -> (s ^. #identifier) ==. val_ (UUID.toText identifier)) + $ all_ ((^. #users) wikiMusicDatabase) + case art of + Nothing -> pure . Right $ () + Just foundArt -> do + let a = + foundArt + { passwordHash = Just $ unPasswordHash hashed, + authToken = Just $ newToken now new, + lastEditedAt = Just now + } :: + User' + liftIO . runBeamSqliteDebug putStrLn (env ^. #conn) . runUpdate . save ((^. #users) wikiMusicDatabase) $ a + pure . Right $ () + +newToken :: UTCTime -> UUID -> Text +newToken now new = + decodeUtf8 + . Data.ByteString.Base64.encode + . encodeUtf8 + $ (pack . WikiMusic.Protolude.show $ now) + <> "--" + <> (pack . WikiMusic.Protolude.show $ new) + +addUser :: (MonadIO m) => Env -> UserEmail -> UserName -> UserRole -> Maybe Text -> m (Either UserCommandError Text) +addUser env email name' role desc = do + now <- liftIO getCurrentTime + passResetToken <- liftIO nextRandom + new <- liftIO nextRandom + newNew <- liftIO nextRandom + let u = + User' + { identifier = UUID.toText new, + displayName = name' ^. #value, + emailAddress = email ^. #value, + passwordHash = Nothing, + passwordResetToken = Just $ UUID.toText passResetToken, + createdAt = now, + authToken = Nothing, + latestLoginAt = Nothing, + latestLoginDevice = Nothing, + avatarUrl = Nothing, + lastEditedAt = Nothing, + description = desc + } :: + User' + let r = + UserRole' + { identifier = UUID.toText newNew, + userIdentifier = UserId . UUID.toText $ new, + roleId = T.pack . Relude.show $ role, + createdAt = now + } :: + UserRole' + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #users) wikiMusicDatabase) + $ insertValues [u] + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runInsert + . insert ((^. #userRoles) wikiMusicDatabase) + $ insertValues [r] + pure . Right . UUID.toText $ passResetToken + +doIfUserFoundByEmail :: (MonadIO m) => Env -> UserEmail -> (UUID -> m (Either UserCommandError a)) -> m (Either UserCommandError a) +doIfUserFoundByEmail env email eff = do + maybeUser <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningFirst $ select $ do + filter_ + ( \s -> + (s ^. #emailAddress) + ==. val_ (email ^. #value) + ) + $ all_ ((^. #users) wikiMusicDatabase) + + case maybeUser of + Nothing -> pure . Left . LogicError $ "User could not be found!" + Just u -> eff (textToUUID $ u ^. #identifier) + +deleteU :: (MonadIO m) => Env -> UUID -> m (Either UserCommandError ()) +deleteU env identifier = do + maybeUser <- liftIO $ runBeamSqliteDebug putStrLn (env ^. #conn) $ do + runSelectReturningFirst $ select $ do + filter_ + ( \s -> + (s ^. #identifier) + ==. val_ (UUID.toText identifier) + ) + $ all_ ((^. #users) wikiMusicDatabase) + case maybeUser of + Nothing -> pure . Left $ PersistenceError "" + Just x -> do + _ <- + liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runUpdate + $ save ((^. #users) wikiMusicDatabase) (x {passwordHash = Just "", authToken = Just ""} :: User') + pure . Right $ () diff --git a/src/WikiMusic/Sqlite/UserQuery.hs b/src/WikiMusic/Sqlite/UserQuery.hs new file mode 100644 --- /dev/null +++ b/src/WikiMusic/Sqlite/UserQuery.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module WikiMusic.Sqlite.UserQuery () where + +import Database.Beam +import Database.Beam.Sqlite +import Optics +import Relude +import WikiMusic.Beam.Database +import WikiMusic.Free.UserQuery +import WikiMusic.Protolude + +instance Exec UserQuery where + execAlgebra (DoesTokenMatchByEmail env email token next) = next =<< doesTokenMatchByEmail' env email token + +doesTokenMatchByEmail' :: (MonadIO m) => Env -> UserEmail -> UserToken -> m (Either UserQueryError Bool) +doesTokenMatchByEmail' env email token = do + maybeUser <- liftIO + . runBeamSqliteDebug putStrLn (env ^. #conn) + . runSelectReturningFirst + . select + $ do + filter_ + ( \s -> + ((s ^. #emailAddress) ==. val_ (email ^. #value)) + &&. ((s ^. #passwordResetToken) ==. val_ (Just (token ^. #value))) + ) + $ all_ ((^. #users) wikiMusicDatabase) + + pure . Right $ isJust maybeUser + +-- getUsers' :: (MonadIO m) => Env -> m (Either UserQueryError [User]) +-- getUsers' env = do +-- users <- liftIO +-- . runBeamSqliteDebug putStrLn (env ^. #conn) +-- . runSelectReturningList +-- . select +-- $ do +-- u <- +-- orderBy_ (asc_ . (^. #displayName)) +-- $ filter_ +-- (\s -> (s ^. #authToken) /=. val_ (Just "")) +-- $ all_ ((^. #users) wikiMusicDatabase) + +-- r <- +-- oneToMany_ ((^. #userRoles) wikiMusicDatabase) (UserId . (^. #identifier)) u + +-- pure (u, r) + +-- -- let uu = (uncurry mkUserM) +-- -- pure . Right $ map uu users +-- -- let rr = groupBy ((==) `on` fst) $ users +-- -- let noneRR = mapMaybe nonEmpty rr +-- -- let noneRRR = map (\x -> do +-- -- x +-- -- ) noneRR +-- -- let roleMap = map (\l -> (fst . head $ l, map snd l)) . catMaybes . map (\(u, r) -> (nonEmpty u, r)) $ rr +-- pure . Right $ [] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,88 +1,7 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} - -module Main (main) where - -import Data.ByteString.Lazy qualified as BL -import Optics import Relude -import System.Process -import Test.Tasty qualified as Tasty -import Test.Tasty.HUnit qualified as Tasty -import TestContainers.Tasty qualified as TC - -data TestConfig = TestConfig - { redisHost :: String, - redisPort :: Int, - postgreSQLHost :: String, - postgreSQLPort :: Int - } - deriving (Eq, Show, Generic) - -makeFieldLabelsNoPrefix ''TestConfig - --- | Sets up and runs the containers required for this test suite. -setupContainers :: (TC.MonadDocker m) => m TestConfig -setupContainers = do - redisContainer <- - TC.run $ - TC.containerRequest (TC.fromTag "redis:6.2-alpine") - -- Expose the port 6379 from within the container. The respective port - -- on the host machine can be looked up using `containerPort` (see below). - TC.& TC.setExpose [6379] - -- Wait until the container is ready to accept requests. `run` blocks until - -- readiness can be established. - TC.& TC.setWaitingFor (TC.waitUntilMappedPortReachable 6379) - postgreSQLContainer <- - TC.run $ - TC.containerRequest (TC.fromTag "postgres:15.5") - TC.& TC.setExpose [5432] - TC.& TC.setWaitingFor (TC.waitUntilMappedPortReachable 5432) - - pure $ - TestConfig - { redisHost = "0.0.0.0", - redisPort = - -- Look up the corresponding port on the host machine for the exposed - -- port 6379. - TC.containerPort redisContainer 6379, - postgreSQLHost = "0.0.0.0", - postgreSQLPort = TC.containerPort postgreSQLContainer 5432 - } +import Test.Hspec +import WikiMusic.Test.Integration main :: IO () -main = - Tasty.defaultMain $ - -- Use `withContainers` to make the containers available in the closed over - -- tests. Due to how Tasty handles resources `withContainers` passes down - -- an IO action `start` to actually start up the containers. `start` can be - -- invoked multiple times, Tasty makes sure to only start up the containrs - -- once. - -- - -- `withContainers` ensures the started containers are shut down correctly - -- once execution leaves its scope. - TC.withContainers setupContainers $ - \start -> - Tasty.testGroup - "Some test group" - [ Tasty.testCase "Redis + PostgreSQL test" $ do - -- Actually start the containers!! - TestConfig {..} <- start - -- ... assert some properties - pure (), - Tasty.testCase "Another Redis + PostgreSQL test" $ do - -- Invoking `start` twice gives the same Endpoints! - TestConfig {..} <- start - (code, stdout, stderr) <- readProcess "ls -l /home" -- >>= BL.putStr - _ <- BL.putStr stdout - -- ... assert some properties - pure (), - Tasty.testCase "Another Redis + PostgreSQL test 2" $ do - -- Invoking `start` twice gives the same Endpoints! - TestConfig {..} <- start - (code, stdout, stderr) <- readProcess "timeout 20s make dev" -- >>= BL.putStr - _ <- BL.putStr stdout - -- ... assert some properties - pure () - ] +main = hspec $ do + integrationSpec diff --git a/test/WikiMusic/Test/Integration.hs b/test/WikiMusic/Test/Integration.hs new file mode 100644 --- /dev/null +++ b/test/WikiMusic/Test/Integration.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE QuasiQuotes #-} + +module WikiMusic.Test.Integration where + +import WikiMusic.Test.Principium + +integrationSpec :: SpecWith () +integrationSpec = + describe "starts WikiMusic application properly" $ do + it "starts and shuts down the application properly" $ do + result <- testWikiMusic (const . liftIO $ sleepSeconds 1) + result `shouldBe` () + it "checks that the system information route is reachable" $ do + httpResponse <- testWikiMusic (\cfg -> httpCall Nothing (mkTestUrl cfg <> "/system-information")) + expectStatus 200 httpResponse + it "checks that invalid UUIDs always return a 400" $ do + let invalidUUIDPaths = + [ "/songs/identifier/abc", + "/artists/identifier/abc", + "/genres/identifier/abc" + ] + httpResponses <- testWikiMusic (\cfg -> mapM (\path -> httpCall Nothing (mkTestUrl cfg <> path)) invalidUUIDPaths) + expectAllStatus 400 httpResponses + it "checks that protected routes are returning 401 when not logged in" $ do + let protectedPaths = + [ "/songs", + "/songs/identifier/c19e4f56-7c06-437d-b8f7-59d13dd53c9a", + "/artists", + "/artists/identifier/c19e4f56-7c06-437d-b8f7-59d13dd53c9a", + "/genres", + "/genres/identifier/c19e4f56-7c06-437d-b8f7-59d13dd53c9a" + ] + httpResponses <- testWikiMusic (\cfg -> mapM (\path -> httpCall Nothing (mkTestUrl cfg <> path)) protectedPaths) + expectAllStatus 401 httpResponses + it "receives empty songs list when a user (demo) exists but no data exists in DB" $ do + httpResponse <- + testWikiMusic + ( \cfg -> do + u <- createUserInDB (cfg ^. #sqlite % #path) "wm::demo" + httpCall (u ^. #authToken) (mkTestUrl cfg <> "/songs") + ) + expectStatus 200 httpResponse + expectResponseBody [trimming|{"songs":{},"sortOrder":[]}|] httpResponse + it "receives empty genres list when a user (demo) exists but no data exists in DB" $ do + httpResponse <- + testWikiMusic + ( \cfg -> do + u <- createUserInDB (cfg ^. #sqlite % #path) "wm::demo" + httpCall (u ^. #authToken) (mkTestUrl cfg <> "/genres") + ) + expectStatus 200 httpResponse + expectResponseBody [trimming|{"genres":{},"sortOrder":[]}|] httpResponse + it "receives empty artists list when a user (demo) exists but no data exists in DB" $ do + httpResponse <- + testWikiMusic + ( \cfg -> do + u <- createUserInDB (cfg ^. #sqlite % #path) "wm::demo" + httpCall (u ^. #authToken) (mkTestUrl cfg <> "/artists") + ) + expectStatus 200 httpResponse + expectResponseBody [trimming|{"artists":{},"sortOrder":[]}|] httpResponse diff --git a/test/WikiMusic/Test/Principium.hs b/test/WikiMusic/Test/Principium.hs new file mode 100644 --- /dev/null +++ b/test/WikiMusic/Test/Principium.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module WikiMusic.Test.Principium + ( -- + module Relude, + module Optics, + module Test.Hspec, + module WikiMusic.Model.Other, + module NeatInterpolation, + module Data.Time, + UUID.UUID, + -- + SpecWith, + maybeDecodeUtf8, + uuidToText, + intToText, + unpackText, + packText, + filterText, + replaceText, + mapElems, + mapFromList, + emptyMap, + mapFilter, + setUnion, + takeText, + mkTestUrl, + createUserInDB, + doInDB, + httpCall, + mkTestConfig, + describe, + it, + sleepSeconds, + testWikiMusic, + expectStatus, + expectAllStatus, + expectResponseBody, + ) +where + +-- + +-- + +import Control.Concurrent +import Data.ByteString.Lazy qualified as BL +import Data.Map qualified as Map +import Data.Password.Bcrypt +import Data.Set qualified +import Data.Text qualified as T +import Data.Time +import Data.UUID qualified as UUID +import Data.UUID.V4 +import Database.Beam +import Database.Beam.Sqlite +import Database.SQLite.Simple +import NeatInterpolation hiding (text) +import Network.HTTP.Client + ( Response (..), + defaultManagerSettings, + httpLbs, + managerSetProxy, + newManager, + proxy, + proxyEnvironment, + requestHeaders, + responseBody, + ) +import Network.HTTP.Types.Status (statusCode) +import Network.Wai.Logger (withStdoutLogger) +import Optics hiding (uncons) +import Relude +import System.Directory +import System.Random +import Test.Hspec +import WikiMusic.Beam.Database +import WikiMusic.Beam.User +import WikiMusic.Boot qualified +import WikiMusic.Model.Auth hiding (show) +import WikiMusic.Model.Config +import WikiMusic.Model.Other +import Yggdrasil + +-- + +maybeDecodeUtf8 :: ByteString -> Either UnicodeException Text +maybeDecodeUtf8 = decodeUtf8' + +uuidToText :: UUID.UUID -> Text +uuidToText = UUID.toText + +intToText :: Int -> Text +intToText = T.pack . show + +unpackText :: Text -> String +unpackText = T.unpack + +packText :: String -> Text +packText = T.pack + +filterText :: (Char -> Bool) -> Text -> Text +filterText = T.filter + +replaceText :: Text -> Text -> Text -> Text +replaceText = T.replace + +mapElems :: Map k a -> [a] +mapElems = Map.elems + +mapFromList :: (Ord a) => [(a, b)] -> Map a b +mapFromList = Map.fromList + +emptyMap :: Map k a +emptyMap = Map.empty + +mapFilter :: (a -> Bool) -> Map k a -> Map k a +mapFilter = Map.filter + +setUnion :: (Ord a) => Set a -> Set a -> Set a +setUnion a b = a `Data.Set.union` b + +takeText :: Int -> Text -> Text +takeText = T.take + +mkTestUrl :: AppConfig -> Text +mkTestUrl cfg = "http://" <> cfg ^. #servant % #host <> ":" <> (T.pack . show $ cfg ^. #servant % #port) + +httpCall :: (MonadIO m) => Maybe Text -> Text -> m (Response BL.ByteString) +httpCall token url = do + let settings = managerSetProxy (proxyEnvironment Nothing) defaultManagerSettings + man <- liftIO $ newManager settings + let req = + (fromString . T.unpack $ url) + { requestHeaders = catMaybes [maybeAuthHeader], + proxy = Nothing + } + res <- liftIO $ httpLbs req man + _ <- print res + pure res + where + maybeAuthHeader = (\t -> Just ("x-wikimusic-auth", fromString . T.unpack $ t)) =<< token + +testWikiMusic :: (MonadIO m) => (AppConfig -> m a) -> m a +testWikiMusic eff = do + portNumber <- liftIO $ randomRIO (2000, 65000) + someUUID <- liftIO nextRandom + + let dbPath = "resources/test/wikimusic-" <> (T.pack . show $ someUUID) <> ".sqlite" + cfg = mkTestConfig portNumber dbPath + startWikiMusic = withStdoutLogger $ \logger' -> + WikiMusic.Boot.startWikiMusicAPI logger' cfg + + processThread <- liftIO $ forkIO startWikiMusic + _ <- liftIO $ runYggdrasil defaultYggdrasil {databaseFilePath = dbPath} + result <- eff cfg + _ <- liftIO $ killThread processThread + _ <- liftIO . removeFile . fromString . T.unpack $ dbPath + pure result + +mkTestConfig :: Int -> Text -> AppConfig +mkTestConfig portNumber dbPath = + AppConfig + { servant = + ServantConfig + { port = portNumber, + host = "127.0.0.1" + }, + sqlite = + SqliteConfig + { path = dbPath, + runMigrations = True + }, + cors = + CorsConfig + { origins = [], + methods = [], + requestHeaders = [] + }, + mail = + MailConfig + { sendTimeoutSeconds = 0, + host = "", + userFile = "", + user = Nothing, + passwordFile = "", + password = Nothing, + senderName = "", + senderMail = "" + }, + webFrontend = + WebFrontendConfig + { baseUrl = "" + }, + dev = + DevConfig + { reportedVersion = "" + } + } + +randomText :: (MonadIO m) => m Text +randomText = T.pack . take 16 . randomRs ('a', 'z') <$> newStdGen + +createUserInDB :: (MonadIO m) => Text -> Text -> m WikiMusicUser +createUserInDB dbPath role = do + conn <- liftIO $ open (fromString . T.unpack $ dbPath) + someUUID <- liftIO nextRandom + someUUID' <- liftIO nextRandom + someText <- liftIO randomText + someText' <- liftIO randomText + now <- liftIO getCurrentTime + let mail = someText <> "@gmail.com" + password = T.pack . reverse . T.unpack $ someText + authToken = password <> "-" <> password + hashed <- hashPassword (mkPassword password) + let u = + User' + { identifier = T.pack . show $ someUUID, + displayName = someText, + emailAddress = mail, + passwordHash = Just $ unPasswordHash hashed, + passwordResetToken = Nothing, + createdAt = now, + authToken = Just authToken, + latestLoginAt = Nothing, + latestLoginDevice = Nothing, + avatarUrl = Nothing, + lastEditedAt = Nothing, + description = Just someText' + } :: + User' + let r = + UserRole' + { identifier = T.pack . show $ someUUID', + userIdentifier = UserId . T.pack . show $ someUUID, + roleId = role, + createdAt = now + } :: + UserRole' + liftIO + . runBeamSqliteDebug putStrLn conn + . runInsert + . insert ((^. #users) wikiMusicDatabase) + $ insertValues [u] + liftIO + . runBeamSqliteDebug putStrLn conn + . runInsert + . insert ((^. #userRoles) wikiMusicDatabase) + $ insertValues [r] + pure $ mkUserM [role] u + +doInDB :: (MonadIO m) => Text -> (Connection -> m a) -> m () +doInDB dbPath eff = do + conn <- liftIO $ open (T.unpack dbPath) + _ <- eff conn + liftIO $ close conn + +sleepSeconds :: (MonadIO m) => Int -> m () +sleepSeconds x = liftIO $ threadDelay (x * 1000000) + +expectStatus :: Int -> Response body -> Expectation +expectStatus x httpResponse = (statusCode . responseStatus $ httpResponse) `shouldBe` x + +expectAllStatus :: Int -> [Response body] -> Expectation +expectAllStatus x httpResponses = all ((== x) . statusCode . responseStatus) httpResponses `shouldBe` True + +expectResponseBody :: Text -> Response LByteString -> Expectation +expectResponseBody txt httpResponse = + (decodeUtf8' . fromLazy . responseBody $ httpResponse) + `shouldBe` (Right . fromString . T.unpack $ txt) diff --git a/wikimusic-api.cabal b/wikimusic-api.cabal --- a/wikimusic-api.cabal +++ b/wikimusic-api.cabal @@ -1,24 +1,23 @@ cabal-version: 1.12 name: wikimusic-api -version: 1.1.0.1 -description: Please see the README at -homepage: https://gitlab.com/jjba-projects/wikimusic-api -bug-reports: https://gitlab.com/jjba-projects/wikimusic-api/-/issues +version: 1.2.0.8 +description: Please see the README at +homepage: https://codeberg.org/jjba23/wikimusic-api +bug-reports: https://codeberg.org/jjba23/wikimusic-api/-/issues author: Josep Bigorra maintainer: Josep Bigorra copyright: 2023 Josep Bigorra license: GPL-3 +license-file: COPYING build-type: Simple extra-source-files: README.org - CHANGELOG.org source-repository head type: git - location: https://gitlab.com/jjba-projects/wikimusic-api - subdir: wikimusic-api + location: https://codeberg.org/jjba23/wikimusic-api library exposed-modules: @@ -60,26 +59,25 @@ WikiMusic.Model.Config WikiMusic.Model.Env - -- λ postgresql implementations - WikiMusic.PostgreSQL.ArtistCommand - WikiMusic.PostgreSQL.ArtistQuery - WikiMusic.PostgreSQL.AuthQuery - WikiMusic.PostgreSQL.GenreCommand - WikiMusic.PostgreSQL.GenreQuery - WikiMusic.PostgreSQL.Migration - WikiMusic.PostgreSQL.WriteAbstraction - WikiMusic.PostgreSQL.ReadAbstraction - WikiMusic.PostgreSQL.SongCommand - WikiMusic.PostgreSQL.SongQuery - WikiMusic.PostgreSQL.UserQuery - WikiMusic.PostgreSQL.UserCommand + WikiMusic.Beam.Artist + WikiMusic.Beam.Genre + WikiMusic.Beam.Song + WikiMusic.Beam.Database + WikiMusic.Beam.User + WikiMusic.Beam.Util + WikiMusic.Beam.Relations - -- λ postgresql data models - WikiMusic.PostgreSQL.Model.Artist - WikiMusic.PostgreSQL.Model.Genre - WikiMusic.PostgreSQL.Model.Other - WikiMusic.PostgreSQL.Model.Song - + -- λ sqlite implementations + WikiMusic.Sqlite.ArtistCommand + WikiMusic.Sqlite.ArtistQuery + WikiMusic.Sqlite.AuthQuery + WikiMusic.Sqlite.GenreCommand + WikiMusic.Sqlite.GenreQuery + WikiMusic.Sqlite.SongCommand + WikiMusic.Sqlite.SongQuery + WikiMusic.Sqlite.UserQuery + WikiMusic.Sqlite.UserCommand + -- λ clock WikiMusic.Clock.LiveClock @@ -87,7 +85,7 @@ WikiMusic.Console.Logger -- λ mail - WikiMusic.SMTP.MailCommandSES + WikiMusic.Smtp.MailCommandSES -- λ custom prelude WikiMusic.Protolude @@ -125,14 +123,6 @@ , base < 5 , bytestring , contravariant-extras - , postgresql-libpq - , hasql - , hasql-implicits - , hasql-migration - , hasql-optparse-applicative - , hasql-pool - , hasql-transaction - , hedis , keuringsdienst , keys , mtl @@ -145,20 +135,20 @@ , time , servant , servant-openapi3 - , servant-rate-limit , servant-server , text , containers , filepath , directory , uuid - , vector , wai , wai-cors , wai-extra - , wai-rate-limit - , wai-rate-limit-redis + , wai-logger , warp + , prometheus-client + , prometheus-metrics-ghc + , wai-middleware-prometheus , smtp-mail , mime-mail , base64-bytestring @@ -168,6 +158,11 @@ , tomland , wikimusic-model-hs , wikimusic-api-spec + , word8 + , beam-core + , beam-sqlite + , sqlite-simple + , yggdrasil-schema default-language: GHC2021 executable wikimusic-api-exe @@ -176,7 +171,7 @@ Paths_wikimusic_api hs-source-dirs: app - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-T -N" default-extensions: DataKinds DefaultSignatures @@ -201,17 +196,19 @@ build-depends: base - , wikimusic-api + , wikimusic-api default-language: GHC2021 -test-suite spec +test-suite wikimusic-api-spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: Paths_wikimusic_api + WikiMusic.Test.Integration + WikiMusic.Test.Principium hs-source-dirs: test - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-T -N" default-extensions: DataKinds DefaultSignatures @@ -237,6 +234,30 @@ build-depends: wikimusic-api , base + , hspec + , QuickCheck , tasty - , tasty-hunit + , tasty-hspec + , relude + , wai + , wai-logger + , random + , uuid + , text + , http-client + , http-types + , containers + , optics + , beam-core + , beam-sqlite + , sqlite-simple + , neat-interpolation + , time + , password + , password-types + , directory + , keuringsdienst + , wikimusic-model-hs + , wikimusic-api-spec + , yggdrasil-schema default-language: GHC2021