Index: branches/cname-collision/COPYING =================================================================== --- branches/cname-collision/COPYING (revision 936) +++ branches/cname-collision/COPYING (revision 936) @@ -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: branches/cname-collision/DNSDB.pm =================================================================== --- branches/cname-collision/DNSDB.pm (revision 936) +++ branches/cname-collision/DNSDB.pm (revision 936) @@ -0,0 +1,7268 @@ +# dns/trunk/DNSDB.pm +# Abstraction functions for DNS administration +## +# $Id$ +# Copyright 2008-2025 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 Digest::MD5 qw(md5_hex); +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.3; ##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/', + usecache => 1, # do we bother using the cache above? + + # BIND-style zone export + bind_export_conf_path => 'zones.conf', + # should arguably inherit something from BIND defaults for /var/named? + bind_export_zone_path => 'zones/db.%zone', + # just in case someone wants reverse zones separate from forward zones + bind_export_zone_path => 'zones/db.%zone', + bind_export_fqdn => 1, + bind_export_autoexpire_ttl => 15, + + # Session params + timeout => '1h', # passed as-is to CGI::Session + + # Other miscellanea + log_failures => 1, # log all evarthing by default + perpage => 15, + maxfcgi => 10, # reasonable default? + force_refresh => 1, + lowercase => 0, # mangle as little as possible by default + # show IPs and CIDR blocks as-is for reverse zones. valid values are + # 'none' (default, show natural IP or CIDR) + # 'zone' (zone name, wherever used) + # 'record' (IP or CIDR values in reverse record lists) + # 'all' (all IP values in any reverse zone view) + showrev_arpa => 'none', + # Two options for template record expansion: + template_skip_0 => 0, # publish .0 by default + template_skip_255 => 0, # publish .255 by default + # allow TXT records to be dealt with mostly automatically by DNS server? + autotxt => 1, + ); + + # 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', 'usecache', + 'bind_export_fqdn', 'template_skip_0', 'template_skip_255', 'autotxt') { + 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}, using default\n"; + $self->{$boolopt} = $defconfig{$boolopt}; + } + } + } + + # Enum-ish option(s) + if (!grep /$self->{showrev_arpa}/, ('none','zone','record','all')) { + warn "Bad showrev_arpa setting $self->{showrev_arpa}, using default\n"; + $self->{showrev_arpa} = 'none'; + } + + # 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::_zonetable() +# Takes default+rdns flags, returns appropriate zone table name +sub _zonetable { + my $def = shift; + my $rev = shift; + + return 'domains' if $rev ne 'y'; + return 'revzones'; +} # end _zonetable() + +## 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::_maybeip() +# Wrapper for quick "does this look like an IP address?" regex, so we don't make dumb copy-paste mistakes +sub _maybeip { + my $izzit = shift; # reference + return 1 if $$izzit =~ m,^(?:[0-9\.]+|[0-9a-fA-F:]+)(?:/[0-9]+)?$,; +} + +## DNSDB::_inrev() +# Check if a given "hostname" is within a given reverse zone +# Takes a reference to the "hostname" and the reverse zone CIDR as a NetAddr::IP +# Returns true/false. Sets $errstr on errors. +sub _inrev { + my $self = shift; + my $dbh = $self->{dbh}; + # References, since we might munge them + my $fq = shift; + my $zone = shift; + + # set default error + $errstr = "$$fq not within $zone"; + + # Unlike forward zones, we will not coerce the data into the reverse zone - an A record + # in a reverse zone is already silly enough without appending a mess of 1.2.3.in-addr.arpa + # (or worse, 1.2.3.4.5.6.7.8.ip6.arpa) on the end of the nominal "hostname". + # We're also going to allow the "hostname" to be stored as .arpa or IP, because of + # non-IP FQDNs in .arpa + if ($$fq =~ /\.arpa$/) { + # "FQDN" could be any syntactically legitimate string, but it must be within the formal + # .arpa zone. Note we're not validating these for correct reverse-IP values. + # yes, we really need the v6 branch on the end here. + $zone = _ZONE($zone, 'ZONE', 'r', '.').($zone->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'); + return unless $$fq =~ /$zone$/; + } else { + # in most cases we should be getting a real IP as the "FQDN" to test + my $addr = new NetAddr::IP $$fq if _maybeip($fq); + + # "FQDN" should be a valid IP address. Normalize formatting if so. + if (!$addr) { + $errstr = "$$fq is not a valid IP address"; + return; + } + return if !$zone->contains($addr); + ($$fq = $addr) =~ s{/(?:32|128)$}{}; + } + return 1; +} # end _inrev() + +## 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, logparent +# The %userdata hash provides the user ID, username, and fullname +# Returns the log entry ID, mainly for use in bulk operations to allow a "parent" log entry +# and a set of child entries (eg, domain add and the individual default-record-copy entries) +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}; + $args{logparent} = 0 if !$args{logparent}; + +##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,logparent,entry,user_id,email,name) ". + "VALUES (?,?,?,?,?,?,?,?)", + undef, + ($args{domain_id}, $args{rdns_id}, $args{group_id}, $args{logparent}, $args{entry}, + $self->{loguserid}, $self->{logusername}, $self->{logfullname}) ); + + my ($log_id) = $dbh->selectrow_array("SELECT currval('log_log_id_seq')"); + return $log_id; + +# } elsif ($self->{log_channel} eq 'file') { +# } elsif ($self->{log_channel} eq 'syslog') { +# } +} # end _log() + +## DNSDB::_updateserial() +# Update the serial number on a forward and/or reverse zone, and flag it as changed +# Takes a logdata hash +sub _updateserial { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + +##fixme: refine to adjust for serial wraparound, ie, if switching from ISO to Unix, +# the serial effectively runs backwards. technically this breaks AXFR slaves. + +##perlnote +# Nested subs... aren't. Subs have file or execution scope, sort of (not sure which ATM), so we +# have to abuse the "anonymous sub" construct and bend our code in a pretzel to work around this limitation. + + # heavy lifting done in this sub-sub. updates may be needed on a forward zone, reverse zone, or both, depending. + my $serup = sub { + my $rev = shift; + my $zid = shift; + my $tname = _zonetable('n', $rev); + my $pname = _recparent('n', $rev); + my ($sertype,$serial) = $dbh->selectrow_array("SELECT sertype,zserial FROM $tname WHERE $pname = ?", undef, $zid) or die $dbh->errstr; + if ($sertype eq 'U') { + # Unix timestamp + $dbh->do("UPDATE $tname SET changed = 'y',zserial = ? WHERE $pname = ?", undef, (scalar(time), $zid) ); + } elsif ($sertype eq 'D') { + # ISO datestamp (YYYYMMDDnn) + my $newserial = strftime("%Y%m%d00", localtime); + if ($newserial > $serial) { + # new day, use the new serial + $serial = $newserial; + } else { + # change on same day, increment existing serial + $serial++; +##fixme: do we need to check for overflow? (eg 2020091599 -> 2020091600 despite not being 2020-09-16) +# technically yes, practically no (effectively falls back to a variation of the simple sequential update) +# - might be a local policy violation. also, any such zone is probably better served by a fixed stub +# and DDNS as supported by BIND etc + } + $dbh->do("UPDATE $tname SET changed = 'y',zserial = ? WHERE $pname = ?", undef, ($serial, $zid) ); + } elsif ($sertype eq 'S') { + # Simple sequential number + $dbh->do("UPDATE $tname SET changed = 'y', zserial = zserial + 1 WHERE $pname = ?", undef, $zid ); + } else { +##fixme: just fall back to simple sequential? shouldn't be possible to have any value other than U, D, or S + # Your llama is on fire + } + }; + + if ($args{rdns_id}) { + &$serup('y', $args{rdns_id}); + } + + if ($args{domain_id}) { + &$serup('n', $args{domain_id}); + } + +} # end _updateserial() + + +## DNSDB::_recfilter() +# Utility sub to construct an SQL fragment for host/value filtering based on a filter argument +# Deconstructs the argument to apply Postgres CIDR operators or Postgres string-matching operators as appropriate +# Used by recSearchCount(), recSearch(), getRecList(), and getRecCount() +# Takes a hash of: +# filter - string to create SQL fragment from +# sql - reference to SQL string. SQL fragment will be appended to this string +# bindvars - reference to list of DBI bind variable scalars to be fed to DBI on execute +sub _recfilter { + my %args = @_; + + # flag for "was this an IPish filter argument?", since we want to fall through + # to the second top-level if() if *any* of the ones in the first block fail + my $ipfilt = 0; + + if ($args{filter} =~ /^\s*(<|<=|=|>=|>|<>|<<|<<=|>>|>>=)\s*([\da-fA-F].+)\s*$/) { + # filter argument starts with a Postgres CIDR operator, followed by something that could be a CIDR value + my $filt_op = $1; + my $filt_val = $2; + # do we have an IP-ish value? + if ($filt_val =~ m,^(?:[\d.]+|[0-9a-f]+)(?:/\d+)?$,) { + # now make sure + my $tmp = new NetAddr::IP $filt_val; + if ($tmp) { + ${$args{sql}} .= " AND inetlazy(r.val) $filt_op ?"; + push @{$args{bindvars}}, $filt_val; + $ipfilt = 1; + } # really looks like a valid IP/CIDR + } # looks IPish + } # has CIDR operator + + if (!$ipfilt) { + # simple text matching, with a bit of mix-n-match to account for .arpa names + ${$args{sql}} .= " AND (r.host ~* ? OR r.val ~* ? OR r.host ~* ? OR r.val ~* ?)"; + my $tmp = join('.',reverse(split(/\./,$args{filter}))); + push @{$args{bindvars}}, ($args{filter},$args{filter}); + push @{$args{bindvars}}, ($tmp, $tmp); + } + +} # _recfilter + + +## +## 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 = @_; + +# only for strict type restrictions +# return ('FAIL', 'Reverse zones cannot contain A records') if $args{revrec} eq 'y'; + + if ($args{revrec} eq 'y') { + # Get the revzone, so we can see if ${$args{val}} is in that zone + my $revzone = new NetAddr::IP $self->revName($args{id}, 'y'); + + return ('FAIL', $errstr) if !$self->_inrev($args{val}, $revzone); + + # ${$args{val}} is either a valid IP or a string ending with the .arpa zone name; + # now check if it's a well-formed FQDN + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec}) && + ${$args{val}} =~ /\.arpa$/; + + # 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',"A record must be a valid IPv4 address") + unless ${$args{host}} =~ m{^\d+\.\d+\.\d+\.\d+(/\d+)?$}; + $args{addr} = new NetAddr::IP ${$args{host}}; + return ('FAIL',"A record must be a valid IPv4 address") + unless $args{addr} && !$args{addr}->{isv6}; + # coerce IP/value to normalized form for storage + ${$args{host}} = $args{addr}->addr; + + # I'm just going to ignore the utterly barmy idea of an A record in the *default* + # records for a reverse zone; it's bad enough to find one in funky legacy data. + + } else { + # revrec ne '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$/i); + + # Check if it's a proper formal .arpa name for an IP, and renormalize it to the IP + # value if so. Done mainly for symmetry with PTR/A+PTR, and saves a conversion on export. + if (${$args{val}} =~ /\.arpa$/) { + my ($code,$tmp) = _zone2cidr(${$args{val}}); + if ($code ne 'FAIL') { + ${$args{val}} = $tmp->addr; + $args{addr} = $tmp; + } + } + # 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',"A record must be a valid IPv4 address") + unless ${$args{val}} =~ /^\d+\.\d+\.\d+\.\d+$/; + $args{addr} = new NetAddr::IP ${$args{val}}; + return ('FAIL',"A 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 = @_; + + # NS target check - IP addresses not allowed. Must be a more or less well-formed hostname. + if ($args{revrec} eq 'y') { + return ('FAIL', "NS records cannot point directly to an IP address") + if ${$args{host}} =~ /^(?:[\d.]+|[0-9a-fA-F:]+)$/; +##enhance: Look up the passed value to see if it exists. Ooo, fancy. + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{host}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + } else { + return ('FAIL', "NS records cannot point directly to an IP address") + if ${$args{val}} =~ /^(?:[\d.]+|[0-9a-fA-F:]+)$/; +##enhance: Look up the passed value to see if it exists. Ooo, fancy. + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + } + + # Check that the target of the record is within the parent. + if ($args{defrec} eq 'n') { + # Check if IP/address/zone/"subzone" is within the parent + if ($args{revrec} eq 'y') { + # Get the revzone, so we can see if ${$args{val}} is in that zone + my $revzone = new NetAddr::IP $self->revName($args{id}, 'y'); + + # Note the NS record may or may not be for the zone itself, it may be a pointer for a subzone + return ('FAIL', $errstr) if !$self->_inrev($args{val}, $revzone); + + # ${$args{val}} is either a valid IP or a string ending with the .arpa zone name; + # now check if it's a well-formed FQDN +##enhance or ##fixme +# convert well-formed .arpa names to IP addresses to match old "strict" validation design + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec}) && + ${$args{val}} =~ /\.arpa$/; + } else { + # Forcibly append the domain name if the hostname being added does not end with the current domain name + my $pname = $self->domainName($args{id}); + ${$args{host}} =~ s/\.*$/\.$pname/ if (${$args{host}} ne '@' && ${$args{host}} !~ /$pname$/i); + } + } else { + # Default reverse NS records should always refer to the implied parent. + if ($args{revrec} eq 'y') { + ${$args{val}} = 'ZONE'; + } else { + ${$args{host}} = 'DOMAIN'; + } + } + + return ('OK','OK'); +} # done NS record + +# CNAME record +sub _validate_5 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + # CNAMEs in reverse zones shouldn't be handled manually, they should be generated on + # export by use of the "delegation" type. For the masochistic, and those importing + # legacy data from $deity-knows-where, we'll support them. + + if ($args{revrec} eq 'y') { + # CNAME target check - IP addresses not allowed. Must be a more or less well-formed hostname. + return ('FAIL', "CNAME records cannot point directly to an IP address") + if ${$args{host}} =~ /^(?:[\d.]+|[0-9a-fA-F:]+)$/; + + if ($args{defrec} eq 'n') { + # Get the revzone, so we can see if ${$args{val}} is in that zone + my $revzone = new NetAddr::IP $self->revName($args{id}, 'y'); + return ('FAIL', $errstr) if !$self->_inrev($args{val}, $revzone); + # CNAMEs can not be used for parent nodes; just leaf nodes with no other record types + # note that this WILL probably miss some edge cases. + if (${$args{val}} =~ /^[\d.\/]+$/) { + # convert IP "hostname" to .arpa + my $tmphn = _ZONE(NetAddr::IP->new(${$args{val}}), 'ZONE', 'r', '.'); + my $tmpz = _ZONE($revzone, 'ZONE', 'r', '.'); + return ('FAIL', "The bare zone may not be a CNAME") if $tmphn eq $tmpz; +##enhance: look up the target name and publish that instead on export + } + } + +##enhance or ##fixme +# convert well-formed .arpa names to IP addresses to match old "strict" validation design + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec}) && + ${$args{val}} =~ /\.arpa$/; + +##enhance: Look up the passed value to see if it exists. Ooo, fancy. + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{host}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + } else { + # a bit expensive to put this here, but we need some kind of cheap flag for an RPZ zone with different rules + my $zname = $self->domainName($args{id}); + if ($zname =~ /\.rpz$/) { + # RPZ domains consist almost entirely of CNAME records, and have special rules for their syntax + # From the Unbound doc: https://unbound.docs.nlnetlabs.nl/en/latest/topics/filtering/rpz.html + # Supposedly other overrides are also valid + return ('FAIL', "Unsupported RPZ override ${$args{val}}") + unless ${$args{val}} =~ /^(?:\.|\*\.|rpz-passthru\.|rpz-drop\.|rpz-tcp-only\.)$/; + # Append the RPZ name + my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id})); + ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/i; + } else { + # CNAME target check - IP addresses not allowed. Must be a more or less well-formed hostname. + return ('FAIL', "CNAME records cannot point directly to an IP address") + if ${$args{val}} =~ /^(?:[\d.]+|[0-9a-fA-F:]+)$/; + + # Make sure target is a well-formed hostname + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + + # Forcibly append the domain name if the hostname being added does not end with the current domain name + my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $zname); + ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/i; + + # CNAMEs can not be used for parent nodes; just leaf nodes with no other record types + # Enforce this for the zone name + return ('FAIL', "The bare zone name may not be a CNAME") if ${$args{host}} eq $pname || ${$args{host}} =~ /^\@/; + +##enhance: Look up the passed value to see if it exists. Ooo, fancy. + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + } # $zname !~ .rpz + } # revzone eq 'n' + + 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 = @_; + my $warnflag = ''; + + if ($args{defrec} eq 'y') { + if ($args{revrec} eq 'y') { + if (${$args{val}} =~ /^[\d.]+$/) { + # v4 or bare number + if (${$args{val}} =~ /^\d+\.\d+\.\d+\.\d+$/) { + # probable full IP. pointless but harmless. validate/normalize. + my $tmp = NetAddr::IP->new(${$args{val}})->addr + or return ('FAIL', "${$args{val}} is not a valid IP address"); + ${$args{val}} = $tmp; + $warnflag = "${$args{val}} will only be added to a small number of zones\n"; + } elsif (${$args{val}} =~ /^\d+$/) { + # bare number. This can be expanded to either a v4 or v6 zone + ${$args{val}} =~ s/^\.*/ZONE./ unless ${$args{val}} =~ /^ZONE/; + } else { + # $deity-only-knows what kind of gibberish we've been given. Only usable as a formal .arpa name. + # Append ARPAZONE to be replaced with the formal .arpa zone name when converted to a live record. + ${$args{val}} =~ s/\.*$/.ARPAZONE/ unless ${$args{val}} =~ /ARPAZONE$/; + } + } elsif (${$args{val}} =~ /^[a-fA-F0-9:]+$/) { + # v6 or fragment; pray it's not complete gibberish + ${$args{val}} =~ s/^:*/ZONE::/ unless ${$args{val}} =~ /^ZONE/; + } else { + # $deity-only-knows what kind of gibberish we've been given. Only usable as a formal .arpa name. + # Append ARPAZONE to be replaced with the formal .arpa zone name when converted to a live record. + ${$args{val}} .= ".ARPAZONE" unless ${$args{val}} =~ /ARPAZONE$/; + } + } else { + return ('FAIL', "PTR records are not supported in default record sets for forward zones (domains)"); + } + } else { + if ($args{revrec} eq 'y') { + # Get the revzone, so we can see if ${$args{val}} is in that zone + my $revzone = new NetAddr::IP $self->revName($args{id}, 'y'); + + return ('FAIL', $errstr) if !$self->_inrev($args{val}, $revzone); + + if (${$args{val}} =~ /\.arpa$/) { + # Check that it's well-formed + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + + # Check if it's a proper formal .arpa name for an IP, and renormalize it to the IP + # value if so. I can't see why someone would voluntarily work with those instead of + # the natural IP values but what the hey. + my ($code,$tmp) = _zone2cidr(${$args{val}}); + ${$args{val}} = $tmp->addr if $code ne 'FAIL'; + } else { + # not a formal .arpa name, so it should be an IP value. Validate... + return ('FAIL', "${$args{val}} is not a valid IP value") + unless ${$args{val}} =~ /^(?:\d+\.\d+\.\d+\.\d+|[a-fA-F0-9:]+)$/; + $args{addr} = NetAddr::IP->new(${$args{val}}) + or return ('FAIL', "IP/value looks like an IP address but isn't valid"); + # ... and normalize. + ${$args{val}} = $args{addr}->addr; + } + # Validate PTR target for form. + # %blank% skips the IP when expanding a template record + return ('FAIL', $errstr) + unless _check_hostname_form(${$args{host}}, ${$args{rectype}}, $args{defrec}, $args{revrec}) || + lc(${$args{host}}) eq '%blank%'; + } else { # revrec ne 'y' + # Fetch the domain and append if the passed hostname isn't within it. + my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : $self->domainName($args{id})); + ${$args{host}} =~ s/\.*$/\.$pname/ if (${$args{host}} ne '@' && ${$args{host}} !~ /$pname$/i); + # Validate hostname and target for form + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{host}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + } + } + +# 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. + + my $chkbase = ${$args{val}};; + my $hostcol = 'val'; # Reverse zone hostnames are stored "backwards" + if ($args{revrec} eq 'n') { # PTRs in forward zones should be rare. + $chkbase = ${$args{host}}; + $hostcol = 'host'; + } + my @checkvals = ($chkbase); + if ($chkbase =~ /,/) { + # push . and :: variants into checkvals if $chkbase has , + my $tmp; + ($tmp = $chkbase) =~ s/,/./; + push @checkvals, $tmp; + ($tmp = $chkbase) =~ s/,/::/; + push @checkvals, $tmp; + } + + my $pcsth = $dbh->prepare("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec})." WHERE $hostcol = ?"); + foreach my $checkme (@checkvals) { + if ($args{update}) { + # $args{update} contains the ID of the record being updated. If the list of records that matches + # the new hostname specification doesn't include this, the change effectively adds a new PTR that's + # the same as one or more existing ones. + my @ptrs = @{ $dbh->selectcol_arrayref("SELECT record_id FROM "._rectable($args{defrec},$args{revrec}). + " WHERE val = ?", undef, ($checkme)) }; + $warnflag .= "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 + # Don't warn when a matching A record exists tho + my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}). + " WHERE $hostcol = ? AND (type=12 OR type=65280 OR type=65281)", undef, ($checkme)); + $warnflag .= "PTR record for $checkme already exists; adding another will probably not do what you want" + if $ptrcount; + } + } + + return ('WARN',$warnflag) if $warnflag; + + return ('OK','OK'); +} # done PTR record + +# MX record +sub _validate_15 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + +# only for strict type restrictions +# 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}}; + + if ($args{revrec} eq 'n') { + # MX target check - IP addresses not allowed. Must be a more or less well-formed hostname. + return ('FAIL', "MX records cannot point directly to an IP address") + if ${$args{val}} =~ /^(?:[\d.]+|[0-9a-fA-F:]+)$/; + + # 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$/i); + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{host}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + } else { + # MX target check - IP addresses not allowed. Must be a more or less well-formed hostname. + return ('FAIL', "MX records cannot point directly to an IP address") + if ${$args{host}} =~ /^(?:[\d.]+|[0-9a-fA-F:]+)$/; + + # MX records in reverse zones get stricter treatment. The UI bars adding them in + # reverse record sets, but we "need" to allow editing existing ones. And we'll allow + # editing them if some loon manually munges one into a default reverse record set. + if ($args{defrec} eq 'n') { + # Get the revzone, so we can see if ${$args{val}} is in that zone + my $revzone = new NetAddr::IP $self->revName($args{id}, 'y'); + return ('FAIL', $errstr) if !$self->_inrev($args{val}, $revzone); + } + +##enhance or ##fixme +# convert well-formed .arpa names to IP addresses to match old "strict" validation design + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec}) && + ${$args{val}} =~ /\.arpa$/; + +##enhance: Look up the passed value to see if it exists. Ooo, fancy. + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{host}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + + } + + return ('OK','OK'); +} # done MX record + +# TXT record +sub _validate_16 { + my $self = shift; + + my %args = @_; + + if ($args{revrec} eq 'n') { + # 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$/i); + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{host}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + } else { + # We don't coerce reverse "hostnames" into the zone, mainly because we store most sane + # records as IP values, not .arpa names. + if ($args{defrec} eq 'n') { + # Get the revzone, so we can see if ${$args{val}} is in that zone + my $revzone = new NetAddr::IP $self->revName($args{id}, 'y'); + return ('FAIL', $errstr) if !$self->_inrev($args{val}, $revzone); + } + +##enhance or ##fixme +# convert well-formed .arpa names to IP addresses to match old "strict" validation design + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec}) && + ${$args{val}} =~ /\.arpa$/; + } + + # 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 separately some day. Call _validate_16() above since + # they're otherwise very similar + return _validate_16(@_); +} # done RP record + +# AAAA record +# Almost but not quite an exact duplicate of A record +sub _validate_28 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + +# only for strict type restrictions +# return ('FAIL', 'Reverse zones cannot contain AAAA records') if $args{revrec} eq 'y'; + + if ($args{revrec} eq 'y') { + # Get the revzone, so we can see if ${$args{val}} is in that zone + my $revzone = new NetAddr::IP $self->revName($args{id}, 'y'); + + return ('FAIL', $errstr) if !$self->_inrev($args{val}, $revzone); + + # ${$args{val}} is either a valid IP or a string ending with the .arpa zone name; + # now check if it's a well-formed FQDN + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec}) && + ${$args{val}} =~ /\.arpa$/; + + # 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',"AAAA record must be a valid IPv6 address") + unless ${$args{host}} =~ /^[a-fA-F0-9:]+$/; + $args{addr} = new NetAddr::IP ${$args{host}}; + return ('FAIL',"AAAA record must be a valid IPv6 address") + unless $args{addr} && $args{addr}->{isv6}; + # coerce IP/value to normalized form for storage + ${$args{host}} = $args{addr}->addr; + + # I'm just going to ignore the utterly barmy idea of an AAAA record in the *default* + # records for a reverse zone; it's bad enough to find one in funky legacy data. + + } else { + # revrec ne '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$/i); + + # Check if it's a proper formal .arpa name for an IP, and renormalize it to the IP + # value if so. Done mainly for symmetry with PTR/AAAA+PTR, and saves a conversion on export. + if (${$args{val}} =~ /\.arpa$/) { + my ($code,$tmp) = _zone2cidr(${$args{val}}); + if ($code ne 'FAIL') { + ${$args{val}} = $tmp->addr; + $args{addr} = $tmp; + } + } + # Check IP is well-formed, and that it's a v6 address + return ('FAIL',"AAAA record must be a valid IPv6 address") + unless ${$args{val}} =~ /^[a-fA-F0-9:]+$/; + $args{addr} = new NetAddr::IP ${$args{val}}; + return ('FAIL',"AAAA 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'; + + # Key additional record parts. Always required. + return ('FAIL',"Distance, port and weight are required for SRV records") + unless defined(${$args{weight}}) && defined(${$args{port}}) && defined(${$args{dist}}); + ${$args{dist}} =~ s/\s*//g; + ${$args{weight}} =~ s/\s*//g; + ${$args{port}} =~ s/\s*//g; + my @ferr; + push @ferr, "distance" unless ${$args{dist}} =~ /^\d+$/; + push @ferr, "weight" unless ${$args{weight}} =~ /^\d+$/; + push @ferr, "port" unless ${$args{port}} =~ /^\d+$/; + return ('FAIL',"Distance, port and weight are required, and must be numeric (check ".join(", ", @ferr).")") + unless ${$args{dist}} =~ /^\d+$/ && ${$args{weight}} =~ /^\d+$/ && ${$args{port}} =~ /^\d+$/; + + ${$args{fields}} = "distance,weight,port,"; + push @{$args{vallist}}, (${$args{dist}}, ${$args{weight}}, ${$args{port}}); + + if ($args{revrec} eq 'n') { + # 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$/i; + +##enhance: Rejig so that we can pass back a WARN red flag, instead of +# hard-failing, since it seems that purely from the DNS record perspective, +# SRV records without underscores are syntactically valid + # Not strictly true, but SRV records not following this convention won't be found. + return ('FAIL',"SRV records must begin with _service._protocol [${$args{host}}]") + unless ${$args{host}} =~ /^_[A-Za-z\d-]+\._[A-Za-z]+\.[a-zA-Z0-9-]+/; + + # SRV target check - IP addresses not allowed. Must be a more or less well-formed hostname. + # Allow a bare . to indicate "this service does not exist" + return ('FAIL', "SRV records cannot point directly to an IP address") + if ${$args{val}} ne '.' && ${$args{val}} =~ /^(?:[\d.]+|[0-9a-fA-F:]+)$/; + } else { + # hm. we can't do anything sane with IP values here; part of the record data is in + # fact encoded in the "hostname". enforce .arpa names? OTOH, SRV records in a reverse + # zone are pretty silly. + +##enhance: Rejig so that we can pass back a WARN red flag, instead of +# hard-failing, since it seems that purely from the DNS record perspective, +# SRV records without underscores are syntactically valid + # Not strictly true, but SRV records not following this convention won't be found. + return ('FAIL',"SRV records must begin with _service._protocol [${$args{host}}]") + unless ${$args{val}} =~ /^_[A-Za-z\d-]+\._[A-Za-z]+\.[a-zA-Z0-9-]+/; + + # SRV target check - IP addresses not allowed. Must be a more or less well-formed hostname. + # Allow a bare . to indicate "this service does not exist" + return ('FAIL', "SRV records cannot point directly to an IP address") + if ${$args{host}} ne '.' && ${$args{host}} =~ /^(?:[\d.]+|[0-9a-fA-F:]+)$/; + + # SRV records in reverse zones get stricter treatment. The UI bars adding them in + # reverse record sets, but we "need" to allow editing existing ones. And we'll allow + # editing them if some loon manually munges one into a default reverse record set. + if ($args{defrec} eq 'n') { + # Get the revzone, so we can see if ${$args{val}} is in that zone + my $revzone = new NetAddr::IP $self->revName($args{id}, 'y'); + return ('FAIL', $errstr) if !$self->_inrev($args{val}, $revzone); + } + +##enhance or ##fixme +# convert well-formed .arpa names to IP addresses to match old "strict" validation design + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec}) && + ${$args{val}} =~ /\.arpa$/; + +##enhance: Look up the passed value to see if it exists. Ooo, fancy. + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{host}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + + } + + return ('OK','OK'); +} # done SRV record + +# CAA record +sub _validate_257 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + my $code = 'OK'; + my $msg = ''; # Default to no message, because there are a lot of handwavy warning cases. + + if ($args{revrec} eq 'n') { + # 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$/i; + + my ($caaflag, $caatag, $caadetail) = (${$args{val}} =~ /(\d+)\s+(\w+)\s+(.+)/); + + return ('FAIL', "Poorly formed CAA record missing one or more of flag, tag, or detail") + if (!defined($caaflag) || !defined($caatag) || !defined($caadetail)); + + # flag is a bitfield, only bit 0 currently has meaning as "Issuer Critical" + # Not 100% clear if this flag is permitted on known tags, or if it's + # semantically null since the known tags are already defined. We'll allow it. + return ('FAIL', "CAA flags other than 0 or 128 not currently supported in DNS") if $caaflag ne '0' && $caaflag ne '128'; + + # known tags: + # issue + # issuewild + # iodef (RFC5070) + # auth (reserved, do not use) + # path (reserved, do not use) + # policy (reserved, do not use) + return ('FAIL', "CAA tags may only use a-z, A-Z, and 0-9") if $caatag !~ /^[a-zA-Z0-9]+$/; + return ('FAIL', "Can't use reserved CAA tag '$caatag'") if $caatag =~ /^(?:auth|path|policy)$/; + if ($caatag !~ /^(?:issue|issuewild|iodef)$/) { + $code = 'WARN'; + $msg = ($msg ? $msg." " : '')."Unknown CAA tag '$caatag' will be published as-is."; + } + if (length($caatag) > 15) { + $code = 'WARN'; + $msg = ($msg ? $msg." " : '').'Custom CAA tag > 15 characters may not behave as intended.'; + } + + if ($caatag eq 'issue' || $caatag eq 'issuewild') { + # Detail format is possibly as complex as: + # [;|cert-authority [; key=value[ key=value ...]] + # but arguably a strict reading says there can only be one key, and the + # rest of the string after first = is the value, even if it appears to + # contain extra key=value pairs. + # See https://datatracker.ietf.org/doc/html/rfc6844 for full ABNF definition. + # Either way all we need to validate is that it's within the specified characters. + if ($caadetail eq ';') { + # No certs permitted + } else { + my ($certauth,$remainder) = ($caadetail =~ /^\s*([a-zA-Z0-9.-]+)\s*((?:;|\s|$).*)?$/); + if (!$certauth) { + # We can't reasonably validate individual domains, just that it's well-formed + return ('FAIL', "CAA authority domain must be a valid domain name"); + } + if ($remainder) { + return ('FAIL', "CAA authority domain and optional key=value entry or entries must be separated by a ';'") + if $remainder !~ /^\s*;/; + $remainder =~ s/\s*;\s*//; + # Just validate the characters in the remainder. Any details are CA-specific and not sanely validateable. + return ('FAIL', "Invalid characters in optional key=value entry or entries") + if $remainder !~ /^[a-zA-Z0-9]+\s*=[\x21-\x7e\s]+$/; + } + } + } # issue/isseuewild + + elsif ($caatag eq 'iodef') { + # Two valid forms: + # mailto:address@example.com + # http://iodef.example.com/ + # RFC seems a little handwavy whether https:// is valid or not, but the chained + # RFC for the HTTP-based reporting protocol says that this should be assumed to + # be a dedicated port (4590) and service, requiring TLS. Allowing https:// per + # the detail description in https://datatracker.ietf.org/doc/html/rfc6844#section-5.4. + return ('FAIL', "iodef tag data must reference a mailto: or http: URI") if $caadetail !~ /^(mailto|https?):/; + if ($1 eq 'mailto') { + # not going full RFC on validating form, just "reasonably sane" + return ('FAIL', "Poorly formed email for iodef tag") if $caadetail !~ /^mailto:[^\s]+\@[a-zA-z0-9._-]+$/ + } else { + return ('FAIL', "Poorly formed URI for iodef tag") if $caadetail !~ m,^https?://[a-zA-z0-9._-]+/?$, + } + } # iodef + + } else { + # CAA records don't make much sense in reverse zones + return ('FAIL', "CAA records not supported in reverse zones"); + } + + # Allow CAA records in default record sets for now, but it's a bit iffy + # whether this makes any sense. Not nice to publish a default "issue ;" + # record, then go through a support mess trying to figure out why a + # customer can't register a cert somewhere. +# if ($args{defrec} eq 'n') { +# } else { +# } + + return ($code, $msg); +} # done CAA 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. + + # Fail early on non-IP gibberish in ${$args{val}}. Arguably .arpa names might be acceptable + # but that gets stupid in forward zones, since these records are shared. + return ('FAIL', "$typemap{${$args{rectype}}} record must be a valid IPv4 address") + if ${$args{rectype}} == 65280 && ${$args{val}} !~ m{^\d+\.\d+\.\d+\.\d+(?:/\d+)?$}; + return ('FAIL', "$typemap{${$args{rectype}}} record must be a valid IPv6 address") + if ${$args{rectype}} == 65281 && ${$args{val}} !~ m{^[a-fA-F0-9:]+(?:/\d+)?$}; + # If things are not OK, this should prevent Stupid in the error log. + $args{addr} = new NetAddr::IP ${$args{val}} + or return ('FAIL', "$typemap{${$args{rectype}}} record must be a valid IPv". + (${$args{rectype}} == 65280 ? '4' : '6')." address"); + ${$args{val}} = $args{addr}->addr; + + 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; + } + + # Add the reverse zone ID to the fieldlist + ${$args{fields}} .= "rdns_id,"; + push @{$args{vallist}}, $revid; + + # Coerce the hostname back to the domain; this is so it displays and manipulates + # sanely in the reverse zone. + if (${$args{host}} eq '@') { + ${$args{host}} = $self->domainName($args{id}); # errors? What errors? + } + } # revrec ne 'y' + + } 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') { + + # Coerce all hostnames to end in ".DOMAIN" for group/default records, + # or the intended parent domain for live records. + my $pname = $self->domainName($args{id}); + ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/i; + + # check for form; note this checks both normal and "other" hostnames. + return ('FAIL', $errstr) + if !_check_hostname_form(${$args{host}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + + # 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 A+PTR template record + +# AAAA+PTR template record +# Not sure this can be handled sanely due to the size of IPv6 address space +# _validate_65283 above should handle v6 template records fine. It's on export we've got trouble. +sub _validate_65284 { + my $self = shift; + my %args = @_; + + # do a quick check on the form of the hostname part; this is effectively a + # "*.0.0.f.ip6.arpa" hostname, not an actual expandable IP template pattern + # like with 65283. + return ('FAIL', $errstr) + if !_check_hostname_form(${$args{host}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + return $self->_validate_65283(%args); +} # 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$/i; + } + } else { + return ('FAIL',"Delegation records are not permitted in default record sets"); + } + return ('OK','OK'); +} # done delegation record + +# ALIAS record +# A specialized variant of the CNAME, which retrieves the A record list on each +# export and publishes the A records instead. Primarily for "root CNAME" or "apex +# alias" records. See https://secure.deepnet.cx/trac/dnsadmin/ticket/55. +# Not allowed in reverse zones because this is already a hack, and reverse zones +# don't get pointed to CNAMEed CDNs the way domains do. +sub _validate_65300 { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + return ('FAIL',"ALIAS records are not permitted in reverse zones") if $args{revrec} eq 'y'; + + # Make sure target is a well-formed hostname + return ('FAIL', $errstr) if ! _check_hostname_form(${$args{val}}, ${$args{rectype}}, $args{defrec}, $args{revrec}); + + # 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$/i); + + # Only do the cache thing on live/active records + return ('OK','OK') unless $args{defrec} eq 'n'; + + # now we check/update the cached target address info + my ($iplist) = $self->{dbh}->selectrow_array("SELECT auxdata FROM records WHERE record_id = ?", undef, $args{recid}); + my $warnmsg; + $iplist = '' if !$iplist; + + # shared target-name-to-IP converter + my $liveips = $self->_grab_65300($args{recid}, ${$args{val}}); + $liveips = '' if !$liveips; + + # check to see if there was an OOOOPS checking for updated A records on the target. also make sure we have something cached. + if (!$liveips) { + if (!$iplist) { + # not fatal since we do the lookup on export as well + $warnmsg = "No cached data and no live DNS data for ALIAS target ${$args{val}}; record may be SKIPPED on export!"; + } + } + + # munge the insert/update fieldlist and data array + # note we always force this; if the target has changed the cached data is almost certainly invalid anyway + if ($liveips && ($iplist ne $liveips)) { + ${$args{fields}} .= "auxdata,"; + push @{$args{vallist}}, $liveips; + } + + return ('WARN', join("\n", $errstr, $warnmsg) ) if $warnmsg; + + return ('OK','OK'); +} # done ALIAS record + +# this segment used multiple places to update ALIAS target details +sub _grab_65300 { + my $self = shift; + my $dbh = $self->{dbh}; + + my $recid = shift; + my $target = shift; + + my $res = Net::DNS::Resolver->new; + $res->tcp_timeout(2); + $res->udp_timeout(2); + # send() returns a Net::DNS::Packet which may or may not be entirely empty, we'll see in the loop below + my $arecs = $res->send($target, 'A'); + my $aaaarecs = $res->send($target,'AAAA'); + + my $liveips = ''; + # default to a one-hour TTL, which should be variously modified down the chain. Arguably this could + # default even lower, since "The Cloud" often uses sub-1-minute TTLs on the final A records. + my $minttl = 3600; + my @newlist; + foreach my $rr ($arecs->answer, $aaaarecs->answer) { + next unless $rr->type eq "A" || $rr->type eq "AAAA"; + push @newlist, $rr->address; + $minttl = $rr->ttl if $rr->ttl < $minttl; + } + if (@newlist) { + # safety limit. could arguably take this lower, or for extra + # complexity, reference off the zone SOA minTTL + $minttl = 60 if $minttl < 60; + # we don't need this to be perfectly correct IP address order, just consistent. + $liveips = "$minttl;".join(';', sort(@newlist)) if @newlist; +#fixme: should it be a formal error case if there are no A/AAAA records returned? + } else { + $errstr = "Lookup failure retrieving ALIAS IP list: ".$res->errorstring; + } + + return $liveips; +} # _grab_65300() + + +# Subs not specific to a particular record type + +# Convert $$host and/or $$val to lowercase as appropriate. +# Should only be called if $self->{lowercase} is true. +# $rectype is also a reference for caller convenience +sub _caseclean { + my ($rectype, $host, $val, $defrec, $revrec) = @_; + + # Can't case-squash default records, due to DOMAIN, ZONE, and ADMINDOMAIN templating + return if $defrec eq 'y'; + + if ($typemap{$$rectype} eq 'TXT' || $typemap{$$rectype} eq 'SPF') { + # TXT records should preserve user entry in the string. + # SPF records are a duplicate of TXT with a new record type value (99) + $$host = lc($$host) if $revrec eq 'n'; # only lowercase $$host on live forward TXT; preserve TXT content + $$val = lc($$val) if $revrec eq 'y'; # only lowercase $$val on live reverse TXT; preserve TXT content + } else { + # Non-TXT, live records, are fully case-insensitive + $$host = lc($$host); + $$val = lc($$val); + } # $typemap{$$rectype} else + +} # _caseclean() + + +## +## 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; + return ('FAIL', "Non-numerics in apparent IPv4 reverse zone name [$tmpzone]") + if $tmpzone !~ m{^(?:\d+[/-])?[\d\.]+\.in-addr\.arpa\.?$}; + $tmpzone =~ s/\.in-addr\.arpa\.?//; + + # 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] =~ m{^((\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; +##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 [$tmpzone]") + if $tmpzone !~ /^[a-fA-F\d\.]+\.ip6\.arpa\.?$/; + $tmpzone =~ s/\.ip6\.arpa\.?//; + 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 && $nc < $#quads; + } + 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"; + } + # polish it off with trailing ::/mask if this is a CIDR block instead of an IP + $tmpcidr .= "::/$mask" if $mask != 128; + } + + # 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); +##fixme: use wantarray() to decide what to return? +} # 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, an IP to use in the replacement, +# an optional netblock for the %ngb (net, gw, bcast) expansion, and an optional index +# number for %c "n'th usable IP in block/range" patterns. +# Alters the template string referred. +sub _template4_expand { + # ugh pthui + my $self; + $self = shift if ref($_[0]) eq 'DNSDB'; + + my $tmpl = shift; + my $ip = shift; + my $subnet = shift; # for %ngb, %c, and %x + my $ipindex = shift; # for %c + + # blank $tmpl on config template_skip_0 or template_skip_255, unless we have a %ngb + if ($$tmpl !~ /\%-?n-?g-?b\%/) { + if ( ($ip =~ /\.0$/ && $self->{template_skip_0}) || + ($ip =~ /\.255$/ && $self->{template_skip_255}) ) { + $$tmpl = ''; + return; + } + } + + my @ipparts = split /\./, $ip; + my @iphex; + my @ippad; + for (@ipparts) { + push @iphex, sprintf("%x", $_); + push @ippad, sprintf("%0.3u", $_); + } + + # Two or three consecutive separator characters (_ or -) should be rare - users that use them + # anywhere other than punycoded internationalized domains get to keep the pieces when it breaks. + # We clean up the ones that we may inadvertently generate after replacing %c and %ngb% + my ($thrsep) = ($$tmpl =~ /[_-]{3}/); + my ($twosep) = ($$tmpl =~ /[_-]{2}/); + + # Take the simplest path to pattern substitution; replace only exactly the %c or %ngb% + # patterns as-is. Then check after to see if we've caused doubled separator characters (- or _) + # and eliminate them, but only if the original template didn't have them already. Also + # unconditionally drop separator characters immediately before a dot; these do not always + # strictly make the label invalid but almost always, and any exceptions should never show up + # in a template record that expands to "many" real records anyway. + + # %ngb and %c require a netblock + if ($subnet) { + # extract the fragments + my ($ngb,$n,$g,$b) = ($$tmpl =~ /(\%(-?n)(-?g)(-?b)\%)/); + my ($c) = ($$tmpl =~ /(\%-?c)/); my $nld = ''; my $cld = ''; + $c = '' if !$c; + my ($cn) = ($$tmpl =~ /(\%x)/); + my $skipgw = ($c =~ /\%-c/ ? 0 : 1); + my $ipkill = 0; + + if ($cn) { + # "n'th natural IP in the block" pattern. + my $iptmp = new NetAddr::IP $ip; + my $natdex = scalar($iptmp - $$subnet); + $natdex++; + $$tmpl =~ s/$cn/$natdex/; + } + +##fixme: still have one edge case not handled well: +# %c%n-gb% +# do we drop the record as per -g, or publish the record with an index of 1 as per %c? +# arguably this is a "that's a STUPID question!" case + + if ($c) { + # "n'th usable IP in the block" pattern. We need the caller to provide an index + # number otherwise we see exponential time growth because we have to iterate over + # the whole block to map the IP back to an index. :/ + # NetAddr::IP does not have a method for asking "what index is IP at?" + + # no index, or index == 0, (AKA network address), or IP == broadcast, blank the index fragment + if (!$ipindex || ($$subnet->broadcast->addr eq $ip)) { + $$tmpl =~ s/$c//; + } else { + # if we have %c, AKA "skip the gateway", and we're on the nominal gateway IP, blank the index fragment + if ($skipgw && $$subnet->first->addr eq $ip) { + $$tmpl =~ s/$c//; + } + # else replace the index fragment with the passed index minus $skipgw, so that we can start the + # resulting index at 1 on net+2 + else { + $$tmpl =~ s/$c/($ipindex-$skipgw)/e; + } + } + } # if ($c) + + if ($ngb) { + # individually check the network, standard gateway (net+1) IP, and broadcast IP + # blank $$tmpl if n, g, or b was prefixed with - (this allows "hiding" net/gw/bcast entries) + + if ($$subnet->network->addr eq $ip) { + if ($n eq '-n') { + $$tmpl = ''; + } else { + $$tmpl =~ s/$ngb/net/; + $ipkill = 1; + } + } elsif ($$subnet->first->addr eq $ip) { + if ($g eq '-g') { + $$tmpl = ''; + } else { + $$tmpl =~ s/$ngb/gw/; + $ipkill = 1; + } + } elsif ($$subnet->broadcast->addr eq $ip) { + if ($b eq '-b') { + $$tmpl = ''; + } else { + $$tmpl =~ s/$ngb/bcast/; + $ipkill = 1; + } + } else { + $$tmpl =~ s/$ngb//; + } + } + + # We don't (usually) want to expand the IP-related patterns on the -net, -gw, or -bcast IPs. + # Arguably this is another place for another config knob, or possibly further extension of + # the template pattern to control it on a per-subnet basis. + if ($ipkill) { + # kill common IP patterns + $$tmpl =~ s/\%[_.-]?[irdh]//; + # kill IP octet patterns + $$tmpl =~ s/\%[1234][dh0](?:[_.-]\%[1234][dh0]){0,3}//; + } + + # and now clean up to make sure we leave a valid DNS label... mostly. Should arguably + # split on /\./ and process each label separately. + $$tmpl =~ s/([_-]){3}/$1/ if !$thrsep; + $$tmpl =~ s/([_-]){2}/$1/ if !$twosep; + $$tmpl =~ s/[_-]\././; + + } # if ($subnet) + + # 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. + DNSDB::_template4_expand(\$tmphost, '10.10.10.10'); + if ($tmphost =~ /\%/ || lc($tmphost) !~ /^(?:\*\.)?(?:[0-9a-z_.-]+)$/) { + $errstr = "Invalid template $hname"; + return; + } + } elsif ($rectype == $reverse_typemap{CNAME} && $revrec eq 'y') { + # Allow / in reverse CNAME hostnames for sub-/24 delegation + if (lc($hname) !~ m|^[0-9a-z_./-]+$|) { + # error message is deliberately restrictive; special cases are SPECIAL and not for general use + $errstr = "Hostnames may not contain anything other than (0-9 a-z . _)"; + return; + } + } elsif ($revrec eq 'y') { + # Reverse zones don't support @ in hostnames + if (lc($hname) !~ /^(?:\*\.)?[0-9a-z_.-]+$/) { + # error message is deliberately restrictive; special cases are SPECIAL and not for general use + $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() + +# Reverse a lurking tinydns-centric octal substitution +sub _deoctal { + my $targ = shift; + while ($$targ =~ /\\(\d{3})/) { + my $sub = chr(oct($1)); + $$targ =~ s/\\$1/$sub/g; + } +} # _deoctal() + + +## +## 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->{usecache} = $1 if m{^usecache\s*=\s*([a-z01]+)}i; + $cfg->{bind_export_conf_path} = $1 if m{^bind_export_conf_path\s*=\s*([a-z0-9/_.%-]+)}i; + $cfg->{bind_export_zone_path} = $1 if m{^bind_export_zone_path\s*=\s*([a-z0-9/_.%-]+)}i; + $cfg->{bind_export_reverse_zone_path} = $1 if m{^bind_export_reverse_zone_path\s*=\s*([a-z0-9/_.%-]+)}i; + $cfg->{bind_export_fqdn} = $1 if /^bind_export_fqdn\s*=\s*([a-z01]+)/i; + $cfg->{bind_export_autoexpire_ttl} = $1 if /^bind_export_autoexpire_ttl\s*=\s*(\d+)/; + $cfg->{force_refresh} = $1 if /^force_refresh\s*=\s*([a-z01]+)/i; + $cfg->{lowercase} = $1 if /^lowercase\s*=\s*([a-z01]+)/i; + $cfg->{showrev_arpa} = $1 if /^showrev_arpa\s*=\s*([a-z]+)/i; + $cfg->{template_skip_0} = $1 if /^template_skip_0\s*=\s*([a-z01]+)/i; + $cfg->{template_skip_255} = $1 if /^template_skip_255\s*=\s*([a-z01]+)/i; + $cfg->{autotxt} = $1 if /^autotxt\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; + 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 $self = shift; + 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 a default location indicator +# 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(?) AND default_location = ?"); + my $dom_id; + +# quick check to start to see if we've already got one + $sth->execute($domain, $defloc); + ($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,zserial) VALUES (?,?,?,?,?)", undef, + ($domain, $group, $state, $defloc, scalar(time()) ) ); + + # get the ID... + ($dom_id) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE lower(domain) = lower(?) AND default_location = ?", + undef, ($domain, $defloc)); + + my $logparent = $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; + _caseclean(\$type, \$host, \$val, 'n', 'n') if $self->{lowercase}; + $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, logparent => $logparent, + 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, logparent => $logparent, + 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::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 = shift; + + # Autodetect formal .arpa zones + if ($zone =~ /\.arpa\.?$/) { + my $code; + ($code,$zone) = _zone2cidr($zone); + return ('FAIL', $zone) if $code eq 'FAIL'; + } + $zone = NetAddr::IP->new($zone); + + 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 = ? AND default_location = ?", + undef, ("$zone", $defloc)); + + 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,zserial) VALUES (?,?,?,?,?)", undef, + ($zone, $group, $state, $defloc, scalar(time()) ) ); + + # 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. + } + } + + _caseclean(\$type, \$host, \$val, 'n', 'y') if $self->{lowercase}; + + $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::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; + + return ('FAIL', 'Need a zone identifier to look up') if !$zoneid; + + my $msg = ''; + my $failmsg = ''; + my $zone = ($revrec eq 'n' ? $self->domainName($zoneid) : $self->revName($zoneid)); + my $zonestatus = $self->zoneStatus($zoneid, $revrec); + + 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 ".($zonestatus ? '' : 'inactive ').($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, and an optional flag to force return of the CIDR zone +# instead of the formal .arpa zone name +# Returns the reverse zone name or undef on failure +sub revName { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $revid = shift; + my $cidrflag = shift || 'n'; + my ($revname) = $dbh->selectrow_array("SELECT revnet FROM revzones WHERE rdns_id=?", undef, ($revid) ); + $errstr = $DBI::errstr if !$revname; + my $tmp = new NetAddr::IP $revname; + $revname = _ZONE($tmp, 'ZONE', 'r', '.').($tmp->{isv6} ? '.ip6.arpa' : '.in-addr.arpa') + if ($self->{showrev_arpa} eq 'zone' || $self->{showrev_arpa} eq 'all') && $cidrflag eq 'n'; + return $revname if $revname; +} # end revName() + + +## DNSDB::domainID() +# Takes a domain name and default location +# Returns the domain ID number +sub domainID { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $domain = shift; + my $location = shift; + + # Note that location may be *empty*, but it may not be *undefined* + if (!defined($location)) { + $errstr = "Missing location"; + return; + } + + my $sql = "SELECT domain_id FROM domains WHERE lower(domain) = lower(?)"; + my @zargs = ($domain); + # yay magic strings! + if ($location eq ':ANY:') { + # no-op + } else { + $sql .= " AND default_location = ?"; + push @zargs, $location; + } + + my ($domid) = $dbh->selectrow_array($sql, undef, @zargs); + + if (!$domid) { + if ($dbh->err) { + $errstr = $DBI::errstr; + } else { + $errstr = "Domain $domain not present"; + } + } + return $domid if $domid; +} # end domainID() + + +## DNSDB::revID() +# Takes a reverse zone name and default location +# Assumes the reverse zone is in the logical CIDR form, not the formal .arpa form +# Returns the rDNS ID number +sub revID { + $errstr = ''; + my $self = shift; + my $dbh = $self->{dbh}; + my $revzone = shift; + my $location = shift; + + # Note that location may be *empty*, but it may not be *undefined* + if (!defined($location)) { + $errstr = "Missing location"; + return; + } + + my $sql = "SELECT rdns_id FROM revzones WHERE revnet = ?"; + my @zargs = ($revzone); + # yay magic strings! + if ($location eq ':ANY:') { + # no-op + } else { + $sql .= " AND default_location = ?"; + push @zargs, $location; + } + + my ($revid) = $dbh->selectrow_array($sql, undef, @zargs); + + if (!$revid) { + if ($dbh->err) { + $errstr = $DBI::errstr; + } else { + $errstr = "Reverse zone $revzone not present"; + } + } + return $revid if $revid; +} # end revID() + + +## 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) ~* ?" : ''); +# if ($self->{showrev_arpa} eq 'zone' || $self->{showrev_arpa} eq 'all') { + # Just In Case the UI is using formal .arpa notation, and someone enters something reversed, + # we want to match both the formal and natural zone name + $sql .= ($args{filter} ? " AND (CAST(revnet AS VARCHAR) ~* ? OR CAST(revnet AS VARCHAR) ~* ?)" : ''); + push @filterargs, join('[.]',reverse(split(/\[\.\]/,$args{filter}))) if $args{filter}; +# } else { +# $sql .= ($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 = q(SELECT + domain_id AS zoneid, + domain AS zone, + status, + groups.group_name AS group, + l.description AS location + FROM domains + LEFT JOIN locations l ON domains.default_location=l.location + 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 = q(SELECT + rdns_id AS zoneid, + revnet AS zone, + status, + groups.group_name AS group, + l.description AS location + FROM revzones + LEFT JOIN locations l ON revzones.default_location=l.location + 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) ~* ?" : ''); +# if ($self->{showrev_arpa} eq 'zone' || $self->{showrev_arpa} eq 'all') { + # Just In Case the UI is using formal .arpa notation, and someone enters something reversed, + # we want to match both the formal and natural zone name + $sql .= ($args{filter} ? " AND (CAST(revnet AS VARCHAR) ~* ? OR CAST(revnet AS VARCHAR) ~* ?)" : ''); + push @filterargs, join('[.]',reverse(split(/\[\.\]/,$args{filter}))) if $args{filter}; +# } else { +# $sql .= ($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 @working; + my $zsth = $dbh->prepare($sql); + $zsth->execute(@filterargs); + while (my $zone = $zsth->fetchrow_hashref) { + if ($args{revrec} eq 'y' && ($self->{showrev_arpa} eq 'zone' || $self->{showrev_arpa} eq 'all')) { + my $tmp = new NetAddr::IP $zone->{zone}; + $zone->{zone} = DNSDB::_ZONE($tmp, 'ZONE', 'r', '.').($tmp->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'); + } + push @working, $zone; + } + return \@working; +} # 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 +##fixme: need better handling of case of inherited or missing (!!) permissions entries + 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 ~* ?" : ''). + " AND NOT type = 'R' "; + 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=? AND password <> 'RPC'"); + $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; + + no warnings qw (uninitialized); + $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 %args = @_; + + my $grp = $args{group}; + my $shdesc = $args{desc}; + my $comments = $args{comments}; + my $iplist = $args{iplist}; + + # $shdesc gets set to the generated location ID if possible, but these can be de-undefined here. + $comments = '' if !$comments; + $iplist = '' if !$iplist; + + # allow requesting a specific location entry. + my $loc = $args{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. + + # just to be as clear as possible; as per http://cr.yp.to/djbdns/tinydns-data.html: + +#For versions 1.04 and above: You may include a client location on each line. The line is ignored for clients +#outside that location. Client locations are specified by % lines: +# +# %lo:ipprefix +# +#means that IP addresses starting with ipprefix are in location lo. lo is a sequence of one or two ASCII letters. + + # this has been confirmed by experiment; locations "lo", "Lo", and "lO" are all distinct. + +# 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 + my ($newloc) = $dbh->selectrow_array("SELECT location FROM locations ORDER BY loc_id DESC LIMIT 1"); + + no warnings qw(uninitialized); + + my $ecnt = $dbh->prepare("SELECT count(*) FROM locations WHERE location LIKE ?"); + + if ($loc) { + $ecnt->execute($loc); + if (($ecnt->fetchrow_array())[0]) { + # too bad, so sad, requested location is unavailable. +##fixme: known failure case: caller requests a location ID that is not two characters. + die "Requested location is already defined\n" if $args{reqonly}; + # fall back to autoincrement + } + $newloc = $loc; + } + + # Either the requested location ID is unavailable and the caller isn't too attached + # to it, OR, the caller hasn't specified a location ID. (The second case should be + # far more common.) Find the "next available" location identifier. + + ($newloc) = ($newloc =~ /^(..)/) if $newloc; + my $origloc = $newloc; + $newloc = 'aa' if !$newloc; + # Make a change... + # ... and keep changing if it exists + while ($dbh->selectrow_array("SELECT count(*) FROM locations WHERE location LIKE ?", undef, ($newloc.'%'))) { + $newloc++; + ($newloc) = ($newloc =~ /^(..)/); + die "too many locations in use, can't add another one\n" if $newloc 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. + $shdesc = $newloc if !$shdesc; + $dbh->do("INSERT INTO locations (location, group_id, iplist, description, comments) VALUES (?,?,?,?,?)", + undef, ($newloc, $grp, $iplist, $shdesc, $comments) ); + $self->_log(entry => "Added location ($shdesc, '$iplist')"); + $loc = $newloc; + $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; + push @{$ulist}, { location => '', description => "(Default/All)", iplist => '', group_name => "All clients"} if $args{full}; + 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}; + + my ($ser) = $dbh->selectrow_array("SELECT zserial FROM "._zonetable($def,$rev). + " WHERE "._recparent($def,$rev)." = ?", undef, $id); + $ret->{serial} = $ser; + + 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 { + if (!$oldsoa) { + # old SOA record is missing for some reason. create a new one. + my $sql = "INSERT INTO "._rectable($defrec, $revrec)." ("._recparent($defrec, $revrec). + ", host, type, val, ttl) VALUES (?,?,6,?,?)"; + $dbh->do($sql, undef, ($soa{id}, "$soa{contact}:$soa{prins}", + "$soa{refresh}:$soa{retry}:$soa{expire}:$soa{minttl}", $soa{ttl}) ); + $msg = ($defrec eq 'y' ? ($revrec eq 'y' ? 'Default reverse ' : 'Default ') : ''). + "SOA missing for $parname; added (ns $soa{prins}, contact $soa{contact}, refresh $soa{refresh},". + " retry $soa{retry}, expire $soa{expire}, minTTL $soa{minttl}, TTL $soa{ttl})"; + } else { + 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})"; + } + $self->_updateserial(%logdata); + $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 = @_; + + $args{revrec} = 'n' if !$args{revrec}; + $args{defrec} = 'n' if !$args{defrec}; + + # RPC callers generally want the "true" IP. Flag argument for those to bypass showrev_arpa +##fixme: this will still blow up if some idiot has actually stored .arpa names in the DB. +# ... do we care? + $args{rpc} = 0 if !$args{rpc}; + + # 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}); + +##fixme: do we need a knob to twist to switch from unix epoch to postgres time string? + my @bindvars; + my $sql = "SELECT r.record_id,"; + # only include the parent info if we don't already know which parent we're in + $sql .= "r.domain_id,r.rdns_id," unless $args{id}; + $sql .= "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 NOT r.type=$reverse_typemap{SOA}"; + + # "normal" record list + if ($args{id}) { + $sql .= " AND "._recparent($args{defrec},$args{revrec})." = ?"; + push @bindvars, $args{id}; + } + + # Filtering on host/val (mainly normal record list) + if ($args{filter}) { + _recfilter(filter => $args{filter}, sql => \$sql, bindvars => \@bindvars); + } + + # Filtering on other fields + foreach (qw(type distance weight port ttl description location)) { + if ($args{$_}) { + $sql .= " AND r.$_ ~* ?"; + push @bindvars, $args{$_}; + } + } + + # whee! multisort means just passing comma-separated fields in sortby! + my $newsort = ''; + foreach my $sf (split /,/, $args{sortby}) { + $sf = "r.$sf"; + # sort on IP, correctly + $sf =~ s/r\.val/inetlazy(r.val)/; +# hmm. do we really need to limit this? +# if $args{revrec} eq 'y' && $args{defrec} eq 'n'; + $sf =~ s/r\.type/t.alphaorder/; # subtly different from sorting on rectypes.name + $newsort .= ",$sf"; + } + $newsort =~ s/^,//; +##enhance: pass in ascending/descending sort per-field + $sql .= " ORDER BY $newsort $args{sortorder}"; + # ensure consistent ordering by sorting on record_id too + $sql .= ", record_id $args{sortorder}"; + + # Offset/pagination + $sql .= ($args{offset} eq 'all' ? '' : " LIMIT $perpage OFFSET ".$args{offset}*$perpage); + + my @working; + my $recsth = $dbh->prepare($sql); + $recsth->execute(@bindvars); + while (my $rec = $recsth->fetchrow_hashref) { + if (!$args{rpc} && $args{revrec} eq 'y' && $args{defrec} eq 'n' && + ($self->{showrev_arpa} eq 'record' || $self->{showrev_arpa} eq 'all') && + $rec->{val} !~ /\.arpa$/ ) { + # skip all reverse zone .arpa "hostnames" since they're already .arpa names. +##enhance: extend {showrev_arpa} eq 'record' to specify record types + my $tmpip = new NetAddr::IP $rec->{val} if $rec->{val} =~ /^(?:[\d.\/]+|[a-fA-F0-9:\/]+)$/; + $rec->{val} = DNSDB::_ZONE($tmpip, 'ZONE', 'r', '.').($tmpip->{isv6} ? '.ip6.arpa' : '.in-addr.arpa') if $tmpip; + } + push @working, $rec; + } + return \@working; +} # 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 %args = @_; + + $args{defrec} = 'n' if !$args{defrec}; + $args{revrec} = 'n' if !$args{revrec}; + + my @bindvars; + my $sql = "SELECT count(*) FROM ". + _rectable($args{defrec},$args{revrec}). + " r WHERE NOT type=$reverse_typemap{SOA}"; + if ($args{id}) { + $sql .= " AND "._recparent($args{defrec},$args{revrec})." = ?"; + push @bindvars, $args{id}; + } + + # Filtering on host/val (mainly normal record list) + if ($args{filter}) { + _recfilter(filter => $args{filter}, sql => \$sql, bindvars => \@bindvars); + } + + # Filtering on other fields + foreach (qw(type distance weight port ttl description)) { + if ($args{$_}) { + $sql .= " AND $_ ~* ?"; + push @bindvars, $args{$_}; + } + } + + 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. + + # extra safety net - apparently RPC can squeak this by. O_o + return ('FAIL', "host must contain a value") if !$$host; + return ('FAIL', "val must contain a value") if !$$val; + + return ('FAIL', "expires must be 1, 't', or 'until', or 0, 'f', or 'after'") + if ($stamp && !$expires) + || ($stamp && $expires ne '0' && $expires ne '1' && $expires ne 't' && $expires ne 'f'); + + # 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+$//; + } + + _caseclean($rectype, $host, $val, $defrec, $revrec) if $self->{lowercase}; + + # prep for validation + my $addr = NetAddr::IP->new($$val) if _maybeip($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 + $ttl = '' if !$ttl; + $ttl =~ s/\s*//g; + return ('FAIL', "TTL must be numeric") unless $ttl =~ /^-?\d+$/; + + # 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'); + # Log reverse records to match the formal .arpa tree + if ($revrec eq 'y') { + $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 ? ', expires at ' : ', valid after ').$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; + + my $retid; + eval { + ($retid) = $dbh->selectrow_array("INSERT INTO "._rectable($defrec, $revrec)." ($fields) VALUES ($vallen) RETURNING record_id", + undef, + @vallist + ) || 'Falsey ID returned'; + $self->_updateserial(%logdata); + $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, $retid); + +} # 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; + + return ('FAIL', "expires must be 1, 't', or 'until', or 0, 'f', or 'after'") + if ($stamp && !$expires) + || ($stamp && $expires ne '0' && $expires ne '1' && $expires ne 't' && $expires ne 'f'); + + # 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+$//; + } + + _caseclean($rectype, $host, $val, $defrec, $revrec) if $self->{lowercase}; + + # prep for validation + my $addr = NetAddr::IP->new($$val) if _maybeip($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 + $ttl = '' if !$ttl; + $ttl =~ s/\s*//g; + return ('FAIL', "TTL must be numeric") unless $ttl =~ /^-?\d+$/; + + # 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. + # needed for crossover types that got coerced down to "standard" types due to data changes + # need to *avoid* funky records being updated like A/AAAA records in revzones, or PTRs in forward zones. + if ($defrec eq 'n' && $oldrec->{type} > 65000) { + 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) { # delegation + $fields .= ",rdns_id" if $revrec eq 'n'; + $fields .= ",domain_id" if $revrec eq 'y'; + push @vallist, 0; + } + # ... and now make sure we *do* associate a record with the "calling" parent + 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"; + # Log reverse records "naturally", since they're stored, um, unnaturally. + if ($revrec eq 'y') { + $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"; + # Log reverse records "naturally", since they're stored, um, unnaturally. + if ($revrec eq 'y') { + $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 ? ', expires at ' : ', valid after ').$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->_updateserial(%logdata); + $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); + # we have no %logdata in this sub + $self->_updateserial(domain_id => $rec->{domain_id}, rdns_id => $rec->{rdns_id}); + $self->_log(domain_id => $rec->{domain_id}, rdns_id => $rec->{rdns_id}, + group_id => $self->parentID(id => $rec->{rdns_id}, type => 'revzone', revrec => 'y'), + entry => "'$rec->{host} $typemap{$rec->{type}} $rec->{val}' downconverted to ". + "'$rec->{host} $typemap{$newtype} $rec->{val}'"); + $dbh->commit; + }; + if ($@) { + $errstr = $@; + eval { $dbh->rollback; }; + return 0; + } + return 1; +} # end downconvert() + + +## DNSDB::delRec() +# Delete a record. +# Takes a default/live flag, forward/reverse flag, and the ID of the record to delete. +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 => ($revrec eq 'n' ? $oldrec->{domain_id} : $oldrec->{rdns_id}), + type => 'domain', 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 { + $dbh->do("DELETE FROM "._rectable($defrec,$revrec)." WHERE record_id=?", undef, ($id)); + $self->_updateserial(%logdata); + $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 identifier and entity type as the primary log "slice" +sub getLogCount { + my $self = shift; + return $self->getLogEntries(@_, count => 1); +} # end getLogCount() + + +## DNSDB::getLogEntries() +# Get a list of log entries +# Takes arguments as with getLogCount() above, plus optional: +# - "count" flag +# OR +# - sort field +# - sort order +# - offset for pagination +sub getLogEntries { + my $self = shift; + my $dbh = $self->{dbh}; + + my %args = @_; + + my @filterargs; + + # fail if the prime id type is missing or invalid + $errstr = "Missing primary log slice type"; + return if !$args{logtype}; + $args{logtype} = 'revzone' if $args{logtype} eq 'rdns'; # hack pthui + $args{logtype} = 'domain' if $args{logtype} eq 'dom'; # hack pthui + $errstr = "Invalid primary log slice type"; + return if !grep /^$args{logtype}$/, ('group', 'domain', 'revzone', 'user'); + + # fail if we don't have a prime ID to look for log entries for + $errstr = "Missing ID for primary log slice"; + return if !($args{id} || $args{fname}); + + # 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', + revzone => 'revnet', domain => 'domain'); + $args{sortby} = $sortmap{$args{sortby}}; + + push @filterargs, $args{filter} if $args{filter}; + my $sql; + if ($args{count}) { + $sql = "SELECT count(*) FROM log l "; + } else { + $sql = "SELECT l.log_id AS logparent, l.user_id AS userid, l.name AS userfname, d.domain, l.domain_id, ". + "r.revnet AS revzone, ". + "l.rdns_id, l.entry AS logentry, date_trunc('second',l.stamp) AS logtime ". + "FROM log l ". + "LEFT JOIN domains d ON l.domain_id = d.domain_id ". + "LEFT JOIN revzones r ON l.rdns_id = r.rdns_id "; + } + + # decide which ID argument to use. Only use the "full name" if no normal ID is present + my $idarg; + if ($args{id}) { + $sql .= "WHERE l.$id_col{$args{logtype}} = ? "; + $idarg = $args{id}; + } else { + $sql .= "WHERE l.name = ? "; + $idarg = $args{fname}; + } + + # trim log "subentries" - we'll figure out where to stash these later + $sql .= " AND logparent = 0"; + + # add the entry filter, if any + $sql .= ($args{filter} ? " AND entry ~* ?" : ''); + + # Limit scope based on group. Mainly useful for ltype==user, so subgroup + # users can see what the deities in parent groups have done to their domains. + if ($args{group} != 1) { + my @grouplist; + $self->getChildren($args{group}, \@grouplist); + my $groupset = join(',', $args{group}, @grouplist); + $sql .= " AND l.group_id IN ($groupset)"; + } + + if ($args{count}) { + my ($count) = $dbh->selectrow_array($sql, undef, ($idarg, @filterargs) ); + $errstr = $dbh->errstr if !$count; + return $count; + } else { + $sql .= " ORDER BY $args{sortby} $args{sortorder}, log_id $args{sortorder}". + ($args{offset} eq 'all' ? '' : " LIMIT $self->{perpage} OFFSET ".$args{offset}*$self->{perpage}); + my @loglist; + my $sth = $dbh->prepare($sql); + my $logchild = $dbh->prepare("SELECT entry FROM log WHERE logparent = ? ORDER BY log_id"); + $sth->execute($idarg, @filterargs); + while (my $row = $sth->fetchrow_hashref) { + $logchild->execute($row->{logparent}); + my $childlist = $logchild->fetchall_arrayref({}); + $row->{childentries} = $childlist; + push @loglist, $row; + } + return \@loglist; + } + + # Your llama is on fire + +} # end getLogEntries() + + +# a collection of joins for the record search +our $recsearchsqlbase = q( +FROM records r +LEFT JOIN domains d ON r.domain_id = d.domain_id + LEFT JOIN groups g1 ON d.group_id = g1.group_id +LEFT JOIN revzones z ON r.rdns_id = z.rdns_id + LEFT JOIN groups g2 on z.group_id = g2.group_id +JOIN rectypes t ON r.type = t.val +LEFT JOIN locations l ON r.location = l.location +WHERE r.type <> 6); + + +## DNSDB::recSearchCount() +# Get a total count for a global record search +# Takes a hash with the search string and the login group of the user +sub recSearchCount { + my $self = shift; + my $dbh = $self->{dbh}; + my %args = @_; + + my $sql = "SELECT count(*)".$recsearchsqlbase; + + my @bindargs; + _recfilter(filter => $args{searchfor}, sql => \$sql, bindvars => \@bindargs); + + # Limit scope based on group + if ($args{group} != 1) { + my @grouplist; + $self->getChildren($args{group}, \@grouplist); + my $groupset = join(',', $args{group}, @grouplist); + # oh my aching HEAD. there has to be a better way to do conditions on joined tables... + $sql .= "AND ( + (g1.group_id IN ($groupset) AND g2.group_id IN ($groupset)) OR + (g1.group_id IN ($groupset) AND g2.group_id IS NULL) OR + (g1.group_id IS NULL AND g2.group_id IN ($groupset)) + ) +"; + } + + my $count = $dbh->selectrow_array($sql, undef, @bindargs); + $errstr = $dbh->errstr if !$count; + return $count; + +} # end recSearchCount() + + +## DNSDB::recSearch() +# Find records matching the search string +# Takes a hash with the search string, login group of the user, pagination offset, sort field, +# and sort direction +# Returns a reference to a list of hashrefs +sub recSearch { + my $self = shift; + my $dbh = $self->{dbh}; + my %args = @_; + + my $sql = q(SELECT + r.domain_id, d.domain, g1.group_name AS domgroup, + r.rdns_id, z.revnet AS revzone, g2.group_name AS revgroup, + r.host, t.name AS rectype, r.val, l.description AS location, r.record_id). + $recsearchsqlbase; + + my @bindargs; + _recfilter(filter => $args{searchfor}, sql => \$sql, bindvars => \@bindargs); + + # Limit scope based on group + if ($args{group} != 1) { + my @grouplist; + $self->getChildren($args{group}, \@grouplist); + my $groupset = join(',', $args{group}, @grouplist); + # oh my aching HEAD. there has to be a better way to do conditions on joined tables... + $sql .= "AND ( + (g1.group_id IN ($groupset) AND g2.group_id IN ($groupset)) OR + (g1.group_id IN ($groupset) AND g2.group_id IS NULL) OR + (g1.group_id IS NULL AND g2.group_id IN ($groupset)) + ) +"; + } + + # mixed tables means this isn't a simple prefix like the regular record list filter. :/ + my %sortmap = ( + domain => 'd.domain', + revzone => 'z.revnet', + host => 'r.host', + type => 't.name', + val => 'inetlazy(r.val)', + location => 'r.location', + ); + + # Sorting defaults + $args{sortorder} = 'ASC' if !$args{sortorder} || !grep /^$args{sortorder}$/, ('ASC','DESC'); + $args{sortby} = 'r.host' if !$args{sortby} || $args{sortby} !~ /^[\w_.]+$/; + $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/; + + $args{sortby} = $sortmap{$args{sortby}} if $args{sortby} !~ /\./; + + # Add sort and offset to SQL + $sql .= "ORDER BY $args{sortby} $args{sortorder},record_id ASC\n"; + $sql .= ($args{offset} eq 'all' ? '' : "LIMIT $self->{perpage} OFFSET ".$args{offset}*$self->{perpage}); + +##fixme: should probably sent the warning somewhere else + my $ret = $dbh->selectall_arrayref($sql, { Slice => {} }, @bindargs) + or warn $dbh->errstr; + return $ret; + +} # end recSearch() + + +## DNSDB::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 %args = @_; + $args{group} = 1 if !$args{group}; # just in case + $args{location} = '' if !$args{location}; + + # 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 >>= ?", + undef, ($cidr) ); + +##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 location = ? AND inetlazy(val) >>= ? ". + "ORDER BY inetlazy(val) DESC LIMIT 1", + undef, ($revid, $args{location}, $cidr) ); + + return $revpatt; +} # end getRevPattern() + + +## DNSDB::getRevSet() +# Return the unique per-IP reverse hostnames, if any, for the passed +# CIDR address (may be a netblock or an IP) +sub getRevSet { + my $self = shift; + my $dbh = $self->{dbh}; + my $cidr = shift; + my %args = @_; + $args{group} = 1 if !$args{group}; # just in case + $args{location} = '' if !$args{location}; + + # 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 >>= ?", + undef, ($cidr) ); + + $cidr = new NetAddr::IP $cidr; + if ($cidr->num > 256) { # should also catch v6! + # Even reverse entries for a v4 /24 of IPs is a bit much. I don't expect + # there to be a sane reason to retrive more than a /27 at once, really. + # v6 is going to be hairy no matter how you slice it. + $errstr = "Reverse hostname detail range too large"; + return; + } + + my $sth = $dbh->prepare("SELECT val, host FROM records ". + "WHERE (type in (12,65280,65281,65282,65283,65284)) AND rdns_id = ? AND location = ? AND inetlazy(val) = ?"); + + my @ret; + foreach my $ip (@{$cidr->splitref()}) { + $sth->execute($revid, $args{location}, $ip); + my @data = $sth->fetchrow_array(); + my %row; + if (@data) { + $row{r_ip} = $data[0]; + $row{iphost} = $data[1]; + } else { + $row{r_ip} = $ip->addr; + $row{iphost} = ''; + } + push @ret, \%row; + } + + return \@ret; +} # end getRevSet() + + +## 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; + # track whether the passed type is in the list at all. allows you to edit a record + # that wouldn't otherwise be generally available in that zone (typically, reverse zones) + # without changing its type (accidentally or otherwise) + my $selflag = 0; + while (my ($rval,$rname) = $sth->fetchrow_array()) { + my %row = ( recval => $rval, recname => $rname ); + if ($rval == $type) { + $row{tselect} = 1; + $selflag = 1; + } + push @typelist, \%row; + } + + # add the passed type if it wasn't in the list + if (!$selflag) { + my %row = ( recval => $type, recname => $typemap{$type}, tselect => 1 ); + 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 defrec and revrec. default to live record, forward zone + $args{defrec} = 'n' if !$args{defrec}; + $args{revrec} = 'n' if !$args{revrec}; + + # clean up the parent-type. Set it to group if not set + $args{partype} = 'group' if !$args{partype}; + + # allow callers to be lazy with type + $args{type} = 'revzone' if $args{type} eq 'domain' && $args{revrec} eq 'y'; + + if ($par_type{$args{partype}} eq 'domain' || $par_type{$args{partype}} eq 'revzone') { + # 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. +# Arguments must be passed in a hash +# Requires an argument "cidr" for the CIDR block to find parent/child zone(s) for +# Accepts optional arguments: +# - return_location: Flag indicating whether to return default_location or not +# - location: Restrict matches to a particular location/view +# - sort: Valid values are ASC or DESC; if omitted or set to something else +# results will be "whatever the database returns" +sub getZonesByCIDR { + my $self = shift; + my $dbh = $self->{dbh}; + my %args = @_; + $args{return_location} = 1 if !defined($args{return_location}); + + my $sql = "SELECT rdns_id,revnet".($args{return_location} ? ',default_location' : ''). + " FROM revzones WHERE (revnet >>= ? OR revnet <<= ?)". + (defined($args{location}) ? " AND default_location = ?" : ''); + if ($args{sort}) { + if ($args{sort} eq 'ASC' || $args{sort} eq 'DESC') { + $sql .= " ORDER BY revnet $args{sort}"; + } + } + my @svals = ($args{cidr}, $args{cidr}); + push @svals, $args{location} if defined $args{location}; + + my $result = $dbh->selectall_arrayref($sql, { Slice => {} }, @svals ); + 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) +# keepserial - keep the upstream serial number even if we overwrite the rest of the SOA +# 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+|^[\d.]+|^[a-fA-F0-9:]+)$}) { + # 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 =~ /^[\d.]+$/) { + # v4 revzone, leading-octet format + my $mask = 32; + while ($zone !~ /^\d+\.\d+\.\d+\.\d+$/) { + $zone .= '.0'; + $mask -= 8; + } + $zone .= "/$mask"; + $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', '.'); + } elsif ($zone =~ /^[a-fA-F\d:]+$/) { + # v6 revzone, leading-group format + $zone =~ s/::$//; + my $mask = 128; + while ($zone !~ /^(?:[a-fA-F\d]{1,4}:){7}[a-fA-F\d]$/) { + $zone .= ":0"; + $mask -= 16; + } + $zone .= "/$mask"; + $cidr = NetAddr::IP->new($zone) or return ('FAIL',"$zone is not a valid CIDR block"); + $zone = _ZONE($cidr, 'ZONE.ip6.arpa', 'r', '.'); + } else { + # there is. no. else! + return ('FAIL', "Unknown zone name format '$zone'"); + } + + # several places this can be triggered from; better to do it once. + $warnmsg .= "Apparent sub-/64 IPv6 reverse zone\n" if $cidr->masklen > 64; + + # 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) { +# # fail on multicharacter nibbles; it's syntactically valid but no standard lookup +# # will ever reach it, because it doesn't directly represent a real IP address. +# return ('FAIL', "Invalid reverse v6 entry") if $_ !~ /^.$/; + $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 { + + my $logparent; + + # Snarf the zone serial. Doing it here lets us log the serial we ultimately + # import with, and cleanly override or not as per the options + my $res = Net::DNS::Resolver->new; + $res->nameservers($ifrom); + my $soaq = $res->query($zone, "SOA"); + die "Error retrieving SOA for $zone: ".$res->errorstring."\n" if !$soaq; + my $ser = ($soaq->answer)[0]->{serial}; + if ($args{rwsoa}) { + if (!$args{keepserial}) { + $ser = scalar(time); + } + } + + if ($rev eq 'n') { + $dbh->do("INSERT INTO domains (domain,group_id,status,zserial) VALUES (?,?,?,?)", undef, + ($zone, $group, $args{status}, $ser) ) or die $dbh->errstr; + # get domain id so we can do the records + ($zone_id) = $dbh->selectrow_array("SELECT currval('domains_domain_id_seq')"); + $domain_id = $zone_id; + $logparent = $self->_log(group_id => $group, domain_id => $domain_id, + entry => "[Added ".($args{status} ? 'active' : 'inactive')." domain $zone with serial $ser via AXFR]"); + } else { + $dbh->do("INSERT INTO revzones (revnet,group_id,status,zserial) VALUES (?,?,?,?)", undef, + ($cidr,$group,$args{status}, $ser) ); + # get revzone id so we can do the records + ($zone_id) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')"); + $rdns_id = $zone_id; + $logparent = $self->_log(group_id => $group, rdns_id => $rdns_id, + entry => "[Added ".($args{status} ? 'active' : 'inactive')." reverse zone $cidr with serial $ser 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 + + $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()) { + + # Discard out-of-zone records. After trying for a while to replicate this with + # *nix-based DNS servers, it appears that only MS DNS is prone to including these + # in the AXFR data in the first place, and possibly only older versions at that... + # so it can't be reasonably tested. Yay Microsoft. + if ($rr->name !~ /$zone$/i) { + $warnmsg .= "Discarding out-of-zone record ".$rr->string."\n"; + } + + my $val; + my $distance = 0; + my $weight = 0; + my $port = 0; + my $logfrag = ''; + + # Collect some record parts + my $type = $rr->type; + my $host = $rr->name; + my $ttl = ($args{newttl} ? $args{newttl} : $rr->ttl); # allow force-override TTLs + + # Info flags for SOA and NS records + $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. + +# do the initial processing as if the record was in a forward zone. If we're +# doing a revzone, we can flip $host and $val as needed, once, after this +# monster if-elsif-...-elsif-else. This actually simplifies things a lot. + +##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? OTOH, those should rarely be rewritten anyway. + next if ($args{rwns} && ($host eq $zone)); + $val = $rr->nsdname; + $warnmsg .= "Suspect record '".$rr->string."' may not be imported correctly: NS records may not be bare IP addresses\n" + if $val =~ /^(?:(?:\d+\.){3}\d+|[a-fA-F0-9:]+)$/; + $nsflag = 1; + } elsif ($type eq 'CNAME') { + $val = $rr->cname; + $warnmsg .= "Suspect record '".$rr->string."' may not be imported correctly: CNAME records may not be bare IP addresses\n" + if $val =~ /^(?:(?:\d+\.){3}\d+|[a-fA-F0-9:]+)$/; + } 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') { + $val = $rr->ptrdname; + } 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. + $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; + $warnmsg .= "Suspect record '".$rr->string."' may not be imported correctly: SRV records may not be bare IP addresses\n" + if $val =~ /^(?:(?:\d+\.){3}\d+|[a-fA-F0-9:]+)$/; + } + + elsif ($type eq 'CAA') { + # Store CAA records without the syntactic quotes + $val = join(" ", $rr->flags, $rr->tag, $rr->value); + } + + 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"; + } + + if ($rev eq 'y' && $type ne 'SOA') { + # up to this point we haven't meddled with the record's hostname part or rdata part. + # for reverse records, (except SOA) we must swap the two. + $host = $val; + $val = $rr->name; + my ($tmpcode,$tmpmsg) = _zone2cidr($val); + if ($tmpcode eq 'FAIL') { + # $val did not have a valid IP value. It's syntactically valid but WTF? + $warnmsg .= "Suspect record '".$rr->string."' may not be imported correctly: $tmpmsg\n"; + } else { + # $val has a valid IP value. See if we can store it as that IP value. + # Note we're enumerating do-nothing cases for clarity. +##enhance: this is where we will implement the more subtle variations on #53 + if ($type ne 'PTR' && $type ne 'NS' && $type ne 'CNAME' && $type ne 'TXT') { + # case: the record is "weird" - ie, not a PTR, NS, CNAME, or TXT + # $warnmsg .= "Discarding suspect record '".$rr->string."'\n" if $self->{strict} eq 'full'; + } elsif ($type eq 'PTR' && $tmpmsg->masklen != 32 && $tmpmsg->masklen != 128) { + # case: PTR with netblock value, not IP value + # eg, "@ PTR foo" in zone f.e.e.b.d.a.e.d.ip6.arpa should not be + # stored/displayed as dead:beef::/32 PTR foo + +## hrm. WTF is this case for, anyway? Needs testing to check the logic. +# } elsif ( ($type eq 'PTR' || $type eq 'NS' || $type eq 'CNAME' || $type eq 'TXT') && +# ($tmpmsg->masklen != $cidr->masklen) +# ) { +# # leave $val as-is if the record is "normal" (a PTR, NS, CNAME, or TXT), +# # and the mask does not match the zone +#$warnmsg .= "WTF case: $host $type $val\n"; +# # $warnmsg .= "Discarding suspect record '".$rr->string."'\n" if $self->{strict} eq 'full'; + + } else { + $val = $tmpmsg; + $val =~ s/\/(?:32|128)$//; # automagically converts $val back to a string before s/// + #$val =~ s/:0$//g; + } + } + # magic? convert * records to PTR template (not sure this actually makes sense) + #if ($val =~ /^\*/) { + # $val =~ s/\*\.//; + # ($tmpcode,$tmpmsg) = _zone2cidr($val); + # if ($tmpcode eq 'FAIL') { + # $val = "*.$val"; + # $warnmsg .= "Suspect record '".$rr->string."' may not be converted to PTR template correctly: $tmpmsg\n"; + # } else { + # $type = 'PTR template'; + # $val = $tmpmsg; if $tmp + # $val =~ s/\/(?:32|128)$//; # automagically converts $val back to a string before s/// + # } + #} + } # non-SOA revrec $host/$val inversion and munging + + 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 '".($rev eq 'y' ? $val : $host)." $type"; + $logentry .= " [distance $distance]" if $type eq 'MX'; + $logentry .= " [priority $distance] [weight $weight] [port $port]" if $type eq 'SRV'; + $logentry .= " ".($rev eq 'y' ? $host : $val)."', TTL $ttl"; + } + $self->_log(group_id => $group, domain_id => $domain_id, rdns_id => $rdns_id, + logparent => $logparent, 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 "._rectable('y', $rev)." WHERE group_id=? AND type=?"); + my $sthputsoa = $dbh->prepare("INSERT INTO records (". + ($rev eq 'n' ? 'domain_id' : 'rdns_id').",host,type,val,ttl) VALUES (?,?,?,?,?)"); + $sthgetsoa->execute($group,$reverse_typemap{SOA}); + while (my ($host,$val,$ttl) = $sthgetsoa->fetchrow_array()) { + if ($rev eq 'n') { + $host =~ s/DOMAIN/$zone/g; + $val =~ s/DOMAIN/$zone/g; # arguably useless + } else { + $host =~ s/ADMINDOMAIN/$self->{domain}/g; + } + $sthputsoa->execute($zone_id,$host,$reverse_typemap{SOA},$val,$ttl); + } + } + + # Add standard NS records. The old one(s) should have been skipped by this point. + if ($args{rwns}) { + $nsflag = 1; + my $sthgetns = $dbh->prepare("SELECT host,val,ttl FROM "._rectable('y',$rev)." WHERE group_id=? AND type=?"); + my $sthputns = $dbh->prepare("INSERT INTO records (". + ($rev eq 'n' ? 'domain_id' : 'rdns_id').",host,type,val,ttl) VALUES (?,?,?,?,?)"); + $sthgetns->execute($group,$reverse_typemap{NS}); + while (my ($host,$val,$ttl) = $sthgetns->fetchrow_array()) { + if ($rev eq 'n') { + $host =~ s/DOMAIN/$zone/g; + $val =~ s/DOMAIN/$zone/g; #hmm. + } else { + $host =~ s/ADMINDOMAIN/$self->{domain}/g; #hmm. + $val =~ s/ZONE/$cidr/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) { + $errstr = "Can't export nothing"; + return; + } + + if ($target eq 'tiny') { + eval { + $self->__export_tiny(@_); + }; + if ($@) { + $errstr = $@; + return undef; + } + } + + # BIND and NSD (and possibly others) could be merged, or partially + # merged, since pretty much everyone uses BIND-style zone files + elsif ($target eq 'bind') { + require DNSDB::ExportBIND; + eval { + # there are probably better ways to structure this + DNSDB::ExportBIND::export($self, @_); + }; + if ($@) { + $errstr = $@; + return undef; + } + } + +# elsif ($target eq 'foo') { +# __export_foo(@_); +#} +# etc + + return 1; +} # 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; + my $zonefilehandle = $datafile; # makes cache/no-cache a little simpler + +##fixme: slurp up further options to specify particular zone(s) to export + +##fixme: fail if $datafile isn't an open, writable file + + # Error check - does the cache dir exist, if we're using one? + if ($self->{usecache}) { + die "Cache directory $self->{exportcache} does not exist\n" if !-e $self->{exportcache}; + die "$self->{exportcache} is not a directory\n" if !-d $self->{exportcache}; + die "$self->{exportcache} must be both readable and writable\n" + if !-r $self->{exportcache} || !-w $self->{exportcache}; + } + + # 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 + + # note: the only I/O failures we seem to be able to actually catch + # here are "closed filehandle" errors. we're probably not writing + # enough data at this point to properly trigger an "out of space" + # error. :/ + eval { + use warnings FATAL => ('io'); + # 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}; + } + }; + if ($@) { + die "Error writing locations to master file: $@, $!\n"; + } + + # 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(inetlazy(val)) DESC, inetlazy(val)"); + my $revsth = $dbh->prepare("SELECT rdns_id,revnet,status,changed FROM revzones WHERE status=1 ". + "ORDER BY masklen(revnet) DESC, rdns_id"); + 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 { + + # write fresh records if: + # - we are not using the cache + # - force_refresh is set + # - the zone has changed + # - the cache file does not exist + # - the cache file is empty + if (!$self->{usecache} || $self->{force_refresh} || $changed || !-e $cachefile || -z $cachefile) { + if ($self->{usecache}) { + open ZONECACHE, ">$tmpcache" or die "Error creating temporary file $tmpcache: $!\n"; + $zonefilehandle = *ZONECACHE; + } + + # 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(); + $self->_printrec_tiny($zonefilehandle, $zsoa[7], 'y',\%recflags,$revzone, + $zsoa[0],$zsoa[1],$zsoa[2],$zsoa[3],$zsoa[4],$zsoa[5],$zsoa[6],$zsoa[8],''); + + $recsth->execute($revid); + my $fullzone = _ZONE($tmpzone, 'ZONE', 'r', '.').($tmpzone->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'); + + while (my ($host, $type, $val, $dist, $weight, $port, $ttl, $recid, $loc, $stamp, $expires, $stampactive) + = $recsth->fetchrow_array) { + next if $recflags{$recid}; + + # Check for out-of-zone data + if ($val =~ /\.arpa$/) { + # val is non-IP + if ($val !~ /$fullzone$/) { + warn "Not exporting out-of-zone record $val $typemap{$type} $host, $ttl (zone $tmpzone)\n"; + next; + } + } else { + my $ipval = new NetAddr::IP $val; + if (!$tmpzone->contains($ipval)) { + warn "Not exporting out-of-zone record $val $typemap{$type} $host, $ttl (zone $tmpzone)\n"; + next; + } + } # is $val a raw .arpa name? + + # 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+$//; + } + + $self->_printrec_tiny($zonefilehandle, $recid, 'y', \%recflags, $revzone, + $host, $type, $val, $dist, $weight, $port, $ttl, $loc, $stamp, $expires, $stampactive); + + $recflags{$recid} = 1; + + } # while ($recsth) + + if ($self->{usecache}) { + 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 ($@) { + die "error writing ".($self->{usecache} ? '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); + } + + if ($self->{usecache}) { + # We've already made as sure as we can that a cached zone file is "good", + # although possibly stale/obsolete due to errors creating a new one. + eval { + open CACHE, "<$cachefile" or die $!; + print $datafile $_ or die "error copying cached $revzone to master file: $!" while ; + close CACHE; + }; + die $@ if $@; + } + + } # while ($revsth) + + $soasth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl,record_id,location ". + "FROM records WHERE domain_id=? AND type=6"); + $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=? AND NOT type=6". # Just exclude all types relating to rDNS + "ORDER BY masklen(inetlazy(val)) DESC, inetlazy(val)"); +# "FROM records WHERE domain_id=? AND type < 65280"); # Just exclude all types relating to rDNS + my $domsth = $dbh->prepare("SELECT domain_id,domain,status,changed FROM domains WHERE status=1 ORDER BY domain_id"); + $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 { + + # write fresh records if: + # - the zone contains ALIAS pseudorecords, which need to cascade changes from the upstream CNAME farm at every opportunity + if ( ($dbh->selectrow_array("SELECT count(*) FROM records WHERE domain_id = ? AND type=65300", undef, $domid))[0] ) { + $changed = 1; # abuse this flag for zones with ALIAS records + # also update the serial number, because while it shouldn't matter purely for serving + # records, it WILL matter if AXFR becomes part of the publishing infrastructure + $self->_updateserial(domain_id => $domid); + } + # - the zone contains records which expire in less than 10 minutes or became valid less than 10 minutes ago + # note, no need to multi-bump the serial + elsif ( ($dbh->selectrow_array("SELECT COUNT(*) FROM records WHERE domain_id = ? AND ". + "stampactive='t' AND @(extract(epoch from stamp-now())) < 600", undef, $domid))[0] ) { + $changed = 1; + $self->_updateserial(domain_id => $domid); + } + # - we are not using the cache + # - force_refresh is set + # - the zone has changed + # - the cache file does not exist + # - the cache file is empty + if (!$self->{usecache} || $self->{force_refresh} || $changed || !-e $cachefile || -z $cachefile) { + if ($self->{usecache}) { + open ZONECACHE, ">$tmpcache" or die "Error creating temporary file $tmpcache: $!\n"; + $zonefilehandle = *ZONECACHE; + } + + # need to fetch this separately so the SOA comes first in the flatfile.... + # Just In Case we need/want to reimport from the flatfile later on. + $soasth->execute($domid); + my (@zsoa) = $soasth->fetchrow_array(); + $self->_printrec_tiny($zonefilehandle, $zsoa[7], 'n',\%recflags,$dom, + $zsoa[0],$zsoa[1],$zsoa[2],$zsoa[3],$zsoa[4],$zsoa[5],$zsoa[6],$zsoa[8],''); + + $recsth->execute($domid); + while (my ($host,$type,$val,$dist,$weight,$port,$ttl,$recid,$loc,$stamp,$expires,$stampactive) = $recsth->fetchrow_array) { + next if $recflags{$recid}; + + # Check for out-of-zone data + $host = $dom if $host eq '@'; + if ($host !~ /$dom$/i) { + warn "Not exporting out-of-zone record $host $type $val, $ttl (zone $dom)\n"; + next; + } + + # 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+$//; + } + + $self->_printrec_tiny($zonefilehandle, $recid, 'n', \%recflags, + $dom, $host, $type, $val, $dist, $weight, $port, $ttl, $loc, $stamp, $expires, $stampactive); + + $recflags{$recid} = 1; + + } # while ($recsth) + + + if ($self->{usecache}) { + 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 ($@) { + die "error writing ".($self->{usecache} ? '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); + } + + if ($self->{usecache}) { + # We've already made as sure as we can that a cached zone file is "good", + # although possibly stale/obsolete due to errors creating a new one. + eval { + open CACHE, "<$cachefile" or die $!; + print $datafile $_ or die "error copying cached $dom to master file: $!" while ; + close CACHE; + }; + die $@ if $@; + } + + } # while ($domsth) + + return 1; +} # end __export_tiny() + + +# Utility sub for __export_tiny above +sub _printrec_tiny { + my $self = shift; + my ($datafile, $recid, $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]); + } + + # Utility sub-sub for reverse records; with "any-record-in-any-zone" + # we may need to do extra processing on $val to make it publishable. + sub __revswap { + my $host = shift; + my $val = shift; + return ($val, $host) if $val =~ /\.arpa/; + $val = new NetAddr::IP $val; + my $newval = _ZONE($val, 'ZONE', 'r', '.').($val->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'); + return ($newval, $host); + } + +## 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 $self = shift; # *sigh* need to pass in the DNSDB object so we can read a couple of options + my $sub = shift; + my $recflags = shift; + my $hpat = shift; + my $fh = shift; + my $ttl = shift; + my $stamp = shift; + my $loc = shift; + my $zone = shift; + # error/sanity check - if $zone is not an IP address, make sure we're just + # converting a string that looks like an IP into a NetAddr::IP, instead of + # doing a DNS lookup that is virtually guaranteed to be wrong. still a + # little hazy where this functionality in NetAddr::IP is useful. + # instead, fall back to the octet-boundary CIDR derived from $sub. + if ($zone !~ m,^\d+\.\d+\.\d+\.\d+/\d+$,) { + $zone = $sub; + $zone =~ s,\d+/\d+$,0/24,; ##fixme: case of larger than /24? + # could apply another sanity check here? as above anything much larger + # than a /16 is WAY too time-consuming to publish in one go + } + $zone = new NetAddr::IP $zone; + my $ptronly = shift || 0; + + # do this conversion once, not (number-of-ips-in-subnet) times + my $arpabase = _ZONE($zone, 'ZONE.in-addr.arpa', 'r', '.'); + + my $iplist = $sub->splitref(32); + my $ipindex = -1; + foreach (@$iplist) { + my $ip = $_->addr; + $ipindex++; + # make as if we split the non-octet-aligned block into octet-aligned blocks as with SOA + my $lastoct = (split /\./, $ip)[3]; + next if $$recflags{$ip}; # && $self->{skip_bcast_255} + $$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 +##fixme: there really isn't a good way to handle sub-/24 zones here. This way at least +# seems less bad than some alternatives. + $self->_template4_expand(\$rec, $ip, \$sub, $ipindex); + # _template4_expand may blank $rec; if so, don't publish a record + next if !$rec; + if ($ptronly || $zone->masklen > 24) { + print $fh "^$lastoct.$arpabase:$rec:$ttl:$stamp:$loc\n" or die $!; + if (!$ptronly) { + # print a separate A record. Arguably we could use an = record here instead. + print $fh "+$rec:$ip:$ttl:$stamp:$loc\n" or die $!; + } + } else { + print $fh "=$rec:$ip:$ttl:$stamp:$loc\n" or die $!; + } + } + } # __publish_subnet + +## And now the meat. + +##fixme? append . to all host/val hostnames +#print "debug: rawdata: $host $typemap{$type} $val\n"; + + if ($typemap{$type} eq 'SOA') { + # host contains pri-ns:responsible + # val is abused to contain refresh:retry:expire:minttl + # 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]; + my $serial = 0; # fail less horribly than leaving it empty? + 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 +# anyone who says they need sub-nibble v6 delegations, at this time, needs their head examined. +##fixme?: alternate SOA serial schemes? + ($serial) = $self->{dbh}->selectrow_array("SELECT zserial FROM revzones WHERE revnet=?", undef, $zone); + $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:$serial:$refresh:$retry:$expire:$min_ttl:$ttl:$stamp:$loc\n" + or die $!; + } + return; # skips "default" bits just below + } + $zone = _ZONE($zone, 'ZONE', 'r', '.').($zone->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'); + } else { + # just snarfing the right SOA serial for the zone type +##fixme?: alternate SOA serial schemes? + ($serial) = $self->{dbh}->selectrow_array("SELECT zserial FROM domains WHERE domain=?", undef, $zone); + } # revrec <> 'y' + $serial = '' if !$serial; # suppress a "uninitialized value" warning. empty serial isn't an error, just falls back to tinydns' autoserial + print $datafile "Z$zone:$primary:$email:$serial:$refresh:$retry:$expire:$min_ttl:$ttl:$stamp:$loc\n" + or die $!; + } # SOA + + elsif ($typemap{$type} eq 'A') { + ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; + print $datafile "+$host:$val:$ttl:$stamp:$loc\n" or die $!; + } # A + + 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" or die $!; + $$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" or die $!; + $$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" or die $!; + $$recflags{$val2} = $val->masklen; + } + } else { + print $datafile "\&$host"."::$val:$ttl:$stamp:$loc\n" or die $!; + } + } # NS + + elsif ($typemap{$type} eq 'AAAA') { + ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; + 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($_); + } + } + my $prefix = ":$host:28:"; + foreach my $octet (@altconv) { + # if not 's', output + $prefix .= $octet unless $octet =~ /^s$/; + # if 's', output (9-array length)x literal '\000\000' + $prefix .= '\000\000'x(9-$altgrp) if $octet =~ /^s$/; + } + print $datafile "$prefix:$ttl:$stamp:$loc\n" or die $!; + } # AAAA + + elsif ($typemap{$type} eq 'MX') { + ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; + print $datafile "\@$host"."::$val:$dist:$ttl:$stamp:$loc\n" or die $!; + } # MX + + elsif ($typemap{$type} eq 'TXT') { + ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; +# le sigh. Some idiot DNS implementations don't seem to like tinydns autosplitting +# long TXT records at 127 characters instead of 255. Hand-crafting a record seems +# to paper over the remote stupid. We will NOT try to split on whitespace; the +# contents of a TXT record are opaque and clients who can't deal are even more broken +# than the ones that don't like them split at 127 characters... because BIND tries +# to "intelligently" split TXT data, and abso-by-damn-lutely generates chunks <255 +# characters, and anything that can't interpret BIND's DNS responses has no business +# trying to interpret DNS data at all. + + if ($self->{autotxt}) { + # let tinydns deal with splitting the record. note tinydns autosplits at 127 + # characters, not 255. Because Reasons. + $val =~ s/:/\\072/g; # may need to replace other symbols + print $datafile "'$host:$val:$ttl:$stamp:$loc\n" or die $!; + } else { + print $datafile ":$host:16:"; + my @txtsegs = $val =~ /.{1,255}/g; + foreach (@txtsegs) { + my $len = length($_); + s/:/\\072/g; + printf $datafile "\\%0.3o%s", $len, $_; + } + print $datafile ":$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 + + } # TXT + + elsif ($typemap{$type} eq 'CNAME') { + ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; + if ($zone =~ /\.rpz$/) { + $val = '..' if $val eq '.'; + } + print $datafile "C$host:$val:$ttl:$stamp:$loc\n" or die $!; + } # CNAME + + elsif ($typemap{$type} eq 'SRV') { + ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; + + # data is two-byte values for priority, weight, port, in that order, + # followed by length/string data + + my $prefix = ":$host:33:".octalize($dist,'d').octalize($weight,'d').octalize($port,'d'); + + $val .= '.' if $val !~ /\.$/; + foreach (split /\./, $val) { + $prefix .= sprintf "\\%0.3o%s", length($_), $_ or die $!; + } + print $datafile "$prefix\\000:$ttl:$stamp:$loc\n" or die $!; + } # SRV + + elsif ($typemap{$type} eq 'CAA') { + # CAA records really don't make much sense in reverse zones + #($host,$val) = __revswap($host,$val) if $revrec eq 'y'; + return if $revrec eq 'y'; + + # data is a bitfield byte, length byte+string, then "everything else" + + my $prefix = ":$host:257:"; + + my ($caaflags, $caatag, $caadetail) = ($val =~ /(\d+)\s+(\w+)\s+(.+)/); + $prefix .= sprintf "\\%0.3o", $caaflags; + $prefix .= sprintf "\\%0.3o%s", length($caatag), $caatag; + $caadetail =~ s/:/\\072/g; + $caadetail =~ s/;/\\073/g; # Not strictly necessary but may be helpful validating records by eye + $caadetail =~ s/^\s*"\s*//; # AXFR imports may produce strings with embedded quotes; these + $caadetail =~ s/\s*"\s*$//; # are purely a syntactic crutch for BIND-style zone files + print $datafile "$prefix$caadetail:$ttl:$stamp:$loc\n" or die $!; + } # CAA + + elsif ($typemap{$type} eq 'RP') { + ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; + # 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. + my $prefix = ":$host:17:"; + my ($who,$what) = split /\s/, $val; + foreach (split /\./, $who) { + $prefix .= sprintf "\\%0.3o%s", length($_), $_; + } + $prefix .= '\000'; + foreach (split /\./, $what) { + $prefix .= sprintf "\\%0.3o%s", length($_), $_; + } + print $datafile "$prefix\\000:$ttl:$stamp:$loc\n" or die $!; + } # RP + + elsif ($typemap{$type} eq 'PTR') { + $$recflags{$val}++; + + # technically a PTR template thing, but Bad Data Happens + return if $host =~ /\%blank\%/; + + if ($revrec eq 'y') { + + if ($val =~ /\.arpa$/) { + # someone put in the formal .arpa name. humor them. + print $datafile "^$val:$host:$ttl:$stamp:$loc\n" or die $!; + } else { + $zone = NetAddr::IP->new($zone); + if (!$zone->{isv6} && $zone->masklen > 24) { + # sub-octet v4 zone + ($val) = ($val =~ /\.(\d+)$/); + print $datafile "^$val."._ZONE($zone, 'ZONE', 'r', '.').'.in-addr.arpa'. + ":$host:$ttl:$stamp:$loc\n" or die $!; + } else { + # not going to care about strange results if $val is not an IP value and is resolveable in DNS + $val = NetAddr::IP->new($val); + print $datafile "^". + _ZONE($val, 'ZONE', 'r', '.').($val->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'). + ":$host:$ttl:$stamp:$loc\n" or die $!; + } + } # non-".arpa" $val + + } else { + # PTRs in forward zones are less bizarre and insane than some other record types + # in reverse zones... OTOH we can't validate them any which way, so we cross our + # fingers and close our eyes and make it Someone Else's Problem. + print $datafile "^$host:$val:$ttl:$stamp:$loc\n" or die $!; + } + } # PTR + + elsif ($type == 65280) { # A+PTR + $$recflags{$val}++; + + # technically a PTR template thing, but Bad Data Happens + return if $host =~ /\%blank\%/; + + print $datafile "=$host:$val:$ttl:$stamp:$loc\n" or die $!; + } # A+PTR + + 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 + $self->_printrec_tiny($datafile,$recid,'n',$recflags, $self->domainName($self->_hostparent($host)), + $host, 28, $val, $dist, $weight, $port, $ttl, $loc, $stamp); + $self->_printrec_tiny($datafile, $recid, 'y', $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 + } # AAAA+PTR + + 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)) { + $self->__publish_subnet($sub, $recflags, $host, $datafile, $ttl, $stamp, $loc, $zone, 1); + } + } else { + $self->__publish_subnet($val, $recflags, $host, $datafile, $ttl, $stamp, $loc, $zone, 1); + } + } # PTR template + + 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)) { + $self->__publish_subnet($sub, $recflags, $host, $datafile, $ttl, $stamp, $loc, $zone, 0); + } + } else { + $self->__publish_subnet($val, $recflags, $host, $datafile, $ttl, $stamp, $loc, $zone, 0); + } + } # A+PTR template + + 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/ ) + } # AAAA+PTR template + + 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. + $self->_printrec_tiny($datafile,$recid,$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. + # OR + # create NS records for each IP + # 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" or die $!; + $$recflags{"$_"}++; + } + } + } + } # Delegation + + elsif ($type == 65300) { # ALIAS + # Implemented as a unique record in parallel with many other + # management tools, for clarity VS formal behviour around CNAME + # Mainly for "root CNAME" or "apex alias"; limited value for any + # other use case since CNAME can generally be used elsewhere. + + # .arpa zones don't need this hack. shouldn't be allowed into + # the DB in the first place, but Just In Case... + return if $revrec eq 'y'; + + my ($iplist) = $self->{dbh}->selectrow_array("SELECT auxdata FROM records WHERE record_id = ?", undef, $recid); + $iplist = '' if !$iplist; + + # shared target-name-to-IP converter + my $liveips = $self->_grab_65300($recid, $val); + # only update the cache if the live lookup actually returned data + if ($liveips && ($iplist ne $liveips)) { + $self->{dbh}->do("UPDATE records SET auxdata = ? WHERE record_id = ?", undef, $liveips, $recid); + $iplist = $liveips; + } + + # slice the TTL we'll actually publish off the front + my @asubs = split ';', $iplist; + my $attl = shift @asubs; + + # output a plain old A or AAAA record for each IP the target name really points to. + # in the event that, for whatever reason, no A/AAAA records are available for $val, nothing will be output. + foreach my $subip (@asubs) { + if ($subip =~ /\d+\.\d+\.\d+\.\d+/) { + print $datafile "+$host:$subip:$attl:$stamp:$loc\n" or die $!; + } else { + $self->_printrec_tiny($datafile, $recid, 'n', $recflags, $self->domainName($self->_hostparent($host)), + $host, 28, $subip, $dist, $weight, $port, $attl, $loc, $stamp); + } + } + } # ALIAS + +## +## Uncommon types. These will need better UI support Any Day Sometime Maybe(TM). +## + + elsif ($type == 44) { # SSHFP + ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; + + 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" or die $!; + } # SSHFP + + 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"; + + } # "other" + +} # 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: branches/cname-collision/DNSDB/ExportBIND.pm =================================================================== --- branches/cname-collision/DNSDB/ExportBIND.pm (revision 936) +++ branches/cname-collision/DNSDB/ExportBIND.pm (revision 936) @@ -0,0 +1,859 @@ +# dns/trunk/DNSDB/ExportBIND.pm +# BIND data export/publication +# Call through DNSDB.pm's export() sub +## +# $Id$ +# Copyright 2022-2025 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::ExportBIND; + +use strict; +use warnings; + +use DNSDB; + +sub export { + # expected to be a DNSDB object + my $dnsdb = shift; + + # to be a hash of views/locations, containing lists of zones + my %viewzones; + + # allow for future exports of subgroups of records + my $viewlist = $dnsdb->getLocList(curgroup => 1, full => 1); + + +## export reverse zones + + my $soasth = $dnsdb->{dbh}->prepare("SELECT host,val,ttl,record_id,location FROM records WHERE rdns_id=? AND type=6"); + # record order matters for reverse zones because we need to override larger templates with smaller ones. + my $recsth = $dnsdb->{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(inetlazy(val)) DESC, inetlazy(val), record_id"); + + # Fetch active zone list + my $revsth = $dnsdb->{dbh}->prepare("SELECT rdns_id,revnet,status,changed,default_location FROM revzones WHERE status=1 ". + "ORDER BY masklen(revnet),revnet DESC, rdns_id"); + # Unflag changed zones, so we can maybe cache the export and not redo everything every time + my $zonesth = $dnsdb->{dbh}->prepare("UPDATE revzones SET changed='n' WHERE rdns_id=?"); + + my %recflags; # need this to be independent for forward vs reverse zones, as they're not merged + + $revsth->execute(); + while (my ($revid,$revzone,$revstat,$changed,$defloc) = $revsth->fetchrow_array) { + my $cidr = NetAddr::IP->new($revzone); + +##fixme: convert logical revzone into .arpa name? maybe take a slice of showrev_arpa? +##fixme: need to bodge logical non-octet-boundary revzones into octet-boundary revzones +##fixme: do we do cache files? views balloon the file count stupidly +## foreach $octetzone $cidr->split(octet-boundary) +## loclist = SELECT DISTINCT location FROM records WHERE rdns_id = $zid AND inetlazy(val) <<= $octetzone + +#printf "non-octet? %s, %i\n", $cidr->masklen, $cidr->masklen % 8; + + # fetch a list of views/locations present in the zone. we need to publish a file for each one. + # in the event that no locations are present (~~ $viewlist is empty), /%view collapses to nothing in the zone path + my $tmplocs = $dnsdb->{dbh}->selectall_arrayref("SELECT DISTINCT location FROM records WHERE rdns_id = ?", undef, $revid); + my @loclist; + foreach my $tloc (@{$tmplocs}) { + push @loclist, ($tloc->[0] eq '' ? 'common' : $tloc->[0]); + } + + my %zonefiles; # zone file handles + + eval { + +##fixme: use tmpfile module for more secure temp files? want the zone name at least in it anyway, not sure that works... + my $arpazone = DNSDB::_ZONE($cidr, 'ZONE', 'r', '.').($cidr->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'); + my $zfile = $cidr->network->addr."-".$cidr->masklen; +# my $cachefile = "$dnsdb->{exportcache}/$zfile"; +# my $tmpcache = "$dnsdb->{exportcache}/tmp.$zfile.$$"; + my $tmpcache = "tmp.$zfile.$$"; # safety net. don't overwrite a previous known-good file + +##fixme: need to open separate zone files for aggregated metazones eg /22 or /14 + foreach my $loc (@loclist) { + my $zfilepath = $dnsdb->{bind_export_reverse_zone_path}; + $zfilepath =~ s/\%view/$loc/; + $zfilepath =~ s/\%zone/$zfile/; + $zfilepath =~ s/\%arpazone/$arpazone/; + + # Just In Case(TM) + $zfilepath =~ s,[^\w./-],_,g; + + # safety check, may need tweaking for race conditions + my $zpathbase = $zfilepath; + $zpathbase =~ s{/[^/]+$}{}; + if (!-e $zpathbase) { + mkdir $zpathbase; + } else { + die "$zpathbase is not a directory\n" unless -d $zpathbase; + } + + # write fresh records if: + # - the zone contains records which expire in less than 10 minutes or became valid less than 10 minutes ago + # note, no need to multi-bump the serial + if ( ($dnsdb->{dbh}->selectrow_array("SELECT COUNT(*) FROM records WHERE rdns_id = ? AND ". + "stampactive='t' AND @(extract(epoch from stamp-now())) < 600", undef, $revid))[0] ) { + $changed = 1; + $dnsdb->_updateserial(rdns_id => $revid); + } +# - we are not using the cache +# if ($dnsdb->{usecache} + # - force_refresh is set + # - the zone has changed + # - the zone file does not exist + # - the zone file is empty + elsif ($dnsdb->{force_refresh} || $changed || !-e $zfilepath || -z $zfilepath) { +# if ($dnsdb->{usecache}) { +# open ZONECACHE, ">$tmpcache" or die "Error creating temporary file $tmpcache: $!\n"; +# $zonefilehandle = *ZONECACHE; +# } + open $zonefiles{$loc}, ">", $zfilepath or die "Error creating temporary file $zfilepath: $!\n"; + + # Header for human convenience +##fixme? vary arpazone/cidr in header and error message per showrev_arpa, or possibly +# new dedicated setting, or possibly interact with with bind_export_fqdn? + printf {$zonefiles{$loc}} "; %s in view %s exported %s\n", $arpazone, $loc, scalar(localtime) + or die "Error writing header [$arpazone, '$loc']: $!\n"; + + # Fetch the SOA separately as we publish it separately for each location with this loop, + # mainly because we want it first in the zone file + $soasth->execute($revid); + my ($soa_host, $soa_val, $soa_ttl, $soa_id, $soa_loc) = $soasth->fetchrow_array; + +##fixme: do we even need @loclist passed in? + printrec_bind($dnsdb, \%zonefiles, \@loclist, $soa_id, 'y', \%recflags, $cidr, + $soa_host, 6, $soa_val, 0, 0, 0, $soa_ttl, $loc, ''); + + } # if force_refresh etc + + # tag the zonefile for publication in the view + push @{$viewzones{$loc}}, $arpazone; + + } # foreach @loclist + + # now the meat of the records + $recsth->execute($revid); + while (my ($host, $type, $val, $dist, $weight, $port, $ttl, $recid, $loc, $stamp, $expires, $stampactive) + = $recsth->fetchrow_array) { + next if $recflags{$recid}; + + # 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+$//; + } + + # Check for out-of-zone data + if ($val =~ /\.arpa$/) { + # val is non-IP + if ($val !~ /$arpazone$/) { + warn "Not exporting out-of-zone record $val $typemap{$type} $host, $ttl (zone $cidr)\n"; + next; + } + } else { + my $ipval = new NetAddr::IP $val; + if (!$cidr->contains($ipval)) { + warn "Not exporting out-of-zone record $val $typemap{$type} $host, $ttl (zone $cidr)\n"; + next; + } + } # is $val a raw .arpa name? + + printrec_bind($dnsdb, \%zonefiles, \@loclist, $recid, 'y', \%recflags, $revzone, + $host, $type, $val, $dist, $weight, $port, $ttl, $loc, $stamp, $expires, $stampactive); + + $recflags{$recid} = 1; + + } # while ($recsth) + +# if ($dnsdb->{usecache}) { +# 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 ($@) { + die "error writing ".($dnsdb->{usecache} ? '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); + } + +# if ($dnsdb->{usecache}) { +# # We've already made as sure as we can that a cached zone file is "good", +# # although possibly stale/obsolete due to errors creating a new one. +# eval { +# open CACHE, "<$cachefile" or die $!; +# print $datafile $_ or die "error copying cached $revzone to master file: $!" while ; +# close CACHE; +# }; +# die $@ if $@; +# } + + } # revsth->fetch + + + +## and now the domains + + $soasth = $dnsdb->{dbh}->prepare("SELECT host,val,ttl,record_id,location FROM records WHERE domain_id=? AND type=6"); + # record order needs to match reverse zone ordering for IP values, or A+PTR + # template records don't cascade/expand correctly to match the reverse zones. + # order by record_id at least makes the zone consistent from export to export, + # otherwise the records could (theoretically) be returned in any old order by + # the DB engine + # ordering by nominal parent-child label hierarchy (as actually found live + # in some AXFRed zone files) would take a lot of chewing on data + $recsth = $dnsdb->{dbh}->prepare( + "SELECT host,type,val,distance,weight,port,ttl,record_id,location,extract(epoch from stamp),expires,stampactive ". + "FROM records WHERE domain_id=? AND NOT type=6 ". + "ORDER BY masklen(inetlazy(val)) DESC, inetlazy(val), record_id"); +# "FROM records WHERE domain_id=? AND type < 65280"); # Just exclude all types relating to rDNS + + # Fetch active zone list + my $domsth = $dnsdb->{dbh}->prepare("SELECT domain_id,domain,status,changed,default_location FROM domains WHERE status=1 ". + "ORDER BY domain_id"); + # Unflag changed zones, so we can maybe cache the export and not redo everything every time + $zonesth = $dnsdb->{dbh}->prepare("UPDATE domains SET changed='n' WHERE domain_id=?"); + + # Clear %reclfags, since we explicitly want to NOT carry "I've published this + # record" over from rDNS, since we have to regenerate any templates for forward + # zones. downside: small mismatches due to overridden entries. not sure how + # best to manage that. :/ +##fixme: selectively delete entries to allow template_always_publish_a to flag +# whether extra A records get published or not. should default to not (nb, of +# *course* that's the complex case) to match original tinydns template masking behaviour +# %recflags = (); + + $domsth->execute(); + while (my ($domid,$domain,$domstat,$changed) = $domsth->fetchrow_array) { + + # fetch a list of views/locations present in the zone. we need to publish a file for each one. + # in the event that no locations are present (~~ $viewlist is empty), /%view collapses to nothing in the zone path + my $tmplocs = $dnsdb->{dbh}->selectall_arrayref("SELECT DISTINCT location FROM records WHERE domain_id = ?", undef, $domid); + my @loclist; + foreach my $tloc (@{$tmplocs}) { + push @loclist, ($tloc->[0] eq '' ? 'common' : $tloc->[0]); + } + + my %zonefiles; # zone file handles + + eval { + +##fixme: use tmpfile module for more secure temp files? want the zone name at least in it anyway, not sure that works... + my $zfile = $domain; # can probably drop this intermediate + my $tmpcache = "tmp.$zfile.$$"; # safety net. don't overwrite a previous known-good file + + foreach my $loc (@loclist) { + my $zfilepath = $dnsdb->{bind_export_zone_path}; + $zfilepath =~ s/\%view/$loc/; + $zfilepath =~ s/\%zone/$zfile/; + + # Just In Case(TM) + $zfilepath =~ s,[^\w./-],_,g; + + # safety check, may need tweaking for race conditions + my $zpathbase = $zfilepath; + $zpathbase =~ s{/[^/]+$}{}; + if (!-e $zpathbase) { + mkdir $zpathbase; + } else { + die "$zpathbase is not a directory\n" unless -d $zpathbase; + } + + # write fresh records if: + # - the zone contains ALIAS pseudorecords, which need to cascade changes from the upstream CNAME farm at every opportunity + if ( ($dnsdb->{dbh}->selectrow_array("SELECT count(*) FROM records WHERE domain_id = ? AND type=65300", undef, $domid))[0] ) { + $changed = 1; # abuse this flag for zones with ALIAS records + # also update the serial number, because while it shouldn't matter purely for serving + # records, it WILL matter if AXFR becomes part of the publishing infrastructure + $dnsdb->_updateserial(domain_id => $domid); + } + # - the zone contains records which expire in less than 10 minutes or became valid less than 10 minutes ago + # note, no need to multi-bump the serial + elsif ( ($dnsdb->{dbh}->selectrow_array("SELECT COUNT(*) FROM records WHERE domain_id = ? AND ". + "stampactive='t' AND @(extract(epoch from stamp-now())) < 600", undef, $domid))[0] ) { + $changed = 1; + $dnsdb->_updateserial(domain_id => $domid); + } +# - we are not using the cache +# if ($dnsdb->{usecache} + # - force_refresh is set + # - the zone has changed + # - the zone file does not exist + # - the zone file is empty +# if (!$self->{usecache} || $self->{force_refresh} || $changed || !-e $cachefile || -z $cachefile) { + if ($dnsdb->{force_refresh} || $changed || !-e $zfilepath || -z $zfilepath) { +# if ($self->{usecache}) { +# open ZONECACHE, ">$tmpcache" or die "Error creating temporary file $tmpcache: $!\n"; +# $zonefilehandle = *ZONECACHE; +# } + open $zonefiles{$loc}, ">", $zfilepath or die "Error creating temporary file $zfilepath: $!\n"; + + # Header for human convenience + printf {$zonefiles{$loc}} "; %s in view %s exported %s\n", $domain, $loc, scalar(localtime) + or die "Error writing header [$domain, '$loc']: $!\n"; + + # Fetch the SOA separately as we publish it separately for each location with this loop, + # mainly because we want it first in the zone file + $soasth->execute($domid); + my ($soa_host, $soa_val, $soa_ttl, $soa_id, $soa_loc) = $soasth->fetchrow_array; + +##fixme: do we even need @loclist passed in? + printrec_bind($dnsdb, \%zonefiles, \@loclist, $soa_id, 'n', \%recflags, $domain, + $soa_host, 6, $soa_val, 0, 0, 0, $soa_ttl, $loc, ''); + + } # if force_refresh etc + + # tag the zonefile for publication in the view + push @{$viewzones{$loc}}, $domain; + + } # foreach @loclist + + # now the meat of the records + $recsth->execute($domid); + while (my ($host,$type,$val,$dist,$weight,$port,$ttl,$recid,$loc,$stamp,$expires,$stampactive) = $recsth->fetchrow_array) { +##work need more subtle check - $recflags{$val} eq 'ptr' maybe? + next if $recflags{$recid}; +#next if $recflags{$val} && $type == 65280;# && !$dnsdb->{template_always_publish_a}; + + # 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+$//; + } + + # Check for out-of-zone data + $host = $domain if $host eq '@'; + if ($domain !~ /\.rpz$/ && $host !~ /$domain$/i) { + warn "Not exporting out-of-zone record $host $type $val, $ttl (zone $domain)\n"; + next; + } + + printrec_bind($dnsdb, \%zonefiles, \@loclist, $recid, 'n', \%recflags, $domain, + $host, $type, $val, $dist, $weight, $port, $ttl, $loc, $stamp, $expires, $stampactive); + + $recflags{$recid} = 1; + + } # while ($recsth) + + # retrieve NS records for subdomains. not strictly required in current production + # context but may matter sometime down the road + my $subnssth = $dnsdb->{dbh}->prepare("SELECT r.host,r.val,r.ttl,r.record_id,r.loc,r.stamp,r.expires,r.stampactive ". + "FROM records r ". + "JOIN domains d ON r.domain_id=d.domain_id ". + "WHERE r.type=2 AND d.domain LIKE ?"); + $subnssth->execute('%.'.$domain); + while (my ($host,$val,$ttl,$recid,$loc,$stamp,$expires,$stampactive) = $subnssth->fetchrow_array) { + printrec_bind($dnsdb, \%zonefiles, \@loclist, $recid, 'n', \%recflags, $domain, + $host, 2, $val, '', '', '', $ttl, $loc, $stamp, $expires, $stampactive); + } # subdomain-ns-recsth + + +# if ($self->{usecache}) { +# 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 ($@) { + die "error writing ".($dnsdb->{usecache} ? 'new data for ' : '')."$domain: $@\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($domid); + } + +# if ($dnsdb->{usecache}) { +# # We've already made as sure as we can that a cached zone file is "good", +# # although possibly stale/obsolete due to errors creating a new one. +# eval { +# open CACHE, "<$cachefile" or die $!; +# print $datafile $_ or die "error copying cached $revzone to master file: $!" while ; +# close CACHE; +# }; +# die $@ if $@; +# } + + } # domsth->fetch + + + + # Write the view configuration last, because otherwise we have to be horribly inefficient + # at figuring out which zones are visible/present in which views + if ($viewlist) { + my $tmpconf = "$dnsdb->{bind_export_conf_path}.$$"; ##fixme: split filename for prefixing + open BINDCONF, ">", $tmpconf; + + foreach my $view (@{$viewlist}, { location => 'common', iplist => '' }) { +#print Dumper($view); + print BINDCONF "view $view->{location} {\n"; +# print "view $view->{location} {\n"; + # could also use an acl { ... }; statement, then match-clients { aclname; };, but that gets hairy + # note that some semantics of data visibility need to be handled by the record export, since it's + # not 100% clear if the semantics of a tinydns view with an empty IP list (matches anyone) are the + # same as a BIND view with match-clients { any; }; + if ($view->{iplist}) { + print BINDCONF " match-clients { ".join("; ", $view->{iplist})."; };\n"; +# print " match-clients { ".join("; ", split(/[\s,]+/, $view->{iplist}))."; };\n"; + } else { + print BINDCONF " match-clients { any; };\n"; +# print " match-clients { any; };\n"; + } + foreach my $zone (@{$viewzones{$view->{location}}}) { +##fixme: notify settings, maybe per-zone? + print BINDCONF qq( zone "$zone" IN {\n\ttype master;\n\tnotify no;\n\tfile "db.$zone";\n };\n); +# print qq( zone "$zone" IN {\n\ttype master;\n\tnotify no;\n\tfile "db.$zone";\n };\n); + } + print BINDCONF "};\n\n"; +# print "};\n\n"; + } # foreach @$viewlist + rename $tmpconf, $dnsdb->{bind_export_conf_path}; + } # if $viewlist + +} # export() + + +# Print individual records in BIND format +sub printrec_bind { + my $dnsdb = shift; + +# my ($zonefiles, $recid, $revrec, $loclist, $zone, $host, $type, $val, $distance, $weight, $port, $ttl, + my ($zonefiles, $loclist, $recid, $revrec, $recflags, $zone, $host, $type, $val, $distance, $weight, $port, $ttl, + $loc, $stamp, $expires, $stampactive) = @_; + + # Just In Case something is lingering in the DB + $loc = '' if !$loc; + + ## Records that are valid only before or after a set time + # Note that BIND-style zone files fundamentally don't support this directly + # unlike tinydns, as it's not a native feature/function. Dropping TTLs to + # 15s or so is the best we can do for expiry. "Valid-after" is only as good + # as the export cron job timing. + if ($stampactive) { + my $now = time(); + if ($expires) { + # record expires at $stamp; decide if we need to keep the TTL on file + # or set it to 15 so the record falls out of caches quickly sometime + # around the nominal expiry time. + + # For weirdos who set huge TTLs, cap the TTL at one day. 30+ years ago + # long TTLs made sense when even DNS had a measurable cost in small + # networks; today DNS is below the noise floor in all but the largest + # networks and systems. + my $ahead = (86400 < $ttl*2 ? 86400 : $ttl*2); + if (($now + $ahead) < $stamp) { + # more than 2x TTL OR more than one day (whichever is less) from expiry time; publish normal record + } elsif ($now > $stamp) { + # record has expired; return early as we don't need to publish anything + return; + } else { + # less than 2x TTL from expiry time, set a short TTL + $ttl = $dnsdb->{bind_export_autoexpire_ttl}; + } + } else { + # record is "active after"; return unless it's now after the nominal validity timestamp. + return unless $now >= $stamp; + } + } # if $stampactive + + ## And now to the records! + + if ($typemap{$type} eq 'SOA') { + # host contains pri-ns:responsible + # val is abused to contain refresh:retry:expire:minttl + # 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]; + my $serial = 0; # fail less horribly than leaving it empty? + # just snarfing the right SOA serial for the zone type + if ($revrec eq 'y') { + ($serial) = $dnsdb->{dbh}->selectrow_array("SELECT zserial FROM revzones WHERE revnet=?", undef, $zone); + } else { + ($serial) = $dnsdb->{dbh}->selectrow_array("SELECT zserial FROM domains WHERE domain=?", undef, $zone); + } # revrec <> 'y' + # suppress a "uninitialized value" warning. should be impossible but... + # abuse hours as the last digit pair of the serial for simplicity +##fixme?: alternate SOA serial schemes? + $serial = strftime("%Y%m%d%H", localtime()) if !$serial; + $primary .= "." if $primary !~ /\.$/; + $email .= "." if $email !~ /\.$/; +# print *{$zonefiles->{$loc}} "Z$zone:$primary:$email:$serial:$refresh:$retry:$expire:$min_ttl:$ttl:$stamp:$loc\n" +# or die $!; +# print *{$zonefiles->{$loc}} "$zone $ttl IN SOA $primary $email ( $serial $refresh $retry $expire $min_ttl )\n" +# or die "couldn't write $zone SOA: $!"; + + # Prepare the body of the record + my $recdata = "$ttl IN SOA $primary $email ( $serial $refresh $retry $expire $min_ttl )\n"; + + # ... and prepend the zone name FQDN + if ($revrec eq 'y') { + my $zone2 = DNSDB::_ZONE($zone, 'ZONE', 'r', '.').($zone->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'); + $recdata = "$zone2. $recdata"; + } else { + $recdata = "$zone. $recdata"; + } + + __recprint($zonefiles, $loclist, $loc, $recdata); + } # SOA + + elsif ($typemap{$type} eq 'A') { + ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; +# print $datafile "+$host:$val:$ttl:$stamp:$loc\n" or die $!; +# print {$zonefiles->{$loc}} "$host $ttl IN A $val\n" or die $!; + my $recdata = "$host. $ttl IN A $val\n"; + __recprint($zonefiles, $loclist, $loc, $recdata); + } # A + + elsif ($typemap{$type} eq 'NS') { + if ($revrec eq 'y') { + $val = NetAddr::IP->new($val); + +##fixme: conversion for sub-/24 delegations in reverse zones? +# if (!$val->{isv6} && ($val->masklen > 24)) { +# } + + my $val2 = DNSDB::_ZONE($val, 'ZONE', 'r', '.').($val->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'); + $host .= "." if $host !~ /\.$/; + my $recdata = "$val2. $ttl IN NS $host\n"; + __recprint($zonefiles, $loclist, $loc, $recdata); + + } else { + my $recdata = "$host. $ttl IN NS $val.\n"; + __recprint($zonefiles, $loclist, $loc, $recdata); + } + } # NS + + elsif ($typemap{$type} eq 'AAAA') { +# ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; +# print {$zonefiles->{$loc}} "$host $ttl IN AAAA $val\n" or die $!; + my $recdata = "$host. $ttl IN AAAA $val\n"; + __recprint($zonefiles, $loclist, $loc, $recdata); + } # AAAA + + elsif ($typemap{$type} eq 'MX') { +# ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; +# print {$zonefiles->{$loc}} "$host $ttl IN MX $distance $val\n" or die $!; +# should arguably swap host and val first, but MX records really don't make any sense in reverse zones, so any silliness that results from finding one doesn't much matter. + my $recdata = "$host. $ttl IN MX $distance $val.\n"; + __recprint($zonefiles, $loclist, $loc, $recdata); + } # MX + + elsif ($typemap{$type} eq 'TXT') { +# ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; +# print {$zonefiles->{$loc}} "$host $ttl IN TXT \"$val\"\n" or die $!; + # Clean up some lingering tinydns/VegaDNSisms + DNSDB::_deoctal(\$val); + my $recdata = "$host. $ttl IN TXT \"$val\"\n"; + __recprint($zonefiles, $loclist, $loc, $recdata); + } # TXT + + elsif ($typemap{$type} eq 'CNAME') { +# ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; +# print {$zonefiles->{$loc}} "$host $ttl IN CNAME $val\n" or die $!; + my $recdata; + if ($zone =~ /\.rpz$/) { + # RPZ data stored and published as-is + $recdata = "$host $ttl IN CNAME $val\n"; + } else { + $recdata = "$host. $ttl IN CNAME $val.\n"; + } + __recprint($zonefiles, $loclist, $loc, $recdata); + } # CNAME + + elsif ($typemap{$type} eq 'SRV') { +# ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; +# print {$zonefiles->{$loc}} "$host $ttl IN SRV $distance $weight $port $val\n" or die $!; + my $recdata = "$host. $ttl IN SRV $distance $weight $port $val.\n"; + __recprint($zonefiles, $loclist, $loc, $recdata); + } # SRV + + elsif ($typemap{$type} eq 'RP') { +# ($host,$val) = __revswap($host,$val) if $revrec eq 'y'; +# print {$zonefiles->{$loc}} "$host $ttl IN RP $val\n" or die $!; + my $recdata = "$host. $ttl IN RP $val\n"; + __recprint($zonefiles, $loclist, $loc, $recdata); + } # RP + + elsif ($typemap{$type} eq 'PTR') { +# $$recflags{$val}++; + # maybe track exclusions like this? so we can publish "all + # A and/or PTR records" irrespective of template records + $$recflags{$val} = 'ptr'; + return if $host eq '%blank%'; + + if ($revrec eq 'y') { + + if ($val =~ /\.arpa$/) { + # someone put in the formal .arpa name. humor them. + my $recdata = "$val. $ttl IN PTR $host.\n"; + __recprint($zonefiles, $loclist, $loc, $recdata); + } else { + $zone = NetAddr::IP->new($zone); + if (!$zone->{isv6} && $zone->masklen > 24) { + # sub-octet v4 zone + ($val) = ($val =~ /\.(\d+)$/); + my $recdata = "$val.".DNSDB::_ZONE($zone, 'ZONE', 'r', '.').".in-addr.arpa. $ttl IN PTR $host.\n"; + __recprint($zonefiles, $loclist, $loc, $recdata); + } else { + # not going to care about strange results if $val is not an IP value and is resolveable in DNS + $val = NetAddr::IP->new($val); + my $recdata = DNSDB::_ZONE($val, 'ZONE', 'r', '.').($val->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'). + ". $ttl IN PTR $host.\n"; + __recprint($zonefiles, $loclist, $loc, $recdata); + } + } # non-".arpa" $val + + } else { + # PTRs in forward zones are less bizarre and insane than some other record types + # in reverse zones... OTOH we can't validate them any which way, so we cross our + # fingers and close our eyes and make it Someone Else's Problem. +# print {$zonefiles->{$loc}} "$host $ttl IN PTR $val\n" or die $!; + my $recdata = "$host. $ttl IN PTR $val.\n"; + __recprint($zonefiles, $loclist, $loc, $recdata); + } + } # PTR + + elsif ($type == 65280) { # A+PTR + # Recurse to PTR or A as appropriate because BIND et al don't share + # the tinydns concept of merged forward/reverse records +# %recflags gets updated in the PTR branch just above +# $$recflags{$val}++; + if ($revrec eq 'y') { + printrec_bind($dnsdb, $zonefiles, $loclist, $recid, $revrec, $recflags, $zone, $host, 12, $val, + $distance, $weight, $port, $ttl, $loc, $stamp, $expires, $stampactive); +# ... but we need to tweak it for this case? so the A record gets published... +#$$recflags{$val} = 'a+ptr'; +#print {$zonefiles->{$loc}} "=$host:$val:$ttl:$stamp:$loc\n" or die $!; +# printrec_bind($dnsdb, \%zonefiles, $recid, 'y', \@loclist, $revzone, +# $host, $type, $val, $dist, $weight, $port, $ttl, $loc, $stamp, $expires, $stampactive); +# my ($zonefiles, $recid, $revrec, $loclist, $zone, $host, $type, $val, $distance, $weight, $port, $ttl, +# $loc, $stamp, $expires, $stampactive) = @_; + } else { + printrec_bind($dnsdb, $zonefiles, $loclist, $recid, $revrec, $recflags, $zone, $host, 1, $val, + $distance, $weight, $port, $ttl, $loc, $stamp, $expires, $stampactive); + # set a unique flag to skip template expansion for this IP in forward zones + $$recflags{$val} = 'a'; + } + } # A+PTR + + 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_template_bind($dnsdb, $sub, $recflags, $host, $zonefiles, $loclist, $ttl, $stamp, $loc, $zone, $revrec); + } + } else { + __publish_template_bind($dnsdb, $val, $recflags, $host, $zonefiles, $loclist, $ttl, $stamp, $loc, $zone, $revrec); + } + } # PTR template + + 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_template_bind($dnsdb, $sub, $recflags, $host, $zonefiles, $loclist, $ttl, $stamp, $loc, $zone, $revrec); + } + } else { + __publish_template_bind($dnsdb, $val, $recflags, $host, $zonefiles, $loclist, $ttl, $stamp, $loc, $zone, $revrec); + } + } # A+PTR template + + 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/ ) + } # AAAA+PTR template + + elsif ($type == 65300) { # ALIAS + # Implemented as a unique record in parallel with many other + # management tools, for clarity VS formal behviour around CNAME + # Mainly for "root CNAME" or "apex alias"; limited value for any + # other use case since CNAME can generally be used elsewhere. + + # .arpa zones don't need this hack. shouldn't be allowed into + # the DB in the first place, but Just In Case... + return if $revrec eq 'y'; + + my ($iplist) = $dnsdb->{dbh}->selectrow_array("SELECT auxdata FROM records WHERE record_id = ?", undef, $recid); + $iplist = '' if !$iplist; + + # shared target-name-to-IP converter + my $liveips = $dnsdb->_grab_65300($recid, $val); + # only update the cache if the live lookup actually returned data + if ($liveips && ($iplist ne $liveips)) { + $dnsdb->{dbh}->do("UPDATE records SET auxdata = ? WHERE record_id = ?", undef, $liveips, $recid); + $iplist = $liveips; + } + + # slice the TTL we'll actually publish off the front + my @asubs = split ';', $iplist; + my $attl = shift @asubs; + + # output a plain old A or AAAA record for each IP the target name really points to. + # in the event that, for whatever reason, no A/AAAA records are available for $val, nothing will be output. + foreach my $subip (@asubs) { + my $recdata; + if ($subip =~ /\d+\.\d+\.\d+\.\d+/) { + $recdata = "$host. $attl IN A $subip\n"; + } else { + $recdata = "$host. $attl IN AAAA $subip\n"; + } + __recprint($zonefiles, $loclist, $loc, $recdata); + } + + } # ALIAS + + +} # printrec_bind() + + +sub __publish_template_bind { + my $dnsdb = shift; + my $sub = shift; + my $recflags = shift; + my $hpat = shift; + my $zonefiles = shift; + my $loclist = shift; + my $ttl = shift; + my $stamp = shift; + my $loc = shift; + my $zpass = shift; + my $zone = new NetAddr::IP $zpass; +# my $zone = new NetAddr::IP shift; + my $revrec = shift || 'y'; +# my $ptrflag = shift || 0; ##fixme: default to PTR instead of A record for the BIND variant of this sub? + + # do this conversion once, not (number-of-ips-in-subnet) times + my $arpabase = DNSDB::_ZONE($zone, 'ZONE.in-addr.arpa.', 'r', '.'); + + my $iplist = $sub->splitref(32); + my $ipindex = -1; + foreach (@$iplist) { + my $ip = $_->addr; + $ipindex++; + # make as if we split the non-octet-aligned block into octet-aligned blocks as with SOA + my $lastoct = (split /\./, $ip)[3]; + + # Allow smaller entries to override longer ones, eg, a specific PTR will + # always publish, overriding any template record containing that IP. + # %blank% also needs to be per-IP here to properly cascade overrides with + # multiple nested templates +# next if $$recflags{$ip}; # && $self->{skip_bcast_255} + +# next if $$recflags{$ip} && ($$recflags{$ip} eq 'ptr' || $$recflags{$ip} eq 'a+ptr'); + + if ($revrec eq 'y') { + next if $$recflags{$ip}; # blanket exclusion; we do reverse records first + } else { +##fixme: A record side templates not cascading correctly + # excluding ptr does NOT work, as it excludes ALL previously covered A+PTR template entries. + # we only want to exclude the singleton (A+)PTR ones + #if ($$recflags{$ip} && ($$recflags{$ip} eq 'a' || $$recflags{$ip} eq 'ptr')) { + if ($$recflags{$ip} && ($$recflags{$ip} eq 'a' || $$recflags{$ip} eq 'atemplate' || $$recflags{$ip} eq 'ptr')) { + # default skip case + next; + } + } # revrec branch for skipping template member expansion + + # set a forward/reverse-unique flag in %recflags + $$recflags{$ip} = ($revrec eq 'y' ? 'ptrtemplate' : 'atemplate'); + next if $hpat eq '%blank%'; + + my $rec = $hpat; # start fresh with the template for each IP +##fixme: there really isn't a good way to handle sub-/24 zones here. This way at least +# seems less bad than some alternatives. + $dnsdb->_template4_expand(\$rec, $ip, \$sub, $ipindex); + # _template4_expand may blank $rec; if so, don't publish a record + next if !$rec; +##fixme: trim merged record type voodoo. "if ($ptrflag) {} else {}" ? +# if ($ptrflag || $zone->masklen > 24) { + my $recdata; + if ($revrec eq 'y') { +# || $zone->masklen > 24) { +# print $fh "^$lastoct.$arpabase:$rec:$ttl:$stamp:$loc\n" or die $!; +##fixme: use $ORIGIN instead? make the FQDN output switchable-optional? +# print $fh "$lastoct.$arpabase $ttl IN PTR $rec\n" or die $!; +# if ($revrec ne 'y') { + # print a separate A record. Arguably we could use an = record here instead. +# print $fh "+$rec:$ip:$ttl:$stamp:$loc\n" or die $!; +# print $fh "$rec $ttl IN A $ip\n" or die $!; +# } + if ($dnsdb->{bind_export_fqdn}) { + $recdata = "$lastoct.$arpabase $ttl IN PTR $rec.\n"; + } else { + $recdata = "$lastoct $ttl IN PTR $rec.\n"; + } + + } else { + # A record, not merged +# print $fh "=$rec:$ip:$ttl:$stamp:$loc\n" or die $!; +# print $fh "$rec $ttl IN A $ip\n" or die $!; + $rec =~ s/\.$zone$// unless $dnsdb->{bind_export_fqdn}; + $recdata = "$rec. $ttl IN A $ip\n"; + } + # and finally + __recprint($zonefiles, $loclist, $loc, $recdata); + } # foreach (@iplist) +} # __publish_template_bind() + + +# actual record printing sub +# loop on the locations here so we don't end up with a huge pot of copypasta +sub __recprint { + my ($zonefiles, $loclist, $loc, $recdata) = @_; + if ($loc eq '') { + # "common" record visible in all locations + foreach my $rloc (@{$loclist}) { + print {$zonefiles->{$rloc}} $recdata or die $!; + } + } else { + # record with specific location tagged + print {$zonefiles->{$loc}} $recdata or die $!; + } +} + +1; Index: branches/cname-collision/INSTALL =================================================================== --- branches/cname-collision/INSTALL (revision 936) +++ branches/cname-collision/INSTALL (revision 936) @@ -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: branches/cname-collision/TODO =================================================================== --- branches/cname-collision/TODO (revision 936) +++ branches/cname-collision/TODO (revision 936) @@ -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: branches/cname-collision/UPGRADE =================================================================== --- branches/cname-collision/UPGRADE (revision 936) +++ branches/cname-collision/UPGRADE (revision 936) @@ -0,0 +1,39 @@ +$Id$ + +DeepNet DNS Administrator - Upgrade Notes +========================================= + +1.2.3 -> 1.2.4 + - A small function was added to allow errorless handling of non-IP values + where IP values would normally be expected. For Postgres 8.2 and older, + you will need to connect to the database as a Postgres superuser to run: + + dnsdb=# CREATE LANGUAGE plpgsql; + + so you can run: + + $ psql -U dnsdb dnsdb -h localhost < dns-1.2.3-1.2.4.sql + + as the regular user. Postgresl 8.4 is soon to go EOL, so this should + not be a big issue. + + The changes are backwards-compatible so if you need to roll back the + code for some reason you do not need to revert the database changes. + +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 Getopt::Long; + +use Data::Dumper; + +##fixme +use lib '.'; +use DNSDB; + +my $dnsdb = new DNSDB; + +my $dryrun = 0; + +#print Dumper(\%reverse_typemap); + +local $dnsdb->{dbh}->{AutoCommit} = 0; +local $dnsdb->{dbh}->{RaiseError} = 1; + +# from tiny-import: arguably can't use -r, -c is irrelevant. others useful? + # -r rewrite imported files to comment imported records + # -c coerce/downconvert A+PTR = records to PTR + # -l swallow A+PTR as-is + # -m merge PTR and A/AAAA as possible + # -t trial mode; don't commit to DB or actually rewrite flatfile (disables -r) + # -g import to specified group (name or ID) instead of group 1 + +##fixme: command arguments/flags to set these to alternate values +my $group = 1; +my $status = 1; +my $location = ''; +# we'll update this with the actual serial number from the SOA record later +my $serial = time(); + +my @skipdefs; +my $skipfile; + +GetOptions( + "skip=s" => \@skipdefs, + "skipfile=s" => \$skipfile, + "test|dry-run" => \$dryrun, +); + +my $usage = "usage: bind-import [--skip pattern [--skip pattern2 ...]] [--skipfile file] + zonename [zonefile] + --skip + Specify a string to skip in the records. If an IP-like string is + used, and the zone is a reverse zone, it will also search for the + octet-reversed form. Specify multiple times to skip multiple + different record patterns. + --skipfile + A file containing patterns to skip. Patterns from the file and + any --skip arguments are merged. + --dry-run + Do everything except finalize the import + zonename + The name of the zone to import. Required. + zonefile + Specify the zone file as an argument. If not specified, the zone + data will be read from STDIN. +"; + +my $zname = shift @ARGV; +my $origzone = $zname; +die $usage if !$zname; + +my $zonefile = shift @ARGV; +if(!$zonefile) { + $zonefile = '&STDIN'; +} + +my $rev = 'n'; +my $zid; +my %foundtypes; + +if ($skipfile) { + if (-f $skipfile) { + open SKIP, "<$skipfile"; + while () { + chomp; + push @skipdefs, $_; + } + close SKIP; + } else { + warn "skipfile $skipfile requested but it doesn't seem to exist. Continuing.\n"; + } +} + +#sub setreplace { +## print "dbg1: $_[0]\ndbg2: $_[1]\n"; +##($_[1] eq '' ? $replace = 1 : $replace = $_[1]); +# if ($_[1] eq '') { +# print "no arg value, setting 1\n"; +# $replace = 1; +# } else { +# print "arg value $_[1]\n"; +# $replace = $_[1]; +# } +#} + + +my %amap; +my %namemap; +my %cmap; + +# wrap all the DB stuff in eval{}, so the entire thing either succeeds or fails. + +eval { + + local $dnsdb->{dbh}->{AutoCommit} = 0; + local $dnsdb->{dbh}->{RaiseError} = 1; + +##fixme: this is wrong, BIND zone files are generally complete and we're adding. merging records is an entire fridge full of worms. +##fixme: for import, should arguably check for zone *non*existence + + if ($zname =~ /\.arpa\.?$/ || $zname =~ m,^[\d./]+$,) { + $rev = 'y'; + $zname = _zone2cidr($zname) if $zname =~ /\.arpa\.?$/; + $zid = $dnsdb->revID($zname,':ANY:'); + if ($zid) { + die "zone $origzone already present, not merging records\n"; +#print "dbg: skip add revzone\n"; +# $zname = new NetAddr::IP $zname; +# $zname = DNSDB::_ZONE($zname, 'ZONE', 'r', '.').($zname->{isv6} ? '.ip6.arpa' : '.in-addr.arpa'); + } + ($zid) = $dnsdb->{dbh}->selectrow_array("INSERT INTO revzones (revnet,group_id,status,default_location,zserial) VALUES (?,?,?,?,?) RETURNING rnds_id", + undef, ($zname, $group, $status, $location, $serial)); + + } else { + $zid = $dnsdb->domainID($zname,':ANY:'); + if ($zid) { +# die "zone $origzone already present, not merging records\n"; +#print "dbg: skip add domain\n"; + } +# ($zid) = $dnsdb->{dbh}->selectrow_array("INSERT INTO domains (domain,group_id,status,default_location,zserial) VALUES (?,?,?,?,?) RETURNING domain_id", +# undef, ($zname, $group, $status, $location, $serial)); + + } + + die "error creating zone stub for $zname: ".$dnsdb->{dbh}->errstr if !$zid; + + +##fixme: should probably make this a named argument so it doesn't get confused with the zone filename + # still no sane way to expose a human-friendly view tag on the command line. + my $view = shift @ARGV; + $view = '' if !$view; + + ##fixme: retrieve defttl from SOA record + my $zonettl = 900; + my $defttl = $zonettl; + my $origin = "$zname."; # to append to unqualified names + + # need to spin up a full state machine-ish thing, because BIND zone files are all about context + # see ch4, p56-72 in the grasshopper book + my $prevlabel = ''; + my $curlabel = ''; + + my $i = 0; + + open ZONEDATA, "<$zonefile"; + + while (my $rec = ) { + chomp $rec; + next if $rec =~ /^\s*$/; + next if $rec =~ /^\s*;/; # comments + next if $rec =~ /^\s*\)/; # SOA closing (possibly other records too?) + # arguably should do some more targeted voodoo when parsing the SOA details + + # check skiplist. do this early since it's (mostly) a simple string match against the raw record line + my $skipflag = 0; + foreach (@skipdefs) { + if ($rec =~ /\Q$_\E/) { + $skipflag = 1; + # might want to do something with the skipped records someday + } + } + next if $skipflag; + + +$i++; +#last if $i > 17; +#print "line $i: ($rec)\n"; + if (my ($macro,$mdetail) = ($rec =~ /^\s*\$(TTL|ORIGIN|INCLUDE|GENERATE)\s+(.+)/) ) { + # macro sort of thing; $TTL and $ORIGIN most common. $INCLUDE is a thing, expect it to be rare in live use tho + if ($macro eq 'TTL') { + $mdetail =~ s/\s*;.+$//; + if ($mdetail =~ /^\d+$/) { + $defttl = $mdetail; + } else { + warn "invalid \$TTL: $rec\n"; + } + } elsif ($macro eq 'ORIGIN') { + # $ORIGIN supports cascading/nesting, by watching for fully-qualified names vs partial names. + if ($mdetail =~ /\.$/) { + $origin = $mdetail; + } else { + # append current origin to unqualified origin + $origin = "$mdetail.$origin"; + } + } + elsif ($macro eq 'GENERATE') { +# needs to generate CIDR range(s) as needed to match the start/stop points + } +##fixme: should arguably handle $INCLUDE + next; + } + + my $origrec = $rec; + + # leading whitespace indicates "same label as last record" + if ($rec =~ /^\s/) { + $curlabel = $prevlabel; +#print " found empty label, using previous label\n"; + } else { + ($curlabel) = ($rec =~ /^([\w\@_.-]+)\s/); + } + + # yay for special cases + $origin = '' if $origin eq '.'; + + # leading whitespace indicates "same label as last record" + if ($rec =~ /^\s/) { + $curlabel = $prevlabel; + } else { + ($curlabel) = ($rec =~ /^([\w\@_.-]+)\s/); + } + + # magic name! + $curlabel = "$zname." if $curlabel eq '@'; + + # append $ORIGIN if name is not fully qualified. + if ($curlabel !~ /\.$/) { + $curlabel .= ".$origin"; + } + + # check for zone scope. skip bad records. + if ($curlabel !~ /$zname.$/) { + warn "bad record $origrec, maybe bad \$ORIGIN?\n"; +# bweh? maybe this should die()? +last; + next; + } + + # trim the label, if any + $rec =~ s/^([\w\@_.-]*)\s+//; + + # now that we've collected and trimmed off the record's label, unpack the class, TTL, and type. + # class and TTL may be omitted, and may appear in either class,TTL or TTL,class order. + my $nc = 0; + # we don't actually use these but we have to recognize them + my $class = 'IN'; + # not preset as we need to detect whether it's present in the record + my $ttl; + my $type; + my $badrec; + my $curatom = 'class'; + eval { + for (; $nc < 3; $nc++) { + last if $type; # short-circuit if we've got a type, further data is record-specific. + my ($atom) = ($rec =~ /^([\w\d.]+)\s/); + # should be safe? + last if !$atom; + if ($atom =~ /^\d+$/) { + if (defined($ttl)) { + # we already have a TTL, so another all-numeric field is invalid. + die "bad record ($origrec)\n"; + } else { + if ($curatom ne 'class' && $curatom ne 'ttl') { + die "bad record ($origrec)\n"; + } + $curatom = 'ttl'; + $ttl = $atom; + } + } + elsif ($atom =~ /^IN|CS|CH|HS$/) { + if ($atom =~ /CS|CH|HS/) { + die "unsupported class $atom in record ($origrec)\n"; + } + $curatom = 'class'; + $class = $atom; + } + elsif ($atom =~ /^[A-Z\d-]+/) { + # check against dnsadmin's internal list of known DNS types. + if ($reverse_typemap{$atom}) { + $type = $atom; + } else { + die "unknown type $atom in record ($origrec)\n"; + } + $curatom = 'type'; + } + $rec =~ s/^$atom\s*//; + } + }; # record class/type/TTL loop + if ($@) { + warn $@; + next; + } + +##todo: BIND conflates a repeated label with repeating the TTL too. Matter of opinion whether that's really correct or not. + # set default TTL here so we can detect a TTL in the loop above + $ttl = $defttl if !defined($ttl); + +#next if $badrec; + + + # Just In Case we need the original rdata after we've sliced off more pieces + my $rdata = $rec; + $prevlabel = $curlabel; + + # part of the record data, when present + my $distance; + my $weight; + my $port; + + my $itype = $reverse_typemap{$type}; + + +# See RFC1035 and successors for the canonical zone file format reference. We'll +# ignore a number of edge cases because they're quite horrible to parse. +# Of particular note is use of () to continue entries across multiple lines. Use +# outside of SOA records is quite rare, although some compliant zone file +# *writers* may use it on TXT records. +# We'll also ignore the strict interpretation in SOA records in favour of spotting +# the more standard pattern where the SOA serial, refresh, retry, expire, and minttl +# numbers are in (): + +#example.invalid IN SOA test.example.invalid. test.example.invalid. ( +# 2020082500 ; serial +# 7200 ; refresh (2 hours) +# 900 ; retry (15 minutes) +# 604800 ; expire (1 week) +# 3600 ; minimum (1 hour) +# ) + + $foundtypes{$type}++; + +##fixme: strip trailing . here? dnsadmin's normalized internal format omits it, some validation fails or may go funky + + if ($type eq 'SOA') { + my ($ns, $adminmail) = ($rdata =~ /([\w.]+)\s+([\w.]+)\s+\(/); + die "Can't parse gibberish SOAish record: $rec\n" if !$ns; + $rdata =~ s/([\w.]+)\s+([\w.]+)\s+\(\s*//; + + # Parse fields from $rdata if present + my @soabits; + my @soafirst = split /\s+/, $rdata; + while (my $f = shift @soafirst) { + last if $f !~ /^\d/; + push @soabits, $f; + } + + # Read more lines if we don't have enough SOA fields filled + while (scalar(@soabits) < 5) { + my $tmp = ; + $tmp =~ s/^\s*//; + my @tmpsoa = split /\s+/, $tmp; + while (my $f = shift @tmpsoa) { + last if $f !~ /^\d/; + push @soabits, $f; + } + if (scalar(@soabits) == 5) { + last; + } + } + my @soavals = ($zid, "$adminmail:$ns", 6, join(':', @soabits), $ttl, $location); +# host = $adminmail:$ns +# val = join(':', @soabits); + + if ($rev eq 'y') { + $dnsdb->{dbh}->do("UPDATE revzones SET zserial = ? WHERE rdns_id = ?", undef, $soabits[0], $zid); + $dnsdb->{dbh}->do("INSERT INTO records (rdns_id,host,type,val,ttl,location) VALUES (?,?,?,?,?,?)", undef, @soavals); + } else { + $dnsdb->{dbh}->do("UPDATE domains SET zserial = ? WHERE domain_id = ?", undef, $soabits[0], $zid); + $dnsdb->{dbh}->do("INSERT INTO records (domain_id,host,type,val,ttl,location) VALUES (?,?,?,?,?,?)", undef, @soavals); + } + # skip insert at end of loop; SOA records are not handled by DNSDB::addRec() + next; + } # SOA + + + # we're using DNSDB::addrec(), so we'll skip detailed validation of other records. Most won't need further breakdown + + elsif ($type eq 'A') { +#print "+$curlabel:$rdata:$ttl\n"; + } + + elsif ($type eq 'NS') { +#print "\&$curlabel::$rdata:$ttl\n"; + } + + elsif ($type eq 'CNAME') { +#print "C$curlabel:$rdata:$ttl\n"; + } + + elsif ($type eq 'PTR') { + } + + elsif ($type eq 'MX') { + ($distance) = ($rdata =~ /^(\d+)\s+/); + if (!defined($distance)) { + warn "malformed MX record: $origrec, skipping\n"; + next; + } + $rdata =~ s/^\d+\s+//; + } + + elsif ($type eq 'TXT') { + # Quotes may arguably be syntactically required, but they're not actually part of the record data + $rdata =~ s/^"//; + $rdata =~ s/"$//; +#print "'$curlabel:$rdata:$ttl\n"; + } + + elsif ($type eq 'RP') { + } + + elsif ($type eq 'AAAA') { + } + + elsif ($type eq 'SRV') { + ($distance, $weight, $port) = ($rdata =~ /^(\d+)\s+(\d+)\s+(\d+)\s+/); + if ( !defined($distance) || !defined($weight) || !defined($port) ) { + warn "malformed SRV record: $origrec, skipping\n"; + next; + } + $rdata =~ s/^\d+\s+\d+\s+\d+\s+//; + } + + # basically a dedicated clone of TXT, not sure anything actually looks up type SPF. + # BIND autogenerates them from SPF TXT records. + elsif ($type eq 'SPF') { + # Quotes may arguably be syntactically required, but they're not actually part of the record data + $rdata =~ s/^"//; + $rdata =~ s/"$//; + } + +# elsif ($type eq 'TXT') { +# elsif ($type eq 'TXT') { + + else { + warn "unsupported type $type, may not import correctly\n"; + } + +##fixme: need to dig out a subtransaction widget or extract a core of addRec() that doesn't dbh->commit(), so --dry-run works +# unless ($dryrun) { + my ($code, $msg); + +# swap curlabel/rdata for revzones, because our internal metastorage only knows about "host" and "val" +# keep the originals Just In Case(TM) +$curlabel =~ s/\.$//; # dnsadmin doesn't store trailing dots +my $inshost = $curlabel; +my $insval = $rdata; +if ($rev eq 'y') { + $inshost = $rdata; + $insval = $curlabel; +} +print "dbg: maybeip next ($insval)\n"; +my $addr = NetAddr::IP->new($insval) if DNSDB::_maybeip(\$insval); +my $fields; +my @vallist; + +($code,$msg) = $validators{$itype}($dnsdb, defrec => 'n', revrec => $rev, id => $zid, + host => \$inshost, rectype => \$itype, val => \$insval, addr => $addr, + dist => \$distance, port => \$port, weight => \$weight, + fields => \$fields, vallist => \@vallist); + +# Add standard common fields +$fields .= "host,type,val,ttl,".DNSDB::_recparent('n',$rev); +push @vallist, ($inshost,$itype,$insval,$ttl,$zid); + +my $vallen = '?'.(',?'x$#vallist); + +print "INSERT INTO records ($fields) VALUES ($vallen);\n".join("','", @vallist)."\n"; + +# if ($rev eq 'n') { +# ($code,$msg) = $dnsdb->addRec('n', $rev, $zid, \$curlabel, \$itype, \$rdata, $ttl, +# $location, undef, undef, $distance, $weight, $port); +# } else { +# ($code,$msg) = $dnsdb->addRec('y', $rev, $zid, \$rdata, \$itype, \$curlabel, $ttl, +# $location, undef, undef, $distance, $weight, $port); +# } + print "$code: $msg\n" if $code ne 'OK'; +# } +# $i++; + } + + if ($dryrun) { + $dnsdb->{dbh}->rollback; + } else { + $dnsdb->{dbh}->commit; + } +}; +if ($@) { + warn "Error parsing zonefile: $@\n"; + $dnsdb->{dbh}->rollback; + exit; +} + +#print Dumper \%amap; +#print Dumper \%namemap; +#print Dumper \%cmap; + +#foreach my $n (keys %amap) { +# foreach my $ip (@{$amap{$n}}) { +##print "$ip $n\n"; +# push @{$namemap{$ip}}, $n unless grep $n, @{$namemap{$ip}}; +# } +#} + +#foreach my $c (keys %cmap) { +# if ($amap{$c}) { +# print Dumper(\@{$amap{$c}}); +# } +## print $amap{$c}; +#} + +# cname targ -> IP + +#foreach my $ip (sort keys %namemap) { +# print "$ip ".join(' ', @{$namemap{$ip}})."\n"; +#} + +##fixme: might not be sane, addRec() above does a commit() internally. +#$dnsdb->{dbh}->rollback; +$dnsdb->{dbh}->commit; + +foreach my $t (keys %foundtypes) { + print "found $t: $foundtypes{$t}\n"; +} Index: branches/cname-collision/bind2hosts =================================================================== --- branches/cname-collision/bind2hosts (revision 936) +++ branches/cname-collision/bind2hosts (revision 936) @@ -0,0 +1,359 @@ +#!/usr/bin/perl +# Convert a BIND zone file to a hosts file +## +# Copyright 2020 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 Getopt::Long; + +use Data::Dumper; + +# push "the directory the script is in" into @INC +use FindBin; +use lib "$FindBin::RealBin/"; + +use DNSDB; + +my @skipdefs; +my $skipfile; +my $dryrun = 0; +# CNAME chain depth +my $maxdepth = 3; + +GetOptions( + "skip=s" => \@skipdefs, + "skipfile=s" => \$skipfile, + "test|dry-run" => \$dryrun, +); + +my $zname = shift @ARGV; + +my $usage = "usage: bind2hosts zone [--skip pattern [--skip pattern2 ...]] [--skipfile file] + zonename < zonefile + + --skip + Specify a string to skip in the records. If an IP-like string is + used, and the zone is a reverse zone, it will also search for the + octet-reversed form. Specify multiple times to skip multiple + different record patterns. + --skipfile + A file containing patterns to skip. Patterns from the file and + any --skip arguments are merged. + zonename + The name of the zone to import. Required. + + Zone data will be read from STDIN. +"; +if (!$zname) { + die $usage; +} + +if ($skipfile) { + if (-f $skipfile) { + open SKIP, "<$skipfile"; + while () { + chomp; + push @skipdefs, $_; + } + close SKIP; + } else { + warn "skipfile $skipfile requested but it doesn't seem to exist. Continuing.\n"; + } +} + +my $rev = 'n'; +my $zid; + +my %amap; +my %namemap; +my %cmap; + +my $dnsdb = new DNSDB; + +# need an ultimate fallback for this one +my $defttl = 900; +my $origin = "$zname."; # to append to unqualified names +my $curlabel; +my $prevlabel; + +my $i = 0; + +# need to spin up a full state machine-ish thing, because BIND zone files are all about context +while (my $rec = <>) { + chomp $rec; + next if $rec =~ /^\s*$/; + next if $rec =~ /^\s*;/; + next if $rec =~ /^\s*\)/; # SOA closing (possibly other records too?) + # arguably should do some more targeted voodoo when parsing the SOA details + + my $skipflag = 0; + foreach (@skipdefs) { + if ($rec =~ /\Q$_\E/) { + $skipflag = 1; + # might want to do something with the skipped records someday + } + } + next if $skipflag; + + if (my ($macro,$mdetail) = ($rec =~ /^\s*\$(TTL|ORIGIN|INCLUDE)\s+(.+)/) ) { + # macro sort of thing; $TTL and $ORIGIN most common. $INCLUDE is a thing, expect it to be rare in live use tho + if ($macro eq 'TTL') { + # irrelevant for a hosts file + } elsif ($macro eq 'ORIGIN') { + # $ORIGIN supports cascading/nesting, by watching for fully-qualified names vs partial names. + if ($mdetail =~ /\.$/) { + $origin = $mdetail; + } else { + # append current origin to unqualified origin + $origin = "$mdetail.$origin"; + } + } +##fixme: should arguably handle $INCLUDE +# probably NOT going to handle $GENERATE, since that type of record set is best handled in DNS + next; + } + + # yay for special cases + $origin = '' if $origin eq '.'; + + my $origrec = $rec; + + # leading whitespace indicates "same label as last record" + if ($rec =~ /^\s/) { + $curlabel = $prevlabel; + } else { + ($curlabel) = ($rec =~ /^([\w\@_.-]+)\s/); + } + + # magic name! + $curlabel = "$zname." if $curlabel eq '@'; + + # append $ORIGIN if name is not fully qualified. + if ($curlabel !~ /\.$/) { + $curlabel .= ".$origin"; + } + + # check for zone scope. skip bad records. + if ($curlabel !~ /$zname.$/) { + warn "bad record $origrec, maybe bad \$ORIGIN?\n"; + next; + } + + # trim the label, if any + $rec =~ s/^([\w\@_.-]*)\s+//; + + # now that we've collected and trimmed off the record's label, unpack the class, TTL, and type. + # class and TTL may be omitted, and may appear in either class,TTL or TTL,class order. + my $nc = 0; + my %seenatoms; + # we don't actually use these but we have to recognize them + my $class = 'IN'; + # not preset as we need to detect whether it's present in the record + my $ttl; + my $type; + my $badrec; + my $curatom = 'class'; + eval { + for (; $nc < 3; $nc++) { + last if $type; # short-circuit if we've got a type, further data is record-specific. + my ($atom) = ($rec =~ /^([\w\d.]+)\s/); + # should be safe? + last if !$atom; + if ($atom =~ /^\d+$/) { + if (defined($ttl)) { + # we already have a TTL, so another all-numeric field is invalid. + die "bad record ($origrec)\n"; + } else { + if ($curatom ne 'class' && $curatom ne 'ttl') { + die "bad record ($origrec)\n"; + } + $curatom = 'ttl'; + $ttl = $atom; + } + } + elsif ($atom =~ /^IN|CS|CH|HS$/) { + if ($atom =~ /CS|CH|HS/) { + die "unsupported class $atom in record ($origrec)\n"; + } + $curatom = 'class'; + $class = $atom; + } + elsif ($atom =~ /^[A-Z\d-]+/) { + # check against dnsadmin's internal list of known DNS types. + if ($reverse_typemap{$atom}) { + $type = $atom; + } else { + die "unknown type $atom in record ($origrec)\n"; + } + $curatom = 'type'; + } + $rec =~ s/^$atom\s*//; + } # class/type/TTL loop + }; + if ($@) { + warn $@; + next; + } + + $ttl = $defttl if !defined($ttl); + + # Just In Case we need the original rdata after we've sliced off more pieces + my $rdata = $rec; + $prevlabel = $curlabel; + +##fixme: squish this down for this script since SOA records are irrelevant + if ($type eq 'SOA') { + my ($ns, $adminmail) = ($rdata =~ /([\w.]+)\s+([\w.]+)\s+\(/); + die "Can't parse gibberish SOAish record: '$rdata'/'$origrec'\n" if !$ns; + $rdata =~ s/([\w.]+)\s+([\w.]+)\s+\(\s*//; + + # There are probably more efficient ways to do this but the SOA record + # format is essentially character based, not line-based. + # In theory the SOA serial etc may be spread over "many" lines, bounded by (). + + # Parse fields from $rdata if present + my @soabits; + my @soafirst = split /\s+/, $rdata; + while (my $f = shift @soafirst) { + last if $f !~ /^\d/; + push @soabits, $f; + } + + # Read more lines if we don't have enough SOA fields filled + while (scalar(@soabits) < 5) { + my $tmp = <>; + $tmp =~ s/^\s*//; + my @tmpsoa = split /\s+/, $tmp; + while (my $f = shift @tmpsoa) { + last if $f !~ /^\d/; + push @soabits, $f; + } + if (scalar(@soabits) == 5) { + last; + } + } + } # SOA + +##fixme: trim dupes if possible + + elsif ($type eq 'A') { + # need the name->IP map so we can reverse-map the CNAMEs on output + push @{$amap{$curlabel}}, $rdata; + $namemap{$rdata}{$curlabel}++; + } # A record + + elsif ($type eq 'CNAME') { + $cmap{$curlabel} = $rdata.($rdata =~ /\./ ? '' : ".$origin"); + } # CNAME record + + # all other record types are irrelevant for a hosts file + +} # + +#print Dumper \%cmap; + +# Walk the CNAME list and see if we can match the targets in-zone. +# Out-of-zone CNAMEs are out of scope for this conversion. +foreach my $cn (sort keys %cmap) { + my $targ = $cmap{$cn}; +#print "dbg: ".Dumper($targ); + my @targlist; +# push @targlist, $targ; # mostly for error reporting +my $dangle = 0; + +my $depth = 1; # CNAME -> A + +# check this as a loop for consistent fail/break conditions. bonus: may allow user choice for CNAME depth? + for (; $dangle == 0; $depth++) { + +#print "d:$depth checking $cn -> $targ\n"; +push @targlist, $targ; + + # Depth limit. If made user-selectable should arguably set a hard + # limit because deeply chained CNAMEs are Baaaaad, mmkaay? + if ($depth >= $maxdepth) { + warn "CNAMEs too deeply chained, skipping: $cn => ".join(' => ', @targlist)."\n"; + last; + } + +# break if CNAME target is in the A record list + last if $amap{$targ}; + if ($cmap{$targ}) { +# note the new target + my $tmpcn = $targ; + $targ = $cmap{$tmpcn}; +#print " chaining $tmpcn to new $targ\n"; + } else { +# target is either out of zone or doesn't exist + $dangle = 1; + last; + } + + +#warn "chained cname $cn => $targ\n"; + # CNAME to another CNAME +#$tmpcn => $targ\n"; + +# last if $dangle; + +# if (!$amap{$targ}) { +# if ($cmap{$targ}) { +# $tmpcn = $targ; +# $targ = $cmap{$tmpcn}; +#push @targlist, $targ; +#warn " chain target $cn => ".join(' => ', @targlist). +# "\n"; +# } else { +# warn "skipping dangling CNAME $cn => $targlist[0] => $targlist[1]\n"; +# next; +# } +# } +# } else { +# # skip depth-3 (?) CNAMES; any such zone does not belong as a hosts file anyway +# warn "skipping dangling CNAME $cn => $targ\n"; +# next; +# } +# } + + + } # CNAME recursion loop + +next if $dangle; + +#print " chain target $cn => ".join(' => ', @targlist)."\n"; + if ($amap{$targ}) { + # absent any criteria, we use the first IP a name was associated with + my $targip = $amap{$targ}[0]; + $namemap{$targip}{$cn}++; + } else { + } +} # each %cmap + +#print Dumper \%amap; +#foreach my $n (keys %amap) { +# foreach my $ip (keys %{$amap{$n}}) { +#print "$ip\t$n\n"; +# push @{$namemap{$ip}}, $n unless grep $n, @{$namemap{$ip}}; +# $namemap{$ip}{$n}++; +# } +#} + +#print Dumper \%namemap; +foreach my $ip (sort keys %namemap) { + print "$ip\t".join(' ', sort keys %{$namemap{$ip}})."\n"; +} Index: branches/cname-collision/bulk-add-domain =================================================================== --- branches/cname-collision/bulk-add-domain (revision 936) +++ branches/cname-collision/bulk-add-domain (revision 936) @@ -0,0 +1,82 @@ +#!/usr/bin/perl +# Add "a bunch" of domains all at once. Should rarely be used as most bulk +# adds should be by AXFR rather than completely new domain names. +## +# 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; + +# push "the directory the script is in" into @INC +use FindBin; +use lib "$FindBin::RealBin/"; + +use DNSDB; + +if (!@ARGV) { + print qq(usage: bulk-add-domain [domain list file 1] [domain list file 2] ... + Each domain list file should be a file with one to four comma-separated + elements: + Domain + Group + State (active/inactive) + Location/view + The group and location/view can be expressed as the internal group ID or + location ID instead of the text identifier. +); + exit; +} + +my $dnsdb = new DNSDB; + +# get userdata for log +($dnsdb->{logusername}, undef, undef, undef, undef, undef, $dnsdb->{logfullname}) = getpwuid($<); +$dnsdb->{logfullname} =~ s/,//g; +$dnsdb->{loguserid} = 0; # not worth setting up a pseudouser the way the RPC system does +$dnsdb->{logusername} = $dnsdb->{logusername}."/bulk-add-domain"; +$dnsdb->{logfullname} = $dnsdb->{logusername} if !$dnsdb->{logfullname}; + +foreach my $fname (@ARGV) { + if (-e $fname && !-z $fname) { + open DLIST, "<$fname"; + while () { + chomp; + my ($domain, $group, $state, $location) = split ','; + if ($domain !~ /^(?:[a-z0-9_-]+\.)+[a-z0-9_-]+$/) { + warn "skipping invalid domain $domain\n"; + next; + } + $group = 1 if !defined($group); + ##fixme: doesn't work with all-numeric group names + my $grpid = ($group =~ /^\d+$/ ? $group : $dnsdb->groupID($group) ); + $grpid = 1 if !$grpid; + $state = 1 if !defined($state); + $state = 0 if !$state; + # Munge in some alternate state values + $state = 1 if $state eq 'active'; + $state = 1 if $state eq 'on'; + $state = 0 if $state eq 'inactive'; + $state = 0 if $state eq 'off'; + warn "invalid state for $domain, skipping\n" if !($state == 0 || $state == 1); + $location = '' if !defined($location); + + my ($res,$msg) = $dnsdb->addDomain($domain, $grpid, $state, $location); + warn "error adding $domain: $msg\n" if $res ne 'OK'; + } + } else { + warn "$fname empty or missing\n"; + } +} Index: branches/cname-collision/bulkdel.pl =================================================================== --- branches/cname-collision/bulkdel.pl (revision 936) +++ branches/cname-collision/bulkdel.pl (revision 936) @@ -0,0 +1,137 @@ +#!/usr/bin/perl +# Bulk-delete records by pattern from a zone +## +# Copyright 2025 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 Getopt::Long; + +# Taint-safe (ish) voodoo to push "the directory the script is in" into @INC. +# See https://secure.deepnet.cx/trac/dnsadmin/ticket/80 for more gory details on how we got here. +use File::Spec (); +use File::Basename (); +my $path; +BEGIN { + $path = File::Basename::dirname(File::Spec->rel2abs($0)); + if ($path =~ /(.*)/) { + $path = $1; + } +} +use lib $path; + +use DNSDB; + +my $dnsdb = new DNSDB; + +my $usage = "usage: bulkdel.pl [-v|--verbose] [-t|--dry-run|] zonename pattern [pattern] + [pattern] .... + Zone name and at least one pattern are required. Further arguments + are taken as additional patterns. + Patterns should be limited to valid DNS name fragments. +"; + +my $dryrun = 0; +my $verbose = 0; + +# -t came to mind for something else +GetOptions( + "dry-run" => \$dryrun, + "verbose" => \$verbose, +); + +die $usage if !$ARGV[1]; +die $usage if $ARGV[0] !~ /^[\w._-]+$/; +# keep patterns simple +foreach (@ARGV) { + die $usage unless /^[\w._-]+$/; +} + +my $zname = shift @ARGV; + +my $zid; +my $revrec = 'n'; +my $code; +my $cidr; + +if ($zname =~ /\.arpa\.?$/ || $zname =~ m{^[\d./]+$} || $zname =~ m{^[0-9a-f:/]+$}) { + # reverse zone + ($code, $cidr) = DNSDB::_zone2cidr($zname); + die "$zname not a valid reverse zone form: ".$dnsdb->errstr."\n" if $code ne 'OK'; + $zid = $dnsdb->revID($cidr, ''); + die "zone $zname not found\n" if !$zid; + $revrec = 'y'; +} else { + $zid = $dnsdb->domainID($zname, ''); + die "zone $zname not found\n" if !$zid; +} + +# get userdata for log +($dnsdb->{logusername}, undef, undef, undef, undef, undef, $dnsdb->{logfullname}) = getpwuid($<); +$dnsdb->{logfullname} =~ s/,//g; +$dnsdb->{loguserid} = 0; # not worth setting up a pseudouser the way the RPC system does +$dnsdb->{logusername} = $dnsdb->{logusername}."/bulkdel.pl"; +$dnsdb->{logfullname} = ($dnsdb->{logfullname} ? $dnsdb->{logfullname}."/bulkdel.pl" : $dnsdb->{logusername}); + +$dnsdb->{dbh}->{AutoCommit} = 0; +$dnsdb->{dbh}->{RaiseError} = 1; + +eval { + my $logpar; + if ($revrec eq 'n') { + $logpar = $dnsdb->_log(group_id => $dnsdb->parentID(id => $zid, type => 'domain', revrec => $revrec), domain_id => $zid, + entry => "Bulk-deleting records in $zname matching one of ['".join("','", @ARGV)."']"); + } else { + $logpar = $dnsdb->_log(group_id => $dnsdb->parentID(id => $zid, type => 'domain', revrec => $revrec), rdns_id => $zid, + entry => "Bulk-deleting records in $zname matching one of ['".join("','", @ARGV)."']"); + } + print "Bulk-deleting records in $zname matching one of ['".join("','", @ARGV)."']\n" if $verbose; + my $sth = $dnsdb->{dbh}->prepare("DELETE FROM records WHERE ". + ($revrec eq 'n' ? 'domain_id' : 'rdns_id')." = ? AND (host ~* ? OR val ~* ?) ". + "RETURNING host, type, val, distance, weight, port, ttl, location" + ); + # These bits of log data won't change through the run; we're only doing one zone at a time. +##fixme ... unless a record is multizone (A+PTR et al) + my %logdata = (logparent => $logpar); + if ($revrec eq 'n') { + $logdata{domain_id} = $zid; + } else { + $logdata{rdns_id} = $zid; + } + foreach my $patt (@ARGV) { + $sth->execute($zid, $patt, $patt); + while (my ($host, $type, $val, $distance, $weight, $port, $ttl, $loc) = $sth->fetchrow_array) { + $logdata{group_id} = $dnsdb->parentID(id => $zid, type => 'domain', revrec => $revrec); + $logdata{entry} = "[bulkdel.pl $zname $patt] Removed '$host $typemap{$type} $val"; + $logdata{entry} .= " [distance $distance]" if $typemap{$type} eq 'MX'; + $logdata{entry} .= " [priority $distance] [weight $weight] [port $port]" if $typemap{$type} eq 'SRV'; + $logdata{entry} .= "', TTL $ttl"; + $logdata{entry} .= ", location ".$dnsdb->getLoc($loc)->{description} if $loc; + print "$logdata{entry}\n" if $verbose; + $dnsdb->_log(%logdata) + } + } + $dnsdb->_updateserial(%logdata); + if ($dryrun) { + $dnsdb->{dbh}->rollback; + } else { + $dnsdb->{dbh}->commit; + } +}; +if ($@) { + die "error bulk-deleting records: $@\n"; +} Index: branches/cname-collision/bumpserial =================================================================== --- branches/cname-collision/bumpserial (revision 936) +++ branches/cname-collision/bumpserial (revision 936) @@ -0,0 +1,113 @@ +#!/usr/bin/perl +# Quickly bump the serial number on one or more zones +## +# Copyright 2019 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 NetAddr::IP; +use Data::Dumper; + +# push "the directory the script is in" into @INC +use FindBin; +use lib "$FindBin::RealBin/"; + +use DNSDB; + +usage() if !@ARGV; + +sub usage { + die "usage: bumpserial zone1 [zone2] [zone3] ...\n"; +} + +my $dnsdb = new DNSDB or die "Couldn't create DNSDB object: ".$DNSDB::errstr."\n"; +my $dbh = $dnsdb->{dbh}; + +# revID() and domainID() need a location. assuming '' likely fails. zones SHOULD usually +# be unique irrespective of locations - we aren't big enough to need to do that (yet...) +my $didsth = $dbh->prepare("SELECT domain_id,domain,default_location FROM domains WHERE domain = ?"); +my $ridsth = $dbh->prepare("SELECT rdns_id,revnet,default_location FROM revzones WHERE revnet = ?"); + +# do the updates by way of the ID, that way we've confirmed we've got a zone that's actually present +my $dser = $dbh->prepare("UPDATE domains SET zserial = ? WHERE domain_id = ?"); +my $rser = $dbh->prepare("UPDATE revzones SET zserial = ? WHERE rdns_id = ?"); + +while (my $zone = shift @ARGV) { + $zone = lc $zone; + if ($zone =~ m,^[\d\./]+$, || $zone =~ /\.in-addr\.arpa$/) { + # reverse zone, CIDR format or .arpa format. ignoring non-octet CIDR ranges and ipv6 for now + my $z; + if ($zone =~ /\.in-addr\.arpa$/) { + # convert to CIDR for database lookups + $z = DNSDB::_zone2cidr($zone); + } else { + $z = new NetAddr::IP $zone; + } + if (!$z) { + warn "error: $zone does not appear to be a valid CIDR range\n"; + next; + } + $ridsth->execute("$z"); + my $rlist = $ridsth->fetchall_arrayref({}); + my $newser = scalar(time); + if (scalar(@{$rlist}) > 1) { + print "warning: multiple zones matched!\n"; + foreach (@{$rlist}) { + print " bump serial on $_->{revnet} (location $_->{default_location})? "; + my $yn = ; + chomp $yn; + if (lower($yn) eq 'y') { + $rser->execute($newser, $_->{rdns_id}); + print " $_->{revnet} serial bumped to $newser\n"; + } + } + } elsif (scalar(@{$rlist}) == 1) { + $rser->execute($newser, $rlist->[0]->{rdns_id}); + print "$zone serial bumped to $newser\n"; + } else { + warn "error: unknown zone '$zone'\n"; + } + + } elsif ($zone =~ /^[a-z0-9\.-]+$/) { + # domain + $didsth->execute($zone); + my $dlist = $didsth->fetchall_arrayref({}); + my $newser = scalar(time); + if (scalar(@{$dlist}) > 1) { + print "warning: multiple zones matched!\n"; + foreach (@{$dlist}) { + print " bump serial on $_->{domain} (location $_->{default_location})? "; + my $yn = ; + chomp $yn; + if (lower($yn) eq 'y') { + $dser->execute($newser, $_->{domain_id}); + print " $_->{domain} serial bumped to $newser\n"; + } + } + } elsif (scalar(@{$dlist}) == 1) { + $dser->execute($newser, $dlist->[0]->{domain_id}); + print "$zone serial bumped to $newser\n"; + } else { + warn "error: unknown zone '$zone'\n"; + } + + } else { + # Your llama is on fire + print "Unknown zone name/format $zone\n"; + } + +} # shift @ARGV Index: branches/cname-collision/compact-recs.pl =================================================================== --- branches/cname-collision/compact-recs.pl (revision 936) +++ branches/cname-collision/compact-recs.pl (revision 936) @@ -0,0 +1,258 @@ +#!/usr/bin/perl +# Quick utility to use post-import to convert great huge piles of +# A+PTR records to single A+PTR template records +## +# $Id$ +# Copyright 2013-2022,2025 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 Getopt::Long; + +# Taint-safe (ish) voodoo to push "the directory the script is in" into @INC. +# See https://secure.deepnet.cx/trac/dnsadmin/ticket/80 for more gory details on how we got here. +use File::Spec (); +use File::Basename (); +my $path; +BEGIN { + $path = File::Basename::dirname(File::Spec->rel2abs($0)); + if ($path =~ /(.*)/) { + $path = $1; + } +} +use lib $path; + +use DNSDB; + +usage() if !$ARGV[1]; + +sub usage { + die qq(usage: compact-recs.pl netblock pattern [--replace [record id]] + 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 + --replace Optional argument to update an existing template if found. + A record ID can be specified to match a particular record, + or 'all' to forcibly remove all but one in the event of + multiple records. If multiple records are found but neither + 'all' or a specific record ID is specified, an error will be + returned and nothing will be changed since there is no + guarantee of which record might be replaced. + + OR + compact-recs.pl --batch patternfile + patternfile should be a file containing a list of netblock-pattern + pairs, whitespace separated. --replace is ignored in this mode. + + 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 may result in duplicate template records. +); +} + +my $batchmode = 0; +my $replace = 0; +my $tmpl_msg = ''; + +GetOptions("batch" => \$batchmode, + "replace:s" => \&setreplace ); + +sub setreplace { + if ($_[1] eq '') { + $replace = -1; + } else { + $replace = $_[1]; + } +} + +if ($replace && $replace !~ /^(all|-?\d+)$/) { + warn "Invalid --replace argument $replace:\n"; + usage(); +} + +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->{logfullname} =~ s/,//g; +$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->{logfullname} ? $dnsdb->{logfullname}."/compact-recs.pl" : $dnsdb->{logusername}); + +if ($batchmode) { + # --replace not safe for --batch. could arguably support an in-file flag someday? + if ($replace) { + $replace = 0; + warn "--replace not compatible with --batch. Attempting to continue.\n"; + } + open NBLIST, "<$ARGV[0]"; + 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 ($zonecidr,$zone,$ploc) = $dbh->selectrow_array( + "SELECT revnet,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; + # Automatically choose new type as A+PTR template if the new pattern's + # domain is managed in this instance, or PTR template if not + my $newtype = ($dparent ? 65283 : 65282); + + my ($tmplcount) = $dbh->selectrow_array("SELECT count(*) FROM records WHERE rdns_id = ? AND ". + "(type=65282 OR type=65283) AND val = ?", undef, ($zone, $cidr) ); + if ($tmplcount && !$replace) { + # Template(s) found, --replace not set + print "One or more templates found for $cidr, use --replace [record_id],". + " --replace all, or clean up manually.\n"; + return; + } elsif ($tmplcount > 1 && ($replace eq '0' || $replace eq '-1')) { + # Multiple templates found, --replace either not set (==0) or no argument provided (==-1) + print "Multiple templates found matching $cidr but no record ID specified with". + " --replace. Use --replace with a record ID, use --replace all, or clean up". + " manually.\n"; + return; + } + + print "Converting PTR and A+PTR records in $cidr matching $patt to single $typemap{$newtype} record\n"; + my $delcnt = 0; + + eval { + # First, clean up the records that match the template. + my $getsth = $dbh->prepare("SELECT record_id,host,val FROM records ". + "WHERE (type = 12 OR type > 65000) AND inetlazy(val) << ? AND rdns_id = ?"); + my $delsth = $dbh->prepare("DELETE FROM records WHERE record_id = ?"); + $getsth->execute($cidr, $zone); + my $i = 0; + while (my ($id,$host,$val) = $getsth->fetchrow_array) { + my $cmp = $patt; + # skip existing template within the new template's range + next if $val =~ m{/\d+$}; + if ($cmp =~ /\%-?c/) { + # Determine "nth host" index value of $val for %c and %-c + my $possible = new NetAddr::IP $val; + my $valindex = $possible - $cidr; + DNSDB::_template4_expand(\$cmp, $val, \$cidr, $valindex); + } else { + DNSDB::_template4_expand(\$cmp, $val, \$cidr); + } + $delsth->execute($id) if $cmp eq $host; + $delcnt++ if $cmp eq $host; + } + + my $template_modified = 0; + + if ($replace) { + if ($replace eq 'all') { + # clear any templates with the same CIDR, and add a new one + $dbh->do("DELETE from records WHERE rdns_id = ? AND (type=65282 OR type=65283) AND val = ?", undef, ($zone, $cidr) ); + $dbh->do("INSERT INTO records (domain_id, rdns_id, host, type, val, ttl, location) VALUES (?,?,?,?,?,?,?)", + undef, ($dparent, $zone, $patt, $newtype, $cidr, $soa->{minttl}, $ploc) ); + $template_modified = 1; + $tmpl_msg = ", replaced $tmplcount template records"; + } else { + if ($replace =~ /^\d+$/) { + # $replace == [id] -> replace that record ID, error if it doesn't exist or isn't + # a template for the specified CIDR. Arguably some stretch on the latter. + my ($rechost,$recval,$rectype) = $dbh->selectrow_array( + "SELECT host,val,type,record_id FROM records WHERE record_id = ?", + undef, $replace); + if (($rectype == 65282 || $rectype == 65283) && $recval eq $cidr) { + # Do the update if the record specified matches is a suitable template + $dbh->do("UPDATE records SET host = ?, type = ?, val = ? WHERE record_id = ?", + undef, ($patt, $newtype, $cidr, $replace) ); + $template_modified = 1; + $tmpl_msg = ", replaced an existing template record"; + } else { + # Specified record ID isn't a template record, or doesn't match $cidr, or both + die "Specified record ID isn't a template for $cidr, skipping:\n". + " $replace found: $rechost $typemap{$rectype} $recval\n"; + } + } else { + # $replace == -1 -> replace/update template iff one template is present + # (should have errored out earlier if multiple templates are present) + my ($rechost,$recval,$rectype,$recid) = $dbh->selectrow_array( + "SELECT host,val,type,record_id FROM records WHERE rdns_id = ? AND (type=65282 OR type=65283) AND val = ?", + undef, ($zone, $cidr) ); + if ($recid) { + # Do the update if we've found an existing template with the same CIDR + $dbh->do("UPDATE records SET host = ?, type = ?, val = ? WHERE record_id = ?", + undef, ($patt, $newtype, $cidr, $recid) ); + $template_modified = 1; + $tmpl_msg = ", replaced an existing template record"; + } else { + $dbh->do("INSERT INTO records (domain_id, rdns_id, host, type, val, ttl, location) VALUES (?,?,?,?,?,?,?)", + undef, ($dparent, $zone, $patt, $newtype, $cidr, $soa->{minttl}, $ploc) ); + $template_modified = 1; + } + } # $replace -> [id] or $replace == -1 + } # $replace <> 'all' + } else { + # $replace == 0 (not set), just insert the new template + $dbh->do("INSERT INTO records (domain_id, rdns_id, host, type, val, ttl, location) VALUES (?,?,?,?,?,?,?)", + undef, ($dparent, $zone, $patt, $newtype, $cidr, $soa->{minttl}, $ploc) ); + $template_modified = 1; + } + + if ($template_modified) { + my %logdata = (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"); + $dnsdb->_updateserial(%logdata); + $dnsdb->_log(%logdata); + $dbh->commit; + } else { + # no need to do push out a null update that just bumps the serial on the zone(s) + $dbh->rollback; + } + + }; + if ($@) { + print "Error(s) encountered: $@\n"; + $dbh->rollback; + return; + } + print " complete (removed $delcnt PTR/A+PTR records"; + print $tmpl_msg; + print ")\n"; +} # squashem () Index: branches/cname-collision/dns-1.0-1.2.sql =================================================================== --- branches/cname-collision/dns-1.0-1.2.sql (revision 936) +++ branches/cname-collision/dns-1.0-1.2.sql (revision 936) @@ -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: branches/cname-collision/dns-1.2.3-1.2.4.sql =================================================================== --- branches/cname-collision/dns-1.2.3-1.2.4.sql (revision 936) +++ branches/cname-collision/dns-1.2.3-1.2.4.sql (revision 936) @@ -0,0 +1,20 @@ +-- SQL upgrade file for dnsadmin 1.2.3 to 1.2.4 bugfix update + +-- pre-pg8.3, this must be run as a superuser +CREATE LANGUAGE plpgsql; +-- it's required for: + +-- Return proper conversion of string to inet, or 0.0.0.0/0 if the string is +-- not a valid inet value. We need to do this to support "funky" records that +-- may not actually have valid IP address values. Used for ORDER BY +CREATE OR REPLACE FUNCTION inetlazy (rdata text) RETURNS inet AS $$ +BEGIN + RETURN CAST(rdata AS inet); +EXCEPTION + WHEN OTHERS THEN + RETURN CAST('0.0.0.0/0' AS inet); +END; +$$ LANGUAGE plpgsql; + +-- Update dbversion +UPDATE misc SET value='1.2.4' WHERE key='dbversion'; Index: branches/cname-collision/dns-rpc.cgi =================================================================== --- branches/cname-collision/dns-rpc.cgi (revision 936) +++ branches/cname-collision/dns-rpc.cgi (revision 936) @@ -0,0 +1,2020 @@ +#!/usr/bin/perl -w -T +# XMLRPC interface to manipulate most DNS DB entities +## +# $Id$ +# Copyright 2012-2016,2020-2025 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; + +# push "the directory the script is in" into @INC +use FindBin; +use lib "$FindBin::RealBin/"; + +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, + 'dnsdb.revID' => \&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' => \&rpc_addRec, + 'dnsdb.updateRec' => \&rpc_updateRec, +#sub downconvert { + 'dnsdb.addOrUpdateRevRec' => \&addOrUpdateRevRec, + 'dnsdb.updateRevSet' => \&updateRevSet, + 'dnsdb.splitTemplate' => \&splitTemplate, + 'dnsdb.resizeTemplate' => \&resizeTemplate, + 'dnsdb.templatesToRecords' => \&templatesToRecords, + 'dnsdb.delRec' => \&delRec, + 'dnsdb.delByCIDR' => \&delByCIDR, + 'dnsdb.delRevSet' => \&delRevSet, +#sub getLogCount {} +#sub getLogEntries {} + 'dnsdb.getRevPattern' => \&getRevPattern, + 'dnsdb.getRevSet' => \&getRevSet, + '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; +my $req = FCGI::Request(); + +while ($req->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; + + +=head1 dns-rpc.cgi + +The RPC API for DeepNet DNS Administrator. + +=head2 Common required arguments + +A few arguments for primitive authorization are required on all calls. + +=over 4 + +=item rpcuser + +A string identifying the remote user in some way. Used to generate a hidden local user for logging. + +=item rpcsystem + +A string identifying the remote system doing the RPC call. This is checked against a list of IPs allowed to +claim this system identifier. + +=back + +=cut + +## +## Subs below here +## + +## +## Internal utility subs +## + +# 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 default 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}; + } +} + +# Check if the hashrefs passed in refer to identical record data, so we can skip +# the actual update if nothing has actually changed. This is mainly useful for +# reducing log noise due to chained calls orginating with updateRevSet() since +# "many" records could be sent for update but only one or two have actually changed. +sub _checkRecMod { + my $oldrec = shift; + my $newrec = shift; + + # Because we don't know which fields we've even been passed + no warnings qw(uninitialized); + + my $modflag = 0; + # order by most common change. host should be first, due to rDNS RPC calls + for my $field (qw(host type val)) { + return 1 if ( + defined($newrec->{$field}) && + $oldrec->{$field} ne $newrec->{$field} ); + } + + return 0; +} # _checRecMod + + +## +## Shims for DNSDB core subs +## + + +=head2 Exposed RPC subs + +=cut +#over 4 + + +#sub connectDB { +#sub finish { +#sub initGlobals { +#sub initPermissions { +#sub getPermissions { +#sub changePermissions { +#sub comparePermissions { +#sub changeGroup { +#sub _log { + + +=head3 addDomain + +Add a domain. Note that while this should accept a formal .arpa reverse zone name, doing so will disrupt +several features that ease management of bulk reverse records. Use C to add reverse zones. + +=over 4 + +=item domain + +The domain to add. + +=item group + +The group ID to add the domain to. Group ID 1 is expected to exist; otherwise a list of groups should be +retrieved with C for selection. The group defines which template records will be used to create +the initial record set in the domain. + +=item state + +Active/inactive flag. Send C, C, or C<1> for domains that should be published; C, +C, or C<0> for domains that should be added but not currently published. + +=item defloc + +Optional argument for the default location/view the domain's records should be published in. Leave blank, or a +list of locations can be retrieved with C or C for selection. + +=back + +Returns the ID of the domain. + +=cut +sub addDomain { + my %args = @_; + + _commoncheck(\%args, 'y'); + + my ($code, $msg) = $dnsdb->addDomain($args{domain}, $args{group}, $args{state}, $args{defloc}); + die "$msg\n" if $code eq 'FAIL'; + return $msg; # domain ID +} + + +=head3 delZone + +Delete a domain or reverse zone + +=over 4 + +=item zone + +The domain name, domain ID, .arpa zone name, or logical CIDR range to remove + +=item revrec + +Flag to indicate whether to go looking for a domain or a reverse zone to delete. Accepts "y" or "n". + +=back + +Returns an informational confirmation message on success. + +=cut +sub delZone { + my %args = @_; + + _commoncheck(\%args, 'y'); + die "Need forward/reverse zone flag\n" if !$args{revrec}; + die "Need zone identifier\n" if !$args{zone}; + + 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 { + die "Need zone location\n" if !defined($args{location}); + my $zoneid; + $zoneid = $dnsdb->domainID($args{zone}, $args{location}) if $args{revrec} eq 'n'; + $zoneid = $dnsdb->revID($args{zone}, $args{location}) 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; +} # delZone() + + +#sub domainName {} +#sub revName {} + + +=head3 domainID + +Retrieve the ID for a domain + +=over 4 + +=item domain + +The domain name to find the ID for + +=back + +Returns the integer ID of the domain if found. + +=cut +sub domainID { + my %args = @_; + + _commoncheck(\%args, 'y'); + + my $domid = $dnsdb->domainID($args{domain}, $args{location}); + die $dnsdb->errstr."\n" if !$domid; + return $domid; +} + +=head3 revID + +Retrieve the ID for a reverse zone + +=over 4 + +=item revzone + +The reverse zone to find the ID for, in CIDR form. + +=back + +Returns the integer ID of the domain if found. + +=cut +sub revID { + my %args = @_; + + _commoncheck(\%args, 'y'); + + my $revid = $dnsdb->revID($args{revzone}, $args{location}); + die $dnsdb->errstr."\n" if !$revid; + return $revid; +} + + + +=head3 addRDNS + +Add a reverse zone + +=over 4 + +=item revzone + +The logical reverse zone to be added. Can be specified as either formal .arpa notation or a valid CIDR +netblock. Using a CIDR netblock allows logical aggregation of related records even if the CIDR range covers +multiple formal .arpa zone boundaries. For example, the logical zone 192.168.4.0/22 covers +4.168.192.in-addr.arpa, 5.168.192.in-addr.arpa, 6.168.192.in-addr.arpa, and 7.168.192.in-addr.arpa, and will be +correctly published as such. + +=item revpatt + +A string representing the pattern to use for an initial template record. + +=item group + +The group ID to add the zone to. + +=item state + +Active/inactive flag. Send C, C, or 1 for zones that should be published; C, +C, or C<0> for zones that should be added but not currently published. + +=item defloc + +Optional argument for the default location/view the zone's records should be published in. Leave blank, or a +list of locations can be retrieved with C or C for selection. + +=back + +Returns the zone ID on success. + +=cut +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; # zone ID +} + +#sub getZoneCount {} +#sub getZoneList {} +#sub getZoneLocation {} + + +=head3 addGroup + +Add a group + +=over 4 + +=item groupname + +The name for the new group + +=item parent_id + +The ID of the group to put the new group in + +=back + +Note that the RPC API does not currently expose the full DNSDB::addGroup interface; the permissions hashref is +substituted with a reasonable standard default user permissions allowing users to add/edit/delete zones and +records. + +Returns literal 'OK' on success. + +=cut +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; +} + + +=head3 delGroup + +Delete a group. The group must be empty of users, zones, or subgroups. + +=over 4 + +=item group + +The group name or group ID to delete + +=back + +Returns an informational message on success. + +=cut +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 {} + + +=head3 addUser + +Add a user. + +=over 4 + +=item username + +The username to add + +=item group + +The group ID to add the user in. Users in subgroups only have access to data in that group and its subgroups. + +=item pass + +The password for the account + +=item state + +Flag to indicate if the account should be active on creation or set to inactive. Accepts the same values as +domains and reverse zones - C, C, or C<1> for an active user, C, C, or C<0> for an +inactive one. + +=back + +B + +=over 4 + +=item type + +Type of user account to add. Current types are C (normal user) and C (superuser). Defaults to C. + +=item permstring + +A string encoding the permissions a normal user receives. By default this is set to C indicating +permissions are inherited from the group. + +C clones permissions from user with id [digits] + +C sets the exact permissions indicated by [string]. It is currently up to the caller to ensure +that related/cascading permissions are set correctly; see C<%DNSDB::permchains> for the current set. Current +valid permission identifiers match +C<(group|user|domain|record|location|self)_(edit|create|delete|locchg|view)>, however see C<@DNSDB::permtypes> +for the exact list. + +The comma after the colon is not a typo. + +=item fname + +First name + +=item lname + +Last name + +=item phone + +Phone number + +=back + +Note that some user properties originate in DNS Administrator's inspiration, VegaDNS. + +=cut +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 {} + + +=head3 updateUser + +Update a user's username, password, state, type, first/last names, and/or phone number + +Most arguments are the same as for addUser. + +=over 4 + +=item uid + +The ID of the user record + +=item username + +The username + +=item group + +The group ID the user is in (for logging). Users cannot currently be moved to a different group. + +=item pass + +An updated password, if provided. Leave blank to keep the existing password. + +=item state + +The account state (active/inactive). Takes the same values as addUser. + +=item type + +The account type (user [C] or superuser [C]) + +=item fname + +First name (optional) + +=item lname + +Last name (optional) + +=item phone + +Phone contact (optional) + +=back + +=cut +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; +} + + +=head3 delUser + +Delete a user + +=over 4 + +=item uid + +The ID of the user record to delete + +=back + +=cut +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 {} + + +=head3 getLocDropdown + +Retrieve a list of locations for display in a dropdown. + +=over 4 + +=item group + +The group ID to select locations from + +=item defloc + +Optional argument to flag the "default" location in the list + +=back + +Returns an arrayref to a list of hashrefs with elements C, C and C. C will +be 0 for all entries unless the C value matches C, where it will be set to 1. + +=cut +sub getLocDropdown { + my %args = @_; + + _commoncheck(\%args); + $args{defloc} = '' if !$args{defloc}; + + my $ret = $dnsdb->getLocDropdown($args{group}, $args{defloc}); + return $ret; +} + + +=head3 getSOA + +Retrieve the SOA record for a zone + +=over 4 + +=item defrec + +Default/live records flag. Accepts C and C. + +=item revrec + +Forward/reverse flag. Accepts C and C. + +=item id + +The zone ID (if C is C) or the group ID (if C is C) to retrieve the SOA from + +=back + +=cut +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 {} + + +=head3 getRecLine + +Retrieve all fields for a specific record + +=over 4 + +=item defrec + +Default/live records flag. Accepts C and C. + +=item revrec + +Forward/reverse flag. Accepts C and C. Mildly abused to determine whether to include C, +C, and C fields, since MX and SRV records don't make much sense in reverse zones. + +=item id + +The record ID (if C is C) or default record ID (if C is C) to retrieve + +=back + +=cut +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; +} + + +=head3 getRecList + +Retrieve a list of records for a zone. + +=over 4 + +=item id + +The zone ID (if C is C) or group ID (if C is C) to retrieve records from + +=item defrec + +Default/live records flag. Accepts C and C. + +=item revrec + +Forward/reverse flag. Accepts C and C. + +=back + +Optional arguments + +=over 4 + +=item offset + +Offset from the start of the raw record list. Mainly for pagination. Defaults 0. + +=item nrecs + +Number of records to return. Defaults to C<$DNSDB::perpage> + +=item sortby + +Sort field. Defaults to host for domain zones, val for reverse zones. Supports multifield sorts; pass the +fields in order separated by commas. + +=item sortorder + +SQL sort order. Defaults to C. + +=item filter + +Return only records whose host or val fields match this string. + +=item type, distance, weight, port, ttl, description + +If these arguments are present, use the value to filter on that field. + +=back + +=cut +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}; + + # caller may not know about zone IDs. accept the zone name, but require a location if so + if ($args{id} !~ /^\d+$/) { + die "Location required to use the zone name\n" if !defined($args{location}); + } + + # 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}, $args{location}) if $args{id} !~ /^\d+$/; + } else { + $args{id} = $dnsdb->revID($args{id}, $args{location}) 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}, location => $args{location}); + die $dnsdb->errstr."\n" if !$ret; + + return $ret; +} # getRecList() + + +=head3 getRecCount + +Return count of non-SOA records in zone (or default records in a group). + +Uses the same arguments as getRecList, except for C, C, C, and C. + +=cut +sub getRecCount { + my %args = @_; + + _commoncheck(\%args); + + _reccheck(\%args); + + # caller may not know about zone IDs. accept the zone name, but require a location if so + if ($args{id} !~ /^\d+$/) { + die "Location required to use the zone name\n" if !defined($args{location}); + } + + # 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}; + + # convert zone name to zone ID, if needed + if ($args{defrec} eq 'n') { + if ($args{revrec} eq 'n') { + $args{id} = $dnsdb->domainID($args{id}, $args{location}) if $args{id} !~ /^\d+$/; + } else { + $args{id} = $dnsdb->revID($args{id}, $args{location}) if $args{id} !~ /^\d+$/ + } + } + + # fail if we *still* don't have a valid zone ID + die $dnsdb->errstr."\n" if !$args{id}; + + my $ret = $dnsdb->getRecCount(defrec => $args{defrec}, revrec => $args{revrec}, + id => $args{id}, filter => $args{filter}); + + die $dnsdb->errstr."\n" if !$ret; + + return $ret; +} # getRecCount() + + +=head3 addRec + +Add a record to a zone or add a default record to a group. + +Note that the name, type, and address arguments may be modified for normalization or to match available zones +for A+PTR and related metatypes. + +=over 4 + +=item defrec + +Default/live records flag. Accepts C and C. + +=item revrec + +Forward/reverse flag. Accepts C and C. + +=item parent_id + +The ID of the parent zone or group. + +=item name + +The fully-qualified hostname for the record. Trailing periods will automatically be stripped for storage, and +added on export as needed. Note that for reverse zone records, this is the nominal record target. + +=item type + +The record type. Both the nominal text identifiers and the bare integer types are accepted. + +=item address + +The record data or target. Note that for reverse zones this is the nominal .arpa name for the record. + +=item ttl + +The record TTL. + +=item location + +The location identifier for the record. + +=item expires + +Flag to indicate the record will either expire at a certain time or become active at a certain time. + +=item stamp + +The timestamp a record will expire or become active at. Note that depending on the DNS system in use this may +not result in an exact expiry or activation time. + +=back + +B + +=over 4 + +=item distance + +MX and SRV distance or priority + +=item weight + +SRV weight + +=item port + +SRV port number + +=back + +=cut +# The core sub uses references for some arguments to allow limited modification for +# normalization or type+zone matching/mapping/availability. +sub rpc_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; +} # rpc_addRec + + +=head3 updateRec + +Update a record. + +Takes the same arguments as C except that C is the record to update, not the primary parent zone ID. + +If C is blank or undefined, any timestamp will be removed. + +=cut +sub rpc_updateRec { + my %args = @_; + + _commoncheck(\%args, 'y'); + + _reccheck(\%args); + + # put some caller-friendly names in their rightful DB column places + $args{val} = $args{address} if !$args{val}; + $args{host} = $args{name} if !$args{host}; + + # 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}) && $oldrec->{stampactive}; + + # 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; +} # rpc_updateRec + + + +=head3 addOrUpdateRevRec + +Add or update a reverse DNS record (usually A+PTR template) as appropriate based on a passed CIDR address and +hostname pattern. The record will automatically be downconverted to a PTR template if the forward zone +referenced by the hostname pattern is not managed in this DNSAdmin instance. + +=over 4 + +=item cidr + +The CIDR address or IP for the record + +=item name + +The hostname pattern for template records, or the hostname for single IP records + +=back + +=cut +# 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}; + + # Location required so we don't turn up unrelated zones in getZonesByCIDR(). + # Caller should generally have some knowledge of this. + die "Need location\n" if !defined($args{location}); + + 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 or v6 /128 assignments, or we just add a new record all the time. + my $filt = ( $cidr->{isv6} ? ($cidr->masklen != 128 ? "$cidr" : $cidr->addr) : + ($cidr->masklen != 32 ? "$cidr" : $cidr->addr) ); + my $reclist = $dnsdb->getRecList(rpc => 1, defrec => 'n', revrec => 'y', + id => $zonelist->[0]->{rdns_id}, filter => $filt); +##fixme: Figure some new magic to automerge new incoming A(AAA)+PTR requests +# with existing A records to prevent duplication of A(AAA) records + if (scalar(@$reclist) == 0) { + # Aren't Magic Numbers Fun? See pseudotype list in dnsadmin. + my $type = ($cidr->{isv6} ? ($cidr->masklen == 128 ? 65281 : 65284) : ($cidr->masklen == 32 ? 65280 : 65283) ); + rpc_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. + # canonicalize the IP values so funny IPv6 short forms don't + # cause non-updates by not being literally string-equal + $rec->{val} = new NetAddr::IP $rec->{val}; + my $tmpcidr = new NetAddr::IP $args{cidr}; + my %newrec = (host => $args{name}, val => $tmpcidr, type => $args{type}); + rpc_updateRec(defrec =>'n', revrec => 'y', id => $rec->{record_id}, + parent_id => $zonelist->[0]->{rdns_id}, address => "$cidr", %args) + if _checkRecMod($rec, \%newrec); # and only do the update if there really is something to change + $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) ); + rpc_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(rpc => 1, 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) ); + rpc_addRec(defrec => 'n', revrec => 'y', parent_id => $zdata->{rdns_id}, type => $type, + address => "$args{cidr}", %args); + } else { + my $updflag = 0; + 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; + my %newrec = (host => $args{name}, val => $zdata->{revnet}, type => $args{type}); + rpc_updateRec(defrec => 'n', revrec => 'y', id => $rec->{record_id}, + parent_id => $zdata->{rdns_id}, %args) + if _checkRecMod($rec, \%newrec); # and only do the update if there really is something to change + $updflag = 1; + last; # only do one record. + } + # catch the case of "oops, no zone-sized template record and need to add a new one", + # because the SOA and NS records will be returned from the getRecList() call above + unless ($updflag) { + my $type = ($cidr->{isv6} ? 65284 : 65283); + rpc_addRec(defrec => 'n', revrec => 'y', parent_id => $zdata->{rdns_id}, type => $type, + address => $zdata->{revnet}, %args); + } + } # scalar(@$reclist) != 0 + } # iterate zones within $cidr + } # done $cidr-contains-zones +##fixme: what about errors? what about warnings? +} # done addOrUpdateRevRec() + + +=head3 updateRevSet + +Update reverse DNS entries for a set of IP addresses all at once. Calls addOrUpdateRevRec internally. + +=over 4 + +=item host_[ip.add.re.ss] (Multiple entries) + +One or more identifiers for one or more IP addresses to update reverse DNS on. The value of the argument is the +hostname to set on that IP. + +=back + +=cut +# Update rDNS on a whole batch of IP addresses. Presented as a separate sub via RPC +# since RPC calls can be s...l...o...w.... +sub updateRevSet { + my %args = @_; + + _commoncheck(\%args, 'y'); + + my @ret; + # loop over passed IP/hostname pairs + foreach my $key (keys %args) { + next unless $key =~ m{^host_((?:[\d.]+|[\da-f:]+)(?:/\d+)?)$}; + my $ip = $1; + push @ret, addOrUpdateRevRec(%args, cidr => $ip, name => $args{$key}); + } + + # now we check the parts of the block that didn't get passed to see if they should be deleted + my $block = new NetAddr::IP $args{cidr}; + if (!$block->{isv6}) { + foreach my $ip (@{$block->splitref(32)}) { + my $bare = $ip->addr; + next if $args{"host_$bare"}; + delByCIDR(delforward => 1, delsubs => 0, cidr => $bare, location => $args{location}, + rpcuser => $args{rpcuser}, rpcsystem => $args{rpcsystem}); + } + } + +##fixme: what about errors? what about warnings? + return \@ret; +} # done updateRevSet() + + +=head3 splitTemplate + +Split a PTR template record into multiple records. + +=over 4 + +=item cidr + +The CIDR address for the record to split + +=item newmask + +The new masklength for the new records. + +=back + +=cut +# Split a template record as per a passed CIDR. +# Requires the CIDR and the new mask length +sub splitTemplate { + my %args = @_; + + _commoncheck(\%args, 'y'); + + my $cidr = new NetAddr::IP $args{cidr}; + + # Location required so we don't turn up unrelated zones in getZonesByCIDR(). + # Caller should generally have some knowledge of this. + die "Need location\n" if !defined($args{location}); + + my $zonelist = $dnsdb->getZonesByCIDR(%args); + + if (scalar(@$zonelist) == 0) { + # enhh.... WTF? + + } elsif (scalar(@$zonelist) == 1) { + my $zone = new NetAddr::IP $zonelist->[0]->{revnet}; + if ($zone->contains($cidr)) { + # Find the first record in the reverse zone that matches the CIDR we're splitting... + my $reclist = $dnsdb->getRecList(rpc => 1, defrec => 'n', revrec => 'y', + id => $zonelist->[0]->{rdns_id}, filter => $cidr, sortby => 'val', sortorder => 'DESC'); + my $oldrec; + foreach my $rec (@$reclist) { + my $reccidr = new NetAddr::IP $rec->{val}; + next unless $cidr->contains($reccidr); # not sure this is needed here + # ... and is a reverse-template type. + # Could arguably trim the list below to just 65282, 65283, 65284 + next unless $rec->{type} == 12 || $rec->{type} == 65280 || $rec->{type} == 65281 || + $rec->{type} == 65282 || $rec->{type} == 65283 ||$rec->{type} == 65284; + # snag old record so we can copy its data + $oldrec = $dnsdb->getRecLine('n', 'y', $rec->{record_id}); + last; # we've found one record that meets our criteria; Extras Are Irrelevant + } + + my @newblocks = $cidr->split($args{newmask}); + # Change the existing record with the new CIDR + my $up_res = rpc_updateRec(%args, val => $newblocks[0], id => $oldrec->{record_id}, defrec => 'n', revrec => 'y'); + my @ret; + # the update is assumed to have succeeded if it didn't fail. +##fixme: find a way to save and return "warning" states? + push @ret, {block => "$newblocks[0]", code => "OK", msg => $up_res}; + # And now add new record(s) for each of the new CIDR entries, reusing the old data + for (my $i = 1; $i <= $#newblocks; $i++) { + my $newval = "$newblocks[$i]"; + my @recargs = ('n', 'y', $oldrec->{rdns_id}, \$oldrec->{host}, \$oldrec->{type}, \$newval, + $oldrec->{ttl}, $oldrec->{location}, 0, ''); + my ($code, $msg) = $dnsdb->addRec(@recargs); + # Note failures here are not fatal; this should typically only ever be called by IPDB + push @ret, {block => "$newblocks[$i]", code => $code, msg => $up_res}; + } + # return an info hash in case of warnings doing the update or add(s) + return \@ret; + + } 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 update DNS records manually."; + } # done single-zone-contains-$cidr + + } else { + # multiple zones nominally "contain" $cidr + } # done $cidr-contains-zones + +} # done splitTemplate() + + +=head3 resizeTemplate + +Resize a template record based on a pair of passed CIDR addresses. + +=over 4 + +=item oldcidr + +The old CIDR to look for in the existing records + +=item newcidr + +The new CIDR + +=back + +=cut +# Resize a template according to an old/new CIDR pair +# Takes the old cidr in $args{oldcidr} and the new in $args{newcidr} +sub resizeTemplate { + my %args = @_; + + _commoncheck(\%args, 'y'); + + my $oldcidr = new NetAddr::IP $args{oldcidr}; + my $newcidr = new NetAddr::IP $args{newcidr}; + die "$oldcidr and $newcidr do not overlap" + unless $oldcidr->contains($newcidr) || $newcidr->contains($oldcidr); + $args{cidr} = $args{oldcidr}; + + my $up_res; + + # Location required so we don't turn up unrelated zones in getZonesByCIDR(). + # Caller should generally have some knowledge of this. + die "Need location\n" if !defined($args{location}); + + my $zonelist = $dnsdb->getZonesByCIDR(%args); + if (scalar(@$zonelist) == 0) { + # enhh.... WTF? + + } elsif (scalar(@$zonelist) == 1) { + my $zone = new NetAddr::IP $zonelist->[0]->{revnet}; + if ($zone->contains($oldcidr)) { + # Find record(s) matching the old and new CIDR + + my $sql = q( + SELECT record_id,host,val + FROM records + WHERE rdns_id = ? + AND type IN (12, 65280, 65281, 65282, 65283, 65284) + AND (val = ? OR val = ?) + ORDER BY masklen(inetlazy(val)) ASC + ); + my $sth = $dnsdb->{dbh}->prepare($sql); + $sth->execute($zonelist->[0]->{rdns_id}, "$oldcidr", "$newcidr"); + my $upd_id; + my $oldhost; + while (my ($recid, $host, $val) = $sth->fetchrow_array) { + my $tcidr = NetAddr::IP->new($val); + if ($tcidr == $newcidr) { + # Match found for new CIDR. Delete this record. + $up_res = $dnsdb->delRec('n', 'y', $recid); + } else { + # Update this record, then exit the loop + $up_res = rpc_updateRec(%args, val => $newcidr, id => $recid, defrec => 'n', revrec => 'y'); + last; + } + # Your llama is on fire + } + $sth->finish; + + return "Template record for $oldcidr changed to $newcidr."; + + } 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 update DNS records manually."; + } # done single-zone-contains-$cidr + + } else { + # multiple zones nominally "contain" $cidr + } + + return $up_res; +} # done resizeTemplate() + + +=head3 templatesToRecords + +Convert one or more template records to individual IP records, expanding the template as would be done on +export. + +=over 4 + +=item templates + +A list/array of CIDR addresses to search for for conversion. + +=back + +=cut +# Convert one or more template records to a set of individual IP records. Expands the template. +# Handle the case of nested templates, although the primary caller (IPDB) should not be +# able to generate records that would trigger that case. +# Accounts for existing PTR or A+PTR records same as on-export template expansion. +# Takes a list of templates and a bounding CIDR? +sub templatesToRecords { + my %args = @_; + + _commoncheck(\%args, 'y'); + + my %iplist; + my @retlist; + + # Location required so we don't turn up unrelated zones + die "Need location\n" if !defined($args{location}); + + my $zsth = $dnsdb->{dbh}->prepare("SELECT rdns_id,group_id FROM revzones WHERE revnet >>= ? AND location = ?"); + # Going to assume template records with no expiry + # Also note IPv6 template records don't expand sanely the way v4 records do + my $recsth = $dnsdb->{dbh}->prepare(q( + SELECT record_id, domain_id, host, type, val, ttl, location + FROM records + WHERE rdns_id = ? + AND type IN (12, 65280, 65282, 65283) + AND inetlazy(val) <<= ? + ORDER BY masklen(inetlazy(val)) DESC + )); + my $insth = $dnsdb->{dbh}->prepare("INSERT INTO records (domain_id, rdns_id, host, type, val, ttl, location)". + " VALUES (?,?,?,?,?,?,?)"); + my $delsth = $dnsdb->{dbh}->prepare("DELETE FROM records WHERE record_id = ?"); + my %typedown = (12 => 12, 65280 => 65280, 65281 => 65281, 65282 => 12, 65283 => 65280, 65284 => 65281); + + my @checkrange; + + local $dnsdb->{dbh}->{AutoCommit} = 0; + local $dnsdb->{dbh}->{RaiseError} = 1; + + eval { + foreach my $template (@{$args{templates}}) { + $zsth->execute($template, $args{location}); + my ($zid,$zgrp) = $zsth->fetchrow_array; + if (!$zid) { + push @retlist, {$template, "Zone not found"}; + next; + } + $recsth->execute($zid, $template); + while (my ($recid, $domid, $host, $type, $val, $ttl, $loc) = $recsth->fetchrow_array) { + # Skip single IPs with PTR or A+PTR records + if ($type == 12 || $type == 65280) { + $iplist{"$val/32"}++; + next; + } + my @newips = NetAddr::IP->new($template)->split(32); + $type = $typedown{$type}; + foreach my $ip (@newips) { + next if $iplist{$ip}; + my $newhost = $host; + $dnsdb->_template4_expand(\$newhost, $ip->addr); + $insth->execute($domid, $zid, $newhost, $type, $ip->addr, $ttl, $loc); + $iplist{$ip}++; + } + $delsth->execute($recid); + $dnsdb->_log(group_id => $zgrp, domain_id => $domid, rdns_id => $zid, + entry => "$template converted to individual $typemap{$type} records"); + push @retlist, "$template converted to individual records"; + } # record fetch + } # foreach passed template CIDR + + $dnsdb->{dbh}->commit; + }; + if ($@) { + die "Error converting a template record to individual records: $@"; + } + + return \@retlist; + +} # done templatesToRecords() + + +=head3 delRec + +Delete a record. + +=over 4 + +=item defrec + +Default/live records flag. Accepts C and C. + +=item revrec + +Forward/reverse flag. Accepts C and C. Used for logging to pick the "primary" zone of the record. + +=item id + +The record to delete. + +=back + +=cut +sub delRec { + my %args = @_; + + _commoncheck(\%args, 'y'); + + _reccheck(\%args); + + my ($code, $msg) = $dnsdb->delRec($args{defrec}, $args{revrec}, $args{id}); + + die "$msg\n" if $code eq 'FAIL'; + return $msg; +} + + +=head3 delByCIDR + +Delete a record by CIDR address. + +=over 4 + +=item cidr + +The CIDR address for the record or record group to delete. + +=back + +B + +=over 4 + +=item delforward (default 0/off) + +Delete the matching A record on A+PTR and similar metarecords. + +=item delsubs (default 0/off) + +Delete all records within C. Send C if desired, otherwise it reverts to default even for other +otherwise "true" values. + +=item parpatt + +Template pattern to add a replacement record if the delete removes all records from a reverse zone. + +=back + +=cut +sub delByCIDR { + my %args = @_; + + _commoncheck(\%args, 'y'); + + # Caller may pass 'n' in delsubs. Assume it should be false/undefined + # unless the caller explicitly requested 'yes' + $args{delsubs} = 0 if !$args{delsubs} || $args{delsubs} ne 'y'; + + # Don't delete the A component of an A+PTR by default + $args{delforward} = 0 if !$args{delforward}; + + # Location required so we don't turn up unrelated zones in getZonesByCIDR(). + die "Need location\n" if !defined($args{location}); + + # quick sanity-check version + die "CIDR is either poorly formed or not an IP/netblock at all\n" if !DNSDB::_maybeip(\$args{cidr}); + my $cidr = new NetAddr::IP $args{cidr}; + die "CIDR is not a valid IP/netblock\n" if !$cidr; + + # much like addOrUpdateRevRec() + 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 + my $zone = new NetAddr::IP $zonelist->[0]->{revnet}; + if ($zone->contains($cidr)) { + if ($args{delsubs}) { + # Delete ALL EVARYTHING!!one11!! in $args{cidr} + + # Deleting a small $args{cidr} from a large reverse zone will sometimes + # silently fail by not finding the appropriate record(s). Prepend a + # Postgres CIDR operator to assist in filtering + my $filt = "<<= $args{cidr}"; + + my $reclist = $dnsdb->getRecList(rpc => 1, defrec => 'n', revrec => 'y', id => $zonelist->[0]->{rdns_id}, + filter => $filt, offset => 'all'); + + 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 { +##fixme: AAAA+PTR? + 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. + rpc_addRec(defrec => 'n', revrec => 'y', parent_id => $zonelist->[0]->{rdns_id}, + type => ($zone->{isv6} ? 65284 : 65283), address => "$cidr", name => $args{parpatt}, %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 != 128 ? "$cidr" : $cidr->addr) : + ($cidr->masklen != 32 ? "$cidr" : $cidr->addr) ); + my $reclist = $dnsdb->getRecList(rpc => 1, defrec => 'n', revrec => 'y', location => $args{location}, + id => $zonelist->[0]->{rdns_id}, filter => $filt, sortby => 'val', sortorder => 'DESC', offset => 'all'); + 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) + # 2018/09/18 found an edge case, of course; if you've hacked IPDB to allow branched master + # blocks you *can* end up with nested reverse zones, in which case deleting a record in one + # may axe records in the other. dunno if it affects cidr-in-large axes recs-in-smaller, but + # I have an active failure for cidr-in-smaller axes recs-in-larger. eeep. + foreach my $zdata (@$zonelist) { + my $reclist = $dnsdb->getRecList(rpc => 1, 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) ); +# rpc_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? + # edge case: if we have nested zones, make sure that we do not delete records outside of + # the passed $cidr. This is horrible-ugly-bad, especially when said out-of-scope records + # constitute key core network names... +##fixme: should this check be moved into getRecList as a search restriction of some kind? +# cf args{filter}, but we really need to leverage the DB's IP type handling for this to be worthwhile + my $rcidr = new NetAddr::IP $rec->{val}; + next unless $cidr->contains($rcidr); + 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. + rpc_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() + + +=head3 delRevSet + +Delete a set of single-IP records similar to updateRevSet + +=over 4 + +=item cidrlist + +Simple comma-separated string containing the IP addresses that should be removed. + +=back + +=cut +# Batch-delete a set of reverse entries similar to updateRevSet +sub delRevSet { + my %args = @_; + + _commoncheck(\%args, 'y'); + + my @ret; + # loop over passed CIDRs in args{cidrlist} + foreach my $cidr (split(',', $args{cidrlist})) { + push @ret, delByCIDR(cidr => $cidr, %args) + } + + return \@ret; +} # end delRevSet() + +#sub getLogCount {} +#sub getLogEntries {} + + +=head3 getRevPattern + +Get the pattern that would be applied to IPs in a CIDR range that do not have narrower patterns or separate +individual reverse entries. + +=over 4 + +=item cidr + +The CIDR address range to find a pattern for. + +=item group + +The group to restrict reverse zone matches to. + +=item location + +The DNS view/location to restrict record matches to. + +=back + +=cut +sub getRevPattern { + my %args = @_; + + _commoncheck(\%args, 'y'); + + return $dnsdb->getRevPattern($args{cidr}, location => $args{location}, group => $args{group}); +} + + +=head3 getRevSet + +Retrieve the set of per-IP reverse records within a CIDR range, if any. + +Returns a list of hashes. + +=over 4 + +=item cidr + +The CIDR address range to find a pattern for. + +=item group + +The group to restrict reverse zone matches to. + +=item location + +The DNS view/location to restrict record matches to. + +=back + +=cut +sub getRevSet { + my %args = @_; + + _commoncheck(\%args, 'y'); + + return $dnsdb->getRevSet($args{cidr}, location => $args{location}, group => $args{group}); +} + + +=head3 getTypelist + +Retrieve a list of record types suitable for a dropdown form field. Returns only record types currently +supported by DNSAdmin. + +Returns a list of hashes. + +=over 4 + +=item recgroup + +Flag argument to determine which record types will be returned. Values not listed fall back to C. + +=over 4 + +=item r + +Logical records commonly found in reverse zones (includes A+PTR and related metatypes) + +=item l + +Records that can actually be looked up in the DNS. + +=item f + +Logical records commonly found in forward zones (includes A+PTR and similar metatypes that include a forward +record component). Append C to exclude the metatypes. + +=back + +=item selected + +Optional flag argument if a particular type should be "selected". Sets the C key on that entry. Note +that the passed type will always be present in the returned list, even if it wouldn't be otherwise - eg, PTR +template if C is set to C, or SRV if C is set to C. + +=back + +=cut +sub getTypelist { + my %args = @_; + _commoncheck(\%args, 'y'); + + $args{selected} = $reverse_typemap{A} if !$args{selected}; + + return $dnsdb->getTypelist($args{recgroup}, $args{selected}); +} + + +=head3 getTypemap + +Return DNS record type hash mapping DNS integer type values to text names + +=cut +sub getTypemap { + my %args = @_; + _commoncheck(\%args, 'y'); + return \%typemap; +} + + +=head3 getReverse_typemap + +Return DNS record type hash mapping text names to integer type values + +=cut +sub getReverse_typemap { + my %args = @_; + _commoncheck(\%args, 'y'); + return \%reverse_typemap; +} + +#sub parentID {} +#sub isParent {} + + +=head3 zoneStatus + +Get or set the status of a zone. Returns the status of the zone. + +=over 4 + +=item zoneid + +The ID of the zone to get or set status on + +=back + +B + +=over 4 + +=item reverse + +Set to C if you want to get/set the status for a reverse zone + +=item status + +Pass C<0> or C to set the zone to inactive; C<1> or C to set it to active + +=back + +=cut +sub zoneStatus { + my %args = @_; + + _commoncheck(\%args, 'y'); + + $args{reverse} = 'n' if !$args{reverse} || $args{reverse} ne 'y'; + my @arglist = ($args{zoneid}, $args{reverse}); + push @arglist, $args{status} if defined($args{status}); + + my $status = $dnsdb->zoneStatus(@arglist); +} + + +=head3 getZonesByCIDR + +Get a list of reverse zones within a passed CIDR block. Returns a list of hashes. + +=over 4 + +=item cidr + +The CIDR range to look for reverse zones in + +=back + +=cut + +# 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; +} + + +# and we're done. close the POD + +#back Index: branches/cname-collision/dns-upd-1.2.6.sql =================================================================== --- branches/cname-collision/dns-upd-1.2.6.sql (revision 936) +++ branches/cname-collision/dns-upd-1.2.6.sql (revision 936) @@ -0,0 +1,19 @@ +-- SQL to update DNS DB schema for 1.2.6 + +-- Allow zones to be duplicated, so long as each version is in a unique location +ALTER TABLE ONLY domains + DROP CONSTRAINT domains_pkey; +ALTER TABLE ONLY domains + ADD PRIMARY KEY (domain,default_location); + +ALTER TABLE ONLY revzones + DROP CONSTRAINT revzones_pkey; +ALTER TABLE ONLY revzones + ADD PRIMARY KEY (revnet,default_location); + +-- MIA unique constraint to match domains table. Arguably not strictly necessary. +ALTER TABLE ONLY revzones + ADD CONSTRAINT revzones_rdns_id_key UNIQUE (rdns_id); + +-- Update dbversion +UPDATE misc SET value='1.2.6' WHERE key='dbversion'; Index: branches/cname-collision/dns-upd-1.4.0.sql =================================================================== --- branches/cname-collision/dns-upd-1.4.0.sql (revision 936) +++ branches/cname-collision/dns-upd-1.4.0.sql (revision 936) @@ -0,0 +1,22 @@ +-- Updates introduced in 1.4.0 schema + +-- Cross-reference field for collapsing large blocks of related log entries +ALTER TABLE log ADD COLUMN logparent integer; +-- As a separate statement Just In Case +UPDATE log SET logparent = 0; +ALTER TABLE log ALTER COLUMN logparent SET DEFAULT 0; +ALTER TABLE log ALTER COLUMN logparent SET NOT NULL; +CREATE INDEX log_logparent_index ON log(logparent); + +-- Missing indexes on the log table; should shave the search/filter +-- time somewhat on large installs. +CREATE INDEX log_domain_id_index ON log(domain_id); +CREATE INDEX log_user_id_index ON log(user_id); +CREATE INDEX log_group_id_index ON log(group_id); +CREATE INDEX log_rdns_id_index ON log(rdns_id); + +-- Matching index on revzones +CREATE INDEX revzones_rdns_id_index ON revzones(rdns_id); + +-- Update dbversion +UPDATE misc SET value='1.4.0' WHERE key='dbversion'; Index: branches/cname-collision/dns-upd-1.4.1.sql =================================================================== --- branches/cname-collision/dns-upd-1.4.1.sql (revision 936) +++ branches/cname-collision/dns-upd-1.4.1.sql (revision 936) @@ -0,0 +1,33 @@ +-- Update formally known types from https://www.iana.org/assignments/dns-parameters/ +COPY rectypes (val, name, stdflag, listorder, alphaorder) FROM stdin; +52 TLSA 5 255 255 +53 SMIMEA 5 255 255 +56 NINFO 5 255 255 +57 RKEY 5 255 255 +58 TALINK 5 255 255 +59 CDS 5 255 255 +60 CDNSKEY 5 255 255 +61 OPENPGPKEY 5 255 255 +62 CSYNC 5 255 255 +104 NID 5 255 255 +105 L32 5 255 255 +106 L64 5 255 255 +107 LP 5 255 255 +108 EUI48 5 255 255 +109 EUI64 5 255 255 +255 * 5 255 255 +256 URI 5 255 255 +257 CAA 5 255 255 +258 AVC 5 255 255 +\. + +-- Add a new pseudotype instead of overloading CNAME handling +COPY rectypes (val, name, stdflag, listorder, alphaorder) FROM stdin; +65300 ALIAS 2 16 255 +\. + +-- And add a place to cache some data for the new type +ALTER TABLE records ADD COLUMN auxdata text; + +-- Update dbversion +UPDATE misc SET value='1.4.1' WHERE key='dbversion'; Index: branches/cname-collision/dns.cgi =================================================================== --- branches/cname-collision/dns.cgi (revision 936) +++ branches/cname-collision/dns.cgi (revision 936) @@ -0,0 +1,2621 @@ +#!/usr/bin/perl -w -T +# Main web UI script for DeepNet DNS Administrator +## +# $Id$ +# Copyright 2008-2022 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 '-ip_match'; +use Net::DNS; +use DBI; + +use Data::Dumper; + +#sub is_tainted { +# # from perldoc perlsec +# return ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 }; +#} + +# Taint-safe (ish) voodoo to push "the directory the script is in" into @INC. +# See https://secure.deepnet.cx/trac/dnsadmin/ticket/80 for more gory details on how we got here. +use File::Spec (); +use File::Basename (); +my $path; +BEGIN { + $path = File::Basename::dirname(File::Spec->rel2abs($0)); + if ($path =~ /(.*)/) { + $path = $1; + } +} +use lib $path; + +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 || !$session->param('uid') || !$dnsdb->userStatus($session->param('uid')) ) { + $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 +# allow <>= so searches can use the Postgres CIDR operators +# allow , for things like DMARC records +$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 = "/dns.cgi" if !$uri_self || $uri_self eq '/'; +$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})) { + $session->param($webvar{page}.'filter', '') if !$session->param($webvar{page}.'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}); + $curgroup = $userdata->{group_id}; + +# 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} =~ /\?/ && $webvar{target} !~ /page=login/) { + 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') { + $webvar{domain} = lc($webvar{domain}) if $dnsdb->{lowercase}; + $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"); + fill_loclist($curgroup, $webvar{defloc} ? $webvar{defloc} : ''); + + # 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(defrec => $webvar{defrec}, revrec => $webvar{revrec}, + id => $webvar{id}, filter => $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' || $webvar{page} eq 'bulkrev') { + # Bulk operations on domains. Note all but group move are available on the domain list. + + changepage(page => "domlist", errmsg => "You are not permitted to make bulk zone changes") + unless ($permissions{admin} || $permissions{domain_edit} || $permissions{domain_create} || $permissions{domain_delete}); + + fill_grouplist("grouplist"); + + $page->param(fwdzone => $webvar{page} eq 'bulkdomain'); + + my $count = $dnsdb->getZoneCount(revrec => ($webvar{page} eq 'bulkdomain' ? 'n' : 'y'), + 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 => ($webvar{page} eq 'bulkdomain' ? 'n' : 'y'), + curgroup => $curgroup, offset => $offset); + my $rownum = 0; + foreach my $dom (@{$domlist}) { + delete $dom->{status}; + delete $dom->{group}; + $dom->{newrow} = (++$rownum) % 5 == 0 && $rownum != $perpage; + } + + $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 'confirmbulkdom' || $webvar{page} eq 'confirmbulkrev') { +} elsif ($webvar{page} eq 'confirmbulk') { + + changepage(page => "domlist", errmsg => "You are not permitted to make bulk zone changes") + unless ($permissions{admin} || $permissions{domain_edit} || $permissions{domain_create} || $permissions{domain_delete}); + + $page->param(bulkaction => $webvar{bulkaction}); + $page->param(destgroup => $webvar{destgroup}); + my @zlist; + my $rownum = 0; + +##fixme: this could probably be made more efficient, since this looks up 2 zone names for +# each comparison during sort rather than slurping them in bulk once before doing the sort + # sort zones by zone name, not ID + sub zsort { + my $tmpa = ($a =~ /^dom/ ? $dnsdb->domainName($webvar{$a}) : $dnsdb->revName($webvar{$a}) ); + my $tmpb = ($b =~ /^dom/ ? $dnsdb->domainName($webvar{$b}) : $dnsdb->revName($webvar{$b}) ); + return $tmpa cmp $tmpb; + } + # eugh. can't see a handy way to sort this mess by zone name the way it is on the submitting page. :( + foreach my $input (sort zsort grep(/^(?:dom|rev)_/, keys %webvar) ) { + next unless $input =~ /^(dom|rev)_\d+$/; + my $fr = $1; + my %row = (zoneid => $webvar{$input}, + zone => ($fr eq 'dom' ? $dnsdb->domainName($webvar{$input}) : $dnsdb->revName($webvar{$input}) ), + zvarname => $input, + newrow => ( (++$rownum) % 5 == 0 && $rownum != $perpage), + ); + push @zlist, \%row; + } + $page->param(domtable => \@zlist); + +} 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; + } + + # skip the changes if user did not confirm + my $wasrev = grep /^rev_/, keys %webvar; + changepage(page => ($wasrev ? "bulkrev" : "bulkdomain")) unless $webvar{okdel} eq 'y'; + + changepage(page => "domlist", errmsg => "You are not permitted to make bulk zone changes") + unless ($permissions{admin} || $permissions{domain_edit} || $permissions{domain_create} || $permissions{domain_delete}); + + # per-action scope checks + if ($webvar{bulkaction} eq 'move') { + changepage(page => "domlist", errmsg => "You are not permitted to bulk-move zones") + 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} zones") + unless ($permissions{admin} || $permissions{domain_edit}); + $page->param(action => "$webvar{bulkaction} zones"); + } elsif ($webvar{bulkaction} eq 'delete') { + changepage(page => "domlist", errmsg => "You are not permitted to bulk-delete zones") + unless ($permissions{admin} || $permissions{domain_delete}); + $page->param(action => "$webvar{bulkaction} zones"); + } 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 my $input (keys %webvar) { + my %row; + next unless $input =~ /^(dom|rev)_\d+$/; + my $fr = $1; + # second security check - does the user have permission to meddle with this domain? + if (!check_scope(id => $webvar{$input}, type => ($fr eq 'dom' ? 'domain' : 'revzone'))) { + $row{domerr} = "You are not permitted to make changes to the requested zone"; + $row{domain} = $webvar{$input}; + push @bulkresults, \%row; + next; + } + $row{domain} = ($fr eq 'dom' ? $dnsdb->domainName($webvar{$input}) : $dnsdb->revName($webvar{$input})); + + # Do the $webvar{bulkaction} + my ($code, $msg); + ($code, $msg) = $dnsdb->changeGroup(($fr eq 'dom' ? 'domain' : 'revzone'), $webvar{$input}, $webvar{destgroup}) + if $webvar{bulkaction} eq 'move'; + if ($webvar{bulkaction} eq 'deactivate' || $webvar{bulkaction} eq 'activate') { + my $stat = $dnsdb->zoneStatus($webvar{$input}, ($fr eq 'dom' ? 'n' : 'y'), + ($webvar{bulkaction} eq 'activate' ? 'domon' : 'domoff')); + $code = (defined($stat) ? 'OK' : 'FAIL'); + $msg = (defined($stat) ? $DNSDB::resultstr : $DNSDB::errstr); + } + ($code, $msg) = $dnsdb->delZone($webvar{$input}, ($fr eq 'dom' ? 'n' : 'y')) + 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}); + # kick user out if user disabled self + # arguably there should be a more specific error message for this case + changepage(page=> 'login', sessexpired => 1) if $webvar{id} == $session->param('uid'); + $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 { + + my $permstring = 'i'; # start with "inherit" + + # Remap passed checkbox states from webvar to integer/boolean values in %newperms + foreach (@permtypes) { + $newperms{$_} = (defined($webvar{$_}) && $webvar{$_} eq 'on' ? 1 : 0); + } + + # Check for chained permissions. Some permissions imply others; make sure they get set. + foreach (keys %permchains) { + if ($newperms{$_} && !$newperms{$permchains{$_}}) { + $newperms{$permchains{$_}} = 1; + } + } + + # check for possible priviledge escalations + if (!$permissions{admin}) { + if ($webvar{perms_type} eq 'inherit') { + # Group permissions are only relevant if inheriting + my %grpperms; + $dnsdb->getPermissions('group', $curgroup, \%grpperms); + my $ret = $dnsdb->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 $ret = $dnsdb->comparePermissions(\%newperms, \%permissions); + if ($ret eq '>' || $ret eq '!') { + # User's new permissions are not a subset or equivalent to previous. Can't add + # permissions user doesn't currently have, so we force custom. + $webvar{perms_type} = 'custom'; + $alterperms = 1; + } + } + +##fixme: +# could possibly factor building the meat of the permstring out of this if/elsif set, so +# as to avoid running around @permtypes quite so many times + if ($webvar{perms_type} eq 'custom') { + $permstring = 'C:'; + foreach (@permtypes) { + if ($permissions{admin} || $permissions{$_}) { + $permstring .= ",$_" if defined($webvar{$_}) && $webvar{$_} eq 'on'; + } else { + $newperms{$_} = 0; # remove permissions user doesn't currently have + } + } + $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); + } + # Recheck chained permissions, in the supposedly impossible case that the removals + # above mangled one of them. This *should* be impossible via normal web UI operations. + 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 $permissions{admin} && $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(group => $curgroup, desc => $webvar{locname}, + comments => $webvar{comments}, iplist => $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') { + + if ($webvar{qfor}) { + $webvar{qfor} =~ s/^\s*//; + $webvar{qfor} =~ s/\s*$//; + $page->param(qfor => $webvar{qfor}); + } + if ($webvar{resolver}) { + $webvar{resolver} =~ s/^\s*//; + $webvar{resolver} =~ s/\s*$//; + $page->param(resolver => $webvar{resolver}); + } + $page->param(typelist => $dnsdb->getTypelist('l', ($webvar{type} ? $webvar{type} : undef))); + $page->param(nrecurse => $webvar{nrecurse}) if $webvar{nrecurse}; + + 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) { +##fixme: Net::DNS has made changes somewhere between 0.66something (~~ Debian wheezy) and +# 0.81 (~~ Debian jessie) that cause taint failures when providing a hostname as a nameserver +# for AXFR. A proper fix may boil down to "split AXFR into its own script". Feh. +# For now, we'll just convert the requested AXFR host to an IP, and pass that down the chain instead. + my $nsip = gethostbyname($webvar{ifrom}); + use Socket; + $nsip = inet_ntoa($nsip); + # strangely enough we don't seem to need to detaint: + #($nsip) = ($nsip =~ /^([a-fA-F0-9:.]+)$/); + my %row; + my ($code,$msg) = $dnsdb->importAXFR($nsip, $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}; +##fixme: don't include username on out-of-scope users + $page->param(logfor => 'user '.($id ? $dnsdb->userFullName($id) : $webvar{fname})); + } 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}; + + # Done here since we want to allow more arbitrary blobs in the log filter + if (defined($webvar{logfilter})) { + $session->param('logfilter', '') if !$session->param('logfilter'); + if ($webvar{logfilter} ne $session->param('logfilter')) { + $uri_self =~ s/\&offset=[^&]//; + $offset = 0; + } + $session->param('logfilter', $webvar{logfilter}) + } + my $logfilter = $session->param('logfilter'); + $filter = $logfilter; + $page->param(logfilter => $logfilter); + + my $lcount = $dnsdb->getLogCount(id => $id, group => $logingroup, fname => $webvar{fname}, + logtype => $webvar{ltype}, filter => $logfilter); + if (!$lcount) { + $page->param(errmsg => $dnsdb->errstr); + $lcount = 0; + } + + $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','domain','revzone','entry','stamp'); + my %colnames = (fname => 'Name', domain => 'Forward zone', revzone => 'Reverse zone', + 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, group => $logingroup, fname => $webvar{fname}, + logtype => $webvar{ltype}, + offset => $webvar{offset}, sortby => $sortby, sortorder => $sortorder, filter => $logfilter); + if (!$logentries) { + $page->param(errmsg => $dnsdb->errstr); + } else { + # undef $logentries is inexplicably puking instead of showing "no entries found", + # like all the rest of the methods that return a list the same way. idunno... + $page->param(logentries => $logentries); + } + +##fixme: +# - 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: ; + +} elsif ($webvar{page} eq 'recsearch') { + + # we do this for the domain and record list filter/search - it should be extremely rare to + # need to search on characters outside this set until we get into IDNs + # note this is a little larger due to template records + # allow <>= so searches can use the Postgres CIDR operators + # allow , for things like DMARC records + $webvar{searchfor} =~ s{[^a-zA-Z0-9_.,:\@%<>=/-]}{}g if $webvar{searchfor}; + + # save the search in the session, same as the "filter" in various other lists... + if (defined($webvar{searchfor})) { + if ($session->param('recsearch') && $webvar{searchfor} ne $session->param('recsearch')) { + $uri_self =~ s/\&offset=[^&]//; + $offset = 0; + } + $session->param(recsearch => $webvar{searchfor}); + } + my $searchfor = $session->param('recsearch'); + + $sortby = 'host'; + $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'); + + # some magic to label and linkify the column headers for sorting + my @cols = ('domain','revzone','host','type','val'); + my %colheads = (domain => "Domain (Group)", revzone => "Reverse zone (Group)", host => "Host", + type => "Type", val => "IP/value"); + # only users allowed to see location/view data get this column + if ($permissions{admin} || $permissions{location_view}) { + $colheads{location} = "Location"; + push @cols, 'location'; + } + fill_colheads($sortby, $sortorder, \@cols, \%colheads); + + # pgcount.tmpl + my $count = $dnsdb->recSearchCount(searchfor => $searchfor, group => $logingroup); + fill_pgcount($count, "records"); + fill_fpnla($count); + + # and a bit for fpnla.tmpl + $page->param(curpage => $webvar{page}); + + $page->param(searchfor => $searchfor); + my $recset = $dnsdb->recSearch(searchfor => $searchfor, group => $logingroup, offset => $webvar{offset}, + sortby => $sortby, sortorder => $sortorder); + $page->param(searchresults => $recset); + +} # 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}?"); +# fill in the generalized path-to-instance + $page->param(webpath => ($ENV{SCRIPT_NAME} =~ m|(/.+)/[^/]+$|)[0]); +} + +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(serial => $soa->{serial}); + $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) { + if ($typemap{$rec->{type}}) { + $rec->{type} = $typemap{$rec->{type}}; + } else { + $rec->{type} = "TYPE$rec->{type}"; + } + $rec->{fwdzone} = $rev eq 'n'; + $rec->{ttl} = '(auto)' if $rec->{ttl} == -1; + $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 { + # 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') { + $page->param(typelist => $dnsdb->getTypelist($webvar{revrec}, $webvar{type})); + 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}, 'y')); + $zname =~ s|\d*/\d+$||; + $page->param(address => ($webvar{address} ? $webvar{address} : $zname)); + $page->param(typelist => $dnsdb->getTypelist($webvar{revrec}, + $webvar{type} || ($zname =~ /:/ ? $reverse_typemap{'AAAA+PTR'} : $reverse_typemap{'A+PTR'}))); + } +# 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 my $rec (@$zonelist) { +# } + $page->param(domtable => $zonelist); +} # end listzones() + + +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: branches/cname-collision/dns.sql =================================================================== --- branches/cname-collision/dns.sql (revision 936) +++ branches/cname-collision/dns.sql (revision 936) @@ -0,0 +1,398 @@ +-- 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'; + +-- pre-pg8.3, this must be run as a superuser +CREATE LANGUAGE plpgsql; +-- it's required for: + +-- Return proper conversion of string to inet, or 0.0.0.0/0 if the string is +-- not a valid inet value. We need to do this to support "funky" records that +-- may not actually have valid IP address values. Used for ORDER BY +CREATE OR REPLACE FUNCTION inetlazy (rdata text) RETURNS inet AS $$ +BEGIN + RETURN CAST(rdata AS inet); +EXCEPTION + WHEN OTHERS THEN + RETURN CAST('0.0.0.0/0' AS inet); +END; +$$ LANGUAGE plpgsql; + + +-- 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.4.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, + 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, + 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 ''::character varying 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, + logparent integer NOT NULL DEFAULT 0 +); +CREATE INDEX log_domain_id_index ON log(domain_id); +CREATE INDEX log_user_id_index ON log(user_id); +CREATE INDEX log_group_id_index ON log(group_id); +CREATE INDEX log_rdns_id_index ON log(rdns_id); + +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, + auxdata text +); +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 https://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 +52 TLSA 5 255 255 +53 SMIMEA 5 255 255 +55 HIP 5 255 19 +56 NINFO 5 255 255 +57 RKEY 5 255 255 +58 TALINK 5 255 255 +59 CDS 5 255 255 +60 CDNSKEY 5 255 255 +61 OPENPGPKEY 5 255 255 +62 CSYNC 5 255 255 +63 ZONEMD 255 255 255 +64 SVCB 255 255 255 +65 HTTPS 255 255 255 +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 +104 NID 5 255 255 +105 L32 5 255 255 +106 L64 5 255 255 +107 LP 5 255 255 +108 EUI48 5 255 255 +109 EUI64 5 255 255 +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 +255 * 5 255 255 +256 URI 5 255 255 +257 CAA 1 17 255 +258 AVC 5 255 255 +259 DOA 255 255 255 +260 AMTRELAY 255 255 255 +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 +65300 ALIAS 2 16 255 +\. + +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 domains + ADD CONSTRAINT domains_pkey PRIMARY KEY ("domain", default_location); + +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 revzones + ADD CONSTRAINT revzones_rdns_id_key UNIQUE (rdns_id); + +ALTER TABLE ONLY revzones + ADD CONSTRAINT revzones_pkey PRIMARY KEY (revnet, default_location); + +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: branches/cname-collision/dnsadmin.spec =================================================================== --- branches/cname-collision/dnsadmin.spec (revision 936) +++ branches/cname-collision/dnsadmin.spec (revision 936) @@ -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: branches/cname-collision/dnsdb.conf =================================================================== --- branches/cname-collision/dnsdb.conf (revision 936) +++ branches/cname-collision/dnsdb.conf (revision 936) @@ -0,0 +1,83 @@ +# 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 + +## Export caching +# 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 + +## BIND export options +# Config fragment populated by exports from dnsadmin +#bind_export_zone_conf = /var/named/zones.conf +# Forward zone file path template +#bind_export_zone_path = /var/named/zones/%view/db.%zone +# Reverse zone file path template +#bind_export_reverse_zone_path = /var/named/zones/%view/db.%zone +# Export all hostnames as full dot-terminated FQDNs? +#bind_export_fqdn = 1 +# Short TTL for "autoexpiry" of records. Values between 1 and 10 or so may +# result in unresolveable names. 0 may be arbitrarily clamped to some saner +# value by third party caches. +#bind_export_autoexpire_ttl = 15 + +## DNS data template options +# publish .0 IP when expanding a template pattern +#template_skip_0 = 0 +# publish .255 IP when expanding a template pattern +#template_skip_255 = 0 + +## misc + +# flag to indicate if failed changes should be logged +#log_failures = 1 + +# number of entries to display in lists +#perpage = 25 + +# fold domain names and hostnames to lowercase? +# strictly speaking, DNS is case-insensitive, but some people insist on Capital Letters anyway. +#lowercase = 0 + +# Show formal .arpa zone name instead of the natural IP or CIDR for reverse zone names and records? +# Valid values are none, zone, record, or all +#showrev_arpa = zone + +# Let DNS server autosplit long TXT records however it pleases, or hand-generate the split points? +#autosplit = 1 + +## General RPC options +# may already be obsolete. how do we want to run RPC requests? +# bare socket, plain HTTP, or standard XMLRPC? +#rpcmode = http +# maximum number of FCGI requests to serve before reloading/restarting FCGI +#maxfcgi = 10 + +## 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: branches/cname-collision/export.pl =================================================================== --- branches/cname-collision/export.pl (revision 936) +++ branches/cname-collision/export.pl (revision 936) @@ -0,0 +1,35 @@ +#!/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; + +# push "the directory the script is in" into @INC +use FindBin; +use lib "$FindBin::RealBin/"; + +use DNSDB; + +my $dnsdb = new DNSDB; + +#open TINYDATA, ">small/tinydata"; +open TINYDATA, ">tinydata"; + +$dnsdb->export('tiny', *TINYDATA) or die "fatal: ".$dnsdb->errstr."\n"; Index: branches/cname-collision/index.shtml =================================================================== --- branches/cname-collision/index.shtml (revision 936) +++ branches/cname-collision/index.shtml (revision 936) @@ -0,0 +1,1 @@ + Index: branches/cname-collision/mergerecs =================================================================== --- branches/cname-collision/mergerecs (revision 936) +++ branches/cname-collision/mergerecs (revision 936) @@ -0,0 +1,228 @@ +#!/usr/bin/perl +# Merge matching forward and reverse A/PTR or AAAA/PTR pairs +## +# $Id$ +# Copyright 2014-2022 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 Net::DNS; +use DBI; + +use Data::Dumper; + +# Taint-safe (ish) voodoo to push "the directory the script is in" into @INC. +# See https://secure.deepnet.cx/trac/dnsadmin/ticket/80 for more gory details on how we got here. +use File::Spec (); +use File::Basename (); +my $path; +BEGIN { + $path = File::Basename::dirname(File::Spec->rel2abs($0)); + if ($path =~ /(.*)/) { + $path = $1; + } +} +use lib $path; + +use DNSDB; + +usage() if !$ARGV[0]; + +sub usage { + die qq(usage: mergerecs zone [domain] [--detail] + zone The primary zone to walk for records to try to merge. May be either + a reverse zone or a domain. + domain Optionally restrict record merges in a reverse zone to a specific + domain. + --detail Optional argument to add one log entry for each A+PTR pair merged + instead of a single generic entry. +); +} + +my $logdetail = 0; +my $matchdom = ''; + +my $pzone = shift @ARGV; +if (@ARGV) { + if ($ARGV[0] eq '--detail') { + $logdetail = 1; + } else { + $matchdom = shift @ARGV; + $logdetail = 1 if @ARGV && $ARGV[0] eq '--detail'; + } +} + +my $dnsdb = new DNSDB or die "Couldn't create DNSDB object: ".$DNSDB::errstr."\n"; +my $dbh = $dnsdb->{dbh}; + +# get userdata for log +($dnsdb->{logusername}, undef, undef, undef, undef, undef, $dnsdb->{logfullname}) = getpwuid($<); +$dnsdb->{logfullname} =~ s/,//g; +$dnsdb->{loguserid} = 0; # not worth setting up a pseudouser the way the RPC system does +$dnsdb->{logusername} = $dnsdb->{logusername}."/mergerecs"; +$dnsdb->{logfullname} = ($dnsdb->{logfullname} ? $dnsdb->{logfullname}."/mergerecs" : $dnsdb->{logusername}); + +# and now the meat + +# get zone ID +my $rev; +my $zid; +if ($pzone =~ /\.arpa$/ || $pzone =~ m{^[0-9./a-fA-F:]+$}) { + # first zone is a reverse zone + $rev = 'y'; + my $npzone; + if ($pzone =~ /\.arpa$/) { + my $msg; + ($msg, $npzone) = $dnsdb->_zone2cidr($pzone); + die "$pzone is not a valid reverse zone specification\n" if $msg eq 'FAIL'; + } else { + $npzone = new NetAddr::IP $pzone; + } + die "$pzone is not a valid reverse zone specification\n" if !$npzone; + $zid = $dnsdb->revID($npzone, ':ANY:'); +} else { + $rev = 'n'; + $zid = $dnsdb->domainID($pzone, ':ANY:'); +} +die "$pzone is not a zone in the database (".$dnsdb->errstr.")\n" if !$zid; + +# check the second arg. +my $fzid = $dnsdb->domainID($matchdom, ''); +die "$matchdom is not a domain in the database\n" if $matchdom && !$fzid; + +if ($rev eq 'n' && $matchdom) { + $fzid = 0; + $matchdom = ''; +} + +# group may or may not in fact be +my $group = $dnsdb->parentID(revrec => $rev, id => $zid, type => ($rev eq 'n' ? 'domain' : 'revzone') ); + +local $dbh->{AutoCommit} = 0; +local $dbh->{RaiseError} = 1; + +eval { + if ($rev eq 'n') { + # merge records in a forward zone + my $reclist = $dbh->prepare("SELECT host,val,type,record_id,ttl,location FROM records ". + "WHERE (type=1 OR type=28) AND domain_id = ?"); + my $findsth = $dbh->prepare("SELECT rdns_id,record_id,ttl FROM records ". + "WHERE host = ? AND val = ? AND type=12"); + my $mergesth = $dbh->prepare("UPDATE records SET rdns_id = ?, ttl = ?, type = ? WHERE record_id = ?"); + my $delsth = $dbh->prepare("DELETE FROM records WHERE record_id = ?"); + + $reclist->execute($zid); + my $nrecs = 0; + my @cloglist; + while (my ($host,$val,$type,$id,$ttl,$loc) = $reclist->fetchrow_array) { + my $etype = 12; + my $logentry; + $findsth->execute($host, $val); + my ($erdns,$erid,$ettl) = $findsth->fetchrow_array; + if ($erid) { + if ($type == 1) { # PTR -> A+PTR + $etype = 65280; + $logentry = "Merged A record with PTR record '$host A+PTR $val', TTL $ettl"; + } + if ($type == 28) { # PTR -> AAAA+PTR + $etype = 65281; + $logentry = "Merged AAAA record with PTR record '$host AAAA+PTR $val', TTL $ettl"; + } + $ettl = ($ettl < $ttl ? $ettl : $ttl); # use lower TTL + $mergesth->execute($erdns, $ettl, $etype, $id); + $delsth->execute($erid); + if ($logdetail) { + my $lid = $dnsdb->_log(group_id => $group, domain_id => $zid, rdns_id => $erdns, entry => $logentry); + push @cloglist, $lid; + print "$logentry\n"; + } + $nrecs++; + } + } # while + my $lpid = $dnsdb->_log(group_id => $group, domain_id => $zid, + entry => "Merged $nrecs A and AAAA records in $pzone with matching PTRs"); + # since unlike in most other operations, we only "know" the parent log entry *after* + # we're done entering all the child entries, we have to update the children with the parent ID + my $assoc = $dbh->prepare("UPDATE log SET logparent = ? WHERE log_id = ?"); + for my $lcid (@cloglist) { + $assoc->execute($lpid, $lcid); + } + print "Merged $nrecs A and AAAA records in $pzone with matching PTRs\n"; + + } else { + # merge records in a reverse zone + my $reclist = $dbh->prepare("SELECT host,val,type,record_id,ttl,location FROM records ". + "WHERE type=12 AND rdns_id = ?"); + my $findsth = $dbh->prepare("SELECT domain_id,type,record_id,ttl FROM records ". + "WHERE host = ? AND val = ? AND (type=1 OR type=28)"); + my $mergesth = $dbh->prepare("UPDATE records SET domain_id = ?, ttl = ?, type = ? WHERE record_id = ?"); + my $delsth = $dbh->prepare("DELETE FROM records WHERE record_id = ?"); + + $reclist->execute($zid); + my $nrecs = 0; + my @cloglist; + while (my ($host,$val,$type,$id,$ttl,$loc) = $reclist->fetchrow_array) { + if ($matchdom) { + next unless $host =~ /$matchdom$/; + } + my $ntype = 12; + my $logentry; + $findsth->execute($host, $val); + my ($edid,$etype,$erid,$ettl) = $findsth->fetchrow_array; + if ($erid) { + if ($etype == 1) { # PTR -> A+PTR + $ntype = 65280; + $logentry = "Merged PTR record with A record '$host A+PTR $val', TTL $ettl"; + } + if ($etype == 28) { # PTR -> AAAA+PTR + $ntype = 65281; + $logentry = "Merged PTR record with A record '$host AAAA+PTR $val', TTL $ettl"; + } + $ettl = ($ettl < $ttl ? $ettl : $ttl); # use lower TTL + $mergesth->execute($edid, $ettl, $ntype, $id); + $delsth->execute($erid); + if ($logdetail) { + my $lid = $dnsdb->_log(group_id => $group, domain_id => $edid, rdns_id => $zid, entry => $logentry); + push @cloglist, $lid; + print "$lid: $logentry\n"; + } + $nrecs++; + } + } # while + my $entry = "Merged $nrecs PTR records in $pzone with matching A or AAAA records".($fzid ? " in $matchdom" : ''); + my $lpid; + if ($fzid) { + $lpid = $dnsdb->_log(group_id => $group, domain_id => $fzid, rdns_id => $zid, entry => $entry); + } else { + $lpid = $dnsdb->_log(group_id => $group, rdns_id => $zid, entry => $entry); + } + # since unlike in most other operations, we only "know" the parent log entry *after* + # we're done entering all the child entries, we have to update the children with the parent ID + my $assoc = $dbh->prepare("UPDATE log SET logparent = ? WHERE log_id = ?"); + for my $lcid (@cloglist) { + $assoc->execute($lpid, $lcid); + } + print "$entry\n"; + } + + $dbh->commit; +}; +if ($@) { + $dbh->rollback; + die "Failure on record update/delete: $@\n"; +} Index: branches/cname-collision/notes =================================================================== --- branches/cname-collision/notes (revision 936) +++ branches/cname-collision/notes (revision 936) @@ -0,0 +1,340 @@ +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 +see also https://www.zytrax.com/books/dns/ch8/dname.html for comments and RFC +refs for rDNS delegation. note that even sub-/16 delegations can't just use +NS records, they need DNAME + +maybe consider a permissioned metatype to allow for delegated customer self-management of eg /29 or /28 blocks? + + +full subdomain NS records need to be seconded into parent zone on BIND export + + +BIND reference for views/locations/split-horizon +https://kb.isc.org/article/AA-00851/0/Understanding-views-in-BIND-9-by-example.html Index: branches/cname-collision/reverse-patterns.html =================================================================== --- branches/cname-collision/reverse-patterns.html (revision 936) +++ branches/cname-collision/reverse-patterns.html (revision 936) @@ -0,0 +1,161 @@ + + + + + Reverse DNS Template Reference + + + + + + +
+

