Index: /tags/1.2/COPYING =================================================================== --- /tags/1.2/COPYING (revision 556) +++ /tags/1.2/COPYING (revision 556) @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. Index: /tags/1.2/DNSDB.pm =================================================================== --- /tags/1.2/DNSDB.pm (revision 556) +++ /tags/1.2/DNSDB.pm (revision 556) @@ -0,0 +1,5587 @@ +# dns/trunk/DNSDB.pm +# Abstraction functions for DNS administration +## +# $Id$ +# Copyright 2008-2013 Kris Deugau +# +# 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 . +## + +package DNSDB; + +use strict; +use warnings; +use Exporter; +use DBI; +use Net::DNS; +use Crypt::PasswdMD5; +use Net::SMTP; +use NetAddr::IP 4.027 qw(:lower); +use POSIX; +use Fcntl qw(:flock); +use Time::TAI64 qw(:tai64); + +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + +$VERSION = 1.1; ##VERSION## +@ISA = qw(Exporter); +@EXPORT_OK = qw( + &initGlobals &login &initActionLog + &getPermissions &changePermissions &comparePermissions + &changeGroup + &connectDB &finish + &addDomain &delZone &domainName &revName &domainID &revID &addRDNS + &getZoneCount &getZoneList &getZoneLocation + &addGroup &delGroup &getChildren &groupName + &getGroupCount &getGroupList + &addUser &updateUser &delUser &userFullName &userStatus &getUserData + &getUserCount &getUserList &getUserDropdown + &addLoc &updateLoc &delLoc &getLoc + &getLocCount &getLocList &getLocDropdown + &getSOA &updateSOA &getRecLine &getRecList &getRecCount + &addRec &updateRec &delRec + &getLogCount &getLogEntries + &getRevPattern + &getTypelist + &parentID + &isParent + &zoneStatus &getZonesByCIDR &importAXFR + &export + &mailNotify + %typemap %reverse_typemap + @permtypes $permlist %permchains + ); + +@EXPORT = qw(%typemap %reverse_typemap @permtypes $permlist %permchains); +%EXPORT_TAGS = ( ALL => [qw( + &initGlobals &login &initActionLog + &getPermissions &changePermissions &comparePermissions + &changeGroup + &connectDB &finish + &addDomain &delZone &domainName &revName &domainID &revID &addRDNS + &getZoneCount &getZoneList &getZoneLocation + &addGroup &delGroup &getChildren &groupName + &getGroupCount &getGroupList + &addUser &updateUser &delUser &userFullName &userStatus &getUserData + &getUserCount &getUserList &getUserDropdown + &addLoc &updateLoc &delLoc &getLoc + &getLocCount &getLocList &getLocDropdown + &getSOA &updateSOA &getRecLine &getRecList &getRecCount + &addRec &updateRec &delRec + &getLogCount &getLogEntries + &getRevPattern + &getTypelist + &parentID + &isParent + &zoneStatus &getZonesByCIDR &importAXFR + &export + &mailNotify + %typemap %reverse_typemap + @permtypes $permlist %permchains + )] + ); + +our $errstr = ''; +our $resultstr = ''; + +# Arguably defined wholly in the db, but little reason to change without supporting code changes +# group_view, user_view permissions? separate rDNS permission(s)? +our @permtypes = qw ( + group_edit group_create group_delete + user_edit user_create user_delete + domain_edit domain_create domain_delete + record_edit record_create record_delete record_locchg + location_edit location_create location_delete location_view + self_edit admin +); +our $permlist = join(',',@permtypes); + +# Some permissions more or less require certain others. +our %permchains = ( + user_edit => 'self_edit', + location_edit => 'location_view', + location_create => 'location_view', + location_delete => 'location_view', + record_locchg => 'location_view', +); + +# DNS record type map and reverse map. +# loaded from the database, from http://www.iana.org/assignments/dns-parameters +our %typemap; +our %reverse_typemap; + +## (Semi)private variables + +# Hash of functions for validating record types. Filled in initGlobals() since +# it relies on visibility flags from the rectypes table in the DB +my %validators; + +# Entity-relationship reference hashes. +my %par_tbl = ( + group => 'groups', + user => 'users', + defrec => 'default_records', + defrevrec => 'default_rev_records', + domain => 'domains', + revzone => 'revzones', + record => 'records' + ); +my %id_col = ( + group => 'group_id', + user => 'user_id', + defrec => 'record_id', + defrevrec => 'record_id', + domain => 'domain_id', + revzone => 'rdns_id', + record => 'record_id' + ); +my %par_col = ( + group => 'parent_group_id', + user => 'group_id', + defrec => 'group_id', + defrevrec => 'group_id', + domain => 'group_id', + revzone => 'group_id', + record => 'domain_id' + ); +my %par_type = ( + group => 'group', + user => 'group', + defrec => 'group', + defrevrec => 'group', + domain => 'group', + revzone => 'group', + record => 'domain' + ); + +## +## Constructor and destructor +## + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %args = @_; + + # Prepopulate a basic config. Note some of these *will* cause errors if left unset. + # note: add appropriate stanzas in __cfgload() to parse these + my %defconfig = ( + # The only configuration options not loadable from a config file. + configfile => "/etc/dnsdb/dnsdb.conf", ##CFG_LEAF## + + # Database connection info + dbname => 'dnsdb', + dbuser => 'dnsdb', + dbpass => 'secret', + dbhost => '', + + # Email notice settings + mailhost => 'smtp.example.com', + mailnotify => 'dnsdb@example.com', # to + mailsender => 'dnsdb@example.com', # from + mailname => 'DNS Administration', + orgname => 'Example Corp', + domain => 'example.com', + + # Template directory + templatedir => 'templates/', +# fmeh. this is a real web path, not a logical internal one. hm.. +# cssdir => 'templates/', + sessiondir => 'session/', + exportcache => 'cache/', + + # Session params + timeout => '1h', # passed as-is to CGI::Session + + # Other miscellanea + log_failures => 1, # log all evarthing by default + perpage => 15, + max_fcgi_requests => 100, # reasonable default? + force_refresh => 1, + lowercase => 0, # mangle as little as possible by default + ); + + # Config file parse calls. + # If we are passed a blank argument for $args{configfile}, + # we should NOT parse the default config file - we will + # rely on hardcoded defaults OR caller-specified values. + # If we are passed a non-blank argument, parse that file. + # If no config file is specified, parse the default one. + my %siteconfig; + if (defined($args{configfile})) { + if ($args{configfile}) { + return if !__cfgload($args{configfile}, \%siteconfig); + } + } else { + return if !__cfgload($defconfig{configfile}, \%siteconfig); + } + + # Assemble the object. Apply configuration hashes in order of precedence. + my $self = { + # Hardcoded defaults + %defconfig, + # Default config file OR caller-specified one, loaded above + %siteconfig, + # Caller-specified arguments + %args + }; + bless $self, $class; + + # Several settings are booleans. Handle multiple possible ways of setting them. + for my $boolopt ('log_failures', 'force_refresh', 'lowercase') { + if ($self->{$boolopt} ne '1' && $self->{$boolopt} ne '0') { + # true/false, on/off, yes/no all valid. + if ($self->{$boolopt} =~ /^(?:true|false|t|f|on|off|yes|no)$/) { + if ($self->{$boolopt} =~ /(?:true|t|on|yes)/) { + $self->{$boolopt} = 1; + } else { + $self->{$boolopt} = 0; + } + } else { + warn "Bad $boolopt setting $self->{$boolopt}\n"; + $self->{$boolopt} = 1; + } + } + } + + # Try to connect to the DB, and initialize a number of handy globals. + $self->{dbh} = connectDB($self->{dbname}, $self->{dbuser}, $self->{dbpass}, $self->{dbhost}) or return; + $self->initGlobals(); + + return $self; +} + +sub DESTROY { + my $self = shift; + $self->{dbh}->disconnect if $self->{dbh}; +} + +sub errstr { $DNSDB::errstr; } + +## +## utility functions +## + +## DNSDB::_rectable() +# Takes default+rdns flags, returns appropriate table name +sub _rectable { + my $def = shift; + my $rev = shift; + + return 'records' if $def ne 'y'; + return 'default_records' if $rev ne 'y'; + return 'default_rev_records'; +} # end _rectable() + +## DNSDB::_recparent() +# Takes default+rdns flags, returns appropriate parent-id column name +sub _recparent { + my $def = shift; + my $rev = shift; + + return 'group_id' if $def eq 'y'; + return 'rdns_id' if $rev eq 'y'; + return 'domain_id'; +} # end _recparent() + +## DNSDB::_ipparent() +# Check an IP to be added in a reverse zone to see if it's really in the requested parent. +# Takes default and reverse flags, IP (fragment) to check, parent zone ID, +# and a reference to a NetAddr::IP object (also used to pass back a fully-reconstructed IP for +# database insertion) +sub _ipparent { + my $self = shift; + my $dbh = $self->{dbh}; + my $defrec = shift; + my $revrec = shift; + my $val = shift; + my $id = shift; + my $addr = shift; + + return if $revrec ne 'y'; # this sub not useful in forward zones + + $$addr = NetAddr::IP->new($$val); #necessary? + + # subsub to split, reverse, and overlay an IP fragment on a netblock + sub __rev_overlay { + my $splitme = shift; # ':' or '.', m'lud? + my $parnet = shift; + my $val = shift; + my $addr = shift; + + my $joinme = $splitme; + $splitme = '\.' if $splitme eq '.'; + my @working = reverse(split($splitme, $parnet->addr)); + my @parts = reverse(split($splitme, $$val)); + for (my $i = 0; $i <= $#parts; $i++) { + $working[$i] = $parts[$i]; + } + my $checkme = NetAddr::IP->new(join($joinme, reverse(@working))) or return 0; + return 0 unless $checkme->within($parnet); + $$addr = $checkme; # force "correct" IP to be recorded. + return 1; + } + + my ($parstr) = $dbh->selectrow_array("SELECT revnet FROM revzones WHERE rdns_id = ?", undef, ($id)); + my $parnet = NetAddr::IP->new($parstr); + + # Fail early on v6-in-v4 or v4-in-v6. We're not accepting these ATM. + return 0 if $parnet->addr =~ /\./ && $$val =~ /:/; + return 0 if $parnet->addr =~ /:/ && $$val =~ /\./; + + if ($$addr && ($$val =~ /^[\da-fA-F][\da-fA-F:]+[\da-fA-F]$/ || $$val =~ m|/\d+$|)) { + # the only case where NetAddr::IP's acceptance of legitimate IPs is "correct" is for a proper IPv6 address, + # or a netblock (only expected on templates) + # the rest we have to restructure before fiddling. *sigh* + return 1 if $$addr->within($parnet); + } else { + # We don't have a complete IP in $$val (yet)... unless we have a netblock + if ($parnet->addr =~ /:/) { + $$val =~ s/^:+//; # gotta strip'em all... + return __rev_overlay(':', $parnet, $val, $addr); + } + if ($parnet->addr =~ /\./) { + $$val =~ s/^\.+//; + return __rev_overlay('.', $parnet, $val, $addr); + } + # should be impossible to get here... + } + # ... and here. + # can't do nuttin' in forward zones +} # end _ipparent() + +## DNSDB::_hostparent() +# A little different than _ipparent above; this tries to *find* the parent zone of a hostname +# Takes a hostname. +# Returns the domain ID of the parent domain if one was found. +sub _hostparent { + my $self = shift; + my $dbh = $self->{dbh}; + my $hname = shift; + + $hname =~ s/^\*\.//; # this should be impossible to find in the domains table. + my @hostbits = split /\./, $hname; + my $sth = $dbh->prepare("SELECT count(*),domain_id FROM domains WHERE lower(domain) = lower(?) GROUP BY domain_id"); + foreach (@hostbits) { + $sth->execute($hname); + my ($found, $parid) = $sth->fetchrow_array; + if ($found) { + return $parid; + } + $hname =~ s/^$_\.//; + } +} # end _hostparent() + +## DNSDB::_log() +# Log an action +# Takes a log entry hash containing at least: +# group_id, log entry +# and optionally one or more of: +# domain_id, rdns_id +# The %userdata hash provides the user ID, username, and fullname +sub _log { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + $args{rdns_id} = 0 if !$args{rdns_id}; + $args{domain_id} = 0 if !$args{domain_id}; + +##fixme: farm out the actual logging to different subs for file, syslog, internal, etc based on config +# if ($self->{log_channel} eq 'sql') { + $dbh->do("INSERT INTO log (domain_id,rdns_id,group_id,entry,user_id,email,name) VALUES (?,?,?,?,?,?,?)", + undef, + ($args{domain_id}, $args{rdns_id}, $args{group_id}, $args{entry}, + $self->{loguserid}, $self->{logusername}, $self->{logfullname}) ); +# } elsif ($self->{log_channel} eq 'file') { +# } elsif ($self->{log_channel} eq 'syslog') { +# } +} # end _log + + +## +## Record validation subs. +## + +## All of these subs take substantially the same arguments: +# a hash containing at least the following keys: +# - defrec (default/live flag) +# - revrec (forward/reverse flag) +# - id (parent entity ID) +# - host (hostname) +# - rectype +# - val (IP, hostname [CNAME/MX/SRV] or text) +# - addr (NetAddr::IP object from val. May be undef.) +# MX and SRV record validation also expect distance, and SRV records expect weight and port as well. +# host, rectype, and addr should be references as these may be modified in validation + +# A record +sub _validate_1 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + return ('FAIL', 'Reverse zones cannot contain A records') if $args{revrec} eq 'y'; + + # Coerce all hostnames to end in ".DOMAIN" for group/default records, + # or the intended parent domain for live records. + my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id})); + ${$args{host}} =~ s/\.*$/\.$pname/ if (${$args{host}} ne '@' && ${$args{host}} !~ /$pname$/); + + # Check IP is well-formed, and that it's a v4 address + # Fail on "compact" IPv4 variants, because they are not consistent and predictable. + return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv4 address") + unless ${$args{val}} =~ /^\d+\.\d+\.\d+\.\d+$/; + return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv4 address") + unless $args{addr} && !$args{addr}->{isv6}; + # coerce IP/value to normalized form for storage + ${$args{val}} = $args{addr}->addr; + + return ('OK','OK'); +} # done A record + +# NS record +sub _validate_2 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + # Check that the target of the record is within the parent. + # Yes, host<->val are mixed up here; can't see a way to avoid it. :( + if ($args{defrec} eq 'n') { + # Check if IP/address/zone/"subzone" is within the parent + if ($args{revrec} eq 'y') { + my $tmpip = NetAddr::IP->new(${$args{val}}); + my $pname = $self->revName($args{id}); + return ('FAIL',"${$args{val}} not within $pname") + unless $self->_ipparent($args{defrec}, $args{revrec}, $args{val}, $args{id}, \$tmpip); + # Sub the returned thing for ZONE? This could get stupid if you have typos... + ${$args{val}} =~ s/ZONE/$tmpip->address/; + } else { + my $pname = $self->domainName($args{id}); + ${$args{host}} = $pname if ${$args{host}} !~ /\.$pname$/; + } + } else { + # Default reverse NS records should always refer to the implied parent + ${$args{host}} = 'DOMAIN' if $args{revrec} eq 'n'; + ${$args{val}} = 'ZONE' if $args{revrec} eq 'y'; + } + +# Let this lie for now. Needs more magic. +# # Check IP is well-formed, and that it's a v4 address +# return ('FAIL',"A record must be a valid IPv4 address") +# unless $addr && !$addr->{isv6}; +# # coerce IP/value to normalized form for storage +# $$val = $addr->addr; + + return ('OK','OK'); +} # done NS record + +# CNAME record +sub _validate_5 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + +# Not really true, but these are only useful for delegating smaller-than-/24 IP blocks. +# This is fundamentally a messy operation and should really just be taken care of by the +# export process, not manual maintenance of the necessary records. + return ('FAIL', 'Reverse zones cannot contain CNAME records') if $args{revrec} eq 'y'; + + # Coerce all hostnames to end in ".DOMAIN" for group/default records, + # or the intended parent domain for live records. + my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id})); + ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/; + + return ('OK','OK'); +} # done CNAME record + +# SOA record +sub _validate_6 { + # Smart monkeys won't stick their fingers in here; we have + # separate dedicated routines to deal with SOA records. + return ('OK','OK'); +} # done SOA record + +# PTR record +sub _validate_12 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + if ($args{revrec} eq 'y') { + if ($args{defrec} eq 'n') { + return ('FAIL', "IP or IP fragment ${$args{val}} is not within ".$self->revName($args{id})) + unless $self->_ipparent($args{defrec}, $args{revrec}, $args{val}, $args{id}, \$args{addr}); + ${$args{val}} = $args{addr}->addr; + } else { + if (${$args{val}} =~ /\./) { + # looks like a v4 or fragment + if (${$args{val}} =~ /^\d+\.\d+\.\d+\.\d+$/) { + # woo! a complete IP! validate it and normalize, or fail. + $args{addr} = NetAddr::IP->new(${$args{val}}) + or return ('FAIL', "IP/value looks like IPv4 but isn't valid"); + ${$args{val}} = $args{addr}->addr; + } else { + ${$args{val}} =~ s/^\.*/ZONE./ unless ${$args{val}} =~ /^ZONE/; + } + } elsif (${$args{val}} =~ /[a-f:]/) { + # looks like a v6 or fragment + ${$args{val}} =~ s/^:*/ZONE::/ if !$args{addr} && ${$args{val}} !~ /^ZONE/; + if ($args{addr}) { + if ($args{addr}->addr =~ /^0/) { + ${$args{val}} =~ s/^:*/ZONE::/ unless ${$args{val}} =~ /^ZONE/; + } else { + ${$args{val}} = $args{addr}->addr; + } + } + } else { + # bare number (probably). These could be v4 or v6, so we'll + # expand on these on creation of a reverse zone. + ${$args{val}} = "ZONE,${$args{val}}" unless ${$args{val}} =~ /^ZONE/; + } + ${$args{host}} =~ s/\.*$/\.$self->{domain}/ if ${$args{host}} !~ /(?:$self->{domain}|ADMINDOMAIN)$/; + } + +# Multiple PTR records do NOT generally do what most people believe they do, +# and tend to fail in the most awkward way possible. Check and warn. +# We use $val instead of $addr->addr since we may be in a defrec, and may have eg "ZONE::42" or "ZONE.12" + + my @checkvals = (${$args{val}}); + if (${$args{val}} =~ /,/) { + # push . and :: variants into checkvals if val has , + my $tmp; + ($tmp = ${$args{val}}) =~ s/,/./; + push @checkvals, $tmp; + ($tmp = ${$args{val}}) =~ s/,/::/; + push @checkvals, $tmp; + } + my $pcsth = $dbh->prepare("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec})." WHERE val = ?"); + foreach my $checkme (@checkvals) { + if ($args{update}) { + # Record update. There should usually be an existing PTR (the record being updated) + my @ptrs = @{ $dbh->selectcol_arrayref("SELECT record_id FROM "._rectable($args{defrec},$args{revrec}). + " WHERE val = ?", undef, ($checkme)) }; + return ('WARN', "PTR record for $checkme already exists; adding another will probably not do what you want") + if @ptrs && (!grep /^$args{update}$/, @ptrs); + } else { + # New record. Always warn if a PTR exists + my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}). + " WHERE val = ?", undef, ($checkme)); + return ('WARN', "PTR record for $checkme already exists; adding another will probably not do what you want") + if $ptrcount; + } + } + + } else { + # Not absolutely true but only useful if you hack things up for sub-/24 v4 reverse delegations + # Simpler to just create the reverse zone and grant access for the customer to edit it, and create direct + # PTR records on export + return ('FAIL',"Forward zones cannot contain PTR records"); + } + + return ('OK','OK'); +} # done PTR record + +# MX record +sub _validate_15 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + +# Not absolutely true but WTF use is an MX record for a reverse zone? + return ('FAIL', 'Reverse zones cannot contain MX records') if $args{revrec} eq 'y'; + + return ('FAIL', "Distance is required for MX records") unless defined(${$args{dist}}); + ${$args{dist}} =~ s/\s*//g; + return ('FAIL',"Distance is required, and must be numeric") unless ${$args{dist}} =~ /^\d+$/; + + ${$args{fields}} = "distance,"; + push @{$args{vallist}}, ${$args{dist}}; + + # Coerce all hostnames to end in ".DOMAIN" for group/default records, + # or the intended parent domain for live records. + my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id})); + ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/; + +# hmm.. this might work. except possibly for something pointing to "deadbeef.ca". +# if ($type == $reverse_typemap{NS} || $type == $reverse_typemap{MX} || $type == $reverse_typemap{SRV}) { +# if ($val =~ /^\s*[\da-f:.]+\s*$/) { +# return ('FAIL',"$val is not a valid IP address") if !$addr; +# } +# } + + return ('OK','OK'); +} # done MX record + +# TXT record +sub _validate_16 { + # Could arguably put a WARN return here on very long (>512) records + return ('OK','OK'); +} # done TXT record + +# RP record +sub _validate_17 { + # Probably have to validate these some day + return ('OK','OK'); +} # done RP record + +# AAAA record +sub _validate_28 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + return ('FAIL', 'Reverse zones cannot contain AAAA records') if $args{revrec} eq 'y'; + + # Coerce all hostnames to end in ".DOMAIN" for group/default records, + # or the intended parent domain for live records. + my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id})); + ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/; + + # Check IP is well-formed, and that it's a v6 address + return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv6 address") + unless $args{addr} && $args{addr}->{isv6}; + # coerce IP/value to normalized form for storage + ${$args{val}} = $args{addr}->addr; + + return ('OK','OK'); +} # done AAAA record + +# SRV record +sub _validate_33 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + +# Not absolutely true but WTF use is an SRV record for a reverse zone? + return ('FAIL', 'Reverse zones cannot contain SRV records') if $args{revrec} eq 'y'; + + return ('FAIL', "Distance is required for SRV records") unless defined(${$args{dist}}); + ${$args{dist}} =~ s/\s*//g; + return ('FAIL',"Distance is required, and must be numeric") unless ${$args{dist}} =~ /^\d+$/; + + return ('FAIL',"SRV records must begin with _service._protocol [${$args{host}}]") + unless ${$args{host}} =~ /^_[A-Za-z]+\._[A-Za-z]+\.[a-zA-Z0-9-]+/; + return ('FAIL',"Port and weight are required for SRV records") + unless defined(${$args{weight}}) && defined(${$args{port}}); + ${$args{weight}} =~ s/\s*//g; + ${$args{port}} =~ s/\s*//g; + + return ('FAIL',"Port and weight are required, and must be numeric") + unless ${$args{weight}} =~ /^\d+$/ && ${$args{port}} =~ /^\d+$/; + + ${$args{fields}} = "distance,weight,port,"; + push @{$args{vallist}}, (${$args{dist}}, ${$args{weight}}, ${$args{port}}); + + # Coerce all hostnames to end in ".DOMAIN" for group/default records, + # or the intended parent domain for live records. + my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id})); + ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/; + + return ('OK','OK'); +} # done SRV record + +# Now the custom types + +# A+PTR record. With a very little bit of magic we can also use this sub to validate AAAA+PTR. Whee! +sub _validate_65280 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + my $code = 'OK'; + my $msg = 'OK'; + + if ($args{defrec} eq 'n') { + # live record; revrec determines whether we validate the PTR or A component first. + + if ($args{revrec} eq 'y') { + ($code,$msg) = $self->_validate_12(%args); + return ($code,$msg) if $code eq 'FAIL'; + + # check A+PTR is really v4 + return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv4 address") + if ${$args{rectype}} == 65280 && $args{addr}->{isv6}; + # check AAAA+PTR is really v6 + return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv6 address") + if ${$args{rectype}} == 65281 && !$args{addr}->{isv6}; + + # Check if the reqested domain exists. If not, coerce the type down to PTR and warn. + if (!(${$args{domid}} = $self->_hostparent(${$args{host}}))) { + my $addmsg = "Record ".($args{update} ? 'updated' : 'added'). + " as PTR instead of $typemap{${$args{rectype}}}; domain not found for ${$args{host}}"; + $msg .= "\n$addmsg" if $code eq 'WARN'; + $msg = $addmsg if $code eq 'OK'; + ${$args{rectype}} = $reverse_typemap{PTR}; + return ('WARN', $msg); + } + + # Add domain ID to field list and values + ${$args{fields}} .= "domain_id,"; + push @{$args{vallist}}, ${$args{domid}}; + + } else { + ($code,$msg) = $self->_validate_1(%args) if ${$args{rectype}} == 65280; + ($code,$msg) = $self->_validate_28(%args) if ${$args{rectype}} == 65281; + return ($code,$msg) if $code eq 'FAIL'; + + # Check if the requested reverse zone exists - note, an IP fragment won't + # work here since we don't *know* which parent to put it in. + # ${$args{val}} has been validated as a valid IP by now, in one of the above calls. + my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?". + " ORDER BY masklen(revnet) DESC", undef, (${$args{val}})); + if (!$revid) { + $msg = "Record ".($args{update} ? 'updated' : 'added')." as ".(${$args{rectype}} == 65280 ? 'A' : 'AAAA'). + " instead of $typemap{${$args{rectype}}}; reverse zone not found for ${$args{val}}"; + ${$args{rectype}} = (${$args{rectype}} == 65280 ? $reverse_typemap{A} : $reverse_typemap{AAAA}); + return ('WARN', $msg); + } + + # Check for duplicate PTRs. Note we don't have to play games with $code and $msg, because + # by definition there can't be duplicate PTRs if the reverse zone isn't managed here. + if ($args{update}) { + # Record update. There should usually be an existing PTR (the record being updated) + my @ptrs = @{ $dbh->selectcol_arrayref("SELECT record_id FROM "._rectable($args{defrec},$args{revrec}). + " WHERE val = ?", undef, (${$args{val}})) }; + if (@ptrs && (!grep /^$args{update}$/, @ptrs)) { + $msg = "PTR record for ${$args{val}} already exists; adding another will probably not do what you want"; + $code = 'WARN'; + } + } else { + # New record. Always warn if a PTR exists + my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}). + " WHERE val = ?", undef, (${$args{val}})); + $msg = "PTR record for ${$args{val}} already exists; adding another will probably not do what you want" + if $ptrcount; + $code = 'WARN' if $ptrcount; + } + +# my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}). +# " WHERE val = ?", undef, ${$args{val}}); +# if ($ptrcount) { +# my $curid = $dbh->selectrow_array("SELECT record_id FROM "._rectable($args{defrec},$args{revrec}). +# " WHERE val = ? +# $msg = "PTR record for ${$args{val}} already exists; adding another will probably not do what you want"; +# $code = 'WARN'; +# } + + ${$args{fields}} .= "rdns_id,"; + push @{$args{vallist}}, $revid; + } + + } else { # defrec eq 'y' + if ($args{revrec} eq 'y') { + ($code,$msg) = $self->_validate_12(%args); + return ($code,$msg) if $code eq 'FAIL'; + if (${$args{rectype}} == 65280) { + return ('FAIL',"A+PTR record must be a valid IPv4 address or fragment") + if ${$args{val}} =~ /:/; + ${$args{val}} =~ s/^ZONE,/ZONE./; # Clean up after uncertain IP-fragment-type from _validate_12 + } elsif (${$args{rectype}} == 65281) { + return ('FAIL',"AAAA+PTR record must be a valid IPv6 address or fragment") + if ${$args{val}} =~ /\./; + ${$args{val}} =~ s/^ZONE,/ZONE::/; # Clean up after uncertain IP-fragment-type from _validate_12 + } + } else { + # This is easy. I also can't see a real use-case for A/AAAA+PTR in *all* forward + # domains, since you wouldn't be able to substitute both domain and reverse zone + # sanely, and you'd end up with guaranteed over-replicated PTR records that would + # confuse the hell out of pretty much anything that uses them. +##fixme: make this a config flag? + return ('FAIL', "$typemap{${$args{rectype}}} records not allowed in default domains"); + } + } + + return ($code, $msg); +} # done A+PTR record + +# AAAA+PTR record +# A+PTR above has been magicked to handle AAAA+PTR as well. +sub _validate_65281 { + return _validate_65280(@_); +} # done AAAA+PTR record + +# PTR template record +sub _validate_65282 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + # we're *this* >.< close to being able to just call _validate_12... unfortunately we can't, quite. + if ($args{revrec} eq 'y') { + if ($args{defrec} eq 'n') { + return ('FAIL', "Template block ${$args{val}} is not within ".$self->revName($args{id})) + unless $self->_ipparent($args{defrec}, $args{revrec}, $args{val}, $args{id}, \$args{addr}); +##fixme: warn if $args{val} is not /31 or larger block? + ${$args{val}} = "$args{addr}"; + } else { + if (${$args{val}} =~ /\./) { + # looks like a v4 or fragment + if (${$args{val}} =~ m|^\d+\.\d+\.\d+\.\d+(?:/\d+)?$|) { + # woo! a complete IP! validate it and normalize, or fail. + $args{addr} = NetAddr::IP->new(${$args{val}}) + or return ('FAIL', "IP/value looks like IPv4 but isn't valid"); + ${$args{val}} = "$args{addr}"; + } else { + ${$args{val}} =~ s/^\.*/ZONE./ unless ${$args{val}} =~ /^ZONE/; + } + } elsif (${$args{val}} =~ /[a-f:]/) { + # looks like a v6 or fragment + ${$args{val}} =~ s/^:*/ZONE::/ if !$args{addr} && ${$args{val}} !~ /^ZONE/; + if ($args{addr}) { + if ($args{addr}->addr =~ /^0/) { + ${$args{val}} =~ s/^:*/ZONE::/ unless ${$args{val}} =~ /^ZONE/; + } else { + ${$args{val}} = "$args{addr}"; + } + } + } else { + # bare number (probably). These could be v4 or v6, so we'll + # expand on these on creation of a reverse zone. + ${$args{val}} = "ZONE,${$args{val}}" unless ${$args{val}} =~ /^ZONE/; + } + } +##fixme: validate %-patterns? + +# Unlike single PTR records, there is absolutely no way to sanely support multiple +# PTR templates for the same block, since they expect to expand to all the individual +# IPs on export. Nested templates should be supported though. + + my @checkvals = (${$args{val}}); + if (${$args{val}} =~ /,/) { + # push . and :: variants into checkvals if val has , + my $tmp; + ($tmp = ${$args{val}}) =~ s/,/./; + push @checkvals, $tmp; + ($tmp = ${$args{val}}) =~ s/,/::/; + push @checkvals, $tmp; + } +##fixme: this feels wrong still - need to restrict template pseudorecords to One Of Each +# Per Netblock such that they don't conflict on export + my $typeck; +# type 65282 -> ptr template -> look for any of 65282, 65283, 65284 + $typeck = 'type=65283 OR type=65284' if ${$args{rectype}} == 65282; +# type 65283 -> a+ptr template -> v4 -> look for 65282 or 65283 + $typeck = 'type=65283' if ${$args{rectype}} == 65282; +# type 65284 -> aaaa+ptr template -> v6 -> look for 65282 or 65284 + $typeck = 'type=65284' if ${$args{rectype}} == 65282; + my $pcsth = $dbh->prepare("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec})." WHERE val = ? ". + "AND (type=65282 OR $typeck)"); + foreach my $checkme (@checkvals) { + $pcsth->execute($checkme); + my ($rc) = $pcsth->fetchrow_array; + return ('FAIL', "Only one template pseudorecord may exist for a given IP block") if $rc > 1; + } + + } else { + return ('FAIL', "Forward zones cannot contain PTR records"); + } + + return ('OK','OK'); +} # done PTR template record + +# A+PTR template record +sub _validate_65283 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + my ($code,$msg) = ('OK','OK'); + +##fixme: need to fiddle things since A+PTR templates are acceptable in live +# forward zones but not default records + if ($args{defrec} eq 'n') { + if ($args{revrec} eq 'n') { + ($code,$msg) = $self->_validate_1(%args) if ${$args{rectype}} == 65280; + ($code,$msg) = $self->_validate_28(%args) if ${$args{rectype}} == 65281; + return ($code,$msg) if $code eq 'FAIL'; + + # Check if the requested reverse zone exists - note, an IP fragment won't + # work here since we don't *know* which parent to put it in. + # ${$args{val}} has been validated as a valid IP by now, in one of the above calls. + my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?". + " ORDER BY masklen(revnet) DESC", undef, (${$args{val}})); + # Fail if no match; we can't coerce a PTR-template type down to not include the PTR bit currently. + if (!$revid) { + $msg = "Can't ".($args{update} ? 'update' : 'add')." ${$args{host}}/${$args{val}} as ". + "$typemap{${$args{rectype}}}: reverse zone not found for ${$args{val}}"; +##fixme: add A template, AAAA template types? +# ${$args{rectype}} = (${$args{rectype}} == 65280 ? $reverse_typemap{A} : $reverse_typemap{AAAA}); + return ('FAIL', $msg); + } + + # Add reverse zone ID to field list and values + ${$args{fields}} .= "rdns_id,"; + push @{$args{vallist}}, $revid; + + } else { + return ('FAIL', "IP or IP fragment ${$args{val}} is not within ".$self->revName($args{id})) + unless $self->_ipparent($args{defrec}, $args{revrec}, $args{val}, $args{id}, \$args{addr}); + ${$args{val}} = "$args{addr}"; + + if (!(${$args{domid}} = $self->_hostparent(${$args{host}}))) { + my $addmsg = "Record ".($args{update} ? 'updated' : 'added'). + " as PTR template instead of $typemap{${$args{rectype}}}; domain not found for ${$args{host}}"; + $msg .= "\n$addmsg" if $code eq 'WARN'; + $msg = $addmsg if $code eq 'OK'; + ${$args{rectype}} = 65282; + return ('WARN', $msg); + } + + # Add domain ID to field list and values + ${$args{fields}} .= "domain_id,"; + push @{$args{vallist}}, ${$args{domid}}; + } + + } else { + my ($code,$msg) = $self->_validate_65282(%args); + return ($code, $msg) if $code eq 'FAIL'; + # get domain, check against ${$args{name}} + } + + return ('OK','OK'); +} # done AAAA+PTR template record + +# AAAA+PTR template record +sub _validate_65284 { + return ('OK','OK'); +} # done AAAA+PTR template record + +# Delegation record +# This is essentially a specialized clone of the NS record, primarily useful +# for delegating IPv4 sub-/24 reverse blocks +sub _validate_65285 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + +# Almost, but not quite, identical to NS record validation. + + # Check that the target of the record is within the parent. + # Yes, host<->val are mixed up here; can't see a way to avoid it. :( + if ($args{defrec} eq 'n') { + # Check if IP/address/zone/"subzone" is within the parent + if ($args{revrec} eq 'y') { + my $tmpip = NetAddr::IP->new(${$args{val}}); + my $pname = $self->revName($args{id}); + return ('FAIL',"${$args{val}} not within $pname") + unless $self->_ipparent($args{defrec}, $args{revrec}, $args{val}, $args{id}, \$tmpip); + # Normalize + ${$args{val}} = "$tmpip"; + } else { + my $pname = $self->domainName($args{id}); + ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/; + } + } else { + return ('FAIL',"Delegation records are not permitted in default record sets"); + } + return ('OK','OK'); +} + + +## +## Record data substitution subs +## + +# Replace ZONE in hostname, or create (most of) the actual proper zone name +sub _ZONE { + my $zone = shift; + my $string = shift; + my $fr = shift || 'f'; # flag for forward/reverse order? nb: ignored for IP + my $sep = shift || '-'; # Separator character - unlikely we'll ever need more than . or - + + my $prefix; + + $string =~ s/,/./ if !$zone->{isv6}; + $string =~ s/,/::/ if $zone->{isv6}; + + # Subbing ZONE in the host. We need to properly ID the netblock range + # The subbed text should have "network IP with trailing zeros stripped" for + # blocks lined up on octet (for v4) or hex-quad (for v6) boundaries + # For blocks that do NOT line up on these boundaries, we take the most + # significant octet or 16-bit chunk of the "broadcast" IP and append it + # after a double-dash + # ie: + # 8.0.0.0/6 -> 8.0.0.0 -> 11.255.255.255; sub should be 8--11 + # 10.0.0.0/12 -> 10.0.0.0 -> 10.0.0.0 -> 10.15.255.255; sub should be 10-0--15 + # 192.168.4.0/22 -> 192.168.4.0 -> 192.168.7.255; sub should be 192-168-4--7 + # 192.168.0.8/29 -> 192.168.0.8 -> 192.168.0.15; sub should be 192-168-0-8--15 + # Similar for v6 + + if (!$zone->{isv6}) { # IPv4 + + $prefix = $zone->network->addr; # Just In Case someone managed to slip in + # a funky subnet that had host bits set. + my $bc = $zone->broadcast->addr; + + if ($zone->masklen > 24) { + $bc =~ s/^\d+\.\d+\.\d+\.//; + } elsif ($zone->masklen > 16) { + $prefix =~ s/\.0$//; + $bc =~ s/^\d+\.\d+\.//; + } elsif ($zone->masklen > 8) { + $bc =~ s/^\d+\.//; + $prefix =~ s/\.0\.0$//; + } else { + $prefix =~ s/\.0\.0\.0$//; + } + if ($zone->masklen % 8) { + $bc =~ s/(\.255)+$//; + $prefix .= "--$bc"; #"--".zone->masklen; # use range or mask length? + } + if ($fr eq 'f') { + $prefix =~ s/\.+/$sep/g; + } else { + $prefix = join($sep, reverse(split(/\./, $prefix))); + } + + } else { # IPv6 + + if ($fr eq 'f') { + + $prefix = $zone->network->addr; # Just In Case someone managed to slip in + # a funky subnet that had host bits set. + my $bc = $zone->broadcast->addr; + if (($zone->masklen % 16) != 0) { + # Strip trailing :0 off $prefix, and :ffff off the broadcast IP + for (my $i=0; $i<(7-int($zone->masklen / 16)); $i++) { + $prefix =~ s/:0$//; + $bc =~ s/:ffff$//; + } + # Strip the leading 16-bit chunks off the front of the broadcast IP + $bc =~ s/^([a-f0-9]+:)+//; + # Append the remaining 16-bit chunk to the prefix after "--" + $prefix .= "--$bc"; + } else { + # Strip off :0 from the end until we reach the netblock length. + for (my $i=0; $i<(8-$zone->masklen / 16); $i++) { + $prefix =~ s/:0$//; + } + } + # Actually deal with the separator + $prefix =~ s/:/$sep/g; + + } else { # $fr eq 'f' + + $prefix = $zone->network->full; # Just In Case someone managed to slip in + # a funky subnet that had host bits set. + my $bc = $zone->broadcast->full; + $prefix =~ s/://g; # clean these out since they're not spaced right for this case + $bc =~ s/://g; + # Strip trailing 0 off $prefix, and f off the broadcast IP, to match the mask length + for (my $i=0; $i<(31-int($zone->masklen / 4)); $i++) { + $prefix =~ s/0$//; + $bc =~ s/f$//; + } + # Split and reverse the order of the nibbles in the network/broadcast IPs + # trim another 0 for nibble-aligned blocks first, but only if we really have a block, not an IP + $prefix =~ s/0$// if $zone->masklen % 4 == 0 && $zone->masklen != 128; + my @nbits = reverse split //, $prefix; + my @bbits = reverse split //, $bc; + # Handle the sub-nibble case. Eww. I feel dirty supporting this... + $nbits[0] = "$nbits[0]-$bbits[0]" if ($zone->masklen % 4) != 0; + # Glue it back together + $prefix = join($sep, @nbits); + + } # $fr ne 'f' + + } # $zone->{isv6} + + # Do the substitution, finally + $string =~ s/ZONE/$prefix/; + $string =~ s/--/-/ if $sep ne '-'; # - as separator needs extra help for sub-octet v4 netblocks + return $string; +} # done _ZONE() + +# Not quite a substitution sub, but placed here as it's basically the inverse of above; +# given the .arpa zone name, return the CIDR netblock the zone is for. +# Supports v4 non-octet/non-classful netblocks as per the method outlined in the Grasshopper Book (2nd Ed p217-218) +# Does NOT support non-quad v6 netblocks via the same scheme; it shouldn't ever be necessary. +# Takes a nominal .arpa zone name, returns a success code and NetAddr::IP, or a fail code and message +sub _zone2cidr { + my $zone = shift; + + my $cidr; + my $tmpcidr; + my $warnmsg = ''; + + if ($zone =~ /\.in-addr\.arpa\.?$/) { + # v4 revzone, formal zone name type + my $tmpzone = $zone; + $tmpzone =~ s/\.in-addr\.arpa\.?//; + return ('FAIL', "Non-numerics in apparent IPv4 reverse zone name") if $tmpzone !~ /^(?:\d+-)?[\d\.]+$/; + + # Snag the octet pieces + my @octs = split /\./, $tmpzone; + + # Map result of a range manipulation to a mask length change. Cheaper than finding the 2-root of $octets[0]+1. + # Note we will not support /31 blocks, mostly due to issues telling "24-31" -> .24/29 apart from + # "24-31" -> .24/31", with a litte bit of "/31 is icky". + my %maskmap = ( 3 => 2, 7 => 3, 15 => 4, 31 => 5, 63 => 6, 127 => 7, + 30 => 2, 29 => 3, 28 => 4, 27 => 5, 26 => 6, 25 => 7 + ); + + # Handle "range" blocks, eg, 80-83.168.192.in-addr.arpa (192.168.80.0/22) + # Need to take the size of the range to offset the basic octet-based mask length, + # and make sure the first number in the range gets used as the network address for the block + # Alternate form: The second number is actually the real netmask, not the end of the range. + my $masklen = 0; + if ($octs[0] =~ /^((\d+)-(\d+))$/) { # take the range... + if (24 < $3 && $3 < 31) { + # we have a real netmask + $masklen = -$maskmap{$3}; + } else { + # we have a range. NB: only real CIDR ranges are supported + $masklen -= $maskmap{-(eval $1)}; # find the mask base... + } + $octs[0] = $2; # set the base octet of the range... + } + @octs = reverse @octs; # We can reverse the octet pieces now that we've extracted and munged any ranges + +# arguably we should only allow sub-octet range/mask in-addr.arpa +# specifications in the least significant octet, but the code is +# simpler if we deal with sub-octet delegations at any level. + + # Now we find the "true" mask with the aid of the "base" calculated above + if ($#octs == 0) { + $masklen += 8; + $tmpcidr = "$octs[0].0.0.0/$masklen"; # really hope we don't see one of these very often. + } elsif ($#octs == 1) { + $masklen += 16; + $tmpcidr = "$octs[0].$octs[1].0.0/$masklen"; + } elsif ($#octs == 2) { + $masklen += 24; + $tmpcidr = "$octs[0].$octs[1].$octs[2].0/$masklen"; + } else { + $masklen += 32; + $tmpcidr = "$octs[0].$octs[1].$octs[2].$octs[3]/$masklen"; + } + + } elsif ($zone =~ /\.ip6\.arpa$/) { + # v6 revzone, formal zone name type + my $tmpzone = $zone; + $tmpzone =~ s/\.ip6\.arpa\.?//; +##fixme: if-n-when we decide we can support sub-nibble v6 zone names, we'll need to change this segment + return ('FAIL', "Non-hexadecimals in apparent IPv6 reverse zone name") if $tmpzone !~ /^[a-fA-F\d\.]+$/; + my @quads = reverse(split(/\./, $tmpzone)); + $warnmsg .= "Apparent sub-/64 IPv6 reverse zone\n" if $#quads > 15; + my $nc; + foreach (@quads) { + $tmpcidr .= $_; + $tmpcidr .= ":" if ++$nc % 4 == 0; + } + my $nq = 1 if $nc % 4 != 0; + my $mask = $nc * 4; # need to do this here because we probably increment it below + while ($nc++ % 4 != 0) { + $tmpcidr .= "0"; + } + $tmpcidr .= ($nq ? '::' : ':')."/$mask"; + } + + # Just to be sure, use NetAddr::IP to validate. Saves a lot of nasty regex watching for valid octet values. + return ('FAIL', "Invalid zone $zone (apparent netblock $tmpcidr)") + unless $cidr = NetAddr::IP->new($tmpcidr); + + if ($warnmsg) { + $errstr = $warnmsg; + return ('WARN', $cidr); + } + return ('OK', $cidr); +} # done _zone2cidr() + +# Record template %-parameter expansion, IPv4. Note that IPv6 doesn't +# really have a sane way to handle this type of expansion at the moment +# due to the size of the address space. +# Takes a reference to a template string to be expanded, and an IP to use in the replacement. +sub _template4_expand { + my $tmpl = shift; + my $ip = shift; + + my @ipparts = split /\./, $ip; + my @iphex; + my @ippad; + for (@ipparts) { + push @iphex, sprintf("%x", $_); + push @ippad, sprintf("%0.3u", $_); + } + + # IP substitutions in template records: + #major patterns: + #dashed IP, forward and reverse + #underscoreed IP, forward and reverse + #dotted IP, forward and reverse (even if forward is... dumb) + # -> %r for reverse, %i for forward, leading -, _, or . to indicate separator, defaults to - + # %r or %-r => %4d-%3d-%2d-%1d + # %_r => %4d_%3d_%2d_%1d + # %.r => %4d.%3d.%2d.%1d + # %i or %-i => %1d-%2d-%3d-%4d + # %_i => %1d_%2d_%3d_%4d + # %.i => %1d.%2d.%3d.%4d + $$tmpl =~ s/\%r/\%4d-\%3d-\%2d-\%1d/g; + $$tmpl =~ s/\%([-._])r/\%4d$1\%3d$1\%2d$1\%1d/g; + $$tmpl =~ s/\%i/\%1d-\%2d-\%3d-\%4d/g; + $$tmpl =~ s/\%([-._])i/\%1d$1\%2d$1\%3d$1\%4d/g; + + #hex-coded IP + # %h + $$tmpl =~ s/\%h/$iphex[0]$iphex[1]$iphex[2]$iphex[3]/g; + + #IP as decimal-coded 32-bit value + # %d + my $iptmp = $ipparts[0]*256*256*256 + $ipparts[1]*256*256 + $ipparts[2]*256 + $ipparts[3]; + $$tmpl =~ s/\%d/$iptmp/g; + + #minor patterns (per-octet) + # %[1234][dh0] + #octet + #hex-coded octet + #0-padded octet + $$tmpl =~ s/\%([1234])d/$ipparts[$1-1]/g; + $$tmpl =~ s/\%([1234])h/$iphex[$1-1]/g; + $$tmpl =~ s/\%([1234])0/$ippad[$1-1]/g; +} # _template4_expand() + +# Broad syntactic check on the hostname. Checks for valid characters, correctly-expandable template patterns. +# Takes the hostname, type, and live/default and forward/reverse flags +# Returns true/false, sets errstr on failures +sub _check_hostname_form { + my ($hname,$rectype,$defrec,$revrec) = @_; + + if ($hname =~ /\%/ && ($rectype == 65282 || $rectype == 65283) ) { + my $tmphost = $hname; + # we don't actually need to test with the real IP passed; that saves a bit of fiddling. + _template4_expand(\$tmphost, '10.10.10.10'); + if ($tmphost =~ /\%/) { + $errstr = "Invalid template $hname"; + return; + } + } elsif ($revrec eq 'y') { + # Reverse zones don't support @ in hostnames + # Also skip failure on revzone TXT records; the hostname contains the TXT content in that case. + if ($rectype != $reverse_typemap{TXT} && lc($hname) !~ /^[0-9a-z_.-]+$/) { + $errstr = "Hostnames may not contain anything other than (0-9 a-z . _)"; + return; + } + } else { + if (lc($hname) !~ /^(?:[0-9a-z_.-]+|@)$/) { + # Don't mention @, because it would be far too wordy to explain the nuance of @ + $errstr = "Hostnames may not contain anything other than (0-9 a-z . _)"; + return; + } + } + return 1; +} # _check_hostname_form() + + +## +## Initialization and cleanup subs +## + +## DNSDB::__cfgload() +# Private sub to parse a config file and load it into %config +# Takes a filename and a hashref to put the parsed entries in +sub __cfgload { + $errstr = ''; + my $cfgfile = shift; + my $cfg = shift; + + if (open CFG, "<$cfgfile") { + while () { + chomp; + s/^\s*//; + next if /^#/; + next if /^$/; +# hmm. more complex bits in this file might require [heading] headers, maybe? +# $mode = $1 if /^\[(a-z)+]/; + # DB connect info + $cfg->{dbname} = $1 if /^dbname\s*=\s*([a-z0-9_.-]+)/i; + $cfg->{dbuser} = $1 if /^dbuser\s*=\s*([a-z0-9_.-]+)/i; + $cfg->{dbpass} = $1 if /^dbpass\s*=\s*([a-z0-9_.-]+)/i; + $cfg->{dbhost} = $1 if /^dbhost\s*=\s*([a-z0-9_.-]+)/i; + # Mail settings + $cfg->{mailhost} = $1 if /^mailhost\s*=\s*([a-z0-9_.-]+)/i; + $cfg->{mailnotify} = $1 if /^mailnotify\s*=\s*([a-z0-9_.\@-]+)/i; + $cfg->{mailsender} = $1 if /^mailsender\s*=\s*([a-z0-9_.\@-]+)/i; + $cfg->{mailname} = $1 if /^mailname\s*=\s*([a-z0-9\s_.-]+)/i; + $cfg->{orgname} = $1 if /^orgname\s*=\s*([a-z0-9\s_.,'-]+)/i; + $cfg->{domain} = $1 if /^domain\s*=\s*([a-z0-9_.-]+)/i; + # session - note this is fed directly to CGI::Session + $cfg->{timeout} = $1 if /^[tT][iI][mM][eE][oO][uU][tT]\s*=\s*(\d+[smhdwMy]?)/; + $cfg->{sessiondir} = $1 if m{^sessiondir\s*=\s*([a-z0-9/_.-]+)}i; + # misc + $cfg->{log_failures} = $1 if /^log_failures\s*=\s*([a-z01]+)/i; + $cfg->{perpage} = $1 if /^perpage\s*=\s*(\d+)/i; + $cfg->{exportcache} = $1 if m{^exportcache\s*=\s*([a-z0-9/_.-]+)}i; + $cfg->{lowercase} = $1 if /^lowercase\s*=\s*([a-z01]+)/i; +# not supported in dns.cgi yet +# $cfg->{templatedir} = $1 if m{^templatedir\s*=\s*([a-z0-9/_.-]+)}i; +# $cfg->{templateoverride} = $1 if m{^templateoverride\s*=\s*([a-z0-9/_.-]+)}i; + # RPC options + $cfg->{rpcmode} = $1 if /^rpc_mode\s*=\s*(socket|HTTP|XMLRPC)\s*$/i; + $cfg->{maxfcgi} = $1 if /^max_fcgi_requests\s*=\s*(\d+)\s*$/i; + $cfg->{force_refresh} = $1 if /^force_refresh\s*=\s*([a-z01]+)/i; + if (my ($tmp) = /^rpc_iplist\s*=\s*(.+)/i) { + my @ips = split /[,\s]+/, $tmp; + my $rpcsys = shift @ips; + push @{$cfg->{rpcacl}{$rpcsys}}, @ips; + } + } + close CFG; + } else { + $errstr = "Couldn't load configuration file $cfgfile: $!"; + return; + } + return 1; +} # end __cfgload() + + +## DNSDB::connectDB() +# Creates connection to DNS database. +# Requires the database name, username, and password. +# Returns a handle to the db or undef on failure. +# Set up for a PostgreSQL db; could be any transactional DBMS with the +# right changes. +# Called by new(); not intended to be called publicly. +sub connectDB { + $errstr = ''; + my $dbname = shift; + my $user = shift; + my $pass = shift; + my $dbh; + my $DSN = "DBI:Pg:dbname=$dbname"; + + my $host = shift; + $DSN .= ";host=$host" if $host; + +# Note that we want to autocommit by default, and we will turn it off locally as necessary. +# We may not want to print gobbledygook errors; YMMV. Have to ponder that further. + $dbh = DBI->connect($DSN, $user, $pass, { + AutoCommit => 1, + PrintError => 0 + }); + if (!$dbh) { + $errstr = $DBI::errstr; + return; + } +#) if(!$dbh); + + local $dbh->{RaiseError} = 1; + + eval { +##fixme: initialize the DB if we can't find the table (since, by definition, there's +# nothing there if we can't select from it...) + my $tblsth = $dbh->prepare("SELECT count(*) FROM pg_catalog.pg_class WHERE relkind='r' AND relname=?"); + my ($tblcount) = $dbh->selectrow_array($tblsth, undef, ('misc')); +# return (undef,$DBI::errstr) if $dbh->err; + +#if ($tblcount == 0) { +# # create tables one at a time, checking for each. +# return (undef, "check table misc missing"); +#} + +# Return here if we can't select. +# This should retrieve the dbversion key. + my $sth = $dbh->prepare("SELECT key,value FROM misc WHERE misc_id=1"); + $sth->execute(); +# return (undef,$DBI::errstr) if ($sth->err); + +##fixme: do stuff to the DB on version mismatch +# x.y series should upgrade on $DNSDB::VERSION > misc(key=>version) +# DB should be downward-compatible; column defaults should give sane (if possibly +# useless-and-needs-help) values in columns an older software stack doesn't know about. + +# See if the select returned anything (or null data). This should +# succeed if the select executed, but... + $sth->fetchrow(); +# return (undef,$DBI::errstr) if ($sth->err); + + $sth->finish; + + }; # wrapped DB checks + if ($@) { + $errstr = $@; + return; + } + +# If we get here, we should be OK. + return $dbh; +} # end connectDB + + +## DNSDB::finish() +# Cleans up after database handles and so on. +# Requires a database handle +sub finish { + my $self = shift; + $self->{dbh}->disconnect; +} # end finish + + +## DNSDB::initGlobals() +# Initialize global variables +# NB: this does NOT include web-specific session variables! +sub initGlobals { + my $self = shift; + my $dbh = $self->{dbh}; + +# load record types from database + my $sth = $dbh->prepare("SELECT val,name,stdflag FROM rectypes"); + $sth->execute; + while (my ($recval,$recname,$stdflag) = $sth->fetchrow_array()) { + $typemap{$recval} = $recname; + $reverse_typemap{$recname} = $recval; + # now we fill the record validation function hash + if ($stdflag < 5) { + my $fn = "_validate_$recval"; + $validators{$recval} = \&$fn; + } else { + my $fn = "sub { return ('FAIL','Type $recval ($recname) not supported'); }"; + $validators{$recval} = eval $fn; + } + } +} # end initGlobals + + +## DNSDB::initRPC() +# Takes a remote username and remote fullname. +# Sets up the RPC logging-pseudouser if needed. +# Sets the %userdata hash for logging. +# Returns undef on failure +sub initRPC { + my $self = shift; + my $dbh = $self->{dbh}; + my %args = @_; + + return if !$args{username}; + return if !$args{fullname}; + + $args{username} = "$args{username}/$args{rpcsys}"; + + my $tmpuser = $dbh->selectrow_hashref("SELECT username,user_id AS userid,group_id,firstname,lastname,status". + " FROM users WHERE username=?", undef, ($args{username}) ); + if (!$tmpuser) { + $dbh->do("INSERT INTO users (username,password,firstname,type) VALUES (?,'RPC',?,'R')", undef, + ($args{username}, $args{fullname}) ); + $tmpuser = $dbh->selectrow_hashref("SELECT username,user_id AS userid,group_id,firstname,lastname,status". + " FROM users WHERE username=?", undef, ($args{username}) ); + } + $tmpuser->{lastname} = '' if !$tmpuser->{lastname}; + $self->{loguserid} = $tmpuser->{userid}; + $self->{logusername} = $tmpuser->{username}; + $self->{logfullname} = "$tmpuser->{firstname} $tmpuser->{lastname} ($args{rpcsys})"; + return 1 if $tmpuser; +} # end initRPC() + + +## DNSDB::login() +# Takes a database handle, username and password +# Returns a userdata hash (UID, GID, username, fullname parts) if username exists, +# password matches the one on file, and account is not disabled +# Returns undef otherwise +sub login { + my $self = shift; + my $dbh = $self->{dbh}; + my $user = shift; + my $pass = shift; + + my $userinfo = $dbh->selectrow_hashref("SELECT user_id,group_id,password,firstname,lastname,status". + " FROM users WHERE username=?", + undef, ($user) ); + return if !$userinfo; + return if !$userinfo->{status}; + + if ($userinfo->{password} =~ m|^\$1\$([A-Za-z0-9/.]+)\$|) { + # native passwords (crypt-md5) + return if $userinfo->{password} ne unix_md5_crypt($pass,$1); + } elsif ($userinfo->{password} =~ /^[0-9a-f]{32}$/) { + # VegaDNS import (hex-coded MD5) + return if $userinfo->{password} ne md5_hex($pass); + } else { + # plaintext (convenient now and then) + return if $userinfo->{password} ne $pass; + } + + return $userinfo; +} # end login() + + +## DNSDB::initActionLog() +# Set up action logging. Takes a database handle and user ID +# Sets some internal globals and Does The Right Thing to set up a logging channel. +# This sets up _log() to spew out log entries to the defined channel without worrying +# about having to open a file or a syslog channel +##fixme Need to call _initActionLog_blah() for various logging channels, configured +# via dnsdb.conf, in $self->{log_channel} or something +# See https://secure.deepnet.cx/trac/dnsadmin/ticket/21 +sub initActionLog { + my $self = shift; + my $dbh = $self->{dbh}; + my $uid = shift; + + return if !$uid; + + # snag user info for logging. there's got to be a way to not have to pass this back + # and forth from a caller, but web usage means no persistence we can rely on from + # the server side. + my ($username,$fullname) = $dbh->selectrow_array("SELECT username, firstname || ' ' || lastname". + " FROM users WHERE user_id=?", undef, ($uid)); +##fixme: errors are unpossible! + + $self->{logusername} = $username; + $self->{loguserid} = $uid; + $self->{logfullname} = $fullname; + + # convert to real check once we have other logging channels + # if ($self->{log_channel} eq 'sql') { + # Open Log, Sez Me! + # } + +} # end initActionLog + + +## DNSDB::getPermissions() +# Get permissions from DB +# Requires DB handle, group or user flag, ID, and hashref. +sub getPermissions { + my $self = shift; + my $dbh = $self->{dbh}; + + my $type = shift; + my $id = shift; + my $hash = shift; + + my $sql = qq( + SELECT + p.admin,p.self_edit, + p.group_create,p.group_edit,p.group_delete, + p.user_create,p.user_edit,p.user_delete, + p.domain_create,p.domain_edit,p.domain_delete, + p.record_create,p.record_edit,p.record_delete,p.record_locchg, + p.location_create,p.location_edit,p.location_delete,p.location_view + FROM permissions p + ); + if ($type eq 'group') { + $sql .= qq( + JOIN groups g ON g.permission_id=p.permission_id + WHERE g.group_id=? + ); + } else { + $sql .= qq( + JOIN users u ON u.permission_id=p.permission_id + WHERE u.user_id=? + ); + } + + my $sth = $dbh->prepare($sql); + +##fixme? we don't trap other plain SELECT errors + $sth->execute($id); + +# my $permref = $sth->fetchrow_hashref; +# return $permref; +# $hash = $permref; +# Eww. Need to learn how to forcibly drop a hashref onto an existing hash. + ($hash->{admin},$hash->{self_edit}, + $hash->{group_create},$hash->{group_edit},$hash->{group_delete}, + $hash->{user_create},$hash->{user_edit},$hash->{user_delete}, + $hash->{domain_create},$hash->{domain_edit},$hash->{domain_delete}, + $hash->{record_create},$hash->{record_edit},$hash->{record_delete},$hash->{record_locchg}, + $hash->{location_create},$hash->{location_edit},$hash->{location_delete},$hash->{location_view} + ) = $sth->fetchrow_array; + +} # end getPermissions() + + +## DNSDB::changePermissions() +# Update an ACL entry +# Takes a db handle, type, owner-id, and hashref for the changed permissions. +sub changePermissions { + my $self = shift; + my $dbh = $self->{dbh}; + my $type = shift; + my $id = shift; + my $newperms = shift; + my $inherit = shift || 0; + + my $resultmsg = ''; + + # see if we're switching from inherited to custom. for bonus points, + # snag the permid and parent permid anyway, since we'll need the permid + # to set/alter custom perms, and both if we're switching from custom to + # inherited. + my $sth = $dbh->prepare("SELECT (u.permission_id=g.permission_id) AS was_inherited,u.permission_id,g.permission_id,". + ($type eq 'user' ? 'u.group_id,u.username' : 'u.parent_group_id,u.group_name'). + " FROM ".($type eq 'user' ? 'users' : 'groups')." u ". + " JOIN groups g ON u.".($type eq 'user' ? '' : 'parent_')."group_id=g.group_id ". + " WHERE u.".($type eq 'user' ? 'user' : 'group')."_id=?"); + $sth->execute($id); + + my ($wasinherited,$permid,$parpermid,$parid,$name) = $sth->fetchrow_array; + +# hack phtoui +# group id 1 is "special" in that it's it's own parent (err... possibly.) +# may make its parent id 0 which doesn't exist, and as a bonus is Perl-false. + $wasinherited = 0 if ($type eq 'group' && $id == 1); + + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + # Wrap all the SQL in a transaction + eval { + if ($inherit) { + + $dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='t',permission_id=? ". + "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($parpermid, $id) ); + $dbh->do("DELETE FROM permissions WHERE permission_id=?", undef, ($permid) ); + + } else { + + if ($wasinherited) { # munge new permission entry in if we're switching from inherited perms +##fixme: need to add semirecursive bit to properly munge inherited permission ID on subgroups and users +# ... if'n'when we have groups with fully inherited permissions. + # SQL is coo + $dbh->do("INSERT INTO permissions ($permlist,".($type eq 'user' ? 'user' : 'group')."_id) ". + "SELECT $permlist,? FROM permissions WHERE permission_id=?", undef, ($id,$permid) ); + ($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions ". + "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($id) ); + $dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='f',permission_id=? ". + "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($permid, $id) ); + } + + # and now set the permissions we were passed + foreach (@permtypes) { + if (defined ($newperms->{$_})) { + $dbh->do("UPDATE permissions SET $_=? WHERE permission_id=?", undef, ($newperms->{$_},$permid) ); + } + } + + } # (inherited->)? custom + + if ($type eq 'user') { + $resultmsg = "Updated permissions for user $name"; + } else { + $resultmsg = "Updated default permissions for group $name"; + } + $self->_log(group_id => ($type eq 'user' ? $parid : $id), entry => $resultmsg); + $dbh->commit; + }; # end eval + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + return ('FAIL',"Error changing permissions: $msg"); + } + + return ('OK',$resultmsg); +} # end changePermissions() + + +## DNSDB::comparePermissions() +# Compare two permission hashes +# Returns '>', '<', '=', '!' +sub comparePermissions { + my $p1 = shift; + my $p2 = shift; + + my $retval = '='; # assume equality until proven otherwise + + no warnings "uninitialized"; + + foreach (@permtypes) { + next if $p1->{$_} == $p2->{$_}; # equal is good + if ($p1->{$_} && !$p2->{$_}) { + if ($retval eq '<') { # if we've already found an unequal pair where + $retval = '!'; # $p2 has more access, and we now find a pair + last; # where $p1 has more access, the overall access + } # is neither greater or lesser, it's unequal. + $retval = '>'; + } + if (!$p1->{$_} && $p2->{$_}) { + if ($retval eq '>') { # if we've already found an unequal pair where + $retval = '!'; # $p1 has more access, and we now find a pair + last; # where $p2 has more access, the overall access + } # is neither greater or lesser, it's unequal. + $retval = '<'; + } + } + return $retval; +} # end comparePermissions() + + +## DNSDB::changeGroup() +# Change group ID of an entity +# Takes a database handle, entity type, entity ID, and new group ID +sub changeGroup { + my $self = shift; + my $dbh = $self->{dbh}; + my $type = shift; + my $id = shift; + my $newgrp = shift; + +##fixme: fail on not enough args + #return ('FAIL', "Missing + + return ('FAIL', "Can't change the group of a $type") + unless grep /^$type$/, ('domain','revzone','user','group'); # could be extended for defrecs? + + # Collect some names for logging and messages + my $entname; + if ($type eq 'domain') { + $entname = $self->domainName($id); + } elsif ($type eq 'revzone') { + $entname = $self->revName($id); + } elsif ($type eq 'user') { + $entname = $self->userFullName($id, '%u'); + } elsif ($type eq 'group') { + $entname = $self->groupName($id); + } + + my ($oldgid) = $dbh->selectrow_array("SELECT group_id FROM $par_tbl{$type} WHERE $id_col{$type}=?", + undef, ($id)); + my $oldgname = $self->groupName($oldgid); + my $newgname = $self->groupName($newgrp); + + return ('FAIL', "Can't move things into a group that doesn't exist") if !$newgname; + + return ('WARN', "Nothing to do, new group is the same as the old group") if $oldgid == $newgrp; + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + eval { + $dbh->do("UPDATE $par_tbl{$type} SET group_id=? WHERE $id_col{$type}=?", undef, ($newgrp, $id)); + # Log the change in both the old and new groups + $self->_log(group_id => $oldgid, entry => "Moved $type $entname from $oldgname to $newgname"); + $self->_log(group_id => $newgrp, entry => "Moved $type $entname from $oldgname to $newgname"); + $dbh->commit; + }; + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + if ($self->{log_failures}) { + $self->_log(group_id => $oldgid, entry => "Error moving $type $entname to $newgname: $msg"); + $dbh->commit; # since we enabled transactions earlier + } + return ('FAIL',"Error moving $type $entname to $newgname: $msg"); + } + + return ('OK',"Moved $type $entname from $oldgname to $newgname"); +} # end changeGroup() + + +## +## Processing subs +## + +## DNSDB::addDomain() +# Add a domain +# Takes a database handle, domain name, numeric group, boolean(ish) state (active/inactive), +# and user info hash (for logging). +# Returns a status code and message +sub addDomain { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $domain = shift; + return ('FAIL',"Domain must not be blank\n") if !$domain; + my $group = shift; + return ('FAIL',"Group must be specified\n") if !defined($group); + my $state = shift; + return ('FAIL',"Domain status must be specified\n") if !defined($state); + my $defloc = shift || ''; + + $state = 1 if $state =~ /^active$/; + $state = 1 if $state =~ /^on$/; + $state = 0 if $state =~ /^inactive$/; + $state = 0 if $state =~ /^off$/; + + return ('FAIL',"Invalid domain status") if $state !~ /^\d+$/; + + $domain = lc($domain) if $self->{lowercase}; + + return ('FAIL', "Invalid characters in domain") if $domain !~ /^[a-zA-Z0-9_.-]+$/; + + my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)"); + my $dom_id; + +# quick check to start to see if we've already got one + $sth->execute($domain); + ($dom_id) = $sth->fetchrow_array; + + return ('FAIL', "Domain already exists") if $dom_id; + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + # Wrap all the SQL in a transaction + eval { + # insert the domain... + $dbh->do("INSERT INTO domains (domain,group_id,status,default_location) VALUES (?,?,?,?)", undef, + ($domain, $group, $state, $defloc)); + + # get the ID... + ($dom_id) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)", + undef, ($domain)); + + $self->_log(domain_id => $dom_id, group_id => $group, + entry => "Added ".($state ? 'active' : 'inactive')." domain $domain"); + + # ... and now we construct the standard records from the default set. NB: group should be variable. + my $sth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?"); + my $sth_in = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,distance,weight,port,ttl,location)". + " VALUES ($dom_id,?,?,?,?,?,?,?,?)"); + $sth->execute($group); + while (my ($host, $type, $val, $dist, $weight, $port, $ttl) = $sth->fetchrow_array()) { + $host =~ s/DOMAIN/$domain/g; + $val =~ s/DOMAIN/$domain/g; + $sth_in->execute($host, $type, $val, $dist, $weight, $port, $ttl, $defloc); + if ($typemap{$type} eq 'SOA') { + my @tmp1 = split /:/, $host; + my @tmp2 = split /:/, $val; + $self->_log(domain_id => $dom_id, group_id => $group, + entry => "[new $domain] Added SOA record [contact $tmp1[0]] [master $tmp1[1]] ". + "[refresh $tmp2[0]] [retry $tmp2[1]] [expire $tmp2[2]] [minttl $tmp2[3]], TTL $ttl"); + } else { + my $logentry = "[new $domain] Added record '$host $typemap{$type}"; + $logentry .= " [distance $dist]" if $typemap{$type} eq 'MX'; + $logentry .= " [priority $dist] [weight $weight] [port $port]" if $typemap{$type} eq 'SRV'; + $self->_log(domain_id => $dom_id, group_id => $group, + entry => $logentry." $val', TTL $ttl"); + } + } + + # once we get here, we should have suceeded. + $dbh->commit; + }; # end eval + + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + $self->_log(group_id => $group, entry => "Failed adding domain $domain ($msg)") + if $self->{log_failures}; + $dbh->commit; # since we enabled transactions earlier + return ('FAIL',$msg); + } else { + return ('OK',$dom_id); + } +} # end addDomain + + +## DNSDB::delZone() +# Delete a forward or reverse zone. +# Takes a database handle, zone ID, and forward/reverse flag. +# for now, just delete the records, then the domain. +# later we may want to archive it in some way instead (status code 2, for example?) +sub delZone { + my $self = shift; + my $dbh = $self->{dbh}; + my $zoneid = shift; + my $revrec = shift; + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + my $msg = ''; + my $failmsg = ''; + my $zone = ($revrec eq 'n' ? $self->domainName($zoneid) : $self->revName($zoneid)); + + return ('FAIL', ($revrec eq 'n' ? 'Domain' : 'Reverse zone')." ID $zoneid doesn't exist") if !$zone; + + # Set this up here since we may use if if $self->{log_failures} is enabled + my %loghash; + $loghash{domain_id} = $zoneid if $revrec eq 'n'; + $loghash{rdns_id} = $zoneid if $revrec eq 'y'; + $loghash{group_id} = $self->parentID( + id => $zoneid, type => ($revrec eq 'n' ? 'domain' : 'revzone'), revrec => $revrec); + + # Wrap all the SQL in a transaction + eval { + # Disentangle custom record types before removing the + # ones that are only in the zone to be deleted + if ($revrec eq 'n') { + my $sth = $dbh->prepare("UPDATE records SET type=?,domain_id=0 WHERE domain_id=? AND type=?"); + $failmsg = "Failure converting multizone types to single-zone"; + $sth->execute($reverse_typemap{PTR}, $zoneid, 65280); + $sth->execute($reverse_typemap{PTR}, $zoneid, 65281); + $sth->execute(65282, $zoneid, 65283); + $sth->execute(65282, $zoneid, 65284); + $failmsg = "Failure removing domain records"; + $dbh->do("DELETE FROM records WHERE domain_id=?", undef, ($zoneid)); + $failmsg = "Failure removing domain"; + $dbh->do("DELETE FROM domains WHERE domain_id=?", undef, ($zoneid)); + } else { + my $sth = $dbh->prepare("UPDATE records SET type=?,rdns_id=0 WHERE rdns_id=? AND type=?"); + $failmsg = "Failure converting multizone types to single-zone"; + $sth->execute($reverse_typemap{A}, $zoneid, 65280); + $sth->execute($reverse_typemap{AAAA}, $zoneid, 65281); +# We don't have an "A template" or "AAAA template" type, although it might be useful for symmetry. +# $sth->execute(65286?, $zoneid, 65283); +# $sth->execute(65286?, $zoneid, 65284); + $failmsg = "Failure removing reverse records"; + $dbh->do("DELETE FROM records WHERE rdns_id=?", undef, ($zoneid)); + $failmsg = "Failure removing reverse zone"; + $dbh->do("DELETE FROM revzones WHERE rdns_id=?", undef, ($zoneid)); + } + + $msg = "Deleted ".($revrec eq 'n' ? 'domain' : 'reverse zone')." $zone"; + $loghash{entry} = $msg; + $self->_log(%loghash); + + # once we get here, we should have suceeded. + $dbh->commit; + }; # end eval + + if ($@) { + $msg = $@; + eval { $dbh->rollback; }; + $loghash{entry} = "Error deleting $zone: $msg ($failmsg)"; + if ($self->{log_failures}) { + $self->_log(%loghash); + $dbh->commit; # since we enabled transactions earlier + } + return ('FAIL', $loghash{entry}); + } else { + return ('OK', $msg); + } + +} # end delZone() + + +## DNSDB::domainName() +# Return the domain name based on a domain ID +# Takes a database handle and the domain ID +# Returns the domain name or undef on failure +sub domainName { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $domid = shift; + my ($domname) = $dbh->selectrow_array("SELECT domain FROM domains WHERE domain_id=?", undef, ($domid) ); + $errstr = $DBI::errstr if !$domname; + return $domname if $domname; +} # end domainName() + + +## DNSDB::revName() +# Return the reverse zone name based on an rDNS ID +# Takes a database handle and the rDNS ID +# Returns the reverse zone name or undef on failure +sub revName { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $revid = shift; + my ($revname) = $dbh->selectrow_array("SELECT revnet FROM revzones WHERE rdns_id=?", undef, ($revid) ); + $errstr = $DBI::errstr if !$revname; + return $revname if $revname; +} # end revName() + + +## DNSDB::domainID() +# Takes a database handle and domain name +# Returns the domain ID number +sub domainID { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $domain = shift; + my ($domid) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)", + undef, ($domain) ); + if (!$domid) { + if ($dbh->err) { + $errstr = $DBI::errstr; + } else { + $errstr = "Domain $domain not present"; + } + } + return $domid if $domid; +} # end domainID() + + +## DNSDB::revID() +# Takes a database handle and reverse zone name +# Returns the rDNS ID number +sub revID { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $revzone = shift; + my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet=?", undef, ($revzone) ); + if (!$revid) { + if ($dbh->err) { + $errstr = $DBI::errstr; + } else { + $errstr = "Reverse zone $revzone not present"; + } + } + return $revid if $revid; +} # end revID() + + +## DNSDB::addRDNS +# Adds a reverse DNS zone +# Takes a database handle, CIDR block, reverse DNS pattern, numeric group, +# and boolean(ish) state (active/inactive) +# Returns a status code and message +sub addRDNS { + my $self = shift; + my $dbh = $self->{dbh}; + my $zone = NetAddr::IP->new(shift); + + return ('FAIL',"Zone name must be a valid CIDR netblock") unless ($zone && $zone->addr !~ /^0/); + my $revpatt = shift; # construct a custom (A/AAAA+)? PTR template record + my $group = shift; + my $state = shift; + my $defloc = shift || ''; + + $state = 1 if $state =~ /^active$/; + $state = 1 if $state =~ /^on$/; + $state = 0 if $state =~ /^inactive$/; + $state = 0 if $state =~ /^off$/; + + return ('FAIL',"Invalid zone status") if $state !~ /^\d+$/; + +# quick check to start to see if we've already got one + my ($rdns_id) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet=?", undef, ("$zone")); + + return ('FAIL', "Zone already exists") if $rdns_id; + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + my $warnstr = ''; + my $defttl = 3600; # 1 hour should be reasonable. And unless things have gone horribly + # wrong, we should have a value to override this anyway. + + # Wrap all the SQL in a transaction + eval { + # insert the zone... + $dbh->do("INSERT INTO revzones (revnet,group_id,status,default_location) VALUES (?,?,?,?)", undef, + ($zone, $group, $state, $defloc) ); + + # get the ID... + ($rdns_id) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')"); + + $self->_log(rdns_id => $rdns_id, group_id => $group, + entry => "Added ".($state ? 'active' : 'inactive')." reverse zone $zone"); + + # ... and now we construct the standard records from the default set. NB: group should be variable. + my $sth = $dbh->prepare("SELECT host,type,val,ttl FROM default_rev_records WHERE group_id=?"); + my $sth_in = $dbh->prepare("INSERT INTO records (rdns_id,domain_id,host,type,val,ttl,location)". + " VALUES ($rdns_id,?,?,?,?,?,?)"); + $sth->execute($group); + while (my ($host,$type,$val,$ttl) = $sth->fetchrow_array()) { + # Silently skip v4/v6 mismatches. This is not an error, this is expected. + if ($zone->{isv6}) { + next if ($type == 65280 || $type == 65283); + } else { + next if ($type == 65281 || $type == 65284); + } + + $host =~ s/ADMINDOMAIN/$self->{domain}/g; + + # Check to make sure the IP stubs will fit in the zone. Under most usage failures here should be rare. + # On failure, tack a note on to a warning string and continue without adding this record. + # While we're at it, we substitute $zone for ZONE in the value. + if ($val eq 'ZONE') { + # If we've got a pattern, we skip the default record version on (A+)PTR-template types + next if $revpatt && ($type == 65282 || $type == 65283); +##fixme? do we care if we have multiple whole-zone templates? + $val = $zone->network; + } elsif ($val =~ /ZONE/) { + my $tmpval = $val; + $tmpval =~ s/ZONE//; + # Bend the rules and allow single-trailing-number PTR or PTR template records to be inserted + # as either v4 or v6. May make this an off-by-default config flag + # Note that the origin records that may trigger this **SHOULD** already have ZONE,\d + if ($type == 12 || $type == 65282) { + $tmpval =~ s/[,.]/::/ if ($tmpval =~ /^[,.]\d+$/ && $zone->{isv6}); + $tmpval =~ s/[,:]+/./ if ($tmpval =~ /^(?:,|::)\d+$/ && !$zone->{isv6}); + } + my $addr; + if ($self->_ipparent('n', 'y', \$tmpval, $rdns_id, \$addr)) { + $val = $addr->addr; + } else { + $warnstr .= "\nDefault record '$val $typemap{$type} $host' doesn't fit in $zone, skipping"; + next; + } + } + + # Substitute $zone for ZONE in the hostname, but only for non-NS records. + # NS records get this substitution on the value instead. + $host = _ZONE($zone, $host) if $type != 2; + + # Fill in the forward domain ID if we can find it, otherwise: + # Coerce type down to PTR or PTR template if we can't + my $domid = 0; + if ($type >= 65280) { + if (!($domid = $self->_hostparent($host))) { + $warnstr .= "\nRecord added as PTR instead of $typemap{$type}; domain not found for $host"; + $type = $reverse_typemap{PTR}; + $domid = 0; # just to be explicit. + } + } + + $sth_in->execute($domid,$host,$type,$val,$ttl,$defloc); + + if ($typemap{$type} eq 'SOA') { + my @tmp1 = split /:/, $host; + my @tmp2 = split /:/, $val; + $self->_log(rdns_id => $rdns_id, group_id => $group, + entry => "[new $zone] Added SOA record [contact $tmp1[0]] [master $tmp1[1]] ". + "[refresh $tmp2[0]] [retry $tmp2[1]] [expire $tmp2[2]] [minttl $tmp2[3]], TTL $ttl"); + $defttl = $tmp2[3]; + } else { + my $logentry = "[new $zone] Added record '$host $typemap{$type} $val', TTL $ttl"; + $logentry .= ", default location ".$self->getLoc($defloc)->{description} if $defloc; + $self->_log(rdns_id => $rdns_id, domain_id => $domid, group_id => $group, entry => $logentry); + } + } + + # Generate record based on provided pattern. + if ($revpatt) { + my $host; + my $type = ($zone->{isv6} ? 65284 : 65283); + my $val = $zone->network; + + # Substitute $zone for ZONE in the hostname. + $host = _ZONE($zone, $revpatt); + + my $domid = 0; + if (!($domid = $self->_hostparent($host))) { + $warnstr .= "\nDefault pattern added as PTR template instead of $typemap{$type}; domain not found for $host"; + $type = 65282; + $domid = 0; # just to be explicit. + } + + $sth_in->execute($domid,$host,$type,$val,$defttl,$defloc); + my $logentry = "[new $zone] Added record '$host $typemap{$type}"; + $self->_log(rdns_id => $rdns_id, domain_id => $domid, group_id => $group, + entry => $logentry." $val', TTL $defttl from pattern"); + } + + # If there are warnings (presumably about default records skipped for cause) log them + $self->_log(rdns_id => $rdns_id, group_id => $group, entry => "Warning(s) adding $zone:$warnstr") + if $warnstr; + + # once we get here, we should have suceeded. + $dbh->commit; + }; # end eval + + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + $self->_log(group_id => $group, entry => "Failed adding reverse zone $zone ($msg)") + if $self->{log_failures}; + $dbh->commit; # since we enabled transactions earlier + return ('FAIL',$msg); + } else { + my $retcode = 'OK'; + if ($warnstr) { + $resultstr = $warnstr; + $retcode = 'WARN'; + } + return ($retcode, $rdns_id); + } + +} # end addRDNS() + + +## DNSDB::getZoneCount +# Get count of zones in group or groups +# Takes a database handle and hash containing: +# - the "current" group +# - an array of "acceptable" groups +# - a flag for forward/reverse zones +# - Optionally accept a "starts with" and/or "contains" filter argument +# Returns an integer count of the resulting zone list. +sub getZoneCount { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + # Fail on bad curgroup argument. There's no sane fallback on this one. + if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) { + $errstr = "Bad or missing curgroup argument"; + return; + } + # Fail on bad childlist argument. This could be sanely ignored if bad, maybe. + if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) { + $errstr = "Bad childlist argument"; + return; + } + + my @filterargs; + $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/; + push @filterargs, "^$args{startwith}" if $args{startwith}; + $args{filter} =~ s/\./\[\.\]/g if $args{filter}; # only match literal dots, usually in reverse zones + push @filterargs, $args{filter} if $args{filter}; + + my $sql; + # Not as compact, and fix-me-twice if the common bits get wrong, but much easier to read + if ($args{revrec} eq 'n') { + $sql = "SELECT count(*) FROM domains". + " WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")". + ($args{startwith} ? " AND domain ~* ?" : ''). + ($args{filter} ? " AND domain ~* ?" : ''); + } else { + $sql = "SELECT count(*) FROM revzones". + " WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")". + ($args{startwith} ? " AND CAST(revnet AS VARCHAR) ~* ?" : ''). + ($args{filter} ? " AND CAST(revnet AS VARCHAR) ~* ?" : ''); + } + my ($count) = $dbh->selectrow_array($sql, undef, @filterargs); + return $count; +} # end getZoneCount() + + +## DNSDB::getZoneList() +# Get a list of zones in the specified group(s) +# Takes the same arguments as getZoneCount() above +# Returns a reference to an array of hashrefs suitable for feeding to HTML::Template +sub getZoneList { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + my @zonelist; + + $args{sortorder} = 'ASC' if !$args{sortorder} || !grep /^$args{sortorder}$/, ('ASC','DESC'); + $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/; + + # Fail on bad curgroup argument. There's no sane fallback on this one. + if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) { + $errstr = "Bad or missing curgroup argument"; + return; + } + # Fail on bad childlist argument. This could be sanely ignored if bad, maybe. + if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) { + $errstr = "Bad childlist argument"; + return; + } + + my @filterargs; + $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/; + push @filterargs, "^$args{startwith}" if $args{startwith}; + $args{filter} =~ s/\./\[\.\]/g if $args{filter}; # only match literal dots, usually in reverse zones + push @filterargs, $args{filter} if $args{filter}; + + my $sql; + # Not as compact, and fix-me-twice if the common bits get wrong, but much easier to read + if ($args{revrec} eq 'n') { + $args{sortby} = 'domain' if !$args{sortby} || !grep /^$args{sortby}$/, ('domain','group','status'); + $sql = "SELECT domain_id,domain,status,groups.group_name AS group FROM domains". + " INNER JOIN groups ON domains.group_id=groups.group_id". + " WHERE domains.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")". + ($args{startwith} ? " AND domain ~* ?" : ''). + ($args{filter} ? " AND domain ~* ?" : ''); + } else { +##fixme: arguably startwith here is irrelevant. depends on the UI though. + $args{sortby} = 'revnet' if !$args{sortby} || !grep /^$args{sortby}$/, ('revnet','group','status'); + $sql = "SELECT rdns_id,revnet,status,groups.group_name AS group FROM revzones". + " INNER JOIN groups ON revzones.group_id=groups.group_id". + " WHERE revzones.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")". + ($args{startwith} ? " AND CAST(revnet AS VARCHAR) ~* ?" : ''). + ($args{filter} ? " AND CAST(revnet AS VARCHAR) ~* ?" : ''); + } + # A common tail. + $sql .= " ORDER BY ".($args{sortby} eq 'group' ? 'groups.group_name' : $args{sortby})." $args{sortorder} ". + ($args{offset} eq 'all' ? '' : " LIMIT $self->{perpage}". + " OFFSET ".$args{offset}*$self->{perpage}); + my $sth = $dbh->prepare($sql); + $sth->execute(@filterargs); + my $rownum = 0; + + while (my @data = $sth->fetchrow_array) { + my %row; + $row{domain_id} = $data[0]; + $row{domain} = $data[1]; + $row{status} = $data[2]; + $row{group} = $data[3]; + push @zonelist, \%row; + } + + return \@zonelist; +} # end getZoneList() + + +## DNSDB::getZoneLocation() +# Retrieve the default location for a zone. +# Takes a database handle, forward/reverse flag, and zone ID +sub getZoneLocation { + my $self = shift; + my $dbh = $self->{dbh}; + my $revrec = shift; + my $zoneid = shift; + + my ($loc) = $dbh->selectrow_array("SELECT default_location FROM ". + ($revrec eq 'n' ? 'domains WHERE domain_id = ?' : 'revzones WHERE rdns_id = ?'), + undef, ($zoneid)); + return $loc; +} # end getZoneLocation() + + +## DNSDB::addGroup() +# Add a group +# Takes a database handle, group name, parent group, hashref for permissions, +# and optional template-vs-cloneme flag for the default records +# Returns a status code and message +sub addGroup { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $groupname = shift; + my $pargroup = shift; + my $permissions = shift; + + # 0 indicates "custom", hardcoded. + # Any other value clones that group's default records, if it exists. + my $inherit = shift || 0; +##fixme: need a flag to indicate clone records or ? + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + my ($group_id) = $dbh->selectrow_array("SELECT group_id FROM groups WHERE group_name=?", undef, ($groupname)); + + return ('FAIL', "Group already exists") if $group_id; + + # Wrap all the SQL in a transaction + eval { + $dbh->do("INSERT INTO groups (parent_group_id,group_name) VALUES (?,?)", undef, ($pargroup, $groupname) ); + + my ($groupid) = $dbh->selectrow_array("SELECT currval('groups_group_id_seq')"); + + # We work through the whole set of permissions instead of specifying them so + # that when we add a new permission, we don't have to change the code anywhere + # that doesn't explicitly deal with that specific permission. + my @permvals; + foreach (@permtypes) { + if (!defined ($permissions->{$_})) { + push @permvals, 0; + } else { + push @permvals, $permissions->{$_}; + } + } + $dbh->do("INSERT INTO permissions (group_id,$permlist) values (?".',?'x($#permtypes+1).")", + undef, ($groupid, @permvals) ); + my ($permid) = $dbh->selectrow_array("SELECT currval('permissions_permission_id_seq')"); + $dbh->do("UPDATE groups SET permission_id=$permid WHERE group_id=$groupid"); + + # Default records + my $sthf = $dbh->prepare("INSERT INTO default_records (group_id,host,type,val,distance,weight,port,ttl) ". + "VALUES ($groupid,?,?,?,?,?,?,?)"); + my $sthr = $dbh->prepare("INSERT INTO default_rev_records (group_id,host,type,val,ttl) ". + "VALUES ($groupid,?,?,?,?)"); + if ($inherit) { + # Duplicate records from parent. Actually relying on inherited records feels + # very fragile, and it would be problematic to roll over at a later time. + my $sth2 = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?"); + $sth2->execute($pargroup); + while (my @clonedata = $sth2->fetchrow_array) { + $sthf->execute(@clonedata); + } + # And now the reverse records + $sth2 = $dbh->prepare("SELECT host,type,val,ttl FROM default_rev_records WHERE group_id=?"); + $sth2->execute($pargroup); + while (my @clonedata = $sth2->fetchrow_array) { + $sthr->execute(@clonedata); + } + } else { +##fixme: Hardcoding is Bad, mmmmkaaaay? + # reasonable basic defaults for SOA, MX, NS, and minimal hosting + # could load from a config file, but somewhere along the line we need hardcoded bits. + $sthf->execute('ns1.example.com:hostmaster.example.com', 6, '10800:3600:604800:10800', 0, 0, 0, 86400); + $sthf->execute('DOMAIN', 1, '192.168.4.2', 0, 0, 0, 7200); + $sthf->execute('DOMAIN', 15, 'mx.example.com', 10, 0, 0, 7200); + $sthf->execute('DOMAIN', 2, 'ns1.example.com', 0, 0, 0, 7200); + $sthf->execute('DOMAIN', 2, 'ns2.example.com', 0, 0, 0, 7200); + $sthf->execute('www.DOMAIN', 5, 'DOMAIN', 0, 0, 0, 7200); + # reasonable basic defaults for generic reverse zone. Same as initial SQL tabledef. + $sthr->execute('hostmaster.ADMINDOMAIN:ns1.ADMINDOMAIN', 6, '10800:3600:604800:10800', 86400); + $sthr->execute('unused-%r.ADMINDOMAIN', 65283, 'ZONE', 3600); + } + + $self->_log(group_id => $pargroup, entry => "Added group $groupname"); + + # once we get here, we should have suceeded. + $dbh->commit; + }; # end eval + + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + if ($self->{log_failures}) { + $self->_log(group_id => $pargroup, entry => "Failed to add group $groupname: $msg"); + $dbh->commit; + } + return ('FAIL',$msg); + } + + return ('OK','OK'); +} # end addGroup() + + +## DNSDB::delGroup() +# Delete a group. +# Takes a group ID +# Returns a status code and message +sub delGroup { + my $self = shift; + my $dbh = $self->{dbh}; + my $groupid = shift; + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + +##fixme: locate "knowable" error conditions and deal with them before the eval +# ... or inside, whatever. +# -> domains still exist in group +# -> ... + my $failmsg = ''; + my $resultmsg = ''; + + # collect some pieces for logging and error messages + my $groupname = $self->groupName($groupid); + my $parid = $self->parentID(id => $groupid, type => 'group'); + + # Wrap all the SQL in a transaction + eval { + # Check for Things in the group + $failmsg = "Can't remove group $groupname"; + my ($grpcnt) = $dbh->selectrow_array("SELECT count(*) FROM groups WHERE parent_group_id=?", undef, ($groupid)); + die "$grpcnt groups still in group\n" if $grpcnt; + my ($domcnt) = $dbh->selectrow_array("SELECT count(*) FROM domains WHERE group_id=?", undef, ($groupid)); + die "$domcnt domains still in group\n" if $domcnt; + my ($revcnt) = $dbh->selectrow_array("SELECT count(*) FROM revzones WHERE group_id=?", undef, ($groupid)); + die "$revcnt reverse zones still in group\n" if $revcnt; + my ($usercnt) = $dbh->selectrow_array("SELECT count(*) FROM users WHERE group_id=?", undef, ($groupid)); + die "$usercnt users still in group\n" if $usercnt; + + $failmsg = "Failed to delete default records for $groupname"; + $dbh->do("DELETE from default_records WHERE group_id=?", undef, ($groupid)); + $failmsg = "Failed to delete default reverse records for $groupname"; + $dbh->do("DELETE from default_rev_records WHERE group_id=?", undef, ($groupid)); + $failmsg = "Failed to remove group $groupname"; + $dbh->do("DELETE from groups WHERE group_id=?", undef, ($groupid)); + + $self->_log(group_id => $parid, entry => "Deleted group $groupname"); + $resultmsg = "Deleted group $groupname"; + + # once we get here, we should have suceeded. + $dbh->commit; + }; # end eval + + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + if ($self->{log_failures}) { + $self->_log(group_id => $parid, entry => "$failmsg: $msg"); + $dbh->commit; # since we enabled transactions earlier + } + return ('FAIL',"$failmsg: $msg"); + } + + return ('OK',$resultmsg); +} # end delGroup() + + +## DNSDB::getChildren() +# Get a list of all groups whose parent^n is group +# Takes a database handle, group ID, reference to an array to put the group IDs in, +# and an optional flag to return only immediate children or all children-of-children +# default to returning all children +# Calls itself +sub getChildren { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $rootgroup = shift; + my $groupdest = shift; + my $immed = shift || 'all'; + + # special break for default group; otherwise we get stuck. + if ($rootgroup == 1) { + # by definition, group 1 is the Root Of All Groups + my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE NOT (group_id=1)". + ($immed ne 'all' ? " AND parent_group_id=1" : '')." ORDER BY group_name"); + $sth->execute; + while (my @this = $sth->fetchrow_array) { + push @$groupdest, @this; + } + } else { + my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE parent_group_id=? ORDER BY group_name"); + $sth->execute($rootgroup); + return if $sth->rows == 0; + my @grouplist; + while (my ($group) = $sth->fetchrow_array) { + push @$groupdest, $group; + $self->getChildren($group, $groupdest) if $immed eq 'all'; + } + } +} # end getChildren() + + +## DNSDB::groupName() +# Return the group name based on a group ID +# Takes a database handle and the group ID +# Returns the group name or undef on failure +sub groupName { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $groupid = shift; + my $sth = $dbh->prepare("SELECT group_name FROM groups WHERE group_id=?"); + $sth->execute($groupid); + my ($groupname) = $sth->fetchrow_array(); + $errstr = $DBI::errstr if !$groupname; + return $groupname if $groupname; +} # end groupName + + +## DNSDB::getGroupCount() +# Get count of subgroups in group or groups +# Takes a database handle and hash containing: +# - the "current" group +# - an array of "acceptable" groups +# - Optionally accept a "starts with" and/or "contains" filter argument +# Returns an integer count of the resulting group list. +sub getGroupCount { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + # Fail on bad curgroup argument. There's no sane fallback on this one. + if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) { + $errstr = "Bad or missing curgroup argument"; + return; + } + # Fail on bad childlist argument. This could be sanely ignored if bad, maybe. + if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) { + $errstr = "Bad childlist argument"; + return; + } + + my @filterargs; + $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/; + push @filterargs, "^$args{startwith}" if $args{startwith}; + push @filterargs, $args{filter} if $args{filter}; + + my $sql = "SELECT count(*) FROM groups ". + "WHERE parent_group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")". + ($args{startwith} ? " AND group_name ~* ?" : ''). + ($args{filter} ? " AND group_name ~* ?" : ''); + my ($count) = $dbh->selectrow_array($sql, undef, (@filterargs) ); + $errstr = $dbh->errstr if !$count; + return $count; +} # end getGroupCount + + +## DNSDB::getGroupList() +# Get a list of sub^n-groups in the specified group(s) +# Takes the same arguments as getGroupCount() above +# Returns an arrayref containing hashrefs suitable for feeding straight to HTML::Template +sub getGroupList { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + # Fail on bad curgroup argument. There's no sane fallback on this one. + if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) { + $errstr = "Bad or missing curgroup argument"; + return; + } + # Fail on bad childlist argument. This could be sanely ignored if bad, maybe. + if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) { + $errstr = "Bad childlist argument"; + return; + } + + my @filterargs; + $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/; + push @filterargs, "^$args{startwith}" if $args{startwith}; + push @filterargs, $args{filter} if $args{filter}; + + # protection against bad or missing arguments + $args{sortorder} = 'ASC' if !$args{sortorder} || !grep /^$args{sortorder}$/, ('ASC','DESC'); + $args{sortby} = 'group' if !$args{sortby} || $args{sortby} !~ /^[\w_.]+$/; + $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/; + + # munge sortby for columns in database + $args{sortby} = 'g.group_name' if $args{sortby} eq 'group'; + $args{sortby} = 'g2.group_name' if $args{sortby} eq 'parent'; + + my $sql = q(SELECT g.group_id AS groupid, g.group_name AS groupname, g2.group_name AS pgroup + FROM groups g + INNER JOIN groups g2 ON g2.group_id=g.parent_group_id + ). + " WHERE g.parent_group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")". + ($args{startwith} ? " AND g.group_name ~* ?" : ''). + ($args{filter} ? " AND g.group_name ~* ?" : ''). + " GROUP BY g.group_id, g.group_name, g2.group_name ". + " ORDER BY $args{sortby} $args{sortorder} ". + ($args{offset} eq 'all' ? '' : " LIMIT $self->{perpage} OFFSET ".$args{offset}*$self->{perpage}); + my $glist = $dbh->selectall_arrayref($sql, { Slice => {} }, (@filterargs) ); + $errstr = $dbh->errstr if !$glist; + + # LEFT JOINs make the result set balloon beyond sanity just to include counts; + # this means there's lots of crunching needed to trim the result set back down. + # So instead we track the order of the groups, and push the counts into the + # arrayref result separately. +##fixme: put this whole sub in a transaction? might be +# needed for accurate results on very busy systems. +##fixme: large group lists need prepared statements? +#my $ucsth = $dbh->prepare("SELECT count(*) FROM users WHERE group_id=?"); +#my $dcsth = $dbh->prepare("SELECT count(*) FROM domains WHERE group_id=?"); +#my $rcsth = $dbh->prepare("SELECT count(*) FROM revzones WHERE group_id=?"); + foreach (@{$glist}) { + my ($ucnt) = $dbh->selectrow_array("SELECT count(*) FROM users WHERE group_id=?", undef, ($$_{groupid})); + $$_{nusers} = $ucnt; + my ($dcnt) = $dbh->selectrow_array("SELECT count(*) FROM domains WHERE group_id=?", undef, ($$_{groupid})); + $$_{ndomains} = $dcnt; + my ($rcnt) = $dbh->selectrow_array("SELECT count(*) FROM revzones WHERE group_id=?", undef, ($$_{groupid})); + $$_{nrevzones} = $rcnt; + } + + return $glist; +} # end getGroupList + + +## DNSDB::groupID() +# Return the group ID based on the group name +# Takes a database handle and the group name +# Returns the group ID or undef on failure +sub groupID { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $group = shift; + my ($grpid) = $dbh->selectrow_array("SELECT group_id FROM groups WHERE group_name=?", undef, ($group) ); + $errstr = $DBI::errstr if !$grpid; + return $grpid if $grpid; +} # end groupID() + + +## DNSDB::addUser() +# Add a user. +# Takes a DB handle, username, group ID, password, state (active/inactive). +# Optionally accepts: +# user type (user/admin) - defaults to user +# permissions string - defaults to inherit from group +# three valid forms: +# i - Inherit permissions +# c: - Clone permissions from +# C: - Set these specific permissions +# first name - defaults to username +# last name - defaults to blank +# phone - defaults to blank (could put other data within column def) +# Returns (OK,) on success, (FAIL,) on failure +sub addUser { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $username = shift; + my $group = shift; + my $pass = shift; + my $state = shift; + + return ('FAIL', "Missing one or more required entries") if !defined($state); + return ('FAIL', "Username must not be blank") if !$username; + + # Munge in some alternate state values + $state = 1 if $state =~ /^active$/; + $state = 1 if $state =~ /^on$/; + $state = 0 if $state =~ /^inactive$/; + $state = 0 if $state =~ /^off$/; + + my $type = shift || 'u'; # create limited users by default - fwiw, not sure yet how this will interact with ACLs + + my $permstring = shift || 'i'; # default is to inhert permissions from group + + my $fname = shift || $username; + my $lname = shift || ''; + my $phone = shift || ''; # not going format-check + + my $sth = $dbh->prepare("SELECT user_id FROM users WHERE username=?"); + my $user_id; + +# quick check to start to see if we've already got one + $sth->execute($username); + ($user_id) = $sth->fetchrow_array; + + return ('FAIL', "User already exists") if $user_id; + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + # Wrap all the SQL in a transaction + eval { + # insert the user... note we set inherited perms by default since + # it's simple and cleans up some other bits of state + my $sth = $dbh->prepare("INSERT INTO users ". + "(group_id,username,password,firstname,lastname,phone,type,status,permission_id,inherit_perm) ". + "VALUES (?,?,?,?,?,?,?,?,(SELECT permission_id FROM permissions WHERE group_id=?),'t')"); + $sth->execute($group,$username,unix_md5_crypt($pass),$fname,$lname,$phone,$type,$state,$group); + + # get the ID... + ($user_id) = $dbh->selectrow_array("SELECT currval('users_user_id_seq')"); + +# Permissions! Gotta set'em all! + die "Invalid permission string $permstring\n" + if $permstring !~ /^(?: + i # inherit + |c:\d+ # clone + # custom. no, the leading , is not a typo + |C:(?:,(?:group|user|domain|record|location|self)_(?:edit|create|delete|locchg|view))* + )$/x; +# bleh. I'd call another function to do my dirty work, but we're in the middle of a transaction already. + if ($permstring ne 'i') { + # for cloned or custom permissions, we have to create a new permissions entry. + my $clonesrc = $group; + if ($permstring =~ /^c:(\d+)/) { $clonesrc = $1; } + $dbh->do("INSERT INTO permissions ($permlist,user_id) ". + "SELECT $permlist,? FROM permissions WHERE permission_id=". + "(SELECT permission_id FROM permissions WHERE ".($permstring =~ /^c:/ ? 'user' : 'group')."_id=?)", + undef, ($user_id,$clonesrc) ); + $dbh->do("UPDATE users SET permission_id=". + "(SELECT permission_id FROM permissions WHERE user_id=?) ". + "WHERE user_id=?", undef, ($user_id, $user_id) ); + } + if ($permstring =~ /^C:/) { + # finally for custom permissions, we set the passed-in permissions (and unset + # any that might have been brought in by the clone operation above) + my ($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions WHERE user_id=?", + undef, ($user_id) ); + foreach (@permtypes) { + if ($permstring =~ /,$_/) { + $dbh->do("UPDATE permissions SET $_='t' WHERE permission_id=?", undef, ($permid) ); + } else { + $dbh->do("UPDATE permissions SET $_='f' WHERE permission_id=?", undef, ($permid) ); + } + } + } + + $dbh->do("UPDATE users SET inherit_perm='n' WHERE user_id=?", undef, ($user_id) ); + +##fixme: add another table to hold name/email for log table? + + $self->_log(group_id => $group, entry => "Added user $username ($fname $lname)"); + # once we get here, we should have suceeded. + $dbh->commit; + }; # end eval + + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + if ($self->{log_failures}) { + $self->_log(group_id => $group, entry => "Error adding user $username: $msg"); + $dbh->commit; # since we enabled transactions earlier + } + return ('FAIL',"Error adding user $username: $msg"); + } + + return ('OK',"User $username ($fname $lname) added"); +} # end addUser + + +## DNSDB::getUserCount() +# Get count of users in group +# Takes a database handle and hash containing at least the current group, and optionally: +# - a reference list of secondary groups +# - a filter string +# - a "Starts with" string +sub getUserCount { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + # Fail on bad curgroup argument. There's no sane fallback on this one. + if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) { + $errstr = "Bad or missing curgroup argument"; + return; + } + # Fail on bad childlist argument. This could be sanely ignored if bad, maybe. + if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) { + $errstr = "Bad childlist argument"; + return; + } + + my @filterargs; + $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/; + push @filterargs, "^$args{startwith}" if $args{startwith}; + push @filterargs, $args{filter} if $args{filter}; + + my $sql = "SELECT count(*) FROM users ". + "WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")". + ($args{startwith} ? " AND username ~* ?" : ''). + ($args{filter} ? " AND username ~* ?" : ''); + my ($count) = $dbh->selectrow_array($sql, undef, (@filterargs) ); + $errstr = $dbh->errstr if !$count; + return $count; +} # end getUserCount() + + +## DNSDB::getUserList() +# Get list of users +# Takes the same arguments as getUserCount() above, plus optional: +# - sort field +# - sort order +# - offset/return-all-everything flag (defaults to $perpage records) +sub getUserList { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + # Fail on bad curgroup argument. There's no sane fallback on this one. + if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) { + $errstr = "Bad or missing curgroup argument"; + return; + } + # Fail on bad childlist argument. This could be sanely ignored if bad, maybe. + if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) { + $errstr = "Bad childlist argument"; + return; + } + + my @filterargs; + $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/; + push @filterargs, "^$args{startwith}" if $args{startwith}; + push @filterargs, $args{filter} if $args{filter}; + + # better to request sorts on "simple" names, but it means we need to map it to real columns + my %sortmap = (user => 'u.username', type => 'u.type', group => 'g.group_name', status => 'u.status', + fname => 'fname'); + $args{sortby} = $sortmap{$args{sortby}}; + + # protection against bad or missing arguments + $args{sortorder} = 'ASC' if !$args{sortorder} || !grep /^$args{sortorder}$/, ('ASC','DESC'); + $args{sortby} = 'u.username' if !$args{sortby} || $args{sortby} !~ /^[\w_.]+$/; + $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/; + + my $sql = "SELECT u.user_id, u.username, u.firstname || ' ' || u.lastname AS fname, u.type, g.group_name, u.status ". + "FROM users u ". + "INNER JOIN groups g ON u.group_id=g.group_id ". + "WHERE u.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")". + ($args{startwith} ? " AND u.username ~* ?" : ''). + ($args{filter} ? " AND u.username ~* ?" : ''). + " AND NOT u.type = 'R' ". + " ORDER BY $args{sortby} $args{sortorder} ". + ($args{offset} eq 'all' ? '' : " LIMIT $self->{perpage} OFFSET ".$args{offset}*$self->{perpage}); + my $ulist = $dbh->selectall_arrayref($sql, { Slice => {} }, (@filterargs) ); + $errstr = $dbh->errstr if !$ulist; + return $ulist; +} # end getUserList() + + +## DNSDB::getUserDropdown() +# Get a list of usernames for use in a dropdown menu. +# Takes a database handle, current group, and optional "tag this as selected" flag. +# Returns a reference to a list of hashrefs suitable to feeding to HTML::Template +sub getUserDropdown { + my $self = shift; + my $dbh = $self->{dbh}; + my $grp = shift; + my $sel = shift || 0; + + my $sth = $dbh->prepare("SELECT username,user_id FROM users WHERE group_id=?"); + $sth->execute($grp); + + my @userlist; + while (my ($username,$uid) = $sth->fetchrow_array) { + my %row = ( + username => $username, + uid => $uid, + selected => ($sel == $uid ? 1 : 0) + ); + push @userlist, \%row; + } + return \@userlist; +} # end getUserDropdown() + + +## DNSDB:: updateUser() +# Update general data about user +sub updateUser { + my $self = shift; + my $dbh = $self->{dbh}; + +##fixme: tweak calling convention so that we can update any given bit of data + my $uid = shift; + my $username = shift; + my $group = shift; + my $pass = shift; + my $state = shift; + my $type = shift || 'u'; + my $fname = shift || $username; + my $lname = shift || ''; + my $phone = shift || ''; # not going format-check + + my $resultmsg = ''; + + # Munge in some alternate state values + $state = 1 if $state =~ /^active$/; + $state = 1 if $state =~ /^on$/; + $state = 0 if $state =~ /^inactive$/; + $state = 0 if $state =~ /^off$/; + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + my $sth; + + # Password can be left blank; if so we assume there's one on file. + # Actual blank passwords are bad, mm'kay? + if (!$pass) { + ($pass) = $dbh->selectrow_array("SELECT password FROM users WHERE user_id=?", undef, ($uid)); + } else { + $pass = unix_md5_crypt($pass); + } + + eval { + $dbh->do("UPDATE users SET username=?, password=?, firstname=?, lastname=?, phone=?, type=?, status=?". + " WHERE user_id=?", undef, ($username, $pass, $fname, $lname, $phone, $type, $state, $uid)); + $resultmsg = "Updated user info for $username ($fname $lname)"; + $self->_log(group_id => $group, entry => $resultmsg); + $dbh->commit; + }; + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + if ($self->{log_failures}) { + $self->_log(group_id => $group, entry => "Error updating user $username: $msg"); + $dbh->commit; # since we enabled transactions earlier + } + return ('FAIL',"Error updating user $username: $msg"); + } + + return ('OK',$resultmsg); +} # end updateUser() + + +## DNSDB::delUser() +# Delete a user. +# Takes a database handle and user ID +# Returns a success/failure code and matching message +sub delUser { + my $self = shift; + my $dbh = $self->{dbh}; + my $userid = shift; + + return ('FAIL',"Bad userid") if !defined($userid); + + my $userdata = $self->getUserData($userid); + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + eval { + $dbh->do("DELETE FROM users WHERE user_id=?", undef, ($userid)); + $self->_log(group_id => $userdata->{group_id}, + entry => "Deleted user ID $userid/".$userdata->{username}. + " (".$userdata->{firstname}." ".$userdata->{lastname}.")"); + $dbh->commit; + }; + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + if ($self->{log_failures}) { + $self->_log(group_id => $userdata->{group_id}, entry => "Error deleting user ID ". + "$userid/".$userdata->{username}.": $msg"); + $dbh->commit; + } + return ('FAIL',"Error deleting user $userid/".$userdata->{username}.": $msg"); + } + + return ('OK',"Deleted user ".$userdata->{username}." (".$userdata->{firstname}." ".$userdata->{lastname}.")"); +} # end delUser + + +## DNSDB::userFullName() +# Return a pretty string! +# Takes a user_id and optional printf-ish string to indicate which pieces where: +# %u for the username +# %f for the first name +# %l for the last name +# All other text in the passed string will be left as-is. +##fixme: need a "smart" option too, so that missing/null/blank first/last names don't give funky output +sub userFullName { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $userid = shift; + my $fullformat = shift || '%f %l (%u)'; + my $sth = $dbh->prepare("select username,firstname,lastname from users where user_id=?"); + $sth->execute($userid); + my ($uname,$fname,$lname) = $sth->fetchrow_array(); + $errstr = $DBI::errstr if !$uname; + + $fullformat =~ s/\%u/$uname/g; + $fullformat =~ s/\%f/$fname/g; + $fullformat =~ s/\%l/$lname/g; + + return $fullformat; +} # end userFullName + + +## DNSDB::userStatus() +# Sets and/or returns a user's status +# Takes a database handle, user ID and optionally a status argument +# Returns undef on errors. +sub userStatus { + my $self = shift; + my $dbh = $self->{dbh}; + my $id = shift; + my $newstatus = shift || 'mu'; + + return undef if $id !~ /^\d+$/; + + my $userdata = $self->getUserData($id); + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + if ($newstatus ne 'mu') { + # ooo, fun! let's see what we were passed for status + eval { + $newstatus = 0 if $newstatus eq 'useroff'; + $newstatus = 1 if $newstatus eq 'useron'; + $dbh->do("UPDATE users SET status=? WHERE user_id=?", undef, ($newstatus, $id)); + + $resultstr = ($newstatus ? 'Enabled' : 'Disabled')." user ".$userdata->{username}. + " (".$userdata->{firstname}." ".$userdata->{lastname}.")"; + + my %loghash; + $loghash{group_id} = $self->parentID(id => $id, type => 'user'); + $loghash{entry} = $resultstr; + $self->_log(%loghash); + + $dbh->commit; + }; + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + $resultstr = ''; + $errstr = $msg; +##fixme: failure logging? + return; + } + } + + my ($status) = $dbh->selectrow_array("SELECT status FROM users WHERE user_id=?", undef, ($id)); + return $status; +} # end userStatus() + + +## DNSDB::getUserData() +# Get misc user data for display +sub getUserData { + my $self = shift; + my $dbh = $self->{dbh}; + my $uid = shift; + + my $sth = $dbh->prepare("SELECT group_id,username,firstname,lastname,phone,type,status,inherit_perm ". + "FROM users WHERE user_id=?"); + $sth->execute($uid); + return $sth->fetchrow_hashref(); +} # end getUserData() + + +## DNSDB::addLoc() +# Add a new location. +# Takes a database handle, group ID, short and long description, and a comma-separated +# list of IP addresses. +# Returns ('OK',) on success, ('FAIL',) on failure +sub addLoc { + my $self = shift; + my $dbh = $self->{dbh}; + my $grp = shift; + my $shdesc = shift; + my $comments = shift; + my $iplist = shift; + + # $shdesc gets set to the generated location ID if possible, but these can be de-undefined here. + $comments = '' if !$comments; + $iplist = '' if !$iplist; + + my $loc; + + # Generate a location ID. This is, by spec, a two-character widget. We'll use [a-z][a-z] + # for now; 676 locations should satisfy all but the largest of the huge networks. + # Not sure whether these are case-sensitive, or what other rules might apply - in any case + # the absolute maximum is 16K (256*256) since it's parsed by tinydns as a two-character field. + +# add just after "my $origloc = $loc;": +# # These expand the possible space from 26^2 to 52^2 [* note in testing only 2052 were achieved], +# # and wrap it around. +# # Yes, they skip a couple of possibles. No, I don't care. +# $loc = 'aA' if $loc eq 'zz'; +# $loc = 'Aa' if $loc eq 'zZ'; +# $loc = 'ZA' if $loc eq 'Zz'; +# $loc = 'aa' if $loc eq 'ZZ'; + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + +##fixme: There is probably a far better way to do this. Sequential increments +# are marginally less stupid that pure random generation though, and the existence +# check makes sure we don't stomp on an imported one. + + eval { + # Get the "last" location. Note this is the only use for loc_id, because selecting on location Does Funky Things + ($loc) = $dbh->selectrow_array("SELECT location FROM locations ORDER BY loc_id DESC LIMIT 1"); + ($loc) = ($loc =~ /^(..)/) if $loc; + my $origloc = $loc; + $loc = 'aa' if !$loc; + # Make a change... + $loc++; + # ... and keep changing if it exists + while ($dbh->selectrow_array("SELECT count(*) FROM locations WHERE location LIKE ?", undef, ($loc.'%'))) { + $loc++; + ($loc) = ($loc =~ /^(..)/); + die "too many locations in use, can't add another one\n" if $loc eq $origloc; +##fixme: really need to handle this case faster somehow +#if $loc eq $origloc die " bad admin: all locations used, your network is too fragmented"; + } + # And now we should have a unique location. tinydns fundamentally limits the + # number of these but there's no doc on what characters are valid. + $shdesc = $loc if !$shdesc; + $dbh->do("INSERT INTO locations (location, group_id, iplist, description, comments) VALUES (?,?,?,?,?)", + undef, ($loc, $grp, $iplist, $shdesc, $comments) ); + $self->_log(entry => "Added location ($shdesc, '$iplist')"); + $dbh->commit; + }; + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + if ($self->{log_failures}) { + $shdesc = $loc if !$shdesc; + $self->_log(entry => "Failed adding location ($shdesc, '$iplist'): $msg"); + $dbh->commit; + } + return ('FAIL',$msg); + } + + return ('OK',$loc); +} # end addLoc() + + +## DNSDB::updateLoc() +# Update details of a location. +# Takes a database handle, location ID, group ID, short description, +# long comments/notes, and comma/space-separated IP list +# Returns a result code and message +sub updateLoc { + my $self = shift; + my $dbh = $self->{dbh}; + my $loc = shift; + my $grp = shift; + my $shdesc = shift; + my $comments = shift; + my $iplist = shift; + + $shdesc = '' if !$shdesc; + $comments = '' if !$comments; + $iplist = '' if !$iplist; + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + my $oldloc = $self->getLoc($loc); + my $okmsg = "Updated location (".$oldloc->{description}.", '".$oldloc->{iplist}."') to ($shdesc, '$iplist')"; + + eval { + $dbh->do("UPDATE locations SET group_id=?,iplist=?,description=?,comments=? WHERE location=?", + undef, ($grp, $iplist, $shdesc, $comments, $loc) ); + $self->_log(entry => $okmsg); + $dbh->commit; + }; + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + if ($self->{log_failures}) { + $shdesc = $loc if !$shdesc; + $self->_log(entry => "Failed updating location ($shdesc, '$iplist'): $msg"); + $dbh->commit; + } + return ('FAIL',$msg); + } + + return ('OK',$okmsg); +} # end updateLoc() + + +## DNSDB::delLoc() +sub delLoc { + my $self = shift; + my $dbh = $self->{dbh}; + my $loc = shift; + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + my $oldloc = $self->getLoc($loc); + my $olddesc = ($oldloc->{description} ? $oldloc->{description} : $loc); + my $okmsg = "Deleted location ($olddesc, '".$oldloc->{iplist}."')"; + + eval { + # Check for records with this location first. Deleting a location without deleting records + # tagged for that location will render them unpublished without other warning. + my ($r) = $dbh->selectrow_array("SELECT record_id FROM records WHERE location=? LIMIT 1", undef, ($loc) ); + die "Records still exist in location $olddesc\n" if $r; + $dbh->do("DELETE FROM locations WHERE location=?", undef, ($loc) ); + $self->_log(entry => $okmsg); + $dbh->commit; + }; + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + if ($self->{log_failures}) { + $self->_log(entry => "Failed to delete location ($olddesc, '$oldloc->{iplist}'): $msg"); + $dbh->commit; + } + return ('FAIL', "Failed to delete location ($olddesc, '$oldloc->{iplist}'): $msg"); + } + + return ('OK',$okmsg); +} # end delLoc() + + +## DNSDB::getLoc() +# Get details about a location/view +# Takes a database handle and location ID. +# Returns a reference to a hash containing the group ID, IP list, description, and comments/notes +sub getLoc { + my $self = shift; + my $dbh = $self->{dbh}; + my $loc = shift; + + my $sth = $dbh->prepare("SELECT group_id,iplist,description,comments FROM locations WHERE location=?"); + $sth->execute($loc); + return $sth->fetchrow_hashref(); +} # end getLoc() + + +## DNSDB::getLocCount() +# Get count of locations/views +# Takes a database handle and hash containing at least the current group, and optionally: +# - a reference list of secondary groups +# - a filter string +# - a "Starts with" string +sub getLocCount { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + # Fail on bad curgroup argument. There's no sane fallback on this one. + if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) { + $errstr = "Bad or missing curgroup argument"; + return; + } + # Fail on bad childlist argument. This could be sanely ignored if bad, maybe. + if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) { + $errstr = "Bad childlist argument"; + return; + } + + my @filterargs; + $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/; + push @filterargs, "^$args{startwith}" if $args{startwith}; + push @filterargs, $args{filter} if $args{filter}; + + my $sql = "SELECT count(*) FROM locations ". + "WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")". + ($args{startwith} ? " AND description ~* ?" : ''). + ($args{filter} ? " AND description ~* ?" : ''); + my ($count) = $dbh->selectrow_array($sql, undef, (@filterargs) ); + $errstr = $dbh->errstr if !$count; + return $count; +} # end getLocCount() + + +## DNSDB::getLocList() +sub getLocList { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + # Fail on bad curgroup argument. There's no sane fallback on this one. + if (!$args{curgroup} || $args{curgroup} !~ /^\d+$/) { + $errstr = "Bad or missing curgroup argument"; + return; + } + # Fail on bad childlist argument. This could be sanely ignored if bad, maybe. + if ($args{childlist} && $args{childlist} !~ /^[\d,]+$/) { + $errstr = "Bad childlist argument"; + return; + } + + my @filterargs; + $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/; + push @filterargs, "^$args{startwith}" if $args{startwith}; + push @filterargs, $args{filter} if $args{filter}; + + # better to request sorts on "simple" names, but it means we need to map it to real columns +# my %sortmap = (user => 'u.username', type => 'u.type', group => 'g.group_name', status => 'u.status', +# fname => 'fname'); +# $args{sortby} = $sortmap{$args{sortby}}; + + # protection against bad or missing arguments + $args{sortorder} = 'ASC' if !$args{sortorder} || !grep /^$args{sortorder}$/, ('ASC','DESC'); + $args{sortby} = 'l.description' if !$args{sortby} || $args{sortby} !~ /^[\w_.]+$/; + $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/; + + my $sql = "SELECT l.location, l.description, l.iplist, g.group_name ". + "FROM locations l ". + "INNER JOIN groups g ON l.group_id=g.group_id ". + "WHERE l.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")". + ($args{startwith} ? " AND l.description ~* ?" : ''). + ($args{filter} ? " AND l.description ~* ?" : ''). + " ORDER BY $args{sortby} $args{sortorder} ". + ($args{offset} eq 'all' ? '' : " LIMIT $self->{perpage} OFFSET ".$args{offset}*$self->{perpage}); + my $ulist = $dbh->selectall_arrayref($sql, { Slice => {} }, (@filterargs) ); + $errstr = $dbh->errstr if !$ulist; + return $ulist; +} # end getLocList() + + +## DNSDB::getLocDropdown() +# Get a list of location names for use in a dropdown menu. +# Takes a database handle, current group, and optional "tag this as selected" flag. +# Returns a reference to a list of hashrefs suitable to feeding to HTML::Template +sub getLocDropdown { + my $self = shift; + my $dbh = $self->{dbh}; + my $grp = shift; + my $sel = shift || ''; + + my $sth = $dbh->prepare(qq( + SELECT description,location FROM locations + WHERE group_id=? + ORDER BY description + ) ); + $sth->execute($grp); + + my @loclist; + push @loclist, { locname => "(Default/All)", loc => '', selected => ($sel ? 0 : ($sel eq '' ? 1 : 0)) }; + while (my ($locname, $loc) = $sth->fetchrow_array) { + my %row = ( + locname => $locname, + loc => $loc, + selected => ($sel eq $loc ? 1 : 0) + ); + push @loclist, \%row; + } + return \@loclist; +} # end getLocDropdown() + + +## DNSDB::getSOA() +# Return all suitable fields from an SOA record in separate elements of a hash +# Takes a database handle, default/live flag, domain/reverse flag, and parent ID +sub getSOA { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $def = shift; + my $rev = shift; + my $id = shift; + + # (ab)use distance and weight columns to store SOA data? can't for default_rev_records... + # - should really attach serial to the zone parent somewhere + + my $sql = "SELECT record_id,host,val,ttl from "._rectable($def,$rev). + " WHERE "._recparent($def,$rev)." = ? AND type=$reverse_typemap{SOA}"; + my $ret = $dbh->selectrow_hashref($sql, undef, ($id) ); + return if !$ret; +##fixme: stick a flag somewhere if the record doesn't exist. by the API, this is an impossible case, but... + + ($ret->{contact},$ret->{prins}) = split /:/, $ret->{host}; + delete $ret->{host}; + ($ret->{refresh},$ret->{retry},$ret->{expire},$ret->{minttl}) = split /:/, $ret->{val}; + delete $ret->{val}; + + return $ret; +} # end getSOA() + + +## DNSDB::updateSOA() +# Update the specified SOA record +# Takes a database handle, default/live flag, forward/reverse flag, and SOA data hash +# Returns a two-element list with a result code and message +sub updateSOA { + my $self = shift; + my $dbh = $self->{dbh}; + my $defrec = shift; + my $revrec = shift; + + my %soa = @_; + + my $oldsoa = $self->getSOA($defrec, $revrec, $soa{id}); + + my $msg; + my %logdata; + if ($defrec eq 'n') { + $logdata{domain_id} = $soa{id} if $revrec eq 'n'; + $logdata{rdns_id} = $soa{id} if $revrec eq 'y'; + $logdata{group_id} = $self->parentID(id => $soa{id}, revrec => $revrec, + type => ($revrec eq 'n' ? 'domain' : 'revzone') ); + } else { + $logdata{group_id} = $soa{id}; + } + my $parname = ($defrec eq 'y' ? $self->groupName($soa{id}) : + ($revrec eq 'n' ? $self->domainName($soa{id}) : $self->revName($soa{id})) ); + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + eval { + my $sql = "UPDATE "._rectable($defrec, $revrec)." SET host=?, val=?, ttl=? WHERE record_id=? AND type=6"; + $dbh->do($sql, undef, ("$soa{contact}:$soa{prins}", "$soa{refresh}:$soa{retry}:$soa{expire}:$soa{minttl}", + $soa{ttl}, $oldsoa->{record_id}) ); + $msg = "Updated ".($defrec eq 'y' ? ($revrec eq 'y' ? 'default reverse ' : 'default ') : ''). + "SOA for $parname: ". + "(ns $oldsoa->{prins}, contact $oldsoa->{contact}, refresh $oldsoa->{refresh},". + " retry $oldsoa->{retry}, expire $oldsoa->{expire}, minTTL $oldsoa->{minttl}, TTL $oldsoa->{ttl}) to ". + "(ns $soa{prins}, contact $soa{contact}, refresh $soa{refresh},". + " retry $soa{retry}, expire $soa{expire}, minTTL $soa{minttl}, TTL $soa{ttl})"; + + $logdata{entry} = $msg; + $self->_log(%logdata); + + $dbh->commit; + }; + if ($@) { + $msg = $@; + eval { $dbh->rollback; }; + $logdata{entry} = "Error updating ".($defrec eq 'y' ? ($revrec eq 'y' ? 'default reverse zone ' : 'default ') : ''). + "SOA record for $parname: $msg"; + if ($self->{log_failures}) { + $self->_log(%logdata); + $dbh->commit; + } + return ('FAIL', $logdata{entry}); + } else { + return ('OK', $msg); + } +} # end updateSOA() + + +## DNSDB::getRecLine() +# Return all data fields for a zone record in separate elements of a hash +# Takes a database handle, default/live flag, forward/reverse flag, and record ID +sub getRecLine { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $defrec = shift; + my $revrec = shift; + my $id = shift; + +##fixme: do we need a knob to twist to switch between unix epoch and postgres time string? + my $sql = "SELECT record_id,host,type,val,ttl". + ($defrec eq 'n' ? ',location' : ''). + ($revrec eq 'n' ? ',distance,weight,port' : ''). + (($defrec eq 'y') ? ',group_id FROM ' : ',domain_id,rdns_id,stamp,stamp < now() AS ispast,expires,stampactive FROM '). + _rectable($defrec,$revrec)." WHERE record_id=?"; + my $ret = $dbh->selectrow_hashref($sql, undef, ($id) ); + + if ($dbh->err) { + $errstr = $DBI::errstr; + return undef; + } + + if (!$ret) { + $errstr = "No such record"; + return undef; + } + + # explicitly set a parent id + if ($defrec eq 'y') { + $ret->{parid} = $ret->{group_id}; + } else { + $ret->{parid} = (($revrec eq 'n') ? $ret->{domain_id} : $ret->{rdns_id}); + # and a secondary if we have a custom type that lives in both a forward and reverse zone + $ret->{secid} = (($revrec eq 'y') ? $ret->{domain_id} : $ret->{rdns_id}) if $ret->{type} > 65279; + } + $ret->{address} = $ret->{val}; # because. + + return $ret; +} + + +##fixme: should use above (getRecLine()) to get lines for below? +## DNSDB::getRecList() +# Return records for a group or zone +# Takes a default/live flag, group or zone ID, start, +# number of records, sort field, and sort order +# Returns a reference to an array of hashes +sub getRecList { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + my @filterargs; + + push @filterargs, $args{filter} if $args{filter}; + + # protection against bad or missing arguments + $args{sortorder} = 'ASC' if !$args{sortorder} || !grep /^$args{sortorder}$/, ('ASC','DESC'); + my $defsort; + $defsort = 'host' if $args{revrec} eq 'n'; # default sort by host on domain record list + $defsort = 'val' if $args{revrec} eq 'y'; # default sort by IP on revzone record list + $args{sortby} = '' if !$args{sortby}; + $args{sortby} = $defsort if !$args{revrec}; + $args{sortby} = $defsort if $args{sortby} !~ /^[\w_,.]+$/; + $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/; + my $perpage = ($args{nrecs} ? $args{nrecs} : $self->{perpage}); + + # sort reverse zones on IP, correctly + # do other fiddling with $args{sortby} while we're at it. + # whee! multisort means just passing comma-separated fields in sortby! + my $newsort = ''; + foreach my $sf (split /,/, $args{sortby}) { + $sf = "r.$sf"; + $sf =~ s/r\.val/CAST (r.val AS inet)/ + if $args{revrec} eq 'y' && $args{defrec} eq 'n'; + $sf =~ s/r\.type/t.alphaorder/; + $newsort .= ",$sf"; + } + $newsort =~ s/^,//; + +##fixme: do we need a knob to twist to switch from unix epoch to postgres time string? + my $sql = "SELECT r.record_id,r.host,r.type,r.val,r.ttl"; + $sql .= ",l.description AS locname,stamp,r.stamp < now() AS ispast,r.expires,r.stampactive" + if $args{defrec} eq 'n'; + $sql .= ",r.distance,r.weight,r.port" if $args{revrec} eq 'n'; + $sql .= " FROM "._rectable($args{defrec},$args{revrec})." r "; + $sql .= "INNER JOIN rectypes t ON r.type=t.val "; # for sorting by type alphabetically + $sql .= "LEFT JOIN locations l ON r.location=l.location " if $args{defrec} eq 'n'; + $sql .= "WHERE "._recparent($args{defrec},$args{revrec})." = ?"; + $sql .= " AND NOT r.type=$reverse_typemap{SOA}"; + $sql .= " AND (r.host ~* ? OR r.val ~* ?)" if $args{filter}; + $sql .= " ORDER BY $newsort $args{sortorder}"; + # ensure consistent ordering by sorting on record_id too + $sql .= ", record_id $args{sortorder}"; + $sql .= ($args{offset} eq 'all' ? '' : " LIMIT $perpage OFFSET ".$args{offset}*$perpage); + + my @bindvars = ($args{id}); + push @bindvars, ($args{filter},$args{filter}) if $args{filter}; + + my $ret = $dbh->selectall_arrayref($sql, { Slice => {} }, (@bindvars) ); + $errstr = "Error retrieving records: ".$dbh->errstr if !$ret; + + return $ret; +} # end getRecList() + + +## DNSDB::getRecCount() +# Return count of non-SOA records in zone (or default records in a group) +# Takes a database handle, default/live flag, reverse/forward flag, group/domain ID, +# and optional filtering modifier +# Returns the count +sub getRecCount { + my $self = shift; + my $dbh = $self->{dbh}; + my $defrec = shift; + my $revrec = shift; + my $id = shift; + my $filter = shift || ''; + + # keep the nasties down, since we can't ?-sub this bit. :/ + # note this is chars allowed in DNS hostnames + $filter =~ s/[^a-zA-Z0-9_.:-]//g; + + my @bindvars = ($id); + push @bindvars, $filter if $filter; + my $sql = "SELECT count(*) FROM ". + _rectable($defrec,$revrec). + " WHERE "._recparent($defrec,$revrec)."=? ". + "AND NOT type=$reverse_typemap{SOA}". + ($filter ? " AND host ~* ?" : ''); + my ($count) = $dbh->selectrow_array($sql, undef, (@bindvars) ); + + return $count; + +} # end getRecCount() + + +## DNSDB::addRec() +# Add a new record to a domain or a group's default records +# Takes a database handle, default/live flag, group/domain ID, +# host, type, value, and TTL +# Some types require additional detail: "distance" for MX and SRV, +# and weight/port for SRV +# Returns a status code and detail message in case of error +##fixme: pass a hash with the record data, not a series of separate values +sub addRec { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $defrec = shift; + my $revrec = shift; + my $id = shift; # parent (group_id for defrecs, rdns_id for reverse records, + # domain_id for domain records) + + my $host = shift; + my $rectype = shift; # reference so we can coerce it if "+"-types can't find both zones + my $val = shift; + my $ttl = shift; + my $location = shift; + $location = '' if !$location; + + my $expires = shift; + $expires = 1 if $expires eq 'until'; # Turn some special values into the appropriate booleans. + $expires = 0 if $expires eq 'after'; + my $stamp = shift; + $stamp = '' if !$stamp; # Timestamp should be a string at this point. + + # Spaces are evil. + $$host =~ s/^\s+//; + $$host =~ s/\s+$//; + if ($typemap{$$rectype} ne 'TXT') { + # Leading or trailng spaces could be legit in TXT records. + $$val =~ s/^\s+//; + $$val =~ s/\s+$//; + } + + if ($self->{lowercase}) { + if ($typemap{$$rectype} ne 'TXT') { + $$host = lc($$host); + $$val = lc($$val); + } else { + # TXT records should preserve user entry in the string. + if ($revrec eq 'n') { + $$host = lc($$host); + } else { + $$val = lc($$val); + } + } + } + + # prep for validation + my $addr = NetAddr::IP->new($$val); + $$host =~ s/\.+$//; # FQDNs ending in . are an internal detail, and really shouldn't be exposed in the UI. + + my $domid = 0; + my $revid = 0; + + my $retcode = 'OK'; # assume everything will go OK + my $retmsg = ''; + + # do simple validation first + return ('FAIL', "TTL must be numeric") unless $ttl =~ /^\d+$/; + + # Quick check on hostname parts. There are enough variations to justify a sub now. + return ('FAIL', $errstr) if ! _check_hostname_form($$host, $$rectype, $defrec, $revrec); + + # Collect these even if we're only doing a simple A record so we can call *any* validation sub + my $dist = shift; + my $weight = shift; + my $port = shift; + + my $fields; + my @vallist; + + # Call the validation sub for the type requested. + ($retcode,$retmsg) = $validators{$$rectype}($self, defrec => $defrec, revrec => $revrec, id => $id, + host => $host, rectype => $rectype, val => $val, addr => $addr, + dist => \$dist, port => \$port, weight => \$weight, + fields => \$fields, vallist => \@vallist); + + return ($retcode,$retmsg) if $retcode eq 'FAIL'; + + # Set up database fields and bind parameters + $fields .= "host,type,val,ttl,"._recparent($defrec,$revrec); + push @vallist, ($$host,$$rectype,$$val,$ttl,$id); + + if ($defrec eq 'n') { + # locations are not for default records, silly coder! + $fields .= ",location"; + push @vallist, $location; + # timestamps are rare. + if ($stamp) { + $fields .= ",stamp,expires,stampactive"; + push @vallist, $stamp, $expires, 'y'; + } else { + $fields .= ",stampactive"; + push @vallist, 'n'; + } + } + + # a little magic to get the right number of ? placeholders based on how many values we're providing + my $vallen = '?'.(',?'x$#vallist); + + # Put together the success log entry. We have to use this horrible kludge + # because domain_id and rdns_id may or may not be present, and if they are, + # they're not at a guaranteed consistent index in the array. wheee! + my %logdata; + my @ftmp = split /,/, $fields; + for (my $i=0; $i <= $#vallist; $i++) { + $logdata{domain_id} = $vallist[$i] if $ftmp[$i] eq 'domain_id'; + $logdata{rdns_id} = $vallist[$i] if $ftmp[$i] eq 'rdns_id'; + } + $logdata{group_id} = $id if $defrec eq 'y'; + $logdata{group_id} = $self->parentID(id => $id, type => ($revrec eq 'n' ? 'domain' : 'revzone'), revrec => $revrec) + if $defrec eq 'n'; + $logdata{entry} = "Added ".($defrec eq 'y' ? 'default record' : 'record'); + # NS records for revzones get special treatment + if ($revrec eq 'y' && $$rectype == 2) { + $logdata{entry} .= " '$$val $typemap{$$rectype} $$host"; + } else { + $logdata{entry} .= " '$$host $typemap{$$rectype} $$val"; + } + + $logdata{entry} .= " [distance $dist]" if $typemap{$$rectype} eq 'MX'; + $logdata{entry} .= " [priority $dist] [weight $weight] [port $port]" + if $typemap{$$rectype} eq 'SRV'; + $logdata{entry} .= "', TTL $ttl"; + $logdata{entry} .= ", location ".$self->getLoc($location)->{description} if $location; + $logdata{entry} .= ($expires eq 'after' ? ', valid after ' : ', expires at ').$stamp if $stamp; + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + eval { + $dbh->do("INSERT INTO "._rectable($defrec, $revrec)." ($fields) VALUES ($vallen)", + undef, @vallist); + $self->_log(%logdata); + $dbh->commit; + }; + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + if ($self->{log_failures}) { + $logdata{entry} = "Failed adding ".($defrec eq 'y' ? 'default ' : ''). + "record '$$host $typemap{$$rectype} $$val', TTL $ttl ($msg)"; + $self->_log(%logdata); + $dbh->commit; + } + return ('FAIL',$msg); + } + + $resultstr = $logdata{entry}; + return ($retcode, $retmsg); + +} # end addRec() + + +## DNSDB::updateRec() +# Update a record +# Takes a database handle, default and reverse flags, record ID, immediate parent ID, and new record data. +# Returns a status code and message +sub updateRec { + $errstr = ''; + + my $self = shift; + my $dbh = $self->{dbh}; + my $defrec = shift; + my $revrec = shift; + my $id = shift; + my $parid = shift; # immediate parent entity that we're descending from to update the record + + # all records have these + my $host = shift; + my $hostbk = $$host; # Keep a backup copy of the original, so we can WARN if the update mangles the domain + my $rectype = shift; + my $val = shift; + my $ttl = shift; + my $location = shift; # may be empty/null/undef depending on caller + $location = '' if !$location; + + my $expires = shift; + $expires = 1 if $expires eq 'until'; # Turn some special values into the appropriate booleans. + $expires = 0 if $expires eq 'after'; + my $stamp = shift; + $stamp = '' if !$stamp; # Timestamp should be a string at this point. + + # just set it to an empty string; failures will be caught later. + $$host = '' if !$$host; + + # Spaces are evil. + $$host =~ s/^\s+//; + $$host =~ s/\s+$//; + if ($typemap{$$rectype} ne 'TXT') { + # Leading or trailng spaces could be legit in TXT records. + $$val =~ s/^\s+//; + $$val =~ s/\s+$//; + } + + if ($self->{lowercase}) { + if ($typemap{$$rectype} ne 'TXT') { + $$host = lc($$host); + $$val = lc($$val); + } else { + # TXT records should preserve user entry in the string. + if ($revrec eq 'n') { + $$host = lc($$host); + } else { + $$val = lc($$val); + } + } + } + + # prep for validation + my $addr = NetAddr::IP->new($$val); + $$host =~ s/\.+$//; # FQDNs ending in . are an internal detail, and really shouldn't be exposed in the UI. + + my $domid = 0; + my $revid = 0; + + my $retcode = 'OK'; # assume everything will go OK + my $retmsg = ''; + + # do simple validation first + return ('FAIL', "TTL must be numeric") unless $ttl =~ /^\d+$/; + + # Quick check on hostname parts. There are enough variations to justify a sub now. + return ('FAIL', $errstr) if ! _check_hostname_form($$host, $$rectype, $defrec, $revrec); + + # only MX and SRV will use these + my $dist = shift || 0; + my $weight = shift || 0; + my $port = shift || 0; + + my $fields; + my @vallist; + + # get old record data so we have the right parent ID + # and for logging (eventually) + my $oldrec = $self->getRecLine($defrec, $revrec, $id); + + # Call the validation sub for the type requested. + # Note the ID to pass here is the *parent*, not the record + ($retcode,$retmsg) = $validators{$$rectype}($self, defrec => $defrec, revrec => $revrec, + id => ($defrec eq 'y' ? $oldrec->{group_id} : ($revrec eq 'n' ? $oldrec->{domain_id} : $oldrec->{rdns_id})), + host => $host, rectype => $rectype, val => $val, addr => $addr, + dist => \$dist, port => \$port, weight => \$weight, + fields => \$fields, vallist => \@vallist, + update => $id); + + return ($retcode,$retmsg) if $retcode eq 'FAIL'; + + # Set up database fields and bind parameters. Note only the optional fields + # (distance, weight, port, secondary parent ID) are added in the validation call above + $fields .= "host,type,val,ttl,"._recparent($defrec,$revrec); + push @vallist, ($$host,$$rectype,$$val,$ttl, + ($defrec eq 'y' ? $oldrec->{group_id} : ($revrec eq 'n' ? $oldrec->{domain_id} : $oldrec->{rdns_id})) ); + + if ($defrec eq 'n') { + # locations are not for default records, silly coder! + $fields .= ",location"; + push @vallist, $location; + # timestamps are rare. + if ($stamp) { + $fields .= ",stamp,expires,stampactive"; + push @vallist, $stamp, $expires, 'y'; + } else { + $fields .= ",stampactive"; + push @vallist, 'n'; + } + } + + # hack hack PTHUI + # need to forcibly make sure we disassociate a record with a parent it's no longer related to. + # eg, PTR records may not have a domain parent, or A/AAAA records may not have a revzone parent. + # mainly needed for crossover types that got coerced down to "standard" types + if ($defrec eq 'n') { + if ($$rectype == $reverse_typemap{PTR}) { + $fields .= ",domain_id"; + push @vallist, 0; + } + if ($$rectype == $reverse_typemap{A} || $$rectype == $reverse_typemap{AAAA}) { + $fields .= ",rdns_id"; + push @vallist, 0; + } + } + # fix fat-finger-originated record type changes + if ($$rectype == 65285) { + $fields .= ",rdns_id" if $revrec eq 'n'; + $fields .= ",domain_id" if $revrec eq 'y'; + push @vallist, 0; + } + if ($defrec eq 'n') { + $domid = $parid if $revrec eq 'n'; + $revid = $parid if $revrec eq 'y'; + } + + # Put together the success log entry. Horrible kludge from addRec() copied as-is since + # we don't know whether the passed arguments or retrieved values for domain_id and rdns_id + # will be maintained (due to "not-in-zone" validation changes) + my %logdata; + $logdata{domain_id} = $domid; + $logdata{rdns_id} = $revid; + my @ftmp = split /,/, $fields; + for (my $i=0; $i <= $#vallist; $i++) { + $logdata{domain_id} = $vallist[$i] if $ftmp[$i] eq 'domain_id'; + $logdata{rdns_id} = $vallist[$i] if $ftmp[$i] eq 'rdns_id'; + } + $logdata{group_id} = $parid if $defrec eq 'y'; + $logdata{group_id} = $self->parentID(id => $parid, type => ($revrec eq 'n' ? 'domain' : 'revzone'), revrec => $revrec) + if $defrec eq 'n'; + $logdata{entry} = "Updated ".($defrec eq 'y' ? 'default record' : 'record')." from\n"; + # NS records for revzones get special treatment + if ($revrec eq 'y' && $$rectype == 2) { + $logdata{entry} .= " '$oldrec->{val} $typemap{$oldrec->{type}} $oldrec->{host}"; + } else { + $logdata{entry} .= " '$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}"; + } + $logdata{entry} .= " [distance $oldrec->{distance}]" if $typemap{$oldrec->{type}} eq 'MX'; + $logdata{entry} .= " [priority $oldrec->{distance}] [weight $oldrec->{weight}] [port $oldrec->{port}]" + if $typemap{$oldrec->{type}} eq 'SRV'; + $logdata{entry} .= "', TTL $oldrec->{ttl}"; + $logdata{entry} .= ", location ".$self->getLoc($oldrec->{location})->{description} if $oldrec->{location}; + $logdata{entry} .= ($oldrec->{expires} ? ', expires at ' : ', valid after ').$oldrec->{stamp} + if $oldrec->{stampactive}; + $logdata{entry} .= "\nto\n"; + # More NS special + if ($revrec eq 'y' && $$rectype == 2) { + $logdata{entry} .= "'$$val $typemap{$$rectype} $$host"; + } else { + $logdata{entry} .= "'$$host $typemap{$$rectype} $$val"; + } + $logdata{entry} .= " [distance $dist]" if $typemap{$$rectype} eq 'MX'; + $logdata{entry} .= " [priority $dist] [weight $weight] [port $port]" if $typemap{$$rectype} eq 'SRV'; + $logdata{entry} .= "', TTL $ttl"; + $logdata{entry} .= ", location ".$self->getLoc($location)->{description} if $location; + $logdata{entry} .= ($expires eq 'after' ? ', valid after ' : ', expires at ').$stamp if $stamp; + + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + # Fiddle the field list into something suitable for updates + $fields =~ s/,/=?,/g; + $fields .= "=?"; + + eval { + $dbh->do("UPDATE "._rectable($defrec,$revrec)." SET $fields WHERE record_id=?", undef, (@vallist, $id) ); + $self->_log(%logdata); + $dbh->commit; + }; + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + if ($self->{log_failures}) { + $logdata{entry} = "Failed updating ".($defrec eq 'y' ? 'default ' : ''). + "record '$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}', TTL $oldrec->{ttl} ($msg)"; + $self->_log(%logdata); + $dbh->commit; + } + return ('FAIL', $msg); + } + + $resultstr = $logdata{entry}; + return ($retcode, $retmsg); +} # end updateRec() + + +## DNSDB::downconvert() +# A mostly internal (not exported) semiutilty sub to downconvert from pseudotype +# to a compatible component type. Only a handful of operations are valid, anything +# else is a null-op. +# Takes the record ID and the new type. Returns boolean. +sub downconvert { + my $self = shift; + my $dbh = $self->{dbh}; + my $recid = shift; + my $newtype = shift; + + # also, only work on live records; little to no value trying to do this on default records. + my $rec = $self->getRecLine('n', 'y', $recid); + + # hm? + #return 1 if !$rec; + + return 1 if $rec->{type} < 65000; # Only the reverse-record pseudotypes can be downconverted + return 1 if $rec->{type} == 65282; # Nowhere to go + + my $delpar; + my @sqlargs; + if ($rec->{type} == 65280) { + return 1 if $newtype != 1 && $newtype != 12; + $delpar = ($newtype == 1 ? 'rdns_id' : 'domain_id'); + push @sqlargs, 0, $newtype, $recid; + } elsif ($rec->{type} == 65281) { + return 1 if $newtype != 28 && $newtype != 12; + $delpar = ($newtype == 28 ? 'rdns_id' : 'domain_id'); + push @sqlargs, 0, $newtype, $recid; + } elsif ($rec->{type} == 65283) { + return 1 if $newtype != 65282; + $delpar = 'rdns_id'; + } elsif ($rec->{type} == 65284) { + return 1 if $newtype != 65282; + $delpar = 'rdns_id'; + } else { + # Your llama is on fire. + } + + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + eval { + $dbh->do("UPDATE records SET $delpar = ?, type = ? WHERE record_id = ?", undef, @sqlargs); + $dbh->commit; + }; + if ($@) { + $errstr = $@; + eval { $dbh->rollback; }; + return 0; + } + return 1; +} # end downconvert() + + +## DNSDB::delRec() +# Delete a record. +sub delRec { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $defrec = shift; + my $revrec = shift; + my $id = shift; + + my $oldrec = $self->getRecLine($defrec, $revrec, $id); + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + # Put together the log entry + my %logdata; + $logdata{domain_id} = $oldrec->{domain_id}; + $logdata{rdns_id} = $oldrec->{rdns_id}; + $logdata{group_id} = $oldrec->{group_id} if $defrec eq 'y'; + $logdata{group_id} = $self->parentID(id => $oldrec->{domain_id}, type => ($revrec eq 'n' ? 'domain' : 'revzone'), + revrec => $revrec) + if $defrec eq 'n'; + $logdata{entry} = "Deleted ".($defrec eq 'y' ? 'default record ' : 'record '). + "'$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}"; + $logdata{entry} .= " [distance $oldrec->{distance}]" if $typemap{$oldrec->{type}} eq 'MX'; + $logdata{entry} .= " [priority $oldrec->{distance}] [weight $oldrec->{weight}] [port $oldrec->{port}]" + if $typemap{$oldrec->{type}} eq 'SRV'; + $logdata{entry} .= "', TTL $oldrec->{ttl}"; + $logdata{entry} .= ", location ".$self->getLoc($oldrec->{location})->{description} if $oldrec->{location}; + + eval { + my $sth = $dbh->do("DELETE FROM "._rectable($defrec,$revrec)." WHERE record_id=?", undef, ($id)); + $self->_log(%logdata); + $dbh->commit; + }; + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + if ($self->{log_failures}) { + $logdata{entry} = "Error deleting ".($defrec eq 'y' ? 'default record' : 'record'). + " '$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}', TTL $oldrec->{ttl} ($msg)"; + $self->_log(%logdata); + $dbh->commit; + } + return ('FAIL', $msg); + } + + return ('OK',$logdata{entry}); +} # end delRec() + + +## DNSDB::getLogCount() +# Get a count of log entries +# Takes a database handle and a hash containing at least: +# - Entity ID and entity type as the primary log "slice" +sub getLogCount { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + my @filterargs; +##fixme: which fields do we want to filter on? +# push @filterargs, + + $errstr = 'Missing primary parent ID and/or type'; + # fail early if we don't have a "prime" ID to look for log entries for + return if !$args{id}; + + # or if the prime id type is missing or invalid + return if !$args{logtype}; + $args{logtype} = 'revzone' if $args{logtype} eq 'rdns'; # hack pthui + $args{logtype} = 'domain' if $args{logtype} eq 'dom'; # hack pthui + return if !grep /^$args{logtype}$/, ('group', 'domain', 'revzone', 'user'); + + my $sql = "SELECT count(*) FROM log ". + "WHERE $id_col{$args{logtype}}=?". + ($args{filter} ? " AND entry ~* ?" : ''); + my ($count) = $dbh->selectrow_array($sql, undef, ($args{id}, @filterargs) ); + $errstr = $dbh->errstr if !$count; + return $count; +} # end getLogCount() + + +## DNSDB::getLogEntries() +# Get a list of log entries +# Takes arguments as with getLogCount() above, plus optional: +# - sort field +# - sort order +# - offset for pagination +sub getLogEntries { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + my @filterargs; + + # fail early if we don't have a "prime" ID to look for log entries for + return if !$args{id}; + + # or if the prime id type is missing or invalid + return if !$args{logtype}; + $args{logtype} = 'revzone' if $args{logtype} eq 'rdns'; # hack pthui + $args{logtype} = 'domain' if $args{logtype} eq 'dom'; # hack pthui + return if !grep /^$args{logtype}$/, ('group', 'domain', 'revzone', 'user'); + + # Sorting defaults + $args{sortorder} = 'DESC' if !$args{sortorder} || !grep /^$args{sortorder}$/, ('ASC','DESC'); + $args{sortby} = 'stamp' if !$args{sortby} || $args{sortby} !~ /^[\w_.]+$/; + $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/; + + my %sortmap = (fname => 'name', username => 'email', entry => 'entry', stamp => 'stamp'); + $args{sortby} = $sortmap{$args{sortby}}; + + my $sql = "SELECT user_id AS userid, email AS useremail, name AS userfname, entry AS logentry, ". + "date_trunc('second',stamp) AS logtime ". + "FROM log ". + "WHERE $id_col{$args{logtype}}=?". + ($args{filter} ? " AND entry ~* ?" : ''). + " ORDER BY $args{sortby} $args{sortorder}, log_id $args{sortorder}". + ($args{offset} eq 'all' ? '' : " LIMIT $self->{perpage} OFFSET ".$args{offset}*$self->{perpage}); + my $loglist = $dbh->selectall_arrayref($sql, { Slice => {} }, ($args{id}, @filterargs) ); + $errstr = $dbh->errstr if !$loglist; + return $loglist; +} # end getLogEntries() + + +## IPDB::getRevPattern() +# Get the narrowest template pattern applicable to a passed CIDR address (may be a netblock or an IP) +sub getRevPattern { + my $self = shift; + my $dbh = $self->{dbh}; + my $cidr = shift; + my $group = shift || 1; # just in case + + # for speed! Casting and comparing even ~7K records takes ~2.5s, so narrow it down to one revzone first. + my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >>= ? AND group_id = ?", + undef, ($cidr, $group) ); + +##fixme? may need to narrow things down more by octet-chopping and doing text comparisons before casting. + my ($revpatt) = $dbh->selectrow_array("SELECT host FROM records ". + "WHERE (type in (12,65280,65281,65282,65283,65284)) AND rdns_id = ? AND CAST (val AS inet) >>= ? ". + "ORDER BY CAST (val AS inet) DESC LIMIT 1", undef, ($revid, $cidr) ); + return $revpatt; +} # end getRevPattern() + + +## DNSDB::getTypelist() +# Get a list of record types for various UI dropdowns +# Takes database handle, forward/reverse/lookup flag, and optional "tag as selected" indicator (defaults to A) +# Returns an arrayref to list of hashrefs perfect for HTML::Template +sub getTypelist { + my $self = shift; + my $dbh = $self->{dbh}; + my $recgroup = shift; + my $type = shift || $reverse_typemap{A}; + + # also accepting $webvar{revrec}! + $recgroup = 'f' if $recgroup eq 'n'; + $recgroup = 'r' if $recgroup eq 'y'; + + my $sql = "SELECT val,name FROM rectypes WHERE "; + if ($recgroup eq 'r') { + # reverse zone types + $sql .= "stdflag=2 OR stdflag=3"; + } elsif ($recgroup eq 'l') { + # DNS lookup types. Note we avoid our custom types >= 65280, since those are entirely internal. + $sql .= "(stdflag=1 OR stdflag=2 OR stdflag=3) AND val < 65280"; + } else { + # default; forward zone types. technically $type eq 'f' but not worth the error message. + $sql .= "stdflag=1 OR stdflag=2"; + $sql .= " AND val < 65280" if $recgroup eq 'fo'; # An extra flag to trim off the pseudotypes as well. + } + $sql .= " ORDER BY listorder"; + + my $sth = $dbh->prepare($sql); + $sth->execute; + my @typelist; + while (my ($rval,$rname) = $sth->fetchrow_array()) { + my %row = ( recval => $rval, recname => $rname ); + $row{tselect} = 1 if $rval == $type; + push @typelist, \%row; + } + + # Add SOA on lookups since it's not listed in other dropdowns. + if ($recgroup eq 'l') { + my %row = ( recval => $reverse_typemap{SOA}, recname => 'SOA' ); + $row{tselect} = 1 if $reverse_typemap{SOA} == $type; + push @typelist, \%row; + } + + return \@typelist; +} # end getTypelist() + + +## DNSDB::parentID() +# Get ID of entity that is nearest parent to requested id +# Takes a database handle and a hash of entity ID, entity type, optional parent type flag +# (domain/reverse zone or group), and optional default/live and forward/reverse flags +# Returns the ID or undef on failure +sub parentID { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + # clean up the parent-type. Set it to group if not set; coerce revzone to domain for simpler logic + $args{partype} = 'group' if !$args{partype}; + $args{partype} = 'domain' if $args{partype} eq 'revzone'; + + # clean up defrec and revrec. default to live record, forward zone + $args{defrec} = 'n' if !$args{defrec}; + $args{revrec} = 'n' if !$args{revrec}; + + if ($par_type{$args{partype}} eq 'domain') { + # only live records can have a domain/zone parent + return unless ($args{type} eq 'record' && $args{defrec} eq 'n'); + my $result = $dbh->selectrow_hashref("SELECT ".($args{revrec} eq 'n' ? 'domain_id' : 'rdns_id'). + " FROM records WHERE record_id = ?", + undef, ($args{id}) ) or return; + return $result; + } else { + # snag some arguments that will either fall through or be overwritten to save some code duplication + my $tmpid = $args{id}; + my $type = $args{type}; + if ($type eq 'record' && $args{defrec} eq 'n') { + # Live records go through the records table first. + ($tmpid) = $dbh->selectrow_array("SELECT ".($args{revrec} eq 'n' ? 'domain_id' : 'rdns_id'). + " FROM records WHERE record_id = ?", + undef, ($args{id}) ) or return; + $type = ($args{revrec} eq 'n' ? 'domain' : 'revzone'); + } + my ($result) = $dbh->selectrow_array("SELECT $par_col{$type} FROM $par_tbl{$type} WHERE $id_col{$type} = ?", + undef, ($tmpid) ); + return $result; + } +# should be impossible to get here with even remotely sane arguments + return; +} # end parentID() + + +## DNSDB::isParent() +# Returns true if $id1 is a parent of $id2, false otherwise +sub isParent { + my $self = shift; + my $dbh = $self->{dbh}; + my $id1 = shift; + my $type1 = shift; + my $id2 = shift; + my $type2 = shift; +##todo: immediate, secondary, full (default) + + # Return false on invalid types + return 0 if !grep /^$type1$/, ('record','defrec','defrevrec','user','domain','revzone','group'); + return 0 if !grep /^$type2$/, ('record','defrec','defrevrec','user','domain','revzone','group'); + + # Return false on impossible relations + return 0 if $type1 eq 'record'; # nothing may be a child of a record + return 0 if $type1 eq 'defrec'; # nothing may be a child of a record + return 0 if $type1 eq 'defrevrec'; # nothing may be a child of a record + return 0 if $type1 eq 'user'; # nothing may be child of a user + return 0 if $type1 eq 'domain' && $type2 ne 'record'; # domain may not be a parent of anything other than a record + return 0 if $type1 eq 'revzone' && $type2 ne 'record';# reverse zone may not be a parent of anything other than a record + + # ennnhhhh.... if we're passed an id of 0, it will never be found. usual + # case would be the UI creating a new , and so we don't have an ID for + # to look up yet. in that case the UI should check the parent as well. + return 0 if $id1 == 0; # nothing can have a parent id of 0 + return 1 if $id2 == 0; # anything could have a child id of 0 (or "unknown") + + # group 1 is the ultimate root parent + return 1 if $type1 eq 'group' && $id1 == 1; + + # groups are always (a) parent of themselves + return 1 if $type1 eq 'group' && $type2 eq 'group' && $id1 == $id2; + + my $id = $id2; + my $type = $type2; + my $foundparent = 0; + + # Records are the only entity with two possible parents. We need to split the parent checks on + # domain/rdns. + if ($type eq 'record') { + my ($dom,$rdns) = $dbh->selectrow_array("SELECT domain_id,rdns_id FROM records WHERE record_id=?", + undef, ($id)); + # check immediate parent against request + return 1 if $type1 eq 'domain' && $id1 == $dom; + return 1 if $type1 eq 'revzone' && $id1 == $rdns; + # if request is group, check *both* parents. Only check if the parent is nonzero though. + return 1 if $dom && $self->isParent($id1, $type1, $dom, 'domain'); + return 1 if $rdns && $self->isParent($id1, $type1, $rdns, 'revzone'); + # exit here since we've executed the loop below by proxy in the above recursive calls. + return 0; + } + +# almost the same loop as getParents() above + my $limiter = 0; + while (1) { + my $sql = "SELECT $par_col{$type} FROM $par_tbl{$type} WHERE $id_col{$type} = ?"; + my $result = $dbh->selectrow_hashref($sql, + undef, ($id) ); + if (!$result) { + $limiter++; +##fixme: how often will this happen on a live site? fail at max limiter ? +# 2013/10/22 only seems to happen when you request an entity that doesn't exist. + warn "no results looking for $sql with id $id (depth $limiter)\n"; + last; + } + if ($result && $result->{$par_col{$type}} == $id1) { + $foundparent = 1; + last; + } else { +##fixme: do we care about trying to return a "no such record/domain/user/group" error? +# should be impossible to create an inconsistent DB just with API calls. + warn $dbh->errstr." $sql, $id" if $dbh->errstr; + } + # group 1 is its own parent. need this here more to break strange loops than for detecting a parent + last if $result->{$par_col{$type}} == 1; + $id = $result->{$par_col{$type}}; + $type = $par_type{$type}; + } + + return $foundparent; +} # end isParent() + + +## DNSDB::zoneStatus() +# Returns and optionally sets a zone's status +# Takes a database handle, domain/revzone ID, forward/reverse flag, and optionally a status argument +# Returns status, or undef on errors. +sub zoneStatus { + my $self = shift; + my $dbh = $self->{dbh}; + my $id = shift; + my $revrec = shift; + my $newstatus = shift || 'mu'; + + return undef if $id !~ /^\d+$/; + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + if ($newstatus ne 'mu') { + # ooo, fun! let's see what we were passed for status + eval { + $newstatus = 0 if $newstatus eq 'domoff'; + $newstatus = 1 if $newstatus eq 'domon'; + $dbh->do("UPDATE ".($revrec eq 'n' ? 'domains' : 'revzones')." SET status=? WHERE ". + ($revrec eq 'n' ? 'domain_id' : 'rdns_id')."=?", undef, ($newstatus,$id) ); + +##fixme switch to more consise "Enabled " as with users? + $resultstr = "Changed ".($revrec eq 'n' ? $self->domainName($id) : $self->revName($id)). + " state to ".($newstatus ? 'active' : 'inactive'); + + my %loghash; + $loghash{domain_id} = $id if $revrec eq 'n'; + $loghash{rdns_id} = $id if $revrec eq 'y'; + $loghash{group_id} = $self->parentID(id => $id, type => ($revrec eq 'n' ? 'domain' : 'revzone'), revrec => $revrec); + $loghash{entry} = $resultstr; + $self->_log(%loghash); + + $dbh->commit; + }; + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + $resultstr = ''; + $errstr = $msg; + return; + } + } + + my ($status) = $dbh->selectrow_array("SELECT status FROM ". + ($revrec eq 'n' ? "domains WHERE domain_id=?" : "revzones WHERE rdns_id=?"), + undef, ($id) ); + return $status; +} # end zoneStatus() + + +## DNSDB::getZonesByCIDR() +# Get a list of zone names and IDs that records for a passed CIDR block are within. +sub getZonesByCIDR { + my $self = shift; + my $dbh = $self->{dbh}; + my %args = @_; + + my $result = $dbh->selectall_arrayref("SELECT rdns_id,revnet FROM revzones WHERE revnet >>= ? OR revnet <<= ?", + { Slice => {} }, ($args{cidr}, $args{cidr}) ); + return $result; +} # end getZonesByCIDR() + + +## DNSDB::importAXFR +# Import a domain via AXFR +# Takes AXFR host, domain to transfer, group to put the domain in, +# and an optional hash containing: +# status - active/inactive state flag (defaults to active) +# rwsoa - overwrite-SOA flag (defaults to off) +# rwns - overwrite-NS flag (defaults to off, doesn't affect subdomain NS records) +# merge - flag to automerge A or AAAA records with matching PTR records +# Returns a status code (OK, WARN, or FAIL) and message - message should be blank +# if status is OK, but WARN includes conditions that are not fatal but should +# really be reported. +sub importAXFR { + my $self = shift; + my $dbh = $self->{dbh}; + my $ifrom_in = shift; + my $zone = shift; + my $group = shift; + + my %args = @_; + +##fixme: add mode to delete&replace, merge+overwrite, merge new? + + $args{status} = (defined($args{status}) ? $args{status} : 0); + $args{status} = 1 if $args{status} eq 'on'; + + my $nrecs = 0; + my $soaflag = 0; + my $nsflag = 0; + my $warnmsg = ''; + my $ifrom; + + my $rev = 'n'; + my $code = 'OK'; + my $msg = 'foobar?'; + + # choke on possible bad setting in ifrom + # IPv4 and v6, and valid hostnames! + ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+|[0-9a-z_.-]+)$/i); + return ('FAIL', "Bad AXFR source host $ifrom") + unless ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+|[0-9a-z_.-]+)$/i); + + my $errmsg; + + my $zone_id; + my $domain_id = 0; + my $rdns_id = 0; + my $cidr; + +# magic happens! detect if we're importing a domain or a reverse zone +# while we're at it, figure out what the CIDR netblock is (if we got a .arpa) +# or what the formal .arpa zone is (if we got a CIDR netblock) +# Handles sub-octet v4 zones in the format specified in the Cricket Book, 2nd Ed, p217-218 + + if ($zone =~ m{(?:\.arpa\.?|/\d+)$}) { + # we seem to have a reverse zone + $rev = 'y'; + + if ($zone =~ /\.arpa\.?$/) { + # we have a formal reverse zone. call _zone2cidr and get the CIDR block. + ($code,$msg) = _zone2cidr($zone); + return ($code, $msg) if $code eq 'FAIL'; + $cidr = $msg; + } elsif ($zone =~ m|^[\d.]+/\d+$|) { + # v4 revzone, CIDR netblock + $cidr = NetAddr::IP->new($zone) or return ('FAIL',"$zone is not a valid CIDR block"); + $zone = _ZONE($cidr, 'ZONE.in-addr.arpa', 'r', '.'); + } elsif ($zone =~ m|^[a-fA-F\d:]+/\d+$|) { + # v6 revzone, CIDR netblock + $cidr = NetAddr::IP->new($zone) or return ('FAIL',"$zone is not a valid CIDR block"); + return ('FAIL', "$zone is not a nibble-aligned block") if $cidr->masklen % 4 != 0; + $zone = _ZONE($cidr, 'ZONE.ip6.arpa', 'r', '.'); + } else { + # there is. no. else! + return ('FAIL', "Unknown zone name format"); + } + + # quick check to start to see if we've already got one + + ($zone_id) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet=?", + undef, ("$cidr")); + $rdns_id = $zone_id; + } else { + # default to domain + ($zone_id) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)", + undef, ($zone)); + $domain_id = $zone_id; + } + + return ('FAIL', ($rev eq 'n' ? 'Domain' : 'Reverse zone')." already exists") if $zone_id; + + # little local utility sub to swap $val and $host for revzone records. + sub _revswap { + my $rechost = shift; + my $recdata = shift; + + if ($rechost =~ /\.in-addr\.arpa\.?$/) { + $rechost =~ s/\.in-addr\.arpa\.?$//; + $rechost = join '.', reverse split /\./, $rechost; + } else { + $rechost =~ s/\.ip6\.arpa\.?$//; + my @nibs = reverse split /\./, $rechost; + $rechost = ''; + my $nc; + foreach (@nibs) { + $rechost.= $_; + $rechost .= ":" if ++$nc % 4 == 0 && $nc < 32; + } + $rechost .= ":" if $nc < 32 && $rechost !~ /\*$/; # close netblock records? +##fixme: there's a case that ends up with a partial entry here: +# ip:add:re:ss:: +# can't reproduce after letting it sit overnight after discovery. :( +#print "$rechost\n"; + # canonicalize with NetAddr::IP + $rechost = NetAddr::IP->new($rechost)->addr unless $rechost =~ /\*$/; + } + return ($recdata,$rechost) + } + + + # Allow transactions, and raise an exception on errors so we can catch it later. + # Use local to make sure these get "reset" properly on exiting this block + local $dbh->{AutoCommit} = 0; + local $dbh->{RaiseError} = 1; + + my $sth; + eval { + + if ($rev eq 'n') { +##fixme: serial + $dbh->do("INSERT INTO domains (domain,group_id,status) VALUES (?,?,?)", undef, + ($zone, $group, $args{status}) ); + # get domain id so we can do the records + ($zone_id) = $dbh->selectrow_array("SELECT currval('domains_domain_id_seq')"); + $domain_id = $zone_id; + $self->_log(group_id => $group, domain_id => $domain_id, + entry => "[Added ".($args{status} ? 'active' : 'inactive')." domain $zone via AXFR]"); + } else { +##fixme: serial + $dbh->do("INSERT INTO revzones (revnet,group_id,status) VALUES (?,?,?)", undef, + ($cidr,$group,$args{status}) ); + # get revzone id so we can do the records + ($zone_id) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')"); + $rdns_id = $zone_id; + $self->_log(group_id => $group, rdns_id => $rdns_id, + entry => "[Added ".($args{status} ? 'active' : 'inactive')." reverse zone $cidr via AXFR]"); + } + +## bizarre DBI<->Net::DNS interaction bug: +## sometimes a zone will cause an immediate commit-and-exit (sort of) of the while() +## fixed, apparently I was doing *something* odd, but not certain what it was that +## caused a commit instead of barfing + + my $res = Net::DNS::Resolver->new; + $res->nameservers($ifrom); + $res->axfr_start($zone) + or die "Couldn't begin AXFR\n"; + + $sth = $dbh->prepare("INSERT INTO records (domain_id,rdns_id,host,type,val,distance,weight,port,ttl)". + " VALUES (?,?,?,?,?,?,?,?,?)"); + + # Stash info about sub-octet v4 revzones here so we don't have + # to store the CNAMEs used to delegate a suboctet zone + # $suboct{zone}{ns}[] -> array of nameservers + # $suboct{zone}{cname}[] -> array of extant CNAMEs (Just In Case someone did something bizarre) +## commented pending actual use of this data. for now, we'll just +## auto-(re)create the CNAMEs in revzones on export +# my %suboct; + + while (my $rr = $res->axfr_next()) { + + my $val; + my $distance = 0; + my $weight = 0; + my $port = 0; + my $logfrag = ''; + + my $type = $rr->type; + my $host = $rr->name; + my $ttl = ($args{newttl} ? $args{newttl} : $rr->ttl); # allow force-override TTLs + + $soaflag = 1 if $type eq 'SOA'; + $nsflag = 1 if $type eq 'NS'; + +# "Primary" types: +# A, NS, CNAME, SOA, PTR(warn in forward), MX, TXT, AAAA, SRV, A6(ob), SPF +# maybe KEY + +# BIND supports: +# [standard] +# A AAAA CNAME MX NS PTR SOA TXT +# [variously experimental, obsolete, or obscure] +# HINFO MB(ex) MD(ob) MF(ob) MG(ex) MINFO(ex) MR(ex) NULL WKS AFSDB(ex) ISDN(ex) RP(ex) RT(ex) X25(ex) PX +# ... if one can ever find the right magic to format them correctly + +# Net::DNS supports: +# RRSIG SIG NSAP NS NIMLOC NAPTR MX MR MINFO MG MB LOC ISDN IPSECKEY HINFO +# EID DNAME CNAME CERT APL AFSDB AAAA A DS NXT NSEC3PARAM NSEC3 NSEC KEY +# DNSKEY DLV X25 TXT TSIG TKEY SSHFP SRV SPF SOA RT RP PX PTR NULL APL::AplItem + +# nasty big ugly case-like thing here, since we have to do *some* different +# processing depending on the record. le sigh. + +##fixme: what record types other than TXT can/will have >255-byte payloads? + + if ($type eq 'A') { + $val = $rr->address; + } elsif ($type eq 'NS') { +# hmm. should we warn here if subdomain NS'es are left alone? + next if ($args{rwns} && ($rr->name eq $zone)); + if ($rev eq 'y') { + # revzones have records more or less reversed from forward zones. + my ($tmpcode,$tmpmsg) = _zone2cidr($host); + die "Error converting NS record: $tmpmsg\n" if $tmpcode eq 'FAIL'; # hmm. may not make sense... + $val = "$tmpmsg"; + $host = $rr->nsdname; + $logfrag = "Added record '$val $type $host', TTL $ttl"; +# Tag and preserve. For now this is commented for a no-op, but we have Ideas for +# another custom storage type ("DELEGATE") that will use these subzone-delegation records +#if ($val ne "$cidr") { +# push @{$suboct{$val}{ns}}, $host; +#} + } else { + $val = $rr->nsdname; + } + $nsflag = 1; + } elsif ($type eq 'CNAME') { + if ($rev eq 'y') { + # hmm. do we even want to bother with storing these at this level? Sub-octet delegation + # by CNAME is essentially a record-publication hack, and we want to just represent the + # "true" logical intentions as far down the stack as we can from the UI. + ($host,$val) = _revswap($host,$rr->cname); + $logfrag = "Added record '$val $type $host', TTL $ttl"; +# Tag and preserve in case we want to commit them as-is later, but mostly we don't care. +# Commented pending actually doing something with possibly new type DELEGATE +#my $tmprev = $host; +#$tmprev =~ s/^\d+\.//; +#($code,$tmprev) = _zone2cidr($tmprev); +#push @{$suboct{"$tmprev"}{cname}}, $val; + # Silently skip CNAMEs in revzones. + next; + } else { + $val = $rr->cname; + } + } elsif ($type eq 'SOA') { + next if $args{rwsoa}; + $host = $rr->rname.":".$rr->mname; + $val = $rr->refresh.":".$rr->retry.":".$rr->expire.":".$rr->minimum; + $soaflag = 1; + } elsif ($type eq 'PTR') { + ($host,$val) = _revswap($host,$rr->ptrdname); + $logfrag = "Added record '$val $type $host', TTL $ttl"; + # hmm. PTR records should not be in forward zones. + } elsif ($type eq 'MX') { + $val = $rr->exchange; + $distance = $rr->preference; + } elsif ($type eq 'TXT') { +##fixme: Net::DNS docs say this should be deprecated for rdatastr() or char_str_list(), +## but don't really seem enthusiastic about it. +#print "should use rdatastr:\n\t".$rr->rdatastr."\n or char_str_list:\n\t".join(' ',$rr->char_str_list())."\n"; +# rdatastr returns a BIND-targetted logical string, including opening and closing quotes +# char_str_list returns a list of the individual string fragments in the record +# txtdata returns the more useful all-in-one form (since we want to push such protocol +# details as far down the stack as we can) +# NB: this may turn out to be more troublesome if we ever have need of >512-byte TXT records. + if ($rev eq 'y') { + ($host,$val) = _revswap($host,$rr->txtdata); + $logfrag = "Added record '$val $type $host', TTL $ttl"; + } else { + $val = $rr->txtdata; + } + } elsif ($type eq 'SPF') { +##fixme: and the same caveat here, since it is apparently a clone of ::TXT + $val = $rr->txtdata; + } elsif ($type eq 'AAAA') { + $val = $rr->address; + } elsif ($type eq 'SRV') { + $val = $rr->target; + $distance = $rr->priority; + $weight = $rr->weight; + $port = $rr->port; + } elsif ($type eq 'KEY') { + # we don't actually know what to do with these... + $val = $rr->flags.":".$rr->protocol.":".$rr->algorithm.":".$rr->key.":".$rr->keytag.":".$rr->privatekeyname; + } else { + $val = $rr->rdatastr; + # Finding a different record type is not fatal.... just problematic. + # We may not be able to export it correctly. + $warnmsg .= "Unusual record ".$rr->name." ($type) found\n"; + } + + my $logentry = "[AXFR ".($rev eq 'n' ? $zone : $cidr)."] "; + + if ($args{merge}) { + if ($rev eq 'n') { + # importing a domain; we have A and AAAA records that could be merged with matching PTR records + my $etype; + my ($erdns,$erid,$ettl) = $dbh->selectrow_array("SELECT rdns_id,record_id,ttl FROM records ". + "WHERE host=? AND val=? AND type=12", + undef, ($host, $val) ); + if ($erid) { + if ($type eq 'A') { # PTR -> A+PTR + $etype = 65280; + $logentry .= "Merged A record with existing PTR record '$host A+PTR $val', TTL $ettl"; + } + if ($type eq 'AAAA') { # PTR -> AAAA+PTR + $etype = 65281; + $logentry .= "Merged AAAA record with existing PTR record '$host AAAA+PTR $val', TTL $ettl"; + } + $ettl = ($ettl < $ttl ? $ettl : $ttl); # use lower TTL + $dbh->do("UPDATE records SET domain_id=?,ttl=?,type=? WHERE record_id=?", undef, + ($domain_id, $ettl, $etype, $erid)); + $nrecs++; + $self->_log(group_id => $group, domain_id => $domain_id, rdns_id => $erdns, entry => $logentry); + next; # while axfr_next + } + } # $rev eq 'n' + else { + # importing a revzone, we have PTR records that could be merged with matching A/AAAA records + my ($domid,$erid,$ettl,$etype) = $dbh->selectrow_array("SELECT domain_id,record_id,ttl,type FROM records ". + "WHERE host=? AND val=? AND (type=1 OR type=28)", + undef, ($host, $val) ); + if ($erid) { + if ($etype == 1) { # A -> A+PTR + $etype = 65280; + $logentry .= "Merged PTR record with existing matching A record '$host A+PTR $val', TTL $ettl"; + } + if ($etype == 28) { # AAAA -> AAAA+PTR + $etype = 65281; + $logentry .= "Merged PTR record with existing matching AAAA record '$host AAAA+PTR $val', TTL $ettl"; + } + $ettl = ($ettl < $ttl ? $ettl : $ttl); # use lower TTL + $dbh->do("UPDATE records SET rdns_id=?,ttl=?,type=? WHERE record_id=?", undef, + ($rdns_id, $ettl, $etype, $erid)); + $nrecs++; + $self->_log(group_id => $group, domain_id => $domid, rdns_id => $rdns_id, entry => $logentry); + next; # while axfr_next + } + } # $rev eq 'y' + } # if $args{merge} + + # Insert the new record + $sth->execute($domain_id, $rdns_id, $host, $reverse_typemap{$type}, $val, + $distance, $weight, $port, $ttl); + + $nrecs++; + + if ($type eq 'SOA') { + # also !$args{rwsoa}, but if that's set, it should be impossible to get here. + my @tmp1 = split /:/, $host; + my @tmp2 = split /:/, $val; + $logentry .= "Added SOA record [contact $tmp1[0]] [master $tmp1[1]] ". + "[refresh $tmp2[0]] [retry $tmp2[1]] [expire $tmp2[2]] [minttl $tmp2[3]], TTL $ttl"; + } elsif ($logfrag) { + # special case for log entries we need to meddle with a little. + $logentry .= $logfrag; + } else { + $logentry .= "Added record '$host $type"; + $logentry .= " [distance $distance]" if $type eq 'MX'; + $logentry .= " [priority $distance] [weight $weight] [port $port]" if $type eq 'SRV'; + $logentry .= " $val', TTL $ttl"; + } + $self->_log(group_id => $group, domain_id => $domain_id, rdns_id => $rdns_id, entry => $logentry); + + } # while axfr_next + +# Detect and handle delegated subzones +# Placeholder for when we decide what to actually do with this, see previous comments in NS and CNAME handling. +#foreach (keys %suboct) { +# print "found ".($suboct{$_}{ns} ? @{$suboct{$_}{ns}} : '0')." NS records and ". +# ($suboct{$_}{cname} ? @{$suboct{$_}{cname}} : '0')." CNAMEs for $_\n"; +#} + + # Overwrite SOA record + if ($args{rwsoa}) { + $soaflag = 1; + my $sthgetsoa = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?"); + my $sthputsoa = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)"); + $sthgetsoa->execute($group,$reverse_typemap{SOA}); + while (my ($host,$val,$ttl) = $sthgetsoa->fetchrow_array()) { + $host =~ s/DOMAIN/$zone/g; + $val =~ s/DOMAIN/$zone/g; + $sthputsoa->execute($zone_id,$host,$reverse_typemap{SOA},$val,$ttl); + } + } + + # Overwrite NS records + if ($args{rwns}) { + $nsflag = 1; + my $sthgetns = $dbh->prepare("SELECT host,val,ttl FROM default_records WHERE group_id=? AND type=?"); + my $sthputns = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,ttl) VALUES (?,?,?,?,?)"); + $sthgetns->execute($group,$reverse_typemap{NS}); + while (my ($host,$val,$ttl) = $sthgetns->fetchrow_array()) { + $host =~ s/DOMAIN/$zone/g; + $val =~ s/DOMAIN/$zone/g; + $sthputns->execute($zone_id,$host,$reverse_typemap{NS},$val,$ttl); + } + } + + die "No records found; either $ifrom is not authoritative or doesn't allow transfers\n" if !$nrecs; + die "Bad zone: No SOA record!\n" if !$soaflag; + die "Bad zone: No NS records!\n" if !$nsflag; + + $dbh->commit; + + }; + + if ($@) { + my $msg = $@; + eval { $dbh->rollback; }; + return ('FAIL',$msg." $warnmsg"); + } else { + return ('WARN', $warnmsg) if $warnmsg; + return ('OK',"Imported OK"); + } + + # it should be impossible to get here. + return ('WARN',"OOOK!"); +} # end importAXFR() + + +## DNSDB::importBIND() +sub importBIND { +} # end importBIND() + + +## DNSDB::import_tinydns() +sub import_tinydns { +} # end import_tinydns() + + +## DNSDB::export() +# Export the DNS database, or a part of it +# Takes a string indicating the export type, plus optional arguments depending on type +# Writes zone data to targets as appropriate for type +sub export { + my $self = shift; + my $target = shift; + + if ($target eq 'tiny') { + $self->__export_tiny(@_); + } +# elsif ($target eq 'foo') { +# __export_foo(@_); +#} +# etc + +} # end export() + + +## DNSDB::__export_tiny +# Internal sub to implement tinyDNS (compatible) export +# Takes filehandle to write export to, optional argument(s) +# to determine which data gets exported +sub __export_tiny { + my $self = shift; + my $dbh = $self->{dbh}; + my $datafile = shift; + +##fixme: slurp up further options to specify particular zone(s) to export + +##fixme: fail if $datafile isn't an open, writable file + + # easy case - export all evarything + # not-so-easy case - export item(s) specified + # todo: figure out what kind of list we use to export items + +# raw packet in unknown format: first byte indicates length +# of remaining data, allows up to 255 raw bytes + + # Locations/views - worth including in the caching setup? + my $lochash = $dbh->selectall_hashref("SELECT location,iplist FROM locations", 'location'); + foreach my $location (keys %$lochash) { + foreach my $ipprefix (split /[,\s]+/, $lochash->{$location}{iplist}) { + $ipprefix =~ s/\s+//g; + $ipprefix = new NetAddr::IP $ipprefix; +##fixme: how to handle IPv6? +next if $ipprefix->{isv6}; + # have to account for /nn CIDR entries. tinydns only speaks octet-sliced prefix. + if ($ipprefix->masklen <= 8) { + foreach ($ipprefix->split(8)) { + my $tmp = $_->addr; + $tmp =~ s/\.\d+\.\d+\.\d+$//; + print $datafile "%$location:$tmp\n"; + } + } elsif ($ipprefix->masklen <= 16) { + foreach ($ipprefix->split(16)) { + my $tmp = $_->addr; + $tmp =~ s/\.\d+\.\d+$//; + print $datafile "%$location:$tmp\n"; + } + } elsif ($ipprefix->masklen <= 24) { + foreach ($ipprefix->split(24)) { + my $tmp = $_->addr; + $tmp =~ s/\.\d+$//; + print $datafile "%$location:$tmp\n"; + } + } else { + foreach ($ipprefix->split(32)) { + print $datafile "%$location:".$_->addr."\n"; + } + } + } + print $datafile "%$location\n" if !$lochash->{$location}{iplist}; + } + + # tracking hash so we don't double-export A+PTR or AAAA+PTR records. + my %recflags; + +# For reasons unknown, we can't sanely UNION these statements. Feh. +# Supposedly it should work though (note last 3 lines): +## PG manual +#UNION Clause +# +#The UNION clause has this general form: +# +# select_statement UNION [ ALL ] select_statement +# +#select_statement is any SELECT statement without an ORDER BY, LIMIT, FOR UPDATE, or FOR SHARE clause. (ORDER BY +#and LIMIT can be attached to a subexpression if it is enclosed in parentheses. Without parentheses, these +#clauses will be taken to apply to the result of the UNION, not to its right-hand input expression.) + my $soasth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl,record_id,location ". + "FROM records WHERE rdns_id=? AND type=6"); + my $recsth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl,record_id,location,extract(epoch from stamp),expires,stampactive ". + "FROM records WHERE rdns_id=? AND not type=6 ". + "ORDER BY masklen(CAST(val AS inet)) DESC, CAST(val AS inet)"); + my $revsth = $dbh->prepare("SELECT rdns_id,revnet,status,changed FROM revzones WHERE status=1 ". + "ORDER BY masklen(revnet) DESC"); + my $zonesth = $dbh->prepare("UPDATE revzones SET changed='n' WHERE rdns_id=?"); + $revsth->execute(); + while (my ($revid,$revzone,$revstat,$changed) = $revsth->fetchrow_array) { +##fixme: need to find a way to block opening symlinked files without introducing a race. +# O_NOFOLLOW +# If pathname is a symbolic link, then the open fails. This is a FreeBSD extension, which was +# added to Linux in version 2.1.126. Symbolic links in earlier components of the pathname will +# still be followed. +# but that doesn't help other platforms. :/ + my $tmpzone = NetAddr::IP->new($revzone); +##fixme: locations/views? subnet mask? need to avoid possible collisions with zone/superzone +## (eg /20 vs /24, starting on .0.0) + my $cz = $tmpzone->network->addr."-".$tmpzone->masklen; + my $cachefile = "$self->{exportcache}/$cz"; + my $tmpcache = "$self->{exportcache}/tmp.$cz.$$"; + eval { + + # only update the cache file if the zone has changed, or if the cache file has nothing in it. + if ($self->{force_refresh} || $changed || !-e $cachefile || -z $cachefile) { + open ZONECACHE, ">$tmpcache" or die "Error creating temporary file $tmpcache: $!\n"; + + # need to fetch this separately since the rest of the records all (should) have real IPs in val + $soasth->execute($revid); + my (@zsoa) = $soasth->fetchrow_array(); + _printrec_tiny(*ZONECACHE,'y',\%recflags,$revzone, + $zsoa[0],$zsoa[1],$zsoa[2],$zsoa[3],$zsoa[4],$zsoa[5],$zsoa[6],$zsoa[8],''); + + $recsth->execute($revid); + while (my ($host,$type,$val,$dist,$weight,$port,$ttl,$recid,$loc,$stamp,$expires,$stampactive) = $recsth->fetchrow_array) { + next if $recflags{$recid}; + +# not sure this is necessary for revzones. +# # Spaces are evil. +# $val =~ s/^\s+//; +# $val =~ s/\s+$//; +# if ($typemap{$type} ne 'TXT') { +# # Leading or trailng spaces could be legit in TXT records. +# $host =~ s/^\s+//; +# $host =~ s/\s+$//; +# } + + _printrec_tiny(*ZONECACHE, 'y', \%recflags, $revzone, + $host, $type, $val, $dist, $weight, $port, $ttl, $loc, $stamp, $expires, $stampactive) + if *ZONECACHE; + + $recflags{$recid} = 1; + + } # while ($recsth) + + close ZONECACHE; # force the file to be written + + # catch obvious write errors that leave an empty temp file + if (-s $tmpcache) { + rename $tmpcache, $cachefile + or die "Error overwriting cache file $cachefile with temporary file: $!\n"; + } + + } # if $changed or cache filesize is 0 + + }; + if ($@) { + print "error writing new data for $revzone: $@\n"; + # error! something borked, and we should be able to fall back on the old cache file + # report the error, somehow. + } else { + # mark zone as unmodified. Only do this if no errors, that way + # export failures should recover a little more automatically. + $zonesth->execute($revid); + } + # Always stream the cache (even if stale or obsolete due to errors creating the new cache) + open CACHE, "<$cachefile"; + print $datafile $_ while ; + close CACHE; + + } # while ($revsth) + + my $domsth = $dbh->prepare("SELECT domain_id,domain,status,changed FROM domains WHERE status=1"); + $recsth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl,record_id,location,extract(epoch from stamp),expires,stampactive ". + "FROM records WHERE domain_id=?"); # Just exclude all types relating to rDNS +# "FROM records WHERE domain_id=? AND type < 65280"); # Just exclude all types relating to rDNS + $zonesth = $dbh->prepare("UPDATE domains SET changed='n' WHERE domain_id=?"); + $domsth->execute(); + while (my ($domid,$dom,$domstat,$changed) = $domsth->fetchrow_array) { +##fixme: need to find a way to block opening symlinked files without introducing a race. +# O_NOFOLLOW +# If pathname is a symbolic link, then the open fails. This is a FreeBSD extension, which was +# added to Linux in version 2.1.126. Symbolic links in earlier components of the pathname will +# still be followed. +# but that doesn't help other platforms. :/ + my $cachefile = "$self->{exportcache}/$dom"; + my $tmpcache = "$self->{exportcache}/tmp.$dom.$$"; + eval { + + # only update the cache file if the zone has changed, or if the cache file has nothing in it. + if ($self->{force_refresh} || $changed || !-e $cachefile || -z $cachefile) { + open ZONECACHE, ">$tmpcache" or die "Error creating temporary file $tmpcache: $!\n"; + + $recsth->execute($domid); + while (my ($host,$type,$val,$dist,$weight,$port,$ttl,$recid,$loc,$stamp,$expires,$stampactive) = $recsth->fetchrow_array) { + next if $recflags{$recid}; + + # Spaces are evil. + $host =~ s/^\s+//; + $host =~ s/\s+$//; + if ($typemap{$type} ne 'TXT') { + # Leading or trailng spaces could be legit in TXT records. + $val =~ s/^\s+//; + $val =~ s/\s+$//; + } + + _printrec_tiny(*ZONECACHE, 'n', \%recflags, + $dom, $host, $type, $val, $dist, $weight, $port, $ttl, $loc, $stamp, $expires, $stampactive) + if *ZONECACHE; + + $recflags{$recid} = 1; + + } # while ($recsth) + + close ZONECACHE; # force the file to be written + + # catch obvious write errors that leave an empty temp file + if (-s $tmpcache) { + rename $tmpcache, $cachefile + or die "Error overwriting cache file $cachefile with temporary file: $!\n"; + } + + } # if $changed or cache filesize is 0 + + }; + if ($@) { + print "error writing new data for $dom: $@\n"; + # error! something borked, and we should be able to fall back on the old cache file + # report the error, somehow. + } else { + # mark domain as unmodified. Only do this if no errors, that way + # export failures should recover a little more automatically. + $zonesth->execute($domid); + } + # Always stream the cache (even if stale or obsolete due to errors creating the new cache) + open CACHE, "<$cachefile"; + print $datafile $_ while ; + close CACHE; + + } # while ($domsth) + +} # end __export_tiny() + + +# Utility sub for __export_tiny above +sub _printrec_tiny { + my ($datafile,$revrec,$recflags,$zone,$host,$type,$val,$dist,$weight,$port,$ttl,$loc,$stamp,$expires,$stampactive) = @_; + + $loc = '' if !$loc; # de-nullify - just in case +##fixme: handle case of record-with-location-that-doesn't-exist better. +# note this currently fails safe (tested) - records with a location that +# doesn't exist will not be sent to any client +# $loc = '' if !$lochash->{$loc}; + + +## Records that are valid only before or after a set time + +# record due to expire sometime is the complex case. we don't want to just +# rely on tinydns' auto-adjusting TTLs, because the default TTL in that case +# is one day instead of the SOA minttl as BIND might do. + +# consider the case where a record is set to expire a week ahead, but the next +# day later you want to change it NOW (or as NOWish as you get with your DNS +# management practice). but now you're stuck, because someone, somewhere, +# has just done a lookup before your latest change was published, and they'll +# be caching that old, broken record for 1 day instead of your zone default +# TTL. + +# $stamp-$ttl is the *latest* we can publish the record with the defined TTL +# to still have the expiry happen as scheduled, but we need to find some +# *earlier* point. We can maybe guess, and 2x TTL is probably reasonable, +# but we need info on the export frequency. + +# export the normal, non-expiring record up until $stamp-, then +# switch to exporting a record with the TAI64 stamp and a 0 TTL so tinydns +# takes over TTL management. + + if ($stampactive) { + if ($expires) { + # record expires at $stamp; decide if we need to keep the TTL and ignore + # the stamp for a time or if we need to change the TTL to 0 and convert + # $stamp to TAI64 so tinydns can use $stamp to autoadjust the TTL on the fly. +# extra hack, optimally needs more knowledge of data export frequency +# smack the idiot customer who insists on 0 TTLs; they can suck up and +# deal with a 10-minute TTL. especially on scheduled changes. note this +# should be (export freq * 2), but we don't know the actual export frequency. +$ttl = 300 if $ttl == 0; #hack phtui + my $ahead = (86400 < $ttl*2 ? 86400 : $ttl*2); + if ((time() + $ahead) < $stamp) { + # more than 2x TTL OR more than one day (whichever is less) from expiry time; publish normal record + $stamp = ''; + } else { + # less than 2x TTL from expiry time, let tinydns take over TTL management and publish the TAI64 stamp. + $ttl = 0; + $stamp = unixtai64($stamp); + $stamp =~ s/\@//; + } + } else { + # record is "active after"; convert epoch from database to TAI64, publish, and collect $200. + $stamp = unixtai64($stamp); + $stamp =~ s/\@//; + } + } else { + # flag for active timestamp is false; don't actually put a timestamp in the output + $stamp = ''; + } + + # support tinydns' auto-TTL + $ttl = '' if $ttl == -1; +# these are WAY FREAKING HIGH - higher even than most TLD registry TTLs! +# NS 259200 => 3d +# all others 86400 => 1d + + if ($revrec eq 'y') { + $val = $zone if $val eq '@'; + } else { + $host = $zone if $host eq '@'; + } + + ## Convert a bare number into an octal-coded pair of octets. + # Take optional arg to indicate a decimal or hex input. Defaults to hex. + sub octalize { + my $tmp = shift; + my $srctype = shift || 'h'; # default assumes hex string + $tmp = sprintf "%0.4x", hex($tmp) if $srctype eq 'h'; # 0-pad hex to 4 digits + $tmp = sprintf "%0.4x", $tmp if $srctype eq 'd'; # 0-pad decimal to 4 hex digits + my @o = ($tmp =~ /^(..)(..)$/); # split into octets + return sprintf "\\%0.3o\\%0.3o", hex($o[0]), hex($o[1]);; + } + +## WARNING: This works to export even the whole Internet's worth of IP space... +## if you have the disk/RAM to handle the dataset, and you call this sub based on /16-sized chunks +## A /16 took ~3 seconds with a handful of separate records; adding a /8 pushed export time out to ~13m:40s +## 0/0 is estimated to take ~54 hours and ~256G of disk +## RAM usage depends on how many non-template entries you have in the set. +## This should probably be done on record addition rather than export; large blocks may need to be done in a +## forked process + sub __publish_subnet { + my $sub = shift; + my $recflags = shift; + my $hpat = shift; + my $fh = shift; + my $ttl = shift; + my $stamp = shift; + my $loc = shift; + my $ptronly = shift || 0; + + my $iplist = $sub->splitref(32); + foreach (@$iplist) { + my $ip = $_->addr; + # make as if we split the non-octet-aligned block into octet-aligned blocks as with SOA + next if $ip =~ /\.(0|255)$/; + next if $$recflags{$ip}; + $$recflags{$ip}++; + next if $hpat eq '%blank%'; # Allows blanking a subnet so no records are published. + my $rec = $hpat; # start fresh with the template for each IP + _template4_expand(\$rec, $ip); + print $fh ($ptronly ? "^"._ZONE($_, 'ZONE.in-addr.arpa', 'r', '.').":$rec" : "=$rec:$ip"). + ":$ttl:$stamp:$loc\n"; + } + } + +##fixme? append . to all host/val hostnames + if ($typemap{$type} eq 'SOA') { + + # host contains pri-ns:responsible + # val is abused to contain refresh:retry:expire:minttl +##fixme: "manual" serial vs tinydns-autoserial + # let's be explicit about abusing $host and $val + my ($email, $primary) = (split /:/, $host)[0,1]; + my ($refresh, $retry, $expire, $min_ttl) = (split /:/, $val)[0,1,2,3]; + if ($revrec eq 'y') { +##fixme: have to publish SOA records for each v4 /24 in sub-/16, and each /16 in sub-/8 +# what about v6? +# -> only need SOA for local chunks offset from reverse delegation boundaries, so v6 is fine + $zone = NetAddr::IP->new($zone); + # handle split-n-multiply SOA for off-octet (8 < mask < 16) or (16 < mask < 24) v4 zones + if (!$zone->{isv6} && ($zone->masklen < 24) && ($zone->masklen % 8 != 0)) { + foreach my $szone ($zone->split($zone->masklen + (8 - $zone->masklen % 8))) { + $szone = _ZONE($szone, 'ZONE.in-addr.arpa', 'r', '.'); + print $datafile "Z$szone:$primary:$email"."::$refresh:$retry:$expire:$min_ttl:$ttl:$stamp:$loc\n"; + } + return; # skips "default" bits just below + } + $zone = _ZONE($zone, 'ZONE', 'r', '.').($zone->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'); + } + print $datafile "Z$zone:$primary:$email"."::$refresh:$retry:$expire:$min_ttl:$ttl:$stamp:$loc\n"; + + } elsif ($typemap{$type} eq 'A') { + + print $datafile "+$host:$val:$ttl:$stamp:$loc\n"; + + } elsif ($typemap{$type} eq 'NS') { + + if ($revrec eq 'y') { + $val = NetAddr::IP->new($val); + # handle split-n-multiply SOA for off-octet (8 < mask < 16) or (16 < mask < 24) v4 zones + if (!$val->{isv6} && ($val->masklen < 24) && ($val->masklen % 8 != 0)) { + foreach my $szone ($val->split($val->masklen + (8 - $val->masklen % 8))) { + my $szone2 = _ZONE($szone, 'ZONE.in-addr.arpa', 'r', '.'); + next if $$recflags{$szone2} && $$recflags{$szone2} > $val->masklen; + print $datafile "\&$szone2"."::$host:$ttl:$stamp:$loc\n"; + $$recflags{$szone2} = $val->masklen; + } + } elsif ($val->{isv6} && ($val->masklen < 64) && ($val->masklen % 4 !=0)) { + foreach my $szone ($val->split($val->masklen + (4 - $val->masklen % 4))) { + my $szone2 = _ZONE($szone, 'ZONE.ip6.arpa', 'r', '.'); + next if $$recflags{$szone2} && $$recflags{$szone2} > $val->masklen; + print $datafile "\&$szone2"."::$host:$ttl:$stamp:$loc\n"; + $$recflags{$szone2} = $val->masklen; + } + } else { + my $val2 = _ZONE($val, 'ZONE', 'r', '.').($val->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'); + print $datafile "\&$val2"."::$host:$ttl:$stamp:$loc\n"; + $$recflags{$val2} = $val->masklen; + } + } else { + print $datafile "\&$host"."::$val:$ttl:$stamp:$loc\n"; + } + + } elsif ($typemap{$type} eq 'AAAA') { + + print $datafile ":$host:28:"; + my $altgrp = 0; + my @altconv; + # Split in to up to 8 groups of hex digits (allows for IPv6 :: 0-collapsing) + foreach (split /:/, $val) { + if (/^$/) { + # flag blank entry; this is a series of 0's of (currently) unknown length + $altconv[$altgrp++] = 's'; + } else { + # call sub to convert 1-4 hex digits to 2 string-rep octal bytes + $altconv[$altgrp++] = octalize($_) + } + } + foreach my $octet (@altconv) { + # if not 's', output + print $datafile $octet unless $octet =~ /^s$/; + # if 's', output (9-array length)x literal '\000\000' + print $datafile '\000\000'x(9-$altgrp) if $octet =~ /^s$/; + } + print $datafile ":$ttl:$stamp:$loc\n"; + + } elsif ($typemap{$type} eq 'MX') { + + print $datafile "\@$host"."::$val:$dist:$ttl:$stamp:$loc\n"; + + } elsif ($typemap{$type} eq 'TXT') { + +##fixme: split v-e-r-y long TXT strings? will need to do so for BIND export, at least + if ($revrec eq 'n') { + $val =~ s/:/\\072/g; # may need to replace other symbols + print $datafile "'$host:$val:$ttl:$stamp:$loc\n"; + } else { + $host =~ s/:/\\072/g; # may need to replace other symbols + my $val2 = NetAddr::IP->new($val); + print $datafile "'"._ZONE($val2, 'ZONE', 'r', '.').($val2->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'). + ":$host:$ttl:$stamp:$loc\n"; + } + +# by-hand TXT +#:deepnet.cx:16:2v\075spf1\040a\040a\072bacon.deepnet.cx\040a\072home.deepnet.cx\040-all:3600 +#@ IN TXT "v=spf1 a a:bacon.deepnet.cx a:home.deepnet.cx -all" +#'deepnet.cx:v=spf1 a a\072bacon.deepnet.cx a\072home.deepnet.cx -all:3600 + +#txttest IN TXT "v=foo bar:bob kn;ob' \" !@#$%^&*()-=_+[]{}<>?" +#:txttest.deepnet.cx:16:\054v\075foo\040bar\072bob\040kn\073ob\047\040\042\040\041\100\043\044\045\136\046\052\050\051-\075\137\053\133\135\173\175\074\076\077:3600 + +# very long TXT record as brought in by axfr-get +# note tinydns does not support >512-byte RR data, need axfr-dns (for TCP support) for that +# also note, tinydns does not seem to support <512, >256-byte RRdata from axfr-get either. :/ +#:longtxt.deepnet.cx:16: +#\170this is a very long txt record. it is really long. long. very long. really very long. this is a very long txt record. +#\263 it is really long. long. very long. really very long. this is a very long txt record. it is really long. long. very long. really very long. this is a very long txt record. +#\351 it is really long. long. very long. really very long.this is a very long txt record. it is really long. long. very long. really very long. this is a very long txt record. it is really long. long. very long. really very long. +#:3600 + + } elsif ($typemap{$type} eq 'CNAME') { + + if ($revrec eq 'n') { + print $datafile "C$host:$val:$ttl:$stamp:$loc\n"; + } else { + my $val2 = NetAddr::IP->new($val); + print $datafile "C"._ZONE($val2, 'ZONE', 'r', '.').($val2->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'). + ":$host:$ttl:$stamp:$loc\n"; + } + + } elsif ($typemap{$type} eq 'SRV') { + + # data is two-byte values for priority, weight, port, in that order, + # followed by length/string data + + print $datafile ":$host:33:".octalize($dist,'d').octalize($weight,'d').octalize($port,'d'); + + $val .= '.' if $val !~ /\.$/; + foreach (split /\./, $val) { + printf $datafile "\\%0.3o%s", length($_), $_; + } + print $datafile "\\000:$ttl:$stamp:$loc\n"; + + } elsif ($typemap{$type} eq 'RP') { + + # RP consists of two mostly free-form strings. + # The first is supposed to be an email address with @ replaced by . (as with the SOA contact) + # The second is the "hostname" of a TXT record with more info. + print $datafile ":$host:17:"; + my ($who,$what) = split /\s/, $val; + foreach (split /\./, $who) { + printf $datafile "\\%0.3o%s", length($_), $_; + } + print $datafile '\000'; + foreach (split /\./, $what) { + printf $datafile "\\%0.3o%s", length($_), $_; + } + print $datafile "\\000:$ttl:$stamp:$loc\n"; + + } elsif ($typemap{$type} eq 'PTR') { + + $zone = NetAddr::IP->new($zone); + $$recflags{$val}++; + if (!$zone->{isv6} && $zone->masklen > 24) { + ($val) = ($val =~ /\.(\d+)$/); + print $datafile "^$val."._ZONE($zone, 'ZONE', 'r', '.').'.in-addr.arpa'. + ":$host:ttl:$stamp:$loc\n"; + } else { + $val = NetAddr::IP->new($val); + print $datafile "^". + _ZONE($val, 'ZONE', 'r', '.').($val->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'). + ":$host:$ttl:$stamp:$loc\n"; + } + + } elsif ($type == 65280) { # A+PTR + + $$recflags{$val}++; + print $datafile "=$host:$val:$ttl:$stamp:$loc\n"; + + } elsif ($type == 65281) { # AAAA+PTR + + $$recflags{$val}++; + # treat these as two separate records. since tinydns doesn't have + # a native combined type, we have to create them separately anyway. + # print both; a dangling record is harmless, and impossible via web + # UI anyway + _printrec_tiny($datafile,$revrec,$recflags,$zone,$host,28,$val,$dist,$weight,$port,$ttl,$loc,$stamp); + _printrec_tiny($datafile,$revrec,$recflags,$zone,$host,12,$val,$dist,$weight,$port,$ttl,$loc,$stamp); +##fixme: add a config flag to indicate use of the patch from http://www.fefe.de/dns/ +# type 6 is for AAAA+PTR, type 3 is for AAAA + + } elsif ($type == 65282) { # PTR template + + # only useful for v4 with standard DNS software, since this expands all + # IPs in $zone (or possibly $val?) with autogenerated records + $val = NetAddr::IP->new($val); + return if $val->{isv6}; + + if ($val->masklen <= 16) { + foreach my $sub ($val->split(16)) { + __publish_subnet($sub, $recflags, $host, $datafile, $ttl, $stamp, $loc, 1); + } + } else { + __publish_subnet($val, $recflags, $host, $datafile, $ttl, $stamp, $loc, 1); + } + + } elsif ($type == 65283) { # A+PTR template + + $val = NetAddr::IP->new($val); + # Just In Case. An A+PTR should be impossible to add to a v6 revzone via API. + return if $val->{isv6}; + + if ($val->masklen <= 16) { + foreach my $sub ($val->split(16)) { + __publish_subnet($sub, $recflags, $host, $datafile, $ttl, $stamp, $loc, 0); + } + } else { + __publish_subnet($val, $recflags, $host, $datafile, $ttl, $stamp, $loc, 0); + } + + } elsif ($type == 65284) { # AAAA+PTR template + # Stub for completeness. Could be exported to DNS software that supports + # some degree of internal automagic in generic-record-creation + # (eg http://search.cpan.org/dist/AllKnowingDNS/ ) + + } elsif ($type == 65285) { # Delegation + # This is intended for reverse zones, but may prove useful in forward zones. + + # All delegations need to create one or more NS records. The NS record handler knows what to do. + _printrec_tiny($datafile,$revrec,$recflags,$zone,$host,$reverse_typemap{'NS'}, + $val,$dist,$weight,$port,$ttl,$loc,$stamp); + if ($revrec eq 'y') { + # In the case of a sub-/24 v4 reverse delegation, we need to generate CNAMEs + # to redirect all of the individual IP lookups as well. + # Not sure how this would actually resolve if a /24 or larger was delegated + # one way, and a sub-/24 in that >=/24 was delegated elsewhere... + my $dblock = NetAddr::IP->new($val); + if (!$dblock->{isv6} && $dblock->masklen > 24) { + my @subs = $dblock->split; + foreach (@subs) { + next if $$recflags{"$_"}; + my ($oct) = ($_->addr =~ /(\d+)$/); + print $datafile "C"._ZONE($_, 'ZONE.in-addr.arpa', 'r', '.').":$oct.". + _ZONE($dblock, 'ZONE.in-addr.arpa', 'r', '.').":$ttl:$stamp:$loc\n"; + $$recflags{"$_"}++; + } + } + } + +## +## Uncommon types. These will need better UI support Any Day Sometime Maybe(TM). +## + + } elsif ($type == 44) { # SSHFP + my ($algo,$fpt,$fp) = split /\s+/, $val; + + my $rec = sprintf ":$host:44:\\%0.3o\\%0.3o", $algo, $fpt; + while (my ($byte) = ($fp =~ /^(..)/) ) { + $rec .= sprintf "\\%0.3o", hex($byte); + $fp =~ s/^..//; + } + print $datafile "$rec:$ttl:$stamp:$loc\n"; + + } else { + # raw record. we don't know what's in here, so we ASS-U-ME the user has + # put it in correctly, since either the user is messing directly with the + # database, or the record was imported via AXFR + # + # convert anything not a-zA-Z0-9.- to octal coding + +##fixme: add flag to export "unknown" record types - note we'll probably end up +# mangling them since they were written to the DB from Net::DNS::RR::->rdatastr. + #print $datafile ":$host:$type:$val:$ttl:$stamp:$loc\n"; + + } # record type if-else + +} # end _printrec_tiny() + + +## DNSDB::mailNotify() +# Sends notification mail to recipients regarding a DNSDB operation +sub mailNotify { + my $self = shift; + my $dbh = $self->{dbh}; + my ($subj,$message) = @_; + + return if $self->{mailhost} eq 'smtp.example.com'; # do nothing if still using default SMTP host. + + my $mailer = Net::SMTP->new($self->{mailhost}, Hello => "dnsadmin.$self->{domain}"); + + my $mailsender = ($self->{mailsender} ? $self->{mailsender} : $self->{mailnotify}); + + $mailer->mail($mailsender); + $mailer->to($self->{mailnotify}); + $mailer->data("From: \"$self->{mailname}\" <$mailsender>\n", + "To: <$self->{mailnotify}>\n", + "Date: ".strftime("%a, %d %b %Y %H:%M:%S %z",localtime)."\n", + "Subject: $subj\n", + "X-Mailer: DNSAdmin v".$DNSDB::VERSION." Notify\n", + "Organization: $self->{orgname}\n", + "\n$message\n"); + $mailer->quit; +} + +# shut Perl up +1; Index: /tags/1.2/INSTALL =================================================================== --- /tags/1.2/INSTALL (revision 556) +++ /tags/1.2/INSTALL (revision 556) @@ -0,0 +1,97 @@ +$Id$ + +Requirements +============ + +- Any CGI-capable web server that can execute arbitrary files or + files with administrator-defineable extensions +- PostgreSQL >= 7.4. It should be possible to trivially convert to + other DBMSes, however I recommend against any that don't fully + support transactions on all changes. +- Perl >= 5.6 + - Standard modules: + These should be included in any base Perl install + - CGI::Carp + - POSIX + - Text::Wrap - for WHOIS response linewrapping + - Extra modules: + - CGI::Simple + - HTML::Template + - CGI::Session + - Crypt::PasswdMD5 (primary password encryption) + - Digest::MD5 (for imported VegaDNS passwords) + - Net::Whois::Raw + - Net::DNS + - Net::SMTP + - DBI + - DBD::Pg + - NetAddr::IP >= 4.0.27 + - Frontier::Responder (only required if using dns-rpc.cgi) + - FCGI (only required if you want to run the RPC script as FastCGI) +- tinydns - support for other DNS server software is planned + + +Installing DeepNet DNS Administrator +==================================== + +1) Untar in a convenient location. You should be able to simply use the +unpacked tarball as-is, or you can run "make install" to install files +in /usr/local/share/dnsadmin-#VERSION#, with configuration in +/usr/local/etc/dnsdb. + +The Makefile supports substitution on most standard GNU/FHS-ish paths, +so you could also run: + + make install prefix=/opt + +to install it under /opt. + +The Makefile also supports DESTDIR for packaging, so you can use: + + make install datadir=/usr/share sysconfdir=/etc DESTDIR=/tmp/dnsdbpkgroot + +to install for packaging under /tmp/dnsdbpkgroot with the core scripts +and HTML packaged under /usr/share/dnsdb-#VERSION#, and the configuration +packaged under /etc/dnsdb. + +2) Configuration: By default DNS Administrator looks for configuration in +/etc/dnsdb/dnsdb.conf. Edit this file with the database name, user, and +password, and the database host if necessary. + +Setting the options under the "mail" heading is also recommended. + +3) As a Postgres superuser, create a database user and the database (replace +the database name, user and password as appropriate): + +shell> psql template1 +pg# create user dnsdb with password "dnsdbpwd"; +pg# create database dnsdb owner dnsdb; + +Create the inital tables using dns.sql: + +shell> psql -U dnsdb dnsdb $(PKGNAME)-$(VERSION)/$(PKGNAME).spec + /usr/bin/perl -p -e 's/#VERSION#/$(VERSION)/;s/#RELEASE#/$(RELEASE)/;s/#BETA#//g' < INSTALL > $(PKGNAME)-$(VERSION)/INSTALL + perl -pi -e 's/["\d.]+;\s*##VERSION##/"$(VERSION)";/;' $(PKGNAME)-$(VERSION)/DNSDB.pm + tar cf $(PKGNAME)-$(VERSION).tar $(PKGNAME)-$(VERSION) + gzip -v -f -9 $(PKGNAME)-$(VERSION).tar + rm -rf $(PKGNAME)-$(VERSION) + gpg -a --detach-sign $(PKGNAME)-$(VERSION).tar.gz Index: /tags/1.2/TODO =================================================================== --- /tags/1.2/TODO (revision 556) +++ /tags/1.2/TODO (revision 556) @@ -0,0 +1,115 @@ +Things I'd like to make happen + +2009/09/04 + - Retain offset/perpage/sort-order and related info in the session and/or user profile + - need to keep separate record of domain list and record list settings [COMPLETE] + - Support groups (currently group id is hardcoded to 1 anywhere it might be referenced) [COMPLETE] + +2009/09/10 + - Security/hardening + - "if a=1 then elsif a=2 then elsif a=3 then else die neatly" + - work correctly with taint mode + - use SQL execution parameters to reduce quoting screwups + - throw garbage at it and see what sticks + - throw deliberately malformed data and see what sticks + - rDNS matching + - tag'n'warn records where forward and reverse are both supposed to be published + "here" - mainly prevents unneccessary record duplication + +2009/12/10 + - MOTD + - Encapsulate all SQL in DNSDB.pm + +2009/12/15 + - Wrap non-critical bits like Net::Whois::Raw so that they don't just cause a failure, + and the bits that need them are only available if they're installed + +2009/12/16 + - Add record type editor - note, just to edit which types are visible + - Subclass some of the specifics of record handling? + - would let users create plugin code to support arbitrary types + - Push DB name, host, username, password into config file [COMPLETE] + +2009/12/17 + - "complete rewrite" target: one table of objects, one set of functions; hooks + to manipulate "special" data for given types of objects? (even merging + domain/group/user objects would reduce a lot of code almost-duplication) + +2010/04/07 + - Show domain's group in domain record display + +2010/06/24 + - VegaDNS is apparently derived from NicTool (nictool.com), and, of course, has + somewhat fewer features. *sigh* [COMMENT] + +2011/02/17 + - Multi-column sort in record list, possibly domain, group, and user lists too. + This could probably integrate with the previous point; there's a lot of + copy-paste-tweak between the four types of abstract object. + +2011/07/14 + - Warnings: + - non-best-practice SRV record (not _service._class) + - long TXT records (tinyDNS support for TCP DNS responses is limited and often not configured) + - Auto-rDNS on adding A record + +2011/07/18 + - "Move domain to group " [PARTIAL - only for domains, separate "bulk operations" page] + +2011/07/20 + - Replaceable web templates + - Stolen^Wborrowed from Curtis Bruneau's API, sort of): + - Multiple templates per group, including sane default template (integrate with default records; add + "template" column) + - Deep search (eg record content) from high UI layer + - Locations/views + +2011/08/31 + - OOPishness: Once things are converted to put all entities/objects in the same table + (with a single series of IDs to uniquely identify any give entity), create subobjects + for user, group, domain, record, and defrec + +2011/09/09 + - Options to bypass the "do you really want to delete " pages, and Just Do It(TM). + Should increase logging verbosity so it can be more easily undone (er, sorta) + - Steal Vega's active_sessions table? + +2011/09/21 + - (Ab)use DNS RR types in the range 65280 to 65534 ("Reserved for Private Use") + for eg A+PTR, or bulk-rDNS default PTR + +2011/10/07 + - Watch for undefined parameters + - Componentizing: + - Add custid field to domains (and/or groups?) to more easily + allow retrieving a restricted set of domains + - For production use, turn on "no errors on template var doesn't exist" + for HTML::Template + - Config knob to allow loading complete custom templates (fall back to stock ones) + +2011/10/13 + - Catch "delete group with stuff still in it" errors. Or possibly offer a flag to + really "YES DAMMIT I WANT IT ALL GONE" delete all children of a group with stuff in it. + +2011/10/20 + - Add "back to " link in log for domain + - Add subgroup count to group list + - Add log link to users, domains, groups? listings + - Validate A -> \d+\.\d+\.\d+\.\d+, AAAA -> [\da-f:]+ before + feeding to NetAddr:IP; don't want to enter a v6 address on + an A record or vice versa [COMPLETE] + +2011/10/27 + - Add support for converting a bare "@" as the hostname into the domain name a la BIND + - do this on entry, or export? + +2011/11/03 + - Log security violations in a separate log, accessible to a restricted group of users (ie, admin-only) + +2011/11/08 + - Instead of logging failures alongside everything else, only log when a + fail-counter for that action has passed a threshold. Track the fail + count in the session. + +2011/11/10 + TODOs and ideas are now (mostly) in Trac (https://secure.deepnet.cx/trac/dnsadmin) Index: /tags/1.2/UPGRADE =================================================================== --- /tags/1.2/UPGRADE (revision 556) +++ /tags/1.2/UPGRADE (revision 556) @@ -0,0 +1,22 @@ +$Id$ + +DeepNet DNS Administrator - Upgrade Notes +========================================= + +1.0 -> 1.2 + - Make sure your NetAddr::IP version is 4.027 or greater. Older versions + have been found to be missing key methods. + + - FastCGI is now supported for RPC. Install the FCGI module to support + this, and rename or symlink: + + dns-rpc.fcgi -> dns-rpc.cgi + + - Apply the database upgrade script dns-1.0-1.2.sql: + + > psql -U dnsdb dnsdb -h localhost +# +# 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 . +## + +use strict; +use warnings; + +use lib '.'; ##uselib## +use DNSDB; + +usage() if !$ARGV[1]; + +sub usage { + die qq(usage: compact-recs.pl netblock pattern + netblock the CIDR block to define the A+PTR template on + pattern the pattern to define the new A+PTR template with, and + to match A+PTR records within the netblock for deletion + OR + compact-recs.pl --batch patternfile + patternfile should be a file containing a list of netblock-pattern + pairs, whitespace separated + + A PTR template record will be created instead of an A+PTR template + if the forward zone specified in the template is not present in + the database. + + WARNING: Multiple runs will result in duplicate template records. +); +} + +my $dnsdb = new DNSDB or die "Couldn't create DNSDB object: ".$DNSDB::errstr."\n"; +my $dbh = $dnsdb->{dbh}; + +my $code; + +# get userdata for log +($dnsdb->{logusername}, undef, undef, undef, undef, undef, $dnsdb->{logfullname}) = getpwuid($<); +$dnsdb->{loguserid} = 0; # not worth setting up a pseudouser the way the RPC system does +$dnsdb->{logusername} = $dnsdb->{logusername}."/compact-recs.pl"; +$dnsdb->{logfullname} = $dnsdb->{logusername} if !$dnsdb->{logfullname}; + +if ($ARGV[0] eq '--batch') { + open NBLIST, "<$ARGV[1]"; + while () { + next if /^#/; + next if /^\s*$/; + s/^\s*//; + squashem(split(/\s+/)); + } +} else { + my $cidr = new NetAddr::IP $ARGV[0]; + usage() if !$cidr; + squashem($cidr, $ARGV[1]); +} + +exit 0; + + +sub squashem { + my $cidr = shift; + my $patt = shift; + + $dbh->{AutoCommit} = 0; + $dbh->{RaiseError} = 1; + + my ($zone,$ploc) = $dbh->selectrow_array("SELECT rdns_id,default_location FROM revzones WHERE revnet >>= ?", + undef, ($cidr) ); + if (!$zone) { + warn "$cidr is not within a zone currently managed here.\n"; + return; + } + my $soa = $dnsdb->getSOA('n', 'y', $zone); + my $dparent = $dnsdb->_hostparent($patt) || 0; + my $newtype = ($dparent ? 65283 : 65282); + + my ($istmpl) = $dbh->selectrow_array("SELECT count(*) FROM records WHERE rdns_id = ? AND ". + "(type=65282 OR type=65283) AND val = ?", undef, ($zone, $cidr) ); + if ($istmpl) { + print "Template already exists for $cidr, manual cleanup required\n"; + return; + } + + print "Converting PTR and A+PTR records in $cidr matching $patt to single $typemap{$newtype} record\n"; + my $delcnt = 0; + + eval { + my $getsth = $dbh->prepare("SELECT record_id,host,val FROM records ". + "WHERE (type = 12 OR type > 65000) AND CAST(val AS inet) << ?"); + my $delsth = $dbh->prepare("DELETE FROM records WHERE record_id = ?"); + $getsth->execute($cidr); + my $i = 0; + while (my ($id,$host,$val) = $getsth->fetchrow_array) { + my $cmp = $patt; + DNSDB::_template4_expand(\$cmp, $val); + $delsth->execute($id) if $cmp eq $host; + $delcnt++ if $cmp eq $host; +# print "got $id, '$host', '$val'; compare '$cmp'\t"; +# print " delete\n" if $cmp eq $host; +# print " keep\n" if $cmp ne $host; +# last if $i++ >8; + } + + $dbh->do("INSERT INTO records (domain_id, rdns_id, host, type, val, ttl, location) VALUES (?,?,?,?,?,?,?)", + undef, ($dparent, $zone, $patt, $newtype, $cidr, $soa->{minttl}, $ploc) ); + $dbh->do("UPDATE revzones SET changed='y' WHERE rdns_id = ?", undef, ($zone)); + $dbh->do("UPDATE domains SET changed='y' WHERE domain_id = ?", undef, ($dparent)) if $dparent; + $dnsdb->_log(rdns_id => $zone, domain_id => $dparent, group_id => 1, + entry => "A+PTR and/or PTR records in $cidr matching $patt replaced by $typemap{$newtype} record for $cidr"); + +# $dbh->rollback; + $dbh->commit; + }; + if ($@) { + print "barf: $@\n"; + $dbh->rollback; + return; + } + print " complete ($delcnt records)\n"; +} # squashem () Index: /tags/1.2/dns-1.0-1.2.sql =================================================================== --- /tags/1.2/dns-1.0-1.2.sql (revision 556) +++ /tags/1.2/dns-1.0-1.2.sql (revision 556) @@ -0,0 +1,182 @@ +-- SQL table/record type upgrade file for dnsadmin 1.0 to 1.2 migration + +-- need this before we add any other bits +CREATE TABLE locations ( + location character varying (4) PRIMARY KEY, + loc_id serial UNIQUE, + group_id integer NOT NULL DEFAULT 1, + iplist text NOT NULL DEFAULT '', + description character varying(40) NOT NULL DEFAULT '', + comments text NOT NULL DEFAULT '' +); + +ALTER TABLE ONLY locations + ADD CONSTRAINT "locations_group_id_fkey" FOREIGN KEY (group_id) REFERENCES groups(group_id); + +ALTER TABLE permissions ADD COLUMN record_locchg boolean DEFAULT false NOT NULL; +ALTER TABLE permissions ADD COLUMN location_create boolean DEFAULT false NOT NULL; +ALTER TABLE permissions ADD COLUMN location_edit boolean DEFAULT false NOT NULL; +ALTER TABLE permissions ADD COLUMN location_delete boolean DEFAULT false NOT NULL; +ALTER TABLE permissions ADD COLUMN location_view boolean DEFAULT false NOT NULL; + +-- Minor buglet; domains must be unique +-- ALTER TABLE domains ADD PRIMARY KEY (domain); + +CREATE TABLE default_rev_records ( + record_id serial NOT NULL, + group_id integer DEFAULT 1 NOT NULL, + host text DEFAULT '' NOT NULL, + "type" integer DEFAULT 1 NOT NULL, + val text DEFAULT '' NOT NULL, + ttl integer DEFAULT 86400 NOT NULL, + description text +); + +COPY default_rev_records (record_id, group_id, host, "type", val, ttl, description) FROM stdin; +1 1 hostmaster.ADMINDOMAIN:ns1.ADMINDOMAIN 6 3600:900:1048576:2560 3600 +2 1 unused-%r.ADMINDOMAIN 65283 ZONE 3600 +3 1 ns2.example.com 2 ZONE 7200 \N +4 1 ns1.example.com 2 ZONE 7200 \N +\. + +SELECT pg_catalog.setval('default_rev_records_record_id_seq', 4, true); + +ALTER TABLE domains ADD COLUMN changed boolean DEFAULT true NOT NULL; +ALTER TABLE domains ADD COLUMN default_location character varying (4) DEFAULT '' NOT NULL; +-- ~2x performance boost iff most zones are fed to output from the cache +CREATE INDEX dom_status_index ON domains (status); + +CREATE TABLE revzones ( + rdns_id serial NOT NULL, + revnet cidr NOT NULL PRIMARY KEY, + group_id integer DEFAULT 1 NOT NULL, + description character varying(255) DEFAULT ''::character varying NOT NULL, + status integer DEFAULT 1 NOT NULL, + zserial integer, + sertype character(1) DEFAULT 'D'::bpchar, + changed boolean DEFAULT true NOT NULL, + default_location character varying (4) DEFAULT '' NOT NULL +); +CREATE INDEX rev_status_index ON revzones (status); + +ALTER TABLE ONLY revzones + ADD CONSTRAINT "$1" FOREIGN KEY (group_id) REFERENCES groups(group_id); + +ALTER TABLE log ADD COLUMN rdns_id INTEGER; + +-- Since records are now parented by one or both of a forward or reverse zone, +-- we can't enforce FK relations on domain_id (or the new rdns_id) since many +-- records won't have one or the other. +ALTER TABLE records DROP CONSTRAINT "$1"; +ALTER TABLE records ALTER COLUMN domain_id SET DEFAULT 0; +ALTER TABLE records ADD COLUMN rdns_id INTEGER DEFAULT 0 NOT NULL; +ALTER TABLE records ADD COLUMN location character varying (4) DEFAULT '' NOT NULL; +-- Scheduled changes. +ALTER TABLE records ADD COLUMN stamp TIMESTAMP WITH TIME ZONE DEFAULT 'epoch' NOT NULL; +ALTER TABLE records ADD COLUMN expires boolean DEFAULT 'n' NOT NULL; +ALTER TABLE records ADD COLUMN stampactive boolean DEFAULT 'n' NOT NULL; + +-- ~120s -> 75s performance boost on 100K records when always exporting all records +CREATE INDEX rec_types_index ON records (type); +-- Further ~1/3 performance gain, same dataset +CREATE INDEX rec_domain_index ON records (domain_id); +CREATE INDEX rec_revzone_index ON records (rdns_id); + +-- May as well drop and recreate; this is nominally static and loaded from the +-- DB mainly for subset grouping and sorting convenience. Most of the entries +-- have also been updated with new subset grouping and sorting data. +DROP TABLE rectypes; +CREATE TABLE rectypes ( + val integer NOT NULL, + name character varying(20) NOT NULL, + stdflag integer DEFAULT 1 NOT NULL, + listorder integer DEFAULT 255 NOT NULL, + alphaorder integer DEFAULT 32768 NOT NULL +); + +-- Types are required. NB: these are vaguely read-only too +-- data from http://www.iana.org/assignments/dns-parameters +COPY rectypes (val, name, stdflag, listorder, alphaorder) FROM stdin; +1 A 1 1 1 +2 NS 2 10 37 +3 MD 5 255 29 +4 MF 5 255 30 +5 CNAME 2 12 9 +6 SOA 0 0 53 +7 MB 5 255 28 +8 MG 5 255 31 +9 MR 5 255 33 +10 NULL 5 255 43 +11 WKS 5 255 64 +12 PTR 3 5 46 +13 HINFO 5 255 18 +14 MINFO 5 255 32 +15 MX 1 11 34 +16 TXT 2 13 60 +17 RP 4 255 48 +18 AFSDB 5 255 4 +19 X25 5 255 65 +20 ISDN 5 255 21 +21 RT 5 255 50 +22 NSAP 5 255 38 +23 NSAP-PTR 5 255 39 +24 SIG 5 255 51 +25 KEY 5 255 23 +26 PX 5 255 47 +27 GPOS 5 255 17 +28 AAAA 1 3 3 +29 LOC 5 255 25 +30 NXT 5 255 44 +31 EID 5 255 15 +32 NIMLOC 5 255 36 +33 SRV 1 14 55 +34 ATMA 5 255 6 +35 NAPTR 5 255 35 +36 KX 5 255 24 +37 CERT 5 255 8 +38 A6 5 3 2 +39 DNAME 5 255 12 +40 SINK 5 255 52 +41 OPT 5 255 45 +42 APL 5 255 5 +43 DS 5 255 14 +44 SSHFP 5 255 56 +45 IPSECKEY 5 255 20 +46 RRSIG 5 255 49 +47 NSEC 5 255 40 +48 DNSKEY 5 255 13 +49 DHCID 5 255 10 +50 NSEC3 5 255 41 +51 NSEC3PARAM 5 255 42 +55 HIP 5 255 19 +99 SPF 5 255 54 +100 UINFO 5 255 62 +101 UID 5 255 61 +102 GID 5 255 16 +103 UNSPEC 5 255 63 +249 TKEY 5 255 58 +250 TSIG 5 255 59 +251 IXFR 5 255 22 +252 AXFR 5 255 7 +253 MAILB 5 255 27 +254 MAILA 5 255 26 +32768 TA 5 255 57 +32769 DLV 5 255 11 +\. + +-- Custom types (ab)using the "Private use" range from 65280 to 65534 +COPY rectypes (val, name, stdflag, listorder, alphaorder) FROM stdin; +65280 A+PTR 2 2 2 +65281 AAAA+PTR 2 4 4 +65282 PTR template 3 6 2 +65283 A+PTR template 2 7 2 +65284 AAAA+PTR template 2 8 2 +65285 Delegation 2 9 2 +\. + +-- and readd the primary key +ALTER TABLE ONLY rectypes + ADD CONSTRAINT rectypes_pkey PRIMARY KEY (val, name); + +-- Update dbversion +UPDATE misc SET value='1.2' WHERE key='dbversion'; Index: /tags/1.2/dns-rpc.cgi =================================================================== --- /tags/1.2/dns-rpc.cgi (revision 556) +++ /tags/1.2/dns-rpc.cgi (revision 556) @@ -0,0 +1,783 @@ +#!/usr/bin/perl -w -T +# XMLRPC interface to manipulate most DNS DB entities +## +# $Id$ +# Copyright 2012,2013 Kris Deugau +# +# 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 . +## + +use strict; +use warnings; + +# don't remove! required for GNU/FHS-ish install from tarball +use lib '.'; ##uselib## +use DNSDB; + +use FCGI; +#use Frontier::RPC2; +use Frontier::Responder; + +## We need to handle a couple of things globally, rather than pasting the same bit into *every* sub. +## So, let's subclass Frontier::RPC2 + Frontier::Responder, so we can override the single sub in each +## that needs kicking +#### hmm. put this in a separate file? +#package DNSDB::RPC; +#our @ISA = ("Frontier::RPC2", "Frontier::Responder"); +#package main; + +my $dnsdb = DNSDB->new(); + +my $methods = { +#sub getPermissions { +#sub changePermissions { +#sub comparePermissions { +#sub changeGroup { + 'dnsdb.addDomain' => \&addDomain, + 'dnsdb.delZone' => \&delZone, +#sub domainName { +#sub revName { + 'dnsdb.domainID' => \&domainID, +#sub revID { + 'dnsdb.addRDNS' => \&addRDNS, +#sub getZoneCount { +#sub getZoneList { +#sub getZoneLocation { + 'dnsdb.addGroup' => \&addGroup, + 'dnsdb.delGroup' => \&delGroup, +#sub getChildren { +#sub groupName { +#sub getGroupCount { +#sub getGroupList { +#sub groupID { + 'dnsdb.addUser' => \&addUser, +#sub getUserCount { +#sub getUserList { +#sub getUserDropdown { + 'dnsdb.updateUser' => \&updateUser, + 'dnsdb.delUser' => \&delUser, +#sub userFullName { +#sub userStatus { +#sub getUserData { +#sub addLoc { +#sub updateLoc { +#sub delLoc { +#sub getLoc { +#sub getLocCount { +#sub getLocList { + 'dnsdb.getLocDropdown' => \&getLocDropdown, + 'dnsdb.getSOA' => \&getSOA, +#sub updateSOA { + 'dnsdb.getRecLine' => \&getRecLine, + 'dnsdb.getRecList' => \&getRecList, + 'dnsdb.getRecCount' => \&getRecCount, + 'dnsdb.addRec' => \&addRec, + 'dnsdb.updateRec' => \&updateRec, +#sub downconvert { + 'dnsdb.addOrUpdateRevRec' => \&addOrUpdateRevRec, + 'dnsdb.delRec' => \&delRec, + 'dnsdb.delByCIDR' => \&delByCIDR, +#sub getLogCount {} +#sub getLogEntries {} + 'dnsdb.getRevPattern' => \&getRevPattern, + 'dnsdb.getTypelist' => \&getTypelist, + 'dnsdb.getTypemap' => \&getTypemap, + 'dnsdb.getReverse_typemap' => \&getReverse_typemap, +#sub parentID { +#sub isParent { + 'dnsdb.zoneStatus' => \&zoneStatus, + 'dnsdb.getZonesByCIDR' => \&getZonesByCIDR, +#sub importAXFR { +#sub importBIND { +#sub import_tinydns { +#sub export { +#sub mailNotify { + + 'dnsdb.getMethods' => \&get_method_list +}; + +my $reqcnt = 0; + +while (FCGI::accept >= 0) { + my $res = Frontier::Responder->new( + methods => $methods + ); + + # "Can't do that" errors + if (!$dnsdb) { + print "Content-type: text/xml\n\n".$res->{_decode}->encode_fault(5, $dnsdb->err); + } else { + print $res->answer; + } + last if $reqcnt++ > $dnsdb->{maxfcgi}; +} # while FCGI::accept + + +exit; + +## +## Subs below here +## + +# Check RPC ACL +sub _aclcheck { + my $subsys = shift; + return 1 if grep /$ENV{REMOTE_ADDR}/, @{$dnsdb->{rpcacl}{$subsys}}; + warn "$subsys/$ENV{REMOTE_ADDR} not in ACL\n"; # a bit of logging + return 0; +} + +# Let's see if we can factor these out of the RPC method subs +sub _commoncheck { + my $argref = shift; + my $needslog = shift; + + die "Missing remote system name\n" if !$argref->{rpcsystem}; + die "Access denied\n" if !_aclcheck($argref->{rpcsystem}); + if ($needslog) { + die "Missing remote username\n" if !$argref->{rpcuser}; + die "Couldn't set userdata for logging\n" + unless $dnsdb->initRPC(username => $argref->{rpcuser}, rpcsys => $argref->{rpcsystem}, + fullname => ($argref->{fullname} ? $argref->{fullname} : $argref->{rpcuser}) ); + } +} + +# check for defrec and revrec; only call on subs that deal with records +sub _reccheck { + my $argref = shift; + die "Missing defrec and/or revrec flags\n" if !($argref->{defrec} || $argref->{revrec}); +} + +# set location to the zone's default location if none is specified +sub _loccheck { + my $argref = shift; + if (!$argref->{location} && $argref->{defrec} eq 'n') { + $argref->{location} = $dnsdb->getZoneLocation($argref->{revrec}, $argref->{parent_id}); + } +} + +# set ttl to zone defailt minttl if none is specified +sub _ttlcheck { + my $argref = shift; + if (!$argref->{ttl}) { + my $tmp = $dnsdb->getSOA($argref->{defrec}, $argref->{revrec}, $argref->{parent_id}); + $argref->{ttl} = $tmp->{minttl}; + } +} + +#sub connectDB { +#sub finish { +#sub initGlobals { +#sub initPermissions { +#sub getPermissions { +#sub changePermissions { +#sub comparePermissions { +#sub changeGroup { +#sub _log { + +sub addDomain { + my %args = @_; + + _commoncheck(\%args, 'y'); + + my ($code, $msg) = $dnsdb->addDomain($args{domain}, $args{group}, $args{state}, $args{location}); + die "$msg\n" if $code eq 'FAIL'; + return $msg; # domain ID +} + +sub delZone { + my %args = @_; + + _commoncheck(\%args, 'y'); + die "Need forward/reverse zone flag\n" if !$args{revrec}; + + my ($code,$msg); + # Let's be nice; delete based on zone id OR zone name. Saves an RPC call round-trip, maybe. + if ($args{zone} =~ /^\d+$/) { + ($code,$msg) = $dnsdb->delZone($args{zone}, $args{revrec}); + } else { + my $zoneid; + $zoneid = $dnsdb->domainID($args{zone}) if $args{revrec} eq 'n'; + $zoneid = $dnsdb->revID($args{zone}) if $args{revrec} eq 'y'; + die "Can't find zone: $dnsdb->errstr\n" if !$zoneid; + ($code,$msg) = $dnsdb->delZone($zoneid, $args{revrec}); + } + die "$msg\n" if $code eq 'FAIL'; + return $msg; +} + +#sub domainName {} +#sub revName {} + +sub domainID { + my %args = @_; + + _commoncheck(\%args, 'y'); + + my $domid = $dnsdb->domainID($args{domain}); + die "$dnsdb->errstr\n" if !$domid; + return $domid; +} + +#sub revID {} + +sub addRDNS { + my %args = @_; + + _commoncheck(\%args, 'y'); + + my ($code, $msg) = $dnsdb->addRDNS($args{revzone}, $args{revpatt}, $args{group}, $args{state}, $args{defloc}); + die "$msg\n" if $code eq 'FAIL'; + return $msg; # domain ID +} + +#sub getZoneCount {} +#sub getZoneList {} +#sub getZoneLocation {} + +sub addGroup { + my %args = @_; + + _commoncheck(\%args, 'y'); + die "Missing new group name\n" if !$args{groupname}; + die "Missing parent group ID\n" if !$args{parent_id}; + +# not sure how to usefully represent permissions via RPC. :/ +# not to mention, permissions are checked at the UI layer, not the DB layer. + my $perms = {domain_edit => 1, domain_create => 1, domain_delete => 1, + record_edit => 1, record_create => 1, record_delete => 1 + }; +## optional $inhert arg? + my ($code,$msg) = $dnsdb->addGroup($args{groupname}, $args{parent_id}, $perms); + die "$msg\n" if $code eq 'FAIL'; + return $msg; +} + +sub delGroup { + my %args = @_; + + _commoncheck(\%args, 'y'); + die "Missing group ID or name to remove\n" if !$args{group}; + + my ($code,$msg); + # Let's be nice; delete based on groupid OR group name. Saves an RPC call round-trip, maybe. + if ($args{group} =~ /^\d+$/) { + ($code,$msg) = $dnsdb->delGroup($args{group}); + } else { + my $grpid = $dnsdb->groupID($args{group}); + die "Can't find group\n" if !$grpid; + ($code,$msg) = $dnsdb->delGroup($grpid); + } + die "$msg\n" if $code eq 'FAIL'; + return $msg; +} + +#sub getChildren {} +#sub groupName {} +#sub getGroupCount {} +#sub getGroupList {} +#sub groupID {} + +sub addUser { + my %args = @_; + + _commoncheck(\%args, 'y'); + +# not sure how to usefully represent permissions via RPC. :/ +# not to mention, permissions are checked at the UI layer, not the DB layer. + # bend and twist; get those arguments in in the right order! + $args{type} = 'u' if !$args{type}; + $args{permstring} = 'i' if !defined($args{permstring}); + my @userargs = ($args{username}, $args{group}, $args{pass}, $args{state}, $args{type}, $args{permstring}); + for my $argname ('fname','lname','phone') { + last if !$args{$argname}; + push @userargs, $args{$argname}; + } + my ($code,$msg) = $dnsdb->addUser(@userargs); + die "$msg\n" if $code eq 'FAIL'; + return $msg; +} + +#sub getUserCount {} +#sub getUserList {} +#sub getUserDropdown {} +#sub checkUser {} + +sub updateUser { + my %args = @_; + + _commoncheck(\%args, 'y'); + + die "Missing UID\n" if !$args{uid}; + + # bend and twist; get those arguments in in the right order! + $args{type} = 'u' if !$args{type}; + my @userargs = ($args{uid}, $args{username}, $args{group}, $args{pass}, $args{state}, $args{type}); + for my $argname ('fname','lname','phone') { + last if !$args{$argname}; + push @userargs, $args{$argname}; + } +##fixme: also underlying in DNSDB::updateUser(): no way to just update this or that attribute; +# have to pass them all in to be overwritten + my ($code,$msg) = $dnsdb->updateUser(@userargs); + die "$msg\n" if $code eq 'FAIL'; + return $msg; +} + +sub delUser { + my %args = @_; + + _commoncheck(\%args, 'y'); + + die "Missing UID\n" if !$args{uid}; + my ($code,$msg) = $dnsdb->delUser($args{uid}); + die "$msg\n" if $code eq 'FAIL'; + return $msg; +} + +#sub userFullName {} +#sub userStatus {} +#sub getUserData {} + +#sub addLoc {} +#sub updateLoc {} +#sub delLoc {} +#sub getLoc {} +#sub getLocCount {} +#sub getLocList {} + +sub getLocDropdown { + my %args = @_; + + _commoncheck(\%args); + $args{defloc} = '' if !$args{defloc}; + + my $ret = $dnsdb->getLocDropdown($args{group}, $args{defloc}); + return $ret; +} + +sub getSOA { + my %args = @_; + + _commoncheck(\%args); + + _reccheck(\%args); + + my $ret = $dnsdb->getSOA($args{defrec}, $args{revrec}, $args{id}); + if (!$ret) { + if ($args{defrec} eq 'y') { + die "No default SOA record in group\n"; + } else { + die "No SOA record in zone\n"; + } + } + return $ret; +} + +#sub updateSOA {} + +sub getRecLine { + my %args = @_; + + _commoncheck(\%args); + + _reccheck(\%args); + + my $ret = $dnsdb->getRecLine($args{defrec}, $args{revrec}, $args{id}); + + die "$dnsdb->errstr\n" if !$ret; + + return $ret; +} + +sub getRecList { + my %args = @_; + + _commoncheck(\%args); + + # deal gracefully with alternate calling convention for args{id} + $args{id} = $args{ID} if !$args{id} && $args{ID}; + # ... and fail if we don't have one + die "Missing zone ID\n" if !$args{id}; + + # set some optional args + $args{offset} = 0 if !$args{offset}; +## for order, need to map input to column names + $args{order} = 'host' if !$args{order}; + $args{direction} = 'ASC' if !$args{direction}; + $args{defrec} = 'n' if !$args{defrec}; + $args{revrec} = 'n' if !$args{revrec}; + + # convert zone name to zone ID, if needed + if ($args{defrec} eq 'n') { + if ($args{revrec} eq 'n') { + $args{id} = $dnsdb->domainID($args{id}) if $args{id} !~ /^\d+$/; + } else { + $args{id} = $dnsdb->revID($args{id}) if $args{id} !~ /^\d+$/ + } + } + + # fail if we *still* don't have a valid zone ID + die "$dnsdb->errstr\n" if !$args{id}; + + # and finally retrieve the records. + my $ret = $dnsdb->getRecList(defrec => $args{defrec}, revrec => $args{revrec}, id => $args{id}, + offset => $args{offset}, nrecs => $args{nrecs}, sortby => $args{sortby}, + sortorder => $args{sortorder}, filter => $args{filter}); + die "$dnsdb->errstr\n" if !$ret; + + return $ret; +} + +sub getRecCount { + my %args = @_; + + _commoncheck(\%args); + + _reccheck(\%args); + + # set some optional args + $args{nrecs} = 'all' if !$args{nrecs}; + $args{nstart} = 0 if !$args{nstart}; +## for order, need to map input to column names + $args{order} = 'host' if !$args{order}; + $args{direction} = 'ASC' if !$args{direction}; + + my $ret = $dnsdb->getRecCount($args{defrec}, $args{revrec}, $args{id}, $args{filter}); + + die "$dnsdb->errstr\n" if !$ret; + + return $ret; +} + +sub addRec { + my %args = @_; + + _commoncheck(\%args, 'y'); + + _reccheck(\%args); + _loccheck(\%args); + _ttlcheck(\%args); + + # allow passing text types rather than DNS integer IDs + $args{type} = $DNSDB::reverse_typemap{$args{type}} if $args{type} !~ /^\d+$/; + + my @recargs = ($args{defrec}, $args{revrec}, $args{parent_id}, + \$args{name}, \$args{type}, \$args{address}, $args{ttl}, $args{location}, + $args{expires}, $args{stamp}); + if ($args{type} == $DNSDB::reverse_typemap{MX} or $args{type} == $DNSDB::reverse_typemap{SRV}) { + push @recargs, $args{distance}; + if ($args{type} == $DNSDB::reverse_typemap{SRV}) { + push @recargs, $args{weight}; + push @recargs, $args{port}; + } + } + + my ($code, $msg) = $dnsdb->addRec(@recargs); + + die "$msg\n" if $code eq 'FAIL'; + return $msg; +} + +sub updateRec { + my %args = @_; + + _commoncheck(\%args, 'y'); + + _reccheck(\%args); + + # put some caller-friendly names in their rightful DB column places + $args{val} = $args{address}; + $args{host} = $args{name}; + + # get old line, so we can update only the bits that the caller passed to change + my $oldrec = $dnsdb->getRecLine($args{defrec}, $args{revrec}, $args{id}); + foreach my $field (qw(host type val ttl location expires distance weight port)) { + $args{$field} = $oldrec->{$field} if !$args{$field} && defined($oldrec->{$field}); + } + # stamp has special handling when blank or 0. "undefined" from the caller should mean "don't change" + $args{stamp} = $oldrec->{stamp} if !defined($args{stamp}) && defined($oldrec->{stamp}); + + # allow passing text types rather than DNS integer IDs + $args{type} = $DNSDB::reverse_typemap{$args{type}} if $args{type} !~ /^\d+$/; + + # note dist, weight, port are not required on all types; will be ignored if not needed. + # parent_id is the "primary" zone we're updating; necessary for forward/reverse voodoo + my ($code, $msg) = $dnsdb->updateRec($args{defrec}, $args{revrec}, $args{id}, $args{parent_id}, + \$args{host}, \$args{type}, \$args{val}, $args{ttl}, $args{location}, + $args{expires}, $args{stamp}, + $args{distance}, $args{weight}, $args{port}); + + die "$msg\n" if $code eq 'FAIL'; + return $msg; +} + +# Takes a passed CIDR block and DNS pattern; adds a new record or updates the record(s) affected +sub addOrUpdateRevRec { + my %args = @_; + + _commoncheck(\%args, 'y'); + my $cidr = new NetAddr::IP $args{cidr}; + + my $zonelist = $dnsdb->getZonesByCIDR(%args); + if (scalar(@$zonelist) == 0) { + # enhh.... WTF? + } elsif (scalar(@$zonelist) == 1) { + # check if the single zone returned is bigger than the CIDR. if so, we can just add a record + my $zone = new NetAddr::IP $zonelist->[0]->{revnet}; + if ($zone->contains($cidr)) { + # We need to strip the CIDR mask on IPv4 /32 assignments, or we just add a new record all the time. + my $filt = ($cidr->{isv6} || $cidr->masklen != 32 ? "$cidr" : $cidr->addr); + my $reclist = $dnsdb->getRecList(defrec => 'n', revrec => 'y', + id => $zonelist->[0]->{rdns_id}, filter => $filt); + if (scalar(@$reclist) == 0) { + # Aren't Magic Numbers Fun? See pseudotype list in dnsadmin. + my $type = ($cidr->{isv6} ? 65284 : ($cidr->masklen == 32 ? 65280 : 65283) ); + addRec(defrec =>'n', revrec => 'y', parent_id => $zonelist->[0]->{rdns_id}, type => $type, + address => "$cidr", %args); + } else { + my $flag = 0; + foreach my $rec (@$reclist) { + # pure PTR plus composite types + next unless $rec->{type} == 12 || $rec->{type} == 65280 || $rec->{type} == 65281 + || $rec->{type} == 65282 || $rec->{type} == 65283 || $rec->{type} == 65284; + next unless $rec->{val} eq $filt; # make sure we really update the record we want to update. + $dnsdb->updateRec(defrec =>'n', revrec => 'y', id => $rec->{record_id}, + parent_id => $zonelist->[0]->{rdns_id}, %args); + $flag = 1; + last; # only do one record. + } + unless ($flag) { + # Nothing was updated, so we didn't really have a match. Add as per @$reclist==0 + # Aren't Magic Numbers Fun? See pseudotype list in dnsadmin. + my $type = ($cidr->{isv6} ? 65282 : ($cidr->masklen == 32 ? 65280 : 65283) ); + $dnsdb->addRec(defrec =>'n', revrec => 'y', parent_id => $zonelist->[0]->{rdns_id}, type => $type, + address => "$cidr", %args); + } + } + } else { + # ebbeh? CIDR is only partly represented in DNS. This needs manual intervention. + } # done single-zone-contains-$cidr + } else { + # Overlapping reverse zones shouldn't be possible, so if we're here we've got a CIDR + # that spans multiple reverse zones (eg, /23 CIDR -> 2 /24 rzones) + foreach my $zdata (@$zonelist) { + my $reclist = $dnsdb->getRecList(defrec => 'n', revrec => 'y', + id => $zdata->{rdns_id}, filter => $zdata->{revnet}); + if (scalar(@$reclist) == 0) { + my $type = ($args{cidr}->{isv6} ? 65282 : ($args{cidr}->masklen == 32 ? 65280 : 65283) ); + $dnsdb->addRec(defrec =>'n', revrec => 'y', parent_id => $zdata->{rdns_id}, type => $type, + address => "$args{cidr}", %args); + } else { + foreach my $rec (@$reclist) { + # only the composite and/or template types; pure PTR or nontemplate composite + # types are nominally impossible here. + next unless $rec->{type} == 65282 || $rec->{type} == 65283 || $rec->{type} == 65284; + $dnsdb->updateRec(defrec =>'n', revrec => 'y', id => $rec->{record_id}, + parent_id => $zdata->{rdns_id}, %args); + last; # only do one record. + } + } + } # iterate zones within $cidr + } # done $cidr-contains-zones +} + +sub delRec { + my %args = @_; + + _commoncheck(\%args, 'y'); + + _reccheck(\%args); + + my ($code, $msg) = $dnsdb->delRec($args{defrec}, $args{recrev}, $args{id}); + + die "$msg\n" if $code eq 'FAIL'; + return $msg; +} + +sub delByCIDR { + my %args = @_; + + _commoncheck(\%args, 'y'); + + # much like addOrUpdateRevRec() + my $zonelist = $dnsdb->getZonesByCIDR(%args); + my $cidr = new NetAddr::IP $args{cidr}; + + if (scalar(@$zonelist) == 0) { + # enhh.... WTF? + } elsif (scalar(@$zonelist) == 1) { + + # check if the single zone returned is bigger than the CIDR + my $zone = new NetAddr::IP $zonelist->[0]->{revnet}; + if ($zone->contains($cidr)) { + + if ($args{delsubs}) { + # Delete ALL EVARYTHING!!one11!! in $args{cidr} + my $reclist = $dnsdb->getRecList(defrec => 'n', revrec => 'y', id => $zonelist->[0]->{rdns_id}); + foreach my $rec (@$reclist) { + my $reccidr = new NetAddr::IP $rec->{val}; + next unless $cidr->contains($reccidr); + next unless $rec->{type} == 12 || $rec->{type} == 65280 || $rec->{type} == 65281 || + $rec->{type} == 65282 || $rec->{type} == 65283 ||$rec->{type} == 65284; + ##fixme: multiple records, wanna wax'em all, how to report errors? + if ($args{delforward} || + $rec->{type} == 12 || $rec->{type} == 65282 || + $rec->{type} == 65283 || $rec->{type} == 65284) { + my ($code,$msg) = $dnsdb->delRec('n', 'y', $rec->{record_id}); + } else { + my $ret = $dnsdb->downconvert($rec->{record_id}, $DNSDB::reverse_typemap{A}); + } + } + if ($args{parpatt} && $zone == $cidr) { + # Edge case; we've just gone and axed all the records in the reverse zone. + # Re-add one to match the parent if we've been given a pattern to use. + $dnsdb->addRec(defrec =>'n', revrec => 'y', parent_id => $zonelist->[0]->{rdns_id}, + type => ($zone->{isv6} ? 65284 : 65283), address => "$cidr", %args); + } + + } else { + # Selectively delete only exact matches on $args{cidr} + + # We need to strip the CIDR mask on IPv4 /32 assignments, or we can't find single-IP records + my $filt = ($cidr->{isv6} || $cidr->masklen != 32 ? "$cidr" : $cidr->addr); + my $reclist = $dnsdb->getRecList(defrec => 'n', revrec => 'y', + id => $zonelist->[0]->{rdns_id}, filter => $filt, sortby => 'val', sortorder => 'DESC'); + foreach my $rec (@$reclist) { + my $reccidr = new NetAddr::IP $rec->{val}; + next unless $cidr == $reccidr; + next unless $rec->{type} == 12 || $rec->{type} == 65280 || $rec->{type} == 65281 || + $rec->{type} == 65282 || $rec->{type} == 65283 ||$rec->{type} == 65284; + if ($args{delforward} || $rec->{type} == 12) { + my ($code,$msg) = $dnsdb->delRec('n', 'y', $rec->{record_id}); + die "$msg\n" if $code eq 'FAIL'; + return $msg; + } else { + my $ret = $dnsdb->downconvert($rec->{record_id}, $DNSDB::reverse_typemap{A}); + die "$dnsdb->errstr\n" if !$ret; + return "A+PTR for $args{cidr} split and PTR removed"; + } + } # foreach @$reclist + } + + } else { # $cidr > $zone but we only have one zone + # ebbeh? CIDR is only partly represented in DNS. This needs manual intervention. + return "Warning: $args{cidr} is only partly represented in DNS. Check and remove DNS records manually."; + } # done single-zone-contains-$cidr + + } else { # multiple zones nominally "contain" $cidr + # Overlapping reverse zones shouldn't be possible, so if we're here we've got a CIDR + # that spans multiple reverse zones (eg, /23 CIDR -> 2 /24 rzones) + foreach my $zdata (@$zonelist) { + my $reclist = $dnsdb->getRecList(defrec => 'n', revrec => 'y', id => $zdata->{rdns_id}); + if (scalar(@$reclist) == 0) { +# nothing to do? or do we (re)add a record based on the parent? +# yes, yes we do, past the close of the else +# my $type = ($args{cidr}->{isv6} ? 65282 : ($args{cidr}->masklen == 32 ? 65280 : 65283) ); +# addRec(defrec =>'n', revrec => 'y', parent_id => $zdata->{rdns_id}, type => $type, +# address => "$args{cidr}", %args); + } else { + foreach my $rec (@$reclist) { + next unless $rec->{type} == 12 || $rec->{type} == 65280 || $rec->{type} == 65281 || + $rec->{type} == 65282 || $rec->{type} == 65283 || $rec->{type} == 65284; + # Template types are only useful when attached to a reverse zone. +##fixme ..... or ARE THEY? + if ($args{delforward} || + $rec->{type} == 12 || $rec->{type} == 65282 || + $rec->{type} == 65283 || $rec->{type} == 65284) { + my ($code,$msg) = $dnsdb->delRec('n', 'y', $rec->{record_id}); + } else { + my $ret = $dnsdb->downconvert($rec->{record_id}, $DNSDB::reverse_typemap{A}); + } + } # foreach @$reclist + } # nrecs != 0 + if ($args{parpatt}) { + # We've just gone and axed all the records in the reverse zone. + # Re-add one to match the parent if we've been given a pattern to use. + $dnsdb->addRec(defrec =>'n', revrec => 'y', parent_id => $zdata->{rdns_id}, + type => ($cidr->{isv6} ? 65284 : 65283), + address => $zdata->{revnet}, name => $args{parpatt}, %args); + } + } # iterate zones within $cidr + } # done $cidr-contains-zones + +} # end delByCIDR() + +#sub getLogCount {} +#sub getLogEntries {} + +sub getRevPattern { + my %args = @_; + + _commoncheck(\%args, 'y'); + + return $dnsdb->getRevPattern($args{cidr}, $args{group}); +} + +sub getTypelist { + my %args = @_; + _commoncheck(\%args, 'y'); + + $args{selected} = $reverse_typemap{A} if !$args{selected}; + + return $dnsdb->getTypelist($args{recgroup}, $args{selected}); +} + +sub getTypemap { + my %args = @_; + _commoncheck(\%args, 'y'); + return \%typemap; +} + +sub getReverse_typemap { + my %args = @_; + _commoncheck(\%args, 'y'); + return \%reverse_typemap; +} + +#sub parentID {} +#sub isParent {} + +sub zoneStatus { + my %args = @_; + + _commoncheck(\%args, 'y'); + + my @arglist = ($args{zoneid}); + push @arglist, $args{status} if defined($args{status}); + + my $status = $dnsdb->zoneStatus(@arglist); +} + +# Get a list of hashes referencing the reverse zone(s) for a passed CIDR block +sub getZonesByCIDR { + my %args = @_; + + _commoncheck(\%args, 'y'); + + return $dnsdb->getZonesByCIDR(%args); +} + +#sub importAXFR {} +#sub importBIND {} +#sub import_tinydns {} +#sub export {} +#sub __export_tiny {} +#sub _printrec_tiny {} +#sub mailNotify {} + +sub get_method_list { + my @methods = keys %{$methods}; + return \@methods; +} Index: /tags/1.2/dns.cgi =================================================================== --- /tags/1.2/dns.cgi (revision 556) +++ /tags/1.2/dns.cgi (revision 556) @@ -0,0 +1,2447 @@ +#!/usr/bin/perl -w -T +# Main web UI script for DeepNet DNS Administrator +## +# $Id$ +# Copyright 2008-2013 Kris Deugau +# +# 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 . +## + +use strict; +use warnings; + +use CGI::Carp qw (fatalsToBrowser); +use CGI::Simple; +use HTML::Template; +use CGI::Session; +use Crypt::PasswdMD5; +use Digest::MD5 qw(md5_hex); +use Net::DNS; +use DBI; + +use Data::Dumper; + +#sub is_tainted { +# # from perldoc perlsec +# return ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 }; +#} +#use Cwd 'abs_path'; +#use File::Basename; +#use lib dirname( abs_path $0 ); +#die "argh! tainted!" if is_tainted($0); +#die "argh! \@INC got tainted!" if is_tainted(@INC); + +# don't remove! required for GNU/FHS-ish install from tarball +use lib '.'; ##uselib## + +use DNSDB; + +my @debugbits; # temp, to be spit out near the end of processing +my $debugenv = 0; + +# Let's do these templates right... +my $templatedir = "templates"; + +# Set up the CGI object... +my $q = new CGI::Simple; +# ... and get query-string params as well as POST params if necessary +$q->parse_query_string; + +# This is probably excessive fiddling, but it puts the parameters somewhere my fingers know about... +my %webvar = $q->Vars; + +# shut up some warnings, in case we arrive somewhere we forgot to set this +$webvar{defrec} = 'n' if !$webvar{defrec}; # non-default records +$webvar{revrec} = 'n' if !$webvar{revrec}; # non-reverse (domain) records + +# create a DNSDB object. this loads some local system defaults and connects to the DB +# with the credentials configured +##fixme: pass params for loadConfig, and use them there, to allow one codebase to support multiple sites +my $dnsdb = new DNSDB; + +my $header = HTML::Template->new(filename => "$templatedir/header.tmpl"); +my $footer = HTML::Template->new(filename => "$templatedir/footer.tmpl"); +$footer->param(version => $DNSDB::VERSION); + +##fixme: slim chance this could be triggered on errors other than DB failure? +if (!$dnsdb) { + print "Content-type: text/html\n\n"; + print $header->output; + my $errpage = HTML::Template->new(filename => "$templatedir/dberr.tmpl"); + $errpage->param(errmsg => $DNSDB::errstr); + print $errpage->output; + print $footer->output; + exit; +} + +$header->param(orgname => $dnsdb->{orgname}) if $dnsdb->{orgname} ne 'Example Corp'; + +my $logingroup; +my $curgroup; +my @viewablegroups; + +# retrieve the session ID from our cookie, if possible +my $sid = $q->cookie('dnsadmin_session'); + +# see if the session loads +my $session = CGI::Session->load("driver:File", $sid, {Directory => $dnsdb->{sessiondir}}) + or die CGI::Session->errstr(); + +if (!$sid || $session->is_expired) { + $webvar{page} = 'login'; +} else { + # we have a session to load from, maybe + $logingroup = ($session->param('logingroup') ? $session->param('logingroup') : 1); + $curgroup = ($session->param('curgroup') ? $session->param('curgroup') : $logingroup); + # security check - does the user have permission to view this entity? + # this is a prep step used "many" places + $dnsdb->getChildren($logingroup, \@viewablegroups, 'all'); + push @viewablegroups, $logingroup; +##fixme: make sessions persist through closing the site? +# this even bridges browser close too. hmm... + $webvar{page} = 'domlist' if !$webvar{page}; +} + +# set $webvar{page} before we try to use it. +$webvar{page} = 'login' if !$webvar{page}; + +## per-page startwith, filter, searchsubs + +##fixme: complain-munge-and-continue with non-"[a-z0-9-.]" filter and startwith +$webvar{startwith} =~ s/^(0-9|[a-z]).*/$1/ if $webvar{startwith}; +# not much call for chars not allowed in domain names +$webvar{filter} =~ s/[^a-zA-Z0-9_.:\@-]//g if $webvar{filter}; +## only set 'y' if box is checked, no other values legal +## however, see https://secure.deepnet.cx/trac/dnsadmin/ticket/31 +# first, drop obvious fakes +delete $webvar{searchsubs} if $webvar{searchsubs} && $webvar{searchsubs} !~ /^[ny]/; +# strip the known "turn me off!" bit. +$webvar{searchsubs} =~ s/^n\s?// if $webvar{searchsubs}; +# strip non-y/n - note this legitimately allows {searchsubs} to go empty +$webvar{searchsubs} =~ s/[^yn]//g if $webvar{searchsubs}; + +# pagination +my $perpage = 15; # Just In Case +$perpage = $dnsdb->{perpage} if $dnsdb->{perpage}; +my $offset = ($webvar{offset} ? $webvar{offset} : 0); + +## set up "URL to self" (whereami edition) +# @#$%@%@#% XHTML - & in a URL must be escaped. >:( +my $uri_self = $ENV{REQUEST_URI}; +$uri_self =~ s/\&([a-z])/\&\;$1/g; + +# le sigh. and we need to strip any previous action +$uri_self =~ s/\&action=[^&]+//g; + +# much magic happens. if startwith or a search string change (to, from, or +# across, in the request vs whatever's in the session) then the offset should +# be reset to 0 so that the first/prev/next/last widget populates correctly, +# and so that the list of whatever we're looking at actually shows things +# (since we may have started on page 42 of 300 with a LOOOOONG list, but we +# now only need 3 pages for the filtered list). +# while we're at it, plonk these into the session for safekeeping. +if (defined($webvar{startwith})) { + if ($webvar{startwith} ne $session->param($webvar{page}.'startwith')) { + $uri_self =~ s/\&offset=[^&]//; + $offset = 0; + } + $session->param($webvar{page}.'startwith', $webvar{startwith}); +} +if (defined($webvar{filter})) { + if ($webvar{filter} ne $session->param($webvar{page}.'filter')) { + $uri_self =~ s/\&offset=[^&]//; + $offset = 0; + } + $session->param($webvar{page}.'filter', $webvar{filter}) +} +$session->param($webvar{page}.'searchsubs', $webvar{searchsubs}) if defined($webvar{searchsubs}); + +# and now that the search/filter criteria for this page are set, put them in some globals for actual use. +my $startwith = $session->param($webvar{page}.'startwith'); +my $filter = $session->param($webvar{page}.'filter'); +my $searchsubs = $session->param($webvar{page}.'searchsubs'); + +# ... and assemble the args +my @filterargs; +push @filterargs, "^[$startwith]" if $startwith; +push @filterargs, $filter if $filter; + +# and search filter options. these get stored in the session, but discarded +# as soon as you switch to a different page. +##fixme: think about retaining these on a per-page basis, as well as offset; same as the sort-order bits +no warnings qw(uninitialized); +$uri_self =~ s/\&startwith=[a-z09-]*(\&)?/$1/g; +$uri_self =~ s/\&searchsubs=[a-z09-]*(\&)?/$1/g; +$uri_self =~ s/\&filter=[a-z09-]*(\&)?/$1/g; +use warnings qw(uninitialized); + +# Fix up $uri_self so we don't lose the session/page +$uri_self .= "?page=$webvar{page}" if $uri_self =~ m{/dns.cgi$}; +$uri_self = "$ENV{SCRIPT_NAME}?page=$webvar{page}$1" if $uri_self =~ m{/dns.cgi\&(.+)$}; + +## end uri_self monkeying + +# NB: these must match the field name and SQL ascend/descend syntax respectively +# sortby is reset to a suitable "default", then re-reset to whatever the user has +# clicked on last in the record=listing subs, but best to put a default here. +my $sortby = "domain"; +my $sortorder = "ASC"; + +# Create the page template object. Display a reasonable error page and whine if the template doesn't exist. +my $page; +eval { + # sigh. can't set loop_context_vars or global_vars once instantiated. + $page = HTML::Template->new(filename => "$templatedir/$webvar{page}.tmpl", + loop_context_vars => 1, global_vars => 1); +}; +if ($@) { + my $msg = $@; + $page = HTML::Template->new(filename => "$templatedir/badpage.tmpl"); + if (-e "$templatedir/$webvar{page}.tmpl") { + $page->param(badtemplate => $q->escapeHTML($msg)); + } else { + warn "Bad page $webvar{page} requested"; + $page->param(badpage => $q->escapeHTML($webvar{page})); + } + $webvar{page} = 'badpage'; +} + +$session->expire($dnsdb->{timeout}); +my $sesscookie = $q->cookie( -name => 'dnsadmin_session', + -value => $sid, +# -expires => "+".$dnsdb->{timeout}, + -secure => 0, +## fixme: need to extract root path for cookie, so as to limit cookie to dnsadmin instance +# -path => $url + ); + +# handle can-happen-on-(almost)-any-page actions +if ($webvar{action}) { + + if ($webvar{action} eq 'login') { + # Snag ACL/permissions here too + + my $userdata = $dnsdb->login($webvar{username}, $webvar{password}); + + if ($userdata) { + + # (re)create the session + $session = new CGI::Session("driver:File", $sid, {Directory => $dnsdb->{sessiondir}}) + or die CGI::Session->errstr(); + $sid = $session->id(); + + $sesscookie = $q->cookie( -name => 'dnsadmin_session', + -value => $sid, +# -expires => "+".$dnsdb->{timeout}, + -secure => 0, +## fixme: need to extract root path for cookie, so as to limit cookie to dnsadmin instance +# -path => $url + ); + + # set session bits + $session->expire($dnsdb->{timeout}); + $session->param('logingroup',$userdata->{group_id}); + $session->param('curgroup',$userdata->{group_id}); + $session->param('uid',$userdata->{user_id}); + $session->param('username',$webvar{username}); + +# for reference. seems we don't need to set these on login any more. +# $session->param('domlistsortby','domain'); +# $session->param('domlistorder','ASC'); +# $session->param('revzonessortby','revnet'); +# $session->param('revzonesorder','ASC'); +# $session->param('useradminsortby','user'); +# $session->param('useradminorder','ASC'); +# $session->param('grpmansortby','group'); +# $session->param('grpmanorder','ASC'); +# $session->param('reclistsortby','host'); +# $session->param('reclistorder','ASC'); +# $session->param('loclistsortby','description'); +# $session->param('loclistorder','ASC'); +# $session->param('logsortby','stamp'); +# $session->param('logorder','DESC'); + + ## "recover my link" - tack on request bits and use requested page instead of hardcoding domlist + # this could possibly be compacted by munging changepage a little so we don't have to deconstruct + # and reconstruct the URI argument list. + my %target = (page => "domlist"); + if ($webvar{target} && $webvar{target} =~ /\?/) { + my $tmp = (split /\?/, $webvar{target})[1]; + $tmp =~ s/^\&//; + my @targs = split /\&/, $tmp; + foreach (@targs) { + my ($k,$v) = split /=/; + $target{$k} = $v if $k; + # if we're going through a "session expired" login, we may have a different + # "current group" than the login group. + $session->param('curgroup', $v) if $k eq 'curgroup'; +##fixme: page=record goes "FOOM", sometimes - cause/fix? + } + } + changepage(%target); + + } else { + $webvar{loginfailed} = 1; + } # user data fetch check + + } elsif ($webvar{action} eq 'logout') { + # delete the session + $session->delete(); + $session->flush(); + + my $sesscookie = $q->cookie( -name => 'dnsadmin_session', + -value => $sid, + -expires => "-1", + -secure => 0, +## fixme: need to extract root path for cookie, so as to limit cookie to dnsadmin instance +# -path => $url + ); + + my $newurl = "http://$ENV{HTTP_HOST}$ENV{SCRIPT_NAME}"; + $newurl =~ s|/[^/]+$|/|; + print $q->redirect( -uri => $newurl, -cookie => $sesscookie); + exit; + + } elsif ($webvar{action} eq 'chgroup' && $webvar{page} ne 'login') { + # fiddle session-stored group data + # magic incantation to... uhhh... + + # ... and the "change group" bits... + $uri_self =~ s/\&group=[^&]*//g; + + # security check - does the user have permission to view this entity? + my $errmsg; + if (!(grep /^$webvar{group}$/, @viewablegroups)) { + # hmm. Reset the current group to the login group? Yes. Prevents confusing behaviour elsewhere. + $session->param('curgroup',$logingroup); + $webvar{group} = $logingroup; + $curgroup = $logingroup; + $errmsg = "You are not permitted to view or make changes in the requested group"; + $page->param(errmsg => $errmsg); + } + + $session->param('curgroup', $webvar{group}); + $curgroup = ($webvar{group} ? $webvar{group} : $session->param('curgroup')); + + # I hate special cases. +##fixme: probably need to handle webvar{revrec}=='y' too + if ($webvar{page} eq 'reclist' && $webvar{defrec} eq 'y') { + my %args = (page => $webvar{page}, id => $curgroup, defrec => $webvar{defrec}, revrec => $webvar{revrec}); + $args{errmsg} = $errmsg if $errmsg; + changepage(%args); + } + # add offset back *into* $uri_self if we're also currently looking at a live record list. + if ($webvar{page} eq 'reclist' && $webvar{defrec} eq 'n') { + $uri_self .= "\&offset=$offset"; + } + } # done action=chgroup +} # handle global webvar{action}s + + +# finally check if the user was disabled. we could just leave this for logout/session expiry, +# but if they keep the session active they'll continue to have access long after being disabled. :/ +# Treat it as a session expiry. +if ($session->param('uid') && !$dnsdb->userStatus($session->param('uid')) ) { + $sid = ''; + $session->delete; # force expiry of the session Right Away + $session->flush; # make sure it hits storage + changepage(page=> "login", sessexpired => 1); +} + +# Misc Things To Do on most pages +my %permissions; +$dnsdb->getPermissions('user', $session->param('uid'), \%permissions); +$dnsdb->initActionLog($session->param('uid')); + +## +## Per-page processing +## + +if ($webvar{page} eq 'login') { + + my $target = $ENV{REQUEST_URI}; + $target =~ s/\&/\&/g; + $page->param(target => $target); # needs to be trimmed a little, maybe? + + $page->param(sessexpired => 1) if (!$sid && $target !~ m|/$|); + + if ($webvar{loginfailed}) { + $page->param(loginfailed => 1); + $webvar{target} =~ s/\&/\&/g; # XHTML we do (not) love you so + $page->param(target => $webvar{target}) if $webvar{target}; + } +# if $webvar{sessexpired}; # or this with below? + if ($session->is_expired) { + $page->param(sessexpired => 1); + $session->delete(); # Just to make sure + $session->flush(); + } + $page->param(version => $DNSDB::VERSION); + $page->param(script_self => ($ENV{SCRIPT_NAME} =~ m|/([^/]+)$|)[0]); + +} elsif ($webvar{page} eq 'domlist' or $webvar{page} eq 'index') { + + $page->param(domlist => 1); + +# hmm. seeing problems in some possibly-not-so-corner cases. +# this currently only handles "domain on", "domain off" + if (defined($webvar{zonestatus})) { + # security check - does the user have permission to access this entity? + my $flag = 0; + foreach (@viewablegroups) { + $flag = 1 if $dnsdb->isParent($_, 'group', $webvar{id}, 'domain'); + } + if ($flag && ($permissions{admin} || $permissions{domain_edit})) { + my $stat = $dnsdb->zoneStatus($webvar{id}, 'n', $webvar{zonestatus}); + $page->param(resultmsg => $DNSDB::resultstr); + } else { + $page->param(errmsg => "You are not permitted to view or change the requested domain"); + } + $uri_self =~ s/\&zonestatus=[^&]*//g; # clean up URL for stuffing into templates + } + + show_msgs(); + + $page->param(curpage => $webvar{page}); + + listdomains(); + +} elsif ($webvar{page} eq 'newdomain') { + + changepage(page => "domlist", errmsg => "You are not permitted to add domains") + unless ($permissions{admin} || $permissions{domain_create}); + + $webvar{group} = $curgroup if !$webvar{group}; + fill_grouplist("grouplist", $webvar{group}); + fill_loclist($curgroup, $webvar{defloc} ? $webvar{defloc} : ''); + + if ($session->param('add_failed')) { + $session->clear('add_failed'); + $page->param(add_failed => 1); + $page->param(errmsg => $session->param('errmsg')); + $session->clear('errmsg'); + $page->param(domain => $webvar{domain}); + $page->param(addinactive => $webvar{makeactive} eq 'n'); + } + +} elsif ($webvar{page} eq 'adddomain') { + + changepage(page => "domlist", errmsg => "You are not permitted to add domains") + unless ($permissions{admin} || $permissions{domain_create}); + + # security check - does the user have permission to access this entity? + if (!check_scope(id => $webvar{group}, type => 'group')) { + $session->param('add_failed', 1); +##fixme: domain a security risk for XSS? + changepage(page => "newdomain", domain => $webvar{domain}, + errmsg => "You do not have permission to add a domain to the requested group"); + } + + $webvar{makeactive} = 0 if !defined($webvar{makeactive}); + + my ($code,$msg) = $dnsdb->addDomain($webvar{domain}, $webvar{group}, ($webvar{makeactive} eq 'on' ? 1 : 0), + $webvar{defloc}); + + if ($code eq 'OK') { + $dnsdb->mailNotify("New ".($webvar{makeactive} eq 'on' ? 'Active' : 'Inactive')." Domain Created", + ($webvar{makeactive} eq 'on' ? 'Active' : 'Inactive').qq( domain "$webvar{domain}" added by ). + $session->param("username")); + changepage(page => "reclist", id => $msg); + } else { + $session->param('add_failed', 1); +##fixme: domain a security risk for XSS? + changepage(page => "newdomain", errmsg => $msg, domain => $webvar{domain}, + group => $webvar{group}, makeactive => ($webvar{makeactive} ? 'y' : 'n'), defloc => $webvar{defloc}); + } + +} elsif ($webvar{page} eq 'deldom') { + + changepage(page => "domlist", errmsg => "You are not permitted to delete domains") + unless ($permissions{admin} || $permissions{domain_delete}); + + # security check - does the user have permission to access this entity? + if (!check_scope(id => $webvar{id}, type => 'domain')) { + changepage(page => "domlist", errmsg => "You do not have permission to delete the requested domain"); + } + + $page->param(id => $webvar{id}); + + # first pass = confirm y/n (sorta) + if (!defined($webvar{del})) { + + $page->param(del_getconf => 1); + $page->param(domain => $dnsdb->domainName($webvar{id})); + + } elsif ($webvar{del} eq 'ok') { + my $pargroup = $dnsdb->parentID(id => $webvar{id}, type => 'domain', revrec => $webvar{revrec}); + my ($code,$msg) = $dnsdb->delZone($webvar{id}, $webvar{revrec}); + if ($code eq 'OK') { + changepage(page => "domlist", resultmsg => $msg); + } else { + changepage(page => "domlist", errmsg => $msg); + } + + } else { + # cancelled. whee! + changepage(page => "domlist"); + } + +} elsif ($webvar{page} eq 'revzones') { + + $webvar{revrec} = 'y'; + + if (defined($webvar{zonestatus})) { + # security check - does the user have permission to access this entity? + my $flag = 0; + foreach (@viewablegroups) { + $flag = 1 if $dnsdb->isParent($_, 'group', $webvar{id}, 'revzone'); + } + if ($flag && ($permissions{admin} || $permissions{domain_edit})) { + my $stat = $dnsdb->zoneStatus($webvar{id}, 'y', $webvar{zonestatus}); + $page->param(resultmsg => $DNSDB::resultstr); + } else { + $page->param(errmsg => "You are not permitted to view or change the requested reverse zone"); + } + $uri_self =~ s/\&zonestatus=[^&]*//g; # clean up URL for stuffing into templates + } + + show_msgs(); + + $page->param(curpage => $webvar{page}); + listzones(); + +} elsif ($webvar{page} eq 'newrevzone') { + +## scope/access check - use domain settings? invent new (bleh) + changepage(page => "revzones", errmsg => "You are not permitted to add reverse zones") + unless ($permissions{admin} || $permissions{domain_create}); + + fill_grouplist("grouplist"); + my $loclist = $dnsdb->getLocDropdown($curgroup); + $page->param(loclist => $loclist); + + # prepopulate revpatt with the matching default record +# $dnsdb->getRecByName(revrec => $webvar{revrec}, defrec => $webvar{defrec}, host => 'string'); + + if ($session->param('add_failed')) { + $session->clear('add_failed'); + $page->param(errmsg => $session->param('errmsg')); + $session->clear('errmsg'); + $page->param(revzone => $webvar{revzone}); + $page->param(revpatt => $webvar{revpatt}); + } + +} elsif ($webvar{page} eq 'addrevzone') { + + changepage(page => "revzones", errmsg => "You are not permitted to add reverse zones") + unless ($permissions{admin} || $permissions{domain_create}); + + # security check - does the user have permission to access this entity? + if (!check_scope(id => $webvar{group}, type => 'group')) { + changepage(page => "newrevzone", add_failed => 1, revzone => $webvar{revzone}, revpatt => $webvar{revpatt}, + errmsg => "You do not have permission to add a reverse zone to the requested group"); + } + + my ($code,$msg) = $dnsdb->addRDNS($webvar{revzone}, $webvar{revpatt}, $webvar{group}, + ($webvar{makeactive} eq 'on' ? 1 : 0), $webvar{location}); + + if ($code eq 'OK') { + changepage(page => "reclist", id => $msg, revrec => 'y'); + } elsif ($code eq 'WARN') { + changepage(page => "reclist", id => $msg, revrec => 'y', warnmsg => $DNSDB::resultstr); + } else { + $session->param('add_failed', 1); + changepage(page => "newrevzone", revzone => $webvar{revzone}, revpatt => $webvar{revpatt}, errmsg => $msg); + } + +} elsif ($webvar{page} eq 'delrevzone') { + + changepage(page => "revzones", errmsg => "You are not permitted to delete reverse zones") + unless ($permissions{admin} || $permissions{domain_delete}); + + # security check - does the user have permission to access this entity? + if (!check_scope(id => $webvar{id}, type => 'revzone')) { + changepage(page => "revzones", errmsg => "You do not have permission to delete the requested reverse zone"); + } + + $page->param(id => $webvar{id}); + + # first pass = confirm y/n (sorta) + if (!defined($webvar{del})) { + + $page->param(del_getconf => 1); + $page->param(revzone => $dnsdb->revName($webvar{id})); + + } elsif ($webvar{del} eq 'ok') { + my $pargroup = $dnsdb->parentID(id => $webvar{id}, type => 'revzone', revrec => $webvar{revrec}); + my $zone = $dnsdb->revName($webvar{id}); + my ($code,$msg) = $dnsdb->delZone($webvar{id}, 'y'); + if ($code eq 'OK') { + changepage(page => "revzones", resultmsg => $msg); + } else { + changepage(page => "revzones", errmsg => $msg); + } + + } else { + # cancelled. whee! + changepage(page => "revzones"); + } + +} elsif ($webvar{page} eq 'reclist') { + + # security check - does the user have permission to view this entity? + if (!check_scope(id => $webvar{id}, type => + ($webvar{defrec} eq 'y' ? 'group' : ($webvar{revrec} eq 'y' ? 'revzone' : 'domain')))) { + $page->param(errmsg => "You are not permitted to view or change the requested ". + ($webvar{defrec} eq 'y' ? "group's default records" : + ($webvar{revrec} eq 'y' ? "reverse zone's records" : "domain's records"))); + $page->param(perm_err => 1); # this causes the template to skip the record listing output. + goto DONERECLIST; # and now we skip filling in the content which is not printed due to perm_err above + } + +# hmm. where do we send them? + if ($webvar{defrec} eq 'y' && !$permissions{admin}) { + $page->param(errmsg => "You are not permitted to edit default records"); + $page->param(perm_err => 1); + } else { + + $page->param(mayeditsoa => $permissions{admin} || $permissions{domain_edit}); +##fixme: ACL needs pondering. Does "edit domain" interact with record add/remove/etc? +# Note this seems to be answered "no" in Vega. +# ACLs + $page->param(record_create => ($permissions{admin} || $permissions{record_create}) ); +# we don't have any general edit links on the page; they're all embedded in the TMPL_LOOP +# $page->param(record_edit => ($permissions{admin} || $permissions{record_edit}) ); + $page->param(record_delete => ($permissions{admin} || $permissions{record_delete}) ); + + # Handle record list for both default records (per-group) and live domain records + + $page->param(defrec => $webvar{defrec}); + $page->param(revrec => $webvar{revrec}); + $page->param(id => $webvar{id}); + $page->param(curpage => $webvar{page}); + + my $count = $dnsdb->getRecCount($webvar{defrec}, $webvar{revrec}, $webvar{id}, $filter); + + $sortby = 'host'; +# sort/order + $session->param($webvar{page}.'sortby', $webvar{sortby}) if $webvar{sortby}; + $session->param($webvar{page}.'order', $webvar{order}) if $webvar{order}; + + $sortby = $session->param($webvar{page}.'sortby') if $session->param($webvar{page}.'sortby'); + $sortorder = $session->param($webvar{page}.'order') if $session->param($webvar{page}.'order'); + +# set up the headers + my @cols; + my %colheads; + if ($webvar{revrec} eq 'n') { + @cols = ('host', 'type', 'val', 'distance', 'weight', 'port', 'ttl'); + %colheads = (host => 'Name', type => 'Type', val => 'Address', + distance => 'Distance', weight => 'Weight', port => 'Port', ttl => 'TTL'); + } else { + @cols = ('val', 'type', 'host', 'ttl'); + %colheads = (val => 'IP Address', type => 'Type', host => 'Hostname', ttl => 'TTL'); + } + my %custom = (id => $webvar{id}, defrec => $webvar{defrec}, revrec => $webvar{revrec}); + fill_colheads($sortby, $sortorder, \@cols, \%colheads, \%custom); + +# fill the page-count and first-previous-next-last-all details + fill_pgcount($count,"records", + ($webvar{defrec} eq 'y' ? "group ".$dnsdb->groupName($webvar{id}) : + ($webvar{revrec} eq 'y' ? $dnsdb->revName($webvar{id}) : $dnsdb->domainName($webvar{id})) + )); + fill_fpnla($count); # should put some params on this sub... + + $page->param(defrec => $webvar{defrec}); + showzone($webvar{defrec}, $webvar{revrec}, $webvar{id}); + if ($webvar{defrec} eq 'n') { + if ($webvar{revrec} eq 'n') { + $page->param(logdom => 1); + } else { + $page->param(logrdns => 1); + } + } + + show_msgs(); + + } # close "you can't edit default records" check + + # Yes, this is a GOTO target. PTBHTTT. + DONERECLIST: ; + +} elsif ($webvar{page} eq 'record') { + + # security check - does the user have permission to access this entity? + if (!check_scope(id => $webvar{id}, type => + ($webvar{defrec} eq 'y' ? ($webvar{revrec} eq 'y' ? 'defrevrec' : 'defrec') : 'record'))) { + $page->param(perm_err => "You are not permitted to edit the requested record"); + goto DONEREC; + } + # round 2, check the parent. + if (!check_scope(id => $webvar{parentid}, type => + ($webvar{defrec} eq 'y' ? 'group' : ($webvar{revrec} eq 'y' ? 'revzone' : 'domain')))) { + my $msg = ($webvar{defrec} eq 'y' ? + "You are not permitted to add or edit default records in the requested group" : + "You are not permitted to add or edit records in the requested domain/zone"); + $page->param(perm_err => $msg); + goto DONEREC; + } + + $page->param(defrec => $webvar{defrec}); + $page->param(revrec => $webvar{revrec}); + $page->param(fwdzone => $webvar{revrec} eq 'n'); + + if ($webvar{recact} eq 'new') { + + changepage(page => "reclist", errmsg => "You are not permitted to add records", id => $webvar{parentid}) + unless ($permissions{admin} || $permissions{record_create}); + + $page->param(todo => "Add record"); + $page->param(recact => "add"); + $page->param(parentid => $webvar{parentid}); + + fill_recdata(); + + if ($webvar{defrec} eq 'n') { + my $defloc = $dnsdb->getZoneLocation($webvar{revrec}, $webvar{parentid}); + fill_loclist($curgroup, $defloc); + } + + } elsif ($webvar{recact} eq 'add') { + + changepage(page => "reclist", errmsg => "You are not permitted to add records", id => $webvar{parentid}) + unless ($permissions{admin} || $permissions{record_create}); + + # location check - if user does not have record_locchg, set $webvar{location} to default location for zone + my $parloc = $dnsdb->getZoneLocation($webvar{revrec}, $webvar{parentid}); + $webvar{location} = $parloc unless ($permissions{admin} || $permissions{record_locchg}); + + my @recargs = ($webvar{defrec}, $webvar{revrec}, $webvar{parentid}, + \$webvar{name}, \$webvar{type}, \$webvar{address}, $webvar{ttl}, $webvar{location}, + $webvar{expires}, $webvar{stamp}); + if ($webvar{type} == $reverse_typemap{MX} or $webvar{type} == $reverse_typemap{SRV}) { + push @recargs, $webvar{distance}; + if ($webvar{type} == $reverse_typemap{SRV}) { + push @recargs, $webvar{weight}; + push @recargs, $webvar{port}; + } + } + + my ($code,$msg) = $dnsdb->addRec(@recargs); + + if ($code eq 'OK' || $code eq 'WARN') { + my %pageparams = (page => "reclist", id => $webvar{parentid}, + defrec => $webvar{defrec}, revrec => $webvar{revrec}); + $pageparams{warnmsg} = $msg."

\n".$DNSDB::resultstr if $code eq 'WARN'; + $pageparams{resultmsg} = $DNSDB::resultstr if $code eq 'OK'; + changepage(%pageparams); + } else { + $page->param(failed => 1); + $page->param(errmsg => $msg); + $page->param(wastrying => "adding"); + $page->param(todo => "Add record"); + $page->param(recact => "add"); + $page->param(parentid => $webvar{parentid}); + $page->param(id => $webvar{id}); + fill_recdata(); # populate the form... er, mostly. + if ($webvar{defrec} eq 'n') { + fill_loclist($curgroup, $webvar{location}); + } + } + + } elsif ($webvar{recact} eq 'edit') { + + changepage(page => "reclist", errmsg => "You are not permitted to edit records", id => $webvar{parentid}) + unless ($permissions{admin} || $permissions{record_edit}); + + $page->param(todo => "Update record"); + $page->param(recact => "update"); + $page->param(parentid => $webvar{parentid}); + $page->param(id => $webvar{id}); + my $recdata = $dnsdb->getRecLine($webvar{defrec}, $webvar{revrec}, $webvar{id}); + $page->param(name => $recdata->{host}); + $page->param(address => $recdata->{val}); + $page->param(distance => $recdata->{distance}); + $page->param(weight => $recdata->{weight}); + $page->param(port => $recdata->{port}); + $page->param(ttl => $recdata->{ttl}); + $page->param(typelist => $dnsdb->getTypelist($webvar{revrec}, $recdata->{type})); + if ($recdata->{stampactive}) { + $page->param(stamp => $recdata->{stamp}); + $page->param(stamp_until => $recdata->{expires}); + } + if ($webvar{defrec} eq 'n') { + fill_loclist($curgroup, $recdata->{location}); + } + + } elsif ($webvar{recact} eq 'update') { + + changepage(page => "reclist", errmsg => "You are not permitted to edit records", id => $webvar{parentid}) + unless ($permissions{admin} || $permissions{record_edit}); + + # retain old location if user doesn't have permission to fiddle locations + my $oldrec = $dnsdb->getRecLine($webvar{defrec}, $webvar{revrec}, $webvar{id}); + $webvar{location} = $oldrec->{location} unless ($permissions{admin} || $permissions{record_locchg}); + + my ($code,$msg) = $dnsdb->updateRec($webvar{defrec}, $webvar{revrec}, $webvar{id}, $webvar{parentid}, + \$webvar{name}, \$webvar{type}, \$webvar{address}, $webvar{ttl}, $webvar{location}, + $webvar{expires}, $webvar{stamp}, + $webvar{distance}, $webvar{weight}, $webvar{port}); + + if ($code eq 'OK' || $code eq 'WARN') { + my %pageparams = (page => "reclist", id => $webvar{parentid}, + defrec => $webvar{defrec}, revrec => $webvar{revrec}); + $pageparams{warnmsg} = $msg."

\n".$DNSDB::resultstr if $code eq 'WARN'; + $pageparams{resultmsg} = $DNSDB::resultstr if $code eq 'OK'; + changepage(%pageparams); + } else { + $page->param(failed => 1); + $page->param(errmsg => $msg); + $page->param(wastrying => "updating"); + $page->param(todo => "Update record"); + $page->param(recact => "update"); + $page->param(parentid => $webvar{parentid}); + $page->param(id => $webvar{id}); + fill_recdata(); + } + } + + if ($webvar{defrec} eq 'y') { + $page->param(dohere => "default records in group ".$dnsdb->groupName($webvar{parentid})); + } else { + $page->param(dohere => $dnsdb->domainName($webvar{parentid})) if $webvar{revrec} eq 'n'; + $page->param(dohere => $dnsdb->revName($webvar{parentid})) if $webvar{revrec} eq 'y'; + } + + # Yes, this is a GOTO target. PTBHTTT. + DONEREC: ; + +} elsif ($webvar{page} eq 'delrec') { + + # This is a complete separate segment since it uses a different template from add/edit records above + + changepage(page => "reclist", errmsg => "You are not permitted to delete records", id => $webvar{parentid}, + defrec => $webvar{defrec}, revrec => $webvar{revrec}) + unless ($permissions{admin} || $permissions{record_delete}); + + if (!check_scope(id => $webvar{id}, type => + ($webvar{defrec} eq 'y' ? ($webvar{revrec} eq 'y' ? 'defrevrec' : 'defrec') : 'record'))) { + # redirect to domlist because we don't have permission for the entity requested + changepage(page => 'domlist', revrec => $webvar{revrec}, + errmsg => "You do not have permission to delete records in the requested ". + ($webvar{defrec} eq 'y' ? 'group' : 'domain')); + } + + $page->param(id => $webvar{id}); + $page->param(defrec => $webvar{defrec}); + $page->param(revrec => $webvar{revrec}); + $page->param(parentid => $webvar{parentid}); + # first pass = confirm y/n (sorta) + if (!defined($webvar{del})) { + $page->param(del_getconf => 1); + my $rec = $dnsdb->getRecLine($webvar{defrec}, $webvar{revrec}, $webvar{id}); + $page->param(host => $rec->{host}); + $page->param(ftype => $typemap{$rec->{type}}); + $page->param(recval => $rec->{val}); + } elsif ($webvar{del} eq 'ok') { + my ($code,$msg) = $dnsdb->delRec($webvar{defrec}, $webvar{revrec}, $webvar{id}); + if ($code eq 'OK') { + changepage(page => "reclist", id => $webvar{parentid}, defrec => $webvar{defrec}, + revrec => $webvar{revrec}, resultmsg => $msg); + } else { +## need to find failure mode + changepage(page => "reclist", id => $webvar{parentid}, defrec => $webvar{defrec}, + revrec => $webvar{revrec}, errmsg => $msg); + } + } else { + changepage(page => "reclist", id => $webvar{parentid}, defrec => $webvar{defrec}, revrec => $webvar{revrec}); + } + +} elsif ($webvar{page} eq 'editsoa') { + + # security check - does the user have permission to view this entity? + # id is domain/revzone/group id + if (!check_scope(id => $webvar{id}, type => + ($webvar{defrec} eq 'y' ? 'group' : ($webvar{revrec} eq 'y' ? 'revzone' : 'domain')))) { + changepage(page => 'domlist', errmsg => "You do not have permission to edit the ". + ($webvar{defrec} eq 'y' ? 'default ' : '')."SOA record for the requested ". + ($webvar{defrec} eq 'y' ? 'group' : 'domain')); + } + + if ($webvar{defrec} eq 'y') { + changepage(page => "domlist", errmsg => "You are not permitted to edit default records") + unless $permissions{admin}; + } else { + changepage(page => "reclist", errmsg => "You are not permitted to edit domain SOA records", id => $webvar{id}) + unless ($permissions{admin} || $permissions{domain_edit}); + } + + fillsoa($webvar{defrec},$webvar{revrec},$webvar{id}); + +} elsif ($webvar{page} eq 'updatesoa') { + + # security check - does the user have permission to view this entity? + # pass 1, record ID + if (!check_scope(id => $webvar{recid}, type => + ($webvar{defrec} eq 'y' ? ($webvar{revrec} eq 'y' ? 'defrevrec' : 'defrec') : 'record'))) { +##fixme: should we redirect to the requested record list page instead of the domain list? + changepage(page => 'domlist', errmsg => "You do not have permission to edit the requested SOA record"); + } + # pass 2, parent (group or domain) ID + if (!check_scope(id => $webvar{id}, type => + ($webvar{defrec} eq 'y' ? 'group' : ($webvar{revrec} eq 'y' ? 'revzone' : 'domain')))) { + changepage(page => ($webvar{revrec} eq 'y' ? 'revzones' : 'domlist'), + errmsg => "You do not have permission to edit the ". + ($webvar{defrec} eq 'y' ? 'default ' : '')."SOA record for the requested ". + ($webvar{defrec} eq 'y' ? 'group' : ($webvar{revrec} eq 'y' ? 'reverse zone' : 'domain')) ); + } + + changepage(page => "reclist", errmsg => "You are not permitted to edit domain SOA records", id => $webvar{id}) + unless ($permissions{admin} || $permissions{domain_edit}); + + my ($code, $msg) = $dnsdb->updateSOA($webvar{defrec}, $webvar{revrec}, + (contact => $webvar{contact}, prins => $webvar{prins}, refresh => $webvar{refresh}, + retry => $webvar{retry}, expire => $webvar{expire}, minttl => $webvar{minttl}, + ttl => $webvar{ttl}, id => $webvar{id}) ); + if ($code eq 'OK') { + changepage(page => "reclist", id => $webvar{id}, defrec => $webvar{defrec}, revrec => $webvar{revrec}, + resultmsg => "SOA record updated"); + } else { + $page->param(update_failed => 1); + $page->param(msg => $msg); + fillsoa($webvar{defrec}, $webvar{revrec}, $webvar{id}, 'w'); + } + +} elsif ($webvar{page} eq 'grpman') { + + listgroups(); + +# Permissions! + $page->param(addgrp => $permissions{admin} || $permissions{group_create}); + $page->param(edgrp => $permissions{admin} || $permissions{group_edit}); + $page->param(delgrp => $permissions{admin} || $permissions{group_delete}); + + show_msgs(); + $page->param(curpage => $webvar{page}); + +} elsif ($webvar{page} eq 'newgrp') { + + changepage(page => "grpman", errmsg => "You are not permitted to add groups") + unless ($permissions{admin} || $permissions{group_create}); + + # do.. uhh.. stuff.. if we have no webvar{grpaction} + if ($webvar{grpaction} && $webvar{grpaction} eq 'add') { + + # security check - does the user have permission to access this entity? + if (!check_scope(id => $webvar{pargroup}, type => 'group')) { + changepage(page => "grpman", errmsg => "You are not permitted to add a group to the requested parent group"); + } + + my %newperms; + my $alterperms = 0; + foreach (@permtypes) { + $newperms{$_} = 0; + if ($permissions{admin} || $permissions{$_}) { + $newperms{$_} = (defined($webvar{$_}) && $webvar{$_} eq 'on' ? 1 : 0); + } else { + $alterperms = 1; + } + } + # "Chained" permissions. Some permissions imply others; make sure they get set. + foreach (keys %permchains) { + if ($newperms{$_} && !$newperms{$permchains{$_}}) { + $newperms{$permchains{$_}} = 1; + } + } + # force inheritance of parent group's default records with inherit flag, + # otherwise we end up with the hardcoded defaults from DNSDB.pm. See + # https://secure.deepnet.cx/trac/dnsadmin/ticket/8 for the UI enhancement + # that will make this variable. + my ($code,$msg) = $dnsdb->addGroup($webvar{newgroup}, $webvar{pargroup}, \%newperms, 1); + if ($code eq 'OK') { + if ($alterperms) { + changepage(page => "grpman", warnmsg => + "You can only grant permissions you hold. New group $webvar{newgroup} added with reduced access."); + } else { + changepage(page => "grpman", resultmsg => "Added group $webvar{newgroup}"); + } + } # fallthrough else + # no point in doing extra work + fill_permissions($page, \%newperms); + $page->param(add_failed => 1); + $page->param(errmsg => $msg); + $page->param(newgroup => $webvar{newgroup}); + fill_grouplist('pargroup',$webvar{pargroup}); + } else { + fill_grouplist('pargroup',$curgroup); + # fill default permissions with immediate parent's current ones + my %parperms; + $dnsdb->getPermissions('group', $curgroup, \%parperms); + fill_permissions($page, \%parperms); + } + +} elsif ($webvar{page} eq 'delgrp') { + + changepage(page => "grpman", errmsg => "You are not permitted to delete groups", id => $webvar{parentid}) + unless ($permissions{admin} || $permissions{group_delete}); + + # security check - does the user have permission to access this entity? + if (!check_scope(id => $webvar{id}, type => 'group')) { + changepage(page => "grpman", errmsg => "You are not permitted to delete the requested group"); + } + + $page->param(id => $webvar{id}); + # first pass = confirm y/n (sorta) + if (!defined($webvar{del})) { + $page->param(del_getconf => 1); + +##fixme +# do a check for "group has stuff in it", and splatter a big warning +# up along with an unchecked-by-default check box to YES DAMMIT DELETE THE WHOLE THING + + } elsif ($webvar{del} eq 'ok') { + my ($code,$msg) = $dnsdb->delGroup($webvar{id}); + if ($code eq 'OK') { +##fixme: need to clean up log when deleting a major container + changepage(page => "grpman", resultmsg => $msg); + } else { +# need to find failure mode + changepage(page => "grpman", errmsg => $msg); + } + } else { + # cancelled. whee! + changepage(page => "grpman"); + } + $page->param(delgroupname => $dnsdb->groupName($webvar{id})); + +} elsif ($webvar{page} eq 'edgroup') { + + changepage(page => "grpman", errmsg => "You are not permitted to edit groups") + unless ($permissions{admin} || $permissions{group_edit}); + + # security check - does the user have permission to access this entity? + if (!check_scope(id => $webvar{gid}, type => 'group')) { + changepage(page => "grpman", errmsg => "You are not permitted to edit the requested group"); + } + + if ($webvar{grpaction} && $webvar{grpaction} eq 'updperms') { + # extra safety check; make sure user can't construct a URL to bypass ACLs + my %curperms; + $dnsdb->getPermissions('group', $webvar{gid}, \%curperms); + my %chperms; + my $alterperms = 0; + foreach (@permtypes) { + $webvar{$_} = 0 if !defined($webvar{$_}); + $webvar{$_} = 1 if $webvar{$_} eq 'on'; + if ($permissions{admin} || $permissions{$_}) { + $chperms{$_} = $webvar{$_} if $curperms{$_} ne $webvar{$_}; + } else { + $alterperms = 1; + $chperms{$_} = 0; + } + } + # "Chained" permissions. Some permissions imply others; make sure they get set. + foreach (keys %permchains) { + if ($chperms{$_} && !$chperms{$permchains{$_}}) { + $chperms{$permchains{$_}} = 1; + } + } + my ($code,$msg) = $dnsdb->changePermissions('group', $webvar{gid}, \%chperms); + if ($code eq 'OK') { + if ($alterperms) { + changepage(page => "grpman", warnmsg => + "You can only grant permissions you hold. Default permissions in group ". + $dnsdb->groupName($webvar{gid})." updated with reduced access"); + } else { + changepage(page => "grpman", resultmsg => $msg); + } + } # fallthrough else + # no point in doing extra work + fill_permissions($page, \%chperms); + $page->param(errmsg => $msg); + } + $page->param(gid => $webvar{gid}); + $page->param(grpmeddle => $dnsdb->groupName($webvar{gid})); + my %grpperms; + $dnsdb->getPermissions('group', $webvar{gid}, \%grpperms); + fill_permissions($page, \%grpperms); + +} elsif ($webvar{page} eq 'bulkdomain') { + # Bulk operations on domains. Note all but group move are available on the domain list. +##fixme: do we care about bulk operations on revzones? Move-to-group, activate, deactivate, +# and delete should all be much rarer for revzones than for domains. + + changepage(page => "domlist", errmsg => "You are not permitted to make bulk domain changes") + unless ($permissions{admin} || $permissions{domain_edit} || $permissions{domain_create} || $permissions{domain_delete}); + + fill_grouplist("grouplist"); + + my $count = $dnsdb->getZoneCount(revrec => 'n', curgroup => $curgroup); + + $page->param(curpage => $webvar{page}); + fill_pgcount($count, 'domains', $dnsdb->groupName($curgroup)); + fill_fpnla($count); + $page->param(perpage => $perpage); + + my $domlist = $dnsdb->getZoneList(revrec => 'n', curgroup => $curgroup, offset => $offset); + my $rownum = 0; + foreach my $dom (@{$domlist}) { + delete $dom->{status}; + delete $dom->{group}; + $dom->{newrow} = (++$rownum) % 5 == 0; + } + + $page->param(domtable => $domlist); + # ACLs + $page->param(maymove => ($permissions{admin} || ($permissions{domain_edit} && $permissions{domain_create} && $permissions{domain_delete}))); + $page->param(maystatus => $permissions{admin} || $permissions{domain_edit}); + $page->param(maydelete => $permissions{admin} || $permissions{domain_delete}); + +} elsif ($webvar{page} eq 'bulkchange') { + + # security check - does the user have permission to access this entity? + if (!check_scope(id => $webvar{destgroup}, type => 'group')) { + $page->param(errmsg => "You are not permitted to make bulk changes in the requested group"); + goto DONEBULK; + } + + # per-action scope checks + if ($webvar{bulkaction} eq 'move') { + changepage(page => "domlist", errmsg => "You are not permitted to bulk-move domains") + unless ($permissions{admin} || ($permissions{domain_edit} && $permissions{domain_create} && $permissions{domain_delete})); + my $newgname = $dnsdb->groupName($webvar{destgroup}); + $page->param(action => "Move to group $newgname"); + } elsif ($webvar{bulkaction} eq 'deactivate' || $webvar{bulkaction} eq 'activate') { + changepage(page => "domlist", errmsg => "You are not permitted to bulk-$webvar{bulkaction} domains") + unless ($permissions{admin} || $permissions{domain_edit}); + $page->param(action => "$webvar{bulkaction} domains"); + } elsif ($webvar{bulkaction} eq 'delete') { + changepage(page => "domlist", errmsg => "You are not permitted to bulk-delete domains") + unless ($permissions{admin} || $permissions{domain_delete}); + $page->param(action => "$webvar{bulkaction} domains"); + } else { + # unknown action, bypass actually doing anything. it should not be possible in + # normal operations, and anyone who meddles with the URL gets what they deserve. + goto DONEBULK; + } # move/(de)activate/delete if() + + my @bulkresults; + # nngh. due to alpha-sorting on the previous page, we can't use domid-numeric + # order here, and since we don't have the domain names until we go around this + # loop, we can't alpha-sort them here. :( + foreach (keys %webvar) { + my %row; + next unless $_ =~ /^dom_\d+$/; + # second security check - does the user have permission to meddle with this domain? + if (!check_scope(id => $webvar{$_}, type => 'domain')) { + $row{domerr} = "You are not permitted to make changes to the requested domain"; + $row{domain} = $webvar{$_}; + push @bulkresults, \%row; + next; + } + $row{domain} = $dnsdb->domainName($webvar{$_}); + + # Do the $webvar{bulkaction} + my ($code, $msg); + ($code, $msg) = $dnsdb->changeGroup('domain', $webvar{$_}, $webvar{destgroup}) + if $webvar{bulkaction} eq 'move'; + if ($webvar{bulkaction} eq 'deactivate' || $webvar{bulkaction} eq 'activate') { + my $stat = $dnsdb->zoneStatus($webvar{$_}, 'n', ($webvar{bulkaction} eq 'activate' ? 'domon' : 'domoff')); + $code = (defined($stat) ? 'OK' : 'FAIL'); + $msg = (defined($stat) ? $DNSDB::resultstr : $DNSDB::errstr); + } + ($code, $msg) = $dnsdb->delZone($webvar{$_}, 'n') + if $webvar{bulkaction} eq 'delete'; + + # Set the result output from the action + if ($code eq 'OK') { + $row{domok} = $msg; + } elsif ($code eq 'WARN') { + $row{domwarn} = $msg; + } else { + $row{domerr} = $msg; + } + push @bulkresults, \%row; + + } # foreach (keys %webvar) + $page->param(bulkresults => \@bulkresults); + + # Yes, this is a GOTO target. PTHBTTT. + DONEBULK: ; + +} elsif ($webvar{page} eq 'useradmin') { + + if (defined($webvar{userstatus})) { + # security check - does the user have permission to access this entity? + my $flag = 0; + foreach (@viewablegroups) { + $flag = 1 if $dnsdb->isParent($_, 'group', $webvar{id}, 'user'); + } + if ($flag && ($permissions{admin} || $permissions{user_edit} || + ($permissions{self_edit} && $webvar{id} == $session->param('uid')) )) { + my $stat = $dnsdb->userStatus($webvar{id}, $webvar{userstatus}); + $page->param(resultmsg => $DNSDB::resultstr); + } else { + $page->param(errmsg => "You are not permitted to view or change the requested user"); + } + $uri_self =~ s/\&userstatus=[^&]*//g; # clean up URL for stuffing into templates + } + + list_users(); + +# Permissions! + $page->param(adduser => $permissions{admin} || $permissions{user_create}); +# should we block viewing other users? Vega blocks "editing"... +# NB: no "edit self" link as with groups here. maybe there should be? +# $page->param(eduser => $permissions{admin} || $permissions{user_edit}); + $page->param(deluser => $permissions{admin} || $permissions{user_delete}); + + show_msgs(); + $page->param(curpage => $webvar{page}); + +} elsif ($webvar{page} eq 'user') { + + # All user add/edit actions fall through the same page, since there aren't + # really any hard differences between the templates + + #fill_actypelist($webvar{accttype}); + fill_clonemelist(); + my %grpperms; + $dnsdb->getPermissions('group', $curgroup, \%grpperms); + + my $grppermlist = new HTML::Template(filename => "$templatedir/permlist.tmpl"); + my %noaccess; + fill_permissions($grppermlist, \%grpperms, \%noaccess); + $grppermlist->param(info => 1); + $page->param(grpperms => $grppermlist->output); + + $page->param(is_admin => $permissions{admin}); + + $webvar{useraction} = '' if !$webvar{useraction}; + + if ($webvar{useraction} eq 'add' or $webvar{useraction} eq 'update') { + + $page->param(add => 1) if $webvar{useraction} eq 'add'; + + # can't re-use $code and $msg for update if we want to be able to identify separate failure states + my ($code,$code2,$msg,$msg2) = ('OK','OK','OK','OK'); + + my $alterperms = 0; # flag iff we need to force custom permissions due to user's current access limits + + my %newperms; # we're going to prefill the existing permissions, so we can change them. + $dnsdb->getPermissions('user', $webvar{uid}, \%newperms); + + if ($webvar{pass1} ne $webvar{pass2}) { + $code = 'FAIL'; + $msg = "Passwords don't match"; + } else { + + # assemble a permission string - far simpler than trying to pass an + # indeterminate set of permission flags individually + + # But first, we have to see if the user can add any particular + # permissions; otherwise we have a priviledge escalation. Whee. + + if (!$permissions{admin}) { + my %grpperms; + $dnsdb->getPermissions('group', $curgroup, \%grpperms); + my $ret = comparePermissions(\%permissions, \%grpperms); + if ($ret eq '<' || $ret eq '!') { + # User's permissions are not a superset or equivalent to group. Can't inherit + # (and include access user doesn't currently have), so we force custom. + $webvar{perms_type} = 'custom'; + $alterperms = 1; + } + } + + my $permstring; + if ($webvar{perms_type} eq 'custom') { + $permstring = 'C:'; + foreach (@permtypes) { + if ($permissions{admin} || $permissions{$_}) { + $permstring .= ",$_" if defined($webvar{$_}) && $webvar{$_} eq 'on'; + $newperms{$_} = (defined($webvar{$_}) && $webvar{$_} eq 'on' ? 1 : 0); + } + } + $page->param(perm_custom => 1); + } elsif ($permissions{admin} && $webvar{perms_type} eq 'clone') { + $permstring = "c:$webvar{clonesrc}"; + $dnsdb->getPermissions('user', $webvar{clonesrc}, \%newperms); + $page->param(perm_clone => 1); + } else { + $permstring = 'i'; + } + # "Chained" permissions. Some permissions imply others; make sure they get set. + foreach (keys %permchains) { + if ($newperms{$_} && !$newperms{$permchains{$_}}) { + $newperms{$permchains{$_}} = 1; + $permstring .= ",$permchains{$_}"; + } + } + if ($webvar{useraction} eq 'add') { + changepage(page => "useradmin", errmsg => "You do not have permission to add new users") + unless $permissions{admin} || $permissions{user_create}; + # no scope check; user is created in the current group + ($code,$msg) = $dnsdb->addUser($webvar{uname}, $curgroup, $webvar{pass1}, + ($webvar{makeactive} eq 'on' ? 1 : 0), $webvar{accttype}, $permstring, + $webvar{fname}, $webvar{lname}, $webvar{phone}); + } else { + changepage(page => "useradmin", errmsg => "You do not have permission to edit users") + unless $permissions{admin} || $permissions{user_edit} || + ($permissions{self_edit} && $session->param('uid') == $webvar{uid}); + # security check - does the user have permission to access this entity? + if (!check_scope(id => $webvar{user}, type => 'user')) { + changepage(page => "useradmin", errmsg => "You do not have permission to edit the requested user"); + } +# User update is icky. I'd really like to do this in one atomic operation, +# but that gets hairy by either duplicating a **lot** of code in DNSDB.pm +# or self-torture trying to not commit the transaction until we're really done. + # Allowing for changing group, but not coding web support just yet. + ($code,$msg) = $dnsdb->updateUser($webvar{uid}, $webvar{uname}, $webvar{gid}, $webvar{pass1}, + ($webvar{makeactive} eq 'on' ? 1 : 0), $webvar{accttype}, + $webvar{fname}, $webvar{lname}, $webvar{phone}); + if ($code eq 'OK') { + $newperms{admin} = 1 if $webvar{accttype} eq 'S'; + ($code2,$msg2) = $dnsdb->changePermissions('user', $webvar{uid}, \%newperms, ($permstring eq 'i')); + } + } + } + + if ($code eq 'OK' && $code2 eq 'OK') { + my %pageparams = (page => "useradmin"); + if ($alterperms) { + $pageparams{warnmsg} = "You can only grant permissions you hold.\nUser ". + ($webvar{useraction} eq 'add' ? "$webvar{uname} added" : "info updated for $webvar{uname}"). + ".\nPermissions ".($webvar{useraction} eq 'add' ? 'added' : 'updated')." with reduced access."; + } else { + $pageparams{resultmsg} = "$msg".($webvar{useraction} eq 'add' ? '' : "\n$msg2"); + } + changepage(%pageparams); + + # add/update failed: + } else { + $page->param(add_failed => 1); + $page->param(action => $webvar{useraction}); + $page->param(set_permgroup => 1); + if ($webvar{perms_type} eq 'inherit') { # set permission class radio + $page->param(perm_inherit => 1); + } elsif ($webvar{perms_type} eq 'clone') { + $page->param(perm_clone => 1); + } else { + $page->param(perm_custom => 1); + } + $page->param(uname => $webvar{uname}); + $page->param(fname => $webvar{fname}); + $page->param(lname => $webvar{lname}); + $page->param(pass1 => $webvar{pass1}); + $page->param(pass2 => $webvar{pass2}); + $page->param(errmsg => "User info updated but permissions update failed: $msg2") if $code eq 'OK'; + $page->param(errmsg => $msg) if $code ne 'OK'; + fill_permissions($page, \%newperms); + fill_actypelist($webvar{accttype}); + fill_clonemelist(); + } + + } elsif ($webvar{useraction} eq 'edit') { + + changepage(page => "useradmin", errmsg => "You do not have permission to edit users") + unless $permissions{admin} || $permissions{user_edit} || + ($permissions{self_edit} && $session->param('uid') == $webvar{user}); + + # security check - does the user have permission to access this entity? + if (!check_scope(id => $webvar{user}, type => 'user')) { + changepage(page => "useradmin", errmsg => "You do not have permission to edit the requested user"); + } + + $page->param(set_permgroup => 1); + $page->param(action => 'update'); + $page->param(uid => $webvar{user}); + fill_clonemelist(); + + my $userinfo = $dnsdb->getUserData($webvar{user}); + fill_actypelist($userinfo->{type}); + # not using this yet, but adding it now means we can *much* more easily do so later. + $page->param(gid => $userinfo->{group_id}); + + my %curperms; + $dnsdb->getPermissions('user', $webvar{user}, \%curperms); + fill_permissions($page, \%curperms); + + $page->param(uname => $userinfo->{username}); + $page->param(fname => $userinfo->{firstname}); + $page->param(lname => $userinfo->{lastname}); + $page->param(set_permgroup => 1); + if ($userinfo->{inherit_perm}) { + $page->param(perm_inherit => 1); + } else { + $page->param(perm_custom => 1); + } + } else { + changepage(page => "useradmin", errmsg => "You are not allowed to add new users") + unless $permissions{admin} || $permissions{user_create}; + # default is "new" + $page->param(add => 1); + $page->param(action => 'add'); + fill_permissions($page, \%grpperms); + fill_actypelist(); + } + +} elsif ($webvar{page} eq 'deluser') { + + changepage(page=> "useradmin", errmsg => "You are not allowed to delete users") + unless $permissions{admin} || $permissions{user_delete}; + + # security check - does the user have permission to access this entity? + if (!check_scope(id => $webvar{id}, type => 'user')) { + changepage(page => "useradmin", errmsg => "You are not permitted to delete the requested user"); + } + + $page->param(id => $webvar{id}); + # first pass = confirm y/n (sorta) + if (!defined($webvar{del})) { + $page->param(del_getconf => 1); + $page->param(user => $dnsdb->userFullName($webvar{id})); + } elsif ($webvar{del} eq 'ok') { + my ($code,$msg) = $dnsdb->delUser($webvar{id}); + if ($code eq 'OK') { + # success. go back to the user list, do not pass "GO" + changepage(page => "useradmin", resultmsg => $msg); + } else { + changepage(page => "useradmin", errmsg => $msg); + } + } else { + # cancelled. whee! + changepage(page => "useradmin"); + } + +} elsif ($webvar{page} eq 'loclist') { + + changepage(page => "domlist", errmsg => "You are not allowed access to this function") + unless $permissions{admin} || $permissions{location_view}; + + # security check - does the user have permission to access this entity? +# if (!check_scope(id => $webvar{id}, type => 'loc')) { +# changepage(page => "loclist", errmsg => "You are not permitted to the requested location/view"); +# } + list_locations(); + show_msgs(); + +# Permissions! + $page->param(addloc => $permissions{admin} || $permissions{location_create}); + $page->param(delloc => $permissions{admin} || $permissions{location_delete}); + +} elsif ($webvar{page} eq 'location') { + + changepage(page => "domlist", errmsg => "You are not allowed access to this function") + unless $permissions{admin} || $permissions{location_view}; + + # security check - does the user have permission to access this entity? +# if (!check_scope(id => $webvar{id}, type => 'loc')) { +# changepage(page => "loclist", errmsg => "You are not permitted to the requested location/view"); +# } + + $webvar{locact} = '' if !$webvar{locact}; + + if ($webvar{locact} eq 'add') { + changepage(page => "loclist", errmsg => "You are not permitted to add locations/views", id => $webvar{parentid}) + unless ($permissions{admin} || $permissions{location_create}); + + my ($code,$msg) = $dnsdb->addLoc($curgroup, $webvar{locname}, $webvar{comments}, $webvar{iplist}); + + if ($code eq 'OK' || $code eq 'WARN') { + my %pageparams = (page => "loclist", id => $webvar{parentid}, + defrec => $webvar{defrec}, revrec => $webvar{revrec}); + $pageparams{warnmsg} = $msg."

\n".$DNSDB::resultstr if $code eq 'WARN'; + $pageparams{resultmsg} = $DNSDB::resultstr if $code eq 'OK'; + changepage(%pageparams); + } else { + $page->param(failed => 1); + $page->param(errmsg => $msg); + $page->param(wastrying => "adding"); + $page->param(todo => "Add location/view"); + $page->param(locact => "add"); + $page->param(id => $webvar{id}); + $page->param(locname => $webvar{locname}); + $page->param(comments => $webvar{comments}); + $page->param(iplist => $webvar{iplist}); + } + + } elsif ($webvar{locact} eq 'edit') { + changepage(page => "loclist", errmsg => "You are not permitted to edit locations/views", id => $webvar{parentid}) + unless ($permissions{admin} || $permissions{location_edit}); + + my $loc = $dnsdb->getLoc($webvar{loc}); + $page->param(wastrying => "editing"); + $page->param(todo => "Edit location/view"); + $page->param(locact => "update"); + $page->param(id => $webvar{loc}); + $page->param(locname => $loc->{description}); + $page->param(comments => $loc->{comments}); + $page->param(iplist => $loc->{iplist}); + + } elsif ($webvar{locact} eq 'update') { + changepage(page => "loclist", errmsg => "You are not permitted to edit locations/views", id => $webvar{parentid}) + unless ($permissions{admin} || $permissions{location_edit}); + + my ($code,$msg) = $dnsdb->updateLoc($webvar{id}, $curgroup, $webvar{locname}, $webvar{comments}, $webvar{iplist}); + + if ($code eq 'OK') { + changepage(page => "loclist", resultmsg => $msg); + } else { + $page->param(failed => 1); + $page->param(errmsg => $msg); + $page->param(wastrying => "editing"); + $page->param(todo => "Edit location/view"); + $page->param(locact => "update"); + $page->param(id => $webvar{loc}); + $page->param(locname => $webvar{locname}); + $page->param(comments => $webvar{comments}); + $page->param(iplist => $webvar{iplist}); + } + } else { + changepage(page => "loclist", errmsg => "You are not permitted to add locations/views", id => $webvar{parentid}) + unless ($permissions{admin} || $permissions{location_create}); + + $page->param(todo => "Add location/view"); + $page->param(locact => "add"); + $page->param(locname => ($webvar{locname} ? $webvar{locname} : '')); + $page->param(iplist => ($webvar{iplist} ? $webvar{iplist} : '')); + + show_msgs(); + } + +} elsif ($webvar{page} eq 'delloc') { + + changepage(page=> "loclist", errmsg => "You are not allowed to delete locations") + unless $permissions{admin} || $permissions{location_delete}; + + # security check - does the user have permission to access this entity? +# if (!check_scope(id => $webvar{id}, type => 'loc')) { +# changepage(page => "loclist", errmsg => "You are not permitted to the requested location/view"); +# } + + $page->param(locid => $webvar{locid}); + my $locdata = $dnsdb->getLoc($webvar{locid}); + $locdata->{description} = $webvar{locid} if !$locdata->{description}; + # first pass = confirm y/n (sorta) + if (!defined($webvar{del})) { + $page->param(del_getconf => 1); + $page->param(location => $locdata->{description}); + } elsif ($webvar{del} eq 'ok') { + my ($code,$msg) = $dnsdb->delLoc($webvar{locid}); + if ($code eq 'OK') { + # success. go back to the user list, do not pass "GO" + changepage(page => "loclist", resultmsg => $msg); + } else { + changepage(page => "loclist", errmsg => $msg); + } + } else { + # cancelled. whee! + changepage(page => "loclist"); + } + +} elsif ($webvar{page} eq 'dnsq') { + + $page->param(qfor => $webvar{qfor}) if $webvar{qfor}; + $page->param(typelist => $dnsdb->getTypelist('l', ($webvar{type} ? $webvar{type} : undef))); + $page->param(nrecurse => $webvar{nrecurse}) if $webvar{nrecurse}; + $page->param(resolver => $webvar{resolver}) if $webvar{resolver}; + + if ($webvar{qfor}) { + my $resolv = Net::DNS::Resolver->new; + $resolv->tcp_timeout(5); # make me adjustable! + $resolv->udp_timeout(5); # make me adjustable! + $resolv->recurse(0) if $webvar{nrecurse}; + $resolv->nameservers($webvar{resolver}) if $webvar{resolver}; + my $query = $resolv->query($webvar{qfor}, $typemap{$webvar{type}}); + if ($query) { + + $page->param(showresults => 1); + + my @answer; + foreach my $rr ($query->answer) { +# next unless $rr->type eq "A" or $rr->type eq 'NS'; + my %row; + my ($host,$ttl,$class,$type,$data) = + ($rr->string =~ /^([0-9a-zA-Z_.-]+)\s+(\d+)\s+([A-Za-z]+)\s+([A-Za-z]+)\s+(.+)$/s); + $row{host} = $host; + $row{ftype} = $type; + $row{rdata} = ($type eq 'SOA' ? "
$data
" : $data); + push @answer, \%row; + } + $page->param(answer => \@answer); + + my @additional; + foreach my $rr ($query->additional) { +# next unless $rr->type eq "A" or $rr->type eq 'NS'; + my %row; + my ($host,$ttl,$class,$type,$data) = + ($rr->string =~ /^([0-9a-zA-Z_.-]+)\s+(\d+)\s+([A-Za-z]+)\s+([A-Za-z]+)\s+(.+)$/); + $row{host} = $host; + $row{ftype} = $type; + $row{rdata} = $data; + push @additional, \%row; + } + $page->param(additional => \@additional); + + my @authority; + foreach my $rr ($query->authority) { +# next unless $rr->type eq "A" or $rr->type eq 'NS'; + my %row; + my ($host,$ttl,$class,$type,$data) = + ($rr->string =~ /^([0-9a-zA-Z_.-]+)\s+(\d+)\s+([A-Za-z]+)\s+([A-Za-z]+)\s+(.+)$/); + $row{host} = $host; + $row{ftype} = $type; + $row{rdata} = $data; + push @authority, \%row; + } + $page->param(authority => \@authority); + + $page->param(usedresolver => $resolv->answerfrom); + $page->param(frtype => $typemap{$webvar{type}}); + + } else { + $page->param(errmsg => $resolv->errorstring); + } + } + ## done DNS query + +} elsif ($webvar{page} eq 'axfr') { + + changepage(page => "domlist", errmsg => "You are not permitted to import domains") + unless ($permissions{admin} || $permissions{domain_create}); + + # don't need this while we've got the dropdown in the menu. hmm. + fill_grouplist("grouplist"); + + $page->param(ifrom => $webvar{ifrom}) if $webvar{ifrom}; + $page->param(rwsoa => $webvar{rwsoa}) if $webvar{rwsoa}; + $page->param(rwns => $webvar{rwns}) if $webvar{rwns}; + $page->param(forcettl => $webvar{forcettl}) if $webvar{forcettl}; + $page->param(newttl => $webvar{newttl}) if $webvar{newttl}; + # This next one is arguably better on by default, but Breaking Things Is Bad, Mmmkay? + $page->param(mergematching => $webvar{mergematching}) if $webvar{mergematching}; + $page->param(dominactive => 1) if (!$webvar{domactive} && $webvar{doit}); # eww. + $page->param(importdoms => $webvar{importdoms}) if $webvar{importdoms}; + + # shut up warning about uninitialized variable + $webvar{doit} = '' if !defined($webvar{doit}); + + if ($webvar{doit} eq 'y' && !$webvar{ifrom}) { + $page->param(errmsg => "Need to set host to import from"); + } elsif ($webvar{doit} eq 'y' && !$webvar{importdoms}) { + $page->param(errmsg => "Need domains to import"); + } elsif ($webvar{doit} eq 'y') { + + # security check - does the user have permission to access this entity? + if (!check_scope(id => $webvar{group}, type => 'group')) { + $page->param(errmsg => "You are not permitted to import domains into the requested group"); + goto DONEAXFR; + } + + # Bizarre Things Happen when you AXFR a null-named zone. + $webvar{importdoms} =~ s/^\s+//; + my @domlist = split /\s+/, $webvar{importdoms}; + my @results; + foreach my $domain (@domlist) { + my %row; + my ($code,$msg) = $dnsdb->importAXFR($webvar{ifrom}, $domain, $webvar{group}, + status => $webvar{domactive}, rwsoa => $webvar{rwsoa}, rwns => $webvar{rwns}, + newttl => ($webvar{forcettl} ? $webvar{newttl} : 0), + merge => $webvar{mergematching}); + $row{domok} = $msg if $code eq 'OK'; + if ($code eq 'WARN') { + $msg =~ s|\n|
|g; + $row{domwarn} = $msg; + } + if ($code eq 'FAIL') { + $msg =~ s|\n|
\n|g; + $row{domerr} = $msg; + } + $msg = "
\n".$msg if $msg =~ m|
|; + $row{domain} = $domain; + push @results, \%row; + } + $page->param(axfrresults => \@results); + } + + # Yes, this is a GOTO target. PTBHTTT. + DONEAXFR: ; + +} elsif ($webvar{page} eq 'whoisq') { + + if ($webvar{qfor}) { + use Net::Whois::Raw; + use Text::Wrap; + +# caching useful? +#$Net::Whois::Raw::CACHE_DIR = "/var/spool/pwhois/"; +#$Net::Whois::Raw::CACHE_TIME = 60; + + my ($dominfo, $whois_server) = whois($webvar{qfor}); +##fixme: if we're given an IP, try rwhois as well as whois so we get the real final data + + # le sigh. idjits spit out data without linefeeds... + $Text::Wrap::columns = 88; + +# &%$@%@# high-bit crap. We should probably find a way to properly recode these +# instead of one-by-one. Note CGI::Simple's escapeHTML() doesn't do more than +# the bare minimum. :/ +# Mainly an XHTML validation thing. + $dominfo = $q->escapeHTML($dominfo); + $dominfo =~ s/\xa9/\©/g; + $dominfo =~ s/\xae/\®/g; + + $page->param(qfor => $webvar{qfor}); + $page->param(dominfo => wrap('','',$dominfo)); + $page->param(whois_server => $whois_server); + } else { + $page->param(errmsg => "Missing host or domain to query in WHOIS") if $webvar{askaway}; + } + +} elsif ($webvar{page} eq 'log') { + + my $id = $curgroup; # we do this because the group log may be called from (almost) any page, + # but the others are much more limited. this is probably non-optimal. + + if ($webvar{ltype} && $webvar{ltype} eq 'user') { +##fixme: where should we call this from? + $id = $webvar{id}; + if (!check_scope(id => $id, type => 'user')) { + $page->param(errmsg => "You are not permitted to view log entries for the requested user"); + goto DONELOG; + } + $page->param(logfor => 'user '.$dnsdb->userFullName($id)); + } elsif ($webvar{ltype} && $webvar{ltype} eq 'dom') { + $id = $webvar{id}; + if (!check_scope(id => $id, type => 'domain')) { + $page->param(errmsg => "You are not permitted to view log entries for the requested domain"); + goto DONELOG; + } + $page->param(logfor => 'domain '.$dnsdb->domainName($id)); + } elsif ($webvar{ltype} && $webvar{ltype} eq 'rdns') { + $id = $webvar{id}; + if (!check_scope(id => $id, type => 'revzone')) { + $page->param(errmsg => "You are not permitted to view log entries for the requested reverse zone"); + goto DONELOG; + } + $page->param(logfor => 'reverse zone '.$dnsdb->revName($id)); + } else { + # Default to listing curgroup log + $page->param(logfor => 'group '.$dnsdb->groupName($id)); + # note that scope limitations are applied via the change-group check; + # group log is always for the "current" group + } + $webvar{ltype} = 'group' if !$webvar{ltype}; + my $lcount = $dnsdb->getLogCount(id => $id, logtype => $webvar{ltype}) or push @debugbits, $dnsdb->errstr; + + $page->param(id => $id); + $page->param(ltype => $webvar{ltype}); + + fill_fpnla($lcount); + fill_pgcount($lcount, "log entries", ''); + $page->param(curpage => $webvar{page}.($webvar{ltype} ? "&ltype=$webvar{ltype}" : '')); + + $sortby = 'stamp'; + $sortorder = 'DESC'; # newest-first; although filtering is probably going to be more useful than sorting +# sort/order + $session->param($webvar{page}.'sortby', $webvar{sortby}) if $webvar{sortby}; + $session->param($webvar{page}.'order', $webvar{order}) if $webvar{order}; + + $sortby = $session->param($webvar{page}.'sortby') if $session->param($webvar{page}.'sortby'); + $sortorder = $session->param($webvar{page}.'order') if $session->param($webvar{page}.'order'); + + # Set up the column headings with the sort info + my @cols = ('fname','username','entry','stamp'); + my %colnames = (fname => 'Name', username => 'Username', entry => 'Log Entry', stamp => 'Date/Time'); + fill_colheads($sortby, $sortorder, \@cols, \%colnames); + +##fixme: increase per-page limit or use separate limit for log? some ops give *lots* of entries... + my $logentries = $dnsdb->getLogEntries(id => $id, logtype => $webvar{ltype}, + offset => $webvar{offset}, sortby => $sortby, sortorder => $sortorder); + $page->param(logentries => $logentries); + +##fixme: +# - filtering +# - show reverse zone column? +# - on log record creation, bundle "parented" log actions (eg, "AXFR record blah for domain foo", +# or "Add record bar for new domain baz") into one entry (eg, "AXFR domain foo", "Add domain baz")? +# need a way to expand this into the complete list, and to exclude "child" entries + + # scope check fail target + DONELOG: ; + +} # end $webvar{page} dance + + +# start output here so we can redirect pages. +print $q->header( -cookie => $sesscookie); +print $header->output; + +##common bits +# mostly things in the menu +if ($webvar{page} ne 'login' && $webvar{page} ne 'badpage') { + $page->param(username => $session->param("username")); + + $page->param(group => $curgroup); + $page->param(groupname => $dnsdb->groupName($curgroup)); + $page->param(logingrp => $dnsdb->groupName($logingroup)); + $page->param(logingrp_num => $logingroup); + +##fixme + $page->param(mayrdns => 1); + + $page->param(mayloc => ($permissions{admin} || $permissions{location_view})); + + $page->param(maydefrec => $permissions{admin}); + $page->param(mayimport => $permissions{admin} || $permissions{domain_create}); + $page->param(maybulk => $permissions{admin} || $permissions{domain_edit} || $permissions{domain_create} || $permissions{domain_delete}); + + $page->param(chggrps => ($permissions{admin} || $permissions{group_create} || $permissions{group_edit} || $permissions{group_delete})); + + # group tree. should go elsewhere, probably + my $tmpgrplist = fill_grptree($logingroup,$curgroup); + $page->param(grptree => $tmpgrplist); + $page->param(subs => ($tmpgrplist ? 1 : 0)); # probably not useful to pass gobs of data in for a boolean + $page->param(inlogingrp => $curgroup == $logingroup); + +# fill in the URL-to-self for the group tree and search-by-letter + $page->param(whereami => $uri_self); +# fill in general URL-to-self + $page->param(script_self => "$ENV{SCRIPT_NAME}?".($curgroup ? "curgroup=$curgroup" : '')); +} + +if (@debugbits) { + print "
\n";
+  foreach (@debugbits) { print; }
+  print "
\n"; +} + +# spit it out +print $page->output; + +if ($debugenv) { + print "
webvar keys: 
\n";
+  foreach my $key (keys %webvar) {
+    print "key: $key\tval: $webvar{$key}\n";
+  }
+  print "
\nsession:\n
\n";
+  my $sesdata = $session->dataref();
+  foreach my $key (keys %$sesdata) {
+    print "key: $key\tval: ".$sesdata->{$key}."\n";
+  }
+  print "
\nENV:\n
\n";
+  foreach my $key (keys %ENV) {
+    print "key: $key\tval: $ENV{$key}\n";
+  }
+  print "
\n"; +} + +print $footer->output; + +# as per the docs, Just In Case +$session->flush(); + +exit 0; + + +sub fill_grptree { + my $root = shift; + my $cur = shift; + my $indent = shift || ' '; + + my @childlist; + + # some magic to control bad offsets on group change + my $grp_uri_self = $uri_self; + $grp_uri_self =~ s/\&offset=[^&]+// unless ($webvar{page} eq 'reclist' && $webvar{defrec} eq 'n'); + + my $grptree = HTML::Template->new(filename => 'templates/grptree.tmpl'); + $dnsdb->getChildren($root, \@childlist, 'immediate'); + return if $#childlist == -1; + my @grouplist; + foreach (@childlist) { + my %row; + $row{grpname} = $dnsdb->groupName($_); + $row{grpnum} = $_; + $row{whereami} = $grp_uri_self; + $row{curgrp} = ($_ == $cur); + $row{expanded} = $dnsdb->isParent($_, 'group', $cur, 'group'); + $row{expanded} = 1 if $_ == $cur; + $row{subs} = fill_grptree($_,$cur,$indent.' '); + $row{indent} = $indent; + push @grouplist, \%row; + } + $grptree->param(indent => $indent); + $grptree->param(treelvl => \@grouplist); + return $grptree->output; +} + +sub changepage { + my %params = @_; # think this works the way I want... + + # cross-site scripting fixup. instead of passing error messages by URL/form + # variable, put them in the session where the nasty user can't meddle. + # these are done here since it's far simpler to pass them in from wherever + # than set them locally everywhere. + foreach my $sessme ('resultmsg','warnmsg','errmsg') { + if (my $tmp = $params{$sessme}) { + $tmp =~ s/^\n//; + $tmp =~ s|\n|
\n|g; + $session->param($sessme, $tmp); + delete $params{$sessme}; + } + } + + # handle user check + my $newurl = "http://$ENV{HTTP_HOST}$ENV{SCRIPT_NAME}?"; + foreach (sort keys %params) { +## fixme: something is undefined here on add location + $newurl .= "&$_=".$q->url_encode($params{$_}); + } + + # Just In Case + $session->flush(); + + print $q->redirect ( -url => $newurl, -cookie => $sesscookie); + exit; +} # end changepage + +# wrap up the usual suspects for result, warning, or error messages to be displayed +sub show_msgs { + if ($session->param('resultmsg')) { + $page->param(resultmsg => $session->param('resultmsg')); + $session->clear('resultmsg'); + } + if ($session->param('warnmsg')) { + $page->param(warnmsg => $session->param('warnmsg')); + $session->clear('warnmsg'); + } + if ($session->param('errmsg')) { + $page->param(errmsg => $session->param('errmsg')); + $session->clear('errmsg'); + } +} # end show_msgs + +sub fillsoa { + my $defrec = shift; + my $revrec = shift; + my $id = shift; + my $preserve = shift || 'd'; # Flag to use webvar fields or retrieve from database + + my $domname = ($defrec eq 'y' ? '' : "DOMAIN"); + + $page->param(defrec => $defrec); + $page->param(revrec => $revrec); + +# i had a good reason to do this when I wrote it... +# $page->param(domain => $domname); +# $page->param(group => $DNSDB::group); + $page->param(isgrp => 1) if $defrec eq 'y'; + $page->param(parent => ($defrec eq 'y' ? $dnsdb->groupName($id) : + ($revrec eq 'n' ? $dnsdb->domainName($id) : $dnsdb->revName($id)) ) ); + +# defaults + $page->param(defcontact => $DNSDB::def{contact}); + $page->param(defns => $DNSDB::def{prins}); + $page->param(defsoattl => $DNSDB::def{soattl}); + $page->param(defrefresh => $DNSDB::def{refresh}); + $page->param(defretry => $DNSDB::def{retry}); + $page->param(defexpire => $DNSDB::def{expire}); + $page->param(defminttl => $DNSDB::def{minttl}); + + $page->param(id => $id); + + if ($preserve eq 'd') { + # there are probably better ways to do this. TMTOWTDI. + my $soa = $dnsdb->getSOA($defrec, $revrec, $id); + + $page->param(prins => ($soa->{prins} ? $soa->{prins} : $DNSDB::def{prins})); + $page->param(contact => ($soa->{contact} ? $soa->{contact} : $DNSDB::def{contact})); + $page->param(refresh => ($soa->{refresh} ? $soa->{refresh} : $DNSDB::def{refresh})); + $page->param(retry => ($soa->{retry} ? $soa->{retry} : $DNSDB::def{retry})); + $page->param(expire => ($soa->{expire} ? $soa->{expire} : $DNSDB::def{expire})); + $page->param(minttl => ($soa->{minttl} ? $soa->{minttl} : $DNSDB::def{minttl})); + $page->param(ttl => ($soa->{ttl} ? $soa->{ttl} : $DNSDB::def{soattl})); + } else { + $page->param(prins => ($webvar{prins} ? $webvar{prins} : $DNSDB::def{prins})); + $page->param(contact => ($webvar{contact} ? $webvar{contact} : $DNSDB::def{contact})); + $page->param(refresh => ($webvar{refresh} ? $webvar{refresh} : $DNSDB::def{refresh})); + $page->param(retry => ($webvar{retry} ? $webvar{retry} : $DNSDB::def{retry})); + $page->param(expire => ($webvar{expire} ? $webvar{expire} : $DNSDB::def{expire})); + $page->param(minttl => ($webvar{minttl} ? $webvar{minttl} : $DNSDB::def{minttl})); + $page->param(ttl => ($webvar{ttl} ? $webvar{ttl} : $DNSDB::def{soattl})); + } +} + +sub showzone { + my $def = shift; + my $rev = shift; + my $id = shift; + + # get the SOA first + my $soa = $dnsdb->getSOA($def, $rev, $id); + + $page->param(contact => $soa->{contact}); + $page->param(prins => $soa->{prins}); + $page->param(refresh => $soa->{refresh}); + $page->param(retry => $soa->{retry}); + $page->param(expire => $soa->{expire}); + $page->param(minttl => $soa->{minttl}); + $page->param(ttl => $soa->{ttl}); + + my $foo2 = $dnsdb->getRecList(defrec => $def, revrec => $rev, id => $id, offset => $webvar{offset}, + sortby => $sortby, sortorder => $sortorder, filter => $filter); + + foreach my $rec (@$foo2) { + $rec->{type} = $typemap{$rec->{type}}; + $rec->{fwdzone} = $rev eq 'n'; + $rec->{distance} = 'n/a' unless ($rec->{type} eq 'MX' || $rec->{type} eq 'SRV'); + $rec->{weight} = 'n/a' unless ($rec->{type} eq 'SRV'); + $rec->{port} = 'n/a' unless ($rec->{type} eq 'SRV'); +# ACLs + $rec->{record_edit} = ($permissions{admin} || $permissions{record_edit}); + $rec->{record_delete} = ($permissions{admin} || $permissions{record_delete}); + $rec->{locname} = '' unless ($permissions{admin} || $permissions{location_view}); +# Timestamps + if ($rec->{expires}) { + $rec->{stamptype} = $rec->{ispast} ? 'expired at' : 'expires at'; + } else { + $rec->{stamptype} = 'valid after'; + } + # strip seconds and timezone? no, not yet. could probably offer a config knob on this display at some point. +# $rec->{stamp} =~ s/:\d\d-\d+$//; + delete $rec->{expires}; + delete $rec->{ispast}; + } + $page->param(reclist => $foo2); +} + +sub fill_recdata { + $page->param(typelist => $dnsdb->getTypelist($webvar{revrec}, $webvar{type})); + +# le sigh. we may get called with many empty %webvar keys + no warnings qw( uninitialized ); + +##todo: allow BIND-style bare names, ASS-U-ME that the name is within the domain? +# prefill or DOMAIN in "Host" space for new records + if ($webvar{revrec} eq 'n') { + my $domroot = ($webvar{defrec} eq 'y' ? 'DOMAIN' : $dnsdb->domainName($webvar{parentid})); + $page->param(name => ($webvar{name} ? $webvar{name} : $domroot)); + $page->param(address => $webvar{address}); + $page->param(distance => $webvar{distance}) + if ($webvar{type} == $reverse_typemap{MX} or $webvar{type} == $reverse_typemap{SRV}); + $page->param(weight => $webvar{weight}) if $webvar{type} == $reverse_typemap{SRV}; + $page->param(port => $webvar{port}) if $webvar{type} == $reverse_typemap{SRV}; + } else { + my $domroot = ($webvar{defrec} eq 'y' ? 'ADMINDOMAIN' : ".$dnsdb->{domain}"); + $page->param(name => ($webvar{name} ? $webvar{name} : $domroot)); + my $zname = ($webvar{defrec} eq 'y' ? 'ZONE' : $dnsdb->revName($webvar{parentid})); + $zname =~ s|\d*/\d+$||; + $page->param(address => ($webvar{address} ? $webvar{address} : $zname)); + } +# retrieve the right ttl instead of falling (way) back to the hardcoded system default + my $soa = $dnsdb->getSOA($webvar{defrec}, $webvar{revrec}, $webvar{parentid}); + $page->param(ttl => ($webvar{ttl} ? $webvar{ttl} : $soa->{minttl})); + $page->param(stamp_until => ($webvar{expires} eq 'until')); + $page->param(stamp => $webvar{stamp}); +} + +sub fill_actypelist { + my $curtype = shift || 'u'; + + my @actypes; + + my %row1 = (actypeval => 'u', actypename => 'user'); + $row1{typesel} = 1 if $curtype eq 'u'; + push @actypes, \%row1; + + my %row2 = (actypeval => 'S', actypename => 'superuser'); + $row2{typesel} = 1 if $curtype eq 'S'; + push @actypes, \%row2; + + $page->param(actypelist => \@actypes); +} + +sub fill_clonemelist { + # shut up some warnings, but don't stomp on caller's state + local $webvar{clonesrc} = 0 if !defined($webvar{clonesrc}); + + my $clones = $dnsdb->getUserDropdown($curgroup, $webvar{clonesrc}); + $page->param(clonesrc => $clones); +} + +sub fill_fpnla { + my $count = shift; + if ($offset eq 'all') { + $page->param(perpage => $perpage); +# uhm.... + } else { + # all these bits only have sensible behaviour if offset is numeric. err, probably. + if ($count > $perpage) { + # if there are more results than the default, always show the "all" link + $page->param(navall => 1); + + if ($offset > 0) { + $page->param(navfirst => 1); + $page->param(navprev => 1); + $page->param(prevoffs => $offset-1); + } + + # show "next" and "last" links if we're not on the last page of results + if ( (($offset+1) * $perpage - $count) < 0 ) { + $page->param(navnext => 1); + $page->param(nextoffs => $offset+1); + $page->param(navlast => 1); + $page->param(lastoffs => int (($count-1)/$perpage)); + } + } else { + $page->param(onepage => 1); + } + } +} # end fill_fpnla() + +sub fill_pgcount { + my $pgcount = shift; + my $pgtype = shift; + my $parent = shift; + + $page->param(ntot => $pgcount); + $page->param(nfirst => (($offset eq 'all' ? 0 : $offset)*$perpage+1)); + $page->param(npglast => ($offset eq 'all' ? $pgcount : + ( (($offset+1)*$perpage) > $pgcount ? $pgcount : (($offset+1)*$perpage) ) + )); + $page->param(pgtype => $pgtype); + $page->param(parent => $parent); + $page->param(filter => $filter); +} # end fill_pgcount() + + +sub listdomains { listzones(); } # temp + +sub listzones { +# ACLs + $page->param(domain_create => ($permissions{admin} || $permissions{domain_create}) ); + $page->param(domain_edit => ($permissions{admin} || $permissions{domain_edit}) ); + $page->param(domain_delete => ($permissions{admin} || $permissions{domain_delete}) ); + + my @childgroups; + $dnsdb->getChildren($curgroup, \@childgroups, 'all') if $searchsubs; + my $childlist = join(',',@childgroups); + + my $count = $dnsdb->getZoneCount(childlist => $childlist, curgroup => $curgroup, revrec => $webvar{revrec}, + filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef) ); + +# fill page count and first-previous-next-last-all bits + fill_pgcount($count,($webvar{revrec} eq 'n' ? 'domains' : 'revzones'),$dnsdb->groupName($curgroup)); + fill_fpnla($count); + + $sortby = ($webvar{revrec} eq 'n' ? 'domain' : 'revnet'); +# sort/order + $session->param($webvar{page}.'sortby', $webvar{sortby}) if $webvar{sortby}; + $session->param($webvar{page}.'order', $webvar{order}) if $webvar{order}; + + $sortby = $session->param($webvar{page}.'sortby') if $session->param($webvar{page}.'sortby'); + $sortorder = $session->param($webvar{page}.'order') if $session->param($webvar{page}.'order'); + +# set up the headers + my @cols = (($webvar{revrec} eq 'n' ? 'domain' : 'revnet'), 'status', 'group'); + my %colheads = (domain => 'Domain', revnet => 'Reverse Zone', status => 'Status', group => 'Group'); + fill_colheads($sortby, $sortorder, \@cols, \%colheads); + + # hack! hack! pthbttt. have to rethink the status column storage, + # or inactive comes "before" active. *sigh* + $sortorder = ($sortorder eq 'ASC' ? 'DESC' : 'ASC') if $sortby eq 'status'; + +# waffle, waffle - keep state on these as well as sortby, sortorder? +##fixme: put this higher so the count doesn't get munched? + $page->param("start$startwith" => 1) if $startwith && $startwith =~ /^(?:[a-z]|0-9)$/; + + $page->param(filter => $filter) if $filter; + $page->param(searchsubs => $searchsubs) if $searchsubs; + + $page->param(group => $curgroup); + + my $zonelist = $dnsdb->getZoneList(childlist => $childlist, curgroup => $curgroup, revrec => $webvar{revrec}, + filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef), + offset => $offset, sortby => $sortby, sortorder => $sortorder + ); +# probably don't need this, keeping for reference for now +# foreach (@$zonelist) { +# } + $page->param(domtable => $zonelist); +} # end listdomains() + + +sub listgroups { + +# security check - does the user have permission to view this entity? + if (!(grep /^$curgroup$/, @viewablegroups)) { + # hmm. Reset the current group to the login group? Yes. Prevents confusing behaviour elsewhere. + $session->param('curgroup',$logingroup); + $page->param(errmsg => "You are not permitted to view the requested group"); + $curgroup = $logingroup; + } + + my @childgroups; + $dnsdb->getChildren($curgroup, \@childgroups, 'all') if $searchsubs; + my $childlist = join(',',@childgroups); + + my ($count) = $dnsdb->getGroupCount(childlist => $childlist, curgroup => $curgroup, + filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef) ); + +# fill page count and first-previous-next-last-all bits + fill_pgcount($count,"groups",''); + fill_fpnla($count); + + $page->param(gid => $curgroup); + + $sortby = 'group'; +# sort/order + $session->param($webvar{page}.'sortby', $webvar{sortby}) if $webvar{sortby}; + $session->param($webvar{page}.'order', $webvar{order}) if $webvar{order}; + + $sortby = $session->param($webvar{page}.'sortby') if $session->param($webvar{page}.'sortby'); + $sortorder = $session->param($webvar{page}.'order') if $session->param($webvar{page}.'order'); + +# set up the headers + my @cols = ('group','parent','nusers','ndomains','nrevzones'); + my %colnames = (group => 'Group', parent => 'Parent Group', nusers => 'Users', ndomains => 'Domains', nrevzones => 'Reverse Zones'); + fill_colheads($sortby, $sortorder, \@cols, \%colnames); + +# waffle, waffle - keep state on these as well as sortby, sortorder? + $page->param("start$startwith" => 1) if $startwith && $startwith =~ /^(?:[a-z]|0-9)$/; + + $page->param(filter => $filter) if $filter; + $page->param(searchsubs => $searchsubs) if $searchsubs; + +# munge sortby for columns in database + $sortby = 'g.group_name' if $sortby eq 'group'; + $sortby = 'g2.group_name' if $sortby eq 'parent'; + + my $glist = $dnsdb->getGroupList(childlist => $childlist, curgroup => $curgroup, + filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef), + offset => $webvar{offset}, sortby => $sortby, sortorder => $sortorder); + + $page->param(grouptable => $glist); +} # end listgroups() + + +sub fill_grouplist { + my $template_var = shift; + my $cur = shift || $curgroup; + + # little recursive utility sub-sub + sub getgroupdrop { + my $root = shift; + my $cur = shift; # to tag the selected group + my $grplist = shift; + my $indent = shift || '    '; + + my @childlist; + $dnsdb->getChildren($root, \@childlist, 'immediate'); + return if $#childlist == -1; + foreach (@childlist) { + my %row; + $row{groupval} = $_; + $row{groupactive} = ($_ == $cur); + $row{groupname} = $indent.$dnsdb->groupName($_); + push @{$grplist}, \%row; + getgroupdrop($_, $cur, $grplist, $indent.'    '); + } + } + + my @grouplist; + push @grouplist, { groupval => $logingroup, groupactive => $logingroup == $curgroup, + groupname => $dnsdb->groupName($logingroup) }; + getgroupdrop($logingroup, $curgroup, \@grouplist); + + $page->param("$template_var" => \@grouplist); +} # end fill_grouplist() + + +sub fill_loclist { + my $cur = shift || $curgroup; + my $defloc = shift || ''; + + return unless ($permissions{admin} || $permissions{location_view}); + + $page->param(location_view => ($permissions{admin} || $permissions{location_view})); + + if ($permissions{admin} || $permissions{record_locchg}) { + my $loclist = $dnsdb->getLocDropdown($cur, $defloc); + $page->param(record_locchg => 1); + $page->param(loclist => $loclist); + } else { + my $loc = $dnsdb->getLoc($defloc); + $page->param(loc_name => $loc->{description}); + } +} # end fill_loclist() + + +sub list_users { + + my @childgroups; + $dnsdb->getChildren($curgroup, \@childgroups, 'all') if $searchsubs; + my $childlist = join(',',@childgroups); + + my $count = $dnsdb->getUserCount(childlist => $childlist, curgroup => $curgroup, + filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef) ); + +# fill page count and first-previous-next-last-all bits + fill_pgcount($count,"users",''); + fill_fpnla($count); + + $sortby = 'user'; +# sort/order + $session->param($webvar{page}.'sortby', $webvar{sortby}) if $webvar{sortby}; + $session->param($webvar{page}.'order', $webvar{order}) if $webvar{order}; + + $sortby = $session->param($webvar{page}.'sortby') if $session->param($webvar{page}.'sortby'); + $sortorder = $session->param($webvar{page}.'order') if $session->param($webvar{page}.'order'); + +# set up the headers + my @cols = ('user','fname','type','group','status'); + my %colnames = (user => 'Username', fname => 'Full Name', type => 'Type', group => 'Group', status => 'Status'); + fill_colheads($sortby, $sortorder, \@cols, \%colnames); + +# waffle, waffle - keep state on these as well as sortby, sortorder? + $page->param("start$startwith" => 1) if $startwith && $startwith =~ /^(?:[a-z]|0-9)$/; + + $page->param(filter => $filter) if $filter; + $page->param(searchsubs => $searchsubs) if $searchsubs; + + my $ulist = $dnsdb->getUserList(childlist => $childlist, curgroup => $curgroup, + filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef), + offset => $webvar{offset}, sortby => $sortby, sortorder => $sortorder); + # Some UI things need to be done to the list (unlike other lists) + foreach my $u (@{$ulist}) { + $u->{eduser} = ($permissions{admin} || + ($permissions{user_edit} && $u->{type} ne 'S') || + ($permissions{self_edit} && $u->{user_id} == $session->param('uid')) ); + $u->{deluser} = ($permissions{admin} || ($permissions{user_delete} && $u->{type} ne 'S')); + $u->{type} = ($u->{type} eq 'S' ? 'superuser' : 'user'); + } + $page->param(usertable => $ulist); +} # end list_users() + + +sub list_locations { + + my @childgroups; + $dnsdb->getChildren($curgroup, \@childgroups, 'all') if $searchsubs; + my $childlist = join(',',@childgroups); + + my $count = $dnsdb->getLocCount(childlist => $childlist, curgroup => $curgroup, + filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef) ); + +# fill page count and first-previous-next-last-all bits + fill_pgcount($count,"locations/views",''); + fill_fpnla($count); + + $sortby = 'user'; +# sort/order + $session->param($webvar{page}.'sortby', $webvar{sortby}) if $webvar{sortby}; + $session->param($webvar{page}.'order', $webvar{order}) if $webvar{order}; + + $sortby = $session->param($webvar{page}.'sortby') if $session->param($webvar{page}.'sortby'); + $sortorder = $session->param($webvar{page}.'order') if $session->param($webvar{page}.'order'); + +# set up the headers + my @cols = ('description', 'iplist', 'group'); + my %colnames = (description => 'Location/View Name', iplist => 'Permitted IPs/Ranges', group => 'Group'); + fill_colheads($sortby, $sortorder, \@cols, \%colnames); + +# waffle, waffle - keep state on these as well as sortby, sortorder? + $page->param("start$startwith" => 1) if $startwith && $startwith =~ /^(?:[a-z]|0-9)$/; + + $page->param(filter => $filter) if $filter; + $page->param(searchsubs => $searchsubs) if $searchsubs; + + my $loclist = $dnsdb->getLocList(childlist => $childlist, curgroup => $curgroup, + filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef), + offset => $webvar{offset}, sortby => $sortby, sortorder => $sortorder); + # Some UI things need to be done to the list + foreach my $l (@{$loclist}) { + $l->{iplist} = "(All IPs)" if !$l->{iplist}; + $l->{edloc} = ($permissions{admin} || $permissions{loc_edit}); + $l->{delloc} = ($permissions{admin} || $permissions{loc_delete}); + } + $page->param(loctable => $loclist); +} # end list_locations() + + +# Generate all of the glop necessary to add or not the appropriate marker/flag for +# the sort order and column in domain, user, group, and record lists +# Takes an array ref and hash ref +sub fill_colheads { + my $sortby = shift; + my $sortorder = shift; + my $cols = shift; + my $colnames = shift; + my $custom = shift; + + my @headings; + + foreach my $col (@$cols) { + my %coldata; + $coldata{page} = $webvar{page}; + $coldata{offset} = $webvar{offset} if $webvar{offset}; + $coldata{sortby} = $col; + $coldata{colname} = $colnames->{$col}; + if ($col eq $sortby) { + $coldata{order} = ($sortorder eq 'ASC' ? 'DESC' : 'ASC'); + $coldata{sortorder} = $sortorder; + } else { + $coldata{order} = 'ASC'; + } + if ($custom) { + foreach my $ckey (keys %$custom) { + $coldata{$ckey} = $custom->{$ckey}; + } + } + push @headings, \%coldata; + } + + $page->param(colheads => \@headings); + +} # end fill_colheads() + + +# we have to do this in a variety of places; let's make it consistent +sub fill_permissions { + my $template = shift; # may need to do several sets on a single page + my $permset = shift; # hashref to permissions on object + my $usercan = shift || \%permissions; # allow alternate user-is-allowed permission block + + foreach (@permtypes) { + $template->param("may_$_" => ($usercan->{admin} || $usercan->{$_})); + $template->param($_ => $permset->{$_}); + } +} + +# so simple when defined as a sub instead of inline. O_o +sub check_scope { + my %args = @_; + my $entity = $args{id} || 0; # prevent the shooting of feet with SQL "... intcolumn = '' ..." + my $entype = $args{type} || ''; + + if ($entype eq 'group') { + return 1 if grep /^$entity$/, @viewablegroups; + } else { + foreach (@viewablegroups) { + return 1 if $dnsdb->isParent($_, 'group', $entity, $entype); + } + } +} Index: /tags/1.2/dns.sql =================================================================== --- /tags/1.2/dns.sql (revision 556) +++ /tags/1.2/dns.sql (revision 556) @@ -0,0 +1,341 @@ +-- these lines could be run as a superuser. alter database name, username, password, group as appropriate. +-- make sure to alter dnsdb.conf to match +-- CREATE GROUP dnsdb; +-- CREATE USER dnsdb WITH UNENCRYPTED PASSWORD 'secret' IN GROUP dnsdb; +-- CREATE DATABASE dnsdb OWNED BY dnsdb; +-- SET SESSION AUTHORIZATION 'dnsdb'; + +-- need a handy place to put eg a DB version identifier - useful for auto-upgrading a DB +CREATE TABLE misc ( + misc_id serial NOT NULL, + key text DEFAULT '' NOT NULL, + value text DEFAULT '' NOT NULL +); + +COPY misc (misc_id, key, value) FROM stdin; +1 dbversion 1.2 +\. + +CREATE TABLE locations ( + location character varying (4) PRIMARY KEY, + loc_id serial UNIQUE, + group_id integer NOT NULL DEFAULT 1, + iplist text NOT NULL DEFAULT '', + description character varying(40) NOT NULL DEFAULT '', + comments text NOT NULL DEFAULT '' +); + +CREATE TABLE default_records ( + record_id serial NOT NULL, + group_id integer DEFAULT 1 NOT NULL, + host text DEFAULT '' NOT NULL, + "type" integer DEFAULT 1 NOT NULL, + val text DEFAULT '' NOT NULL, + distance integer DEFAULT 0 NOT NULL, + weight integer DEFAULT 0 NOT NULL, + port integer DEFAULT 0 NOT NULL, + ttl integer DEFAULT 86400 NOT NULL, + description text +); + +-- default records for the default group +COPY default_records (record_id, group_id, host, "type", val, distance, weight, port, ttl, description) FROM stdin; +1 1 ns1.example.com:hostmaster.DOMAIN 6 10800:3600:604800:5400 0 0 0 86400 \N +2 1 DOMAIN 2 ns2.example.com 0 0 0 7200 \N +3 1 DOMAIN 2 ns1.example.com 0 0 0 7200 \N +4 1 DOMAIN 1 10.0.0.4 0 0 0 7200 \N +5 1 DOMAIN 15 mx1.example.com 10 0 0 7200 \N +6 1 www.DOMAIN 5 DOMAIN 0 0 0 10800 \N +7 1 DOMAIN 16 "v=spf1 a mx -all" 0 0 0 10800 \N +\. + +CREATE TABLE default_rev_records ( + record_id serial NOT NULL, + group_id integer DEFAULT 1 NOT NULL, + host text DEFAULT '' NOT NULL, + "type" integer DEFAULT 1 NOT NULL, + val text DEFAULT '' NOT NULL, + ttl integer DEFAULT 86400 NOT NULL, + description text +); + +COPY default_rev_records (record_id, group_id, host, "type", val, ttl, description) FROM stdin; +1 1 hostmaster.ADMINDOMAIN:ns1.ADMINDOMAIN 6 3600:900:1048576:2560 3600 +2 1 unused-%r.ADMINDOMAIN 65283 ZONE 3600 +3 1 ns2.example.com 2 ZONE 7200 \N +4 1 ns1.example.com 2 ZONE 7200 \N +\. + +CREATE TABLE domains ( + domain_id serial NOT NULL, + "domain" character varying(80) NOT NULL PRIMARY KEY, + group_id integer DEFAULT 1 NOT NULL, + description character varying(255) DEFAULT ''::character varying NOT NULL, + status integer DEFAULT 1 NOT NULL, + zserial integer, + sertype character(1) DEFAULT 'D'::bpchar, + changed boolean DEFAULT true NOT NULL, + default_location character varying (4) DEFAULT '' NOT NULL +); +-- ~2x performance boost iff most zones are fed to output from the cache +CREATE INDEX dom_status_index ON domains (status); + + +CREATE TABLE revzones ( + rdns_id serial NOT NULL, + revnet cidr NOT NULL PRIMARY KEY, + group_id integer DEFAULT 1 NOT NULL, + description character varying(255) DEFAULT ''::character varying NOT NULL, + status integer DEFAULT 1 NOT NULL, + zserial integer, + sertype character(1) DEFAULT 'D'::bpchar, + changed boolean DEFAULT true NOT NULL, + default_location character varying (4) DEFAULT '' NOT NULL +); +CREATE INDEX rev_status_index ON revzones USING btree (status); + +CREATE TABLE groups ( + group_id serial NOT NULL, + parent_group_id integer DEFAULT 1 NOT NULL, + group_name character varying(255) DEFAULT ''::character varying NOT NULL, + permission_id integer DEFAULT 1 NOT NULL, + inherit_perm boolean DEFAULT true NOT NULL +); + +-- Provide a basic default group +COPY groups (group_id, parent_group_id, permission_id, group_name) FROM stdin; +1 1 1 default +\. + +-- entry is text due to possible long entries from AXFR - a domain with "many" +-- odd records will overflow varchar(200) +CREATE TABLE log ( + log_id serial NOT NULL, + domain_id integer, + user_id integer, + group_id integer, + email character varying(60), + name character varying(60), + entry text, + stamp timestamp with time zone DEFAULT now(), + rdns_id integer +); + +CREATE TABLE permissions ( + permission_id serial NOT NULL, + "admin" boolean DEFAULT false NOT NULL, + self_edit boolean DEFAULT false NOT NULL, + group_create boolean DEFAULT false NOT NULL, + group_edit boolean DEFAULT false NOT NULL, + group_delete boolean DEFAULT false NOT NULL, + user_create boolean DEFAULT false NOT NULL, + user_edit boolean DEFAULT false NOT NULL, + user_delete boolean DEFAULT false NOT NULL, + domain_create boolean DEFAULT false NOT NULL, + domain_edit boolean DEFAULT false NOT NULL, + domain_delete boolean DEFAULT false NOT NULL, + record_create boolean DEFAULT false NOT NULL, + record_edit boolean DEFAULT false NOT NULL, + record_delete boolean DEFAULT false NOT NULL, + user_id integer UNIQUE, + group_id integer UNIQUE, + record_locchg boolean DEFAULT false NOT NULL, + location_create boolean DEFAULT false NOT NULL, + location_edit boolean DEFAULT false NOT NULL, + location_delete boolean DEFAULT false NOT NULL, + location_view boolean DEFAULT false NOT NULL +); + +-- Need *two* basic permissions; one for the initial group, one for the default admin user +COPY permissions (permission_id, "admin", self_edit, group_create, group_edit, group_delete, user_create, user_edit, user_delete, domain_create, domain_edit, domain_delete, record_create, record_edit, record_delete, user_id, group_id, record_locchg, location_create, location_edit, location_delete, location_view) FROM stdin; +1 f f f f f f f f t t t t t t \N 1 f f f f f +2 t f f f f f f f f f f f f f 1 \N f f f f f +\. + +-- rdns_id defaults to 0 since many records will not have an associated rDNS entry. +CREATE TABLE records ( + domain_id integer NOT NULL DEFAULT 0, + record_id serial NOT NULL, + host text DEFAULT '' NOT NULL, + "type" integer DEFAULT 1 NOT NULL, + val text DEFAULT '' NOT NULL, + distance integer DEFAULT 0 NOT NULL, + weight integer DEFAULT 0 NOT NULL, + port integer DEFAULT 0 NOT NULL, + ttl integer DEFAULT 7200 NOT NULL, + description text, + rdns_id integer NOT NULL DEFAULT 0, + location character varying (4) DEFAULT '' NOT NULL, + stamp TIMESTAMP WITH TIME ZONE DEFAULT 'epoch' NOT NULL, + expires boolean DEFAULT 'n' NOT NULL, + stampactive boolean DEFAULT 'n' NOT NULL +); +CREATE INDEX rec_domain_index ON records USING btree (domain_id); +CREATE INDEX rec_revzone_index ON records USING btree (rdns_id); +CREATE INDEX rec_types_index ON records USING btree ("type"); + +CREATE TABLE rectypes ( + val integer NOT NULL, + name character varying(20) NOT NULL, + stdflag integer DEFAULT 1 NOT NULL, + listorder integer DEFAULT 255 NOT NULL, + alphaorder integer DEFAULT 32768 NOT NULL +); + +-- Types are required. NB: these are vaguely read-only too +-- data from http://www.iana.org/assignments/dns-parameters +COPY rectypes (val, name, stdflag, listorder, alphaorder) FROM stdin; +1 A 1 1 1 +2 NS 2 10 37 +3 MD 5 255 29 +4 MF 5 255 30 +5 CNAME 2 12 9 +6 SOA 0 0 53 +7 MB 5 255 28 +8 MG 5 255 31 +9 MR 5 255 33 +10 NULL 5 255 43 +11 WKS 5 255 64 +12 PTR 3 5 46 +13 HINFO 5 255 18 +14 MINFO 5 255 32 +15 MX 1 11 34 +16 TXT 2 13 60 +17 RP 4 255 48 +18 AFSDB 5 255 4 +19 X25 5 255 65 +20 ISDN 5 255 21 +21 RT 5 255 50 +22 NSAP 5 255 38 +23 NSAP-PTR 5 255 39 +24 SIG 5 255 51 +25 KEY 5 255 23 +26 PX 5 255 47 +27 GPOS 5 255 17 +28 AAAA 1 3 3 +29 LOC 5 255 25 +30 NXT 5 255 44 +31 EID 5 255 15 +32 NIMLOC 5 255 36 +33 SRV 1 14 55 +34 ATMA 5 255 6 +35 NAPTR 5 255 35 +36 KX 5 255 24 +37 CERT 5 255 8 +38 A6 5 3 2 +39 DNAME 5 255 12 +40 SINK 5 255 52 +41 OPT 5 255 45 +42 APL 5 255 5 +43 DS 5 255 14 +44 SSHFP 5 255 56 +45 IPSECKEY 5 255 20 +46 RRSIG 5 255 49 +47 NSEC 5 255 40 +48 DNSKEY 5 255 13 +49 DHCID 5 255 10 +50 NSEC3 5 255 41 +51 NSEC3PARAM 5 255 42 +55 HIP 5 255 19 +99 SPF 5 255 54 +100 UINFO 5 255 62 +101 UID 5 255 61 +102 GID 5 255 16 +103 UNSPEC 5 255 63 +249 TKEY 5 255 58 +250 TSIG 5 255 59 +251 IXFR 5 255 22 +252 AXFR 5 255 7 +253 MAILB 5 255 27 +254 MAILA 5 255 26 +32768 TA 5 255 57 +32769 DLV 5 255 11 +\. + +-- Custom types (ab)using the "Private use" range from 65280 to 65534 +COPY rectypes (val, name, stdflag, listorder, alphaorder) FROM stdin; +65280 A+PTR 2 2 2 +65281 AAAA+PTR 2 4 4 +65282 PTR template 3 6 2 +65283 A+PTR template 2 7 2 +65284 AAAA+PTR template 2 8 2 +65285 Delegation 2 9 2 +\. + +CREATE TABLE users ( + user_id serial NOT NULL, + group_id integer DEFAULT 1 NOT NULL, + username character varying(60) NOT NULL, + "password" character varying(34) NOT NULL, + firstname character varying(60), + lastname character varying(60), + phone character varying(15), + "type" character(1) DEFAULT 'S'::bpchar NOT NULL, + status integer DEFAULT 1 NOT NULL, + permission_id integer DEFAULT 1 NOT NULL, + inherit_perm boolean DEFAULT true NOT NULL +); + +-- create initial default user? may be better to create an "initialize" script or something +COPY users (user_id, group_id, username, "password", firstname, lastname, phone, "type", status, permission_id, inherit_perm) FROM stdin; +1 1 admin $1$PfEBUv9d$wV2/UG4gmKk08DLmdE8/d. Initial User \N S 1 2 f +\. + +-- +-- contraints. add these here so initial data doesn't get added strangely. +-- + +-- primary keys +ALTER TABLE ONLY permissions + ADD CONSTRAINT permissions_permission_id_key UNIQUE (permission_id); + +ALTER TABLE ONLY groups + ADD CONSTRAINT groups_group_id_key UNIQUE (group_id); + +ALTER TABLE ONLY domains + ADD CONSTRAINT domains_domain_id_key UNIQUE (domain_id); + +ALTER TABLE ONLY default_records + ADD CONSTRAINT default_records_pkey PRIMARY KEY (record_id); + +ALTER TABLE ONLY records + ADD CONSTRAINT records_pkey PRIMARY KEY (record_id); + +ALTER TABLE ONLY rectypes + ADD CONSTRAINT rectypes_pkey PRIMARY KEY (val, name); + +ALTER TABLE ONLY users + ADD CONSTRAINT users_pkey PRIMARY KEY (username); + +ALTER TABLE ONLY users + ADD CONSTRAINT uidu UNIQUE (user_id); + +-- foreign keys +-- fixme: permissions FK refs +ALTER TABLE ONLY locations + ADD CONSTRAINT "locations_group_id_fkey" FOREIGN KEY (group_id) REFERENCES groups(group_id); + +ALTER TABLE ONLY domains + ADD CONSTRAINT "$1" FOREIGN KEY (group_id) REFERENCES groups(group_id); + +ALTER TABLE ONLY default_records + ADD CONSTRAINT "$1" FOREIGN KEY (group_id) REFERENCES groups(group_id); + +ALTER TABLE ONLY users + ADD CONSTRAINT "$1" FOREIGN KEY (group_id) REFERENCES groups(group_id); + +ALTER TABLE ONLY revzones + ADD CONSTRAINT "$1" FOREIGN KEY (group_id) REFERENCES groups(group_id); + +ALTER TABLE ONLY groups + ADD CONSTRAINT group_parent FOREIGN KEY (parent_group_id) REFERENCES groups(group_id); + +-- set starting sequence numbers, since we've inserted data before they're active +-- only set the ones that have data loaded with \copy, and obey the convention +-- that comes out of pg_dump +SELECT pg_catalog.setval('misc_misc_id_seq', 1, true); +SELECT pg_catalog.setval('default_records_record_id_seq', 8, true); +SELECT pg_catalog.setval('default_rev_records_record_id_seq', 4, true); +SELECT pg_catalog.setval('groups_group_id_seq', 1, true); +SELECT pg_catalog.setval('permissions_permission_id_seq', 2, true); +SELECT pg_catalog.setval('users_user_id_seq', 1, true); Index: /tags/1.2/dnsadmin.spec =================================================================== --- /tags/1.2/dnsadmin.spec (revision 556) +++ /tags/1.2/dnsadmin.spec (revision 556) @@ -0,0 +1,106 @@ +# spec file for DNS Administrator +# $Id$ + +# A collection of magic for packaging with debbuild (https://secure.deepnet.cx/trac/debbuild +# Sets the release "number" such that dist upgrades will upgrade in the right order. +%if "%{debdist}" == "sarge" +%define errata 0 +%endif +%if "%{debdist}" == "dapper" +%define errata 1 +%endif +%if "%{debdist}" == "etch" +%define errata 2 +%endif +%if "%{debdist}" == "lenny" +%define errata 3 +%endif +%if "%{debdist}" == "squeeze" +%define errata 4 +%endif +%if %{?relnum:0}%{?!relnum:1} +%define relnum 1 +%endif + +# redefine release only if debdist is defined +%if %{?debdist:1}%{?!debdist:0} +%define release %{relnum}.%{errata}%{debdist} +%else +%define release 1 +%endif + +# handle flag for parallel-versions installs. +%if %{?para_versions:1}%{?!para_versions:0} +%define pkg_leaf dnsdb-%{version} +%define cfg_leaf dnsdb/%{version} +%else +%define pkg_leaf dnsdb +%define cfg_leaf dnsdb +%endif + +Summary: DeepNet DNS Administrator +Name: dnsadmin +Version: #VERSION# +Release: %{release} +Group: Applications/System +Source: %{name}-%{version}.tar.gz +Packager: Kris Deugau +BuildRoot: /var/tmp/%{name}-%{version} +License: GPL 3+ +BuildArch: noarch + +# not absolutely required: +Requires: perl(NetAddr::IP) >= 4 + +# rpmbuild should fill in the rest of the deps. Debian's tools aren't so friendly. :/ + +%if %{_vendor} == "debbuild" +# ah, Debian, how we do *love* thee so... *eyeroll* +Requires: libfrontier-rpc-perl >= 0.07b4, perl(CGI::Simple), perl(HTML::Template), perl(Net::DNS) +Requires: perl(CGI::Session), perl(Crypt::PasswdMD5), perl(Digest::MD5), perl(Net::Whois::Raw) +%endif + +%description +A web-based DNS management tool + +%prep +%setup + +%build + +%install +# le sigh. rpm's makeinstall macro includes the buildroot in the dirs, so it will break here. :/ +make \ + prefix=%{_prefix} \ + exec_prefix=%{_exec_prefix} \ + bindir=%{_bindir} \ + sbindir=%{_sbindir} \ + sysconfdir=%{_sysconfdir} \ + datadir=%{_datadir} \ + includedir=%{_includedir} \ + libdir=%{_libdir} \ + libexecdir=%{_libexecdir} \ + localstatedir=%{_localstatedir} \ + sharedstatedir=%{_sharedstatedir} \ + mandir=%{_mandir} \ + infodir=%{_infodir} \ + install DESTDIR=$RPM_BUILD_ROOT PARA_VERSIONS=%{?para_versions:1}%{?!para_versions:0} + +%clean +if [ "$RPM_BUILD_ROOT" != "/" ]; then + rm -rf $RPM_BUILD_ROOT +fi + +%files +%dir %{_datadir}/%{pkg_leaf} +%attr(-,-,0755) %{_datadir}/%{pkg_leaf}/*.cgi +%attr(-,-,0755) %{_datadir}/%{pkg_leaf}/*.pl +%{_datadir}/%{pkg_leaf}/DNSDB.pm +%{_datadir}/%{pkg_leaf}/images +%{_datadir}/%{pkg_leaf}/templates +%dir %{_sysconfdir}/%{cfg_leaf} +%config %{_sysconfdir}/%{cfg_leaf}/dnsdb.conf + +%changelog +* Fri Jan 13 2012 Kris Deugau 1.0-1 +- Initial package Index: /tags/1.2/dnsdb.conf =================================================================== --- /tags/1.2/dnsdb.conf (revision 556) +++ /tags/1.2/dnsdb.conf (revision 556) @@ -0,0 +1,45 @@ +# System-wide config for DNSDB + +# Database connection info +#dbname = dsndb +#dbuser = dnsdb +#dbpass = dnsdbpwd +#dbhost = dnsdbhost + +# Mail settings +#mailhost = smtp.example.com +#mailnotify = dns@example.com +#mailsender = hostmaster@example.com +#mailname = Example Corp DNS Administrator +#orgname = Example Corp +#domain = example.com + +# session - note this is fed directly to CGI::Session +# timeout supports (s)econds, (m)inutes, (h)ours, (d)ays, (w)eeks, (M)months, or (y)ears +#timeout = 3h +#sessiondir = /var/lib/dnsdb + +## misc + +# flag to indicate if failed changes should be logged +#log_failures = 1 +# number of entries to display in lists +#perpage = 25 +# maximum number of FCGI requests to serve before reloading/restarting FCGI +#max_fcgi_requests = 10 +# path for per-zone cache files for export +#exportcache = /var/cache/dnsdb + +# always refresh the cache from the DB on export if 1/on +# if 0/off, use the "changed" flag on a zone to determine if we export from +# the DB or read from the existing cache file. +#force_refresh = 1 + +# RPC ACL +# A comma-separated list starting with an abstract "system name" +# (passed by an RPC caller), followed by a list of IP addresses +# allowed to make RPC calls with that name. +# Finer-grained access control must be handled by the caller. +#rpc_iplist = billing, 192.168.0.11 +#rpc_iplist = billing, 172.12.12.12 +#rpc_iplist = custportal, 192.168.1.12, 192.168.1.13 Index: /tags/1.2/export.pl =================================================================== --- /tags/1.2/export.pl (revision 556) +++ /tags/1.2/export.pl (revision 556) @@ -0,0 +1,33 @@ +#!/usr/bin/perl +# Absolutely minimal DNS record export script +## +# $Id$ +# Copyright 2012,2013 Kris Deugau +# +# 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 . +## + +use strict; +use warnings; + +# don't remove! required for GNU/FHS-ish install from tarball +use lib '.'; ##uselib## + +use DNSDB; + +my $dnsdb = new DNSDB; + +open TINYDATA, ">tinydata"; + +$dnsdb->export('tiny', *TINYDATA); Index: /tags/1.2/index.shtml =================================================================== --- /tags/1.2/index.shtml (revision 556) +++ /tags/1.2/index.shtml (revision 556) @@ -0,0 +1,1 @@ + Index: /tags/1.2/notes =================================================================== --- /tags/1.2/notes (revision 556) +++ /tags/1.2/notes (revision 556) @@ -0,0 +1,328 @@ +web frontend: + +workflow: + +log in, see domain list from current group + +-> "current group" includes all subgroups? (hairy SQL) + + +logic: +-> need to pass session ID on every call, otherwise we don't know who we are +-> should check ACLs on every call in case of changing permissions +-> should be able to store all webvar bits in the session + + +ooo! ooo! what about "clone existing domain"? + + +export for tinydns: arbitrary record data is binary blob, decomposed by hex octets to octal codes + + +components: +menu list (actions/sections) +domain list +group tree +user list + pages> + + + +time tables: +3600: 1h +7200: 2h +10800: 3h +14400: 4h +21600: 6h +43200: 12h +86400: 1d +172800: 2d +604800: 7d (1w) + +valid records: + +nb: wildcards are supported for most types. use with extreme caution! (I don't plan on writing +tools that will create them.) + +.fqdn:ip:x:ttl:timestamp:lo + -> x.fqdn is a nameserver at ip, SOA sets x.fqdn as master with hostmaster@fqdn as contact + -> if x contains a . that is used as the NS name +(Not much use for us) + +Zfqdn:primary:contact:serial:refresh:retry:expire:minttl:recttl:(timestamp:lo) + -> SOA for fqdn + +&fqdn:ip:x:ttl:timestamp:lo + -> x.fqdn is a nameserver + -> if x contains a . that is used as the NS name + -> ip may be omitted; A record for fqdn->ip is created otherwise + +=fqdn:ip:ttl:timestamp:lo + -> A record and matching PTR record with fqdn and ip + ++fqdn:ip:ttl:timestamp:lo + -> A record + +^ptr:fqdn:ttl:timestamp:lo + -> PTR record. note ptr must be reverse-IP format ending in .in-addr.arpa + +@fqdn:ip:x:dist:ttl:timestamp:lo + -> MX. Dist defaults to 0. + -> ip may be omitted; A record for fqdn->ip is created otherwise + +-fqdn:ip:ttl:timestamp:lo + -> ignored + +'fqdn:text:ttl:timestamp:lo + -> TXT record + -> octal-encode special characters in text as \nnn + +Cfqdn:name:ttl:timestamp:lo + -> CNAME for fqdn pointing to name + +:fqdn:n:data:ttl:timestamp:lo + -> Generic data, of type n (n is a 16-bit unsigned integer) + 17 is RP + 16 is TXT + 2 (NS), 5 (CNAME), 6 (SOA), 12 (PTR), 15 (MX) and 252 (AXFR) (WTF?) should not be used + -> data must use octal escapes for : or nondisplayable characters. axfr-get seems to escape all + non-alphanumerics, therefore so will we. + +two primary groups of data: +-> forward zones + -> local master zones + -> local slave zones +-> reverse zones +- note that it would be really nice to eliminate duplicated A records (+domain.com:ip:: plus =domain.com:ip::) + +operations: +-> import zone data (BIND*, djbdns, vegadns-mysql) + -> allow overwrite of existing SOA +-> export data (BIND*, djbdns) +-> add zone/domain + -> as slave + -> as master +-> delete zone/domain +-> add record to domain +-> remove record from domain +-> change record + -> A record IP + -> CNAME destination + -> MX destination + -> MX priority + -> A <-> CNAME ? + -> flag record as "primary" A record for an IP (means that PTR will set that name as rDNS) +-> force propagation (execute propagation script) +-> User ACL fiddling: + -> take IPDB model, include groups/delegation/etc + "admin" -> nominally full access to anything/everything + "staff" -> general access to all domains, can create users and delegate domains to them + "bulk hoster" -> customer with more than one domain, (can create users and delegate domains to them)? + "user" -> customer with one domain + + +recommended SOA/TTL/etc times: +refresh 86400 (24h), retry 7200 (2h), expire 2592000 (30d), ttl 345600 (4d) + +Qs re: new servers: +-> IPs for cache/authoritative? + + +flow of data: +user input -> database -> local "zone" data -> rsync/scp to slaves + +don't use "domain ID" goop; its only advantage is slightly lower disk use. otherwise it's more +complicated, less traceable thru the DB manually + + +db structure (current) + +domains: +| domain_id | int(11) | | MUL | NULL | auto_increment | +| domain | varchar(100) | | | | | +| group_id | int(11) | YES | | NULL | | +| description | varchar(255) | | | | | +| status | enum('active','inactive') | | | inactive | | + +records: +| domain_id | int(11) | | MUL | 0 | | +| record_id | int(11) | | PRI | NULL | auto_increment | +| host | varchar(100) | | | | | +| type | char(1) | YES | | NULL | | +| val | varchar(100) | YES | | NULL | | +| distance | int(4) | YES | | 0 | | +| weight | int(4) | YES | | NULL | | - for SRV only +| port | int(4) | YES | | NULL | | - for SRV only +| ttl | int(11) | | | 86400 | | +| description | varchar(255) | | | | | + +default_records is a duplicate of records structurally + +log: (not sure how useful this really is, in this form...) +| domain_id | int(11) | | | 0 | | +| user_id | int(11) | | | 0 | | +| group_id | int(11) | | | 0 | | +| email | varchar(60) | | | | | +| name | varchar(60) | | | | | +| entry | varchar(200) | | | | | +| time | int(11) | | | 0 | | + +db structure (proposed) + +domains: +domain char(128) pk, indexed +group char(32) fk, indexed? +status enum? +masterns char(64) +email char(128) +serial long int (needs 2^32 at least) +refresh long int needs semi-sane default +retry long int needs semi-sane default +expire long int needs semi-sane default +minttl long int needs semi-sane default +ctime timestamp +mtime timestamp + +records: +recid serial +domain char(128) fk, indexed? +host char(128) pk, indexed +type enum? +val char(256) to allow for 255-char TXT records +extra char(10) 10 should be enough to express any needs for MX, SRV, or anything else...right? +ttl long int +ctime timestamp +mtime timestamp + +default records to be either database-coded as default values or coded in er, code. +-> hrm. + database-level defaults are "recommended practice" according to the cricket book + code-level defaults may be hardcoded (easy) or loaded from a config file (harder, but cleaner) + all must be overrideable by a database-table-stored "local policy defaults" widget + +add domain: + -> need domain name + -> IP/"company default" radio button pair, with some Javascript to change defaults for: + -> radio buttons with sane defaults for standard hosts (www/mail/ftp/smtp) + -> www CNAME @ + -> FTP CNAME @ + -> mail CNAME mail.company.com + -> smtp CNAME smtp.company.com + -> MX defaults to + ++----------------------------------------------------------------+ +| Domain: _________________________________ | +| o Company hosting o Slave zone o Custom settings | ++----------------------------------------------------------------+ + +add_domain($domain,$class) +update_domain($domain,$group,$status,[$contact,$primary,$serial,$ttl,$refresh,$retry,$expire,$minttl]) +delete_domain($domain) +lock_domain($domain) -hm.. lock/unlock may be admin-level "don't touch!" flags vs "active/inactive" flags +unlock_domain($domain) +add_record($domain,$host,$type,$value,$extra,$ttl) +update_record($id,$host,$type,$val,$extra,$ttl) +delete_record($id) +export_data($domain,$format) ->takes special arg for all zones. $format -> BIND or djb (implement DJB first) +update_nameservers() + + +FFFF:FFFF:FFFF:FFFF : FFFF:FFFF:FFFF:FFFF +we get: + ::FFFF:FFFF +we assign: + ::: (/64, nominally equivalent to current /32, logically) + :::FF (/56, bitwise equivalent to current /24 relative to /32) + :::FFFF (/48, bitwise equivalent to current /16 relative to /24) + +Allocations SHOULD leave space for growth + + +SELECT u.user_id, u.email, u.firstname, u.lastname, u.type, g.group_name + "FROM users u ". + "INNER JOIN groups g ON u.group_id=g.group_id ". + ($offset eq 'all' ? '' : " LIMIT $perpage OFFSET ".$offset*$perpage) + + +SELECT g.group_id, g.group_name, g2.group_name, g.children, count(distinct(u.email)), count(distinct(d.domain)) +FROM groups g +INNER JOIN groups g2 ON g2.group_id=g.parent_group_id +LEFT OUTER JOIN users u ON u.group_id=g.group_id +LEFT OUTER JOIN domains d ON d.group_id=g.group_id +GROUP BY g.group_id, g.group_name, g2.group_name, g.children + + + + record_id | group_id | host | type | val | distance | weight | port | ttl | description +-----------+----------+----------------------------------------+------+-------------------------+----------+--------+------+-------+------------- + 1 | 1 | ns1.example.com:hostmaster.DOMAIN | 6 | 10800:3600:604800:10800 | 0 | 0 | 0 | 86400 | + 25 | 1 | DOMAIN | 1 | 10.2.3.4 | 0 | 0 | 0 | 7200 | + 2 | 1 | DOMAIN | 15 | mx1.example.com | 10 | 0 | 0 | 7200 | + 26 | 1 | DOMAIN | 15 | mx2.example.com | 10 | 0 | 0 | 7200 | + 27 | 1 | DOMAIN | 2 | ns2.example.com | 0 | 0 | 0 | 7200 | + 22 | 1 | DOMAIN | 2 | ns1.example.com | 0 | 0 | 0 | 7200 | + 31 | 1 | www.DOMAIN | 5 | DOMAIN | 0 | 0 | 0 | 10800 | + 32 | 1 | DOMAIN | 16 | "v=spf1 a mx -all" | 0 | 0 | 0 | 10800 | + 17 | 1 | DOMAIN | 33 | srv.example.com | 15 | 2 | 325 | 7200 | + + +serial in domains table +'manual' - date+inc +'manual' - monotone +'auto' - generated (TinyDNS only; uses auto(date) for other exports) + +add enable/disable for individual records + +log_id? domain_id? group_id user_id action detail timestamp + + + + LOG_EMERG + A panic condition. + + LOG_ALERT + A condition that should be corrected immediately, such as a corrupted system database. + + LOG_CRIT + Critical conditions, such as hard device errors. + + LOG_ERR + Errors. + + LOG_WARNING + + Warning messages. + + LOG_NOTICE + Conditions that are not error conditions, but that may require special handling. + + LOG_INFO + Informational messages. + + LOG_DEBUG +#define LOG_EMERG 0 /* system is unusable */ +#define LOG_ALERT 1 /* action must be taken immediately */ +#define LOG_CRIT 2 /* critical conditions */ +#define LOG_ERR 3 /* error conditions */ +#define LOG_WARNING 4 /* warning conditions */ +#define LOG_NOTICE 5 /* normal but significant condition */ +#define LOG_INFO 6 /* informational */ +#define LOG_DEBUG 7 /* debug-level messages */ + + + +another web-UI for DNS record maintenance: +http://www.henriknordstrom.net/code/webdns/ + + +sub-octet delegation for v4 nets: +p 216-218 in cricket^Wgrasshopper book + +Also see new draft spec, applies to both v4 and v6: +http://tools.ietf.org/html/draft-gersch-dnsop-revdns-cidr-01 + +new custom types "Forward delegation" and "Reverse delegation"? + - forward creates NS records in parent for .parent + - reverse creates NS records plus CNAMEs for sub-octet zones +-> would solve the conundrum of what to do with the unsightly CNAME + records presented in the UI to indicate sub-octet zone delegation Index: /tags/1.2/reverse-patterns.html =================================================================== --- /tags/1.2/reverse-patterns.html (revision 556) +++ /tags/1.2/reverse-patterns.html (revision 556) @@ -0,0 +1,83 @@ + + + + + Reverse DNS Template Reference + + + + + + +
+

Reverse DNS Template Reference

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Substitution patternExample expansion using 192.168.23.45
Whole-IP patterns
Dashed IP%i192-168-23-45
Reverse dashed IP%r45-23-168-192
Hex-coded IP%hc0a8172d
Decimal IP%d323241453
Per-octet patterns (1, 2, 3, or 4 specify + the octet; d, h or 0 specify decimal, hexidecimal, or + 0-padded decimal)
First octet, decimal%1d192
Third octet, 0-padded%30023
Fourth octet, hexidecimal%4h2d
All octets, different expansions%1h-%2d-%30-%4hc0-168-023-2d
+

%i and %r also allow explicitly defining the separator; eg %.i + or %_r. '.', '-', and '_' are the only characters
+ supported since DNS names may not contain most other + non-alphanumerics.

+

%blank% may be used to specifically prevent template expansion on + a segment of a block if desired; eg, if
+ 192.168.23.0/24 has "unused-%i.example.com" set, adding an A+PTR + template for 192.168.23.48/30 of
+ "%blank%" will leave 192.168.23.48 through .51 without PTR records + unless specific entries exist for those IPs.

+

+ + Index: /tags/1.2/templates/adddomain.tmpl =================================================================== --- /tags/1.2/templates/adddomain.tmpl (revision 556) +++ /tags/1.2/templates/adddomain.tmpl (revision 556) @@ -0,0 +1,5 @@ + + + + + Index: /tags/1.2/templates/addgroup.tmpl =================================================================== --- /tags/1.2/templates/addgroup.tmpl (revision 556) +++ /tags/1.2/templates/addgroup.tmpl (revision 556) @@ -0,0 +1,5 @@ + + + + + Index: /tags/1.2/templates/addrec.tmpl =================================================================== --- /tags/1.2/templates/addrec.tmpl (revision 556) +++ /tags/1.2/templates/addrec.tmpl (revision 556) @@ -0,0 +1,5 @@ + + + + + Index: /tags/1.2/templates/addrevzone.tmpl =================================================================== --- /tags/1.2/templates/addrevzone.tmpl (revision 556) +++ /tags/1.2/templates/addrevzone.tmpl (revision 556) @@ -0,0 +1,5 @@ + + + + + Index: /tags/1.2/templates/adduser.tmpl =================================================================== --- /tags/1.2/templates/adduser.tmpl (revision 556) +++ /tags/1.2/templates/adduser.tmpl (revision 556) @@ -0,0 +1,5 @@ + + + + + Index: /tags/1.2/templates/axfr.tmpl =================================================================== --- /tags/1.2/templates/axfr.tmpl (revision 556) +++ /tags/1.2/templates/axfr.tmpl (revision 556) @@ -0,0 +1,77 @@ + + + + + +
+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Error:
Import domains via AXFR
Import from host: value="" />
Import to group: + +
Rewrite SOA to group default? checked="checked" />
Rewrite NS to group default? checked="checked" />
Force all TTLs to new value? checked="checked" /> value="" />
Merge records on A+PTR or AAAA+PTR match? checked="checked" />
Import as active? checked="checked" />
Domains to import:
(one per line)
+ +
+
+ + +
+ + + + + + + + + + + +
AXFR Import Results
Imported OKImport OK but:
+		Failed:
+ + +
Index: /tags/1.2/templates/badpage.tmpl =================================================================== --- /tags/1.2/templates/badpage.tmpl (revision 556) +++ /tags/1.2/templates/badpage.tmpl (revision 556) @@ -0,0 +1,15 @@ +
+ +Bad page requested: +
+ +
+Press the 'Back' button on your browser to continue. + + +Template error: +
+ +
+ +
Index: /tags/1.2/templates/bulkchange.tmpl =================================================================== --- /tags/1.2/templates/bulkchange.tmpl (revision 556) +++ /tags/1.2/templates/bulkchange.tmpl (revision 556) @@ -0,0 +1,20 @@ + + + + + +
+ + + + + + + + + + + + +
Bulk Change Results ()
+
Index: /tags/1.2/templates/bulkdomain.tmpl =================================================================== --- /tags/1.2/templates/bulkdomain.tmpl (revision 556) +++ /tags/1.2/templates/bulkdomain.tmpl (revision 556) @@ -0,0 +1,58 @@ + + + + +
+ +
+
+ + + + + + + + +
+ + + + + + + + + + + + + + +
Bulk Domain Changes
Action: + Move to group:
+ Deactivate
+ Activate
 + Delete
 +
Domains to change:
+
+
+ + + + + + + + +
+
+
+ +
+
+ +
Index: /tags/1.2/templates/dberr.tmpl =================================================================== --- /tags/1.2/templates/dberr.tmpl (revision 556) +++ /tags/1.2/templates/dberr.tmpl (revision 556) @@ -0,0 +1,7 @@ +
+
Database error:
+ +

+ +
+
Index: /tags/1.2/templates/deldom.tmpl =================================================================== --- /tags/1.2/templates/deldom.tmpl (revision 556) +++ /tags/1.2/templates/deldom.tmpl (revision 556) @@ -0,0 +1,13 @@ + + + + +
+

Are you really sure you want to delete domain ?

+cancel   |   +confirm +
+ + + + Index: /tags/1.2/templates/delgrp.tmpl =================================================================== --- /tags/1.2/templates/delgrp.tmpl (revision 556) +++ /tags/1.2/templates/delgrp.tmpl (revision 556) @@ -0,0 +1,13 @@ + + + + +
+

Are you really sure you want to delete group ?

+cancel   |   +confirm +
+ + + + Index: /tags/1.2/templates/delloc.tmpl =================================================================== --- /tags/1.2/templates/delloc.tmpl (revision 556) +++ /tags/1.2/templates/delloc.tmpl (revision 556) @@ -0,0 +1,13 @@ + + + + +
+

Are you really sure you want to delete location ?

+cancel   |   +confirm +
+ + + + Index: /tags/1.2/templates/delrec.tmpl =================================================================== --- /tags/1.2/templates/delrec.tmpl (revision 556) +++ /tags/1.2/templates/delrec.tmpl (revision 556) @@ -0,0 +1,15 @@ + + + + +
+

Are you really sure you want to delete record:
+

+cancel +   |   +confirm +
+ + + + Index: /tags/1.2/templates/delrevzone.tmpl =================================================================== --- /tags/1.2/templates/delrevzone.tmpl (revision 556) +++ /tags/1.2/templates/delrevzone.tmpl (revision 556) @@ -0,0 +1,13 @@ + + + + +
+

Are you really sure you want to delete reverse zone ?

+cancel   |   +confirm +
+ + + + Index: /tags/1.2/templates/deluser.tmpl =================================================================== --- /tags/1.2/templates/deluser.tmpl (revision 556) +++ /tags/1.2/templates/deluser.tmpl (revision 556) @@ -0,0 +1,13 @@ + + + + +
+

Are you really sure you want to delete user ?

+cancel   |   +confirm +
+ + + + Index: /tags/1.2/templates/dns.css =================================================================== --- /tags/1.2/templates/dns.css (revision 556) +++ /tags/1.2/templates/dns.css (revision 556) @@ -0,0 +1,280 @@ +#debug { + background-color: #990066; + padding: 2px; +} + +/* General settings */ +body { + font-family: Verdana, Helvetica, sans-serif; + font-size: 12px; + margin-left: 0px; + margin-right: 0px; +/* background-color: #deadDD;*/ + background-color: #f8f8f8; +} +hr { + background-color: #666; + height: 1px; + border: 0; +} +img { + border: 0px; +} +/* Use Gecko-style list elements */ +ul, ol, li { + margin-left: 0; + padding-left: 40px; +/* border: thin solid #FF0000;*/ +} +fieldset { + border: none; + padding: 0px; + margin: 0px; +} + +table.list { + background-color: #F0F0F0; +} +.container { + background-color: #FFFFFF; + border: none; +} +table.wholepage { + width: 100%; +} +table.border { + border: thin solid #000000; +} + +tr.row0 { + background-color: #FFFFFF; +} +tr.row1 { + background-color: #DDDDDD; +} +tr.tableheader { + background-color: #CCCCCC; + padding: 3px; + text-align: left; +} +tr.darkrowheader { + background-color: #CCCCCC; + padding: 3px; +} +tr.datalinelight { + background-color: #F0F0F0; + text-align: left; +} + +th { + background-color: #F0F0F0; + font-size: 1.1em; + font-weight:normal; + padding: 4px; +} + +td.tblsubmit { + background-color: #F0F0F0; + text-align: center; +} +td.inputlabel { + text-align: right; + padding: 3px; +} +td.datahead_l { + background-color: #F0F0F0; + border-bottom: 1px solid #666666; + text-align: left; +} +td.datahead_s { + background-color: #F0F0F0; + border-bottom: 1px solid #666666; + width: 1%; + white-space: nowrap; +} +td.data_nowrap { + white-space: nowrap; +} +td.data { + padding: 3px; +} +td.title { + text-align: center; +} +td.menu { + width: 200px; + white-space: nowrap; + border: thin solid #000000; + background-color: #f0f0f0; + vertical-align: top; +} +td.defaults { + background-color: #DDDDDD; +} +td.errhead { + font-weight: bold; + font-size: 110%; + color: red; + background-color: #404040; + text-align: center; + padding: 3px; + border: solid 2px #FF0000; +} +td.err { + border: solid 2px #FF0000; + color: red; + background-color: #e0e0e0; +} +td.warn { + border: solid 2px #FFFF00; + color: #333300; + background-color: #e0e0e0; +} +td.leftthird { + width: 36%; + text-align: left; +} +td.rightthird { + width: 36%; + text-align: right; +} +td.border { + background-color: #e0e0e0; + border: solid 1px #101010; + padding: 2px; +} +td.noaccess { + background-color: #ffd8d8; + color: #3f0000; +} + +.meat { + align: center; + width: 100%; +} +input { + font-size: 10px; +} + + +/* general classes */ +.result { + border: solid 1px #00CC00; + color: #000000; + background-color: #f0f0f0; + text-align: center; + padding: 5px; + width: 55%; +} +.warning { + border: solid 2px #FFFF00; + color: #333300; + background-color: #e0e0e0; + text-align: center; + padding: 5px; + width: 70%; +} +.errmsg { + font-weight: bold; + font-family: Verdana, Arial, Helvetica, sans-serif; + font-size:100%; + color: red; + background-color: #404040; + text-align: center; + border: thin solid #FFFFFF; + padding: 5px; + width: 70%; + margin: 1% auto; +} +.right { + right: 3px; +} +.center { + text-align: center; +} +/* not sure this really does what I think it does. is it really not + possible to center an arbitrary in some other arbitrary ? */ +.loccenter { + margin-left: 10%; + margin-right: 10%; +} +.maintitle { + font-size: 1.3em; +} + + +#footer { + border-top: thin solid #000000; + clear: both; + margin-top: 20px; +} +#contact { + font-size: 10px; + position: absolute; + right: 10px; + text-align: right; +} + +#main { + position: relative; + float: right; + width: 100%; + margin:bottom: 50px; +} +#login { + margin: 17% auto; + padding: 3px; + font-size: 1.1em; +} +#login2 { + margin: auto; + border: thin solid #000000; +} +#tableholder { + padding: 2px; + background: #FFFFFF; + width: 70%; +} +#menu { + border-right: thin solid #000000; + margin-right: 5px; + padding: 5px; +} +#soadetail { + text-align: left; +} +#badpage { + margin: 5% auto; + border: solid 2px #FFFF00; + color: #333300; + background-color: #e0e0e0; + text-align: center; + padding: 5px; + width: 70%; +} +/* somewhat generic/reusable */ +#datatablewrapper { + border: none; + width: 98%; + margin-left: 1%; + margin-right: 1%; + vertical-align: top; +} +table.csubtable { + margin-left: auto; + margin-right: auto; +} +td.main { + vertical-align: top; +} + +/* Allow current group in list to be easily flagged */ +/* For reasons of "CSS is stupid" you apparently can't apply the font to the
  • *eyeroll* */ +label.curgrp { + font-weight: bold; + font-size: 1.2em; +} +span.curgrp { + font-weight: bold; + font-size: 1.2em; +} Index: /tags/1.2/templates/dnsq.tmpl =================================================================== --- /tags/1.2/templates/dnsq.tmpl (revision 556) +++ /tags/1.2/templates/dnsq.tmpl (revision 556) @@ -0,0 +1,82 @@ + + + + + +
    + +
    Query error:
    + +
    +
    + + + + + + + + + + + + + + + + + + + + + +
    DNS Query
    Host/Name:
    Record type: + +
    Non-recursive query: checked="checked" />
    Use this server:
    + +
    +
    + +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Query:
    + + + +
    Response from :
    Authority:
    Additional information:
    +     + +
    + Index: /tags/1.2/templates/domlist.tmpl =================================================================== --- /tags/1.2/templates/domlist.tmpl (revision 556) +++ /tags/1.2/templates/domlist.tmpl (revision 556) @@ -0,0 +1,56 @@ + + + + + +
    + + + + + + + + + + + + +
    DomainReverse zone list
    + + +New Domain + +New Reverse Zone + + +
    + + + + + + + + + + + + + + + + + + + + + + +
     <TMPL_VAR NAME=sortorder>Change StatusDelete
    ActiveInactivedeactivateactivate[ Delete ]
    No domainsreverse zones found
    + +
    Index: /tags/1.2/templates/edgroup.tmpl =================================================================== --- /tags/1.2/templates/edgroup.tmpl (revision 556) +++ /tags/1.2/templates/edgroup.tmpl (revision 556) @@ -0,0 +1,33 @@ + + + + + +
    + +
    +
    + + + + + + + + + + + + + + + + + + +
    Error updating group :
    Default permissions for group
    By default, users of this group will inherit the following privileges:
    + +
    +
    + +
    Index: /tags/1.2/templates/editsoa.tmpl =================================================================== --- /tags/1.2/templates/editsoa.tmpl (revision 556) +++ /tags/1.2/templates/editsoa.tmpl (revision 556) @@ -0,0 +1,72 @@ + + + + + +
    + +
    Error updating SOA record:
    + +
    Edit SOA
    + +
    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Edit default SOA record for group Edit SOA record for System defaults:
    Primary Name Server
    Contact Address
    SOA TTL
    Refresh
    Retry
    Expire
    Minimum TTL
    + +
    +
    + +
    + +
    + Index: /tags/1.2/templates/footer.tmpl =================================================================== --- /tags/1.2/templates/footer.tmpl (revision 556) +++ /tags/1.2/templates/footer.tmpl (revision 556) @@ -0,0 +1,13 @@ + + + +     + + + Index: /tags/1.2/templates/fpnla.tmpl =================================================================== --- /tags/1.2/templates/fpnla.tmpl (revision 556) +++ /tags/1.2/templates/fpnla.tmpl (revision 556) @@ -0,0 +1,5 @@ +[ First ]First[ First ]First  +[ Previous ]Previous[ Previous ]Previous  +Next[ Next ]Next[ Next ]  +Last[ Last ]Last[ Last ]  +All per page Index: /tags/1.2/templates/grouptree-ie.css =================================================================== --- /tags/1.2/templates/grouptree-ie.css (revision 556) +++ /tags/1.2/templates/grouptree-ie.css (revision 556) @@ -0,0 +1,60 @@ +/* + CSS for group tree, IE-specific non-collapsing version +*/ +ul.grptree { +/* padding-left: 0px; /* hack pthui */ + padding-left: 15px; /* hack pthui */ +} +li.hassub { + position: relative; + margin: 0 0 0 0px; + padding: 0; + list-style: none; + background: url('../images/tree_open.png') 0px 0px no-repeat; /* hack pthui */ +} +li.leaf { + margin: 0; + padding: 0 0 0 15px; /* in px since this is to adjust for a fixed-size image */ + list-style: none; +} +li.hassub input { + position: absolute; + left: 0; + margin: 0; + opacity: 0; + filter:alpha(opacity=0); /* IE > 6, maybe */ + z-index: 2; + height: 1em; + width: 1em; + top: 0; +} +input.grptreebox { + height: 0; + -khtml-opacity: 0; +} +/*li.hassub input + ul { +/* background: url('../images/tree_closed.png') 0px -2px no-repeat;*/ +/* margin-top: -0.95em; /* esplain to me, why this not 1em? O_o */ +/* padding-top: 0.1em;*/ +/* padding-left: 2.25em; /* ah-HA! use this to adjust the indent! watch for neg margin from li.hassub */ +/* xdisplay: block; +/* height: 1em;*/ +/*} +/*li.hassub input + ul > li { +/* height: 0; +/* overflow: hidden; +/* margin-left: -14px !important; +/*}*/ +li.hassub label { + display: block; + padding-left: 15px; /* in px as it ajusts for fixed-size image */ +} +/*li.hassub input:checked + ul { +/* background: url('../images/tree_open.png') 0px 0px no-repeat; +/* margin-top: -1.2em; +/* padding-top: 1.1em; +/* height: auto;*/ +/*}*/ +/*li.hassub input:checked + ul > li { +/* height: auto; +/*}*/ Index: /tags/1.2/templates/grouptree.css =================================================================== --- /tags/1.2/templates/grouptree.css (revision 556) +++ /tags/1.2/templates/grouptree.css (revision 556) @@ -0,0 +1,59 @@ +/* + Pure CSS collapseable tree for groups, for all browsers but IE + Adapted (mostly trimmed down) from http://www.thecssninja.com/css/css-tree-menu + Fails variously in IE < 9, may or may not work in IE 9 +*/ + +ul.grptree { + padding-left: 40px; /* hack pthui */ +} +li.hassub { + position: relative; + margin: 0 0 0 -40px; + padding: 0; + list-style: none; + background: none; /* hack pthui */ +} +li.leaf { + margin: 0; + padding: 0 0 0 15px; /* in px since this is to adjust for a fixed-size image */ +} +li.hassub input { + position: absolute; + left: 0; + margin: 0; + opacity: 0; + filter:alpha(opacity=0); /* IE > 6, maybe */ + z-index: 2; + cursor: pointer; + height: 1em; + width: 1em; + top: 0; +} +li.hassub input + ul { + background: url('../images/tree_closed.png') 0px -2px no-repeat; + margin-top: -0.95em; /* esplain to me, why this not 1em? O_o */ + padding-top: 0.1em; + padding-left: 2.25em; /* ah-HA! use this to adjust the indent! watch for neg margin from li.hassub */ + xdisplay: block; + height: 1em; +} +li.hassub input + ul > li { + height: 0; + overflow: hidden; + margin-left: -14px !important; +} +li.hassub label { + cursor: pointer; + display: block; + padding-left: 15px; /* in px as it ajusts for fixed-size image */ +} +li.hassub input:checked + ul { + background: url('../images/tree_open.png') 0px 0px no-repeat; + margin-top: -1.2em; + padding-top: 1.1em; + height: auto; +} +li.hassub input:checked + ul > li { + height: auto; +} Index: /tags/1.2/templates/grpman.tmpl =================================================================== --- /tags/1.2/templates/grpman.tmpl (revision 556) +++ /tags/1.2/templates/grpman.tmpl (revision 556) @@ -0,0 +1,56 @@ + + + + + +
    + + + + + + + + + + + + + + + +
    ManageView groups
    Edit Current GroupNew Group +
    + + + + + + + + + + + + + + + + + + + + + + + + + + +
     <TMPL_VAR NAME=sortorder>Delete
    [ Delete ]
    No groups found
    + +
    Index: /tags/1.2/templates/grptree.tmpl =================================================================== --- /tags/1.2/templates/grptree.tmpl (revision 556) +++ /tags/1.2/templates/grptree.tmpl (revision 556) @@ -0,0 +1,6 @@ +
      +
    • + > + checked="checked" id="grp_" /> +
      • +
    Index: /tags/1.2/templates/header.tmpl =================================================================== --- /tags/1.2/templates/header.tmpl (revision 556) +++ /tags/1.2/templates/header.tmpl (revision 556) @@ -0,0 +1,28 @@ + + + + + <TMPL_IF orgname><TMPL_VAR NAME=orgname> - </TMPL_IF>DNS Administration + + + + + + + + + + + + + + + + + + +
    Index: /tags/1.2/templates/lettsearch.tmpl =================================================================== --- /tags/1.2/templates/lettsearch.tmpl (revision 556) +++ /tags/1.2/templates/lettsearch.tmpl (revision 556) @@ -0,0 +1,28 @@ +All | +0-90-9 | +AA | +BB | +CC | +DD | +EE | +FF | +GG | +HH | +II | +JJ | +KK | +LL | +MM | +NN | +OO | +PP | +QQ | +RR | +SS | +TT | +UU | +VV | +WW | +XX | +YY | +ZZ Index: /tags/1.2/templates/location.tmpl =================================================================== --- /tags/1.2/templates/location.tmpl (revision 556) +++ /tags/1.2/templates/location.tmpl (revision 556) @@ -0,0 +1,50 @@ + + + + + +
    + + +
    + + +
    +
    + + + + + + + +
    + + + + + + + + + + + + + + + + + + + +
    Error location:
    :
    Location name/description
    IP list
    Comments
    + +
    + +
    +
    + +     + +
    Index: /tags/1.2/templates/loclist.tmpl =================================================================== --- /tags/1.2/templates/loclist.tmpl (revision 556) +++ /tags/1.2/templates/loclist.tmpl (revision 556) @@ -0,0 +1,49 @@ + + + + + +
    + + + + + + + + + + + + + +
    Manage locations/views
    New Location/View
    + + + + + + + + + + + + + + + + + + + + + +
     <TMPL_VAR NAME=sortorder>Delete
    [ Delete ]
    No locations/views defined
    + +
    Index: /tags/1.2/templates/log.tmpl =================================================================== --- /tags/1.2/templates/log.tmpl (revision 556) +++ /tags/1.2/templates/log.tmpl (revision 556) @@ -0,0 +1,51 @@ + + + + + +
    + + +
    +     + + + + + + + + +
    Log entries for
     
    + + + + + + + + + + + + + + + + + + + + + + + + +
     <TMPL_VAR NAME=sortorder>
    No log entries found
    + +
    Index: /tags/1.2/templates/login.tmpl =================================================================== --- /tags/1.2/templates/login.tmpl (revision 556) +++ /tags/1.2/templates/login.tmpl (revision 556) @@ -0,0 +1,21 @@ +
    +
    + + + + +
    +
    DeepNet DNS Administrator v
    +
    + + + + + + + +
    Error logging in: Invalid username or password
    Your session has expired
    Please log in:
    Username:
    Password:
    +
    + +
    +
    Index: /tags/1.2/templates/menu.tmpl =================================================================== --- /tags/1.2/templates/menu.tmpl (revision 556) +++ /tags/1.2/templates/menu.tmpl (revision 556) @@ -0,0 +1,35 @@ + + logged in
    +Log out +
    +Domains
    +Reverse Zones
     +Users
    +Log
    +Default Records
    +Default Reverse Records
     +Locations/Views
     +AXFR Import
     +Bulk Domain Operations
     +
    +ManageView groups
    +
    +
    + +
      +
    • + > + + + + +
      • +
    + +
    + +
    +DNS Query
    +WHOIS Query
    + + Index: /tags/1.2/templates/msgblock.tmpl =================================================================== --- /tags/1.2/templates/msgblock.tmpl (revision 556) +++ /tags/1.2/templates/msgblock.tmpl (revision 556) @@ -0,0 +1,9 @@ + +
    +     + +
    Warning:
    +     + +
    +     Index: /tags/1.2/templates/newdomain.tmpl =================================================================== --- /tags/1.2/templates/newdomain.tmpl (revision 556) +++ /tags/1.2/templates/newdomain.tmpl (revision 556) @@ -0,0 +1,51 @@ + + + + +
    + +
    +
    + + + + + + + +
    + + + + + + + + + + + + + + + + + + + + + + +
    Error adding domain :
    Add Domain
    Domain Name:
    Add domain to group:
    Make domain active on next DNS propagation checked="checked" />
    Location/view:
    +
    + +
    +
    + +
    Index: /tags/1.2/templates/newgrp.tmpl =================================================================== --- /tags/1.2/templates/newgrp.tmpl (revision 556) +++ /tags/1.2/templates/newgrp.tmpl (revision 556) @@ -0,0 +1,47 @@ + + + + +
    + +
    +
    + + + + + + + +
    + + + + + + + + + + + + + + + + + + + +
    Error adding group :
    Add Group
    Group Name:
    Add as subgroup of:
    Default permissions for users created in this group:
    + +
    +
    + +
    +
    + +
    Index: /tags/1.2/templates/newrevzone.tmpl =================================================================== --- /tags/1.2/templates/newrevzone.tmpl (revision 556) +++ /tags/1.2/templates/newrevzone.tmpl (revision 556) @@ -0,0 +1,59 @@ + + + + +
    + +
    +
    + + + + + + + +
    + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Error adding reverse zone : +
    Add Reverse Zone
    CIDR network or reverse zone name:
    Default reverse hostname pattern:
    Add reverse zone to group:
    Make reverse zone active on next DNS propagation
    Location/view: + +
    +
    + +
    +
    + +
    Index: /tags/1.2/templates/permlist.tmpl =================================================================== --- /tags/1.2/templates/permlist.tmpl (revision 556) +++ /tags/1.2/templates/permlist.tmpl (revision 556) @@ -0,0 +1,38 @@ + + Group: + class="noaccessinfo"> name="group_edit" checked="checked" disabled="disabled" /> Edit + class="noaccessinfo"> name="group_create" checked="checked" disabled="disabled" /> Create + class="noaccessinfo"> name="group_delete" checked="checked" disabled="disabled" /> Delete + + User: + class="noaccessinfo"> name="user_edit" checked="checked" disabled="disabled" /> Edit + class="noaccessinfo"> name="user_create" checked="checked" disabled="disabled" /> Create + class="noaccessinfo"> name="user_delete" checked="checked" disabled="disabled" /> Delete + + + Domain: + class="noaccessinfo"> name="domain_edit" checked="checked" disabled="disabled" /> Edit + class="noaccessinfo"> name="domain_create" checked="checked" disabled="disabled" /> Create + class="noaccessinfo"> name="domain_delete" checked="checked" disabled="disabled" /> Delete + + + + Domain Record: + class="noaccessinfo"> name="record_edit" checked="checked" disabled="disabled" /> Edit + class="noaccessinfo"> name="record_create" checked="checked" disabled="disabled" /> Create + class="noaccessinfo"> name="record_delete" checked="checked" disabled="disabled" /> Delete + class="noaccessinfo"> name="record_locchg" checked="checked" disabled="disabled" /> Change location + + + + Location/View: + class="noaccessinfo"> name="location_edit" checked="checked"disabled="disabled" /> Edit + class="noaccessinfo"> name="location_create" checked="checked" disabled="disabled" /> Create + class="noaccessinfo"> name="location_delete" checked="checked" disabled="disabled" /> Delete + class="noaccessinfo"> name="location_view" checked="checked" disabled="disabled" /> View + + + Self: + class="noaccessinfo"> name="self_edit" checked="checked" disabled="disabled" /> Edit + + Index: /tags/1.2/templates/pgcount.tmpl =================================================================== --- /tags/1.2/templates/pgcount.tmpl (revision 556) +++ /tags/1.2/templates/pgcount.tmpl (revision 556) @@ -0,0 +1,1 @@ +Listing - of No in matching "" Index: /tags/1.2/templates/reclist.tmpl =================================================================== --- /tags/1.2/templates/reclist.tmpl (revision 556) +++ /tags/1.2/templates/reclist.tmpl (revision 556) @@ -0,0 +1,100 @@ + + + + + +
    + + + + + + +
    + +
    Records in
    + + + + + + + + + + + + + + + + +
    + + + + +
    +
    + + + + + + value="" /> + +
    +
    +
    RecordsPlain textAdd recordView log
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
     <TMPL_VAR NAME=sortorder>Delete
    () ()
    ( )    		 () ()
    ( )    		[ Delete ]
    No records found
    + +
    + +     + +
    Index: /tags/1.2/templates/record.tmpl =================================================================== --- /tags/1.2/templates/record.tmpl (revision 556) +++ /tags/1.2/templates/record.tmpl (revision 556) @@ -0,0 +1,107 @@ + + + + + +
    + + +
    + + +
    +
    + + + + + + + + + + +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Error record:
    :
    Hostname    ?IP Address
    Type
    AddressHostname    ?
    Distance (MX and SRV only)
    Weight (SRV only)
    Port (SRV only)
    TTL
    Location/view
    Timestamp
    (blank or 0 disables timestamp)    		Valid checked="checked">until + checked="checked">after: + +
    + +
    + +
    +
    + +     + +
    Index: /tags/1.2/templates/revzones.tmpl =================================================================== --- /tags/1.2/templates/revzones.tmpl (revision 556) +++ /tags/1.2/templates/revzones.tmpl (revision 556) @@ -0,0 +1,1 @@ + Index: /tags/1.2/templates/sbox.tmpl =================================================================== --- /tags/1.2/templates/sbox.tmpl (revision 556) +++ /tags/1.2/templates/sbox.tmpl (revision 556) @@ -0,0 +1,8 @@ +
    +
    + +Search subgroups: checked="checked" name="searchsubs" value="y" /> + + +
    +
    Index: /tags/1.2/templates/soadata.tmpl =================================================================== --- /tags/1.2/templates/soadata.tmpl (revision 556) +++ /tags/1.2/templates/soadata.tmpl (revision 556) @@ -0,0 +1,34 @@ + + + + + + +
    SOA:edit
    + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Contact address:Primary Nameserver:
    Serial Number:Refresh:
    Retry:Expiration:
    Minimum TTL:Default TTL:
    Index: /tags/1.2/templates/template.tmpl =================================================================== --- /tags/1.2/templates/template.tmpl (revision 556) +++ /tags/1.2/templates/template.tmpl (revision 556) @@ -0,0 +1,10 @@ + + + + + +
    + + + +
    Index: /tags/1.2/templates/textrecs.tmpl =================================================================== --- /tags/1.2/templates/textrecs.tmpl (revision 556) +++ /tags/1.2/templates/textrecs.tmpl (revision 556) @@ -0,0 +1,40 @@ + + + + + <TMPL_IF orgname><TMPL_VAR NAME=orgname> - </TMPL_IF>DNS Administration + + + + + +
    +Plain version of default reverse records for .
    +Press the "Back" button to return to the standard record list. +
    + +
    + + + + + + + + + + + + + + + + + + + +
    No records found
    +
    + + + Index: /tags/1.2/templates/updatesoa.tmpl =================================================================== --- /tags/1.2/templates/updatesoa.tmpl (revision 556) +++ /tags/1.2/templates/updatesoa.tmpl (revision 556) @@ -0,0 +1,1 @@ + Index: /tags/1.2/templates/user.tmpl =================================================================== --- /tags/1.2/templates/user.tmpl (revision 556) +++ /tags/1.2/templates/user.tmpl (revision 556) @@ -0,0 +1,103 @@ + + + + +
    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    AddEdit User
    Username:
    First Name:
    Last Name:
    Password:
    Confirm Password:
    Account Type:User
    Create as active userUser is active
    + + + + + + + + + + + + + + + + + + + + + +
    + checked="checked"checked="checked"/> Use permissions from group +
    + checked="checked"/> Clone permissions from an existing user +
    + Note: Only users in the current group may be cloned
    + +
    + checked="checked"/> Specify permissions +
    + +
    + +
    +
    + +
    Index: /tags/1.2/templates/useradmin.tmpl =================================================================== --- /tags/1.2/templates/useradmin.tmpl (revision 556) +++ /tags/1.2/templates/useradmin.tmpl (revision 556) @@ -0,0 +1,58 @@ + + + + + +
    + + + + + + + + + + + + + + +
    Manage users
    New User
    + + + + + + + + + + + + + + + + + + + + + + + + +
     <TMPL_VAR NAME=sortorder>Delete
    + + enableddisabled + + enableddisabled + +[ Delete ]
    No users found
    + +
    Index: /tags/1.2/templates/whoisq.tmpl =================================================================== --- /tags/1.2/templates/whoisq.tmpl (revision 556) +++ /tags/1.2/templates/whoisq.tmpl (revision 556) @@ -0,0 +1,44 @@ + + + + + +
    + +
    Query error:
    + +
    +
    + + + + + + + + + + +
    WHOIS Query
    Host/Name:
    + +
    +
    + +
    + + + + + + + + + + +
    Query:
    + +
    Response from :
    
+
    +     + +
    Index: /tags/1.2/textrecs.cgi =================================================================== --- /tags/1.2/textrecs.cgi (revision 556) +++ /tags/1.2/textrecs.cgi (revision 556) @@ -0,0 +1,104 @@ +#!/usr/bin/perl -w -T +# Plaintext record list for DeepNet DNS Administrator +## +# $Id$ +# Copyright 2012,2013 Kris Deugau +# +# 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 . +## + +use strict; +use warnings; + +use CGI::Carp qw (fatalsToBrowser); +use CGI::Simple; +use HTML::Template; +use CGI::Session; +use DBI; + +# don't remove! required for GNU/FHS-ish install from tarball +use lib '.'; ##uselib## + +use DNSDB; + +# Let's do these templates right... +my $templatedir = "templates"; + +# Set up the CGI object... +my $q = new CGI::Simple; +# ... and get query-string params as well as POST params if necessary +$q->parse_query_string; + +# This is probably excessive fiddling, but it puts the parameters somewhere my fingers know about... +my %webvar = $q->Vars; + +# shut up some warnings, in case we arrive somewhere we forgot to set this +$webvar{defrec} = 'n' if !$webvar{defrec}; # non-default records +$webvar{revrec} = 'n' if !$webvar{revrec}; # non-reverse (domain) records + +my $dnsdb = new DNSDB; + +# Check the session and if we have a zone ID to retrieve. Call a failure sub if not. +my $sid = $q->cookie('dnsadmin_session'); +my $session = new CGI::Session("driver:File", $sid, {Directory => $dnsdb->{sessiondir}}) + or die CGI::Session->errstr(); +do_not_pass_go() if !$sid; +do_not_pass_go() if !$webvar{id}; + +my $zone; +$zone = ($webvar{revrec} eq 'n' ? $dnsdb->domainName($webvar{id}) : $dnsdb->revName($webvar{id})) + if $webvar{defrec} eq 'n'; +$zone = "group ".$dnsdb->groupName($webvar{id}) if $webvar{defrec} eq 'y'; + +##fixme: do we support both HTML-plain and true plaintext? could be done, with another $webvar{} +# Don't die on bad parameters. Saves munging the return from getRecList. +#my $page = HTML::Template->new(filename => "$templatedir/textrecs.tmpl", +# loop_context_vars => 1, global_vars => 1, die_on_bad_params => 0); +#print "Content-type: text/html\n\n"; + +print "Content-type: text/plain\n\n"; +print "Plaintext version of records for $zone.\n" if $webvar{defrec} eq 'n'; +print "Plaintext version of default ".($webvar{revrec} eq 'y' ? 'reverse ' : '')."records for $zone.\n" + if $webvar{defrec} eq 'y'; +print qq(Press the "Back" button to return to the standard record list.\n\n); + +my $reclist = $dnsdb->getRecList(defrec => $webvar{defrec}, revrec => $webvar{revrec}, id => $webvar{id}, + sortby => ($webvar{revrec} eq 'n' ? 'type,host' : 'type,val'), sortorder => 'ASC'); +foreach my $rec (@$reclist) { + $rec->{type} = $typemap{$rec->{type}}; + $rec->{val} .= '.' if $rec->{type} ne 'A' && $rec->{type} ne 'TXT' && $webvar{revrec} eq 'n' && $rec->{val} !~ /\.$/; + $rec->{host} .= '.' if $webvar{revrec} eq 'y' && $rec->{val} !~ /\.$/; + $rec->{val} = "$rec->{distance} $rec->{val}" if $rec->{type} eq 'MX'; + $rec->{val} = "$rec->{distance} $rec->{weight} $rec->{port} $rec->{val}" if $rec->{type} eq 'SRV'; + if ($webvar{revrec} eq 'y') { + printf "%-16s\t%d\t%s\t%s\n", $rec->{val}, $rec->{ttl}, $rec->{type}, $rec->{host}; + } else { + printf "%-45s\t%d\t%s\t%s\n", $rec->{host}, $rec->{ttl}, $rec->{type}, $rec->{val}; + } +} +#$page->param(defrec => ($webvar{defrec} eq 'y')); +#$page->param(revrec => ($webvar{revrec} eq 'y')); +#$page->param(zone => $zone); +#$page->param(reclist => $reclist); +#$page->param(fwdzone => ($webvar{revrec} eq 'n')); +#print $page->output; + +exit; + +sub do_not_pass_go { + my $webpath = $ENV{SCRIPT_NAME}; + $webpath =~ s|/[^/]+$|/|; + print "Status: 302\nLocation: http://$ENV{HTTP_HOST}$webpath\n\n"; + exit; +} Index: /tags/1.2/tiny-import.pl =================================================================== --- /tags/1.2/tiny-import.pl (revision 556) +++ /tags/1.2/tiny-import.pl (revision 556) @@ -0,0 +1,844 @@ +#!/usr/bin/perl +# dnsadmin shell-based import tool for tinydns flatfiles +## +# $Id$ +# Copyright 2012,2013 Kris Deugau +# +# 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 . +## + +# WARNING: This is NOT a heavy-duty validator; it is assumed that the data +# being imported is more or less sane. Only minor structural validation will +# be done to weed out the most broken records. + +use strict; +use warnings; +use POSIX; +use Time::TAI64 qw(:tai); + +use lib '.'; ##uselib## +use DNSDB; + +my $dnsdb = new DNSDB; + +usage() if !@ARGV; + +my %importcfg = ( + rw => 0, + conv => 0, + trial => 0, + legacy => 0, + ); +# Handle some command-line arguments +while ($ARGV[0] =~ /^-/) { + my $arg = shift @ARGV; + usage() if $arg !~ /^-[rclt]+$/; + # -r rewrite imported files to comment imported records + # -c coerce/downconvert A+PTR = records to PTR + # -l swallow A+PTR as-is + # -t trial mode; don't commit to DB or actually rewrite flatfile (disables -r) + $arg =~ s/^-//; + my @tmp = split //, $arg; + foreach (@tmp) { + $importcfg{rw} = 1 if $_ eq 'r'; + $importcfg{conv} = 1 if $_ eq 'c'; + $importcfg{legacy} = 1 if $_ eq 'l'; + $importcfg{trial} = 1 if $_ eq 't'; + } +} +$importcfg{rw} = 0 if $importcfg{trial}; + +sub usage { + die q(usage: tiny-import.pl [-r] [-c] datafile1 datafile2 ... datafileN ... + -r Rewrite all specified data files with a warning header indicating the + records are now managed by web, and commenting out all imported records. + The directory containing any given datafile must be writable. + -c Convert any A+PTR (=) record to a bare PTR if the forward domain is + not present in the database. Note this does NOT look forward through + a single file, nor across multiple files handled in the same run. + Multiple passes may be necessary if SOA and = records are heavily + intermixed and not clustered together. + -l (for "legacy") Force import of A+PTR records as-is. Mutually exclusive + with -c. -l takes precedence as -c is lossy. + -t Trial run mode; spits out records that would be left unimported. + Disables -r if set. + + -r and -c may be combined (-rc) + + datafileN is any tinydns record data file. +); +} + +my $code; +my $dbh = $dnsdb->{dbh}; + +$dbh->{AutoCommit} = 0; +$dbh->{RaiseError} = 1; + +my %cnt; +my @deferred; +my $converted = 0; +my $errstr = ''; + +foreach my $file (@ARGV) { + eval { + import(file => $file); +# import(file => $file, nosoa => 1); + $dbh->rollback if $importcfg{trial}; + $dbh->commit unless $importcfg{trial}; + }; + if ($@) { + print "Failure trying to import $file: $@\n $errstr\n"; + unlink ".$file.$$" if $importcfg{rw}; # cleanup + $dbh->rollback; + } +} + +# print summary count of record types encountered +foreach (keys %cnt) { + print " $_ $cnt{$_}\n"; +} + +exit 0; + +sub import { + our %args = @_; + my $flatfile = $args{file}; + my @fpath = split '/', $flatfile; + $fpath[$#fpath] = ".$fpath[$#fpath]"; + my $rwfile = join('/', @fpath);#.".$$"; + + open FLAT, "<$flatfile"; + + if ($importcfg{rw}) { + open RWFLAT, ">$rwfile" or die "Couldn't open tempfile $rwfile for rewriting: $!\n"; + print RWFLAT "# WARNING: Records in this file have been imported to the web UI.\n#\n"; + } + + our $recsth = $dbh->prepare("INSERT INTO records (domain_id,rdns_id,host,type,val,distance,weight,port,ttl,location,stamp,expires,stampactive) ". + " VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"); + + my %deleg; + + my $ok = 0; + while () { + if (/^#/ || /^\s*$/) { + print RWFLAT "#$_" if $importcfg{rw}; + next; + } + chomp; + s/\s*$//; + my $recstat = recslurp($_); + $ok++ if $recstat; + if ($importcfg{rw}) { + if ($recstat) { + print RWFLAT "#$_\n"; + } else { + print RWFLAT "$_\n"; + } + } + } + + # Move the rewritten flatfile in place of the original, so that any + # external export processing will pick up any remaining records. + if ($importcfg{rw}) { + close RWFLAT; + rename "$rwfile", $flatfile; + } + + # Show the failed records + foreach (@deferred) { + print "failed to import $_\n"; + } + +##fixme: hmm. can't write the record back to the flatfile in the +# main while above, then come down here and import it anyway, can we? +# # Try the deferred records again, once. +# foreach (@deferred) { +# print "trying $_ again\n"; +# recslurp($_, 1); +# } + + # .. but we can at least say how many records weren't imported. + print "$ok OK, ".scalar(@deferred)." deferred, $converted downconverted records in $flatfile\n"; + undef @deferred; + $converted = 0; + + # Sub for various nonstandard types with lots of pure bytes expressed in octal + # Takes a tinydns rdata string and count, returns a list of $count bytes as well + # as trimming those logical bytes off the front of the rdata string. + sub _byteparse { + my $src = shift; + my $count = shift; + my @ret; + for (my $i = 0; $i < $count; $i++) { + if ($$src =~ /^\\/) { + # we should have an octal bit + my ($tmp) = ($$src =~ /^(\\\d{3})/); + $tmp =~ s/\\/0/; + push @ret, oct($tmp); + $$src =~ s/^\\\d{3}//; + } else { + # we seem to have a byte expressed as an ASCII character + my ($tmp) = ($$src =~ /^(.)/); + push @ret, ord($tmp); + $$src =~ s/^.//; + } + } + return @ret; + } + + # Convert octal-coded bytes back to something resembling normal characters, general case + sub _deoctal { + my $targ = shift; + while ($$targ =~ /\\(\d{3})/) { + my $sub = chr(oct($1)); + $$targ =~ s/\\$1/$sub/g; + } + } + + sub _rdata2string { + my $rdata = shift; + my $tmpout = ''; + while ($rdata) { + my $bytecount = 0; + if ($rdata =~ /^\\/) { + ($bytecount) = ($rdata =~ /^(\\\d{3})/); + $bytecount =~ s/\\/0/; + $bytecount = oct($bytecount); + $rdata =~ s/^\\\d{3}//; + } else { + ($bytecount) = ($rdata =~ /^(.)/); + $bytecount = ord($bytecount); + $rdata =~ s/^.//; + } + my @tmp = _byteparse(\$rdata, $bytecount); + foreach (@tmp) { $tmpout .= chr($_); } +##fixme: warn or fail on long (>256? >512? >321?) strings + } + return $tmpout; + } + + sub _rdata2hex { + my $rdata = shift; + my $tmpout = ''; + while ($rdata) { + my $byte = ''; + if ($rdata =~ /^\\/) { + ($byte) = ($rdata =~ /^(\\\d{3})/); + $byte =~ s/\\/0/; + $tmpout .= sprintf("%0.2x", oct($byte)); + $rdata =~ s/^\\\d{3}//; + } else { + ($byte) = ($rdata =~ /^(.)/); + $tmpout .= sprintf("%0.2x", ord($byte)); + $rdata =~ s/^.//; + } + } + return $tmpout; + } + + sub calcstamp { + my $stampin = shift; + my $ttl = shift; + my $pzone = shift; + my $revrec = shift; + + return ($ttl, 'n', 'n', '1970-01-01 00:00:00 -0') if !$stampin; + +##fixme Yes, this fails for records in 2038 sometime. No, I'm not going to care for a while. + $stampin = "\@$stampin"; # Time::TAI64 needs the leading @. Feh. + my $u = tai2unix($stampin); + $stampin = strftime("%Y-%m-%d %H:%M:%S %z", localtime($u)); + my $expires = 'n'; + if ($ttl) { + # TTL can stay put. + } else { + # TTL on import is 0, almost certainly wrong. Get the parent zone's SOA and use the minttl. + my $soa = $dnsdb->getSOA('n', $revrec, $pzone); + $ttl = $soa->{minttl}; + $expires = 'y'; + } + return ($ttl, 'y', $expires, $stampin); + } + + sub recslurp { + my $rec = shift; + my $nodefer = shift || 0; + my $impok = 1; + my $msg; + + $errstr = $rec; # this way at least we have some idea what went + + if ($rec =~ /^=/) { + $cnt{APTR}++; + +##fixme: do checks like this for all types + if ($rec !~ /^=(?:\*|\\052)?[a-z0-9\._-]+:[\d\.]+:\d*/i) { + print "bad A+PTR $rec\n"; + return; + } + my ($host,$ip,$ttl,$stamp,$loc) = split /:/, $rec, 5; + $host =~ s/^=//; + $host =~ s/\.$//; + $ttl = -1 if $ttl eq ''; + $stamp = '' if !$stamp; + $loc = '' if !$loc; + $loc = '' if $loc =~ /^:+$/; + my $fparent = $dnsdb->_hostparent($host); + my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($ip)); + + my $stampactive = 'n'; + my $expires = 'n'; + + # can't set a timestamp on an orphaned record. we'll actually fail import of this record a little later. + if ($fparent || $rparent) { + if ($fparent) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $fparent, 'n'); + } else { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $rparent, 'y'); + } + } + + if ($fparent && $rparent) { + $recsth->execute($fparent, $rparent, $host, 65280, $ip, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + if ($importcfg{legacy}) { + # Just import it already! Record may still be subject to downconversion on editing. + $fparent = 0 if !$fparent; + $rparent = 0 if !$rparent; + if ($fparent || $rparent) { + $recsth->execute($fparent, $rparent, $host, 65280, $ip, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + # No parents found, cowardly refusing to add a dangling record + push @deferred, $rec unless $nodefer; + $impok = 0; + } + } elsif ($importcfg{conv}) { + # downconvert A+PTR if forward zone is not found + $recsth->execute(0, $rparent, $host, 12, $ip, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + $converted++; + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + # print "$tmporig deferred; can't find both forward and reverse zone parents\n"; + } + } + + } elsif ($rec =~ /^C/) { + $cnt{CNAME}++; + + my ($host,$targ,$ttl,$stamp,$loc) = split /:/, $rec, 5; + $host =~ s/^C//; + $host =~ s/\.$//; + $host =~ s/^\\052/*/; + $ttl = -1 if $ttl eq ''; + $stamp = '' if !$stamp; + $loc = '' if !$loc; + $loc = '' if $loc =~ /^:+$/; + + my $stampactive = 'n'; + my $expires = 'n'; + + if ($host =~ /\.arpa$/) { + ($code,$msg) = DNSDB::_zone2cidr($host); + my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($msg)); + if ($rparent) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $rparent, 'y'); + $recsth->execute(0, $rparent, $targ, 5, $msg->addr, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + # print "$tmporig deferred; can't find parent zone\n"; + } + +##fixme: automagically convert manually maintained sub-/24 delegations +# my ($subip, $zone) = split /\./, $targ, 2; +# ($code, $msg) = DNSDB::_zone2cidr($zone); +# push @{$deleg{"$msg"}{iplist}}, $subip; +#print "$msg $subip\n"; + + } else { + my $fparent = $dnsdb->_hostparent($host); + if ($fparent) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $fparent, 'n'); + $recsth->execute($fparent, 0, $host, 5, $targ, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + # print "$tmporig deferred; can't find parent zone\n"; + } + } + + } elsif ($rec =~ /^\&/) { + $cnt{NS}++; + + my ($zone,$ip,$ns,$ttl,$stamp,$loc) = split /:/, $rec, 6; + $zone =~ s/^\&//; + $zone =~ s/\.$//; + $ns =~ s/\.$//; + $ns = "$ns.ns.$zone" if $ns !~ /\./; + $ttl = -1 if $ttl eq ''; + $stamp = '' if !$stamp; + $loc = '' if !$loc; + $loc = '' if $loc =~ /^:+$/; + + my $stampactive = 'n'; + my $expires = 'n'; + + if ($zone =~ /\.arpa$/) { + ($code,$msg) = DNSDB::_zone2cidr($zone); + my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >>= ?", undef, ("$msg")); +##fixme, in concert with the CNAME check for same; automagically +# create "delegate" record instead for subzone NSes: convert above to use = instead of >>= +# ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ("$msg")) +# if !$rparent; + if ($rparent) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $rparent, 'y'); + $recsth->execute(0, $rparent, $ns, 2, $msg, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + } + } else { + my $fparent = $dnsdb->_hostparent($zone); + if ($fparent) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $fparent, 'n'); + $recsth->execute($fparent, 0, $zone, 2, $ns, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + $recsth->execute($fparent, 0, $ns, 2, $ip, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive) if $ip; + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + } + } + + } elsif ($rec =~ /^\^/) { + $cnt{PTR}++; + + my ($rip,$host,$ttl,$stamp,$loc) = split /:/, $rec, 5; + $rip =~ s/^\^//; + $rip =~ s/\.$//; + $ttl = -1 if $ttl eq ''; + $stamp = '' if !$stamp; + $loc = '' if !$loc; + $loc = '' if $loc =~ /^:+$/; + + my $stampactive = 'n'; + my $expires = 'n'; + + my $rparent; + if (my ($i, $z) = ($rip =~ /^(\d+)\.(\d+-(?:\d+\.){4}in-addr.arpa)$/) ) { + ($code,$msg) = DNSDB::_zone2cidr($z); + # Exact matches only, because we're in a sub-/24 delegation +##fixme: flag the type of delegation (range, subnet-with-dash, subnet-with-slash) +# somewhere so we can recover it on export. probably best to do that in the revzone data. + ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet = ?", undef, ("$msg")); + $z =~ s/^[\d-]+//; + ($code,$msg) = DNSDB::_zone2cidr("$i.$z"); # Get the actual IP and normalize + } else { + ($code,$msg) = DNSDB::_zone2cidr($rip); + ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ("$msg")); + } + if ($rparent) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $rparent, 'y'); + $recsth->execute(0, $rparent, $host, 12, $msg->addr, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + } + + } elsif ($rec =~ /^\+/) { + $cnt{A}++; + + my ($host,$ip,$ttl,$stamp,$loc) = split /:/, $rec, 5; + $host =~ s/^\+//; + $host =~ s/\.$//; + $host =~ s/^\\052/*/; + $ttl = -1 if $ttl eq ''; + $stamp = '' if !$stamp; + $loc = '' if !$loc; + $loc = '' if $loc =~ /^:+$/; + + my $stampactive = 'n'; + my $expires = 'n'; + + my $domid = $dnsdb->_hostparent($host); + if ($domid) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $domid, 'n'); + $recsth->execute($domid, 0, $host, 1, $ip, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + } + + } elsif ($rec =~ /^Z/) { + $cnt{SOA}++; + + my ($zone,$master,$contact,$serial,$refresh,$retry,$expire,$minttl,$ttl,$stamp,$loc) = split /:/, $rec, 11; + $zone =~ s/^Z//; + $zone =~ s/\.$//; + $master =~ s/\.$//; + $contact =~ s/\.$//; + $ttl = -1 if $ttl eq ''; + $stamp = '' if !$stamp; + $loc = '' if !$loc; + $loc = '' if $loc =~ /^:+$/; + + my $stampactive = 'n'; + my $expires = 'n'; + +##fixme er... what do we do with an SOA with a timestamp? O_o +# fail for now, since there's no clean way I can see to handle this (yet) +# maybe (ab)use the -l flag to import as-is? + if ($stamp) { + push @deferred, $rec unless $nodefer; + return 0; + } + +##fixme: need more magic on TTL, so we can decide whether to use the minttl or newttl +# my $newttl; +# ($newttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $minttl, 0, 'n'); +# $ttl = $newttl if !$ttl; + + if ($zone =~ /\.arpa$/) { + ($code,$msg) = DNSDB::_zone2cidr($zone); + $dbh->do("INSERT INTO revzones (revnet,group_id,status,default_location) VALUES (?,1,1,?)", + undef, ($msg, $loc)); + my ($rdns) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')"); + my $newttl; + ($newttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $minttl, 0, 'y'); + $ttl = $newttl if !$ttl; + $recsth->execute(0, $rdns, "$contact:$master", 6, "$refresh:$retry:$expire:$minttl", 0, 0, 0, $ttl, + $loc, $stamp, $expires, $stampactive); + } else { + $dbh->do("INSERT INTO domains (domain,group_id,status,default_location) VALUES (?,1,1,?)", + undef, ($zone, $loc)); + my ($domid) = $dbh->selectrow_array("SELECT currval('domains_domain_id_seq')"); + my $newttl; + ($newttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $minttl, 0, 'n'); + $ttl = $newttl if !$ttl; + $recsth->execute($domid, 0, "$contact:$master", 6, "$refresh:$retry:$expire:$minttl", 0, 0, 0, $ttl, + $loc, $stamp, $expires, $stampactive); + } + + } elsif ($rec =~ /^\@/) { + $cnt{MX}++; + + my ($zone,$ip,$host,$dist,$ttl,$stamp,$loc) = split /:/, $rec, 7; + $zone =~ s/^\@//; + $zone =~ s/\.$//; + $zone =~ s/^\\052/*/; + $host =~ s/\.$//; + $host = "$host.mx.$zone" if $host !~ /\./; + $ttl = -1 if $ttl eq ''; + $stamp = '' if !$stamp; + $loc = '' if !$loc; + $loc = '' if $loc =~ /^:+$/; + + my $stampactive = 'n'; + my $expires = 'n'; + +# note we don't check for reverse domains here, because MX records don't make any sense in reverse zones. +# if this really ever becomes an issue for someone it can be expanded to handle those weirdos + + # allow for subzone MXes, since it's perfectly legitimate to simply stuff it all in a single parent zone + my $domid = $dnsdb->_hostparent($zone); + if ($domid) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $domid, 'n'); + $recsth->execute($domid, 0, $zone, 15, $host, $dist, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + $recsth->execute($domid, 0, $host, 1, $ip, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive) if $ip; + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + } + + } elsif ($rec =~ /^'/) { + $cnt{TXT}++; + + my ($fqdn, $rdata, $ttl, $stamp, $loc) = split /:/, $rec, 5; + $fqdn =~ s/^'//; + $fqdn =~ s/^\\052/*/; + _deoctal(\$rdata); + $ttl = -1 if $ttl eq ''; + $stamp = '' if !$stamp; + $loc = '' if !$loc; + $loc = '' if $loc =~ /^:+$/; + + my $stampactive = 'n'; + my $expires = 'n'; + + if ($fqdn =~ /\.arpa$/) { + ($code,$msg) = DNSDB::_zone2cidr($fqdn); + my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($msg)); + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $rparent, 'y'); + $recsth->execute(0, $rparent, $rdata, 16, "$msg", 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + my $domid = $dnsdb->_hostparent($fqdn); + if ($domid) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $domid, 'n'); + $recsth->execute($domid, 0, $fqdn, 16, $rdata, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + } + } + + } elsif ($rec =~ /^\./) { + $cnt{NSASOA}++; + + my ($fqdn, $ip, $ns, $ttl, $stamp, $loc) = split /:/, $rec, 6; + $fqdn =~ s/^\.//; + $fqdn =~ s/\.$//; + $ns =~ s/\.$//; + $ns = "$ns.ns.$fqdn" if $ns !~ /\./; + $ttl = -1 if $ttl eq ''; + $stamp = '' if !$stamp; + $loc = '' if !$loc; + $loc = '' if $loc =~ /^:+$/; + + my $stampactive = 'n'; + my $expires = 'n'; + +##fixme er... what do we do with an SOA with a timestamp? O_o +# fail for now, since there's no clean way I can see to handle this (yet) +# maybe (ab)use the -l flag to import as-is? + if ($stamp) { + push @deferred, $rec unless $nodefer; + return 0; + } + +##fixme: need more magic on TTL, so we can decide whether to use the minttl or newttl +# my $newttl; +# ($newttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $minttl, 0, 'n'); + + if ($fqdn =~ /\.arpa$/) { + ($code,$msg) = DNSDB::_zone2cidr($fqdn); + my ($rdns) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet = ?", undef, ($msg)); + if (!$rdns) { + $errstr = "adding revzone $msg"; + $dbh->do("INSERT INTO revzones (revnet,group_id,status,default_location) VALUES (?,1,1,?)", + undef, ($msg, $loc)); + ($rdns) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')"); + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, 2560, 0, 'y'); +# this would probably make a lot more sense to do hostmaster.$config{admindomain} +# otherwise, it's as per the tinydns defaults that work tolerably well on a small scale +# serial -> modtime of data file, ref -> 16384, ret -> 2048, exp -> 1048576, min -> 2560 + $recsth->execute(0, $rdns, "hostmaster.$fqdn:$ns", 6, "16384:2048:1048576:2560", 0, 0, 0, "2560", + $loc, $stamp, $expires, $stampactive); + } + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, 2560, $rdns, 'y') if !$stamp; + $recsth->execute(0, $rdns, $ns, 2, "$msg", 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); +##fixme: (?) implement full conversion of tinydns . records? +# -> problem: A record for NS must be added to the appropriate *forward* zone, not the reverse +#$recsth->execute(0, $rdns, $ns, 1, $ip, 0, 0, 0, $ttl, $stamp, $expires, $stampactive) +# ... auto-A-record simply does not make sense in reverse zones. Functionally +# I think it would work, sort of, but it's a nasty mess and anyone hosting reverse +# zones has names for their nameservers already. +# Even the auto-nameserver-fqdn comes out... ugly. + + } else { + my ($domid) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)", + undef, ($fqdn)); + if (!$domid) { + $errstr = "adding domain $fqdn"; + $dbh->do("INSERT INTO domains (domain,group_id,status,default_location) VALUES (?,1,1,?)", + undef, ($fqdn, $loc)); + ($domid) = $dbh->selectrow_array("SELECT currval('domains_domain_id_seq')"); + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, 2560, 0, 'n'); + $recsth->execute($domid, 0, "hostmaster.$fqdn:$ns", 6, "16384:2048:1048576:2560", 0, 0, 0, "2560", + $loc, $stamp, $expires, $stampactive); + } + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $domid, 'n') if !$stamp; + $recsth->execute($domid, 0, $fqdn, 2, $ns, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + $recsth->execute($domid, 0, $ns, 1, $ip, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive) if $ip; + } + + + } elsif ($rec =~ /^\%/) { + $cnt{VIEWS}++; + + # unfortunate that we don't have a guaranteed way to get a description on these. :/ + my ($loc,$cnet) = split /:/, $rec, 2; + $loc =~ s/^\%//; + if (my ($iplist) = $dbh->selectrow_array("SELECT iplist FROM locations WHERE location = ?", undef, ($loc))) { + if ($cnet) { + $iplist .= ", $cnet"; + $dbh->do("UPDATE locations SET iplist = ? WHERE location = ?", undef, ($iplist, $loc)); + } else { + # hmm. spit out a warning? if we already have entries for $loc, adding a null + # entry will almost certainly Do The Wrong Thing(TM) + } + } else { + $cnet = '' if !$cnet; # de-nullify + $dbh->do("INSERT INTO locations (location,iplist,description) VALUES (?,?,?)", undef, ($loc, $cnet, $loc)); + } + + } elsif ($rec =~ /^:/) { + $cnt{NCUST}++; +# Big section. Since tinydns can publish anything you can encode properly, but only provides official +# recognition and handling for the core common types, this must deal with the leftovers. +# :fqdn:type:rdata:ttl:time:loc + + my (undef, $fqdn, $type, $rdata, $ttl, $stamp, $loc) = split /:/, $rec, 7; + $fqdn =~ s/\.$//; + $fqdn =~ s/^\\052/*/; + $ttl = -1 if $ttl eq ''; + $stamp = '' if !$stamp; + $loc = '' if !$loc; + $loc = '' if $loc =~ /^:+$/; + + my $stampactive = 'n'; + my $expires = 'n'; + + if ($type == 33) { + # SRV + my ($prio, $weight, $port, $target) = (0,0,0,0); + + my @tmp = _byteparse(\$rdata, 2); + $prio = $tmp[0] * 256 + $tmp[1]; + @tmp = _byteparse(\$rdata, 2); + $weight = $tmp[0] * 256 + $tmp[1]; + @tmp = _byteparse(\$rdata, 2); + $port = $tmp[0] * 256 + $tmp[1]; + + $rdata =~ s/\\\d{3}/./g; + ($target) = ($rdata =~ /^\.(.+)\.$/); +# hmm. the above *should* work, but What If(TM) we have ASCII-range bytes +# representing the target's fqdn part length(s)? axfr-get doesn't seem to, +# probably because dec. 33->63 includes most punctuation and all the numbers +# while ($rdata =~ /(\\\d{3})/) { +# my $cnt = $1; +# $rdata =~ s/^$cnt//; +# $cnt =~ s/^\\/0/; +# $cnt = oct($cnt); +# my ($seg) = ($rdata =~ /^(.{$cnt})/); +# $target .= +# } + + my $domid = $dnsdb->_hostparent($fqdn); + if ($domid) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $domid, 'n'); + $recsth->execute($domid, 0, $fqdn, 33, $target, $prio, $weight, $port, $ttl, $loc, $stamp, $expires, $stampactive) if $domid; + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + } + + } elsif ($type == 28) { + # AAAA + my @v6; + + for (my $i=0; $i < 8; $i++) { + my @tmp = _byteparse(\$rdata, 2); + push @v6, sprintf("%0.4x", $tmp[0] * 256 + $tmp[1]); + } + my $val = NetAddr::IP->new(join(':', @v6)); + + my $fparent = $dnsdb->_hostparent($fqdn); + + if ($fparent) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $fparent, 'n'); + $recsth->execute($fparent, 0, $fqdn, 28, $val->addr, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + } + + } elsif ($type == 16) { + # TXT + my $txtstring = _rdata2string($rdata); + + if ($fqdn =~ /\.arpa$/) { + ($code,$msg) = DNSDB::_zone2cidr($fqdn); + my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($msg)); + if ($rparent) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $rparent, 'y'); + $recsth->execute(0, $rparent, $txtstring, 16, "$msg", 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + } + } else { + my $domid = $dnsdb->_hostparent($fqdn); + if ($domid) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $domid, 'n'); + $recsth->execute($domid, 0, $fqdn, 16, $txtstring, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + } + } + + } elsif ($type == 17) { + # RP + my ($email, $txtrec) = split /\\000/, $rdata; + $email =~ s/\\\d{3}/./g; + $email =~ s/^\.//; + $txtrec =~ s/\\\d{3}/./g; + $txtrec =~ s/^\.//; + + # these might actually make sense in a reverse zone... sort of. + if ($fqdn =~ /\.arpa$/) { + ($code,$msg) = DNSDB::_zone2cidr($fqdn); + my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($msg)); + if ($rparent) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $rparent, 'y'); + $recsth->execute(0, $rparent, "$email $txtrec", 17, "$msg", 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive ); + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + } + } else { + my $domid = $dnsdb->_hostparent($fqdn); + if ($domid) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $domid, 'n'); + $recsth->execute($domid, 0, $fqdn, 17, "$email $txtrec", 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + } + } + + } elsif ($type == 44) { + # SSHFP + my $sshfp = _byteparse(\$rdata, 1); + $sshfp .= " "._byteparse(\$rdata, 1); + $sshfp .= " "._rdata2hex($rdata); + + # these do not make sense in a reverse zone, since they're logically attached to an A record + my $domid = $dnsdb->_hostparent($fqdn); + if ($domid) { + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $domid, 'n'); + $recsth->execute($domid, 0, $fqdn, 44, $sshfp, 0, 0, 0, $ttl, $loc, $stamp, $expires, $stampactive); + } else { + push @deferred, $rec unless $nodefer; + $impok = 0; + } + + } else { + print "unhandled rec $rec\n"; + $impok = 0; + # ... uhhh, dunno + } + + } else { + $cnt{other}++; + print " $_\n"; + } + + return $impok; # just to make sure + } # recslurp() + + close FLAT; +} Index: /tags/1.2/vega-import.pl =================================================================== --- /tags/1.2/vega-import.pl (revision 556) +++ /tags/1.2/vega-import.pl (revision 556) @@ -0,0 +1,411 @@ +#!/usr/bin/perl +# Import script for VegaDNS data +## +# $Id$ +# Copyright 2011-2013 Kris Deugau +# +# 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 . +## + +# Runs in one of two modes: +# - Wipe the contents and import the VegaDNS data with (almost) all entity-ID info as-is +# - Add the contents to the current DB, as a subgroup of the root parent group 1 + +use strict; +use warnings; + +use DBI; +use Data::Dumper; + +use DNSDB; + +my $dnsdb = new DNSDB; + +my $mode = 'add'; + +if ($ARGV[0] && $ARGV[0] !~ /^(add|replace)$/) { + die "Usage: vega-import.pl [add|replace]\n". + " add Import VegaDNS data as a subgroup of the default root group (default)\n". + " replace Wipe all existing data and import VegaDNS data into the root group\n"; +} + +$mode = $ARGV[0] if $ARGV[0]; + +my $newdbh = $dnsdb->{dbh}; +$newdbh->{PrintError} = 1; +$newdbh->{PrintWarn} = 1; + +my %vegatypes = ('S' => 'SOA', 'N' => 'NS', 'A' => 'A', 'T' => 'TXT', + 'V' => 'SRV', 'P' => 'PTR', 'M' => 'MX', 'C' => 'CNAME', + '3' => 'AAAA' ); + +if ($mode eq 'replace') { + print "WARNING: Using 'replace' will **DELETE** all existing group,\n". + "user, domain, and record data in DeepNet DNS Administrator.\n". + "Once started this cannot be reversed. Enter 'yes' to proceed: "; + my $resp = ; + chomp $resp; + if ($resp ne 'yes') { + print "Aborting; no changes made.\n"; + exit; + } else { + print "OK, continuing.\n"; + $newdbh->do("DELETE FROM users") or warn "error deleting users: ".$newdbh->errstr."\n"; + $newdbh->do("DELETE FROM log") or warn "error deleting log: ".$newdbh->errstr."\n"; + $newdbh->do("DELETE FROM default_records") or warn "error deleting defrecs: ".$newdbh->errstr."\n"; + $newdbh->do("DELETE FROM records") or warn "error deleting records: ".$newdbh->errstr."\n"; + $newdbh->do("DELETE FROM domains") or warn "error deleting domains: ".$newdbh->errstr."\n"; + $newdbh->do("DELETE FROM groups") or warn "error deleting groups: ".$newdbh->errstr."\n"; + $newdbh->do("DELETE FROM permissions") or warn "error deleting permissions: ".$newdbh->errstr."\n"; + # set seq id on permissions, since we merged the two tables, and the new permission IDs will not match the old + $newdbh->do("SELECT pg_catalog.setval(pg_catalog.pg_get_serial_sequence('permissions', 'permission_id'),". + "1, false)") or warn "couldn't set permission sequence: ".$newdbh->errstr."\n"; + # set seq id on default_records since we're inserting more than we retrieved + $newdbh->do("SELECT pg_catalog.setval(pg_catalog.pg_get_serial_sequence('default_records', 'record_id'),". + "1, false)") or warn "couldn't set defrec sequence: ".$newdbh->errstr."\n"; + } +} + +my $vegadbh = DBI->connect('DBI:mysql:database=vegadns;host=localhost', 'vegadns', 'secret', { + PrintError => 1, + PrintWarn => 1, + AutoCommit => 0 + }); + +my $grpsubs = $vegadbh->prepare("SELECT group_id FROM groups ORDER BY group_id"); +my $grpdata = $vegadbh->prepare("SELECT group_id, parent_group_id, name FROM groups WHERE group_id=?"); +my $grppget = $vegadbh->prepare("SELECT perm_id,inherit_group_perms,accouedit,accoucreate,accoudelete,". + "self_edit,group_edit,group_create,group_delete,domain_edit,domain_create,domain_delete,record_edit,". + "record_create,record_delete FROM group_permissions WHERE group_id=?"); +my $userget = $vegadbh->prepare("SELECT user_id, group_id, email, password, first_name, last_name, phone, ". + "account_type, status FROM accounts WHERE group_id=?"); +my $userpget = $vegadbh->prepare("SELECT perm_id,inherit_group_perms,accouedit,accoucreate,accoudelete,". + "self_edit,group_edit,group_create,group_delete,domain_edit,domain_create,domain_delete,record_edit,". + "record_create,record_delete FROM user_permissions WHERE user_id=?"); +my $domget = $vegadbh->prepare("SELECT domain_id,domain,description,status FROM domains WHERE group_id=?"); +my $recget = $vegadbh->prepare("SELECT record_id,host,type,val,distance,weight,port,ttl,description ". + "FROM records WHERE domain_id=?"); +my $defrecget = $vegadbh->prepare("SELECT group_id, host, type, val, distance, weight, port, ttl, ". + "description FROM default_records WHERE group_id=?"); +my $logget = $vegadbh->prepare("SELECT domain_id, user_id, group_id, email, name, entry, time FROM log ". + "WHERE group_id=?"); + +my $newgrp = $newdbh->prepare("INSERT INTO groups (group_id,parent_group_id,group_name,permission_id) ". + "VALUES (?,?,?,?)"); +my $newgrppset = $newdbh->prepare("INSERT INTO permissions (self_edit, group_create, ". + "group_edit, group_delete, user_create, user_edit, user_delete, domain_create, domain_edit, ". + "domain_delete, record_create, record_edit, record_delete, group_id) ". + "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)"); +my $newpid = $newdbh->prepare("SELECT currval('permissions_permission_id_seq')"); +my $newuser = $newdbh->prepare("INSERT INTO users (user_id, group_id, username, password, firstname, ". + "lastname, phone, type, status, permission_id, inherit_perm) VALUES (?,?,?,?,?,?,?,?,?,?,'f')"); +my $newuserpset = $newdbh->prepare("INSERT INTO permissions (admin, self_edit, group_create, ". + "group_edit, group_delete, user_create, user_edit, user_delete, domain_create, domain_edit, ". + "domain_delete, record_create, record_edit, record_delete, user_id) ". + "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"); +my $newdom = $newdbh->prepare("INSERT INTO domains (domain_id, domain, group_id, description, status) VALUES ". + "(?,?,?,?,?)"); +my $newrec = $newdbh->prepare("INSERT INTO records (domain_id,record_id,host,type,val,distance,weight,port,". + "ttl,description) VALUES (?,?,?,?,?,?,?,?,?,?)"); +my $newdefrec = $newdbh->prepare("INSERT INTO default_records (group_id,host,type,val,distance,". + "weight,port,ttl,description) VALUES (?,?,?,?,?,?,?,?,?)"); +my $logput = $newdbh->prepare("INSERT INTO log (domain_id, user_id, group_id, email, name, entry, stamp) ". + "VALUES (?,?,?,?,?,?,?)"); + +my $newgrpid = $newdbh->prepare("SELECT currval('groups_group_id_seq')"); +my $newpgidup = $newdbh->prepare("UPDATE groups SET permission_id=? WHERE group_id=?"); +my $newuserid = $newdbh->prepare("SELECT currval('users_user_id_seq')"); +my $newpuidup = $newdbh->prepare("UPDATE users SET permission_id=? WHERE user_id=?"); +my $newdomid = $newdbh->prepare("SELECT currval('domains_domain_id_seq')"); +my $newrecid = $newdbh->prepare("SELECT currval('records_record_id_seq')"); + +my $newgrp_add = $newdbh->prepare("INSERT INTO groups (parent_group_id,group_name) VALUES (?,?)"); +my $newuser_add = $newdbh->prepare("INSERT INTO users (group_id, username, password, firstname, ". + "lastname, phone, type, status, inherit_perm) VALUES (?,?,?,?,?,?,?,?,'f')"); +my $newdom_add = $newdbh->prepare("INSERT INTO domains (domain, group_id, description, status) VALUES ". + "(?,?,?,?)"); +my $newrec_add = $newdbh->prepare("INSERT INTO records (domain_id,host,type,val,distance,weight,port,". + "ttl,description) VALUES (?,?,?,?,?,?,?,?,?)"); + +my $foo = qq( + +perm_id | group_id | inherit_group_perms | accouedit | accoucreate | accoudelete | self_edit | group_edit | +group_create | group_delete | domain_edit | domain_create | domain_delegate | domain_delete | record_edit | +record_create | record_delete | record_delegate | default_record_edit | default_record_create | +default_record_delete | rrtype_allow_n | rrtype_allow_a | rrtype_allow_3 | rrtype_allow_6 | rrtype_allow_m | +rrtype_allow_p | rrtype_allow_t | rrtype_allow_v | rrtype_allow_all + +permission_id | admin | self_edit | group_create | group_edit | group_delete | user_create | user_edit | +user_delete | domain_create | domain_edit | domain_delete | record_create | record_edit | record_delete | +user_id | group_id + +); + +my $maxgrp = 0; +my %pcmap; # used to map parent/child relations + +if ($mode eq 'replace') { + + my $stage = 'start'; + $grpsubs->execute; + my $grp = 0; + while (($grp) = $grpsubs->fetchrow_array()) { + $maxgrp = $grp if $grp > $maxgrp; + dogroup_replace($grp); + } + + # Fix up sequence numbers to prevent insert problems + my %idmap = ('groups' => 'group_id', 'users' => 'user_id', 'domains' => 'domain_id', + 'records' => 'record_id'); + for my $table ('groups','users','domains','records') { + $newdbh->do("SELECT pg_catalog.setval(pg_catalog.pg_get_serial_sequence('$table','$idmap{$table}'),". + "(SELECT max($idmap{$table}) FROM $table),true)"); + } + +} else { + + $grpsubs->execute; + my $grp = 0; + while (($grp) = $grpsubs->fetchrow_array()) { + $maxgrp = $grp if $grp > $maxgrp; + dogroup_add($grp); + } + +} + +# and done. +exit; + +sub dogroup_replace { + my $grpid = shift; + $grpdata->execute($grpid) or warn $grpdata->errstr; + my $oldgrp = $grpdata->fetchrow_hashref() or warn $grpdata->errstr; + print "group id $grpid, name $oldgrp->{name}\n"; + + $grppget->execute($grpid) or warn $grppget->errstr; + my $oldp; + unless ($oldp = $grppget->fetchrow_hashref()) { + foreach my $permtype ('self_edit', 'group_create', 'group_edit', 'group_delete', 'user_create', + 'user_edit', 'user_delete', 'domain_create', 'domain_edit', 'domain_delete', 'record_create', + 'record_edit', 'record_delete') { $oldp->{$permtype} = 't'; } + } + + # de-nullify + foreach my $permtype ('self_edit', 'group_create', 'group_edit', 'group_delete', 'user_create', + 'user_edit', 'user_delete', 'domain_create', 'domain_edit', 'domain_delete', 'record_create', + 'record_edit', 'record_delete') { + $oldp->{$permtype} = 'f' if !defined($oldp->{$permtype}); + } + $newgrppset->execute($oldp->{self_edit}, $oldp->{group_create}, $oldp->{group_edit}, $oldp->{group_delete}, + $oldp->{user_create}, $oldp->{user_edit}, $oldp->{user_delete}, + $oldp->{domain_create}, $oldp->{domain_edit}, $oldp->{domain_delete}, + $oldp->{record_create}, $oldp->{record_edit}, $oldp->{record_delete}, + $grpid) or warn $newgrppset->errstr; + $newpid->execute; + my ($pid) = $newpid->fetchrow_array; + $newgrp->execute($grpid, $oldgrp->{parent_group_id}, $oldgrp->{name}, $pid); + + ## Users + print " users: "; + $userget->execute($grpid); + while (my $user = $userget->fetchrow_hashref) { + # fiddle user data + $user->{account_type} = 'S' if $user->{account_type} eq 'senior_admin'; + $user->{account_type} = 'u' if $user->{account_type} eq 'user'; + $user->{status} = ($user->{status} eq 'active' ? 1 : 0); + $userpget->execute($user->{user_id}) or warn "failed permission get on ".$user->{user_id}."\n"; + my $oldp = $userpget->fetchrow_hashref; + # de-nullify + foreach my $permtype ('admin', 'self_edit', 'group_create', 'group_edit', 'group_delete', 'user_create', + 'user_edit', 'user_delete', 'domain_create', 'domain_edit', 'domain_delete', 'record_create', + 'record_edit', 'record_delete') { + $oldp->{$permtype} = 'f' if !defined($oldp->{$permtype}); + } + $newuserpset->execute(($user->{account_type} eq 'S' ? 't' : 'f'), $oldp->{self_edit}, + $oldp->{group_create}, $oldp->{group_edit}, $oldp->{group_delete}, + $oldp->{user_create}, $oldp->{user_edit}, $oldp->{user_delete}, + $oldp->{domain_create}, $oldp->{domain_edit}, $oldp->{domain_delete}, + $oldp->{record_create}, $oldp->{record_edit}, $oldp->{record_delete}, + $user->{user_id}) or warn $newgrppset->errstr; + $newpid->execute; + my ($pid) = $newpid->fetchrow_array; + $newuser->execute($user->{user_id}, $user->{group_id}, $user->{email}, $user->{password}, + $user->{first_name}, $user->{last_name}, $user->{phone}, $user->{account_type}, $user->{status}, $pid) + or warn " new user ".$user->{email}." (".$user->{user_id}.") failed: ".$newuser->errstr."\n"; + print $user->{email}." (".$user->{user_id}."), "; + } + + ## Domains + print "\n domains: "; + $domget->execute($grpid); + while (my ($id,$dom,$desc,$status) = $domget->fetchrow_array) { + $status = ($status eq 'active' ? 1 : 0); + $newdom->execute($id, $dom, $grpid, $desc, $status); + print "$dom ($id), "; + $recget->execute($id); + while (my @rec = $recget->fetchrow_array) { + $rec[2] = $reverse_typemap{$vegatypes{$rec[2]}}; + $rec[4] = 0 if !$rec[4]; + $rec[5] = 0 if !$rec[5]; + $rec[6] = 0 if !$rec[6]; + $newrec->execute($id,@rec); + } + } + + ## Default records + print "\n default records: "; + $defrecget->execute(1); # Vega 1.1.5/1.1.6 do not have default records for all groups; + # there is only support for one set of default records coded. + while (my @rec = $defrecget->fetchrow_array) { + $rec[0] = $grpid; + $rec[2] = $reverse_typemap{$vegatypes{$rec[2]}}; + $rec[4] = 0 if !$rec[4]; + $rec[5] = 0 if !$rec[5]; + $rec[6] = 0 if !$rec[6]; + $newdefrec->execute(@rec); + } + + ## Log entries + print "\n log entries: "; + $logget->execute($grpid); + while (my ($did,$uid,$gid,$email,$name,$entry,$stamp) = $logget->fetchrow_array) { + $stamp = localtime($stamp).''; + $logput->execute($did,$uid,$gid,$email,$name,'[Vega] '.$entry,$stamp); + } + + print "\n done\n"; +} + +sub dogroup_add { + my $oldgrpid = shift; + + $grpdata->execute($oldgrpid) or warn $grpdata->errstr; + my $oldgrp = $grpdata->fetchrow_hashref() or warn $grpdata->errstr; + print "group id $oldgrpid, name $oldgrp->{name}\n"; + + my $newgrpparent = $pcmap{g}{$oldgrp->{parent_group_id}}; + $newgrpparent = 1 if $oldgrpid == 1; + + # do in the same order as dnsdb + $newgrp_add->execute($newgrpparent, $oldgrp->{name}); + $newgrpid->execute; + my ($newgid) = $newgrpid->fetchrow_array; + $pcmap{g}{$oldgrpid} = $newgid; + + $grppget->execute($oldgrpid) or warn $grppget->errstr; + my $oldp; + unless ($oldp = $grppget->fetchrow_hashref()) { + foreach my $permtype ('self_edit', 'group_create', 'group_edit', 'group_delete', 'user_create', + 'user_edit', 'user_delete', 'domain_create', 'domain_edit', 'domain_delete', 'record_create', + 'record_edit', 'record_delete') { $oldp->{$permtype} = 't'; } + } + + # de-nullify + foreach my $permtype ('self_edit', 'group_create', 'group_edit', 'group_delete', 'user_create', + 'user_edit', 'user_delete', 'domain_create', 'domain_edit', 'domain_delete', 'record_create', + 'record_edit', 'record_delete') { + $oldp->{$permtype} = 'f' if !defined($oldp->{$permtype}); + } + $newgrppset->execute($oldp->{self_edit}, $oldp->{group_create}, $oldp->{group_edit}, $oldp->{group_delete}, + $oldp->{user_create}, $oldp->{user_edit}, $oldp->{user_delete}, + $oldp->{domain_create}, $oldp->{domain_edit}, $oldp->{domain_delete}, + $oldp->{record_create}, $oldp->{record_edit}, $oldp->{record_delete}, + $newgid) or warn $newgrppset->errstr; + $newpid->execute; + my ($pid) = $newpid->fetchrow_array; + $newpgidup->execute($pid,$newgid); + + ## Users + print " users: "; + $userget->execute($oldgrpid); + while (my $user = $userget->fetchrow_hashref) { + # fiddle user data + $user->{account_type} = 'S' if $user->{account_type} eq 'senior_admin'; + $user->{account_type} = 'u' if $user->{account_type} eq 'user'; + $user->{status} = ($user->{status} eq 'active' ? 1 : 0); + $userpget->execute($user->{user_id}) or warn "failed permission get on ".$user->{user_id}."\n"; + + $newuser_add->execute($newgid, $user->{email}, $user->{password}, $user->{first_name}, + $user->{last_name}, $user->{phone}, $user->{account_type}, $user->{status}) + or warn " new user ".$user->{email}." (".$user->{user_id}.") failed: ".$newuser->errstr."\n"; + print " user ".$user->{email}." (".$user->{user_id}."), "; + $newuserid->execute; + my ($newuid) = $newuserid->fetchrow_array; + $pcmap{u}{$user->{user_id}} = $newuid; + + my $oldp = $userpget->fetchrow_hashref; + # de-nullify + foreach my $permtype ('admin', 'self_edit', 'group_create', 'group_edit', 'group_delete', 'user_create', + 'user_edit', 'user_delete', 'domain_create', 'domain_edit', 'domain_delete', 'record_create', + 'record_edit', 'record_delete') { + $oldp->{$permtype} = 'f' if !defined($oldp->{$permtype}); + } + $newuserpset->execute(($user->{account_type} eq 'S' ? 't' : 'f'), $oldp->{self_edit}, + $oldp->{group_create}, $oldp->{group_edit}, $oldp->{group_delete}, + $oldp->{user_create}, $oldp->{user_edit}, $oldp->{user_delete}, + $oldp->{domain_create}, $oldp->{domain_edit}, $oldp->{domain_delete}, + $oldp->{record_create}, $oldp->{record_edit}, $oldp->{record_delete}, + $newuid) or warn $newgrppset->errstr; + $newpid->execute; + my ($pid) = $newpid->fetchrow_array; + $newpuidup->execute($pid,$newuid); + } + + ## Domains + print "\n domains: "; + $domget->execute($oldgrpid); + while (my ($id,$dom,$desc,$status) = $domget->fetchrow_array) { + $status = ($status eq 'active' ? 1 : 0); + $newdom_add->execute($dom, $newgid, $desc, $status); + print "$dom ($id), "; + $newdomid->execute; + my ($newdid) = $newdomid->fetchrow_array; + $pcmap{d}{$id} = $newdid; + $recget->execute($id); + while (my @rec = $recget->fetchrow_array) { + $rec[0] = $newdid; + $rec[2] = $reverse_typemap{$vegatypes{$rec[2]}}; + $rec[4] = 0 if !$rec[4]; + $rec[5] = 0 if !$rec[5]; + $rec[6] = 0 if !$rec[6]; + $newrec_add->execute(@rec); + } + } + + ## Default records + print "\n default records: "; + $defrecget->execute(1); # Vega 1.1.5/1.1.6 do not have default records for all groups; + # there is only support for one set of default records coded. + while (my @rec = $defrecget->fetchrow_array) { + $rec[0] = $newgid; + $rec[2] = $reverse_typemap{$vegatypes{$rec[2]}}; + $rec[4] = 0 if !$rec[4]; + $rec[5] = 0 if !$rec[5]; + $rec[6] = 0 if !$rec[6]; + $newdefrec->execute(@rec); + } + + ## Log entries + print "\n log entries: "; + $logget->execute($oldgrpid); + while (my ($did,$uid,$gid,$email,$name,$entry,$stamp) = $logget->fetchrow_array) { + $did = $pcmap{d}{$did}; + $uid = $pcmap{u}{$uid}; + $gid = $pcmap{g}{$gid}; + $stamp = localtime($stamp).''; + $logput->execute($did,$uid,$gid,$email,$name,'[V] '.$entry,$stamp); + } + + print "\n done\n"; +}