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