Reverse DNS Template Reference

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Whole-IP patterns
Substitution patternExample expansion using 192.168.23.45
Dashed IP%i192-168-23-45
Reverse dashed IP%r45-23-168-192
Hex-coded IP%hc0a8172d
Decimal IP%d323241453
+ %i and %r also allow explicitly defining the separator; eg %.i or %_r. Dot/period (.), dash (-), + and underscore (_) 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. +
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
 
Extensions
Substitution patternExample expansion using 192.168.23.40/29
Network/
gateway/
broadcast		%ngb% + customer-%i%ngb%.example.com
+ 192.168.23.40 -> customer-net.example.com
+ 192.168.23.41 -> customer-gw.example.com
+ 192.168.23.42 -> customer-192-168-23-42.example.com
+ 192.168.23.43 -> customer-192-168-23-43.example.com
+ 192.168.23.44 -> customer-192-168-23-44.example.com
+ 192.168.23.45 -> customer-192-168-23-45.example.com
+ 192.168.23.46 -> customer-192-168-23-46.example.com
+ 192.168.23.47 -> customer-bcast.example.com +
+ Any IP pattern component is blanked on the network, gateway, and broadcast IPs when this is + used.
+ Each of n, g, or b can be prefixed with a dash, eg %-ng-b% or %n-g-b%, which will + blank that entire entry instead of substituting net, gw, or bcast. +
n'th usable IP%c + customer-%3d-%c.example.com
+ 192.168.23.40 -> customer-23.example.com
+ 192.168.23.41 -> customer-23.example.com
+ 192.168.23.42 -> customer-23-1.example.com
+ 192.168.23.43 -> customer-23-2.example.com
+ 192.168.23.44 -> customer-23-3.example.com
+ 192.168.23.45 -> customer-23-4.example.com
+ 192.168.23.46 -> customer-23-5.example.com
+ 192.168.23.47 -> customer-23.example.com +
+ c can be prefixed with a dash (%-c), which starts the numbering from the conventional gateway IP + instead. (.41 above would be 1, .42 2, etc, finishing with 6 at .46). +
n'th natural IP%x + customer-23-%x.example.com
+ 192.168.23.40 -> customer-23-1.example.com
+ 192.168.23.41 -> customer-23-2.example.com
+ 192.168.23.42 -> customer-23-3.example.com
+ 192.168.23.43 -> customer-23-4.example.com
+ 192.168.23.44 -> customer-23-5.example.com
+ 192.168.23.45 -> customer-23-6.example.com
+ 192.168.23.46 -> customer-23-7.example.com
+ 192.168.23.47 -> customer-23-8.example.com +
+ + +
+ + Index: branches/cname-collision/templates/adddomain.tmpl =================================================================== --- branches/cname-collision/templates/adddomain.tmpl (revision 936) +++ branches/cname-collision/templates/adddomain.tmpl (revision 936) @@ -0,0 +1,5 @@ + + + + + Index: branches/cname-collision/templates/addgroup.tmpl =================================================================== --- branches/cname-collision/templates/addgroup.tmpl (revision 936) +++ branches/cname-collision/templates/addgroup.tmpl (revision 936) @@ -0,0 +1,5 @@ + + + + + Index: branches/cname-collision/templates/addrec.tmpl =================================================================== --- branches/cname-collision/templates/addrec.tmpl (revision 936) +++ branches/cname-collision/templates/addrec.tmpl (revision 936) @@ -0,0 +1,5 @@ + + + + + Index: branches/cname-collision/templates/addrevzone.tmpl =================================================================== --- branches/cname-collision/templates/addrevzone.tmpl (revision 936) +++ branches/cname-collision/templates/addrevzone.tmpl (revision 936) @@ -0,0 +1,5 @@ + + + + + Index: branches/cname-collision/templates/adduser.tmpl =================================================================== --- branches/cname-collision/templates/adduser.tmpl (revision 936) +++ branches/cname-collision/templates/adduser.tmpl (revision 936) @@ -0,0 +1,5 @@ + + + + + Index: branches/cname-collision/templates/axfr.tmpl =================================================================== --- branches/cname-collision/templates/axfr.tmpl (revision 936) +++ branches/cname-collision/templates/axfr.tmpl (revision 936) @@ -0,0 +1,80 @@ + +
+ + + + + + +
+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
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: branches/cname-collision/templates/badpage.tmpl =================================================================== --- branches/cname-collision/templates/badpage.tmpl (revision 936) +++ branches/cname-collision/templates/badpage.tmpl (revision 936) @@ -0,0 +1,18 @@ + +
+ +
+ +Bad page requested: +
+ +
+Press the 'Back' button on your browser to continue. + + +Template error: +
+ +
+ +
Index: branches/cname-collision/templates/bulkchange.tmpl =================================================================== --- branches/cname-collision/templates/bulkchange.tmpl (revision 936) +++ branches/cname-collision/templates/bulkchange.tmpl (revision 936) @@ -0,0 +1,23 @@ + +
+ + + + + + +
+ + + + + + + + + + + + +
Bulk Change Results ()
+
Index: branches/cname-collision/templates/bulkdomain.tmpl =================================================================== --- branches/cname-collision/templates/bulkdomain.tmpl (revision 936) +++ branches/cname-collision/templates/bulkdomain.tmpl (revision 936) @@ -0,0 +1,63 @@ + +
+ + + + + +
+ +
+
+ + + + + + + + +
+ + + + + + + + + + + + + + +
Bulk Zone Changes
Action: + Move to group:
+ Deactivate
+ Activate
 + Delete
 +
