diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,3 @@ +Michael Herold +Roman Naumann + diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,32 @@ +v0.7.0 + - Fixes all compiler warnings + - Fixes several bugs related to ROLE upgrades + - Fixes table checks missing after upgrade + - Adds --sql-log flag + - Adds --version flag + - Better SQL-Error presentation + - Better test coverage, now using pytest3 + - Better usage information for CLI + - Code coverage reports + - Refactoring of many code parts + - Removes support for column templates + - Splits library from binary (cabal) + - Started API and implementation docs +v0.6.0 + - Adds resolve complicated dependency issues + - Adds resolve change of function return type (if function can be dropped) + - Changes connection options to suppress SQL NOTICE messages + - Fixes fundamental logic error in pgsqlUpdateFragile + Without --perimit-data-deletion upgrades would not create objects etc. + - Fixes constraints in schema public are not deleted + - Renames Module to Schema + - Copletely new Library structure + - Reworked Documentation feature + - Removes avoidable dependencies + - Mostly uses Data.Text instead of String + - Renames modules to schemas +v0.5.0 + - Adds proper deletion of obsolete functions + - Changes to no data deletion as default for upgrades +v0.4.1 + - First release used in production diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,674 @@ +GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + {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 . + +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: + + {project} Copyright (C) {year} {fullname} + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,38 @@ +HamSql +====== + +Interpreter for SQL-structure definitions in Yaml ([YamSql](http://yamsql.readthedocs.io/)) + +- [![build status](https://git.hemio.de/hemio/hamsql/badges/master/build.svg)](https://git.hemio.de/hemio/hamsql/commits/master) *Debian Stable* +- [![Build Status](https://travis-ci.org/qua-bla/hamsql.svg?branch=master)](https://travis-ci.org/qua-bla/hamsql) *GHC 7.6, 7.8* + +## Building HamSql on Debian + +Install haskell compiler and required libraries: + +```sh +apt install \ + make \ + ghc \ + cabal-install \ + libghc-aeson-dev \ + libghc-file-embed-dev \ + libghc-network-uri-dev \ + libghc-optparse-applicative-dev \ + libghc-pandoc-dev \ + libghc-postgresql-simple-dev \ + libghc-text-dev \ + libghc-unordered-containers-dev \ + libghc-yaml-dev +``` + +Now you can + + make + make install + +Completly building from sources + + apt install make ghc cabal-install libpq-dev happy + make + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/data/doc-template.rst b/data/doc-template.rst new file mode 100644 --- /dev/null +++ b/data/doc-template.rst @@ -0,0 +1,229 @@ +$name$ +====================================================================== + +$description$ + +.. contents:: Module Contents + :local: + :depth: 2 + + +$if(tables)$ + +Tables +------ + +$for(tables)$ + +.. _TABLE-$name$.$tables.name$: + +``$name$.$tables.name$`` +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +$tables.description$ + +Primary key +$for(tables.primary_key)$ + - $tables.primary_key$ +$endfor$ + + +.. BEGIN FKs + +$if(tables.foreign_keys)$ +Foreign keys +$for(tables.foreign_keys)$ + - $tables.foreign_keys.name$ + + Local Columns +$for(tables.foreign_keys.columns)$ + - $tables.foreign_keys.columns$ +$endfor$ + + Referenced Columns +$for(tables.foreign_keys.ref_columns)$ + - :ref:`$tables.foreign_keys.ref_table$.$tables.foreign_keys.ref_columns$ ` +$endfor$ + +$endfor$ +$endif$ + +.. END FKs + +$if(tables.inherits)$ +Inherits +$for(tables.inherits)$ + - $tables.inherits$ +$endfor$ +$endif$ + +Columns +$for(tables.columns)$ + - .. _COLUMN-$name$.$tables.name$.$tables.columns.name$: + + ``$tables.columns.name$`` $if(tables.columns.null)$*NULL* | $endif$:ref:`$tables.columns.type$ ` + $tables.columns.description$ + +$if(tables.columns.default)$ + Default + .. code-block:: sql + + $tables.columns.default$ +$endif$ + +$if(tables.columns.references)$ + References :ref:`$tables.columns.references$ ` +$endif$ + +$if(tables.columns.on_ref_delete)$ + On Delete: $tables.columns.on_ref_delete$ +$endif$ + +$if(tables.columns.on_ref_update)$ + On Update: $tables.columns.on_ref_update$ +$endif$ + +$endfor$ + +$endfor$ + +$endif$ + + +$if(functions)$ + +Functions +--------- + +$for(functions)$ + + +.. _FUNCTION-$name$.$functions.name$: + +``$name$.$functions.name$`` +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +$functions.description$ + +Parameters +$if(functions.parameters)$ +$for(functions.parameters)$ + - ``$functions.parameters.name$`` :ref:`$functions.parameters.type$ ` + $if(functions.variables.default)$(default: ``$functions.parameters.default$``)$endif$ + $functions.parameters.description$ +$endfor$ +$else$ + *None* +$endif$ + +$if(functions.language)$ +Language + $functions.language$ +$endif$ + +$if(functions.variables)$ +Variables defined for body +$for(functions.variables)$ + - ``$functions.variables.name$`` :ref:`$functions.variables.type$ ` + $if(functions.variables.default)$(default: ``$functions.variables.default$``)$endif$ + $functions.variables.description$ +$endfor$ +$endif$ + +Returns + $functions.returns$ + +$if(functions.returns_columns)$ +Returned columns +$for(functions.returns_columns)$ + - ``$functions.returns_columns.name$`` :ref:`$functions.returns_columns.type$ ` + $functions.returns_columns.description$ +$endfor$ +$endif$ + +$if(functions.priv_execute)$ +Execute privilege +$for(functions.priv_execute)$ + - :ref:`$functions.priv_execute$ ` +$endfor$ +$endif$ + +.. code-block:: $if(functions.language)$guess$else$plpgsql$endif$ + + $functions.body$ + +$endfor$ + +$endif$ + + +$if(domains)$ + +Domains +------- + +$for(domains)$ + + +.. _DOMAIN-$name$.$domains.name$: + +``$name$.$domains.name$`` +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +$domains.description$ + +$if(domains.checks)$ +Checks +$for(domains.checks)$ + - ``$domains.checks.name$`` + $domains.checks.description$ + + .. code-block:: sql + + $domains.checks.check$ + +$endfor$ +$endif$ + +$endfor$ +$endif$ + + +$if(roles)$ + +Roles +----- + +$for(roles)$ + +.. _ROLE-$roles.name$: + +``$roles.name$`` +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +$roles.description$ + +Login + *$if(roles.login)$Enabled$else$Disabled$endif$* + +$endfor$ +$endif$ + + +$if(sequences)$ + +Sequences +--------- + +$for(sequences)$ + +.. _SEQUENCE-$name$.$sequences.name$: + +``$name$.$sequences.name$`` +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +$sequences.description$ + +$endfor$ +$endif$ + diff --git a/hamsql-tests.hs b/hamsql-tests.hs new file mode 100644 --- /dev/null +++ b/hamsql-tests.hs @@ -0,0 +1,8 @@ +module Main where + +import Database.HamSql.Cli + +main :: IO () +main = do + exec ["--help"] + where exec xs = parseThisArgv xs >>= run diff --git a/hamsql.cabal b/hamsql.cabal new file mode 100644 --- /dev/null +++ b/hamsql.cabal @@ -0,0 +1,115 @@ +name: hamsql +version: 0.7.0.0 +synopsis: HamSql +category: Database +description: Interpreter for SQL-structure definitions in Yaml (YamSql) +homepage: https://git.hemio.de/hemio/hamsql +bug-reports: https://git.hemio.de/hemio/hamsql/issues +license: GPL-3 +license-file: COPYING +author: Michael Herold +maintainer: Michael Herold +copyright: (c) 2014-2016 Michael Herold et al. +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: + AUTHORS, + CHANGELOG, + README.md, + data/doc-template.rst + +library + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: + OverloadedStrings + + other-extensions: + DeriveDataTypeable, + DeriveGeneric, + FlexibleContexts, + FlexibleInstances, + GADTs, + ScopedTypeVariables, + StandaloneDeriving, + TemplateHaskell + exposed-modules: + Database.HamSql + Database.HamSql.Cli + Database.HamSql.Setup + Database.YamSql + Database.YamSql.Parser + + other-modules: + Database.HamSql.Internal.DbUtils + Database.HamSql.Internal.Documentation + Database.HamSql.Internal.InquireDeployed + Database.HamSql.Internal.Load + Database.HamSql.Internal.Option + Database.HamSql.Internal.PostgresCon + Database.HamSql.Internal.Stmt + Database.HamSql.Internal.Stmt.Basic + Database.HamSql.Internal.Stmt.Commons + Database.HamSql.Internal.Stmt.Create + Database.HamSql.Internal.Stmt.Domain + Database.HamSql.Internal.Stmt.Drop + Database.HamSql.Internal.Stmt.Function + Database.HamSql.Internal.Stmt.Role + Database.HamSql.Internal.Stmt.Schema + Database.HamSql.Internal.Stmt.Sequence + Database.HamSql.Internal.Stmt.Table + Database.HamSql.Internal.Stmt.Type + Database.HamSql.Internal.Utils + Database.YamSql.Internal.Basic + Database.YamSql.Internal.Check + Database.YamSql.Internal.Commons + Database.YamSql.Internal.Domain + Database.YamSql.Internal.Function + Database.YamSql.Internal.Role + Database.YamSql.Internal.Schema + Database.YamSql.Internal.Sequence + Database.YamSql.Internal.SqlId + Database.YamSql.Internal.Table + Database.YamSql.Internal.Type + Paths_hamsql + + build-depends: + aeson >=1.0 && <1.1, + base >=4.8 && <5.0, + bytestring >=0.10 && <0.11, + directory >=1.2 && <1.3, + file-embed >=0.0 && <0.1, + filepath >=1.4 && <1.5, + frontmatter >=0.1 && <0.2, + groom >=0.1 && < 0.2, + network-uri >=2.6 && <2.7, + optparse-applicative >=0.13 && <0.14, + pandoc >=1.17 && <1.18, + postgresql-simple >=0.4 && <0.6, + semigroups >=0.18 && <0.19, + text >=1.2 && <1.3, + transformers >=0.5 && <0.6, + unordered-containers >=0.2 && <0.3, + yaml >=0.8 && <0.9 + +executable hamsql + main-is: hamsql.hs + default-language: Haskell2010 + + build-depends: + base >=4.8 && <5.0, + hamsql + +test-suite hamsql-tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: hamsql-tests.hs + build-depends: + base >=4.8 && <5.0, + hamsql + +source-repository head + type: git + location: git@git.hemio.de:hemio/hamsql.git + diff --git a/hamsql.hs b/hamsql.hs new file mode 100644 --- /dev/null +++ b/hamsql.hs @@ -0,0 +1,11 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +module Main where + +import Database.HamSql.Cli + +main :: IO () +main = parseArgv >>= run + diff --git a/src/Database/HamSql.hs b/src/Database/HamSql.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql.hs @@ -0,0 +1,19 @@ +module Database.HamSql + ( module Database.HamSql.Internal.Documentation + , module Database.HamSql.Internal.PostgresCon + , module Database.HamSql.Internal.Load + , module Database.HamSql.Internal.Option + , module Database.HamSql.Internal.DbUtils + , module Database.HamSql.Internal.Stmt + , module Database.HamSql.Internal.Utils + , module Database.HamSql.Internal.Stmt.Create + ) where + +import Database.HamSql.Internal.DbUtils +import Database.HamSql.Internal.Documentation +import Database.HamSql.Internal.Load +import Database.HamSql.Internal.Option +import Database.HamSql.Internal.PostgresCon +import Database.HamSql.Internal.Stmt +import Database.HamSql.Internal.Stmt.Create +import Database.HamSql.Internal.Utils diff --git a/src/Database/HamSql/Cli.hs b/src/Database/HamSql/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Cli.hs @@ -0,0 +1,112 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +module Database.HamSql.Cli + ( run + , parseArgv + , parseThisArgv + ) where + +import Control.Monad (void, when) +import Data.List +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.IO as T.IO +import Data.Version (showVersion) +import Network.URI +import Options.Applicative hiding (info) +import System.Environment (getArgs) + +import Paths_hamsql (version) + +import Database.HamSql +import Database.YamSql + +parserPrefs :: ParserPrefs +parserPrefs = + defaultPrefs + { prefShowHelpOnEmpty = True + } + +parseArgv :: IO Command +parseArgv = getArgs >>= parseThisArgv + +parseThisArgv :: [String] -> IO Command +parseThisArgv xs = + handleParseResult $ execParserPure parserPrefs parserInfoHamsql xs + +run :: Command -> IO () +-- Install +run (Install optCommon optDb optInstall) + | optPermitDataDeletion optDb /= optDeleteExistingDatabase optInstall = + err $ + "For installs either both --permit-data-deletion and --delete-existing-database" <-> + "must be supplied or non of them." + | otherwise = do + let dbname = SqlName $ T.pack $ tail $ uriPath $ getConUrl optDb + if not (optEmulate optDb || optPrint optDb) + then void $ + pgsqlExecWithoutTransact + optDb + ((getConUrl optDb) + { uriPath = "/postgres" + }) + (catMaybes $ + sqlCreateDatabase (optDeleteExistingDatabase optInstall) dbname) + else when (optDeleteExistingDatabase optInstall) $ + warn' $ + "In --emulate and --print mode the DROP/CREATE DATABASE" <-> + "statements are skipped. You have to ensure that an empty" <-> + "database exists for those commands to make sense." + setup <- loadSetup optCommon (optSetup optCommon) + stmts <- pgsqlGetFullStatements optCommon optDb setup + -- TODO: Own option for this + dropRoleStmts <- + if optDeleteExistingDatabase optInstall + then pgsqlDropAllRoleStmts optDb setup + else return [] + useSqlStmts optCommon optDb $ sort $ stmts ++ dropRoleStmts +-- Upgrade +run (Upgrade optCommon optDb) = do + setup <- loadSetup optCommon (optSetup optCommon) + conn <- pgsqlConnectUrl (getConUrl optDb) + deleteStmts <- pgsqlDeleteAllStmt conn + createStmts <- pgsqlGetFullStatements optCommon optDb setup + fragile <- pgsqlUpdateFragile setup conn createStmts + let stmts = sort deleteStmts ++ Data.List.filter allowInUpgrade (sort fragile) + useSqlStmts optCommon optDb stmts +-- Doc +run (Doc optCommon optDoc) = do + setup <- loadSetup optCommon (optSetup optCommon) + docWrite optDoc setup +run (NoCommand opt) + | optVersion opt = putStrLn $ "hamsql " ++ showVersion version + | otherwise = err "UNEXPECTED: You supplied an unsupported option." + +useSqlStmts :: OptCommon -> OptCommonDb -> [SqlStmt] -> IO () +useSqlStmts optCommon optDb unfilteredStmts + | optPrint optDb = T.IO.putStrLn $ sqlPrinter $ sqlAddTransact stmts + | optEmulate optDb = void $ pgsqlExec optDb (getConUrl optDb) stmts + | otherwise = void $ pgsqlExec optDb (getConUrl optDb) stmts + where + warnOnDiff xs = + case unfilteredStmts \\ xs of + [] -> xs + ys -> + warn + ("A total of" <-> tshow (length ys) <-> + "objects will not be deleted. You must supply the" <-> + "--permit-data-deletion argument if you want to delete them.") $ + info + optCommon + ("The following objects are not deleted:" <\> + showCode (T.intercalate "\n" (map stmtDesc ys))) + xs + stmts + | optPermitDataDeletion optDb = unfilteredStmts + | otherwise = + warnOnDiff + [ x + | x <- unfilteredStmts + , not $ stmtRequiresPermitDeletion x ] diff --git a/src/Database/HamSql/Internal/DbUtils.hs b/src/Database/HamSql/Internal/DbUtils.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/DbUtils.hs @@ -0,0 +1,84 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Database.HamSql.Internal.DbUtils where + +import Control.Exception +import qualified Data.ByteString.Char8 as B +import Data.String +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text.IO as TIO +import Database.PostgreSQL.Simple +import Network.URI (URI, parseAbsoluteURI, uriToString) + +import Database.HamSql.Internal.Option +import Database.HamSql.Internal.Stmt +import Database.HamSql.Internal.Utils +import Database.YamSql + +toQry :: Text -> Query +toQry = fromString . T.unpack + +logStmt :: OptCommonDb -> Text -> IO () +logStmt opt x = + case optSqlLog opt of + Nothing -> return () + Just filename -> TIO.appendFile filename (x <> "\n") + +getConUrl :: OptCommonDb -> URI +getConUrl xs = + fromJustReason "Not a valid URI" (parseAbsoluteURI $ optConnection xs) + +pgsqlExecStmt :: Connection -> SqlStmt -> IO () +pgsqlExecStmt conn stmt = do + let code = toSqlCode stmt + _ <- execute_ conn (toQry code) + return () + +pgsqlExecStmtHandled :: Connection -> SqlStmt -> IO () +pgsqlExecStmtHandled conn stmt = + pgsqlExecStmt conn stmt `catch` pgsqlHandleErr stmt + +data PgSqlMode + = PgSqlWithoutTransaction + | PgSqlWithTransaction + deriving (Eq) + +data Status + = Init + | Changed + | Unchanged + +pgsqlConnectUrl :: URI -> IO Connection +pgsqlConnectUrl url = do + connResult <- try $ connectPostgreSQL (B.pack $ uriToString id url "") + let conn = getConn connResult + _ <- execute_ conn "SET client_min_messages TO WARNING" + return conn + where + getConn res = + case res of + Left e@SqlError {} -> + err $ + "Connection to SQL-Server failed" <> + showCode (decodeUtf8 (sqlErrorMsg e)) + Right conn -> conn + +pgsqlHandleErr :: SqlStmt -> SqlError -> IO () +pgsqlHandleErr stmt e = do + _ <- + err $ + "An SQL error occured while executing the following statement" <> + showCode (toSqlCode stmt) <\> + "The SQL-Server reported" <> + showCode (decodeUtf8 (sqlErrorMsg e)) <-> + "(Error Code: " <> + decodeUtf8 (sqlState e) <> + ")" <\> + "\nAll statements have been rolled back if possible." + return () diff --git a/src/Database/HamSql/Internal/Documentation.hs b/src/Database/HamSql/Internal/Documentation.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Documentation.hs @@ -0,0 +1,49 @@ +-- This file is part of HamSql +-- +-- Copyright 2014 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE TemplateHaskell #-} + +module Database.HamSql.Internal.Documentation where + +import Data.FileEmbed +import qualified Data.Text as T +import Data.Text.Encoding +import qualified Data.Text.IO as T.IO +import System.FilePath +import Text.Pandoc.Templates + +import Database.HamSql.Internal.Option +import Database.HamSql.Internal.Utils +import Database.HamSql.Setup +import Database.YamSql (Schema (..), SqlName (..)) + +templateFromFile :: FilePath -> IO Template +templateFromFile "DEFAULT.rst" = return templateDefaultSchema +templateFromFile fname = do + str <- T.IO.readFile fname + return $ templateCompile str + +templateCompile :: Text -> Template +templateCompile str = + case compileTemplate str of + (Left e) -> err $ tshow e + (Right t) -> t + +docWrite :: OptDoc -> Setup -> IO () +docWrite optDoc s = do + t <- templateFromFile (optTemplate optDoc) + _ <- mapM (docWriteSchema optDoc t) (fromMaybe [] $ setupSchemaData s) + return () + +docWriteSchema :: OptDoc -> Template -> Schema -> IO () +docWriteSchema optDoc t m = T.IO.writeFile path (renderTemplate t m) + where + path = + optOutputDir optDoc getName (schemaName m) <.> + takeExtension (optTemplate optDoc) + getName (SqlName n) = T.unpack n + +templateDefaultSchema :: Template +templateDefaultSchema = + templateCompile $ decodeUtf8 $(embedFile "data/doc-template.rst") diff --git a/src/Database/HamSql/Internal/InquireDeployed.hs b/src/Database/HamSql/Internal/InquireDeployed.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/InquireDeployed.hs @@ -0,0 +1,131 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +module Database.HamSql.Internal.InquireDeployed where + +import Data.Text (stripPrefix) +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.Types (PGArray (..), fromPGArray) + +import Database.HamSql.Internal.DbUtils +import Database.HamSql.Internal.Utils +import Database.HamSql.Setup +import Database.YamSql + +sqlManageSchemaJoin :: Text -> Text +sqlManageSchemaJoin schemaid = + " JOIN pg_namespace AS n " <\> " ON" <-> schemaid <-> "= n.oid AND " <\> + " NOT n.nspname LIKE 'pg_%' AND " <\> + " n.nspname NOT IN ('information_schema') " + +deployedTableConstrIds :: Connection -> IO [SqlIdContentSqoObj] +deployedTableConstrIds conn = map toSqlCodeId <$> query_ conn qry + where + toSqlCodeId (schema, table, constraint) = + SqlIdContentSqoObj "TABLE-CONSTRAINT" (schema <.> table) constraint + qry = + toQry $ + "SELECT n.nspname, t.relname, c.conname" <\> "FROM pg_constraint AS c" <\> + "JOIN pg_class AS t" <\> + " ON c.conrelid = t.oid" <-> + sqlManageSchemaJoin "c.connamespace" + +deployedDomainConstrIds :: Connection -> IO [SqlIdContentSqoObj] +deployedDomainConstrIds conn = map toSqlCodeId <$> query_ conn qry + where + toSqlCodeId (schema, table, constraint) = + SqlIdContentSqoObj "DOMAIN-CONSTRAINT" (schema <.> table) constraint + qry = + toQry $ + "SELECT n.nspname, d.typname, c.conname" <\> "FROM pg_constraint AS c " <\> + "JOIN pg_type AS d " <\> + " ON c.contypid = d.oid" <-> + sqlManageSchemaJoin "c.connamespace" + +-- | List SEQUENCE +deployedSequenceIds :: Connection -> IO [SqlIdContentSqo] +deployedSequenceIds conn = map toSqlCodeId <$> query_ conn qry + where + toSqlCodeId (s, t) = SqlIdContentSqo "SEQUENCE" $ s <.> t + qry = + toQry $ + "SELECT sequence_schema, sequence_name" <\> + "FROM information_schema.sequences" + +-- | List TABLE +deployedTableIds :: Connection -> IO [SqlIdContentSqo] +deployedTableIds conn = do + dat <- + query_ conn $ + toQry $ + "SELECT table_schema, table_name" <\> "FROM information_schema.tables" <\> + "WHERE table_type = 'BASE TABLE'" <\> + " AND table_schema NOT IN ('information_schema', 'pg_catalog')" + return $ map toSqlCodeId dat + where + toSqlCodeId (s, t) = SqlIdContentSqo "TABLE" $ s <.> t + +-- | List TABLE COLUMN +deployedTableColumnIds :: Connection -> IO [SqlIdContentSqoObj] +deployedTableColumnIds conn = map toSqlCodeId <$> query_ conn qry + where + toSqlCodeId (s, t, u) = SqlIdContentSqoObj "TABLE-COLUMN" (s <.> t) u + qry = + toQry $ + "SELECT table_schema, table_name, column_name" <\> + " FROM information_schema.columns" <\> + --" WHERE table_type = 'BASE TABLE'" ++ + " WHERE table_schema NOT IN ('information_schema', 'pg_catalog')" + +-- | List TYPE +deployedTypeIds :: Connection -> IO [SqlIdContentSqo] +deployedTypeIds conn = map toSqlCodeId <$> query_ conn qry + where + toSqlCodeId (schema, t) = SqlIdContentSqo "TYPE" $ schema <.> t + qry = + toQry $ + "SELECT user_defined_type_schema, user_defined_type_name" <\> + " FROM information_schema.user_defined_types" <\> + " WHERE user_defined_type_schema NOT IN ('information_schema', 'pg_catalog')" + +-- | List ROLE +deployedRoleIds :: Setup -> Connection -> IO [SqlIdContentObj] +deployedRoleIds setup conn = do + roles <- + query conn "SELECT rolname FROM pg_roles WHERE rolname LIKE ?" $ + Only $ prefix <> "%" + return $ map toSqlCodeId roles + where + prefix = setupRolePrefix' setup + unprefixed = + fromJustReason "Retrived role without prefix from database" . + stripPrefix prefix + toSqlCodeId (Only role) = SqlIdContentObj "ROLE" (SqlName $ unprefixed role) + +deployedDomainIds :: Connection -> IO [SqlIdContentSqo] +deployedDomainIds conn = map toSqlCodeId <$> query_ conn qry + where + toSqlCodeId (schema, domain) = SqlIdContentSqo "DOMAIN" $ schema <.> domain + qry = + toQry $ + "SELECT domain_schema, domain_name" <\> " FROM information_schema.domains" <\> + " WHERE domain_schema NOT IN ('information_schema', 'pg_catalog')" + +deployedFunctionIds :: Connection -> IO [SqlIdContentSqoArgtypes] +deployedFunctionIds conn = map toSqlCodeId <$> query_ conn qry + where + toSqlCodeId (schema, function, args) = + SqlIdContentSqoArgtypes + "FUNCTION" + (schema <.> function) + (fromPGArray args) + qry = + toQry $ + "SELECT n.nspname, p.proname, " <> + -- This part of the query includes a workaround for + -- + "ARRAY(SELECT UNNEST(p.proargtypes::regtype[]::varchar[]))" <\> + "FROM pg_proc AS p" <-> + sqlManageSchemaJoin "p.pronamespace" <\> + "WHERE p.probin IS NULL" diff --git a/src/Database/HamSql/Internal/Load.hs b/src/Database/HamSql/Internal/Load.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Load.hs @@ -0,0 +1,188 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +module Database.HamSql.Internal.Load where + +import Control.Exception +import Control.Monad +import qualified Data.ByteString as B +import Data.Char +import Data.Frontmatter +import Data.List +import Data.Maybe +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import Data.Yaml +import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents) +import System.FilePath.Posix (combine, dropFileName, takeFileName) + +import Database.HamSql.Internal.Option +import Database.HamSql.Internal.Utils +import Database.HamSql.Setup +import Database.YamSql +import Database.YamSql.Parser + +loadSetup :: OptCommon -> FilePath -> IO Setup +loadSetup opts filePath = do + setup <- readObjectFromFile opts filePath + setup' <- + loadSetupSchemas opts (dropFileName filePath) (initSetupInternal setup) + return $ applyTpl setup' + where + initSetupInternal s' = + s' + { setupSchemas = removeDuplicates $ setupSchemas s' + , setupSchemaData = Nothing + } + +-- Tries to loads all defined modules from defined module dirs +loadSetupSchemas :: OptCommon -> FilePath -> Setup -> IO Setup +loadSetupSchemas opts path s = do + schemaData <- loadSchemas opts path s [] (setupSchemas s) + return + s + { setupSchemaData = Just schemaData + } + +loadSchemas :: OptCommon + -> FilePath + -> Setup + -> [Schema] + -> [SqlName] + -> IO [Schema] +loadSchemas _ _ _ allLoaded [] = return allLoaded +loadSchemas optCom path setup loadedSchemas missingSchemas = do + schemas <- + sequence + [ loadSchema (T.unpack $ unsafePlainName schema) + | schema <- missingSchemas ] + let newDependencyNames = + nub . concat $ map (fromMaybe [] . schemaDependencies) schemas + let allLoadedSchemas = schemas ++ loadedSchemas + let newMissingDepencenyNames = newDependencyNames \\ map schemaName allLoadedSchemas + loadSchemas optCom path setup allLoadedSchemas newMissingDepencenyNames + where + loadSchema :: FilePath -> IO Schema + loadSchema schema = do + schemaPath <- findSchemaPath schema schemaDirs + readSchema optCom schemaPath + schemaDirs = map (combine path) (fromMaybe [""] $ setupSchemaDirs setup) + +findSchemaPath :: FilePath -> [FilePath] -> IO FilePath +findSchemaPath schema search = findDir search + where + findDir [] = + err $ "Schema '" <> tshow schema <> "' not found in " <> tshow search + findDir (d:ds) = do + let dir = combine d schema + dirExists <- doesDirectoryExist (dir :: FilePath) + if dirExists + then return dir + else findDir ds + +catchErrors + :: (FromJSON a, ToJSON a) + => FilePath -> a -> IO a +catchErrors filePath x = do + y <- try (forceToJson x) + return $ + case y of + Left (YamsqlException exc) -> + err $ "In file '" <> tshow filePath <> "': " <> exc + Right _ -> x + +isConfigDirFile :: FilePath -> Bool +isConfigDirFile xs = isAlphaNum (last fn) && head fn /= '.' + where + fn = takeFileName xs + +getFilesInDir :: FilePath -> IO [FilePath] +getFilesInDir path = do + conts <- getDirectoryContents path + let ordConts = sort conts + fmap (map (combine path)) (filterM doesFileExist' ordConts) + where + doesFileExist' relName = doesFileExist (combine path relName) + +selectFilesInDir :: (FilePath -> Bool) -> FilePath -> IO [FilePath] +selectFilesInDir ending dir = do + dirExists <- doesDirectoryExist dir + if not dirExists + then return [] + else do + files <- getFilesInDir dir + return $ filter ending files + +errorCheck :: Text -> Bool -> IO () +errorCheck errMsg False = err errMsg +errorCheck _ True = return () + +readSchema :: OptCommon -> FilePath -> IO Schema +readSchema opts md = do + doesDirectoryExist md >>= + errorCheck ("module dir does not exist: " <> tshow md) + schemaData <- readObjectFromFile opts schemaConfig + domains <- + do files <- confDirFiles "domains.d" + sequence + [ readObjectFromFile opts f + | f <- files ] + tables <- + do files <- confDirFiles "tables.d" + sequence + [ readObjectFromFile opts f + | f <- files ] + functions <- + do files <- confDirFiles "functions.d" + let ins x s = + x + { functionBody = Just s + } + sequence + [ readFunctionFromFile ins opts f + | f <- files ] + let schemaData' = + schemaData + { schemaDomains = maybeJoin (schemaDomains schemaData) (Just domains) + , schemaTables = maybeJoin (schemaTables schemaData) (Just tables) + , schemaFunctions = + maybeJoin (schemaFunctions schemaData) (Just functions) + } + return schemaData' + where + schemaConfig = combine md "schema.yml" + confDirFiles confDir = selectFilesInDir isConfigDirFile (combine md confDir) + +readObjectFromFile + :: (FromJSON a, ToJSON a) + => OptCommon -> FilePath -> IO a +readObjectFromFile opts file = do + b <- readYamSqlFile opts file + readObject file b + +readObject + :: (FromJSON a, ToJSON a) + => FilePath -> B.ByteString -> IO a +readObject file b = + catchErrors file $ + case decodeEither' b of + Left errMsg -> err $ "in yaml-file: " <> tshow file <> ": " <> tshow errMsg + Right obj -> obj + +readFunctionFromFile + :: (FromJSON a, ToJSON a) + => (a -> Text -> a) -> OptCommon -> FilePath -> IO a +readFunctionFromFile rpl opts file = do + b <- readYamSqlFile opts file + case parseFrontmatter b of + Done body yaml -> do + f <- readObject file yaml + return $ rpl f (decodeUtf8 body) + _ -> readObject file b + +readYamSqlFile :: OptCommon -> FilePath -> IO B.ByteString +readYamSqlFile opts file = do + fileExists <- doesFileExist file + unless fileExists $ err $ "Expected file existance: '" <> tshow file <> "'" + debug opts ("Reading file " <> tshow file) $ B.readFile file diff --git a/src/Database/HamSql/Internal/Option.hs b/src/Database/HamSql/Internal/Option.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Option.hs @@ -0,0 +1,156 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +module Database.HamSql.Internal.Option where + +import Control.Monad.Trans.Reader +import Data.Semigroup hiding (option) +import Options.Applicative +import Options.Applicative.Builder.Internal (HasMetavar, HasValue) +import Options.Applicative.Types + +-- helper functions +boolFlag :: Mod FlagFields Bool -> Parser Bool +boolFlag = flag False True + +val + :: (HasMetavar f, HasValue f) + => String -> Mod f String +val xs = value xs <> metavar ("\"" ++ xs ++ "\"") + +-- Global +parserInfoHamsql :: ParserInfo Command +parserInfoHamsql = + info + (helper <*> parserCommand) + (fullDesc <> progDesc "A YamSql interpreter and smart executor." <> + header "hamsql - YamSql interperter written in Haskell") + +-- Command +data Command + = Install OptCommon + OptCommonDb + OptInstall + | Upgrade OptCommon + OptCommonDb + | Doc OptCommon + OptDoc + | NoCommand OptNoCommand + deriving (Show) + +parserCommand :: Parser Command +parserCommand = + subparser + (command + "install" + (info + (parserCmdInstall <**> helper) + (progDesc "Installs the setup on a database from scratch.")) <> + command + "upgrade" + (info + (parserCmdUpgrade <**> helper) + (progDesc "Upgrades an existing setup on a database.")) <> + command + "doc" + (info + (parserCmdDoc <**> helper) + (progDesc "Produces a documentation of the setup."))) <|> + parserOptNoCommand + +parserCmdInstall :: Parser Command +parserCmdInstall = Install <$> parserOptCommon <*> parserOptCommonDb <*> parserOptInstall + +parserCmdUpgrade :: Parser Command +parserCmdUpgrade = Upgrade <$> parserOptCommon <*> parserOptCommonDb + +parserCmdDoc :: Parser Command +parserCmdDoc = Doc <$> parserOptCommon <*> parserOptDoc + +-- Commons +data OptCommon = OptCommon + { optSetup :: FilePath + , optVerbose :: Bool + , optDebug :: Bool + } deriving (Show) + +parserOptCommon :: Parser OptCommon +parserOptCommon = + OptCommon <$> + strOption + (long "setup" <> short 's' <> help "Setup file (yaml)" <> val "setup.yml" <> + action "file -X '!*.yml'" <> + action "directory") <*> + boolFlag (long "verbose" <> short 'v' <> help "Verbose") <*> + boolFlag (long "debug" <> help "Debug") + +-- Commons Execute +data OptCommonDb = OptCommonDb + { optEmulate :: Bool + , optPrint :: Bool + , optConnection :: String + , optPermitDataDeletion :: Bool + , optSqlLog :: Maybe FilePath + } deriving (Show) + +justStr :: ReadM (Maybe String) +justStr = Just <$> ReadM ask + +parserOptCommonDb :: Parser OptCommonDb +parserOptCommonDb = + OptCommonDb <$> + boolFlag (long "emulate" <> short 'e' <> help "Perform changes but rollback") <*> + boolFlag + (long "print" <> short 'p' <> help "Print SQL code instead of executing") <*> + strOption (long "connection" <> short 'c' <> val "postgresql://") <*> + boolFlag + (long "permit-data-deletion" <> help "Permit deletion of columns and tables") <*> + option + justStr + (long "sql-log" <> + help + ("If specified, log sql statements to given file. " <> + "Existing logfiles will be extended, not deleted.") <> + value Nothing <> + metavar "") + +-- Command Install +data OptInstall = OptInstall + { optDeleteExistingDatabase :: Bool + } deriving (Show) + +parserOptInstall :: Parser OptInstall +parserOptInstall = + OptInstall <$> + boolFlag + (long "delete-existing-database" <> short 'd' <> + help "Delete database if it allready exists") + +-- Command NoCommand +data OptNoCommand = OptNoCommand + { optVersion :: Bool + } deriving (Show) + +parserOptNoCommand :: Parser Command +parserOptNoCommand = + NoCommand . OptNoCommand <$> + flag' True (long "version" <> help "Prints program version") + +-- Command Doc +data OptDoc = OptDoc + { optOutputDir :: FilePath + , optTemplate :: FilePath + } deriving (Show) + +parserOptDoc :: Parser OptDoc +parserOptDoc = + OptDoc <$> + strOption + (long "output-dir" <> short 'o' <> val "docs/" <> action "directory") <*> + strOption + (long "template" <> short 't' <> val "DEFAULT.rst" <> + action "file -X '!*.html'" <> + action "file -X '!*.md'" <> + action "file -X '!*.rst'" <> + action "directory") diff --git a/src/Database/HamSql/Internal/PostgresCon.hs b/src/Database/HamSql/Internal/PostgresCon.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/PostgresCon.hs @@ -0,0 +1,275 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| += Implementation of Upgrades + +Upgrades are tricky. + +* DELETE statements must come first + +== Tables + +__TODO__: Delete tables and columns if the user excplicitly agrees to data loss. + +CREATE TABLE IF NOT EXISTS without any columns. + +CREATE columns with their type on demand. + +Always apply all ALTER COLUMN statments + +* SET DATA TYPE +* DROP DEFAULT +* SET DEFAULT +* SET/DROP NOT NULL + +__TODO__: Maybe bundle DROP/SET DEFAULT, such that they can't be reordered. + +Constrs are completly dropped an recreated. Would be cool to create PKs +first, to fix FK requirements right away. + +== Functions + +Many things can depend on functions (column defaults, table and domain +constraints). Therefore, they should all be deleted before deleting a function. + +Usually @CREATE OR REPLACE FUNCTION@ is used, such that no deletions occure. + +However, some function properties cannot be changed via CREATE OR REPLACE. A +known example this the change of the return type. In this case the +'sqlErrInvalidFunctionDefinition' will be catched and the function is deleted +and created again. + +== Domains + +Constrs are always deleted an recreated. + +Defaults are always set explicitly. + +Domains are deleted on demand. + +/The data type of a domain cannot be changed (at least in PostgreSQL)./ + +__TODO__: Issue error if domain type differs. + +== Roles + +Difficult since not schema qualified, but be have prefixes. + +__TODO__: LOGIN and PASSWORD are not implemented via ALTER ROLE + +__TODO__: Are role memberships revoked? + +== Sequences + +CREATE only defines name on demand. + +Properties all via ALTER SEQUENCE. + +-} +module Database.HamSql.Internal.PostgresCon where + +import Control.Exception +import Control.Monad (void, when) +import qualified Data.ByteString.Char8 as B +import Data.Maybe +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.Transaction + +import Network.URI (URI) + +import Database.HamSql.Internal.DbUtils +import Database.HamSql.Internal.InquireDeployed +import Database.HamSql.Internal.Option +import Database.HamSql.Internal.Stmt +import Database.HamSql.Internal.Stmt.Create +import Database.HamSql.Internal.Stmt.Domain +import Database.HamSql.Internal.Stmt.Drop +import Database.HamSql.Internal.Stmt.Function +import Database.HamSql.Internal.Stmt.Role +import Database.HamSql.Internal.Stmt.Sequence +import Database.HamSql.Internal.Stmt.Table +import Database.HamSql.Internal.Utils +import Database.HamSql.Setup +import Database.YamSql + +sqlErrInvalidFunctionDefinition :: B.ByteString +sqlErrInvalidFunctionDefinition = "42P13" + +pgsqlGetFullStatements :: OptCommon -> OptCommonDb -> Setup -> IO [SqlStmt] +pgsqlGetFullStatements optCom _ setup = + return $ catMaybes $ getSetupStatements optCom setup + +pgsqlDeleteAllStmt :: Connection -> IO [SqlStmt] +pgsqlDeleteAllStmt conn = do + domainConstrs <- deployedDomainConstrIds conn + tableConstrs <- deployedTableConstrIds conn + return $ + catMaybes $ + concatMap stmtsDropDomainConstr domainConstrs ++ + concatMap stmtsDropTableConstr tableConstrs + +pgsqlUpdateFragile :: Setup -> Connection -> [SqlStmt] -> IO [SqlStmt] +pgsqlUpdateFragile setup conn stmts = + correctStmts SqlCreateDomain deployedDomainIds stmtsDropDomain stmts >>= + correctStmts SqlCreateTable deployedTableIds stmtsDropTable >>= + correctStmts SqlAddColumn deployedTableColumnIds stmtsDropTableColumn >>= + correctStmts SqlCreateSequence deployedSequenceIds stmtsDropSequence >>= + correctStmts SqlCreateRole (deployedRoleIds setup) (stmtsDropRole setup) >>= + dropResidual SqlCreateFunction deployedFunctionIds stmtsDropFunction + where + correctStmts + :: ToSqlId a + => SqlStmtType + -> (Connection -> IO [a]) + -> (a -> [Maybe SqlStmt]) + -> [SqlStmt] + -> IO [SqlStmt] + correctStmts createType existingInquire dropStmtGenerator = + correctStatements createType (existingInquire conn) dropStmtGenerator + dropResidual + :: ToSqlId a + => SqlStmtType + -> (Connection -> IO [a]) + -> (a -> [Maybe SqlStmt]) + -> [SqlStmt] + -> IO [SqlStmt] + dropResidual t isf f xs = addDropResidual t (isf conn) f xs + +pgsqlDropAllRoleStmts :: OptCommonDb -> Setup -> IO [SqlStmt] +pgsqlDropAllRoleStmts optDb setup = do + conn <- pgsqlConnectUrl $ getConUrl optDb + addDropResidual + SqlCreateRole + (deployedRoleIds setup conn) + (stmtsDropRole setup) + [] + +-- DB Utils +pgsqlExecWithoutTransact :: OptCommonDb -> URI -> [SqlStmt] -> IO Connection +pgsqlExecWithoutTransact opt = pgsqlExecIntern opt PgSqlWithoutTransaction + +pgsqlExec :: OptCommonDb -> URI -> [SqlStmt] -> IO Connection +pgsqlExec opt = pgsqlExecIntern opt PgSqlWithTransaction + +pgsqlExecAndRollback :: OptCommonDb -> URI -> [SqlStmt] -> IO () +pgsqlExecAndRollback opt url stmts = do + conn <- pgsqlExecIntern opt PgSqlWithTransaction url stmts + rollback conn + +pgsqlExecStmtList + :: OptCommonDb + -> Status + -> [SqlStmt] -- ^ Statements that still need to be executed + -> [SqlStmt] -- ^ Statements that have failed during execution + -> Connection + -> IO () +pgsqlExecStmtList _ Init _ (x:_) _ = + err $ "supplied failed statements to (pgsqlExecStmtList _ Init): " <> tshow x +-- No remaining statements to execute +pgsqlExecStmtList _ _ [] [] conn = commit conn +pgsqlExecStmtList _ Unchanged [] failed conn = + pgsqlExecStmtHandled conn (head failed) +pgsqlExecStmtList opt Changed [] failed conn = + void $ pgsqlExecStmtList opt Unchanged failed [] conn +pgsqlExecStmtList opt status (x:xs) failed conn = do + savepoint <- newSavepoint conn + tryExec savepoint `catch` handleSqlError savepoint `catch` handleQueryError savepoint + where + tryExec savepoint = do + logStmt opt $ + "-- Executing " <> tshow (stmtIdType x) <> " for " <> stmtDesc x + pgsqlExecStmt conn x + logStmt opt $ toSqlCode x + proceed savepoint + -- action after execution has not failed + proceed savepoint = do + releaseSavepoint conn savepoint + pgsqlExecStmtList opt Changed xs failed conn + handleSqlError savepoint SqlError {sqlState = errCode} + | errCode == sqlErrInvalidFunctionDefinition = + skipQuery savepoint (stmtsDropFunction' (sqlId x) ++ [x]) + | otherwise = skipQuery savepoint [x] + handleQueryError savepoint QueryError {} = proceed savepoint + -- action after execution has failed + skipQuery savepoint stmts = do + logStmt opt "SAVEPOINT retry;" + logStmt opt $ toSqlCode x + logStmt opt "ROLLBACK TO SAVEPOINT retry;" + rollbackToSavepoint conn savepoint + releaseSavepoint conn savepoint + pgsqlExecStmtList opt forwardStatus xs (failed ++ stmts) conn + -- Init may not be forwarded to next iteration + forwardStatus = + case status of + Init -> Unchanged + s -> s + +pgsqlExecIntern :: OptCommonDb -> PgSqlMode -> URI -> [SqlStmt] -> IO Connection +pgsqlExecIntern opt mode connUrl xs = do + conn <- pgsqlConnectUrl connUrl + when (mode == PgSqlWithTransaction) $ + do begin conn + pgsqlExecStmtList opt Init xs [] conn + when (mode == PgSqlWithoutTransaction) $ mapM_ (pgsqlExecStmtHandled conn) xs + return conn + +addSqlStmtType + :: ToSqlId a + => SqlStmtType -- ^ statment + -> [a] -- ^ SQL ids that should become a "SqlStmtId" type to use + -> [SqlStmtId] +addSqlStmtType t = map (SqlStmtId t . sqlId) + +filterSqlStmtType :: SqlStmtType -> [SqlStmt] -> [SqlStmt] +filterSqlStmtType t xs = + [ x + | x <- xs + , stmtIdType x == t ] + +removeStmtsMatchingIds + :: [SqlStmtId] -- ^ Statement ids to remove + -> [SqlStmt] + -> [SqlStmt] +removeStmtsMatchingIds ids stmts = + [ stmt + | stmt <- stmts + , stmtId stmt `notElem` ids ] + +removeSqlIdBySqlStmts + :: ToSqlId a + => SqlStmtType -> [SqlStmt] -> [a] -> [a] +removeSqlIdBySqlStmts t xs is = + [ x + | x <- is + , sqlId x `notElem` ids ] + where + ids = map sqlId $ filterSqlStmtType t xs + +-- target set of sql ids +correctStatements + :: ToSqlId a + => SqlStmtType -- ^ install statements and the stmt type of interest + -> IO [a] -- ^ deployed (existing) elements + -> (a -> [Maybe SqlStmt]) -- ^ drop statment generator + -> [SqlStmt] -- ^ install statements, representing desired state + -> IO [SqlStmt] +correctStatements t iois f xs = do + is <- iois + xs' <- addDropResidual t iois f xs + return $ removeStmtsMatchingIds (addSqlStmtType t is) xs' + +addDropResidual + :: ToSqlId a + => SqlStmtType + -> IO [a] + -> (a -> [Maybe SqlStmt]) + -> [SqlStmt] + -> IO [SqlStmt] +addDropResidual t iois f xs = do + is <- iois + return $ xs ++ catMaybes (concatMap f (removeSqlIdBySqlStmts t xs is)) diff --git a/src/Database/HamSql/Internal/Stmt.hs b/src/Database/HamSql/Internal/Stmt.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Stmt.hs @@ -0,0 +1,139 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE GADTs #-} + +--{-# LANGUAGE FlexibleInstances #-} +module Database.HamSql.Internal.Stmt where + +import qualified Data.Text as T +import Database.PostgreSQL.Simple.FromField + +import Database.HamSql.Internal.Utils +import Database.YamSql + +data SqlStmtId = SqlStmtId + { stmtType :: SqlStmtType + , stmtSqlId :: SqlId + } deriving (Eq, Ord) + +instance Show SqlStmtId where + show (SqlStmtId x y) = "(SqlStmtId " ++ show x ++ " " ++ show y ++ ")" + +data SqlStmt = + SqlStmt SqlStmtId + Text + deriving (Show) + +stmtId :: SqlStmt -> SqlStmtId +stmtId (SqlStmt x _) = x + +stmtBody :: SqlStmt -> Text +stmtBody (SqlStmt _ x) = x + +stmtIdType :: SqlStmt -> SqlStmtType +stmtIdType (SqlStmt x _) = stmtType x + +stmtDesc :: SqlStmt -> Text +stmtDesc stmt = sqlIdType (sqlId stmt) <-> sqlIdCode stmt + +instance Eq SqlStmt where + x == y = stmtId x == stmtId y + +instance Ord SqlStmt where + x `compare` y = stmtId x `compare` stmtId y + +instance ToSqlId SqlStmt where + sqlId = stmtSqlId . stmtId + +newSqlStmtId + :: (ToSqlId a) + => SqlStmtType -> a -> SqlStmtId +newSqlStmtId x y = SqlStmtId x (sqlId y) + +newSqlStmt + :: (ToSqlId a) + => SqlStmtType -> a -> Text -> Maybe SqlStmt +newSqlStmt t o b = Just $ SqlStmt (newSqlStmtId t o) b + +sqlPrinter :: [SqlStmt] -> Text +sqlPrinter xs = T.concat $ map toSqlCode xs + +instance FromField SqlType where + fromField x y = SqlType <$> fromField x y + +instance FromField SqlName where + fromField x y = SqlName <$> fromField x y + +-- | More like always perform unfiltered after delete +allowInUpgrade :: SqlStmt -> Bool +allowInUpgrade x = + case stmtIdType x of + SqlPreInstall -> False + SqlPostInstall -> False + _ -> True + +stmtRequiresPermitDeletion :: SqlStmt -> Bool +stmtRequiresPermitDeletion x = + case stmtIdType x of + SqlDropDatabase -> True + SqlDropTable -> True + SqlDropTableColumn -> True + _ -> False + +data SqlStmtType + = SqlDropDatabase + | SqlCreateDatabase + | SqlPre + | SqlPreInstall + | SqlDropRole + | SqlCreateRole + | SqlAlterRole + | SqlRoleMembership + | SqlCreateSchema + | SqlCreateDomain + | SqlCreateType + -- DROP CONSTRAINTS + | SqlDropTableConstr + | SqlDropDomainConstr + | SqlDropSequence + -- DROP FUNCTION + | SqlDropTableColumn + | SqlDropTable + | SqlDropFunction + -- SEQUENCE + | SqlCreateSequence + -- TABLE + | SqlCreateTable + | SqlAddColumn + | SqlAlterTable + | SqlDropColumnDefault + | SqlAlterColumn + -- ALTER SEQUENCE + | SqlAlterSequence + -- FUNCTION + | SqlDropDomain + | SqlDropType + | SqlCreateFunction + | SqlInherit + | SqlAddTableConstr + | SqlCreatePrimaryKeyConstr + | SqlCreateUniqueConstr + | SqlCreateForeignKeyConstr + | SqlCreateCheckConstr + | SqlAddDefault + -- TRIGGER + | SqlCreateTrigger + | SqlPriv + | SqlComment + | SqlUnclassified + | SqlPostInstallAndUpgrade + | SqlPostInstall + deriving (Eq, Ord, Show) + +instance ToSqlCode SqlStmt where + toSqlCode x = stmtBody x <> ";\n" + +toSqlCodeString :: Text -> Text +toSqlCodeString xs = "'" <> T.replace "'" "''" xs <> "'" diff --git a/src/Database/HamSql/Internal/Stmt/Basic.hs b/src/Database/HamSql/Internal/Stmt/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Stmt/Basic.hs @@ -0,0 +1,19 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +module Database.HamSql.Internal.Stmt.Basic + ( module Database.HamSql.Internal.Stmt.Commons + , module Database.HamSql.Internal.Option + , module Database.HamSql.Internal.Stmt + , module Database.HamSql.Internal.Utils + , module Database.HamSql.Setup + , module Database.YamSql + ) where + +import Database.HamSql.Internal.Option +import Database.HamSql.Internal.Stmt +import Database.HamSql.Internal.Stmt.Commons +import Database.HamSql.Internal.Utils +import Database.HamSql.Setup +import Database.YamSql diff --git a/src/Database/HamSql/Internal/Stmt/Commons.hs b/src/Database/HamSql/Internal/Stmt/Commons.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Stmt/Commons.hs @@ -0,0 +1,25 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +module Database.HamSql.Internal.Stmt.Commons where + +import Database.HamSql.Internal.Stmt +import Database.HamSql.Internal.Utils +import Database.HamSql.Setup +import Database.YamSql + +stmtCommentOn + :: (ToSqlId a) + => a -> Text -> Maybe SqlStmt +stmtCommentOn obj comment = + newSqlStmt SqlComment obj $ + "COMMENT ON " <> rewriteType (sqlIdType (sqlId obj)) <> " " <> sqlIdCode obj <> + " IS " <> + toSqlCodeString comment + where + rewriteType "TABLE-COLUMN" = "COLUMN" + rewriteType xs = xs + +prefixedRole :: Setup -> SqlName -> Text +prefixedRole setup role = toSqlCode ((SqlName $ setupRolePrefix' setup) // role) diff --git a/src/Database/HamSql/Internal/Stmt/Create.hs b/src/Database/HamSql/Internal/Stmt/Create.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Stmt/Create.hs @@ -0,0 +1,81 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2015 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +module Database.HamSql.Internal.Stmt.Create where + +import Data.Maybe + +import Database.HamSql.Internal.Option +import Database.HamSql.Internal.Stmt +import Database.HamSql.Internal.Stmt.Basic +import Database.HamSql.Internal.Stmt.Commons () +import Database.HamSql.Internal.Stmt.Domain () +import Database.HamSql.Internal.Stmt.Function () +import Database.HamSql.Internal.Stmt.Role () +import Database.HamSql.Internal.Stmt.Schema () +import Database.HamSql.Internal.Stmt.Sequence () +import Database.HamSql.Internal.Stmt.Table () +import Database.HamSql.Internal.Stmt.Type () + +fa + :: Show b + => Maybe b -> Schema -> [SetupElement] +fa source schema = + [toSetupElement $ SqlContextObj schema] ++ + toElemList' SqlContextObj schemaRoles schema ++ + toElemList SqlContextSqo schemaDomains schema ++ + toElemList SqlContextSqoArgtypes schemaFunctions schema ++ + toElemList SqlContextSqo schemaSequences schema ++ + toElemList SqlContextSqo schemaTables schema ++ + toElemList SqlContextSqo schemaTypes schema ++ + concat + [ map (toSetupElement . SqlContextSqoObj schema table) $ tableColumns table + | table <- fromMaybe [] $ schemaTables schema ] + where + toSetupElement x = SetupElement x source + toElemList x y = maybeMap (toSetupElement . x schema) . y + toElemList' x y = maybeMap (toSetupElement . x) . y + +fb :: SetupContext -> [SetupElement] -> [Maybe SqlStmt] +fb x = concatMap (toSqlStmts x) + +emptyName :: SqlId +emptyName = SqlId $ SqlIdContentObj "?" $ SqlName "" + +sqlAddTransact :: [SqlStmt] -> [SqlStmt] +sqlAddTransact xs = + catMaybes [newSqlStmt SqlUnclassified emptyName "BEGIN TRANSACTION"] ++ + xs ++ catMaybes [newSqlStmt SqlUnclassified emptyName "COMMIT"] + +-- | create database +sqlCreateDatabase :: Bool -> SqlName -> [Maybe SqlStmt] +sqlCreateDatabase deleteDatabase dbName = + [ sqlDelete deleteDatabase + , newSqlStmt SqlCreateDatabase (SqlId $ SqlIdContentObj "DATABASE" dbName) $ + "CREATE DATABASE " <> toSqlCode dbName + , newSqlStmt + SqlCreateDatabase + (SqlId $ SqlIdContentObj "DATABASE" dbName) + "ALTER DEFAULT PRIVILEGES REVOKE EXECUTE ON FUNCTIONS FROM PUBLIC" + ] + where + sqlDelete True = + newSqlStmt SqlDropDatabase (SqlId $ SqlIdContentObj "DATABASE" dbName) $ + "DROP DATABASE IF EXISTS" <-> toSqlCode dbName + sqlDelete False = Nothing + +-- | Setup +getSetupStatements :: OptCommon -> Setup -> [Maybe SqlStmt] +getSetupStatements opts s = + debug opts "stmtInstallSetup" $ + [getStmt $ setupPreCode s] ++ schemaStatements ++ [getStmt $ setupPostCode s] + where + schemaStatements = + concat $ maybeMap (getSchemaStatements opts s) (setupSchemaData s) + getStmt (Just code) = newSqlStmt SqlPre emptyName code + getStmt Nothing = Nothing + +getSchemaStatements :: OptCommon -> Setup -> Schema -> [Maybe SqlStmt] +getSchemaStatements _ setup s = + fb (SetupContext setup) $ fa (Just ("src" :: String)) s diff --git a/src/Database/HamSql/Internal/Stmt/Domain.hs b/src/Database/HamSql/Internal/Stmt/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Stmt/Domain.hs @@ -0,0 +1,45 @@ +-- This file is part of HamSql +-- +-- Copyright 2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE FlexibleInstances #-} + +module Database.HamSql.Internal.Stmt.Domain where + +import Database.HamSql.Internal.Stmt.Basic + +stmtsDropDomain :: SqlIdContentSqo -> [Maybe SqlStmt] +stmtsDropDomain x = [newSqlStmt SqlDropDomain x $ "DROP DOMAIN" <-> toSqlCode x] + +stmtsDropDomainConstr :: SqlIdContentSqoObj -> [Maybe SqlStmt] +stmtsDropDomainConstr x = + [ newSqlStmt SqlDropDomainConstr x $ + "ALTER DOMAIN" <-> sqlSqoIdCode x <-> "DROP CONSTRAINT" <-> + sqlSqoObjIdCode x + ] + +instance ToSqlStmts (SqlContextSqo Domain) where + toSqlStmts = stmtsDeployDomain + +stmtsDeployDomain :: SetupContext -> SqlContextSqo Domain -> [Maybe SqlStmt] +stmtsDeployDomain _ obj@SqlContextSqo {sqlSqoObject = d} = + stmtCreateDomain : + sqlDefault (domainDefault d) : maybeMap sqlCheck (domainChecks d) + where + stmtCreateDomain = + newSqlStmt SqlCreateDomain obj $ + "CREATE DOMAIN" <-> sqlIdCode obj <-> "AS" <-> toSqlCode (domainType d) + sqlCheck :: Check -> Maybe SqlStmt + sqlCheck c = + newSqlStmt SqlCreateCheckConstr obj $ + "ALTER DOMAIN" <-> sqlIdCode obj <-> "ADD CONSTRAINT" <-> + toSqlCode (checkName c) <-> + "CHECK (" <> + checkCheck c <> + ")" + sqlDefault Nothing = + newSqlStmt SqlAddDefault obj $ + "ALTER DOMAIN" <-> sqlIdCode obj <-> "DROP DEFAULT" + sqlDefault (Just def) = + newSqlStmt SqlAddDefault obj $ + "ALTER DOMAIN" <-> sqlIdCode obj <-> "SET DEFAULT" <-> def diff --git a/src/Database/HamSql/Internal/Stmt/Drop.hs b/src/Database/HamSql/Internal/Stmt/Drop.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Stmt/Drop.hs @@ -0,0 +1,15 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +module Database.HamSql.Internal.Stmt.Drop where + +import Database.HamSql.Internal.Stmt.Basic + +-- TABLE +stmtsDropTable :: SqlIdContentSqo -> [Maybe SqlStmt] +stmtsDropTable t = [newSqlStmt SqlDropTable t $ "DROP TABLE " <> toSqlCode t] + +-- TYPE +stmtsDropType :: SqlIdContentSqo -> [Maybe SqlStmt] +stmtsDropType t = [newSqlStmt SqlDropType t $ "DROP TYPE " <> toSqlCode t] diff --git a/src/Database/HamSql/Internal/Stmt/Function.hs b/src/Database/HamSql/Internal/Stmt/Function.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Stmt/Function.hs @@ -0,0 +1,104 @@ +-- This file is part of HamSql +-- +-- Copyright 2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE FlexibleInstances #-} + +module Database.HamSql.Internal.Stmt.Function where + +import Data.Maybe +import qualified Data.Text as T + +import Database.HamSql.Internal.Stmt.Basic + +stmtsDropFunction' :: SqlId -> [SqlStmt] +stmtsDropFunction' x = + catMaybes [newSqlStmt SqlDropFunction x $ "DROP FUNCTION " <> toSqlCode x] + +stmtsDropFunction :: SqlIdContentSqoArgtypes -> [Maybe SqlStmt] +stmtsDropFunction x = map Just $ stmtsDropFunction' $ sqlId x + +instance ToSqlStmts (SqlContextSqoArgtypes Function) where + toSqlStmts = stmtsDeployFunction + +stmtsDeployFunction :: SetupContext + -> SqlContextSqoArgtypes Function + -> [Maybe SqlStmt] +stmtsDeployFunction SetupContext {setupContextSetup = setup} obj@SqlContextSqoArgtypes {sqlSqoArgtypesObject = f} = + stmtCreateFunction : + sqlSetOwner (functionOwner f) : + stmtComment : maybeMap sqlStmtGrantExecute (functionPrivExecute f) +--name = schemaName m <.> functionName f + where + sqlStmtGrantExecute u = newSqlStmt SqlPriv obj $ sqlGrantExecute u + sqlGrantExecute u = + "GRANT EXECUTE ON FUNCTION \n" <> sqlIdCode obj <> "\nTO " <> + prefixedRole setup u + stmtCreateFunction = + newSqlStmt SqlCreateFunction obj $ + --(maybeMap variableType (functionParameters f)) $ + "CREATE OR REPLACE FUNCTION " <> sqlFunctionIdentifierDef <> "\n" <> + "RETURNS" <-> + toSqlCode (functionReturns f) <> + sqlReturnsColumns (functionReturnsColumns f) <> + "\nLANGUAGE " <> + sqlLanguage (functionLanguage f) <> + "\nSECURITY " <> + sqlSecurity (functionSecurityDefiner f) <> + "\nAS\n$BODY$\n" <> + sqlBody <> + "\n$BODY$\n" + stmtComment = stmtCommentOn obj $ toSqlCodeString (functionDescription f) + sqlSetOwner (Just o) = + newSqlStmt SqlPriv obj $ + "ALTER FUNCTION " <> sqlIdCode obj <> "OWNER TO " <> prefixedRole setup o + sqlSetOwner Nothing = Nothing + sqlFunctionIdentifierDef = + (toSqlCode . sqlIdNameOnly) obj <> "(\n" <> + T.intercalate ",\n" (maybeMap sqlParameterDef (functionParameters f)) <> + "\n)" + -- function parameter + sqlParameterDef p = + toSqlCode (variableName p) <-> toSqlCode (variableType p) <-> + sqlParamDefault (variableDefault p) + where + sqlParamDefault Nothing = "" + sqlParamDefault (Just x) = "DEFAULT" <-> x + -- If function returns a table, use service for field definition + sqlReturnsColumns cs + | toSqlCode (functionReturns f) == "TABLE" = + " (" <\> T.intercalate ",\n" (maybeMap sqlReturnsColumn cs) <> ") " + | otherwise = "" + sqlReturnsColumn c = + toSqlCode (parameterName c) <> " " <> toSqlCode (parameterType c) + -- If language not defined, use service for variable definitions + sqlBody + | isNothing (functionLanguage f) = + "DECLARE" <\> sqlVariables (functionVariables f) <> "BEGIN" <\> body <\> + "END;" + | otherwise = body + where + body = + T.intercalate "\n" preludes <> fromMaybe "" (functionBody f) <> + T.intercalate "\n" postludes + preludes :: [Text] + preludes = + catMaybes $maybeMap functiontplBodyPrelude (functionTemplateData f) + postludes :: [Text] + postludes = + catMaybes $maybeMap functiontplBodyPostlude (functionTemplateData f) + -- Service for variable definitions + sqlVariables Nothing = "" + sqlVariables (Just vs) = T.concat (map sqlVariable vs) + sqlVariable v = + toSqlCode (variableName v) <-> toSqlCode (variableType v) <-> + sqlVariableDefault (variableDefault v) <> + ";\n" + sqlVariableDefault Nothing = "" + sqlVariableDefault (Just d) = ":=" <-> d + -- SECURITY + sqlSecurity (Just True) = "DEFINER" + sqlSecurity _ = "INVOKER" + -- LANGUAGE + sqlLanguage Nothing = "plpgsql" + sqlLanguage (Just lang) = lang diff --git a/src/Database/HamSql/Internal/Stmt/Role.hs b/src/Database/HamSql/Internal/Stmt/Role.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Stmt/Role.hs @@ -0,0 +1,40 @@ +-- This file is part of HamSql +-- +-- Copyright 2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE FlexibleInstances #-} + +module Database.HamSql.Internal.Stmt.Role where + +import Database.HamSql.Internal.Stmt.Basic + +stmtsDropRole :: Setup -> SqlIdContentObj -> [Maybe SqlStmt] +stmtsDropRole setup role = + [ newSqlStmt SqlDropRole role $ + "DROP ROLE " <> prefixedRole setup (sqlObjId role) + ] + +instance ToSqlStmts (SqlContextObj Role) where + toSqlStmts SetupContext {setupContextSetup = setup} obj@SqlContextObj {sqlObjectObject = r} = + [stmtCreateRole, stmtAlterRole, stmtCommentRole] ++ + maybeMap sqlRoleMembership (roleMemberIn r) + where + stmtCreateRole = + newSqlStmt SqlCreateRole obj $ "CREATE ROLE" <-> prefix (roleName r) + stmtAlterRole = + newSqlStmt SqlAlterRole obj $ + "ALTER ROLE" <-> prefix (roleName r) <-> "WITH" <-> + sqlLogin (roleLogin r) <-> + sqlPassword (rolePassword r) + stmtCommentRole = + newSqlStmt SqlComment obj $ + "COMMENT ON ROLE" <-> prefix (roleName r) <-> "IS" <-> + toSqlCodeString (roleDescription r) + sqlRoleMembership group = + newSqlStmt SqlRoleMembership obj $ + "GRANT" <-> prefix group <-> "TO" <-> prefix (roleName r) + sqlLogin (Just True) = "LOGIN" + sqlLogin _ = "NOLOGIN" + sqlPassword Nothing = "PASSWORD NULL" + sqlPassword (Just p) = "ENCRYPTED PASSWORD '" <> p <> "' " + prefix role = prefixedRole setup role diff --git a/src/Database/HamSql/Internal/Stmt/Schema.hs b/src/Database/HamSql/Internal/Stmt/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Stmt/Schema.hs @@ -0,0 +1,53 @@ +-- This file is part of HamSql +-- +-- Copyright 2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE FlexibleInstances #-} + +module Database.HamSql.Internal.Stmt.Schema where + +import Database.HamSql.Internal.Stmt.Basic + +instance ToSqlStmts (SqlContextObj Schema) where + toSqlStmts SetupContext {setupContextSetup = setup} obj@SqlContextObj {sqlObjectObject = s} = + [ newSqlStmt SqlCreateSchema obj $ + "CREATE SCHEMA IF NOT EXISTS" <-> sqlIdCode obj + , postInst $ schemaExecPostInstall s + , postInstallAndUpgrade $ schemaExecPostInstallAndUpgrade s + , stmtCommentOn obj (schemaDescription s) + ] ++ + maybeMap privUsage (schemaPrivUsage s) ++ + maybeMap privSelectAll (schemaPrivSelectAll s) ++ + maybeMap privInsertAll (schemaPrivInsertAll s) ++ + maybeMap privUpdateAll (schemaPrivUpdateAll s) ++ + maybeMap privDeleteAll (schemaPrivDeleteAll s) ++ + maybeMap privSequenceAll (schemaPrivSequenceAll s) ++ + maybeMap privExecuteAll (schemaPrivExecuteAll s) ++ + concat (maybeMap privAllAll (schemaPrivAllAll s)) + where + postInst Nothing = Nothing + postInst (Just xs) = newSqlStmt SqlPostInstall obj xs + postInstallAndUpgrade Nothing = Nothing + postInstallAndUpgrade (Just xs) = + newSqlStmt SqlPostInstallAndUpgrade obj xs + priv p r = + newSqlStmt SqlPriv obj $ + "GRANT " <> p <> " " <> sqlIdCode obj <> " TO " <> prefixedRole setup r + privUsage = priv "USAGE ON SCHEMA" + privSelectAll = priv "SELECT ON ALL TABLES IN SCHEMA" + privInsertAll = priv "INSERT ON ALL TABLES IN SCHEMA" + privUpdateAll = priv "UPDATE ON ALL TABLES IN SCHEMA" + privDeleteAll = priv "DELETE ON ALL TABLES IN SCHEMA" + privSequenceAll = priv "USAGE ON ALL SEQUENCES IN SCHEMA" + privExecuteAll = priv "EXECUTE ON ALL FUNCTIONS IN SCHEMA" + privAllAll d = + map + (\x -> x d) + [ privUsage + , privSelectAll + , privInsertAll + , privUpdateAll + , privDeleteAll + , privSequenceAll + , privExecuteAll + ] diff --git a/src/Database/HamSql/Internal/Stmt/Sequence.hs b/src/Database/HamSql/Internal/Stmt/Sequence.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Stmt/Sequence.hs @@ -0,0 +1,45 @@ +-- This file is part of HamSql +-- +-- Copyright 2015-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE FlexibleInstances #-} + +module Database.HamSql.Internal.Stmt.Sequence where + +import Database.HamSql.Internal.Stmt.Basic + +stmtsDropSequence :: SqlIdContentSqo -> [Maybe SqlStmt] +stmtsDropSequence x = + [newSqlStmt SqlDropSequence x $ "DROP SEQUENCE " <> toSqlCode x] + +instance ToSqlStmts (SqlContextSqo Sequence) where + toSqlStmts = stmtsDeploySequence + +stmtsDeploySequence :: SetupContext -> SqlContextSqo Sequence -> [Maybe SqlStmt] +stmtsDeploySequence _ obj@SqlContextSqo {sqlSqoObject = s} = + [ newSqlStmt SqlCreateSequence obj $ "CREATE SEQUENCE" <-> sqlIdCode obj + , newSqlStmt SqlAlterSequence obj $ + "ALTER SEQUENCE" <-> sqlIdCode obj <-> incrementBy (sequenceIncrement s) <-> + minValue (sequenceMinValue s) <-> + maxValue (sequenceMaxValue s) <-> + startValue (sequenceStartValue s) <-> + cache (sequenceCache s) <-> + cycled (sequenceCycle s) <-> + ownedByColumn (sequenceOwnedByColumn s) + ] + where + incrementBy Nothing = "INCREMENT BY 1" + incrementBy (Just i) = "INCREMENT BY " <> tshow i + minValue Nothing = "NO MINVALUE" + minValue (Just i) = "MINVALUE " <> tshow i + maxValue Nothing = "NO MAXVALUE" + maxValue (Just i) = "MAXVALUE " <> tshow i + startValue Nothing = "" + startValue (Just i) = "START WITH " <> tshow i + cache Nothing = "CACHE 1" + cache (Just i) = "CACHE " <> tshow i + cycled Nothing = "NO CYCLE" + cycled (Just False) = "NO CYCLE" + cycled (Just True) = "CYCLE" + ownedByColumn Nothing = "OWNED BY NONE" + ownedByColumn (Just n) = "OWNED BY " <> toSqlCode n diff --git a/src/Database/HamSql/Internal/Stmt/Table.hs b/src/Database/HamSql/Internal/Stmt/Table.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Stmt/Table.hs @@ -0,0 +1,230 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE FlexibleInstances #-} + +module Database.HamSql.Internal.Stmt.Table where + +import qualified Data.Text as T + +import Database.HamSql.Internal.Stmt.Basic +import Database.HamSql.Internal.Stmt.Sequence + +-- | Assuming that CASCADE will only cause other constraints to be deleted +-- | Required since foreign keys may depend on other keys +stmtsDropTableConstr :: SqlIdContentSqoObj -> [Maybe SqlStmt] +stmtsDropTableConstr x = + [ newSqlStmt SqlDropTableConstr x $ + "ALTER TABLE" <-> sqlSqoIdCode x <-> "DROP CONSTRAINT IF EXISTS" <-> + sqlSqoObjIdCode x <-> + "CASCADE" + ] + +stmtsDropTableColumn :: SqlIdContentSqoObj -> [Maybe SqlStmt] +stmtsDropTableColumn x = + [ newSqlStmt SqlDropTableColumn x $ + "ALTER TABLE" <-> sqlSqoIdCode x <-> "DROP COLUMN" <-> sqlSqoObjIdCode x + ] + +columnObj :: SqlContextSqo Table -> Column -> SqlContextSqoObj Table Column +columnObj x y = + SqlContextSqoObj + { sqlSqoObjectSchema = sqlSqoSchema x + , sqlSqoObject1 = sqlSqoObject x + , sqlSqoObject2 = y + } + +instance ToSqlStmts (SqlContextSqoObj Table Column) where + toSqlStmts _ _ = [] + +instance ToSqlStmts (SqlContextSqo Table) where + toSqlStmts = stmtsDeployTable + +stmtsDeployTable :: SetupContext -> SqlContextSqo Table -> [Maybe SqlStmt] +stmtsDeployTable context@SetupContext {setupContextSetup = setup} obj@SqlContextSqo {sqlSqoSchema = m + ,sqlSqoObject = t} + -- table with columns + = + [ stmtCreateTable + -- table comment + , stmtCommentOn obj (tableDescription t) + ] ++ + map stmtAddColumn columns ++ + map stmtAlterColumnType columns ++ + map stmtDropDefault columns ++ + map stmtAddColumnDefault columns ++ + map stmtAlterColumnNull columns ++ + concatMap stmtAddColumnCheck columns ++ + concat (sequences (tableColumns t)) ++ + maybeMap stmtCheck (tableChecks t) ++ + -- column comments + map (\c -> stmtCommentOn (columnObj obj c) (columnDescription c)) columns ++ + -- grant rights to roles + maybeMap (sqlGrant "SELECT") (tablePrivSelect t) ++ + maybeMap (sqlGrant "UPDATE") (tablePrivUpdate t) ++ + maybeMap (sqlGrant "INSERT") (tablePrivInsert t) ++ + maybeMap (sqlGrant "DELETE") (tablePrivDelete t) ++ + -- primary key + [sqlAddPrimaryKey (tablePrimaryKey t)] ++ + -- mult column unique + maybeMap sqlUniqueConstr (tableUnique t) ++ + -- single column FKs (references) + map sqlAddForeignKey columns ++ + -- inheritance + maybeMap sqlAddInheritance (tableInherits t) ++ + -- multi column unique constraints + map sqlColumnUnique columns ++ + -- multi column FKs + maybeMap sqlAddForeignKey' (tableForeignKeys t) + where + stmtCreateTable = + newSqlStmt SqlCreateTable obj $ + "CREATE TABLE IF NOT EXISTS" <-> sqlIdCode obj <> " ()" + stmtCheck c = + newSqlStmt SqlCreateCheckConstr obj $ + "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <> + constrName (checkName c) <> + " CHECK (" <> + checkCheck c <> + ")" + -- COLUMNS + sqlAlterColumn c = + "ALTER TABLE " <> sqlIdCode obj <> " ALTER COLUMN " <> + toSqlCode (columnName c) <> + " " + stmtAddColumn c = + newSqlStmt SqlAddColumn (columnObj obj c) $ + "ALTER TABLE" <-> sqlIdCode obj <-> "ADD COLUMN" <-> + toSqlCode (columnName c) <-> + toSqlCode (columnType c) + stmtAlterColumnType c = + newSqlStmt SqlAlterColumn obj $ + sqlAlterColumn c <> "SET DATA TYPE " <> toSqlCode (columnType c) + stmtDropDefault c = + newSqlStmt SqlDropColumnDefault obj $ sqlAlterColumn c <> "DROP DEFAULT" + stmtAddColumnCheck c = maybeMap stmtCheck (columnChecks c) + stmtAlterColumnNull c = + newSqlStmt SqlAlterColumn obj $ + sqlAlterColumn c <> sqlSetNull (columnNull c) + where + sqlSetNull Nothing = sqlSetNull (Just False) + sqlSetNull (Just False) = "SET NOT NULL" + sqlSetNull (Just True) = "DROP NOT NULL" + stmtAddColumnDefault c = columnDefault c >>= sqlDefault + where + sqlDefault d = + newSqlStmt SqlAddDefault (columnObj obj c) $ + sqlAlterColumn c <> "SET DEFAULT " <> d + -- SERIAL + columns = map injectSerialParameters (tableColumns t) + injectSerialParameters c + | columnIsSerial c = + c + { columnType = SqlType "integer" + , columnDefault = + Just $ "nextval('" <> sqlIdCode (serialSqlContext c) <> "')" + } + | otherwise = c + columnIsSerial c = toSqlCode (columnType c) == "SERIAL" + -- do not change this, it is PostgreSQL internal convention + serialSequenceName c = + tableName t // SqlName "_" // columnName c // SqlName "_seq" + sequences cs = map serial (filter columnIsSerial cs) + where + serial c = stmtsDeploySequence context (serialSqlContext c) + serialSqlContext c = + SqlContextSqo + { sqlSqoSchema = m + , sqlSqoObject = + Sequence + { sequenceName = serialSequenceName c + , sequenceIncrement = Nothing + , sequenceMinValue = Nothing + , sequenceMaxValue = Nothing + , sequenceStartValue = Nothing + , sequenceCache = Nothing + , sequenceCycle = Nothing + , sequenceOwnedByColumn = Just $ SqlName $ sqlIdCode (columnObj obj c) + } + } + -- PRIMARY KEY + sqlAddPrimaryKey :: [SqlName] -> Maybe SqlStmt + sqlAddPrimaryKey [] = Nothing + sqlAddPrimaryKey ks = + newSqlStmt SqlCreatePrimaryKeyConstr (constrId (SqlName "primary_key")) $ + "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <> + constrName (SqlName "primary_key") <> + " PRIMARY KEY (" <> + T.intercalate ", " (map toSqlCode ks) <> + ")" + sqlUniqueConstr :: UniqueKey -> Maybe SqlStmt + sqlUniqueConstr ks = + newSqlStmt SqlCreateUniqueConstr (constrId (uniquekeyName ks)) $ + "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <> + constrName (uniquekeyName ks) <> + " UNIQUE (" <> + T.intercalate ", " (map toSqlCode (uniquekeyColumns ks)) <> + ")" + --sqlCheck c = + -- " CONSTRAINT " <> name (checkName c) <> " CHECK (" <> checkCheck c <> ")" + sqlAddForeignKey :: Column -> Maybe SqlStmt + sqlAddForeignKey Column {columnReferences = Nothing} = Nothing + sqlAddForeignKey c@Column {columnReferences = (Just ref)} = + newSqlStmt SqlCreateForeignKeyConstr (constrId (columnName c)) $ + "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <> + constrName (columnName c) <> + " FOREIGN KEY (" <> + toSqlCode (columnName c) <> + ")" <> + " REFERENCES " <> + toSqlCode' (init $ expSqlName ref) <> + " (" <> + toSqlCode (last $ expSqlName ref) <> + ")" <> + sqlOnRefUpdate (columnOnRefUpdate c) <> + sqlOnRefDelete (columnOnRefDelete c) + sqlAddForeignKey' :: ForeignKey -> Maybe SqlStmt + sqlAddForeignKey' fk = + newSqlStmt SqlCreateForeignKeyConstr (constrId (foreignkeyName fk)) $ + "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <> + constrName (foreignkeyName fk) <> + " FOREIGN KEY (" <> + T.intercalate ", " (map toSqlCode (foreignkeyColumns fk)) <> + ")" <> + " REFERENCES " <> + toSqlCode (foreignkeyRefTable fk) <> + " (" <> + T.intercalate ", " (map toSqlCode $ foreignkeyRefColumns fk) <> + ")" <> + sqlOnRefUpdate (foreignkeyOnUpdate fk) <> + sqlOnRefDelete (foreignkeyOnDelete fk) + sqlOnRefUpdate Nothing = "" + sqlOnRefUpdate (Just a) = " ON UPDATE " <> a + sqlOnRefDelete Nothing = "" + sqlOnRefDelete (Just a) = " ON DELETE " <> a + sqlGrant right role = + newSqlStmt + SqlPriv + obj + ("GRANT " <> right <> " ON TABLE " <> toSqlCode (tableName t) <> " TO " <> + prefixedRole setup role) + sqlAddInheritance :: SqlName -> Maybe SqlStmt + sqlAddInheritance n = + newSqlStmt SqlAlterTable obj $ + "ALTER TABLE " <> sqlIdCode obj <> " INHERIT " <> toSqlCode n + sqlColumnUnique c@Column {columnUnique = (Just True)} = + newSqlStmt SqlCreateUniqueConstr (constrId (columnName c)) $ + "ALTER TABLE " <> sqlIdCode obj <> " ADD CONSTRAINT " <> + constrName (columnName c) <> + " UNIQUE (" <> + toSqlCode (columnName c) <> + ")" + sqlColumnUnique _ = Nothing + -- tools + constrName a = toSqlCode (tableName t // SqlName "-" // a) + constrId a = + SqlIdContentSqoObj + "TABLE-CONSTRAINT" + (SqlName $ sqlIdCode obj) + (SqlName $ constrName a) diff --git a/src/Database/HamSql/Internal/Stmt/Type.hs b/src/Database/HamSql/Internal/Stmt/Type.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Stmt/Type.hs @@ -0,0 +1,27 @@ +-- This file is part of HamSql +-- +-- Copyright 2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE FlexibleInstances #-} + +module Database.HamSql.Internal.Stmt.Type where + +import qualified Data.Text as T + +import Database.HamSql.Internal.Stmt.Basic + +instance ToSqlStmts (SqlContextSqo Type) where + toSqlStmts = stmtsDeployType + +stmtsDeployType :: SetupContext -> SqlContextSqo Type -> [Maybe SqlStmt] +stmtsDeployType _ obj@SqlContextSqo {sqlSqoObject = t} = + [ newSqlStmt SqlCreateType obj $ + "CREATE TYPE" <-> sqlIdCode obj <-> "AS (" <> + T.intercalate ", " (map sqlElement (typeElements t)) <> + ")" + , stmtCommentOn obj (typeDescription t) + ] +-- ALTER TYPE name ALTER ATTRIBUTE attribute_name [ SET DATA ] TYPE data_type + where + sqlElement e = + toSqlCode (typeelementName e) <-> toSqlCode (typeelementType e) diff --git a/src/Database/HamSql/Internal/Utils.hs b/src/Database/HamSql/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Internal/Utils.hs @@ -0,0 +1,113 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +module Database.HamSql.Internal.Utils + ( module Data.Maybe + , module Database.HamSql.Internal.Utils + , Text + , (<>) + ) where + +import Data.List (group, intercalate, sort) +import Data.Maybe +import Data.Monoid ((<>)) +import Data.Text (Text, pack) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Debug.Trace +import System.Exit +import System.IO (stderr) +import System.IO.Unsafe +import Text.Groom + +import Database.HamSql.Internal.Option + +join :: [a] -> [[a]] -> [a] +join = intercalate + +err :: Text -> a +err xs = + unsafePerformIO $ + do TIO.hPutStrLn stderr ("error: " <> xs) + exitWith $ ExitFailure 1 + +warn :: Text -> a -> a +warn = msg "warning" + +warn' :: Text -> IO () +warn' = msg' "warning" + +msg :: Text -> Text -> a -> a +msg typ xs ys = + unsafePerformIO $ + do msg' typ xs + return ys + +msg' :: Text -> Text -> IO () +msg' typ xs = TIO.hPutStrLn stderr (typ <> ": " <> xs) + +info :: OptCommon -> Text -> a -> a +info opts xs + | optVerbose opts = msg "info" xs + | otherwise = id + +debug :: OptCommon -> Text -> a -> a +debug opts xs + | optDebug opts = msg "debug" xs + | otherwise = id + +removeDuplicates + :: (Ord a) + => [a] -> [a] +removeDuplicates = map head . group . sort + +--- Maybe Utils +-- | Joins two Maybe lists +maybeJoin :: Maybe [a] -> Maybe [a] -> Maybe [a] +maybeJoin Nothing Nothing = Nothing +maybeJoin xs ys = Just (fromMaybe [] xs ++ fromMaybe [] ys) + +maybeMap :: (a -> b) -> Maybe [a] -> [b] +maybeMap f = maybe [] (map f) + +-- | Takes the right value, if Just there +maybeRight :: Maybe a -> Maybe a -> Maybe a +maybeRight _ (Just r) = Just r +maybeRight l _ = l + +fromJustReason :: Text -> Maybe a -> a +fromJustReason _ (Just x) = x +fromJustReason reason Nothing = err $ "fromJust failed: " <> reason + +selectUniqueReason :: Text -> [a] -> a +selectUniqueReason _ [x] = x +selectUniqueReason msgt [] = + err $ "No element found while trying to find exactly one: " <> msgt +selectUniqueReason msgt xs = + err $ + "More then one element (" <> tshow (length xs) <> + ") found while trying to extrac one: " <> + msgt + +tshow + :: (Show a) + => a -> Text +tshow = T.replace "\\\"" "“" . pack . groom + +showCode :: Text -> Text +showCode = T.replace "\n" "\n " . T.cons '\n' + +tr + :: Show a + => a -> a +tr x = trace (show x <> "\n") x + +isIn :: Char -> Text -> Bool +isIn c t = T.singleton c `T.isInfixOf` t + +(<->) :: Text -> Text -> Text +(<->) a b = a <> " " <> b + +(<\>) :: Text -> Text -> Text +(<\>) a b = a <> "\n" <> b diff --git a/src/Database/HamSql/Setup.hs b/src/Database/HamSql/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Database/HamSql/Setup.hs @@ -0,0 +1,131 @@ +-- This file is part of HamSql +-- +-- Copyright 2014 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} + +module Database.HamSql.Setup where + +import Data.Typeable +import Data.Yaml + +import Database.HamSql.Internal.Utils +import Database.YamSql +import Database.YamSql.Parser +import Database.HamSql.Internal.Stmt + +data SetupContext = SetupContext + { setupContextSetup :: Setup + } + +data SetupElement where SetupElement :: (ToSqlStmts a, Show b) => { setupElement :: a + , setupElementSource :: Maybe b + } -> SetupElement + +instance ToSqlStmts SetupElement where + toSqlStmts x SetupElement{setupElement=y} = toSqlStmts x y + +class (Typeable a) => ToSqlStmts a where + toSqlStmts :: SetupContext -> a -> [Maybe SqlStmt] + +-- | Setup +data Setup = Setup + { setupSchemas :: [SqlName] + , setupSchemaDirs :: Maybe [FilePath] + , setupRolePrefix :: Maybe Text + , setupPreCode :: Maybe Text + , setupPostCode :: Maybe Text + , setupSchemaData :: Maybe [Schema] + } deriving (Generic, Show, Data) + +instance FromJSON Setup where + parseJSON = parseYamSql + +instance ToJSON Setup where + toJSON = toYamSqlJson + +setupRolePrefix' :: Setup -> Text +setupRolePrefix' setup = fromMaybe "yamsql_" (setupRolePrefix setup) + +-- | Template handling and applyTemplate +data WithSchema a = + WithSchema Schema + a + deriving (Show) + +class WithName a where + name :: a -> Text + +instance WithName (WithSchema TableTpl) where + name (WithSchema m t) = toSqlCode $ schemaName m <.> tabletplTemplate t + +instance WithName (WithSchema FunctionTpl) where + name (WithSchema m f) = toSqlCode $ schemaName m <.> functiontplTemplate f + +withoutSchema :: WithSchema a -> a +withoutSchema (WithSchema _ t) = t + +selectTemplates :: (ToSqlCode a, WithName (WithSchema t)) => + Maybe [a] -> [WithSchema t] -> [t] +selectTemplates ns ts + -- TODO: error handling here should be done using exceptions + = + [ withoutSchema $ + selectUniqueReason ("table or function tpl " <> n) $ + filter (\t -> n == name t) ts + | n <- maybeMap toSqlCode ns ] + +selectTemplate :: (ToSqlCode a1, WithName (WithSchema a)) => + a1 -> [WithSchema a] -> a +selectTemplate x ts = + head' $ map withoutSchema $ filter (\y -> name y == toSqlCode x) ts + where + head' = selectUniqueReason ("Column template " <> toSqlCode x) + +-- get things from Setup +setupAllSchemas :: Setup -> [Schema] +setupAllSchemas = fromMaybe [] . setupSchemaData + +setupAllFunctionTemplates :: Setup -> [WithSchema FunctionTpl] +setupAllFunctionTemplates s = + concat + [ maybeMap (WithSchema m) (schemaFunctionTemplates m) + | m <- setupAllSchemas s ] + +setupAllTableTemplates :: Setup -> [WithSchema TableTpl] +setupAllTableTemplates s = + concat + [ maybeMap (WithSchema m) (schemaTableTemplates m) + | m <- setupAllSchemas s ] + + + +applyTpl :: Setup -> Setup +applyTpl s = + s + -- TODO: possible overwrite here! + { setupSchemaData = Just $ maybeMap applySchema (setupSchemaData s) + } + where + applySchema m = + m + { schemaTables = + Just $ + maybeMap applyTableTemplates (schemaTables m) + , schemaFunctions = + Just $ maybeMap applyFunctionTemplates (schemaFunctions m) + } + applyTableTemplates :: Table -> Table + applyTableTemplates t = foldr applyTableTpl t (tableTpls t) + tableTpls :: Table -> [TableTpl] + tableTpls t = selectTemplates (tableTemplates t) (setupAllTableTemplates s) + applyFunctionTemplates :: Function -> Function + applyFunctionTemplates f = foldr applyFunctionTpl f (functionTpls f) + functionTpls :: Function -> [FunctionTpl] + functionTpls f = + selectTemplates (functionTemplates f) (setupAllFunctionTemplates s) + diff --git a/src/Database/YamSql.hs b/src/Database/YamSql.hs new file mode 100644 --- /dev/null +++ b/src/Database/YamSql.hs @@ -0,0 +1,13 @@ +-- This file is part of HamSql +-- +-- Copyright 2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +module Database.YamSql + ( module Database.YamSql.Internal.Schema + , module Database.YamSql.Internal.SqlId + , module Database.YamSql.Internal.Commons + ) where + +import Database.YamSql.Internal.Commons +import Database.YamSql.Internal.Schema +import Database.YamSql.Internal.SqlId diff --git a/src/Database/YamSql/Internal/Basic.hs b/src/Database/YamSql/Internal/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Database/YamSql/Internal/Basic.hs @@ -0,0 +1,13 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +module Database.YamSql.Internal.Basic + ( module Database.HamSql.Internal.Utils + , module Database.YamSql.Internal.SqlId + , module Database.YamSql.Parser + ) where + +import Database.HamSql.Internal.Utils +import Database.YamSql.Internal.SqlId +import Database.YamSql.Parser diff --git a/src/Database/YamSql/Internal/Check.hs b/src/Database/YamSql/Internal/Check.hs new file mode 100644 --- /dev/null +++ b/src/Database/YamSql/Internal/Check.hs @@ -0,0 +1,27 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Database.YamSql.Internal.Check where + +import Database.YamSql.Internal.Basic + +data Check = Check + { checkName :: SqlName + , checkDescription :: Text + , checkCheck :: Text + } deriving (Generic, Show, Data) + +instance FromJSON Check where + parseJSON = parseYamSql + +instance ToJSON Check where + toJSON = toYamSqlJson + +-- TODO clearify if this is useful for uniqueness +instance ToSqlIdPart Check where + sqlIdPart = checkName + sqlIdPartType = const "CHECK" diff --git a/src/Database/YamSql/Internal/Commons.hs b/src/Database/YamSql/Internal/Commons.hs new file mode 100644 --- /dev/null +++ b/src/Database/YamSql/Internal/Commons.hs @@ -0,0 +1,35 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Database.YamSql.Internal.Commons where + +import Database.YamSql.Internal.Basic + +data Variable = Variable + { variableName :: SqlName + , variableDescription :: Maybe Text + , variableType :: SqlType + , variableDefault :: Maybe Text + } deriving (Generic, Show, Data) + +instance FromJSON Variable where + parseJSON = parseYamSql + +instance ToJSON Variable where + toJSON = toYamSqlJson + +data Parameter = Parameter + { parameterName :: SqlName + , parameterDescription :: Maybe Text + , parameterType :: SqlType + } deriving (Generic, Show, Data) + +instance FromJSON Parameter where + parseJSON = parseYamSql + +instance ToJSON Parameter where + toJSON = toYamSqlJson diff --git a/src/Database/YamSql/Internal/Domain.hs b/src/Database/YamSql/Internal/Domain.hs new file mode 100644 --- /dev/null +++ b/src/Database/YamSql/Internal/Domain.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Database.YamSql.Internal.Domain where + +import Database.YamSql.Internal.Basic +import Database.YamSql.Internal.Check + +-- | Domains are aliases of an existing SQL types, possibly with checks +data Domain = Domain + { domainName :: SqlName + , domainDescription :: Text + , domainType :: SqlType + , domainDefault :: Maybe Text + , domainChecks :: Maybe [Check] + } deriving (Generic, Show, Data) + +instance FromJSON Domain where + parseJSON = parseYamSql + +instance ToJSON Domain where + toJSON = toYamSqlJson + +instance ToSqlIdPart Domain where + sqlIdPart = domainName + sqlIdPartType = const "DOMAIN" diff --git a/src/Database/YamSql/Internal/Function.hs b/src/Database/YamSql/Internal/Function.hs new file mode 100644 --- /dev/null +++ b/src/Database/YamSql/Internal/Function.hs @@ -0,0 +1,110 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Database.YamSql.Internal.Function where + +import Database.YamSql.Internal.Basic +import Database.YamSql.Internal.Commons + +data Function = Function + -- function name + { functionName :: SqlName + -- | description what the function is good for + , functionDescription :: Text + -- | return type of the function, TABLE is special (see return_columns) + , functionReturns :: SqlType + -- | parameters the function takes + , functionParameters :: Maybe [Variable] + -- | list of templates, used for this function + , functionTemplates :: Maybe [SqlName] + -- | loaded templates, not designed for use via Yaml + -- + -- __TODO: move to xfunctionInternal__ + , functionTemplateData :: Maybe [FunctionTpl] + -- | if return is TABLE, gives the columns that are returned (see parameter) + , functionReturnsColumns :: Maybe [Parameter] + -- | variables that are defined (ignored if language is given) + , functionVariables :: Maybe [Variable] + -- | Role that has the privilege to execute the function + , functionPrivExecute :: Maybe [SqlName] + -- | If true, the function is executed with the privileges of the owner! + -- | Owner has to be given, if this is true (not implemented yet!) + , functionSecurityDefiner :: Maybe Bool + -- | owner of the function + , functionOwner :: Maybe SqlName + -- | language in which the body is written + -- if not defined, pgsql is assumed an variables must be defined via variables + -- if pgsql is given explicitly, variables are your problem... + , functionLanguage :: Maybe Text + -- | the code of the function (body) + , functionBody :: Maybe Text + } deriving (Generic, Show, Data) + +instance FromJSON Function where + parseJSON = parseYamSql + +instance ToJSON Function where + toJSON = toYamSqlJson + +instance ToSqlIdPart Function where + sqlIdPart = functionName + sqlIdPartType = const "FUNCTION" + +instance ToSqlIdPartArgs Function where + sqlIdPartArgs x = maybeMap variableType $ functionParameters x + +data FunctionTpl = FunctionTpl + -- template name, used to refere the template via templates + { functiontplTemplate :: SqlName + -- description what the template is good for + , functiontplDescription :: Text + -- language of the function has to be the same as for used templates + -- TODO: implement checks to avoid explosions here ;) + , functiontplLanguage :: Maybe Text + -- parameters are joined with function definition parameters + , functiontplParameters :: Maybe [Variable] + -- variables are appended to the functions variables + , functiontplVariables :: Maybe [Variable] + -- defines priv_execute, can be overwritten by function definition + , functiontplPrivExecute :: Maybe [SqlName] + -- defines security_definer, can be overwritten by function definition + , functiontplSecurityDefiner :: Maybe Bool + -- defines owner, can be overwritten by function definition + , functiontplOwner :: Maybe SqlName + -- code added before the body of the function + , functiontplBodyPrelude :: Maybe Text + -- code added after the body of the function + , functiontplBodyPostlude :: Maybe Text + } deriving (Generic, Show, Data) + +instance FromJSON FunctionTpl where + parseJSON = parseYamSql + +instance ToJSON FunctionTpl where + toJSON = toYamSqlJson + +applyFunctionTpl :: FunctionTpl -> Function -> Function +applyFunctionTpl t f = + f + { functionPrivExecute = + maybeRight (functiontplPrivExecute t) (functionPrivExecute f) + , functionSecurityDefiner = + maybeRight (functiontplSecurityDefiner t) (functionSecurityDefiner f) + , functionOwner = maybeRight (functiontplOwner t) (functionOwner f) + , functionParameters = + maybeJoin (functionParameters f) (functiontplParameters t) + , functionVariables = maybeJoin (functionVariables f) (functiontplVariables t) + , functionBody = + Just $ + maybeStringL (functiontplBodyPrelude t) <> fromMaybe "" (functionBody f) <> + maybeStringR (functiontplBodyPostlude t) + } + where + maybeStringL (Just xs) = xs <> "\n" + maybeStringL Nothing = "" + maybeStringR (Just xs) = "\n" <> xs + maybeStringR Nothing = "" diff --git a/src/Database/YamSql/Internal/Role.hs b/src/Database/YamSql/Internal/Role.hs new file mode 100644 --- /dev/null +++ b/src/Database/YamSql/Internal/Role.hs @@ -0,0 +1,28 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Database.YamSql.Internal.Role where + +import Database.YamSql.Internal.Basic + +data Role = Role + { roleName :: SqlName + , roleDescription :: Text + , roleLogin :: Maybe Bool + , rolePassword :: Maybe Text + , roleMemberIn :: Maybe [SqlName] + } deriving (Generic, Show, Data) + +instance FromJSON Role where + parseJSON = parseYamSql + +instance ToJSON Role where + toJSON = toYamSqlJson + +instance ToSqlIdPart Role where + sqlIdPart = roleName + sqlIdPartType = const "ROLE" diff --git a/src/Database/YamSql/Internal/Schema.hs b/src/Database/YamSql/Internal/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Database/YamSql/Internal/Schema.hs @@ -0,0 +1,123 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Database.YamSql.Internal.Schema + ( Schema(..) + , SqlContextObj(..) + , SqlContextSqoArgtypes(..) + , SqlContextSqo(..) + , SqlContextSqoObj(..) + , sqlIdNameOnly + , module Database.YamSql.Internal.Check + , module Database.YamSql.Internal.Domain + , module Database.YamSql.Internal.Function + , module Database.YamSql.Internal.Role + , module Database.YamSql.Internal.Sequence + , module Database.YamSql.Internal.Table + , module Database.YamSql.Internal.Type + ) where + +import Database.YamSql.Internal.Basic + +import Database.YamSql.Internal.Check +import Database.YamSql.Internal.Domain +import Database.YamSql.Internal.Function +import Database.YamSql.Internal.Role +import Database.YamSql.Internal.Sequence +import Database.YamSql.Internal.Table +import Database.YamSql.Internal.Type + +-- Schema -- +data Schema = Schema + { schemaName :: SqlName + , schemaDescription :: Text + , schemaDependencies :: Maybe [SqlName] + , schemaFunctions :: Maybe [Function] + , schemaFunctionTemplates :: Maybe [FunctionTpl] + , schemaTables :: Maybe [Table] + , schemaTableTemplates :: Maybe [TableTpl] + , schemaRoles :: Maybe [Role] + , schemaSequences :: Maybe [Sequence] + , schemaPrivUsage :: Maybe [SqlName] + , schemaPrivSelectAll :: Maybe [SqlName] + , schemaPrivInsertAll :: Maybe [SqlName] + , schemaPrivUpdateAll :: Maybe [SqlName] + , schemaPrivDeleteAll :: Maybe [SqlName] + , schemaPrivSequenceAll :: Maybe [SqlName] + , schemaPrivExecuteAll :: Maybe [SqlName] + , schemaPrivAllAll :: Maybe [SqlName] + , schemaDomains :: Maybe [Domain] + , schemaTypes :: Maybe [Type] + , schemaExecPostInstall :: Maybe Text + , schemaExecPostInstallAndUpgrade :: Maybe Text + } deriving (Generic, Show, Data) + +instance FromJSON Schema where + parseJSON = parseYamSql + +instance ToJSON Schema where + toJSON = toYamSqlJson + +instance ToSqlIdPart Schema where + sqlIdPart = schemaName + sqlIdPartType = const "SCHEMA" + +data SqlContextObj a where + SqlContextObj :: ToSqlIdPart a => { + sqlObjectObject :: a + } -> SqlContextObj a + +deriving instance Show (SqlContextObj a) + +instance ToSqlId (SqlContextObj a) where + sqlId (SqlContextObj x) = SqlId $ SqlIdContentObj (sqlIdPartType x) (sqlIdPart x) + +data SqlContextSqo a where SqlContextSqo:: ToSqlIdPart a => { + sqlSqoSchema:: Schema, + sqlSqoObject :: a + } -> SqlContextSqo a + +deriving instance Show (SqlContextSqo a) + +instance ToSqlId (SqlContextSqo a) where + sqlId (SqlContextSqo s x) = SqlId $ SqlIdContentSqo + (sqlIdPartType x) + (sqlIdPart s <.> sqlIdPart x) + +data SqlContextSqoArgtypes a where SqlContextSqoArgtypes :: (ToSqlIdPart a, ToSqlIdPartArgs a) => { + sqlSqoArgtypesSchema:: Schema, + sqlSqoArgtypesObject :: a + } -> SqlContextSqoArgtypes a + +deriving instance Show (SqlContextSqoArgtypes a) + +instance ToSqlId (SqlContextSqoArgtypes a) where + sqlId (SqlContextSqoArgtypes s x) = SqlId $ SqlIdContentSqoArgtypes + (sqlIdPartType x) + (sqlIdPart s <.> sqlIdPart x) + (sqlIdPartArgs x) + +data SqlContextSqoObj a0 a1 where SqlContextSqoObj :: (ToSqlIdPart a0, ToSqlIdPart a1) => { + sqlSqoObjectSchema :: Schema, + sqlSqoObject1 :: a0, + sqlSqoObject2 :: a1 +} -> SqlContextSqoObj a0 a1 + +deriving instance Show (SqlContextSqoObj a0 a1) + +instance ToSqlId (SqlContextSqoObj a0 a1) where + sqlId (SqlContextSqoObj s x1 x2) = SqlId $ SqlIdContentSqoObj + (sqlIdPartType x1 <> "-" <> sqlIdPartType x2) + (sqlIdPart s <.> sqlIdPart x1) + (sqlIdPart x2) + +sqlIdNameOnly :: SqlContextSqoArgtypes a -> SqlName +sqlIdNameOnly (SqlContextSqoArgtypes s x) = (sqlIdPart s <.> sqlIdPart x) + diff --git a/src/Database/YamSql/Internal/Sequence.hs b/src/Database/YamSql/Internal/Sequence.hs new file mode 100644 --- /dev/null +++ b/src/Database/YamSql/Internal/Sequence.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Database.YamSql.Internal.Sequence where + +import Database.YamSql.Internal.Basic + +data Sequence = Sequence + { sequenceName :: SqlName + , sequenceIncrement :: Maybe Int + , sequenceMinValue :: Maybe Int + , sequenceMaxValue :: Maybe Int + , sequenceStartValue :: Maybe Int + , sequenceCache :: Maybe Int + , sequenceCycle :: Maybe Bool + -- PostgreSQL extension + , sequenceOwnedByColumn :: Maybe SqlName + } deriving (Generic, Show, Data) + +instance FromJSON Sequence where + parseJSON = parseYamSql + +instance ToJSON Sequence where + toJSON = toYamSqlJson + +instance ToSqlIdPart Sequence where + sqlIdPart = sequenceName + sqlIdPartType = const "SEQUENCE" diff --git a/src/Database/YamSql/Internal/SqlId.hs b/src/Database/YamSql/Internal/SqlId.hs new file mode 100644 --- /dev/null +++ b/src/Database/YamSql/Internal/SqlId.hs @@ -0,0 +1,239 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} + +{-# LANGUAGE StandaloneDeriving #-} + +module Database.YamSql.Internal.SqlId where + +import Data.Typeable +import qualified Data.Text as T + +import Database.HamSql.Internal.Utils +import Database.YamSql.Parser + +-- | Idable +class Show a => + ToSqlId a where + sqlId :: a -> SqlId + sqlIdCode :: a -> Text + sqlIdCode = toSqlCode . sqlId + +class (Typeable a, ToSqlCode a, Eq a, Show a) => + SqlIdContent a where + sqlIdContentType :: a -> SqlContextObjType + +class Show a => + ToSqlIdPart a where + sqlIdPart :: a -> SqlName + sqlIdPartType :: a -> SqlContextObjType + +class ToSqlObjId a where + sqlObjId :: a -> SqlName + sqlObjIdCode :: a -> Text + sqlObjIdCode = toSqlCode . sqlObjId + +class ToSqlSqoId a where + sqlSqoId :: a -> SqlName + sqlSqoIdCode :: a -> Text + sqlSqoIdCode = toSqlCode . sqlSqoId + +class ToSqlSqoObjId a where + sqlSqoObjId :: a -> SqlName + sqlSqoObjIdCode :: a -> Text + sqlSqoObjIdCode = toSqlCode . sqlSqoObjId + +-- | Strings like /TABLE/ +type SqlContextObjType = Text + +class ToSqlIdPartArgs a where + sqlIdPartArgs :: a -> [SqlType] + +-- | SqlId +data SqlId where + SqlId :: (SqlIdContent a) => { sqlIdContent :: a } -> SqlId + +deriving instance Show SqlId + +sqlIdType :: SqlId -> SqlContextObjType +sqlIdType (SqlId x) = sqlIdContentType x + +instance Eq SqlId where + SqlId x == SqlId y = Just x == cast y + +instance Ord SqlId where + SqlId x `compare` SqlId y = + case sqlIdContentType x `compare` sqlIdContentType y of + EQ -> toSqlCode x `compare` toSqlCode y + x' -> x' + +instance ToSqlId SqlId where + sqlId = id + +instance ToSqlCode SqlId where + toSqlCode (SqlId x) = toSqlCode x + +-- | ROLE, DATABASE, SCHEMA +data SqlIdContentObj = + SqlIdContentObj SqlContextObjType + SqlName + deriving (Eq, Show) + +instance SqlIdContent SqlIdContentObj where + sqlIdContentType (SqlIdContentObj x _) = x + +instance ToSqlId SqlIdContentObj where + sqlId = SqlId + +instance ToSqlCode SqlIdContentObj where + toSqlCode (SqlIdContentObj _ x) = toSqlCode x + +instance ToSqlObjId SqlIdContentObj where + sqlObjId (SqlIdContentObj _ x) = x + +-- | TABLE +data SqlIdContentSqo = + SqlIdContentSqo SqlContextObjType + SqlName + deriving (Eq, Show) + +instance SqlIdContent SqlIdContentSqo where + sqlIdContentType (SqlIdContentSqo x _) = x + +instance ToSqlId SqlIdContentSqo where + sqlId = SqlId + +instance ToSqlCode SqlIdContentSqo where + toSqlCode (SqlIdContentSqo _ x) = toSqlCode x + +instance ToSqlSqoId SqlIdContentSqo where + sqlSqoId (SqlIdContentSqo _ x) = x + +-- | TABLE TRIGGER, TABLE CONTRAINT +data SqlIdContentSqoObj = + SqlIdContentSqoObj SqlContextObjType + SqlName + SqlName + deriving (Eq, Show) + +instance SqlIdContent SqlIdContentSqoObj where + sqlIdContentType (SqlIdContentSqoObj x _ _) = x + +instance ToSqlId SqlIdContentSqoObj where + sqlId = SqlId + +instance ToSqlCode SqlIdContentSqoObj where + toSqlCode (SqlIdContentSqoObj _ x y) = toSqlCode (x <.> y) + +instance ToSqlSqoId SqlIdContentSqoObj where + sqlSqoId (SqlIdContentSqoObj _ x _) = x + +instance ToSqlSqoObjId SqlIdContentSqoObj where + sqlSqoObjId (SqlIdContentSqoObj _ _ x) = x + +-- | FUNCTION +data SqlIdContentSqoArgtypes = + SqlIdContentSqoArgtypes SqlContextObjType + SqlName + [SqlType] + deriving (Eq, Show) + +instance SqlIdContent SqlIdContentSqoArgtypes where + sqlIdContentType (SqlIdContentSqoArgtypes x _ _) = x + +instance ToSqlId SqlIdContentSqoArgtypes where + sqlId = SqlId + +instance ToSqlSqoId SqlIdContentSqoArgtypes where + sqlSqoId (SqlIdContentSqoArgtypes _ x _) = x + +instance ToSqlCode SqlIdContentSqoArgtypes where + toSqlCode (SqlIdContentSqoArgtypes _ x ys) = + toSqlCode x <> "(" <> T.intercalate ", " (map toSqlCode ys) <> ")" + +-- ToSqlCode (right now only SqlName) +unsafePlainName :: SqlName -> Text +unsafePlainName (SqlName n) = n + +instance Eq SqlName where + (==) x y = toSqlCode x == toSqlCode y + +instance ToSqlCode SqlName where + toSqlCode (SqlName n) = + if '"' `isIn` n + then n + else toSqlCode' $ expSqlName $ SqlName n + +instance SqlIdentifierConcat SqlName where + (//) (SqlName s) (SqlName t) = SqlName (s <> t) + +(<.>) :: SqlName -> SqlName -> SqlName +(<.>) (SqlName s) (SqlName t) = SqlName $ s <> "." <> t + +expSqlName :: SqlName -> [SqlName] +expSqlName n = map SqlName (T.splitOn "." (getStr n)) + where + getStr (SqlName n') = n' + +instance ToSqlCode SqlType where + toSqlCode (SqlType n) + -- if quotes are contained + -- assume that user cares for correct enquoting + = + if '"' `isIn` n || + -- if at least a pair of brakets is found + -- assume that a type like varchar(20) is meant + ('(' `isIn` n && ')' `isIn` n) || + -- if no dot is present, assume that buildin type + -- like integer is meant + not ('.' `isIn` n) || + -- if % is present, assume that something like + -- table%ROWTYPE could be meant + '%' `isIn` n + then n + else toSqlCode' $ expSqlName $ SqlName n + +instance SqlIdentifierConcat SqlType where + (//) (SqlType s) (SqlType t) = SqlType (s <> t) + +contSqlName :: [SqlName] -> SqlName +contSqlName ns = SqlName $ T.intercalate "." $ map getStr ns + where + getStr (SqlName n') = n' + +toSqlCode' :: [SqlName] -> Text +toSqlCode' xs = T.intercalate "." $ map quotedName xs + where + quotedName (SqlName s) = "\"" <> s <> "\"" + +class ToSqlCode a where + toSqlCode :: a -> Text + +class SqlIdentifierConcat a where + (//) :: a -> a -> a + +-- SqlName +newtype SqlName = + SqlName Text + deriving (Generic, Ord, Show, Data) + +instance FromJSON SqlName where + parseJSON = genericParseJSON myOpt + +instance ToJSON SqlName where + toJSON = toYamSqlJson + +newtype SqlType = + SqlType Text + deriving (Generic, Show, Eq, Data) + +instance FromJSON SqlType where + parseJSON = genericParseJSON myOpt + +instance ToJSON SqlType where + toJSON = toYamSqlJson + diff --git a/src/Database/YamSql/Internal/Table.hs b/src/Database/YamSql/Internal/Table.hs new file mode 100644 --- /dev/null +++ b/src/Database/YamSql/Internal/Table.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Database.YamSql.Internal.Table where + +import Database.YamSql.Internal.Basic +import Database.YamSql.Internal.Check + +data Table = Table + { tableName :: SqlName + , tableDescription :: Text + , tableColumns :: [Column] + , tablePrimaryKey :: [SqlName] + , tableUnique :: Maybe [UniqueKey] + , tableForeignKeys :: Maybe [ForeignKey] + , tableChecks :: Maybe [Check] + , tableInherits :: Maybe [SqlName] + , tablePrivSelect :: Maybe [SqlName] + , tablePrivInsert :: Maybe [SqlName] + , tablePrivUpdate :: Maybe [SqlName] + , tablePrivDelete :: Maybe [SqlName] + , tableTemplates :: Maybe [SqlName] + , tableTemplateData :: Maybe [TableTpl] + } deriving (Data, Generic, Show) + +instance FromJSON Table where + parseJSON = parseYamSql + +instance ToJSON Table where + toJSON = toYamSqlJson + +instance ToSqlIdPart Table where + sqlIdPart = tableName + sqlIdPartType = const "TABLE" + +data TableTpl = TableTpl + { tabletplTemplate :: SqlName + , tabletplDescription :: Text + , tabletplForeignKeys :: Maybe [ForeignKey] + , tabletplInherits :: Maybe [SqlName] + , tabletplColumns :: Maybe [Column] + , tabletplChecks :: Maybe [Check] + , tabletplPrivSelect :: Maybe [SqlName] + , tabletplPrivInsert :: Maybe [SqlName] + , tabletplPrivUpdate :: Maybe [SqlName] + , tabletplPrivDelete :: Maybe [SqlName] + } deriving (Generic, Show, Data) + +instance FromJSON TableTpl where + parseJSON = parseYamSql + +instance ToJSON TableTpl where + toJSON = toYamSqlJson + +data Column = Column + { columnName :: SqlName + , columnType :: SqlType + , columnDescription :: Text + , columnDefault :: Maybe Text + , columnNull :: Maybe Bool + , columnReferences :: Maybe SqlName + , columnOnRefDelete :: Maybe Text + , columnOnRefUpdate :: Maybe Text + , columnUnique :: Maybe Bool + , columnChecks :: Maybe [Check] + } deriving (Generic, Show, Data) + +instance FromJSON Column where + parseJSON = parseYamSql + +instance ToJSON Column where + toJSON = toYamSqlJson + +instance ToSqlIdPart Column where + sqlIdPart = columnName + sqlIdPartType = const "COLUMN" + +applyTableTpl :: TableTpl -> Table -> Table +applyTableTpl tpl t = + t + { tableColumns = fromMaybe [] (tabletplColumns tpl) ++ tableColumns t + , tableForeignKeys = maybeJoin (tabletplForeignKeys tpl) (tableForeignKeys t) + , tableInherits = maybeJoin (tabletplInherits tpl) (tableInherits t) + , tableChecks = maybeJoin (tabletplChecks tpl) (tableChecks t) + , tablePrivSelect = maybeJoin (tabletplPrivSelect tpl) (tablePrivSelect t) + , tablePrivInsert = maybeJoin (tabletplPrivInsert tpl) (tablePrivInsert t) + , tablePrivUpdate = maybeJoin (tabletplPrivUpdate tpl) (tablePrivUpdate t) + , tablePrivDelete = maybeJoin (tabletplPrivDelete tpl) (tablePrivDelete t) + } + +data UniqueKey = UniqueKey + { uniquekeyName :: SqlName + , uniquekeyColumns :: [SqlName] + } deriving (Generic, Show, Data) + +instance FromJSON UniqueKey where + parseJSON = parseYamSql + +instance ToJSON UniqueKey where + toJSON = toYamSqlJson + +data ForeignKey = ForeignKey + { foreignkeyName :: SqlName + , foreignkeyColumns :: [SqlName] + , foreignkeyRefTable :: SqlName + , foreignkeyRefColumns :: [SqlName] + , foreignkeyOnDelete :: Maybe Text + , foreignkeyOnUpdate :: Maybe Text + } deriving (Generic, Show, Data) + +instance FromJSON ForeignKey where + parseJSON = parseYamSql + +instance ToJSON ForeignKey where + toJSON = toYamSqlJson diff --git a/src/Database/YamSql/Internal/Type.hs b/src/Database/YamSql/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/src/Database/YamSql/Internal/Type.hs @@ -0,0 +1,37 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Database.YamSql.Internal.Type where + +import Database.YamSql.Internal.Basic + +data Type = Type + { typeName :: SqlName + , typeDescription :: Text + , typeElements :: [TypeElement] + } deriving (Generic, Show, Data) + +instance FromJSON Type where + parseJSON = parseYamSql + +instance ToJSON Type where + toJSON = toYamSqlJson + +data TypeElement = TypeElement + { typeelementName :: SqlName + , typeelementType :: SqlType + } deriving (Generic, Show, Data) + +instance FromJSON TypeElement where + parseJSON = parseYamSql + +instance ToJSON TypeElement where + toJSON = toYamSqlJson + +instance ToSqlIdPart Type where + sqlIdPart = typeName + sqlIdPartType = const "TYPE" diff --git a/src/Database/YamSql/Parser.hs b/src/Database/YamSql/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Database/YamSql/Parser.hs @@ -0,0 +1,94 @@ +-- This file is part of HamSql +-- +-- Copyright 2014-2016 by it's authors. +-- Some rights reserved. See COPYING, AUTHORS. +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} + +module Database.YamSql.Parser + ( module Database.YamSql.Parser + , genericParseJSON + , genericToJSON + , ToJSON(..) + , FromJSON(..) + , Generic(..) + , Data(..) + ) where + +import Control.Exception +import Data.Aeson.Types + (GFromJSON, GToJSON, Options(..), defaultOptions, genericParseJSON, + genericToJSON, Zero) + +import Data.Char +import Data.Data +import Data.HashMap.Strict (keys) +import Data.List +import qualified Data.Text as T +import Data.Yaml +import GHC.Generics +import System.IO + +import Database.HamSql.Internal.Utils + +-- removes first part of camel case. e.g.: +-- columnDescriptionField |-> descriptionField +removeFirstPart :: String -> String +removeFirstPart xs = lowerStr rest + where + rest = dropWhile isLower xs + lowerStr (x':xs') = toLower x' : xs' + lowerStr [] = "__" + +-- makes camelCaseSpelling to camel_case_spelling +snakeify :: String -> String +snakeify [] = [] +snakeify (x:xs) + | isUpper x = '_' : toLower x : snakeify xs + | otherwise = x : snakeify xs + +myOpt :: Options +myOpt = + defaultOptions + { fieldLabelModifier = snakeify . removeFirstPart + , constructorTagModifier = drop 1 . snakeify + } + +outJson + :: ToJSON a + => a -> String +outJson s = show $ toJSON s + +forceToJson + :: ToJSON a + => a -> IO () +forceToJson s = + withFile "/dev/null" WriteMode (\handl -> hPrint handl (toJSON s)) + +parseYamSql + :: (Generic r, GFromJSON Zero (Rep r), Data r) + => Value -> Parser r +parseYamSql xs = do + parsed <- genericParseJSON myOpt xs + let diff = keysOfValue xs \\ keysOfData parsed + return $ + if null diff + then parsed + else throw $ YamsqlException $ "Found unknown keys: " <> tshow diff + where + keysOfData u = + "tag" : map (snakeify . removeFirstPart) (constrFields (toConstr u)) + keysOfValue :: Value -> [String] + keysOfValue (Object ys) = map T.unpack $ keys ys + keysOfValue _ = err "HAMSQL-UNEXPECTED 3" + +toYamSqlJson + :: (Generic a, GToJSON Zero (Rep a)) + => a -> Value +toYamSqlJson = genericToJSON myOpt + +data YamsqlException = + YamsqlException Text + deriving (Show) + +instance Exception YamsqlException