packages feed

wikimusic-api 1.1.0.1 → 1.2.0.8

raw patch · 60 files changed

+5281/−4028 lines, 60 filesdep +QuickCheckdep +beam-coredep +beam-sqlitedep −hasqldep −hasql-implicitsdep −hasql-migration

Dependencies added: QuickCheck, beam-core, beam-sqlite, hspec, http-client, http-types, prometheus-client, prometheus-metrics-ghc, random, sqlite-simple, tasty-hspec, wai-logger, wai-middleware-prometheus, word8, yggdrasil-schema

Dependencies removed: hasql, hasql-implicits, hasql-migration, hasql-optparse-applicative, hasql-pool, hasql-transaction, hedis, postgresql-libpq, servant-rate-limit, tasty-hunit, vector, wai-rate-limit, wai-rate-limit-redis

Files

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