Zones to change:
+
+
+ + + + + + + + + +
()
+
+
+ +
+
+ +
Index: branches/cname-collision/templates/bulkrev.tmpl =================================================================== --- branches/cname-collision/templates/bulkrev.tmpl (revision 936) +++ branches/cname-collision/templates/bulkrev.tmpl (revision 936) @@ -0,0 +1,1 @@ + Index: branches/cname-collision/templates/confirmbulk.tmpl =================================================================== --- branches/cname-collision/templates/confirmbulk.tmpl (revision 936) +++ branches/cname-collision/templates/confirmbulk.tmpl (revision 936) @@ -0,0 +1,54 @@ + +
+ + + + +
+ +
+
+ + + + + + +
+ + + + + + + + + + +
Confirm Bulk Zone Changes
+

Are you sure you want to the following zones?

+ No   + Yes   + +
Zones to change:
+ + + + + + + + +
+ +
+ + +
+ +
+
+ + +
+ Index: branches/cname-collision/templates/dberr.tmpl =================================================================== --- branches/cname-collision/templates/dberr.tmpl (revision 936) +++ branches/cname-collision/templates/dberr.tmpl (revision 936) @@ -0,0 +1,10 @@ + +
+ +
+
Database error:
+ +

+ +
+
Index: branches/cname-collision/templates/deldom.tmpl =================================================================== --- branches/cname-collision/templates/deldom.tmpl (revision 936) +++ branches/cname-collision/templates/deldom.tmpl (revision 936) @@ -0,0 +1,16 @@ + + +
+ + + + +
+

Are you really sure you want to delete domain ?

+cancel   |   +confirm +
+ + + + Index: branches/cname-collision/templates/delgrp.tmpl =================================================================== --- branches/cname-collision/templates/delgrp.tmpl (revision 936) +++ branches/cname-collision/templates/delgrp.tmpl (revision 936) @@ -0,0 +1,16 @@ + + +
+ + + + +
+

Are you really sure you want to delete group ?

+cancel   |   +confirm +
+ + + + Index: branches/cname-collision/templates/delloc.tmpl =================================================================== --- branches/cname-collision/templates/delloc.tmpl (revision 936) +++ branches/cname-collision/templates/delloc.tmpl (revision 936) @@ -0,0 +1,16 @@ + + +
+ + + + +
+

Are you really sure you want to delete location ?

+cancel   |   +confirm +
+ + + + Index: branches/cname-collision/templates/delrec.tmpl =================================================================== --- branches/cname-collision/templates/delrec.tmpl (revision 936) +++ branches/cname-collision/templates/delrec.tmpl (revision 936) @@ -0,0 +1,18 @@ + + +
+ + + + +
+

Are you really sure you want to delete record:
+

+cancel +   |   +confirm +
+ + + + Index: branches/cname-collision/templates/delrevzone.tmpl =================================================================== --- branches/cname-collision/templates/delrevzone.tmpl (revision 936) +++ branches/cname-collision/templates/delrevzone.tmpl (revision 936) @@ -0,0 +1,16 @@ + + +
+ + + + +
+

Are you really sure you want to delete reverse zone ?

+cancel   |   +confirm +
+ + + + Index: branches/cname-collision/templates/deluser.tmpl =================================================================== --- branches/cname-collision/templates/deluser.tmpl (revision 936) +++ branches/cname-collision/templates/deluser.tmpl (revision 936) @@ -0,0 +1,16 @@ + + +
+ + + + +
+

Are you really sure you want to delete user ?

+cancel   |   +confirm +
+ + + + Index: branches/cname-collision/templates/dns.css =================================================================== --- branches/cname-collision/templates/dns.css (revision 936) +++ branches/cname-collision/templates/dns.css (revision 936) @@ -0,0 +1,324 @@ +#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; +} + +/* Alternating row colours, now in CSS */ +.altrows > tbody > tr { + background-color: #D0E0E0; +} +.altrows > tbody > tr:nth-child(even) { + background-color: #FFFFFF; +} +.altrows > tbody > tr:nth-child(odd) { + background-color: #DDDDDD; +} + +.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; +} + +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; +} +.vpad { + padding-top: 5px; + padding-bottom: 5px; +} +/* 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; +} +.hidden { + display: none; +} + +#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; +} + +/* Pure CSS "click to show" widget, adapted from the group tree CSS */ +.collapsible li > input + * { + display: none; +} +/* when the input is checked, show the content div */ +.collapsible li > input:checked + * { + display: block; +} +/* hide the checkbox */ +.nocheckbox li > input { + display: none; + margin: 0em; + padding: 0px; +} +/* mostly just making the input label clickable */ +.collapsible label { + cursor: pointer; + display: inline; + margin: 0em; + padding: 0px; + padding-left: 10px; +} +/* be nice if we could make this work without the HTML list structure... */ +.notalist { + list-style: none; + margin: 0; + padding: 1px; +} + Index: branches/cname-collision/templates/dnsq.tmpl =================================================================== --- branches/cname-collision/templates/dnsq.tmpl (revision 936) +++ branches/cname-collision/templates/dnsq.tmpl (revision 936) @@ -0,0 +1,85 @@ + +
    + + + + + + +
    + +
    Query error:
    + +
    +
    + + + + + + + + + + + + + + + + + + + + + +
    DNS Query
    Host/Name:
    Record type: + +
    Non-recursive query: checked="checked" />
    Use this server:
    + +
    +
    + +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Query:
    + + + +
    Response from :
    Authority:
    Additional information:
    +     + +
    + Index: branches/cname-collision/templates/domlist.tmpl =================================================================== --- branches/cname-collision/templates/domlist.tmpl (revision 936) +++ branches/cname-collision/templates/domlist.tmpl (revision 936) @@ -0,0 +1,60 @@ + +
    + + + + + + +
    + + + + + + + + + + + + +
    DomainReverse zone list
    + + +New Domain + +New Reverse Zone + + +
    + + + + + + + + + + + + + + + + + + + + + +
     <TMPL_VAR NAME=sortorder>Change StatusDelete
    ()ActiveInactivedeactivateactivate[ Delete ]
    No domainsreverse zones found
    + +
     + +
    Index: branches/cname-collision/templates/edgroup.tmpl =================================================================== --- branches/cname-collision/templates/edgroup.tmpl (revision 936) +++ branches/cname-collision/templates/edgroup.tmpl (revision 936) @@ -0,0 +1,36 @@ + +
    + + + + + + +
    + +
    +
    + + + + + + + + + + + + + + + + + + +
    Error updating group :
    Default permissions for group
    By default, users of this group will inherit the following privileges:
    + +
    +
    + +
    Index: branches/cname-collision/templates/editsoa.tmpl =================================================================== --- branches/cname-collision/templates/editsoa.tmpl (revision 936) +++ branches/cname-collision/templates/editsoa.tmpl (revision 936) @@ -0,0 +1,75 @@ + +
    + + + + + + +
    + +
    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: branches/cname-collision/templates/footer.tmpl =================================================================== --- branches/cname-collision/templates/footer.tmpl (revision 936) +++ branches/cname-collision/templates/footer.tmpl (revision 936) @@ -0,0 +1,13 @@ + +
    + +     + + + Index: branches/cname-collision/templates/fpnla.tmpl =================================================================== --- branches/cname-collision/templates/fpnla.tmpl (revision 936) +++ branches/cname-collision/templates/fpnla.tmpl (revision 936) @@ -0,0 +1,5 @@ +[ First ]First[ First ]First  +[ Previous ]Previous[ Previous ]Previous  +Next[ Next ]Next[ Next ]  +Last[ Last ]Last[ Last ]  +All per page Index: branches/cname-collision/templates/grouptree-ie.css =================================================================== --- branches/cname-collision/templates/grouptree-ie.css (revision 936) +++ branches/cname-collision/templates/grouptree-ie.css (revision 936) @@ -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: branches/cname-collision/templates/grouptree.css =================================================================== --- branches/cname-collision/templates/grouptree.css (revision 936) +++ branches/cname-collision/templates/grouptree.css (revision 936) @@ -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: branches/cname-collision/templates/grpman.tmpl =================================================================== --- branches/cname-collision/templates/grpman.tmpl (revision 936) +++ branches/cname-collision/templates/grpman.tmpl (revision 936) @@ -0,0 +1,60 @@ + +
    + + + + + + +
    + + + + + + + + + + + + + + + +
    ManageView groups
    Edit Current GroupNew Group +
    + + + + + + + + + + + + + + + + + + + + + + + + + +
     <TMPL_VAR NAME=sortorder>Delete
    [ Delete ]
    No groups found
    + +
     + +
    Index: branches/cname-collision/templates/grptree.tmpl =================================================================== --- branches/cname-collision/templates/grptree.tmpl (revision 936) +++ branches/cname-collision/templates/grptree.tmpl (revision 936) @@ -0,0 +1,6 @@ +
      +
    • + > + checked="checked" id="grp_" /> +
      • +
    Index: branches/cname-collision/templates/header.tmpl =================================================================== --- branches/cname-collision/templates/header.tmpl (revision 936) +++ branches/cname-collision/templates/header.tmpl (revision 936) @@ -0,0 +1,31 @@ + + + + + <TMPL_IF orgname><TMPL_VAR NAME=orgname> - </TMPL_IF>DNS Administration + + + + + + + + + + + + + + + + + + + + + Index: branches/cname-collision/templates/lettsearch.tmpl =================================================================== --- branches/cname-collision/templates/lettsearch.tmpl (revision 936) +++ branches/cname-collision/templates/lettsearch.tmpl (revision 936) @@ -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: branches/cname-collision/templates/location.tmpl =================================================================== --- branches/cname-collision/templates/location.tmpl (revision 936) +++ branches/cname-collision/templates/location.tmpl (revision 936) @@ -0,0 +1,53 @@ + +
    + + + + + + +
    + + +
    + + +
    +
    + + + + + + + +
    + + + + + + + + + + + + + + + + + + + +
    Error location:
    :
    Location name/description
    IP list
    Comments
    + +
    + +
    +
    + +     + +
    Index: branches/cname-collision/templates/loclist.tmpl =================================================================== --- branches/cname-collision/templates/loclist.tmpl (revision 936) +++ branches/cname-collision/templates/loclist.tmpl (revision 936) @@ -0,0 +1,54 @@ + +
    + + + + + + +
    + + + + + + + + + + + + + +
    Manage locations/views
    New Location/View
    + + + + + + + + + + + + + + + + + + + + + +
     <TMPL_VAR NAME=sortorder>Delete
    [ Delete ]
    No locations/views defined
    + +
     + +
    Index: branches/cname-collision/templates/log.tmpl =================================================================== --- branches/cname-collision/templates/log.tmpl (revision 936) +++ branches/cname-collision/templates/log.tmpl (revision 936) @@ -0,0 +1,87 @@ + +
    + + + + + + +
    + + +
    +     + + + + + + + + +
    Log entries for
    +
    + + + + + value="" /> + + +
    + + + + + + + + + + + + + + + + + + + + + + + +
     <TMPL_VAR NAME=sortorder>
    +
      +
    • + + +
        +
      • +
        +
        • +
      +
      • +
    + +     		+ +
    No log entries found
    + +
     + +
    Index: branches/cname-collision/templates/login.tmpl =================================================================== --- branches/cname-collision/templates/login.tmpl (revision 936) +++ branches/cname-collision/templates/login.tmpl (revision 936) @@ -0,0 +1,24 @@ + +
    + +
    +
    + + + + +
    +
    DeepNet DNS Administrator v
    +
    + + + + + + + +
    Error logging in: Invalid username or password
    Your session has expired
    Please log in:
    Username:
    Password:
    +
    + +
    +
    Index: branches/cname-collision/templates/menu.tmpl =================================================================== --- branches/cname-collision/templates/menu.tmpl (revision 936) +++ branches/cname-collision/templates/menu.tmpl (revision 936) @@ -0,0 +1,43 @@ + + + logged in
    +Log out +
    +Domains
    +Reverse Zones
     +Users
    +Log
    +Default Records
    +Default Reverse Records
     +Locations/Views
     +AXFR Import
     +Bulk Domain Operations
     +Bulk Reverse Zone Operations
     +
    +ManageView groups
    +
    +
    + +
      +
    • + > + + + + +
      • +
    + +
    + +
    +Find records(s): +
    + + +
    +
    +DNS Query
    +WHOIS Query
    + + Index: branches/cname-collision/templates/msgblock.tmpl =================================================================== --- branches/cname-collision/templates/msgblock.tmpl (revision 936) +++ branches/cname-collision/templates/msgblock.tmpl (revision 936) @@ -0,0 +1,9 @@ + +
    +     + +
    Warning:
    +     + +
    +     Index: branches/cname-collision/templates/newdomain.tmpl =================================================================== --- branches/cname-collision/templates/newdomain.tmpl (revision 936) +++ branches/cname-collision/templates/newdomain.tmpl (revision 936) @@ -0,0 +1,54 @@ + +
    + + + + + +
    + +
    +
    + + + + + + + +
    + + + + + + + + + + + + + + + + + + + + + + +
    Error adding domain :
    Add Domain
    Domain Name:
    Add domain to group:
    Make domain active on next DNS propagation checked="checked" />
    Location/view:
    +
    + +
    +
    + +
    Index: branches/cname-collision/templates/newgrp.tmpl =================================================================== --- branches/cname-collision/templates/newgrp.tmpl (revision 936) +++ branches/cname-collision/templates/newgrp.tmpl (revision 936) @@ -0,0 +1,50 @@ + +
    + + + + + +
    + +
    +
    + + + + + + + +
    + + + + + + + + + + + + + + + + + + + +
    Error adding group :
    Add Group
    Group Name:
    Add as subgroup of:
    Default permissions for users created in this group:
    + +
    +
    + +
    +
    + +
    Index: branches/cname-collision/templates/newrevzone.tmpl =================================================================== --- branches/cname-collision/templates/newrevzone.tmpl (revision 936) +++ branches/cname-collision/templates/newrevzone.tmpl (revision 936) @@ -0,0 +1,62 @@ + +
    + + + + + +
    + +
    +
    + + + + + + + +
    + + + + + + + + + + + + + + + + + + + + + + + + + + +
    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: branches/cname-collision/templates/permlist.tmpl =================================================================== --- branches/cname-collision/templates/permlist.tmpl (revision 936) +++ branches/cname-collision/templates/permlist.tmpl (revision 936) @@ -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: branches/cname-collision/templates/pgcount.tmpl =================================================================== --- branches/cname-collision/templates/pgcount.tmpl (revision 936) +++ branches/cname-collision/templates/pgcount.tmpl (revision 936) @@ -0,0 +1,1 @@ +Listing - of No in matching "" Index: branches/cname-collision/templates/reclist.tmpl =================================================================== --- branches/cname-collision/templates/reclist.tmpl (revision 936) +++ branches/cname-collision/templates/reclist.tmpl (revision 936) @@ -0,0 +1,104 @@ + +
    + + + + + + +
    + + + + + + +
    + +
    Records in
    + + + + + + + + + + + + + + + + +
    + + + + +
    +
    + + + + + + value="" /> + +
    +
    +
    RecordsPlain textAdd recordView log
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
     <TMPL_VAR NAME=sortorder>Delete
    () ()
    ( )    		 () ()
    ( )    		[ Delete ]
    No records found
    + +
     + +
    + +     + +
    Index: branches/cname-collision/templates/record.tmpl =================================================================== --- branches/cname-collision/templates/record.tmpl (revision 936) +++ branches/cname-collision/templates/record.tmpl (revision 936) @@ -0,0 +1,110 @@ + +
    + + + + + + +
    + + +
    + + +
    +
    + + + + + + + + + + +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Error record:
    in
    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: branches/cname-collision/templates/recsearch.tmpl =================================================================== --- branches/cname-collision/templates/recsearch.tmpl (revision 936) +++ branches/cname-collision/templates/recsearch.tmpl (revision 936) @@ -0,0 +1,73 @@ + +
    + + + + + + +
    + + + + + + + + + + +
    Record search for ''
    +
    + + + + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
     <TMPL_VAR NAME=sortorder>
    () ()
    No records found matching ''
    + +
     + +
    Index: branches/cname-collision/templates/revzones.tmpl =================================================================== --- branches/cname-collision/templates/revzones.tmpl (revision 936) +++ branches/cname-collision/templates/revzones.tmpl (revision 936) @@ -0,0 +1,1 @@ + Index: branches/cname-collision/templates/sbox.tmpl =================================================================== --- branches/cname-collision/templates/sbox.tmpl (revision 936) +++ branches/cname-collision/templates/sbox.tmpl (revision 936) @@ -0,0 +1,8 @@ +
    +
    + +Search subgroups: checked="checked" name="searchsubs" value="y" /> + + +
    +
    Index: branches/cname-collision/templates/soadata.tmpl =================================================================== --- branches/cname-collision/templates/soadata.tmpl (revision 936) +++ branches/cname-collision/templates/soadata.tmpl (revision 936) @@ -0,0 +1,34 @@ + + + + + + +
    SOA:edit
    + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Contact address:Primary Nameserver:
    Serial Number:Refresh:
    Retry:Expiration:
    Minimum TTL:Default TTL:
    Index: branches/cname-collision/templates/template.tmpl =================================================================== --- branches/cname-collision/templates/template.tmpl (revision 936) +++ branches/cname-collision/templates/template.tmpl (revision 936) @@ -0,0 +1,13 @@ + +
    + + + + + + +
    + + + +
    Index: branches/cname-collision/templates/textrecs.tmpl =================================================================== --- branches/cname-collision/templates/textrecs.tmpl (revision 936) +++ branches/cname-collision/templates/textrecs.tmpl (revision 936) @@ -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: branches/cname-collision/templates/updatesoa.tmpl =================================================================== --- branches/cname-collision/templates/updatesoa.tmpl (revision 936) +++ branches/cname-collision/templates/updatesoa.tmpl (revision 936) @@ -0,0 +1,1 @@ + Index: branches/cname-collision/templates/user.tmpl =================================================================== --- branches/cname-collision/templates/user.tmpl (revision 936) +++ branches/cname-collision/templates/user.tmpl (revision 936) @@ -0,0 +1,106 @@ + +
    + + + + + +
    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    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: branches/cname-collision/templates/useradmin.tmpl =================================================================== --- branches/cname-collision/templates/useradmin.tmpl (revision 936) +++ branches/cname-collision/templates/useradmin.tmpl (revision 936) @@ -0,0 +1,62 @@ + +
    + + + + + + +
    + + + + + + + + + + + + + + +
    Manage users
    New User
    + + + + + + + + + + + + + + + + + + + + + + + +
     <TMPL_VAR NAME=sortorder>Delete
    + + enableddisabled + + enableddisabled + +[ Delete ]
    No users found
    + +
     + +
    Index: branches/cname-collision/templates/whoisq.tmpl =================================================================== --- branches/cname-collision/templates/whoisq.tmpl (revision 936) +++ branches/cname-collision/templates/whoisq.tmpl (revision 936) @@ -0,0 +1,47 @@ + +
    + + + + + + +
    + +
    Query error:
    + +
    +
    + + + + + + + + + + +
    WHOIS Query
    Host/Name:
    + +
    +
    + +
    + + + + + + + + + + +
    Query:
    + +
    Response from :
    
+
    +     + +
    Index: branches/cname-collision/templates/widgets.js =================================================================== --- branches/cname-collision/templates/widgets.js (revision 936) +++ branches/cname-collision/templates/widgets.js (revision 936) @@ -0,0 +1,29 @@ +/* +** Javascript helper bits +** Note that these should be HELPERS, not DOESN'T WORK WITHOUT +*/ + +/* Select all domains on a page on the Bulk Domain Operations" page */ +// a handy place to store state +var bulk_selstate = []; +function bulk_selall() { + var x=document.getElementById("main"); + var y=x.getElementsByTagName("input"); + + // snag the ALL EVARYTHING checkbox state + var newstate = document.getElementById("master").checked; + for (var i=0; i +# +# 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; + +# Taint-safe (ish) voodoo to push "the directory the script is in" into @INC. +use File::Spec (); +use File::Basename (); +my $path; +BEGIN { + $path = File::Basename::dirname(File::Spec->rel2abs($0)); + if ($path =~ /(.*)/) { + $path = $1; + } +} +use lib $path; + +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', offset => 'all'); +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: branches/cname-collision/tiny-import.pl =================================================================== --- branches/cname-collision/tiny-import.pl (revision 936) +++ branches/cname-collision/tiny-import.pl (revision 936) @@ -0,0 +1,964 @@ +#!/usr/bin/perl +# dnsadmin shell-based import tool for tinydns flatfiles +## +# $Id$ +# Copyright 2012-2014,2020-2022 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); + +# Taint-safe (ish) voodoo to push "the directory the script is in" into @INC. +use File::Spec (); +use File::Basename (); +my $path; +BEGIN { + $path = File::Basename::dirname(File::Spec->rel2abs($0)); + if ($path =~ /(.*)/) { + $path = $1; + } +} +use lib $path; + +use DNSDB; + +my $dnsdb = new DNSDB; + +usage() if !@ARGV; + +my %importcfg = ( + rw => 0, + conv => 0, + trial => 0, + legacy => 0, + merge => 0, + group => 1, + ); +my $gnum = ''; +# Handle some command-line arguments +while ($ARGV[0] =~ /^-/) { + my $arg = shift @ARGV; + usage() if $arg !~ /^-(?:[rclmt]+|g\d*)$/; + # -r rewrite imported files to comment imported records + # -c coerce/downconvert A+PTR = records to PTR + # -l swallow A+PTR as-is + # -m merge PTR and A/AAAA as possible + # -t trial mode; don't commit to DB or actually rewrite flatfile (disables -r) + # -g import to specified group (name or ID) instead of group 1 + $arg =~ s/^-//; +# for Reasons (none clear), $arg is undefined yet defined, but only when number characters are involved. Ebbeh? +no warnings qw(uninitialized); + if ($arg =~ /^g/) { + if ($arg eq 'g') { + $importcfg{group} = shift @ARGV; + } else { + $arg =~ s/^g//; + $importcfg{group} = $arg; + } + } else { + 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{merge} = 1 if $_ eq 'm'; + $importcfg{trial} = 1 if $_ eq 't'; + } + } + use warnings qw(uninitialized); +} +$importcfg{rw} = 0 if $importcfg{trial}; + +# allow group names +if ($importcfg{group} =~ /^\d+$/) { + $importcfg{groupname} = $dnsdb->groupName($importcfg{group}); +} else { + $importcfg{groupname} = $importcfg{group}; + $importcfg{group} = $dnsdb->groupID($importcfg{groupname}); +} + +die usage() if $importcfg{group} !~ /^\d+$/; + +sub usage { + die q(usage: tiny-import.pl [-rclt] [-gnn] [-g name] 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. + -m Merge PTR and A or AAAA records to A+PTR or AAAA+PTR records where possible + -gnnn or -g nnn or -g name + Import new zones into this group (group name or ID accepted) instead of + the root/default group 1 + -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}; + +# collect some things for logging +($dnsdb->{logusername}, undef, undef, undef, undef, undef, $dnsdb->{logfullname}) = getpwuid($<); +$dnsdb->{logfullname} =~ s/,//g; +$dnsdb->{loguserid} = 0; # not worth setting up a pseudouser the way the RPC system does +$dnsdb->{logusername} = $dnsdb->{logusername}."/tiny-import.pl"; +$dnsdb->{logfullname} = $dnsdb->{logusername} if !$dnsdb->{logfullname}; +$dnsdb->{logfullname} = $dnsdb->{logfullname}."/tiny-import.pl"; + +$dbh->{AutoCommit} = 0; +$dbh->{RaiseError} = 1; + +my %cnt; +my @deferred; +my $converted = 0; +my $errstr = ''; + +foreach my $file (@ARGV) { + my %filecount; + my $logentry = "Import records from $file: "; + eval { + import(file => $file, cnt => \%filecount); + if (%filecount) { + foreach (sort keys %filecount) { + $logentry .= "$_ $filecount{$_}, "; + $cnt{$_} += $filecount{$_}; + } + $logentry =~ s/[\s,]+$//; + $dnsdb->_log(group_id => $importcfg{group}, entry => $logentry); + } + $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 (sort keys %cnt) { + print " $_ $cnt{$_}\n"; +} + +exit 0; + +sub import { + our %args = @_; + my $flatfile = $args{file}; + my $filecnt = $args{cnt}; + 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 (?,?,?,?,?,?,?,?,?,?,?,?,?)"); + + # for A/AAAA records + our $revcheck = $dbh->prepare("SELECT rdns_id,record_id,ttl FROM records WHERE host=? AND val=? AND type=12"); + our $mergefwd = $dbh->prepare("UPDATE records SET type=?,domain_id=?,ttl=? WHERE record_id=?"); + # for PTR records + our $fwdcheck = $dbh->prepare("SELECT domain_id,record_id,ttl FROM records WHERE host=? AND val=? AND (type=1 OR type=28)"); + our $mergerev = $dbh->prepare("UPDATE records SET type=?,rdns_id=?,ttl=? WHERE record_id=?"); + + my %deleg; + + my $ok = 0; + while () { + if (/^#/ || /^\s*$/) { + print RWFLAT "#$_" if $importcfg{rw}; + next; + } + chomp; + s/\s*$//; + s/:+$//; + my $recstat = recslurp($_, $filecnt); + $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 $filecnt = shift; + my $nodefer = shift || 0; + my $impok = 1; + my $msg; + + $errstr = $rec; # this way at least we have some idea what went + + if ($rec =~ /^=/) { + $filecnt->{'A+PTR'}++; + +##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/) { + $filecnt->{CNAME}++; + + my ($host,$targ,$ttl,$stamp,$loc) = split /:/, $rec, 5; + $host =~ s/^C//; + $host =~ s/\.$//; + $host =~ s/^\\052/*/; + $ttl = -1 if !defined($ttl) || $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 =~ /^\&/) { + $filecnt->{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 =~ /^\^/) { + $filecnt->{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) { +##fixme: really want to pull this DB call inside an if $importcfg{merge}, +# but then we need to duplicate the insert for the case where the matching +# reverse doesn't exist. + $host =~ s/\.$//g; # pure sytactic sugar, we don't store this trailing dot. + $fwdcheck->execute($host, $msg->addr); + my ($domid, $recid, $rttl) = $fwdcheck->fetchrow_array; + if ($importcfg{merge} && $domid) { + $ttl = ($rttl < $ttl ? $rttl : $ttl); # Take the shorter TTL + $mergerev->execute(($msg->{isv6} ? 65281 : 65280), $rparent, $ttl, $recid); + $dnsdb->_log(rdns_id => $rparent, domain_id => $domid, group_id => $importcfg{group}, + entry => "[ import ] PTR ".$msg->addr." -> $host merged with matching ". + ($msg->{isv6} ? 'AAAA' : 'A')." record"); + } else { + ($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 =~ /^\+/) { + $filecnt->{A}++; + + my ($host,$ip,$ttl,$stamp,$loc) = split /:/, $rec, 5; + $host =~ s/^\+//; + $host =~ s/\.$//; + $host =~ s/^\\052/*/; + $ttl = -1 if !defined($ttl) || $ttl eq ''; + $stamp = '' if !$stamp; + $loc = '' if !$loc; + $loc = '' if $loc =~ /^:+$/; + + my $stampactive = 'n'; + my $expires = 'n'; + + my $domid = $dnsdb->_hostparent($host); + if ($domid) { +##fixme: really want to pull this DB call inside an if $importcfg{merge}, +# but then we need to duplicate the insert for the case where the matching +# reverse doesn't exist. + $revcheck->execute($host, $ip); + my ($revid, $recid, $rttl) = $revcheck->fetchrow_array; + if ($importcfg{merge} && $revid) { + $ttl = ($rttl < $ttl ? $rttl : $ttl); # Take the shorter TTL + $mergefwd->execute(65280, $domid, $ttl, $recid); + $dnsdb->_log(rdns_id => $revid, domain_id => $domid, group_id => $importcfg{group}, + entry => "[ import ] ".($msg->{isv6} ? 'AAAA' : 'A')." record $host -> $ip". + " merged with matching PTR record"); + } else { + ($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/) { + $filecnt->{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 =~ /^:+$/; +# Default to UNIX epoch for zones with no existing serial value + $serial = scalar(time) if !$serial; + + 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,sertype,zserial) VALUES (?,?,1,?,'U',?)", + undef, ($msg, $importcfg{group}, $loc, $serial)); + 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,sertype,zserial) VALUES (?,?,1,?,'U',?)", + undef, ($zone, $importcfg{group}, $loc, $serial)); + 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 =~ /^\@/) { + $filecnt->{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 =~ /^'/) { + $filecnt->{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 =~ /^\./) { + $filecnt->{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')"); + my $soattl; + ($soattl, $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 +# the SOA also gets the default 2560 TTL, no matter what was set on the . entry. + $recsth->execute(0, $rdns, "hostmaster.$fqdn:$ns", 6, "16384:2048:1048576:2560", 0, 0, 0, $soattl, + $loc, $stamp, $expires, $stampactive); + } + # NS records get the specified TTL from the original . entry + ($ttl, $stampactive, $expires, $stamp) = calcstamp($stamp, $ttl, $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 =~ /^\%/) { + $filecnt->{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 =~ /^:/) { + $filecnt->{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); + +##fixme: really want to pull this DB call inside an if $importcfg{merge}, +# but then we need to duplicate the insert for the case where the matching +# reverse doesn't exist. + $revcheck->execute($fqdn, $val); + my ($revid, $recid, $rttl) = $revcheck->fetchrow_array; + + # If we have a revzone and merging is enabled, update the existing + # record with a reverse ID, set the type to one of the internal + # pseudotypes, and set the TTL to the lower of the two. + if ($importcfg{merge} && $revid) { + $ttl = ($rttl < $ttl ? $rttl : $ttl); # Take the shorter TTL + $mergefwd->execute(65281, $fparent, $ttl, $recid); + $dnsdb->_log(rdns_id => $revid, domain_id => $fparent, group_id => $importcfg{group}, + entry => "[ import ] ".($msg->{isv6} ? 'AAAA' : 'A')." record $fqdn -> $val". + " merged with matching PTR record"); + } else { + 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 { + $filecnt->{other}++; + print " $_\n"; + } + + return $impok; # just to make sure + } # recslurp() + + close FLAT; +} Index: branches/cname-collision/vega-import.pl =================================================================== --- branches/cname-collision/vega-import.pl (revision 936) +++ branches/cname-collision/vega-import.pl (revision 936) @@ -0,0 +1,415 @@ +#!/usr/bin/perl +# Import script for VegaDNS data +## +# $Id$ +# Copyright 2011-2013,2020 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; + +# push "the directory the script is in" into @INC +use FindBin; +use lib "$FindBin::RealBin/"; + +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"; +}