Changeset 545 for branches


Ignore:
Timestamp:
12/10/13 17:47:44 (11 years ago)
Author:
Kris Deugau
Message:

/branches/stable

Merge reverse DNS and location work; 2 of mumble

Numerous conflicts due to hand-copy or partial merges

Location:
branches/stable
Files:
25 edited
6 copied

Legend:

Unmodified
Added
Removed

  • branches/stable

  • branches/stable/COPYING

    r114 r545  
    673673Public License instead of this License.  But first, please read
    674674<http://www.gnu.org/philosophy/why-not-lgpl.html>.
    675                     GNU GENERAL PUBLIC LICENSE
    676                        Version 3, 29 June 2007
    677 
    678  Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
    679  Everyone is permitted to copy and distribute verbatim copies
    680  of this license document, but changing it is not allowed.
    681 
    682                             Preamble
    683 
    684   The GNU General Public License is a free, copyleft license for
    685 software and other kinds of works.
    686 
    687   The licenses for most software and other practical works are designed
    688 to take away your freedom to share and change the works.  By contrast,
    689 the GNU General Public License is intended to guarantee your freedom to
    690 share and change all versions of a program--to make sure it remains free
    691 software for all its users.  We, the Free Software Foundation, use the
    692 GNU General Public License for most of our software; it applies also to
    693 any other work released this way by its authors.  You can apply it to
    694 your programs, too.
    695 
    696   When we speak of free software, we are referring to freedom, not
    697 price.  Our General Public Licenses are designed to make sure that you
    698 have the freedom to distribute copies of free software (and charge for
    699 them if you wish), that you receive source code or can get it if you
    700 want it, that you can change the software or use pieces of it in new
    701 free programs, and that you know you can do these things.
    702 
    703   To protect your rights, we need to prevent others from denying you
    704 these rights or asking you to surrender the rights.  Therefore, you have
    705 certain responsibilities if you distribute copies of the software, or if
    706 you modify it: responsibilities to respect the freedom of others.
    707 
    708   For example, if you distribute copies of such a program, whether
    709 gratis or for a fee, you must pass on to the recipients the same
    710 freedoms that you received.  You must make sure that they, too, receive
    711 or can get the source code.  And you must show them these terms so they
    712 know their rights.
    713 
    714   Developers that use the GNU GPL protect your rights with two steps:
    715 (1) assert copyright on the software, and (2) offer you this License
    716 giving you legal permission to copy, distribute and/or modify it.
    717 
    718   For the developers' and authors' protection, the GPL clearly explains
    719 that there is no warranty for this free software.  For both users' and
    720 authors' sake, the GPL requires that modified versions be marked as
    721 changed, so that their problems will not be attributed erroneously to
    722 authors of previous versions.
    723 
    724   Some devices are designed to deny users access to install or run
    725 modified versions of the software inside them, although the manufacturer
    726 can do so.  This is fundamentally incompatible with the aim of
    727 protecting users' freedom to change the software.  The systematic
    728 pattern of such abuse occurs in the area of products for individuals to
    729 use, which is precisely where it is most unacceptable.  Therefore, we
    730 have designed this version of the GPL to prohibit the practice for those
    731 products.  If such problems arise substantially in other domains, we
    732 stand ready to extend this provision to those domains in future versions
    733 of the GPL, as needed to protect the freedom of users.
    734 
    735   Finally, every program is threatened constantly by software patents.
    736 States should not allow patents to restrict development and use of
    737 software on general-purpose computers, but in those that do, we wish to
    738 avoid the special danger that patents applied to a free program could
    739 make it effectively proprietary.  To prevent this, the GPL assures that
    740 patents cannot be used to render the program non-free.
    741 
    742   The precise terms and conditions for copying, distribution and
    743 modification follow.
    744 
    745                        TERMS AND CONDITIONS
    746 
    747   0. Definitions.
    748 
    749   "This License" refers to version 3 of the GNU General Public License.
    750 
    751   "Copyright" also means copyright-like laws that apply to other kinds of
    752 works, such as semiconductor masks.
    753 
    754   "The Program" refers to any copyrightable work licensed under this
    755 License.  Each licensee is addressed as "you".  "Licensees" and
    756 "recipients" may be individuals or organizations.
    757 
    758   To "modify" a work means to copy from or adapt all or part of the work
    759 in a fashion requiring copyright permission, other than the making of an
    760 exact copy.  The resulting work is called a "modified version" of the
    761 earlier work or a work "based on" the earlier work.
    762 
    763   A "covered work" means either the unmodified Program or a work based
    764 on the Program.
    765 
    766   To "propagate" a work means to do anything with it that, without
    767 permission, would make you directly or secondarily liable for
    768 infringement under applicable copyright law, except executing it on a
    769 computer or modifying a private copy.  Propagation includes copying,
    770 distribution (with or without modification), making available to the
    771 public, and in some countries other activities as well.
    772 
    773   To "convey" a work means any kind of propagation that enables other
    774 parties to make or receive copies.  Mere interaction with a user through
    775 a computer network, with no transfer of a copy, is not conveying.
    776 
    777   An interactive user interface displays "Appropriate Legal Notices"
    778 to the extent that it includes a convenient and prominently visible
    779 feature that (1) displays an appropriate copyright notice, and (2)
    780 tells the user that there is no warranty for the work (except to the
    781 extent that warranties are provided), that licensees may convey the
    782 work under this License, and how to view a copy of this License.  If
    783 the interface presents a list of user commands or options, such as a
    784 menu, a prominent item in the list meets this criterion.
    785 
    786   1. Source Code.
    787 
    788   The "source code" for a work means the preferred form of the work
    789 for making modifications to it.  "Object code" means any non-source
    790 form of a work.
    791 
    792   A "Standard Interface" means an interface that either is an official
    793 standard defined by a recognized standards body, or, in the case of
    794 interfaces specified for a particular programming language, one that
    795 is widely used among developers working in that language.
    796 
    797   The "System Libraries" of an executable work include anything, other
    798 than the work as a whole, that (a) is included in the normal form of
    799 packaging a Major Component, but which is not part of that Major
    800 Component, and (b) serves only to enable use of the work with that
    801 Major Component, or to implement a Standard Interface for which an
    802 implementation is available to the public in source code form.  A
    803 "Major Component", in this context, means a major essential component
    804 (kernel, window system, and so on) of the specific operating system
    805 (if any) on which the executable work runs, or a compiler used to
    806 produce the work, or an object code interpreter used to run it.
    807 
    808   The "Corresponding Source" for a work in object code form means all
    809 the source code needed to generate, install, and (for an executable
    810 work) run the object code and to modify the work, including scripts to
    811 control those activities.  However, it does not include the work's
    812 System Libraries, or general-purpose tools or generally available free
    813 programs which are used unmodified in performing those activities but
    814 which are not part of the work.  For example, Corresponding Source
    815 includes interface definition files associated with source files for
    816 the work, and the source code for shared libraries and dynamically
    817 linked subprograms that the work is specifically designed to require,
    818 such as by intimate data communication or control flow between those
    819 subprograms and other parts of the work.
    820 
    821   The Corresponding Source need not include anything that users
    822 can regenerate automatically from other parts of the Corresponding
    823 Source.
    824 
    825   The Corresponding Source for a work in source code form is that
    826 same work.
    827 
    828   2. Basic Permissions.
    829 
    830   All rights granted under this License are granted for the term of
    831 copyright on the Program, and are irrevocable provided the stated
    832 conditions are met.  This License explicitly affirms your unlimited
    833 permission to run the unmodified Program.  The output from running a
    834 covered work is covered by this License only if the output, given its
    835 content, constitutes a covered work.  This License acknowledges your
    836 rights of fair use or other equivalent, as provided by copyright law.
    837 
    838   You may make, run and propagate covered works that you do not
    839 convey, without conditions so long as your license otherwise remains
    840 in force.  You may convey covered works to others for the sole purpose
    841 of having them make modifications exclusively for you, or provide you
    842 with facilities for running those works, provided that you comply with
    843 the terms of this License in conveying all material for which you do
    844 not control copyright.  Those thus making or running the covered works
    845 for you must do so exclusively on your behalf, under your direction
    846 and control, on terms that prohibit them from making any copies of
    847 your copyrighted material outside their relationship with you.
    848 
    849   Conveying under any other circumstances is permitted solely under
    850 the conditions stated below.  Sublicensing is not allowed; section 10
    851 makes it unnecessary.
    852 
    853   3. Protecting Users' Legal Rights From Anti-Circumvention Law.
    854 
    855   No covered work shall be deemed part of an effective technological
    856 measure under any applicable law fulfilling obligations under article
    857 11 of the WIPO copyright treaty adopted on 20 December 1996, or
    858 similar laws prohibiting or restricting circumvention of such
    859 measures.
    860 
    861   When you convey a covered work, you waive any legal power to forbid
    862 circumvention of technological measures to the extent such circumvention
    863 is effected by exercising rights under this License with respect to
    864 the covered work, and you disclaim any intention to limit operation or
    865 modification of the work as a means of enforcing, against the work's
    866 users, your or third parties' legal rights to forbid circumvention of
    867 technological measures.
    868 
    869   4. Conveying Verbatim Copies.
    870 
    871   You may convey verbatim copies of the Program's source code as you
    872 receive it, in any medium, provided that you conspicuously and
    873 appropriately publish on each copy an appropriate copyright notice;
    874 keep intact all notices stating that this License and any
    875 non-permissive terms added in accord with section 7 apply to the code;
    876 keep intact all notices of the absence of any warranty; and give all
    877 recipients a copy of this License along with the Program.
    878 
    879   You may charge any price or no price for each copy that you convey,
    880 and you may offer support or warranty protection for a fee.
    881 
    882   5. Conveying Modified Source Versions.
    883 
    884   You may convey a work based on the Program, or the modifications to
    885 produce it from the Program, in the form of source code under the
    886 terms of section 4, provided that you also meet all of these conditions:
    887 
    888     a) The work must carry prominent notices stating that you modified
    889     it, and giving a relevant date.
    890 
    891     b) The work must carry prominent notices stating that it is
    892     released under this License and any conditions added under section
    893     7.  This requirement modifies the requirement in section 4 to
    894     "keep intact all notices".
    895 
    896     c) You must license the entire work, as a whole, under this
    897     License to anyone who comes into possession of a copy.  This
    898     License will therefore apply, along with any applicable section 7
    899     additional terms, to the whole of the work, and all its parts,
    900     regardless of how they are packaged.  This License gives no
    901     permission to license the work in any other way, but it does not
    902     invalidate such permission if you have separately received it.
    903 
    904     d) If the work has interactive user interfaces, each must display
    905     Appropriate Legal Notices; however, if the Program has interactive
    906     interfaces that do not display Appropriate Legal Notices, your
    907     work need not make them do so.
    908 
    909   A compilation of a covered work with other separate and independent
    910 works, which are not by their nature extensions of the covered work,
    911 and which are not combined with it such as to form a larger program,
    912 in or on a volume of a storage or distribution medium, is called an
    913 "aggregate" if the compilation and its resulting copyright are not
    914 used to limit the access or legal rights of the compilation's users
    915 beyond what the individual works permit.  Inclusion of a covered work
    916 in an aggregate does not cause this License to apply to the other
    917 parts of the aggregate.
    918 
    919   6. Conveying Non-Source Forms.
    920 
    921   You may convey a covered work in object code form under the terms
    922 of sections 4 and 5, provided that you also convey the
    923 machine-readable Corresponding Source under the terms of this License,
    924 in one of these ways:
    925 
    926     a) Convey the object code in, or embodied in, a physical product
    927     (including a physical distribution medium), accompanied by the
    928     Corresponding Source fixed on a durable physical medium
    929     customarily used for software interchange.
    930 
    931     b) Convey the object code in, or embodied in, a physical product
    932     (including a physical distribution medium), accompanied by a
    933     written offer, valid for at least three years and valid for as
    934     long as you offer spare parts or customer support for that product
    935     model, to give anyone who possesses the object code either (1) a
    936     copy of the Corresponding Source for all the software in the
    937     product that is covered by this License, on a durable physical
    938     medium customarily used for software interchange, for a price no
    939     more than your reasonable cost of physically performing this
    940     conveying of source, or (2) access to copy the
    941     Corresponding Source from a network server at no charge.
    942 
    943     c) Convey individual copies of the object code with a copy of the
    944     written offer to provide the Corresponding Source.  This
    945     alternative is allowed only occasionally and noncommercially, and
    946     only if you received the object code with such an offer, in accord
    947     with subsection 6b.
    948 
    949     d) Convey the object code by offering access from a designated
    950     place (gratis or for a charge), and offer equivalent access to the
    951     Corresponding Source in the same way through the same place at no
    952     further charge.  You need not require recipients to copy the
    953     Corresponding Source along with the object code.  If the place to
    954     copy the object code is a network server, the Corresponding Source
    955     may be on a different server (operated by you or a third party)
    956     that supports equivalent copying facilities, provided you maintain
    957     clear directions next to the object code saying where to find the
    958     Corresponding Source.  Regardless of what server hosts the
    959     Corresponding Source, you remain obligated to ensure that it is
    960     available for as long as needed to satisfy these requirements.
    961 
    962     e) Convey the object code using peer-to-peer transmission, provided
    963     you inform other peers where the object code and Corresponding
    964     Source of the work are being offered to the general public at no
    965     charge under subsection 6d.
    966 
    967   A separable portion of the object code, whose source code is excluded
    968 from the Corresponding Source as a System Library, need not be
    969 included in conveying the object code work.
    970 
    971   A "User Product" is either (1) a "consumer product", which means any
    972 tangible personal property which is normally used for personal, family,
    973 or household purposes, or (2) anything designed or sold for incorporation
    974 into a dwelling.  In determining whether a product is a consumer product,
    975 doubtful cases shall be resolved in favor of coverage.  For a particular
    976 product received by a particular user, "normally used" refers to a
    977 typical or common use of that class of product, regardless of the status
    978 of the particular user or of the way in which the particular user
    979 actually uses, or expects or is expected to use, the product.  A product
    980 is a consumer product regardless of whether the product has substantial
    981 commercial, industrial or non-consumer uses, unless such uses represent
    982 the only significant mode of use of the product.
    983 
    984   "Installation Information" for a User Product means any methods,
    985 procedures, authorization keys, or other information required to install
    986 and execute modified versions of a covered work in that User Product from
    987 a modified version of its Corresponding Source.  The information must
    988 suffice to ensure that the continued functioning of the modified object
    989 code is in no case prevented or interfered with solely because
    990 modification has been made.
    991 
    992   If you convey an object code work under this section in, or with, or
    993 specifically for use in, a User Product, and the conveying occurs as
    994 part of a transaction in which the right of possession and use of the
    995 User Product is transferred to the recipient in perpetuity or for a
    996 fixed term (regardless of how the transaction is characterized), the
    997 Corresponding Source conveyed under this section must be accompanied
    998 by the Installation Information.  But this requirement does not apply
    999 if neither you nor any third party retains the ability to install
    1000 modified object code on the User Product (for example, the work has
    1001 been installed in ROM).
    1002 
    1003   The requirement to provide Installation Information does not include a
    1004 requirement to continue to provide support service, warranty, or updates
    1005 for a work that has been modified or installed by the recipient, or for
    1006 the User Product in which it has been modified or installed.  Access to a
    1007 network may be denied when the modification itself materially and
    1008 adversely affects the operation of the network or violates the rules and
    1009 protocols for communication across the network.
    1010 
    1011   Corresponding Source conveyed, and Installation Information provided,
    1012 in accord with this section must be in a format that is publicly
    1013 documented (and with an implementation available to the public in
    1014 source code form), and must require no special password or key for
    1015 unpacking, reading or copying.
    1016 
    1017   7. Additional Terms.
    1018 
    1019   "Additional permissions" are terms that supplement the terms of this
    1020 License by making exceptions from one or more of its conditions.
    1021 Additional permissions that are applicable to the entire Program shall
    1022 be treated as though they were included in this License, to the extent
    1023 that they are valid under applicable law.  If additional permissions
    1024 apply only to part of the Program, that part may be used separately
    1025 under those permissions, but the entire Program remains governed by
    1026 this License without regard to the additional permissions.
    1027 
    1028   When you convey a copy of a covered work, you may at your option
    1029 remove any additional permissions from that copy, or from any part of
    1030 it.  (Additional permissions may be written to require their own
    1031 removal in certain cases when you modify the work.)  You may place
    1032 additional permissions on material, added by you to a covered work,
    1033 for which you have or can give appropriate copyright permission.
    1034 
    1035   Notwithstanding any other provision of this License, for material you
    1036 add to a covered work, you may (if authorized by the copyright holders of
    1037 that material) supplement the terms of this License with terms:
    1038 
    1039     a) Disclaiming warranty or limiting liability differently from the
    1040     terms of sections 15 and 16 of this License; or
    1041 
    1042     b) Requiring preservation of specified reasonable legal notices or
    1043     author attributions in that material or in the Appropriate Legal
    1044     Notices displayed by works containing it; or
    1045 
    1046     c) Prohibiting misrepresentation of the origin of that material, or
    1047     requiring that modified versions of such material be marked in
    1048     reasonable ways as different from the original version; or
    1049 
    1050     d) Limiting the use for publicity purposes of names of licensors or
    1051     authors of the material; or
    1052 
    1053     e) Declining to grant rights under trademark law for use of some
    1054     trade names, trademarks, or service marks; or
    1055 
    1056     f) Requiring indemnification of licensors and authors of that
    1057     material by anyone who conveys the material (or modified versions of
    1058     it) with contractual assumptions of liability to the recipient, for
    1059     any liability that these contractual assumptions directly impose on
    1060     those licensors and authors.
    1061 
    1062   All other non-permissive additional terms are considered "further
    1063 restrictions" within the meaning of section 10.  If the Program as you
    1064 received it, or any part of it, contains a notice stating that it is
    1065 governed by this License along with a term that is a further
    1066 restriction, you may remove that term.  If a license document contains
    1067 a further restriction but permits relicensing or conveying under this
    1068 License, you may add to a covered work material governed by the terms
    1069 of that license document, provided that the further restriction does
    1070 not survive such relicensing or conveying.
    1071 
    1072   If you add terms to a covered work in accord with this section, you
    1073 must place, in the relevant source files, a statement of the
    1074 additional terms that apply to those files, or a notice indicating
    1075 where to find the applicable terms.
    1076 
    1077   Additional terms, permissive or non-permissive, may be stated in the
    1078 form of a separately written license, or stated as exceptions;
    1079 the above requirements apply either way.
    1080 
    1081   8. Termination.
    1082 
    1083   You may not propagate or modify a covered work except as expressly
    1084 provided under this License.  Any attempt otherwise to propagate or
    1085 modify it is void, and will automatically terminate your rights under
    1086 this License (including any patent licenses granted under the third
    1087 paragraph of section 11).
    1088 
    1089   However, if you cease all violation of this License, then your
    1090 license from a particular copyright holder is reinstated (a)
    1091 provisionally, unless and until the copyright holder explicitly and
    1092 finally terminates your license, and (b) permanently, if the copyright
    1093 holder fails to notify you of the violation by some reasonable means
    1094 prior to 60 days after the cessation.
    1095 
    1096   Moreover, your license from a particular copyright holder is
    1097 reinstated permanently if the copyright holder notifies you of the
    1098 violation by some reasonable means, this is the first time you have
    1099 received notice of violation of this License (for any work) from that
    1100 copyright holder, and you cure the violation prior to 30 days after
    1101 your receipt of the notice.
    1102 
    1103   Termination of your rights under this section does not terminate the
    1104 licenses of parties who have received copies or rights from you under
    1105 this License.  If your rights have been terminated and not permanently
    1106 reinstated, you do not qualify to receive new licenses for the same
    1107 material under section 10.
    1108 
    1109   9. Acceptance Not Required for Having Copies.
    1110 
    1111   You are not required to accept this License in order to receive or
    1112 run a copy of the Program.  Ancillary propagation of a covered work
    1113 occurring solely as a consequence of using peer-to-peer transmission
    1114 to receive a copy likewise does not require acceptance.  However,
    1115 nothing other than this License grants you permission to propagate or
    1116 modify any covered work.  These actions infringe copyright if you do
    1117 not accept this License.  Therefore, by modifying or propagating a
    1118 covered work, you indicate your acceptance of this License to do so.
    1119 
    1120   10. Automatic Licensing of Downstream Recipients.
    1121 
    1122   Each time you convey a covered work, the recipient automatically
    1123 receives a license from the original licensors, to run, modify and
    1124 propagate that work, subject to this License.  You are not responsible
    1125 for enforcing compliance by third parties with this License.
    1126 
    1127   An "entity transaction" is a transaction transferring control of an
    1128 organization, or substantially all assets of one, or subdividing an
    1129 organization, or merging organizations.  If propagation of a covered
    1130 work results from an entity transaction, each party to that
    1131 transaction who receives a copy of the work also receives whatever
    1132 licenses to the work the party's predecessor in interest had or could
    1133 give under the previous paragraph, plus a right to possession of the
    1134 Corresponding Source of the work from the predecessor in interest, if
    1135 the predecessor has it or can get it with reasonable efforts.
    1136 
    1137   You may not impose any further restrictions on the exercise of the
    1138 rights granted or affirmed under this License.  For example, you may
    1139 not impose a license fee, royalty, or other charge for exercise of
    1140 rights granted under this License, and you may not initiate litigation
    1141 (including a cross-claim or counterclaim in a lawsuit) alleging that
    1142 any patent claim is infringed by making, using, selling, offering for
    1143 sale, or importing the Program or any portion of it.
    1144 
    1145   11. Patents.
    1146 
    1147   A "contributor" is a copyright holder who authorizes use under this
    1148 License of the Program or a work on which the Program is based.  The
    1149 work thus licensed is called the contributor's "contributor version".
    1150 
    1151   A contributor's "essential patent claims" are all patent claims
    1152 owned or controlled by the contributor, whether already acquired or
    1153 hereafter acquired, that would be infringed by some manner, permitted
    1154 by this License, of making, using, or selling its contributor version,
    1155 but do not include claims that would be infringed only as a
    1156 consequence of further modification of the contributor version.  For
    1157 purposes of this definition, "control" includes the right to grant
    1158 patent sublicenses in a manner consistent with the requirements of
    1159 this License.
    1160 
    1161   Each contributor grants you a non-exclusive, worldwide, royalty-free
    1162 patent license under the contributor's essential patent claims, to
    1163 make, use, sell, offer for sale, import and otherwise run, modify and
    1164 propagate the contents of its contributor version.
    1165 
    1166   In the following three paragraphs, a "patent license" is any express
    1167 agreement or commitment, however denominated, not to enforce a patent
    1168 (such as an express permission to practice a patent or covenant not to
    1169 sue for patent infringement).  To "grant" such a patent license to a
    1170 party means to make such an agreement or commitment not to enforce a
    1171 patent against the party.
    1172 
    1173   If you convey a covered work, knowingly relying on a patent license,
    1174 and the Corresponding Source of the work is not available for anyone
    1175 to copy, free of charge and under the terms of this License, through a
    1176 publicly available network server or other readily accessible means,
    1177 then you must either (1) cause the Corresponding Source to be so
    1178 available, or (2) arrange to deprive yourself of the benefit of the
    1179 patent license for this particular work, or (3) arrange, in a manner
    1180 consistent with the requirements of this License, to extend the patent
    1181 license to downstream recipients.  "Knowingly relying" means you have
    1182 actual knowledge that, but for the patent license, your conveying the
    1183 covered work in a country, or your recipient's use of the covered work
    1184 in a country, would infringe one or more identifiable patents in that
    1185 country that you have reason to believe are valid.
    1186 
    1187   If, pursuant to or in connection with a single transaction or
    1188 arrangement, you convey, or propagate by procuring conveyance of, a
    1189 covered work, and grant a patent license to some of the parties
    1190 receiving the covered work authorizing them to use, propagate, modify
    1191 or convey a specific copy of the covered work, then the patent license
    1192 you grant is automatically extended to all recipients of the covered
    1193 work and works based on it.
    1194 
    1195   A patent license is "discriminatory" if it does not include within
    1196 the scope of its coverage, prohibits the exercise of, or is
    1197 conditioned on the non-exercise of one or more of the rights that are
    1198 specifically granted under this License.  You may not convey a covered
    1199 work if you are a party to an arrangement with a third party that is
    1200 in the business of distributing software, under which you make payment
    1201 to the third party based on the extent of your activity of conveying
    1202 the work, and under which the third party grants, to any of the
    1203 parties who would receive the covered work from you, a discriminatory
    1204 patent license (a) in connection with copies of the covered work
    1205 conveyed by you (or copies made from those copies), or (b) primarily
    1206 for and in connection with specific products or compilations that
    1207 contain the covered work, unless you entered into that arrangement,
    1208 or that patent license was granted, prior to 28 March 2007.
    1209 
    1210   Nothing in this License shall be construed as excluding or limiting
    1211 any implied license or other defenses to infringement that may
    1212 otherwise be available to you under applicable patent law.
    1213 
    1214   12. No Surrender of Others' Freedom.
    1215 
    1216   If conditions are imposed on you (whether by court order, agreement or
    1217 otherwise) that contradict the conditions of this License, they do not
    1218 excuse you from the conditions of this License.  If you cannot convey a
    1219 covered work so as to satisfy simultaneously your obligations under this
    1220 License and any other pertinent obligations, then as a consequence you may
    1221 not convey it at all.  For example, if you agree to terms that obligate you
    1222 to collect a royalty for further conveying from those to whom you convey
    1223 the Program, the only way you could satisfy both those terms and this
    1224 License would be to refrain entirely from conveying the Program.
    1225 
    1226   13. Use with the GNU Affero General Public License.
    1227 
    1228   Notwithstanding any other provision of this License, you have
    1229 permission to link or combine any covered work with a work licensed
    1230 under version 3 of the GNU Affero General Public License into a single
    1231 combined work, and to convey the resulting work.  The terms of this
    1232 License will continue to apply to the part which is the covered work,
    1233 but the special requirements of the GNU Affero General Public License,
    1234 section 13, concerning interaction through a network will apply to the
    1235 combination as such.
    1236 
    1237   14. Revised Versions of this License.
    1238 
    1239   The Free Software Foundation may publish revised and/or new versions of
    1240 the GNU General Public License from time to time.  Such new versions will
    1241 be similar in spirit to the present version, but may differ in detail to
    1242 address new problems or concerns.
    1243 
    1244   Each version is given a distinguishing version number.  If the
    1245 Program specifies that a certain numbered version of the GNU General
    1246 Public License "or any later version" applies to it, you have the
    1247 option of following the terms and conditions either of that numbered
    1248 version or of any later version published by the Free Software
    1249 Foundation.  If the Program does not specify a version number of the
    1250 GNU General Public License, you may choose any version ever published
    1251 by the Free Software Foundation.
    1252 
    1253   If the Program specifies that a proxy can decide which future
    1254 versions of the GNU General Public License can be used, that proxy's
    1255 public statement of acceptance of a version permanently authorizes you
    1256 to choose that version for the Program.
    1257 
    1258   Later license versions may give you additional or different
    1259 permissions.  However, no additional obligations are imposed on any
    1260 author or copyright holder as a result of your choosing to follow a
    1261 later version.
    1262 
    1263   15. Disclaimer of Warranty.
    1264 
    1265   THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
    1266 APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
    1267 HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
    1268 OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
    1269 THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
    1270 PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
    1271 IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
    1272 ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
    1273 
    1274   16. Limitation of Liability.
    1275 
    1276   IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
    1277 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
    1278 THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
    1279 GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
    1280 USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
    1281 DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
    1282 PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
    1283 EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
    1284 SUCH DAMAGES.
    1285 
    1286   17. Interpretation of Sections 15 and 16.
    1287 
    1288   If the disclaimer of warranty and limitation of liability provided
    1289 above cannot be given local legal effect according to their terms,
    1290 reviewing courts shall apply local law that most closely approximates
    1291 an absolute waiver of all civil liability in connection with the
    1292 Program, unless a warranty or assumption of liability accompanies a
    1293 copy of the Program in return for a fee.
    1294 
    1295                      END OF TERMS AND CONDITIONS
    1296 
    1297             How to Apply These Terms to Your New Programs
    1298 
    1299   If you develop a new program, and you want it to be of the greatest
    1300 possible use to the public, the best way to achieve this is to make it
    1301 free software which everyone can redistribute and change under these terms.
    1302 
    1303   To do so, attach the following notices to the program.  It is safest
    1304 to attach them to the start of each source file to most effectively
    1305 state the exclusion of warranty; and each file should have at least
    1306 the "copyright" line and a pointer to where the full notice is found.
    1307 
    1308     <one line to give the program's name and a brief idea of what it does.>
    1309     Copyright (C) <year>  <name of author>
    1310 
    1311     This program is free software: you can redistribute it and/or modify
    1312     it under the terms of the GNU General Public License as published by
    1313     the Free Software Foundation, either version 3 of the License, or
    1314     (at your option) any later version.
    1315 
    1316     This program is distributed in the hope that it will be useful,
    1317     but WITHOUT ANY WARRANTY; without even the implied warranty of
    1318     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    1319     GNU General Public License for more details.
    1320 
    1321     You should have received a copy of the GNU General Public License
    1322     along with this program.  If not, see <http://www.gnu.org/licenses/>.
    1323 
    1324 Also add information on how to contact you by electronic and paper mail.
    1325 
    1326   If the program does terminal interaction, make it output a short
    1327 notice like this when it starts in an interactive mode:
    1328 
    1329     <program>  Copyright (C) <year>  <name of author>
    1330     This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
    1331     This is free software, and you are welcome to redistribute it
    1332     under certain conditions; type `show c' for details.
    1333 
    1334 The hypothetical commands `show w' and `show c' should show the appropriate
    1335 parts of the General Public License.  Of course, your program's commands
    1336 might be different; for a GUI interface, you would use an "about box".
    1337 
    1338   You should also get your employer (if you work as a programmer) or school,
    1339 if any, to sign a "copyright disclaimer" for the program, if necessary.
    1340 For more information on this, and how to apply and follow the GNU GPL, see
    1341 <http://www.gnu.org/licenses/>.
    1342 
    1343   The GNU General Public License does not permit incorporating your program
    1344 into proprietary programs.  If your program is a subroutine library, you
    1345 may consider it more useful to permit linking proprietary applications with
    1346 the library.  If this is what you want to do, use the GNU Lesser General
    1347 Public License instead of this License.  But first, please read
    1348 <http://www.gnu.org/philosophy/why-not-lgpl.html>.

  • branches/stable/DNSDB.pm

    r544 r545  
    33##
    44# $Id$
    5 # Copyright 2008-2011 Kris Deugau <kdeugau@deepnet.cx>
     5# Copyright 2008-2012 Kris Deugau <kdeugau@deepnet.cx>
    66#
    77#    This program is free software: you can redistribute it and/or modify
    … …  
    3030use NetAddr::IP qw(:lower);
    3131use POSIX;
     32use Fcntl qw(:flock);
     33
    3234use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    3335
    34 $VERSION        = "1.0.5";      ##VERSION##
     36$VERSION        = 1.1;  ##VERSION##
    3537@ISA            = qw(Exporter);
    3638@EXPORT_OK      = qw(
    37         &initGlobals
     39        &initGlobals &login &initActionLog
    3840        &initPermissions &getPermissions &changePermissions &comparePermissions
    3941        &changeGroup
    4042        &loadConfig &connectDB &finish
    41         &addDomain &delDomain &domainName &revName &domainID &addRDNS
    42         &getZoneCount &getZoneList
     43        &addDomain &delZone &domainName &revName &domainID &revID &addRDNS
     44        &getZoneCount &getZoneList &getZoneLocation
    4345        &addGroup &delGroup &getChildren &groupName
     46        &getGroupCount &getGroupList
    4447        &addUser &updateUser &delUser &userFullName &userStatus &getUserData
    45         &getSOA &getRecLine &getDomRecs &getRecCount
     48        &getUserCount &getUserList &getUserDropdown
     49        &addLoc &updateLoc &delLoc &getLoc
     50        &getLocCount &getLocList &getLocDropdown
     51        &getSOA &updateSOA &getRecLine &getDomRecs &getRecCount
    4652        &addRec &updateRec &delRec
     53        &getLogCount &getLogEntries
    4754        &getTypelist
    4855        &parentID
    4956        &isParent
    50         &domStatus &importAXFR
     57        &zoneStatus &importAXFR
    5158        &export
    5259        &mailNotify
    5360        %typemap %reverse_typemap %config
    54         %permissions @permtypes $permlist
     61        %permissions @permtypes $permlist %permchains
    5562        );
    5663
    5764@EXPORT         = (); # Export nothing by default.
    5865%EXPORT_TAGS    = ( ALL => [qw(
    59                 &initGlobals
     66                &initGlobals &login &initActionLog
    6067                &initPermissions &getPermissions &changePermissions &comparePermissions
    6168                &changeGroup
    6269                &loadConfig &connectDB &finish
    63                 &addDomain &delDomain &domainName &revName &domainID &addRDNS
    64                 &getZoneCount &getZoneList
     70                &addDomain &delZone &domainName &revName &domainID &revID &addRDNS
     71                &getZoneCount &getZoneList &getZoneLocation
    6572                &addGroup &delGroup &getChildren &groupName
     73                &getGroupCount &getGroupList
    6674                &addUser &updateUser &delUser &userFullName &userStatus &getUserData
    67                 &getSOA &getRecLine &getDomRecs &getRecCount
     75                &getUserCount &getUserList &getUserDropdown
     76                &addLoc &updateLoc &delLoc &getLoc
     77                &getLocCount &getLocList &getLocDropdown
     78                &getSOA &updateSOA &getRecLine &getDomRecs &getRecCount
    6879                &addRec &updateRec &delRec
     80                &getLogCount &getLogEntries
    6981                &getTypelist
    7082                &parentID
    7183                &isParent
    72                 &domStatus &importAXFR
     84                &zoneStatus &importAXFR
    7385                &export
    7486                &mailNotify
    7587                %typemap %reverse_typemap %config
    76                 %permissions @permtypes $permlist
     88                %permissions @permtypes $permlist %permchains
    7789                )]
    7890        );
    … …  
    8092our $group = 1;
    8193our $errstr = '';
     94our $resultstr = '';
    8295
    8396# Halfway sane defaults for SOA, TTL, etc.
    … …  
    97110
    98111# Arguably defined wholly in the db, but little reason to change without supporting code changes
     112# group_view, user_view permissions? separate rDNS permission(s)?
    99113our @permtypes = qw (
    100114        group_edit      group_create    group_delete
    101115        user_edit       user_create     user_delete
    102116        domain_edit     domain_create   domain_delete
    103         record_edit     record_create   record_delete
     117        record_edit     record_create   record_delete   record_locchg
     118        location_edit   location_create location_delete location_view
    104119        self_edit       admin
    105120);
    106121our $permlist = join(',',@permtypes);
     122
     123# Some permissions more or less require certain others.
     124our %permchains = (
     125        user_edit       => 'self_edit',
     126        location_edit   => 'location_view',
     127        location_create => 'location_view',
     128        location_delete => 'location_view',
     129        record_locchg   => 'location_view',
     130);
    107131
    108132# DNS record type map and reverse map.
    … …  
    135159#               cssdir  => 'templates/',
    136160                sessiondir      => 'session/',
     161                exportcache     => 'cache/',
    137162
    138163                # Session params
    … …  
    145170
    146171## (Semi)private variables
     172
    147173# Hash of functions for validating record types.  Filled in initGlobals() since
    148174# it relies on visibility flags from the rectypes table in the DB
    149175my %validators;
    150176
    151 
    152 ##
    153 ## utility functions
    154 # _rectable()
    155 # Takes default+rdns flags, returns appropriate table name
    156 sub _rectable {
    157   my $def = shift;
    158   my $rev = shift;
    159 
    160   return 'records' if $def ne 'y';
    161   return 'default_records' if $rev ne 'y';
    162   return 'default_rev_records';
    163 } # end _rectable()
    164 
    165 # _recparent()
    166 # Takes default+rdns flags, returns appropriate parent-id column name
    167 sub _recparent {
    168   my $def = shift;
    169   my $rev = shift;
    170 
    171   return 'group_id' if $def eq 'y';
    172   return 'rdns_id' if $rev eq 'y';
    173   return 'domain_id';
    174 } # end _recparent()
    175 
    176 # Check an IP to be added in a reverse zone to see if it's really in the requested parent.
    177 # Takes a database handle, default and reverse flags, IP (fragment) to check, parent zone ID,
    178 # and a reference to a NetAddr::IP object (also used to pass back a fully-reconstructed IP for
    179 # database insertion)
    180 sub _ipparent {
    181   my $dbh = shift;
    182   my $defrec = shift;
    183   my $revrec = shift;
    184   my $val = shift;
    185   my $id = shift;
    186   my $addr = shift;
    187 
    188   return if $revrec ne 'y';     # this sub not useful in forward zones
    189 
    190   $$addr = NetAddr::IP->new($$val);      #necessary?
    191 
    192   # subsub to split, reverse, and overlay an IP fragment on a netblock
    193   sub __rev_overlay {
    194     my $splitme = shift;        # ':' or '.', m'lud?
    195     my $parnet = shift;
    196     my $val = shift;
    197     my $addr = shift;
    198 
    199     my $joinme = $splitme;
    200     $splitme = '\.' if $splitme eq '.';
    201     my @working = reverse(split($splitme, $parnet->addr));
    202     my @parts = reverse(split($splitme, $$val));
    203     for (my $i = 0; $i <= $#parts; $i++) {
    204       $working[$i] = $parts[$i];
    205     }
    206     my $checkme = NetAddr::IP->new(join($joinme, reverse(@working))) or return 0;
    207     return 0 unless $checkme->within($parnet);
    208     $$addr = $checkme;  # force "correct" IP to be recorded.
    209     return 1;
    210   }
    211 
    212   my ($parstr) = $dbh->selectrow_array("SELECT revnet FROM revzones WHERE rdns_id = ?", undef, ($id));
    213   my $parnet = NetAddr::IP->new($parstr);
    214 
    215   # Fail early on v6-in-v4 or v4-in-v6.  We're not accepting these ATM.
    216   return 0 if $parnet->addr =~ /\./ && $$val =~ /:/;
    217   return 0 if $parnet->addr =~ /:/ && $$val =~ /\./;
    218 
    219   if ($$addr && $$val =~ /^[\da-fA-F][\da-fA-F:]+[\da-fA-F]$/) {
    220     # the only case where NetAddr::IP's acceptance of legitimate IPs is "correct" is for a proper IPv6 address.
    221     # the rest we have to restructure before fiddling.  *sigh*
    222     return 1 if $$addr->within($parnet);
    223   } else {
    224     # We don't have a complete IP in $$val (yet)
    225     if ($parnet->addr =~ /:/) {
    226       $$val =~ s/^:+//;  # gotta strip'em all...
    227       return __rev_overlay(':', $parnet, $val, $addr);
    228     }
    229     if ($parnet->addr =~ /\./) {
    230       $$val =~ s/^\.+//;
    231       return __rev_overlay('.', $parnet, $val, $addr);
    232     }
    233     # should be impossible to get here...
    234   }
    235   # ... and here.
    236   # can't do nuttin' in forward zones
    237 } # end _ipparent()
    238 
    239 # A little different than _ipparent above;  this tries to *find* the parent zone of a hostname
    240 sub _hostparent {
    241   my $dbh = shift;
    242   my $hname = shift;
    243  
    244   my @hostbits = split /\./, $hname;
    245   my $sth = $dbh->prepare("SELECT count(*),domain_id FROM domains WHERE domain = ? GROUP BY domain_id");
    246   foreach (@hostbits) {
    247     $sth->execute($hname);
    248     my ($found, $parid) = $sth->fetchrow_array;
    249     if ($found) {
    250       return $parid;
    251     }
    252     $hname =~ s/^$_\.//;
    253   }
    254 } # end _hostparent()
    255 
    256 ##
    257 ## Record validation subs.
    258 ##
    259 
    260 # A record
    261 sub _validate_1 {
    262   my $dbh = shift;
    263 
    264   my %args = @_;
    265 
    266   return ('FAIL', 'Reverse zones cannot contain A records') if $args{revrec} eq 'y';
    267 
    268   # Coerce all hostnames to end in ".DOMAIN" for group/default records,
    269   # or the intended parent domain for live records.
    270   my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
    271   ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
    272 
    273   # Check IP is well-formed, and that it's a v4 address
    274   # Fail on "compact" IPv4 variants, because they are not consistent and predictable.
    275   return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv4 address")
    276         unless ${$args{val}} =~ /^\d+\.\d+\.\d+\.\d+$/;
    277   return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv4 address")
    278         unless $args{addr} && !$args{addr}->{isv6};
    279   # coerce IP/value to normalized form for storage
    280   ${$args{val}} = $args{addr}->addr;
    281 
    282   return ('OK','OK');
    283 } # done A record
    284 
    285 # NS record
    286 sub _validate_2 {
    287   my $dbh = shift;
    288 
    289   my %args = @_;
    290 
    291   # Coerce the hostname to "DOMAIN" for forward default records, "ZONE" for reverse default records,
    292   # or the intended parent zone for live records.
    293 ##fixme:  allow for delegating <subdomain>.DOMAIN?
    294   if ($args{revrec} eq 'y') {
    295     my $pname = ($args{defrec} eq 'y' ? 'ZONE' : revName($dbh,$args{id}));
    296     ${$args{host}} = $pname if ${$args{host}} ne $pname;
    297   } else {
    298     my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
    299     ${$args{host}} = $pname if ${$args{host}} ne $pname;
    300   }
    301 
    302 # Let this lie for now.  Needs more magic.
    303 #  # Check IP is well-formed, and that it's a v4 address
    304 #  return ('FAIL',"A record must be a valid IPv4 address")
    305 #       unless $addr && !$addr->{isv6};
    306 #  # coerce IP/value to normalized form for storage
    307 #  $$val = $addr->addr;
    308 
    309   return ('OK','OK');
    310 } # done NS record
    311 
    312 # CNAME record
    313 sub _validate_5 {
    314   my $dbh = shift;
    315 
    316   my %args = @_;
    317 
    318 # Not really true, but these are only useful for delegating smaller-than-/24 IP blocks.
    319 # This is fundamentally a messy operation and should really just be taken care of by the
    320 # export process, not manual maintenance of the necessary records.
    321   return ('FAIL', 'Reverse zones cannot contain CNAME records') if $args{revrec} eq 'y';
    322 
    323   # Coerce all hostnames to end in ".DOMAIN" for group/default records,
    324   # or the intended parent domain for live records.
    325   my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
    326   ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
    327 
    328   return ('OK','OK');
    329 } # done CNAME record
    330 
    331 # SOA record
    332 sub _validate_6 {
    333   # Smart monkeys won't stick their fingers in here;  we have
    334   # separate dedicated routines to deal with SOA records.
    335   return ('OK','OK');
    336 } # done SOA record
    337 
    338 # PTR record
    339 sub _validate_12 {
    340   my $dbh = shift;
    341 
    342   my %args = @_;
    343 
    344   if ($args{revrec} eq 'y') {
    345     if ($args{defrec} eq 'n') {
    346       return ('FAIL', "IP or IP fragment ${$args{val}} is not within ".revName($dbh, $args{id}))
    347         unless _ipparent($dbh, $args{defrec}, $args{revrec}, $args{val}, $args{id}, \$args{addr});
    348       ${$args{val}} = $args{addr}->addr;
    349     } else {
    350       if (${$args{val}} =~ /\./) {
    351         # looks like a v4 or fragment
    352         if (${$args{val}} =~ /^\d+\.\d+\.\d+\.\d+$/) {
    353           # woo!  a complete IP!  validate it and normalize, or fail.
    354           $args{addr} = NetAddr::IP->new(${$args{val}})
    355                 or return ('FAIL', "IP/value looks like IPv4 but isn't valid");
    356           ${$args{val}} = $args{addr}->addr;
    357         } else {
    358           ${$args{val}} =~ s/^\.*/ZONE./ unless ${$args{val}} =~ /^ZONE/;
    359         }
    360       } elsif (${$args{val}} =~ /[a-f:]/) {
    361         # looks like a v6 or fragment
    362         ${$args{val}} =~ s/^:*/ZONE::/ if !$args{addr} && ${$args{val}} !~ /^ZONE/;
    363         if ($args{addr}) {
    364           if ($args{addr}->addr =~ /^0/) {
    365             ${$args{val}} =~ s/^:*/ZONE::/ unless ${$args{val}} =~ /^ZONE/;
    366           } else {
    367             ${$args{val}} = $args{addr}->addr;
    368           }
    369         }
    370       } else {
    371         # bare number (probably).  These could be v4 or v6, so we'll
    372         # expand on these on creation of a reverse zone.
    373         ${$args{val}} = "ZONE,${$args{val}}" unless ${$args{val}} =~ /^ZONE/;
    374       }
    375       ${$args{host}} =~ s/\.*$/\.$config{domain}/ if ${$args{host}} !~ /(?:$config{domain}|ADMINDOMAIN)$/;
    376     }
    377 
    378 # Multiple PTR records do NOT generally do what most people believe they do,
    379 # and tend to fail in the most awkward way possible.  Check and warn.
    380 # We use $val instead of $addr->addr since we may be in a defrec, and may have eg "ZONE::42" or "ZONE.12"
    381 
    382     my @checkvals = (${$args{val}});
    383     if (${$args{val}} =~ /,/) {
    384       # push . and :: variants into checkvals if val has ,
    385       my $tmp;
    386       ($tmp = ${$args{val}}) =~ s/,/./;
    387       push @checkvals, $tmp;
    388       ($tmp = ${$args{val}}) =~ s/,/::/;
    389       push @checkvals, $tmp;
    390     }
    391     my $pcsth = $dbh->prepare("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec})." WHERE val = ?");
    392     foreach my $checkme (@checkvals) {
    393       my $ptrcount;
    394       ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}).
    395         " WHERE val = ?", undef, ($checkme));
    396       return ('WARN', "PTR record for $checkme already exists;  adding another will probably not do what you want")
    397         if $ptrcount;
    398     }
    399   } else {
    400     # Not absolutely true but only useful if you hack things up for sub-/24 v4 reverse delegations
    401     # Simpler to just create the reverse zone and grant access for the customer to edit it, and create direct
    402     # PTR records on export
    403     return ('FAIL',"Forward zones cannot contain PTR records");
    404   }
    405 
    406   return ('OK','OK');
    407 } # done PTR record
    408 
    409 # MX record
    410 sub _validate_15 {
    411   my $dbh = shift;
    412 
    413   my %args = @_;
    414 
    415 # Not absolutely true but WTF use is an MX record for a reverse zone?
    416   return ('FAIL', 'Reverse zones cannot contain MX records') if $args{revrec} eq 'y';
    417 
    418   return ('FAIL', "Distance is required for MX records") unless defined(${$args{dist}});
    419   ${$args{dist}} =~ s/\s*//g;
    420   return ('FAIL',"Distance is required, and must be numeric") unless ${$args{dist}} =~ /^\d+$/;
    421 
    422   ${$args{fields}} = "distance,";
    423   push @{$args{vallist}}, ${$args{dist}};
    424 
    425   # Coerce all hostnames to end in ".DOMAIN" for group/default records,
    426   # or the intended parent domain for live records.
    427   my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
    428   ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
    429 
    430   return ('OK','OK');
    431 } # done MX record
    432 
    433 # TXT record
    434 sub _validate_16 {
    435   # Could arguably put a WARN return here on very long (>512) records
    436   return ('OK','OK');
    437 } # done TXT record
    438 
    439 # RP record
    440 sub _validate_17 {
    441   # Probably have to validate these some day
    442   return ('OK','OK');
    443 } # done RP record
    444 
    445 # AAAA record
    446 sub _validate_28 {
    447   my $dbh = shift;
    448 
    449   my %args = @_;
    450 
    451   return ('FAIL', 'Reverse zones cannot contain AAAA records') if $args{revrec} eq 'y';
    452 
    453   # Coerce all hostnames to end in ".DOMAIN" for group/default records,
    454   # or the intended parent domain for live records.
    455   my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
    456   ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
    457 
    458   # Check IP is well-formed, and that it's a v6 address
    459   return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv6 address")
    460         unless $args{addr} && $args{addr}->{isv6};
    461   # coerce IP/value to normalized form for storage
    462   ${$args{val}} = $args{addr}->addr;
    463 
    464   return ('OK','OK');
    465 } # done AAAA record
    466 
    467 # SRV record
    468 sub _validate_33 {
    469   my $dbh = shift;
    470 
    471   my %args = @_;
    472 
    473 # Not absolutely true but WTF use is an SRV record for a reverse zone?
    474   return ('FAIL', 'Reverse zones cannot contain SRV records') if $args{revrec} eq 'y';
    475 
    476   return ('FAIL', "Distance is required for SRV records") unless defined(${$args{dist}});
    477   ${$args{dist}} =~ s/\s*//g;
    478   return ('FAIL',"Distance is required, and must be numeric") unless ${$args{dist}} =~ /^\d+$/;
    479 
    480   return ('FAIL',"SRV records must begin with _service._protocol [${$args{host}}]")
    481         unless ${$args{host}} =~ /^_[A-Za-z]+\._[A-Za-z]+\.[a-zA-Z0-9-]+/;
    482   return ('FAIL',"Port and weight are required for SRV records")
    483         unless defined(${$args{weight}}) && defined(${$args{port}});
    484   ${$args{weight}} =~ s/\s*//g;
    485   ${$args{port}} =~ s/\s*//g;
    486 
    487   return ('FAIL',"Port and weight are required, and must be numeric")
    488         unless ${$args{weight}} =~ /^\d+$/ && ${$args{port}} =~ /^\d+$/;
    489 
    490   ${$args{fields}} = "distance,weight,port,";
    491   push @{$args{vallist}}, (${$args{dist}}, ${$args{weight}}, ${$args{port}});
    492 
    493   # Coerce all hostnames to end in ".DOMAIN" for group/default records,
    494   # or the intended parent domain for live records.
    495   my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
    496   ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
    497 
    498   return ('OK','OK');
    499 } # done SRV record
    500 
    501 # Now the custom types
    502 
    503 # A+PTR record.  With a very little bit of magic we can also use this sub to validate AAAA+PTR.  Whee!
    504 sub _validate_65280 {
    505   my $dbh = shift;
    506 
    507   my %args = @_;
    508 
    509   my $code = 'OK';
    510   my $msg = 'OK';
    511 
    512   if ($args{defrec} eq 'n') {
    513     # live record;  revrec determines whether we validate the PTR or A component first.
    514 
    515     if ($args{revrec} eq 'y') {
    516       ($code,$msg) = _validate_12($dbh, %args);
    517       return ($code,$msg) if $code eq 'FAIL';
    518 
    519       # Check if the reqested domain exists.  If not, coerce the type down to PTR and warn.
    520       if (!(${$args{domid}} = _hostparent($dbh, ${$args{host}}))) {
    521         my $addmsg = "Record added as PTR instead of $typemap{${$args{rectype}}};  domain not found for ${$args{host}}";
    522         $msg .= "\n$addmsg" if $code eq 'WARN';
    523         $msg = $addmsg if $code eq 'OK';
    524         ${$args{rectype}} = $reverse_typemap{PTR};
    525         return ('WARN', $msg);
    526       }
    527 
    528       # Add domain ID to field list and values
    529       ${$args{fields}} .= "domain_id,";
    530       push @{$args{vallist}}, ${$args{domid}};
    531 
    532     } else {
    533       ($code,$msg) = _validate_1($dbh, %args) if ${$args{rectype}} == 65280;
    534       ($code,$msg) = _validate_28($dbh, %args) if ${$args{rectype}} == 65281;
    535       return ($code,$msg) if $code eq 'FAIL';
    536 
    537       # Check if the requested reverse zone exists - note, an IP fragment won't
    538       # work here since we don't *know* which parent to put it in.
    539       # ${$args{val}} has been validated as a valid IP by now, in one of the above calls.
    540       my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?".
    541         " ORDER BY masklen(revnet) DESC", undef, (${$args{val}}));
    542       if (!$revid) {
    543         $msg = "Record added as ".(${$args{rectype}} == 65280 ? 'A' : 'AAAA').
    544                 " instead of $typemap{${$args{rectype}}};  reverse zone not found for ${$args{val}}";
    545         ${$args{rectype}} = (${$args{rectype}} == 65280 ? $reverse_typemap{A} : $reverse_typemap{AAAA});
    546         return ('WARN', $msg);
    547       }
    548 
    549       # Check for duplicate PTRs.  Note we don't have to play games with $code and $msg, because
    550       # by definition there can't be duplicate PTRs if the reverse zone isn't managed here.
    551       my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}).
    552         " WHERE val = ?", undef, ${$args{val}});
    553       if ($ptrcount) {
    554         $msg = "PTR record for ${$args{val}} already exists;  adding another will probably not do what you want";
    555         $code = 'WARN';
    556       }
    557 
    558       ${$args{fields}} .= "rdns_id,";
    559       push @{$args{vallist}}, $revid;
    560     }
    561 
    562   } else {      # defrec eq 'y'
    563     if ($args{revrec} eq 'y') {
    564       ($code,$msg) = _validate_12($dbh, %args);
    565       return ($code,$msg) if $code eq 'FAIL';
    566       if (${$args{rectype}} == 65280) {
    567         return ('FAIL',"A+PTR record must be a valid IPv4 address or fragment")
    568                 if ${$args{val}} =~ /:/;
    569         ${$args{val}} =~ s/^ZONE,/ZONE./;       # Clean up after uncertain IP-fragment-type from _validate_12
    570       } elsif (${$args{rectype}} == 65281) {
    571         return ('FAIL',"AAAA+PTR record must be a valid IPv6 address or fragment")
    572                 if ${$args{val}} =~ /\./;
    573         ${$args{val}} =~ s/^ZONE,/ZONE::/;      # Clean up after uncertain IP-fragment-type from _validate_12
    574       }
    575     } else {
    576       # This is easy.  I also can't see a real use-case for A/AAAA+PTR in *all* forward
    577       # domains, since you wouldn't be able to substitute both domain and reverse zone
    578       # sanely, and you'd end up with guaranteed over-replicated PTR records that would
    579       # confuse the hell out of pretty much anything that uses them.
    580 ##fixme: make this a config flag?
    581       return ('FAIL', "$typemap{${$args{rectype}}} records not allowed in default domains");
    582     }
    583   }
    584 
    585   return ($code, $msg);
    586 } # done A+PTR record
    587 
    588 # AAAA+PTR record
    589 # A+PTR above has been magicked to handle AAAA+PTR as well.
    590 sub _validate_65281 {
    591   return _validate_65280(@_);
    592 } # done AAAA+PTR record
    593 
    594 # PTR template record
    595 sub _validate_65282 {
    596   return ('OK','OK');
    597 } # done PTR template record
    598 
    599 # A+PTR template record
    600 sub _validate_65283 {
    601   return ('OK','OK');
    602 } # done AAAA+PTR template record
    603 
    604 # AAAA+PTR template record
    605 sub _validate_65284 {
    606   return ('OK','OK');
    607 } # done AAAA+PTR template record
    608 
    609 
    610 
    611 ##
    612 ## Initialization and cleanup subs
    613 ##
    614 
    615 
    616 ## DNSDB::loadConfig()
    617 # Load the minimum required initial state (DB connect info) from a config file
    618 # Load misc other bits while we're at it.
    619 # Takes an optional basename and config path to look for
    620 # Populates the %config and %def hashes
    621 sub loadConfig {
    622   my $basename = shift || '';   # this will work OK
    623 ##fixme  $basename isn't doing what I think I thought I was trying to do.
    624 
    625   my $deferr = '';      # place to put error from default config file in case we can't find either one
    626 
    627   my $configroot = "/etc/dnsdb";        ##CFG_LEAF##
    628   $configroot = '' if $basename =~ m|^/|;
    629   $basename .= ".conf" if $basename !~ /\.conf$/;
    630   my $defconfig = "$configroot/dnsdb.conf";
    631   my $siteconfig = "$configroot/$basename";
    632 
    633   # System defaults
    634   __cfgload("$defconfig") or $deferr = $errstr;
    635 
    636   # Per-site-ish settings.
    637   if ($basename ne '.conf') {
    638     unless (__cfgload("$siteconfig")) {
    639       $errstr = ($deferr ? "Error opening default config file $defconfig: $deferr\n" : '').
    640         "Error opening site config file $siteconfig";
    641       return;
    642     }
    643   }
    644 
    645   # Munge log_failures.
    646   if ($config{log_failures} ne '1' && $config{log_failures} ne '0') {
    647     # true/false, on/off, yes/no all valid.
    648     if ($config{log_failures} =~ /^(?:true|false|on|off|yes|no)$/) {
    649       if ($config{log_failures} =~ /(?:true|on|yes)/) {
    650         $config{log_failures} = 1;
    651       } else {
    652         $config{log_failures} = 0;
    653       }
    654     } else {
    655       $errstr = "Bad log_failures setting $config{log_failures}";
    656       $config{log_failures} = 1;
    657       # Bad setting shouldn't be fatal.
    658       # return 2;
    659     }
    660   }
    661 
    662   # All good, clear the error and go home.
    663   $errstr = '';
    664   return 1;
    665 } # end loadConfig()
    666 
    667 
    668 ## DNSDB::__cfgload()
    669 # Private sub to parse a config file and load it into %config
    670 # Takes a file handle on an open config file
    671 sub __cfgload {
    672   $errstr = '';
    673   my $cfgfile = shift;
    674 
    675   if (open CFG, "<$cfgfile") {
    676     while (<CFG>) {
    677       chomp;
    678       s/^\s*//;
    679       next if /^#/;
    680       next if /^$/;
    681 # hmm.  more complex bits in this file might require [heading] headers, maybe?
    682 #    $mode = $1 if /^\[(a-z)+]/;
    683     # DB connect info
    684       $config{dbname}   = $1 if /^dbname\s*=\s*([a-z0-9_.-]+)/i;
    685       $config{dbuser}   = $1 if /^dbuser\s*=\s*([a-z0-9_.-]+)/i;
    686       $config{dbpass}   = $1 if /^dbpass\s*=\s*([a-z0-9_.-]+)/i;
    687       $config{dbhost}   = $1 if /^dbhost\s*=\s*([a-z0-9_.-]+)/i;
    688       # SOA defaults
    689       $def{contact}     = $1 if /^contact\s*=\s*([a-z0-9_.-]+)/i;
    690       $def{prins}       = $1 if /^prins\s*=\s*([a-z0-9_.-]+)/i;
    691       $def{soattl}      = $1 if /^soattl\s*=\s*(\d+)/i;
    692       $def{refresh}     = $1 if /^refresh\s*=\s*(\d+)/i;
    693       $def{retry}       = $1 if /^retry\s*=\s*(\d+)/i;
    694       $def{expire}      = $1 if /^expire\s*=\s*(\d+)/i;
    695       $def{minttl}      = $1 if /^minttl\s*=\s*(\d+)/i;
    696       $def{ttl}         = $1 if /^ttl\s*=\s*(\d+)/i;
    697       # Mail settings
    698       $config{mailhost}         = $1 if /^mailhost\s*=\s*([a-z0-9_.-]+)/i;
    699       $config{mailnotify}       = $1 if /^mailnotify\s*=\s*([a-z0-9_.\@-]+)/i;
    700       $config{mailsender}       = $1 if /^mailsender\s*=\s*([a-z0-9_.\@-]+)/i;
    701       $config{mailname}         = $1 if /^mailname\s*=\s*([a-z0-9\s_.-]+)/i;
    702       $config{orgname}          = $1 if /^orgname\s*=\s*([a-z0-9\s_.,'-]+)/i;
    703       $config{domain}           = $1 if /^domain\s*=\s*([a-z0-9_.-]+)/i;
    704       # session - note this is fed directly to CGI::Session
    705       $config{timeout}          = $1 if /^[tT][iI][mM][eE][oO][uU][tT]\s*=\s*(\d+[smhdwMy]?)/;
    706       $config{sessiondir}       = $1 if m{^sessiondir\s*=\s*([a-z0-9/_.-]+)}i;
    707       # misc
    708       $config{log_failures}     = $1 if /^log_failures\s*=\s*([a-z01]+)/i;
    709       $config{perpage}          = $1 if /^perpage\s*=\s*(\d+)/i;
    710     }
    711     close CFG;
    712   } else {
    713     $errstr = $!;
    714     return;
    715   }
    716   return 1;
    717 } # end __cfgload()
    718 
    719 
    720 ## DNSDB::connectDB()
    721 # Creates connection to DNS database.
    722 # Requires the database name, username, and password.
    723 # Returns a handle to the db.
    724 # Set up for a PostgreSQL db;  could be any transactional DBMS with the
    725 # right changes.
    726 sub connectDB {
    727   $errstr = '';
    728   my $dbname = shift;
    729   my $user = shift;
    730   my $pass = shift;
    731   my $dbh;
    732   my $DSN = "DBI:Pg:dbname=$dbname";
    733 
    734   my $host = shift;
    735   $DSN .= ";host=$host" if $host;
    736 
    737 # Note that we want to autocommit by default, and we will turn it off locally as necessary.
    738 # We may not want to print gobbledygook errors;  YMMV.  Have to ponder that further.
    739   $dbh = DBI->connect($DSN, $user, $pass, {
    740         AutoCommit => 1,
    741         PrintError => 0
    742         })
    743     or return (undef, $DBI::errstr) if(!$dbh);
    744 
    745 ##fixme:  initialize the DB if we can't find the table (since, by definition, there's
    746 # nothing there if we can't select from it...)
    747   my $tblsth = $dbh->prepare("SELECT count(*) FROM pg_catalog.pg_class WHERE relkind='r' AND relname=?");
    748   my ($tblcount) = $dbh->selectrow_array($tblsth, undef, ('misc'));
    749   return (undef,$DBI::errstr) if $dbh->err;
    750 
    751 #if ($tblcount == 0) {
    752 #  # create tables one at a time, checking for each.
    753 #  return (undef, "check table misc missing");
    754 #}
    755 
    756 
    757 # Return here if we can't select.
    758 # This should retrieve the dbversion key.
    759   my $sth = $dbh->prepare("SELECT key,value FROM misc WHERE misc_id=1");
    760   $sth->execute();
    761   return (undef,$DBI::errstr) if ($sth->err);
    762 
    763 ##fixme:  do stuff to the DB on version mismatch
    764 # x.y series should upgrade on $DNSDB::VERSION > misc(key=>version)
    765 # DB should be downward-compatible;  column defaults should give sane (if possibly
    766 # useless-and-needs-help) values in columns an older software stack doesn't know about.
    767 
    768 # See if the select returned anything (or null data).  This should
    769 # succeed if the select executed, but...
    770   $sth->fetchrow();
    771   return (undef,$DBI::errstr)  if ($sth->err);
    772 
    773   $sth->finish;
    774 
    775 # If we get here, we should be OK.
    776   return ($dbh,"DB connection OK");
    777 } # end connectDB
    778 
    779 
    780 ## DNSDB::finish()
    781 # Cleans up after database handles and so on.
    782 # Requires a database handle
    783 sub finish {
    784   my $dbh = $_[0];
    785   $dbh->disconnect;
    786 } # end finish
    787 
    788 
    789 ## DNSDB::initGlobals()
    790 # Initialize global variables
    791 # NB: this does NOT include web-specific session variables!
    792 # Requires a database handle
    793 sub initGlobals {
    794   my $dbh = shift;
    795 
    796 # load record types from database
    797   my $sth = $dbh->prepare("SELECT val,name,stdflag FROM rectypes");
    798   $sth->execute;
    799   while (my ($recval,$recname,$stdflag) = $sth->fetchrow_array()) {
    800     $typemap{$recval} = $recname;
    801     $reverse_typemap{$recname} = $recval;
    802     # now we fill the record validation function hash
    803     if ($stdflag < 5) {
    804       my $fn = "_validate_$recval";
    805       $validators{$recval} = \&$fn;
    806     } else {
    807       my $fn = "sub { return ('FAIL','Type $recval ($recname) not supported'); }";
    808       $validators{$recval} = eval $fn;
    809     }
    810   }
    811 } # end initGlobals
    812 
    813 
    814 ## DNSDB::initPermissions()
    815 # Set up permissions global
    816 # Takes database handle and UID
    817 sub initPermissions {
    818   my $dbh = shift;
    819   my $uid = shift;
    820 
    821 #  %permissions = $(getPermissions($dbh,'user',$uid));
    822   getPermissions($dbh, 'user', $uid, \%permissions);
    823 
    824 } # end initPermissions()
    825 
    826 
    827 ## DNSDB::getPermissions()
    828 # Get permissions from DB
    829 # Requires DB handle, group or user flag, ID, and hashref.
    830 sub getPermissions {
    831   my $dbh = shift;
    832   my $type = shift;
    833   my $id = shift;
    834   my $hash = shift;
    835 
    836   my $sql = qq(
    837         SELECT
    838         p.admin,p.self_edit,
    839         p.group_create,p.group_edit,p.group_delete,
    840         p.user_create,p.user_edit,p.user_delete,
    841         p.domain_create,p.domain_edit,p.domain_delete,
    842         p.record_create,p.record_edit,p.record_delete
    843         FROM permissions p
    844         );
    845   if ($type eq 'group') {
    846     $sql .= qq(
    847         JOIN groups g ON g.permission_id=p.permission_id
    848         WHERE g.group_id=?
    849         );
    850   } else {
    851     $sql .= qq(
    852         JOIN users u ON u.permission_id=p.permission_id
    853         WHERE u.user_id=?
    854         );
    855   }
    856 
    857   my $sth = $dbh->prepare($sql);
    858 
    859   $sth->execute($id) or die "argh: ".$sth->errstr;
    860 
    861 #  my $permref = $sth->fetchrow_hashref;
    862 #  return $permref;
    863 #  $hash = $permref;
    864 # Eww.  Need to learn how to forcibly drop a hashref onto an existing hash.
    865   ($hash->{admin},$hash->{self_edit},
    866         $hash->{group_create},$hash->{group_edit},$hash->{group_delete},
    867         $hash->{user_create},$hash->{user_edit},$hash->{user_delete},
    868         $hash->{domain_create},$hash->{domain_edit},$hash->{domain_delete},
    869         $hash->{record_create},$hash->{record_edit},$hash->{record_delete})
    870         = $sth->fetchrow_array;
    871 
    872 } # end getPermissions()
    873 
    874 
    875 ## DNSDB::changePermissions()
    876 # Update an ACL entry
    877 # Takes a db handle, type, owner-id, and hashref for the changed permissions.
    878 sub changePermissions {
    879   my $dbh = shift;
    880   my $type = shift;
    881   my $id = shift;
    882   my $newperms = shift;
    883   my $inherit = shift || 0;
    884 
    885   my $failmsg = '';
    886 
    887   # see if we're switching from inherited to custom.  for bonus points,
    888   # snag the permid and parent permid anyway, since we'll need the permid
    889   # to set/alter custom perms, and both if we're switching from custom to
    890   # inherited.
    891   my $sth = $dbh->prepare("SELECT (u.permission_id=g.permission_id) AS was_inherited,u.permission_id,g.permission_id".
    892         " FROM ".($type eq 'user' ? 'users' : 'groups')." u ".
    893         " JOIN groups g ON u.".($type eq 'user' ? '' : 'parent_')."group_id=g.group_id ".
    894         " WHERE u.".($type eq 'user' ? 'user' : 'group')."_id=?");
    895   $sth->execute($id);
    896 
    897   my ($wasinherited,$permid,$parpermid) = $sth->fetchrow_array;
    898 
    899 # hack phtoui
    900 # group id 1 is "special" in that it's it's own parent (err...  possibly.)
    901 # may make its parent id 0 which doesn't exist, and as a bonus is Perl-false.
    902   $wasinherited = 0 if ($type eq 'group' && $id == 1);
    903 
    904   local $dbh->{AutoCommit} = 0;
    905   local $dbh->{RaiseError} = 1;
    906 
    907   # Wrap all the SQL in a transaction
    908   eval {
    909     if ($inherit) {
    910 
    911       $dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='t',permission_id=? ".
    912         "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($parpermid, $id) );
    913       $dbh->do("DELETE FROM permissions WHERE permission_id=?", undef, ($permid) );
    914 
    915     } else {
    916 
    917       if ($wasinherited) {      # munge new permission entry in if we're switching from inherited perms
    918 ##fixme: need to add semirecursive bit to properly munge inherited permission ID on subgroups and users
    919 # ... if'n'when we have groups with fully inherited permissions.
    920         # SQL is coo
    921         $dbh->do("INSERT INTO permissions ($permlist,".($type eq 'user' ? 'user' : 'group')."_id) ".
    922                 "SELECT $permlist,? FROM permissions WHERE permission_id=?", undef, ($id,$permid) );
    923         ($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions ".
    924                 "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($id) );
    925         $dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='f',permission_id=? ".
    926                 "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($permid, $id) );
    927       }
    928 
    929       # and now set the permissions we were passed
    930       foreach (@permtypes) {
    931         if (defined ($newperms->{$_})) {
    932           $dbh->do("UPDATE permissions SET $_=? WHERE permission_id=?", undef, ($newperms->{$_},$permid) );
    933         }
    934       }
    935 
    936     } # (inherited->)? custom
    937 
    938     $dbh->commit;
    939   }; # end eval
    940   if ($@) {
    941     my $msg = $@;
    942     eval { $dbh->rollback; };
    943     return ('FAIL',"$failmsg: $msg ($permid)");
    944   } else {
    945     return ('OK',$permid);
    946   }
    947 
    948 } # end changePermissions()
    949 
    950 
    951 ## DNSDB::comparePermissions()
    952 # Compare two permission hashes
    953 # Returns '>', '<', '=', '!'
    954 sub comparePermissions {
    955   my $p1 = shift;
    956   my $p2 = shift;
    957 
    958   my $retval = '=';     # assume equality until proven otherwise
    959 
    960   no warnings "uninitialized";
    961 
    962   foreach (@permtypes) {
    963     next if $p1->{$_} == $p2->{$_};     # equal is good
    964     if ($p1->{$_} && !$p2->{$_}) {
    965       if ($retval eq '<') {     # if we've already found an unequal pair where
    966         $retval = '!';          # $p2 has more access, and we now find a pair
    967         last;                   # where $p1 has more access, the overall access
    968       }                         # is neither greater or lesser, it's unequal.
    969       $retval = '>';
    970     }
    971     if (!$p1->{$_} && $p2->{$_}) {
    972       if ($retval eq '>') {     # if we've already found an unequal pair where
    973         $retval = '!';          # $p1 has more access, and we now find a pair
    974         last;                   # where $p2 has more access, the overall access
    975       }                         # is neither greater or lesser, it's unequal.
    976       $retval = '<';
    977     }
    978   }
    979   return $retval;
    980 } # end comparePermissions()
    981 
    982 
    983 ## DNSDB::changeGroup()
    984 # Change group ID of an entity
    985 # Takes a database handle, entity type, entity ID, and new group ID
    986 sub changeGroup {
    987   my $dbh = shift;
    988   my $type = shift;
    989   my $id = shift;
    990   my $newgrp = shift;
    991 
    992 ##fixme:  fail on not enough args
    993   #return ('FAIL', "Missing
    994 
    995   if ($type eq 'domain') {
    996     $dbh->do("UPDATE domains SET group_id=? WHERE domain_id=?", undef, ($newgrp, $id))
    997         or return ('FAIL','Group change failed: '.$dbh->errstr);
    998   } elsif ($type eq 'user') {
    999     $dbh->do("UPDATE users SET group_id=? WHERE user_id=?", undef, ($newgrp, $id))
    1000         or return ('FAIL','Group change failed: '.$dbh->errstr);
    1001   } elsif ($type eq 'group') {
    1002     $dbh->do("UPDATE groups SET parent_group_id=? WHERE group_id=?", undef, ($newgrp, $id))
    1003         or return ('FAIL','Group change failed: '.$dbh->errstr);
    1004   }
    1005   return ('OK','OK');
    1006 } # end changeGroup()
    1007 
    1008 
    1009 ## DNSDB::_log()
    1010 # Log an action
    1011 # Internal sub
    1012 # Takes a database handle and log entry hash containing at least:
    1013 # user_id, group_id, log entry
    1014 # and optionally one or more of:
    1015 # username/email, user full name, domain_id, rdns_id
    1016 ##fixme:  convert to trailing hash for user info
    1017 # User info must contain a (user ID OR username)+fullname
    1018 sub _log {
    1019   my $dbh = shift;
    1020 
    1021   my %args = @_;
    1022 
    1023   $args{rdns_id} = 0 if !$args{rdns_id};
    1024   $args{domain_id} = 0 if !$args{domain_id};
    1025 
    1026 ##fixme:  need better way(s?) to snag userinfo for log entries.  don't want to have
    1027 # to pass around yet *another* constant (already passing $dbh, shouldn't need to)
    1028   my $fullname;
    1029   if (!$args{user_id}) {
    1030     ($args{user_id}, $fullname) = $dbh->selectrow_array("SELECT user_id, firstname || ' ' || lastname FROM users".
    1031         " WHERE username=?", undef, ($args{username}));
    1032   }
    1033   if (!$args{username}) {
    1034     ($args{username}, $fullname) = $dbh->selectrow_array("SELECT username, firstname || ' ' || lastname FROM users".
    1035         " WHERE user_id=?", undef, ($args{user_id}));
    1036   }
    1037   if (!$args{fullname}) {
    1038     ($fullname) = $dbh->selectrow_array("SELECT firstname || ' ' || lastname FROM users".
    1039         " WHERE user_id=?", undef, ($args{user_id}));
    1040   }
    1041 
    1042   $args{name} = $fullname if !$args{name};
    1043 
    1044 ##fixme:  farm out the actual logging to different subs for file, syslog, internal, etc based on config
    1045   $dbh->do("INSERT INTO log (domain_id,rdns_id,user_id,group_id,email,name,entry) VALUES (?,?,?,?,?,?,?)",
    1046         undef,
    1047         ($args{domain_id},$args{rdns_id},$args{user_id},$args{group_id},$args{username},$args{name},$args{entry}));
    1048 
    1049 } # end _log
    1050 
    1051 
    1052 ##
    1053 ## Processing subs
    1054 ##
    1055 
    1056 ## DNSDB::addDomain()
    1057 # Add a domain
    1058 # Takes a database handle, domain name, numeric group, boolean(ish) state (active/inactive),
    1059 # and user info hash (for logging).
    1060 # Returns a status code and message
    1061 sub addDomain {
    1062   $errstr = '';
    1063   my $dbh = shift;
    1064   return ('FAIL',"Need database handle") if !$dbh;
    1065   my $domain = shift;
    1066   return ('FAIL',"Domain must not be blank") if !$domain;
    1067   my $group = shift;
    1068   return ('FAIL',"Need group") if !defined($group);
    1069   my $state = shift;
    1070   return ('FAIL',"Need domain status") if !defined($state);
    1071 
    1072   my %userinfo = @_;    # remaining bits.
    1073 # user ID, username, user full name
    1074 
    1075   $state = 1 if $state =~ /^active$/;
    1076   $state = 1 if $state =~ /^on$/;
    1077   $state = 0 if $state =~ /^inactive$/;
    1078   $state = 0 if $state =~ /^off$/;
    1079 
    1080   return ('FAIL',"Invalid domain status") if $state !~ /^\d+$/;
    1081 
    1082   return ('FAIL', "Invalid characters in domain") if $domain !~ /^[a-zA-Z0-9_.-]+$/;
    1083 
    1084   my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
    1085   my $dom_id;
    1086 
    1087 # quick check to start to see if we've already got one
    1088   $sth->execute($domain);
    1089   ($dom_id) = $sth->fetchrow_array;
    1090 
    1091   return ('FAIL', "Domain already exists") if $dom_id;
    1092 
    1093   # Allow transactions, and raise an exception on errors so we can catch it later.
    1094   # Use local to make sure these get "reset" properly on exiting this block
    1095   local $dbh->{AutoCommit} = 0;
    1096   local $dbh->{RaiseError} = 1;
    1097 
    1098   # Wrap all the SQL in a transaction
    1099   eval {
    1100     # insert the domain...
    1101     $dbh->do("INSERT INTO domains (domain,group_id,status) VALUES (?,?,?)", undef, ($domain, $group, $state));
    1102 
    1103     # get the ID...
    1104     ($dom_id) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE domain=?", undef, ($domain));
    1105 
    1106     _log($dbh, (domain_id => $dom_id, user_id => $userinfo{id}, group_id => $group, username => $userinfo{username},
    1107         entry => "Added ".($state ? 'active' : 'inactive')." domain $domain"));
    1108 
    1109     # ... and now we construct the standard records from the default set.  NB:  group should be variable.
    1110     my $sth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?");
    1111     my $sth_in = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,distance,weight,port,ttl)".
    1112         " VALUES ($dom_id,?,?,?,?,?,?,?)");
    1113     $sth->execute($group);
    1114     while (my ($host,$type,$val,$dist,$weight,$port,$ttl) = $sth->fetchrow_array()) {
    1115       $host =~ s/DOMAIN/$domain/g;
    1116       $val =~ s/DOMAIN/$domain/g;
    1117       $sth_in->execute($host,$type,$val,$dist,$weight,$port,$ttl);
    1118       if ($typemap{$type} eq 'SOA') {
    1119         my @tmp1 = split /:/, $host;
    1120         my @tmp2 = split /:/, $val;
    1121         _log($dbh, (domain_id => $dom_id, user_id => $userinfo{id}, group_id => $group,
    1122                 username => $userinfo{username}, entry =>
    1123                 "[new $domain] Added SOA record [contact $tmp1[0]] [master $tmp1[1]] ".
    1124                 "[refresh $tmp2[0]] [retry $tmp2[1]] [expire $tmp2[2]] [minttl $tmp2[3]], TTL $ttl"));
    1125       } else {
    1126         my $logentry = "[new $domain] Added record '$host $typemap{$type}";
    1127         $logentry .= " [distance $dist]" if $typemap{$type} eq 'MX';
    1128         $logentry .= " [priority $dist] [weight $weight] [port $port]" if $typemap{$type} eq 'SRV';
    1129         _log($dbh, (domain_id => $dom_id, user_id => $userinfo{id}, group_id => $group,
    1130                 username => $userinfo{username}, entry =>
    1131                 $logentry." $val', TTL $ttl"));
    1132       }
    1133     }
    1134 
    1135     # once we get here, we should have suceeded.
    1136     $dbh->commit;
    1137   }; # end eval
    1138 
    1139   if ($@) {
    1140     my $msg = $@;
    1141     eval { $dbh->rollback; };
    1142     return ('FAIL',$msg);
    1143   } else {
    1144     return ('OK',$dom_id);
    1145   }
    1146 } # end addDomain
    1147 
    1148 
    1149 ## DNSDB::delDomain()
    1150 # Delete a domain.
    1151 # for now, just delete the records, then the domain.
    1152 # later we may want to archive it in some way instead (status code 2, for example?)
    1153 sub delDomain {
    1154   my $dbh = shift;
    1155   my $domid = shift;
    1156 
    1157   # Allow transactions, and raise an exception on errors so we can catch it later.
    1158   # Use local to make sure these get "reset" properly on exiting this block
    1159   local $dbh->{AutoCommit} = 0;
    1160   local $dbh->{RaiseError} = 1;
    1161 
    1162   my $failmsg = '';
    1163 
    1164   # Wrap all the SQL in a transaction
    1165   eval {
    1166     my $sth = $dbh->prepare("delete from records where domain_id=?");
    1167     $failmsg = "Failure removing domain records";
    1168     $sth->execute($domid);
    1169     $sth = $dbh->prepare("delete from domains where domain_id=?");
    1170     $failmsg = "Failure removing domain";
    1171     $sth->execute($domid);
    1172 
    1173     # once we get here, we should have suceeded.
    1174     $dbh->commit;
    1175   }; # end eval
    1176 
    1177   if ($@) {
    1178     my $msg = $@;
    1179     eval { $dbh->rollback; };
    1180     return ('FAIL',"$failmsg: $msg");
    1181   } else {
    1182     return ('OK','OK');
    1183   }
    1184 
    1185 } # end delDomain()
    1186 
    1187 
    1188 ## DNSDB::domainName()
    1189 # Return the domain name based on a domain ID
    1190 # Takes a database handle and the domain ID
    1191 # Returns the domain name or undef on failure
    1192 sub domainName {
    1193   $errstr = '';
    1194   my $dbh = shift;
    1195   my $domid = shift;
    1196   my ($domname) = $dbh->selectrow_array("SELECT domain FROM domains WHERE domain_id=?", undef, ($domid) );
    1197   $errstr = $DBI::errstr if !$domname;
    1198   return $domname if $domname;
    1199 } # end domainName()
    1200 
    1201 
    1202 ## DNSDB::revName()
    1203 # Return the reverse zone name based on an rDNS ID
    1204 # Takes a database handle and the rDNS ID
    1205 # Returns the reverse zone name or undef on failure
    1206 sub revName {
    1207   $errstr = '';
    1208   my $dbh = shift;
    1209   my $revid = shift;
    1210   my ($revname) = $dbh->selectrow_array("SELECT revnet FROM revzones WHERE rdns_id=?", undef, ($revid) );
    1211   $errstr = $DBI::errstr if !$revname;
    1212   return $revname if $revname;
    1213 } # end revName()
    1214 
    1215 
    1216 ## DNSDB::domainID()
    1217 # Takes a database handle and domain name
    1218 # Returns the domain ID number
    1219 sub domainID {
    1220   $errstr = '';
    1221   my $dbh = shift;
    1222   my $domain = shift;
    1223   my ($domid) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE domain=?", undef, ($domain) );
    1224   $errstr = $DBI::errstr if !$domid;
    1225   return $domid if $domid;
    1226 } # end domainID()
    1227 
    1228 
    1229 ## DNSDB::addRDNS
    1230 # Adds a reverse DNS zone
    1231 # Takes a database handle, CIDR block, numeric group, boolean(ish) state (active/inactive),
    1232 # and user info hash (for logging).
    1233 # Returns a status code and message
    1234 sub addRDNS {
    1235   my $dbh = shift;
    1236   my $zone = NetAddr::IP->new(shift);
    1237   return ('FAIL',"Zone name must be a valid CIDR netblock") unless ($zone && $zone->addr !~ /^0/);
    1238   my $revpatt = shift;
    1239   my $group = shift;
    1240   my $state = shift;
    1241 
    1242   my %userinfo = @_;    # remaining bits.
    1243 # user ID, username, user full name
    1244 
    1245   $state = 1 if $state =~ /^active$/;
    1246   $state = 1 if $state =~ /^on$/;
    1247   $state = 0 if $state =~ /^inactive$/;
    1248   $state = 0 if $state =~ /^off$/;
    1249 
    1250   return ('FAIL',"Invalid zone status") if $state !~ /^\d+$/;
    1251 
    1252 # quick check to start to see if we've already got one
    1253   my ($rdns_id) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revzone=?", undef, ("$zone"));
    1254 
    1255   return ('FAIL', "Zone already exists") if $rdns_id;
    1256 
    1257   # Allow transactions, and raise an exception on errors so we can catch it later.
    1258   # Use local to make sure these get "reset" properly on exiting this block
    1259   local $dbh->{AutoCommit} = 0;
    1260   local $dbh->{RaiseError} = 1;
    1261 
    1262 #$dbh->selectrow_array("SELECT currval('users_user_id_seq')");
    1263   # Wrap all the SQL in a transaction
    1264   eval {
    1265     # insert the domain...
    1266     $dbh->do("INSERT INTO revzones (revnet,group_id,status) VALUES (?,?,?)", undef, ($zone, $group, $state));
    1267 
    1268     # get the ID...
    1269     ($rdns_id) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')");
    1270 
    1271     _log($dbh, (rdns_id => $rdns_id, user_id => $userinfo{id}, group_id => $group, username => $userinfo{name},
    1272         entry => "Added ".($state ? 'active' : 'inactive')." reverse zone $zone"));
    1273 
    1274     # ... and now we construct the standard records from the default set.  NB:  group should be variable.
    1275     my $sth = $dbh->prepare("SELECT host,type,val,ttl FROM default_rev_records WHERE group_id=?");
    1276     my $sth_in = $dbh->prepare("INSERT INTO records (rdns_id,host,type,val,ttl)".
    1277         " VALUES ($rdns_id,?,?,?,?)");
    1278     $sth->execute($group);
    1279     while (my ($host,$type,$val,$ttl) = $sth->fetchrow_array()) {
    1280       $host =~ s/ADMINDOMAIN/$config{domain}/g;
    1281 ##work
    1282 # - replace ZONE in $val
    1283 # - skip records not appropriate for the zone (skip A+PTR on v6 zones, and AAAA+PTR on v4 zones)
    1284 #      $val =~ s/DOMAIN/$domain/g;
    1285       $sth_in->execute($host,$type,$val,$ttl);
    1286       if ($typemap{$type} eq 'SOA') {
    1287         my @tmp1 = split /:/, $host;
    1288         my @tmp2 = split /:/, $val;
    1289         _log($dbh, (rdns_id => $rdns_id, user_id => $userinfo{id}, group_id => $group,
    1290                 username => $userinfo{name}, entry =>
    1291                 "[new $zone] Added SOA record [contact $tmp1[0]] [master $tmp1[1]] ".
    1292                 "[refresh $tmp2[0]] [retry $tmp2[1]] [expire $tmp2[2]] [minttl $tmp2[3]], TTL $ttl"));
    1293       } else {
    1294         my $logentry = "[new $zone] Added record '$host $typemap{$type}";
    1295 #       $logentry .= " [distance $dist]" if $typemap{$type} eq 'MX';
    1296 #       $logentry .= " [priority $dist] [weight $weight] [port $port]" if $typemap{$type} eq 'SRV';
    1297         _log($dbh, (rdns_id => $rdns_id, user_id => $userinfo{id}, group_id => $group,
    1298                 username => $userinfo{name}, entry =>
    1299                 $logentry." $val', TTL $ttl"));
    1300       }
    1301     }
    1302 
    1303     # once we get here, we should have suceeded.
    1304     $dbh->commit;
    1305   }; # end eval
    1306 
    1307   if ($@) {
    1308     my $msg = $@;
    1309     eval { $dbh->rollback; };
    1310     return ('FAIL',$msg);
    1311   } else {
    1312     return ('OK',$rdns_id);
    1313   }
    1314 
    1315 } # end addRDNS()
    1316 
    1317 
    1318 ## DNSDB::getZoneCount
    1319 # Get count of zones in group or groups
    1320 # Takes a database handle and hash containing:
    1321 #  - the "current" group
    1322 #  - an array of "acceptable" groups
    1323 #  - a flag for forward/reverse zones
    1324 #  - Optionally accept a "starts with" and/or "contains" filter argument
    1325 # Returns an integer count of the resulting zone list.
    1326 sub getZoneCount {
    1327   my $dbh = shift;
    1328 
    1329   my %args = @_;
    1330 
    1331   my @filterargs;
    1332   $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
    1333   push @filterargs, "^$args{startwith}" if $args{startwith};
    1334   $args{filter} =~ s/\./\[\.\]/g if $args{filter};      # only match literal dots, usually in reverse zones
    1335   push @filterargs, $args{filter} if $args{filter};
    1336 
    1337   my $sql;
    1338   # Not as compact, and fix-me-twice if the common bits get wrong, but much easier to read
    1339   if ($args{revrec} eq 'n') {
    1340     $sql = "SELECT count(*) FROM domains".
    1341         " WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
    1342         ($args{startwith} ? " AND domain ~* ?" : '').
    1343         ($args{filter} ? " AND domain ~* ?" : '');
    1344   } else {
    1345     $sql = "SELECT count(*) FROM revzones".
    1346         " WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
    1347         ($args{startwith} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '').
    1348         ($args{filter} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '');
    1349   }
    1350   my ($count) = $dbh->selectrow_array($sql, undef, @filterargs);
    1351   return $count;
    1352 } # end getZoneCount()
    1353 
    1354 
    1355 ## DNSDB::getZoneList()
    1356 # Get a list of zones in the specified group(s)
    1357 # Takes the same arguments as getZoneCount() above
    1358 # Returns a reference to an array of hashrefs suitable for feeding to HTML::Template
    1359 sub getZoneList {
    1360   my $dbh = shift;
    1361 
    1362   my %args = @_;
    1363 
    1364   my @zonelist;
    1365 
    1366   $args{sortorder} = 'ASC' if !grep $args{sortorder}, ('ASC','DESC');
    1367   $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/;
    1368 
    1369   my @filterargs;
    1370   $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
    1371   push @filterargs, "^$args{startwith}" if $args{startwith};
    1372   $args{filter} =~ s/\./\[\.\]/g if $args{filter};      # only match literal dots, usually in reverse zones
    1373   push @filterargs, $args{filter} if $args{filter};
    1374 
    1375   my $sql;
    1376   # Not as compact, and fix-me-twice if the common bits get wrong, but much easier to read
    1377   if ($args{revrec} eq 'n') {
    1378     $args{sortby} = 'domain' if !grep $args{sortby}, ('revnet','group','status');
    1379     $sql = "SELECT domain_id,domain,status,groups.group_name AS group FROM domains".
    1380         " INNER JOIN groups ON domains.group_id=groups.group_id".
    1381         " WHERE domains.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
    1382         ($args{startwith} ? " AND domain ~* ?" : '').
    1383         ($args{filter} ? " AND domain ~* ?" : '');
    1384   } else {
    1385 ##fixme:  arguably startwith here is irrelevant.  depends on the UI though.
    1386     $args{sortby} = 'revnet' if !grep $args{sortby}, ('domain','group','status');
    1387     $sql = "SELECT rdns_id,revnet,status,groups.group_name AS group FROM revzones".
    1388         " INNER JOIN groups ON revzones.group_id=groups.group_id".
    1389         " WHERE revzones.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
    1390         ($args{startwith} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '').
    1391         ($args{filter} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '');
    1392   }
    1393   # A common tail.
    1394   $sql .= " ORDER BY ".($args{sortby} eq 'group' ? 'groups.group_name' : $args{sortby})." $args{sortorder} ".
    1395         ($args{offset} eq 'all' ? '' : " LIMIT $config{perpage}".
    1396         " OFFSET ".$args{offset}*$config{perpage});
    1397   my $sth = $dbh->prepare($sql);
    1398   $sth->execute(@filterargs);
    1399   my $rownum = 0;
    1400 
    1401   while (my @data = $sth->fetchrow_array) {
    1402     my %row;
    1403     $row{domainid} = $data[0];
    1404     $row{domain} = $data[1];
    1405     $row{status} = $data[2];
    1406     $row{group} = $data[3];
    1407     push @zonelist, \%row;
    1408   }
    1409 
    1410   return \@zonelist;
    1411 } # end getZoneList()
    1412 
    1413 
    1414 ## DNSDB::addGroup()
    1415 # Add a group
    1416 # Takes a database handle, group name, parent group, hashref for permissions,
    1417 # and optional template-vs-cloneme flag
    1418 # Returns a status code and message
    1419 sub addGroup {
    1420   $errstr = '';
    1421   my $dbh = shift;
    1422   my $groupname = shift;
    1423   my $pargroup = shift;
    1424   my $permissions = shift;
    1425 
    1426   # 0 indicates "custom", hardcoded.
    1427   # Any other value clones that group's default records, if it exists.
    1428   my $inherit = shift || 0;     
    1429 ##fixme:  need a flag to indicate clone records or <?> ?
    1430 
    1431   # Allow transactions, and raise an exception on errors so we can catch it later.
    1432   # Use local to make sure these get "reset" properly on exiting this block
    1433   local $dbh->{AutoCommit} = 0;
    1434   local $dbh->{RaiseError} = 1;
    1435 
    1436   my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE group_name=?");
    1437   my $group_id;
    1438 
    1439 # quick check to start to see if we've already got one
    1440   $sth->execute($groupname);
    1441   ($group_id) = $sth->fetchrow_array;
    1442 
    1443   return ('FAIL', "Group already exists") if $group_id;
    1444 
    1445   # Wrap all the SQL in a transaction
    1446   eval {
    1447     $sth = $dbh->prepare("INSERT INTO groups (parent_group_id,group_name) VALUES (?,?)");
    1448     $sth->execute($pargroup,$groupname);
    1449 
    1450     my ($groupid) = $dbh->selectrow_array("SELECT group_id FROM groups WHERE group_name=?", undef, ($groupname));
    1451 
    1452 # Permissions
    1453     if ($inherit) {
    1454     } else {
    1455       my @permvals;
    1456       foreach (@permtypes) {
    1457         if (!defined ($permissions->{$_})) {
    1458           push @permvals, 0;
    1459         } else {
    1460           push @permvals, $permissions->{$_};
    1461         }
    1462       }
    1463 
    1464       $sth = $dbh->prepare("INSERT INTO permissions (group_id,$permlist) values (?".',?'x($#permtypes+1).")");
    1465       $sth->execute($groupid,@permvals);
    1466 
    1467       $sth = $dbh->prepare("SELECT permission_id FROM permissions WHERE group_id=?");
    1468       $sth->execute($groupid);
    1469       my ($permid) = $sth->fetchrow_array();
    1470 
    1471       $dbh->do("UPDATE groups SET permission_id=$permid WHERE group_id=$groupid");
    1472     } # done permission fiddling
    1473 
    1474 # Default records
    1475     my $sthf = $dbh->prepare("INSERT INTO default_records (group_id,host,type,val,distance,weight,port,ttl) ".
    1476         "VALUES ($groupid,?,?,?,?,?,?,?)");
    1477     my $sthr = $dbh->prepare("INSERT INTO default_rev_records (group_id,host,type,val,ttl) ".
    1478         "VALUES ($groupid,?,?,?,?)");
    1479     if ($inherit) {
    1480       # Duplicate records from parent.  Actually relying on inherited records feels
    1481       # very fragile, and it would be problematic to roll over at a later time.
    1482       my $sth2 = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?");
    1483       $sth2->execute($pargroup);
    1484       while (my @clonedata = $sth2->fetchrow_array) {
    1485         $sthf->execute(@clonedata);
    1486       }
    1487       # And now the reverse records
    1488       $sth2 = $dbh->prepare("SELECT group_id,host,type,val,ttl FROM default_rev_records WHERE group_id=?");
    1489       $sth2->execute($pargroup);
    1490       while (my @clonedata = $sth2->fetchrow_array) {
    1491         $sthr->execute(@clonedata);
    1492       }
    1493     } else {
    1494 ##fixme: Hardcoding is Bad, mmmmkaaaay?
    1495       # reasonable basic defaults for SOA, MX, NS, and minimal hosting
    1496       # could load from a config file, but somewhere along the line we need hardcoded bits.
    1497       $sthf->execute('ns1.example.com:hostmaster.example.com', 6, '10800:3600:604800:10800', 0, 0, 0, 86400);
    1498       $sthf->execute('DOMAIN', 1, '192.168.4.2', 0, 0, 0, 7200);
    1499       $sthf->execute('DOMAIN', 15, 'mx.example.com', 10, 0, 0, 7200);
    1500       $sthf->execute('DOMAIN', 2, 'ns1.example.com', 0, 0, 0, 7200);
    1501       $sthf->execute('DOMAIN', 2, 'ns2.example.com', 0, 0, 0, 7200);
    1502       $sthf->execute('www.DOMAIN', 5, 'DOMAIN', 0, 0, 0, 7200);
    1503       # reasonable basic defaults for generic reverse zone.  Same as initial SQL tabledef.
    1504       $sthr->execute('hostmaster.ADMINDOMAIN:ns1.ADMINDOMAIN', 6, '10800:3600:604800:10800', 86400);
    1505       $sthr->execute('unused-%r.ADMINDOMAIN', 65283, 'ZONE', 3600);
    1506     }
    1507 
    1508     # once we get here, we should have suceeded.
    1509     $dbh->commit;
    1510   }; # end eval
    1511 
    1512   if ($@) {
    1513     my $msg = $@;
    1514     eval { $dbh->rollback; };
    1515     return ('FAIL',$msg);
    1516   } else {
    1517     return ('OK','OK');
    1518   }
    1519 
    1520 } # end addGroup()
    1521 
    1522 
    1523 ## DNSDB::delGroup()
    1524 # Delete a group.
    1525 # Takes a group ID
    1526 # Returns a status code and message
    1527 sub delGroup {
    1528   my $dbh = shift;
    1529   my $groupid = shift;
    1530 
    1531   # Allow transactions, and raise an exception on errors so we can catch it later.
    1532   # Use local to make sure these get "reset" properly on exiting this block
    1533   local $dbh->{AutoCommit} = 0;
    1534   local $dbh->{RaiseError} = 1;
    1535 
    1536 ##fixme:  locate "knowable" error conditions and deal with them before the eval
    1537 # ... or inside, whatever.
    1538 # -> domains still exist in group
    1539 # -> ...
    1540   my $failmsg = '';
    1541 
    1542   # Wrap all the SQL in a transaction
    1543   eval {
    1544     my $sth = $dbh->prepare("SELECT count(*) FROM domains WHERE group_id=?");
    1545     $sth->execute($groupid);
    1546     my ($domcnt) = $sth->fetchrow_array;
    1547     $failmsg = "Can't remove group ".groupName($dbh,$groupid);
    1548     die "$domcnt domains still in group\n" if $domcnt;
    1549 
    1550     $sth = $dbh->prepare("delete from default_records where group_id=?");
    1551     $failmsg = "Failed to delete default records for ".groupName($dbh,$groupid);
    1552     $sth->execute($groupid);
    1553     $sth = $dbh->prepare("delete from groups where group_id=?");
    1554     $failmsg = "Failed to remove group ".groupName($dbh,$groupid);
    1555     $sth->execute($groupid);
    1556 
    1557     # once we get here, we should have suceeded.
    1558     $dbh->commit;
    1559   }; # end eval
    1560 
    1561   if ($@) {
    1562     my $msg = $@;
    1563     eval { $dbh->rollback; };
    1564     return ('FAIL',"$failmsg: $msg");
    1565   } else {
    1566     return ('OK','OK');
    1567   }
    1568 } # end delGroup()
    1569 
    1570 
    1571 ## DNSDB::getChildren()
    1572 # Get a list of all groups whose parent^n is group <n>
    1573 # Takes a database handle, group ID, reference to an array to put the group IDs in,
    1574 # and an optional flag to return only immediate children or all children-of-children
    1575 # default to returning all children
    1576 # Calls itself
    1577 sub getChildren {
    1578   $errstr = '';
    1579   my $dbh = shift;
    1580   my $rootgroup = shift;
    1581   my $groupdest = shift;
    1582   my $immed = shift || 'all';
    1583 
    1584   # special break for default group;  otherwise we get stuck.
    1585   if ($rootgroup == 1) {
    1586     # by definition, group 1 is the Root Of All Groups
    1587     my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE NOT (group_id=1)".
    1588         ($immed ne 'all' ? " AND parent_group_id=1" : ''));
    1589     $sth->execute;
    1590     while (my @this = $sth->fetchrow_array) {
    1591       push @$groupdest, @this;
    1592     }
    1593   } else {
    1594     my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE parent_group_id=?");
    1595     $sth->execute($rootgroup);
    1596     return if $sth->rows == 0;
    1597     my @grouplist;
    1598     while (my ($group) = $sth->fetchrow_array) {
    1599       push @$groupdest, $group;
    1600       getChildren($dbh,$group,$groupdest) if $immed eq 'all';
    1601     }
    1602   }
    1603 } # end getChildren()
    1604 
    1605 
    1606 ## DNSDB::groupName()
    1607 # Return the group name based on a group ID
    1608 # Takes a database handle and the group ID
    1609 # Returns the group name or undef on failure
    1610 sub groupName {
    1611   $errstr = '';
    1612   my $dbh = shift;
    1613   my $groupid = shift;
    1614   my $sth = $dbh->prepare("SELECT group_name FROM groups WHERE group_id=?");
    1615   $sth->execute($groupid);
    1616   my ($groupname) = $sth->fetchrow_array();
    1617   $errstr = $DBI::errstr if !$groupname;
    1618   return $groupname if $groupname;
    1619 } # end groupName
    1620 
    1621 
    1622 ## DNSDB::groupID()
    1623 # Return the group ID based on the group name
    1624 # Takes a database handle and the group name
    1625 # Returns the group ID or undef on failure
    1626 sub groupID {
    1627   $errstr = '';
    1628   my $dbh = shift;
    1629   my $group = shift;
    1630   my ($grpid) = $dbh->selectrow_array("SELECT group_id FROM groups WHERE group=?", undef, ($group) );
    1631   $errstr = $DBI::errstr if !$grpid;
    1632   return $grpid if $grpid;
    1633 } # end groupID()
    1634 
    1635 
    1636 ## DNSDB::addUser()
    1637 # Add a user.
    1638 # Takes a DB handle, username, group ID, password, state (active/inactive).
    1639 # Optionally accepts:
    1640 #   user type (user/admin)      - defaults to user
    1641 #   permissions string          - defaults to inherit from group
    1642 #      three valid forms:
    1643 #       i                    - Inherit permissions
    1644 #       c:<user_id>          - Clone permissions from <user_id>
    1645 #       C:<permission list>  - Set these specific permissions
    1646 #   first name                  - defaults to username
    1647 #   last name                   - defaults to blank
    1648 #   phone                       - defaults to blank (could put other data within column def)
    1649 # Returns (OK,<uid>) on success, (FAIL,<message>) on failure
    1650 sub addUser {
    1651   $errstr = '';
    1652   my $dbh = shift;
    1653   my $username = shift;
    1654   my $group = shift;
    1655   my $pass = shift;
    1656   my $state = shift;
    1657 
    1658   return ('FAIL', "Missing one or more required entries") if !defined($state);
    1659   return ('FAIL', "Username must not be blank") if !$username;
    1660 
    1661   my $type = shift || 'u';      # create limited users by default - fwiw, not sure yet how this will interact with ACLs
    1662  
    1663   my $permstring = shift || 'i';        # default is to inhert permissions from group
    1664 
    1665   my $fname = shift || $username;
    1666   my $lname = shift || '';
    1667   my $phone = shift || '';      # not going format-check
    1668 
    1669   my $sth = $dbh->prepare("SELECT user_id FROM users WHERE username=?");
    1670   my $user_id;
    1671 
    1672 # quick check to start to see if we've already got one
    1673   $sth->execute($username);
    1674   ($user_id) = $sth->fetchrow_array;
    1675 
    1676   return ('FAIL', "User already exists") if $user_id;
    1677 
    1678   # Allow transactions, and raise an exception on errors so we can catch it later.
    1679   # Use local to make sure these get "reset" properly on exiting this block
    1680   local $dbh->{AutoCommit} = 0;
    1681   local $dbh->{RaiseError} = 1;
    1682 
    1683   my $failmsg = '';
    1684 
    1685   # Wrap all the SQL in a transaction
    1686   eval {
    1687     # insert the user...  note we set inherited perms by default since
    1688     # it's simple and cleans up some other bits of state
    1689     my $sth = $dbh->prepare("INSERT INTO users ".
    1690         "(group_id,username,password,firstname,lastname,phone,type,status,permission_id,inherit_perm) ".
    1691         "VALUES (?,?,?,?,?,?,?,?,(SELECT permission_id FROM permissions WHERE group_id=?),'t')");
    1692     $sth->execute($group,$username,unix_md5_crypt($pass),$fname,$lname,$phone,$type,$state,$group);
    1693 
    1694     # get the ID...
    1695     ($user_id) = $dbh->selectrow_array("SELECT currval('users_user_id_seq')");
    1696 
    1697 # Permissions!  Gotta set'em all!
    1698     die "Invalid permission string $permstring"
    1699         if $permstring !~ /^(?:
    1700                 i       # inherit
    1701                 |c:\d+  # clone
    1702                         # custom.  no, the leading , is not a typo
    1703                 |C:(?:,(?:group|user|domain|record|self)_(?:edit|create|delete))*
    1704                 )$/x;
    1705 # bleh.  I'd call another function to do my dirty work, but we're in the middle of a transaction already.
    1706     if ($permstring ne 'i') {
    1707       # for cloned or custom permissions, we have to create a new permissions entry.
    1708       my $clonesrc = $group;
    1709       if ($permstring =~ /^c:(\d+)/) { $clonesrc = $1; }
    1710       $dbh->do("INSERT INTO permissions ($permlist,user_id) ".
    1711         "SELECT $permlist,? FROM permissions WHERE permission_id=".
    1712         "(SELECT permission_id FROM permissions WHERE ".($permstring =~ /^c:/ ? 'user' : 'group')."_id=?)",
    1713         undef, ($user_id,$clonesrc) );
    1714       $dbh->do("UPDATE users SET permission_id=".
    1715         "(SELECT permission_id FROM permissions WHERE user_id=?) ".
    1716         "WHERE user_id=?", undef, ($user_id, $user_id) );
    1717     }
    1718     if ($permstring =~ /^C:/) {
    1719       # finally for custom permissions, we set the passed-in permissions (and unset
    1720       # any that might have been brought in by the clone operation above)
    1721       my ($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions WHERE user_id=?",
    1722         undef, ($user_id) );
    1723       foreach (@permtypes) {
    1724         if ($permstring =~ /,$_/) {
    1725           $dbh->do("UPDATE permissions SET $_='t' WHERE permission_id=?", undef, ($permid) );
    1726         } else {
    1727           $dbh->do("UPDATE permissions SET $_='f' WHERE permission_id=?", undef, ($permid) );
    1728         }
    1729       }
    1730     }
    1731 
    1732     $dbh->do("UPDATE users SET inherit_perm='n' WHERE user_id=?", undef, ($user_id) );
    1733 
    1734 ##fixme: add another table to hold name/email for log table?
    1735 
    1736     # once we get here, we should have suceeded.
    1737     $dbh->commit;
    1738   }; # end eval
    1739 
    1740   if ($@) {
    1741     my $msg = $@;
    1742     eval { $dbh->rollback; };
    1743     return ('FAIL',$msg." $failmsg");
    1744   } else {
    1745     return ('OK',$user_id);
    1746   }
    1747 } # end addUser
    1748 
    1749 
    1750 ## DNSDB::checkUser()
    1751 # Check user/pass combo on login
    1752 sub checkUser {
    1753   my $dbh = shift;
    1754   my $user = shift;
    1755   my $inpass = shift;
    1756 
    1757   my $sth = $dbh->prepare("SELECT user_id,group_id,password,firstname,lastname FROM users WHERE username=?");
    1758   $sth->execute($user);
    1759   my ($uid,$gid,$pass,$fname,$lname) = $sth->fetchrow_array;
    1760   my $loginfailed = 1 if !defined($uid);
    1761 
    1762   if ($pass =~ m|^\$1\$([A-Za-z0-9/.]+)\$|) {
    1763     $loginfailed = 1 if $pass ne unix_md5_crypt($inpass,$1);
    1764   } else {
    1765     $loginfailed = 1 if $pass ne $inpass;
    1766   }
    1767 
    1768   # nnnngggg
    1769   return ($uid, $gid);
    1770 } # end checkUser
    1771 
    1772 
    1773 ## DNSDB:: updateUser()
    1774 # Update general data about user
    1775 sub updateUser {
    1776   my $dbh = shift;
    1777 
    1778 ##fixme:  tweak calling convention so that we can update any given bit of data
    1779   my $uid = shift;
    1780   my $username = shift;
    1781   my $group = shift;
    1782   my $pass = shift;
    1783   my $state = shift;
    1784   my $type = shift || 'u';
    1785   my $fname = shift || $username;
    1786   my $lname = shift || '';
    1787   my $phone = shift || '';      # not going format-check
    1788 
    1789   my $failmsg = '';
    1790 
    1791   # Allow transactions, and raise an exception on errors so we can catch it later.
    1792   # Use local to make sure these get "reset" properly on exiting this block
    1793   local $dbh->{AutoCommit} = 0;
    1794   local $dbh->{RaiseError} = 1;
    1795 
    1796   my $sth;
    1797 
    1798   # Password can be left blank;  if so we assume there's one on file.
    1799   # Actual blank passwords are bad, mm'kay?
    1800   if (!$pass) {
    1801     $sth = $dbh->prepare("SELECT password FROM users WHERE user_id=?");
    1802     $sth->execute($uid);
    1803     ($pass) = $sth->fetchrow_array;
    1804   } else {
    1805     $pass = unix_md5_crypt($pass);
    1806   }
    1807 
    1808   eval {
    1809     my $sth = $dbh->prepare(q(
    1810         UPDATE users
    1811         SET username=?, password=?, firstname=?, lastname=?, phone=?, type=?, status=?
    1812         WHERE user_id=?
    1813         )
    1814       );
    1815     $sth->execute($username, $pass, $fname, $lname, $phone, $type, $state, $uid);
    1816     $dbh->commit;
    1817   };
    1818   if ($@) {
    1819     my $msg = $@;
    1820     eval { $dbh->rollback; };
    1821     return ('FAIL',"$failmsg: $msg");
    1822   } else {
    1823     return ('OK','OK');
    1824   }
    1825 } # end updateUser()
    1826 
    1827 
    1828 ## DNSDB::delUser()
    1829 #
    1830 sub delUser {
    1831   my $dbh = shift;
    1832   return ('FAIL',"Need database handle") if !$dbh;
    1833   my $userid = shift;
    1834   return ('FAIL',"Missing userid") if !defined($userid);
    1835 
    1836   my $sth = $dbh->prepare("delete from users where user_id=?");
    1837   $sth->execute($userid);
    1838 
    1839   return ('FAIL',"Couldn't remove user: ".$sth->errstr) if $sth->err;
    1840 
    1841   return ('OK','OK');
    1842 
    1843 } # end delUser
    1844 
    1845 
    1846 ## DNSDB::userFullName()
    1847 # Return a pretty string!
    1848 # Takes a user_id and optional printf-ish string to indicate which pieces where:
    1849 # %u for the username
    1850 # %f for the first name
    1851 # %l for the last name
    1852 # All other text in the passed string will be left as-is.
    1853 ##fixme:  need a "smart" option too, so that missing/null/blank first/last names don't give funky output
    1854 sub userFullName {
    1855   $errstr = '';
    1856   my $dbh = shift;
    1857   my $userid = shift;
    1858   my $fullformat = shift || '%f %l (%u)';
    1859   my $sth = $dbh->prepare("select username,firstname,lastname from users where user_id=?");
    1860   $sth->execute($userid);
    1861   my ($uname,$fname,$lname) = $sth->fetchrow_array();
    1862   $errstr = $DBI::errstr if !$uname;
    1863 
    1864   $fullformat =~ s/\%u/$uname/g;
    1865   $fullformat =~ s/\%f/$fname/g;
    1866   $fullformat =~ s/\%l/$lname/g;
    1867 
    1868   return $fullformat;
    1869 } # end userFullName
    1870 
    1871 
    1872 ## DNSDB::userStatus()
    1873 # Sets and/or returns a user's status
    1874 # Takes a database handle, user ID and optionally a status argument
    1875 # Returns undef on errors.
    1876 sub userStatus {
    1877   my $dbh = shift;
    1878   my $id = shift;
    1879   my $newstatus = shift;
    1880 
    1881   return undef if $id !~ /^\d+$/;
    1882 
    1883   my $sth;
    1884 
    1885 # ooo, fun!  let's see what we were passed for status
    1886   if ($newstatus) {
    1887     $sth = $dbh->prepare("update users set status=? where user_id=?");
    1888     # ass-u-me caller knows what's going on in full
    1889     if ($newstatus =~ /^[01]$/) {       # only two valid for now.
    1890       $sth->execute($newstatus,$id);
    1891     } elsif ($newstatus =~ /^usero(?:n|ff)$/) {
    1892       $sth->execute(($newstatus eq 'useron' ? 1 : 0),$id);
    1893     }
    1894   }
    1895 
    1896   $sth = $dbh->prepare("select status from users where user_id=?");
    1897   $sth->execute($id);
    1898   my ($status) = $sth->fetchrow_array;
    1899   return $status;
    1900 } # end userStatus()
    1901 
    1902 
    1903 ## DNSDB::getUserData()
    1904 # Get misc user data for display
    1905 sub getUserData {
    1906   my $dbh = shift;
    1907   my $uid = shift;
    1908 
    1909   my $sth = $dbh->prepare("SELECT group_id,username,firstname,lastname,phone,type,status,inherit_perm ".
    1910         "FROM users WHERE user_id=?");
    1911   $sth->execute($uid);
    1912   return $sth->fetchrow_hashref();
    1913 
    1914 } # end getUserData()
    1915 
    1916 
    1917 ## DNSDB::getSOA()
    1918 # Return all suitable fields from an SOA record in separate elements of a hash
    1919 # Takes a database handle, default/live flag, domain/reverse flag, and parent ID
    1920 sub getSOA {
    1921   $errstr = '';
    1922   my $dbh = shift;
    1923   my $def = shift;
    1924   my $rev = shift;
    1925   my $id = shift;
    1926   my %ret;
    1927 
    1928   # (ab)use distance and weight columns to store SOA data?  can't for default_rev_records...
    1929   # - should really attach serial to the zone parent somewhere
    1930 
    1931   my $sql = "SELECT record_id,host,val,ttl from "._rectable($def,$rev).
    1932         " WHERE "._recparent($def,$rev)." = ? AND type=$reverse_typemap{SOA}";
    1933 
    1934   my $sth = $dbh->prepare($sql);
    1935   $sth->execute($id);
    1936 ##fixme:  stick a flag somewhere if the record doesn't exist.  by the API, this is an impossible case, but...
    1937 
    1938   my ($recid,$host,$val,$ttl) = $sth->fetchrow_array() or return;
    1939   my ($contact,$prins) = split /:/, $host;
    1940   my ($refresh,$retry,$expire,$minttl) = split /:/, $val;
    1941 
    1942   $ret{recid}   = $recid;
    1943   $ret{ttl}     = $ttl;
    1944 #  $ret{serial} = $serial;      # ca't use distance for serial with default_rev_records
    1945   $ret{prins}   = $prins;
    1946   $ret{contact} = $contact;
    1947   $ret{refresh} = $refresh;
    1948   $ret{retry}   = $retry;
    1949   $ret{expire}  = $expire;
    1950   $ret{minttl}  = $minttl;
    1951 
    1952   return %ret;
    1953 } # end getSOA()
    1954 
    1955 
    1956 ## DNSDB::updateSOA()
    1957 # Update the specified SOA record
    1958 # Takes a database handle, default/live flag, forward/reverse flag, and SOA data hash
    1959 sub updateSOA {
    1960   my $dbh = shift;
    1961   my $defrec = shift;
    1962   my $revrec = shift;
    1963 
    1964   my %soa = @_;
    1965 
    1966 ##fixme: data validation: make sure {recid} is really the SOA for {parent}
    1967   my $sql = "UPDATE "._rectable($defrec, $revrec)." SET host=?, val=?, ttl=? WHERE record_id=? AND type=6";
    1968   $dbh->do($sql, undef, ("$soa{contact}:$soa{prins}", "$soa{refresh}:$soa{retry}:$soa{expire}:$soa{minttl}",
    1969         $soa{ttl}, $soa{recid}));
    1970 
    1971 } # end updateSOA()
    1972 
    1973 
    1974 ## DNSDB::getRecLine()
    1975 # Return all data fields for a zone record in separate elements of a hash
    1976 # Takes a database handle, default/live flag, forward/reverse flag, and record ID
    1977 sub getRecLine {
    1978   $errstr = '';
    1979   my $dbh = shift;
    1980   my $defrec = shift;
    1981   my $revrec = shift;
    1982   my $id = shift;
    1983 
    1984   my $sql = "SELECT record_id,host,type,val,ttl".($revrec eq 'n' ? ',distance,weight,port' : '').
    1985         (($defrec eq 'y') ? ',group_id FROM ' : ',domain_id,rdns_id FROM ').
    1986         _rectable($defrec,$revrec)." WHERE record_id=?";
    1987   my $ret = $dbh->selectrow_hashref($sql, undef, ($id) );
    1988 
    1989   if ($dbh->err) {
    1990     $errstr = $DBI::errstr;
    1991     return undef;
    1992   }
    1993 
    1994   if (!$ret) {
    1995     $errstr = "No such record";
    1996     return undef;
    1997   }
    1998 
    1999   # explicitly set a parent id
    2000   if ($defrec eq 'y') {
    2001     $ret->{parid} = $ret->{group_id};
    2002   } else {
    2003     $ret->{parid} = (($revrec eq 'n') ? $ret->{domain_id} : $ret->{rdns_id});
    2004     # and a secondary if we have a custom type that lives in both a forward and reverse zone
    2005     $ret->{secid} = (($revrec eq 'y') ? $ret->{domain_id} : $ret->{rdns_id}) if $ret->{type} > 65279;
    2006   }
    2007 
    2008   return $ret;
    2009 }
    2010 
    2011 
    2012 ##fixme: should use above (getRecLine()) to get lines for below?
    2013 ## DNSDB::getDomRecs()
    2014 # Return records for a domain
    2015 # Takes a database handle, default/live flag, group/domain ID, start,
    2016 # number of records, sort field, and sort order
    2017 # Returns a reference to an array of hashes
    2018 sub getDomRecs {
    2019   $errstr = '';
    2020   my $dbh = shift;
    2021   my $def = shift;
    2022   my $rev = shift;
    2023   my $id = shift;
    2024   my $nrecs = shift || 'all';
    2025   my $nstart = shift || 0;
    2026 
    2027 ## for order, need to map input to column names
    2028   my $order = shift || 'host';
    2029   my $direction = shift || 'ASC';
    2030 
    2031   my $filter = shift || '';
    2032 
    2033   my $sql = "SELECT r.record_id,r.host,r.type,r.val,r.ttl";
    2034   $sql .= ",r.distance,r.weight,r.port" if $rev eq 'n';
    2035   $sql .= " FROM "._rectable($def,$rev)." r ";
    2036 
    2037   # whee!  multisort means just passing comma-separated fields in sortby!
    2038   my $newsort = '';
    2039   foreach my $sf (split /,/, $order) {
    2040     $sf = "r.$sf";
    2041     $sf =~ s/r\.type/t.alphaorder/;
    2042     $newsort .= ",$sf";
    2043   }
    2044   $newsort =~ s/^,//;
    2045 
    2046   $sql .= "INNER JOIN rectypes t ON r.type=t.val ";     # for sorting by type alphabetically
    2047   $sql .= "WHERE "._recparent($def,$rev)." = ?";
    2048   $sql .= " AND NOT r.type=$reverse_typemap{SOA}";
    2049   $sql .= " AND host ~* ?" if $filter;
    2050   # use alphaorder column for "correct" ordering of sort-by-type instead of DNS RR type number
    2051   $sql .= " ORDER BY $newsort $direction";
    2052 
    2053   my @bindvars = ($id);
    2054   push @bindvars, $filter if $filter;
    2055 
    2056   # just to be ultraparanoid about SQL injection vectors
    2057   if ($nstart ne 'all') {
    2058     $sql .= " LIMIT ? OFFSET ?";
    2059     push @bindvars, $nrecs;
    2060     push @bindvars, ($nstart*$nrecs);
    2061   }
    2062   my $sth = $dbh->prepare($sql) or warn $dbh->errstr;
    2063   $sth->execute(@bindvars) or warn "$sql: ".$sth->errstr;
    2064 
    2065   my @retbase;
    2066   while (my $ref = $sth->fetchrow_hashref()) {
    2067     push @retbase, $ref;
    2068   }
    2069 
    2070   my $ret = \@retbase;
    2071   return $ret;
    2072 } # end getDomRecs()
    2073 
    2074 
    2075 ## DNSDB::getRecCount()
    2076 # Return count of non-SOA records in zone (or default records in a group)
    2077 # Takes a database handle, default/live flag, reverse/forward flag, group/domain ID,
    2078 # and optional filtering modifier
    2079 # Returns the count
    2080 sub getRecCount {
    2081   my $dbh = shift;
    2082   my $defrec = shift;
    2083   my $revrec = shift;
    2084   my $id = shift;
    2085   my $filter = shift || '';
    2086 
    2087   # keep the nasties down, since we can't ?-sub this bit.  :/
    2088   # note this is chars allowed in DNS hostnames
    2089   $filter =~ s/[^a-zA-Z0-9_.:-]//g;
    2090 
    2091   my @bindvars = ($id);
    2092   push @bindvars, $filter if $filter;
    2093   my $sql = "SELECT count(*) FROM ".
    2094         _rectable($defrec,$revrec).
    2095         " WHERE "._recparent($defrec,$revrec)."=? ".
    2096         "AND NOT type=$reverse_typemap{SOA}".
    2097         ($filter ? " AND host ~* ?" : '');
    2098   my ($count) = $dbh->selectrow_array($sql, undef, (@bindvars) );
    2099 
    2100   return $count;
    2101 
    2102 } # end getRecCount()
    2103 
    2104 
    2105 ## DNSDB::addRec()
    2106 # Add a new record to a domain or a group's default records
    2107 # Takes a database handle, default/live flag, group/domain ID,
    2108 # host, type, value, and TTL
    2109 # Some types require additional detail: "distance" for MX and SRV,
    2110 # and weight/port for SRV
    2111 # Returns a status code and detail message in case of error
    2112 ##fixme:  pass a hash with the record data, not a series of separate values
    2113 sub addRec {
    2114   $errstr = '';
    2115   my $dbh = shift;
    2116   my $defrec = shift;
    2117   my $revrec = shift;
    2118   my $id = shift;       # parent (group_id for defrecs, rdns_id for reverse records,
    2119                         # domain_id for domain records)
    2120 
    2121   my $host = shift;
    2122   my $rectype = shift;  # reference so we can coerce it if "+"-types can't find both zones
    2123   my $val = shift;
    2124   my $ttl = shift;
    2125 
    2126   # Spaces are evil.
    2127   $host =~ s/^\s+//;
    2128   $host =~ s/\s+$//;
    2129   if ($typemap{$rectype} ne 'TXT') {
    2130     # Leading or trailng spaces could be legit in TXT records.
    2131     $val =~ s/^\s+//;
    2132     $val =~ s/\s+$//;
    2133   }
    2134 
    2135   # Validation
    2136   my $addr = NetAddr::IP->new($val);
    2137   if ($rectype == $reverse_typemap{A}) {
    2138     return ('FAIL',$typemap{$rectype}." record must be a valid IPv4 address")
    2139         unless $addr && !$addr->{isv6};
    2140   }
    2141   if ($rectype == $reverse_typemap{AAAA}) {
    2142     return ('FAIL',$typemap{$rectype}." record must be a valid IPv6 address")
    2143         unless $addr && $addr->{isv6};
    2144   }
    2145 
    2146   my $domid = 0;
    2147   my $revid = 0;
    2148 
    2149   my $retcode = 'OK';   # assume everything will go OK
    2150   my $retmsg = '';
    2151 
    2152   # do simple validation first
    2153   return ('FAIL', "TTL must be numeric") unless $ttl =~ /^\d+$/;
    2154 
    2155   # Quick check on hostname parts.  Note the regex is more forgiving than the error message;
    2156   # domain names technically are case-insensitive, and we use printf-like % codes for a couple
    2157   # of types.  Other things may also be added to validate default records of several flavours.
    2158   return ('FAIL', "Hostnames may not contain anything other than (0-9 a-z . _)")
    2159         if $defrec eq 'n' && $$host !~ /^[0-9a-z_%.]+$/i;
    2160 
    2161   # Collect these even if we're only doing a simple A record so we can call *any* validation sub
    2162   my $dist = shift;
    2163   my $port = shift;
    2164   my $weight = shift;
    2165 
    2166   my $fields;
    2167   my @vallist;
    2168 
    2169   # Call the validation sub for the type requested.
    2170   ($retcode,$retmsg) = $validators{$$rectype}($dbh, (defrec => $defrec, revrec => $revrec, id => $id,
    2171         host => $host, rectype => $rectype, val => $val, addr => $addr,
    2172         dist => \$dist, port => \$port, weight => \$weight,
    2173         fields => \$fields, vallist => \@vallist) );
    2174 
    2175   return ($retcode,$retmsg) if $retcode eq 'FAIL';
    2176 
    2177   # Set up database fields and bind parameters
    2178   $fields .= "host,type,val,ttl,"._recparent($defrec,$revrec);
    2179   push @vallist, ($$host,$$rectype,$$val,$ttl,$id);
    2180   my $vallen = '?'.(',?'x$#vallist);
    2181 
    2182   # Allow transactions, and raise an exception on errors so we can catch it later.
    2183   # Use local to make sure these get "reset" properly on exiting this block
    2184   local $dbh->{AutoCommit} = 0;
    2185   local $dbh->{RaiseError} = 1;
    2186 
    2187   eval {
    2188     $dbh->do("INSERT INTO "._rectable($defrec, $revrec)." ($fields) VALUES ($vallen)",
    2189         undef, @vallist);
    2190     $dbh->commit;
    2191   };
    2192   if ($@) {
    2193     my $msg = $@;
    2194     eval { $dbh->rollback; };
    2195     return ('FAIL',$msg);
    2196   }
    2197 
    2198   return ($retcode, $retmsg);
    2199 
    2200 } # end addRec()
    2201 
    2202 
    2203 ## DNSDB::updateRec()
    2204 # Update a record
    2205 sub updateRec {
    2206   $errstr = '';
    2207 
    2208   my $dbh = shift;
    2209   my $defrec = shift;
    2210   my $id = shift;
    2211 
    2212 # all records have these
    2213   my $host = shift;
    2214   my $type = shift;
    2215   my $val = shift;
    2216   my $ttl = shift;
    2217 
    2218   return('FAIL',"Missing standard argument(s)") if !defined($ttl);
    2219 
    2220   # Spaces are evil.
    2221   $host =~ s/^\s+//;
    2222   $host =~ s/\s+$//;
    2223   if ($typemap{$type} ne 'TXT') {
    2224     # Leading or trailng spaces could be legit in TXT records.
    2225     $val =~ s/^\s+//;
    2226     $val =~ s/\s+$//;
    2227   }
    2228 
    2229 # only MX and SRV will use these
    2230   my $dist = 0;
    2231   my $weight = 0;
    2232   my $port = 0;
    2233 
    2234   if ($type == $reverse_typemap{MX} || $type == $reverse_typemap{SRV}) {
    2235     $dist = shift;
    2236     $dist =~ s/\s+//g;
    2237     return ('FAIL',"MX or SRV requires distance") if !defined($dist);
    2238     return ('FAIL', "Distance must be numeric") unless $dist =~ /^\d+$/;
    2239     if ($type == $reverse_typemap{SRV}) {
    2240       $weight = shift;
    2241       $weight =~ s/\s+//g;
    2242       return ('FAIL',"SRV requires weight") if !defined($weight);
    2243       return ('FAIL',"Weight must be numeric") unless $weight =~ /^\d+$/;
    2244       $port = shift;
    2245       $port =~ s/\s+//g;
    2246       return ('FAIL',"SRV requires port") if !defined($port);
    2247       return ('FAIL',"Port must be numeric") unless $port =~ /^\d+$/;
    2248     }
    2249   }
    2250 
    2251 # Enforce IP addresses on A and AAAA types
    2252   my $addr = NetAddr::IP->new($val);
    2253   if ($type == $reverse_typemap{A}) {
    2254     return ('FAIL',$typemap{$type}." record must be a valid IPv4 address")
    2255         unless $addr && !$addr->{isv6};
    2256   }
    2257   if ($type == $reverse_typemap{AAAA}) {
    2258     return ('FAIL',$typemap{$type}." record must be a valid IPv6 address")
    2259         unless $addr && $addr->{isv6};
    2260   }
    2261 
    2262 # hmm..  this might work.  except possibly for something pointing to "deadbeef.ca".  <g>
    2263 #  if ($type == $reverse_typemap{NS} || $type == $reverse_typemap{MX} || $type == $reverse_typemap{SRV}) {
    2264 #    if ($val =~ /^\s*[\da-f:.]+\s*$/) {
    2265 #      return ('FAIL',"$val is not a valid IP address") if !$addr;
    2266 #    }
    2267 #  }
    2268 
    2269   local $dbh->{AutoCommit} = 0;
    2270   local $dbh->{RaiseError} = 1;
    2271 
    2272   eval {
    2273     $dbh->do("UPDATE ".($defrec eq 'y' ? 'default_' : '')."records ".
    2274         "SET host=?,val=?,type=?,ttl=?,distance=?,weight=?,port=? ".
    2275         "WHERE record_id=?", undef, ($host, $val, $type, $ttl, $dist, $weight, $port, $id) );
    2276     $dbh->commit;
    2277   };
    2278   if ($@) {
    2279     my $msg = $@;
    2280     $dbh->rollback;
    2281     return ('FAIL', $msg);
    2282   }
    2283 
    2284   return ('OK','OK');
    2285 } # end updateRec()
    2286 
    2287 
    2288 ## DNSDB::delRec()
    2289 # Delete a record. 
    2290 sub delRec {
    2291   $errstr = '';
    2292   my $dbh = shift;
    2293   my $defrec = shift;
    2294   my $revrec = shift;
    2295   my $id = shift;
    2296 
    2297   my $sth = $dbh->prepare("DELETE FROM "._rectable($defrec,$revrec)." WHERE record_id=?");
    2298   $sth->execute($id);
    2299 
    2300   return ('FAIL',"Couldn't remove record: ".$sth->errstr) if $sth->err;
    2301 
    2302   return ('OK','OK');
    2303 } # end delRec()
    2304 
    2305 
    2306   # Reference hashes.
     177# Username, full name, ID - mainly for logging
     178my %userdata;
     179
     180# Entity-relationship reference hashes.
    2307181my %par_tbl = (
    2308182                group   => 'groups',
    … …  
    2342216        );
    2343217
     218##
     219## utility functions
     220##
     221
     222## DNSDB::_rectable()
     223# Takes default+rdns flags, returns appropriate table name
     224sub _rectable {
     225  my $def = shift;
     226  my $rev = shift;
     227
     228  return 'records' if $def ne 'y';
     229  return 'default_records' if $rev ne 'y';
     230  return 'default_rev_records';
     231} # end _rectable()
     232
     233## DNSDB::_recparent()
     234# Takes default+rdns flags, returns appropriate parent-id column name
     235sub _recparent {
     236  my $def = shift;
     237  my $rev = shift;
     238
     239  return 'group_id' if $def eq 'y';
     240  return 'rdns_id' if $rev eq 'y';
     241  return 'domain_id';
     242} # end _recparent()
     243
     244## DNSDB::_ipparent()
     245# Check an IP to be added in a reverse zone to see if it's really in the requested parent.
     246# Takes a database handle, default and reverse flags, IP (fragment) to check, parent zone ID,
     247# and a reference to a NetAddr::IP object (also used to pass back a fully-reconstructed IP for
     248# database insertion)
     249sub _ipparent {
     250  my $dbh = shift;
     251  my $defrec = shift;
     252  my $revrec = shift;
     253  my $val = shift;
     254  my $id = shift;
     255  my $addr = shift;
     256
     257  return if $revrec ne 'y';     # this sub not useful in forward zones
     258
     259  $$addr = NetAddr::IP->new($$val);      #necessary?
     260
     261  # subsub to split, reverse, and overlay an IP fragment on a netblock
     262  sub __rev_overlay {
     263    my $splitme = shift;        # ':' or '.', m'lud?
     264    my $parnet = shift;
     265    my $val = shift;
     266    my $addr = shift;
     267
     268    my $joinme = $splitme;
     269    $splitme = '\.' if $splitme eq '.';
     270    my @working = reverse(split($splitme, $parnet->addr));
     271    my @parts = reverse(split($splitme, $$val));
     272    for (my $i = 0; $i <= $#parts; $i++) {
     273      $working[$i] = $parts[$i];
     274    }
     275    my $checkme = NetAddr::IP->new(join($joinme, reverse(@working))) or return 0;
     276    return 0 unless $checkme->within($parnet);
     277    $$addr = $checkme;  # force "correct" IP to be recorded.
     278    return 1;
     279  }
     280
     281  my ($parstr) = $dbh->selectrow_array("SELECT revnet FROM revzones WHERE rdns_id = ?", undef, ($id));
     282  my $parnet = NetAddr::IP->new($parstr);
     283
     284  # Fail early on v6-in-v4 or v4-in-v6.  We're not accepting these ATM.
     285  return 0 if $parnet->addr =~ /\./ && $$val =~ /:/;
     286  return 0 if $parnet->addr =~ /:/ && $$val =~ /\./;
     287
     288  if ($$addr && ($$val =~ /^[\da-fA-F][\da-fA-F:]+[\da-fA-F]$/ || $$val =~ m|/\d+$|)) {
     289    # the only case where NetAddr::IP's acceptance of legitimate IPs is "correct" is for a proper IPv6 address,
     290    # or a netblock (only expected on templates)
     291    # the rest we have to restructure before fiddling.  *sigh*
     292    return 1 if $$addr->within($parnet);
     293  } else {
     294    # We don't have a complete IP in $$val (yet)... unless we have a netblock
     295    if ($parnet->addr =~ /:/) {
     296      $$val =~ s/^:+//;  # gotta strip'em all...
     297      return __rev_overlay(':', $parnet, $val, $addr);
     298    }
     299    if ($parnet->addr =~ /\./) {
     300      $$val =~ s/^\.+//;
     301      return __rev_overlay('.', $parnet, $val, $addr);
     302    }
     303    # should be impossible to get here...
     304  }
     305  # ... and here.
     306  # can't do nuttin' in forward zones
     307} # end _ipparent()
     308
     309## DNSDB::_hostparent()
     310# A little different than _ipparent above;  this tries to *find* the parent zone of a hostname
     311# Takes a database handle and hostname.
     312# Returns the domain ID of the parent domain if one was found.
     313sub _hostparent {
     314  my $dbh = shift;
     315  my $hname = shift;
     316
     317  $hname =~ s/^\*\.//;  # this should be impossible to find in the domains table.
     318  my @hostbits = split /\./, $hname;
     319  my $sth = $dbh->prepare("SELECT count(*),domain_id FROM domains WHERE lower(domain) = lower(?) GROUP BY domain_id");
     320  foreach (@hostbits) {
     321    $sth->execute($hname);
     322    my ($found, $parid) = $sth->fetchrow_array;
     323    if ($found) {
     324      return $parid;
     325    }
     326    $hname =~ s/^$_\.//;
     327  }
     328} # end _hostparent()
     329
     330## DNSDB::_log()
     331# Log an action
     332# Takes a database handle and log entry hash containing at least:
     333#  group_id, log entry
     334# and optionally one or more of:
     335#  domain_id, rdns_id
     336# The %userdata hash provides the user ID, username, and fullname
     337sub _log {
     338  my $dbh = shift;
     339
     340  my %args = @_;
     341
     342  $args{rdns_id} = 0 if !$args{rdns_id};
     343  $args{domain_id} = 0 if !$args{domain_id};
     344
     345##fixme:  farm out the actual logging to different subs for file, syslog, internal, etc based on config
     346#  if ($config{log_channel} eq 'sql') {
     347  $dbh->do("INSERT INTO log (domain_id,rdns_id,group_id,entry,user_id,email,name) VALUES (?,?,?,?,?,?,?)",
     348        undef,
     349        ($args{domain_id}, $args{rdns_id}, $args{group_id}, $args{entry},
     350                $userdata{userid}, $userdata{username}, $userdata{fullname}) );
     351#  } elsif ($config{log_channel} eq 'file') {
     352#  } elsif ($config{log_channel} eq 'syslog') {
     353#  }
     354} # end _log
     355
     356
     357##
     358## Record validation subs.
     359##
     360
     361## All of these subs take substantially the same arguments:
     362# a database handle
     363# a hash containing at least the following keys:
     364#  - defrec (default/live flag)
     365#  - revrec (forward/reverse flag)
     366#  - id (parent entity ID)
     367#  - host (hostname)
     368#  - rectype
     369#  - val (IP, hostname [CNAME/MX/SRV] or text)
     370#  - addr (NetAddr::IP object from val.  May be undef.)
     371# MX and SRV record validation also expect distance, and SRV records expect weight and port as well.
     372# host, rectype, and addr should be references as these may be modified in validation
     373
     374# A record
     375sub _validate_1 {
     376  my $dbh = shift;
     377
     378  my %args = @_;
     379
     380  return ('FAIL', 'Reverse zones cannot contain A records') if $args{revrec} eq 'y';
     381
     382  # Coerce all hostnames to end in ".DOMAIN" for group/default records,
     383  # or the intended parent domain for live records.
     384  my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
     385  ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
     386
     387  # Check IP is well-formed, and that it's a v4 address
     388  # Fail on "compact" IPv4 variants, because they are not consistent and predictable.
     389  return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv4 address")
     390        unless ${$args{val}} =~ /^\d+\.\d+\.\d+\.\d+$/;
     391  return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv4 address")
     392        unless $args{addr} && !$args{addr}->{isv6};
     393  # coerce IP/value to normalized form for storage
     394  ${$args{val}} = $args{addr}->addr;
     395
     396  return ('OK','OK');
     397} # done A record
     398
     399# NS record
     400sub _validate_2 {
     401  my $dbh = shift;
     402
     403  my %args = @_;
     404
     405  # Check that the target of the record is within the parent.
     406  # Yes, host<->val are mixed up here;  can't see a way to avoid it.  :(
     407  if ($args{defrec} eq 'n') {
     408    # Check if IP/address/zone/"subzone" is within the parent
     409    if ($args{revrec} eq 'y') {
     410      my $tmpip = NetAddr::IP->new(${$args{val}});
     411      my $pname = revName($dbh,$args{id});
     412      return ('FAIL',"${$args{val}} not within $pname")
     413         unless _ipparent($dbh, $args{defrec}, $args{revrec}, $args{val}, $args{id}, \$tmpip);
     414      # Sub the returned thing for ZONE?  This could get stupid if you have typos...
     415      ${$args{val}} =~ s/ZONE/$tmpip->address/;
     416    } else {
     417      my $pname = domainName($dbh,$args{id});
     418      ${$args{host}} = $pname if ${$args{host}} !~ /\.$pname$/;
     419    }
     420  } else {
     421    # Default reverse NS records should always refer to the implied parent
     422    ${$args{host}} = 'DOMAIN' if $args{revrec} eq 'n';
     423    ${$args{val}} = 'ZONE' if $args{revrec} eq 'y';
     424  }
     425
     426# Let this lie for now.  Needs more magic.
     427#  # Check IP is well-formed, and that it's a v4 address
     428#  return ('FAIL',"A record must be a valid IPv4 address")
     429#       unless $addr && !$addr->{isv6};
     430#  # coerce IP/value to normalized form for storage
     431#  $$val = $addr->addr;
     432
     433  return ('OK','OK');
     434} # done NS record
     435
     436# CNAME record
     437sub _validate_5 {
     438  my $dbh = shift;
     439
     440  my %args = @_;
     441
     442# Not really true, but these are only useful for delegating smaller-than-/24 IP blocks.
     443# This is fundamentally a messy operation and should really just be taken care of by the
     444# export process, not manual maintenance of the necessary records.
     445  return ('FAIL', 'Reverse zones cannot contain CNAME records') if $args{revrec} eq 'y';
     446
     447  # Coerce all hostnames to end in ".DOMAIN" for group/default records,
     448  # or the intended parent domain for live records.
     449  my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
     450  ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
     451
     452  return ('OK','OK');
     453} # done CNAME record
     454
     455# SOA record
     456sub _validate_6 {
     457  # Smart monkeys won't stick their fingers in here;  we have
     458  # separate dedicated routines to deal with SOA records.
     459  return ('OK','OK');
     460} # done SOA record
     461
     462# PTR record
     463sub _validate_12 {
     464  my $dbh = shift;
     465
     466  my %args = @_;
     467
     468  if ($args{revrec} eq 'y') {
     469    if ($args{defrec} eq 'n') {
     470      return ('FAIL', "IP or IP fragment ${$args{val}} is not within ".revName($dbh, $args{id}))
     471        unless _ipparent($dbh, $args{defrec}, $args{revrec}, $args{val}, $args{id}, \$args{addr});
     472      ${$args{val}} = $args{addr}->addr;
     473    } else {
     474      if (${$args{val}} =~ /\./) {
     475        # looks like a v4 or fragment
     476        if (${$args{val}} =~ /^\d+\.\d+\.\d+\.\d+$/) {
     477          # woo!  a complete IP!  validate it and normalize, or fail.
     478          $args{addr} = NetAddr::IP->new(${$args{val}})
     479                or return ('FAIL', "IP/value looks like IPv4 but isn't valid");
     480          ${$args{val}} = $args{addr}->addr;
     481        } else {
     482          ${$args{val}} =~ s/^\.*/ZONE./ unless ${$args{val}} =~ /^ZONE/;
     483        }
     484      } elsif (${$args{val}} =~ /[a-f:]/) {
     485        # looks like a v6 or fragment
     486        ${$args{val}} =~ s/^:*/ZONE::/ if !$args{addr} && ${$args{val}} !~ /^ZONE/;
     487        if ($args{addr}) {
     488          if ($args{addr}->addr =~ /^0/) {
     489            ${$args{val}} =~ s/^:*/ZONE::/ unless ${$args{val}} =~ /^ZONE/;
     490          } else {
     491            ${$args{val}} = $args{addr}->addr;
     492          }
     493        }
     494      } else {
     495        # bare number (probably).  These could be v4 or v6, so we'll
     496        # expand on these on creation of a reverse zone.
     497        ${$args{val}} = "ZONE,${$args{val}}" unless ${$args{val}} =~ /^ZONE/;
     498      }
     499      ${$args{host}} =~ s/\.*$/\.$config{domain}/ if ${$args{host}} !~ /(?:$config{domain}|ADMINDOMAIN)$/;
     500    }
     501
     502# Multiple PTR records do NOT generally do what most people believe they do,
     503# and tend to fail in the most awkward way possible.  Check and warn.
     504# We use $val instead of $addr->addr since we may be in a defrec, and may have eg "ZONE::42" or "ZONE.12"
     505
     506    my @checkvals = (${$args{val}});
     507    if (${$args{val}} =~ /,/) {
     508      # push . and :: variants into checkvals if val has ,
     509      my $tmp;
     510      ($tmp = ${$args{val}}) =~ s/,/./;
     511      push @checkvals, $tmp;
     512      ($tmp = ${$args{val}}) =~ s/,/::/;
     513      push @checkvals, $tmp;
     514    }
     515    my $pcsth = $dbh->prepare("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec})." WHERE val = ?");
     516    foreach my $checkme (@checkvals) {
     517      if ($args{update}) {
     518        # Record update.  There should usually be an existing PTR (the record being updated)
     519        my @ptrs = @{ $dbh->selectcol_arrayref("SELECT record_id FROM "._rectable($args{defrec},$args{revrec}).
     520                " WHERE val = ?", undef, ($checkme)) };
     521        return ('WARN', "PTR record for $checkme already exists;  adding another will probably not do what you want")
     522                if @ptrs && (!grep /^$args{update}$/, @ptrs);
     523      } else {
     524        # New record.  Always warn if a PTR exists
     525        my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}).
     526                " WHERE val = ?", undef, ($checkme));
     527        return ('WARN', "PTR record for $checkme already exists;  adding another will probably not do what you want")
     528                if $ptrcount;
     529      }
     530    }
     531
     532  } else {
     533    # Not absolutely true but only useful if you hack things up for sub-/24 v4 reverse delegations
     534    # Simpler to just create the reverse zone and grant access for the customer to edit it, and create direct
     535    # PTR records on export
     536    return ('FAIL',"Forward zones cannot contain PTR records");
     537  }
     538
     539  return ('OK','OK');
     540} # done PTR record
     541
     542# MX record
     543sub _validate_15 {
     544  my $dbh = shift;
     545
     546  my %args = @_;
     547
     548# Not absolutely true but WTF use is an MX record for a reverse zone?
     549  return ('FAIL', 'Reverse zones cannot contain MX records') if $args{revrec} eq 'y';
     550
     551  return ('FAIL', "Distance is required for MX records") unless defined(${$args{dist}});
     552  ${$args{dist}} =~ s/\s*//g;
     553  return ('FAIL',"Distance is required, and must be numeric") unless ${$args{dist}} =~ /^\d+$/;
     554
     555  ${$args{fields}} = "distance,";
     556  push @{$args{vallist}}, ${$args{dist}};
     557
     558  # Coerce all hostnames to end in ".DOMAIN" for group/default records,
     559  # or the intended parent domain for live records.
     560  my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
     561  ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
     562
     563# hmm..  this might work.  except possibly for something pointing to "deadbeef.ca".  <g>
     564#  if ($type == $reverse_typemap{NS} || $type == $reverse_typemap{MX} || $type == $reverse_typemap{SRV}) {
     565#    if ($val =~ /^\s*[\da-f:.]+\s*$/) {
     566#      return ('FAIL',"$val is not a valid IP address") if !$addr;
     567#    }
     568#  }
     569
     570  return ('OK','OK');
     571} # done MX record
     572
     573# TXT record
     574sub _validate_16 {
     575  # Could arguably put a WARN return here on very long (>512) records
     576  return ('OK','OK');
     577} # done TXT record
     578
     579# RP record
     580sub _validate_17 {
     581  # Probably have to validate these some day
     582  return ('OK','OK');
     583} # done RP record
     584
     585# AAAA record
     586sub _validate_28 {
     587  my $dbh = shift;
     588
     589  my %args = @_;
     590
     591  return ('FAIL', 'Reverse zones cannot contain AAAA records') if $args{revrec} eq 'y';
     592
     593  # Coerce all hostnames to end in ".DOMAIN" for group/default records,
     594  # or the intended parent domain for live records.
     595  my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
     596  ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
     597
     598  # Check IP is well-formed, and that it's a v6 address
     599  return ('FAIL',"$typemap{${$args{rectype}}} record must be a valid IPv6 address")
     600        unless $args{addr} && $args{addr}->{isv6};
     601  # coerce IP/value to normalized form for storage
     602  ${$args{val}} = $args{addr}->addr;
     603
     604  return ('OK','OK');
     605} # done AAAA record
     606
     607# SRV record
     608sub _validate_33 {
     609  my $dbh = shift;
     610
     611  my %args = @_;
     612
     613# Not absolutely true but WTF use is an SRV record for a reverse zone?
     614  return ('FAIL', 'Reverse zones cannot contain SRV records') if $args{revrec} eq 'y';
     615
     616  return ('FAIL', "Distance is required for SRV records") unless defined(${$args{dist}});
     617  ${$args{dist}} =~ s/\s*//g;
     618  return ('FAIL',"Distance is required, and must be numeric") unless ${$args{dist}} =~ /^\d+$/;
     619
     620  return ('FAIL',"SRV records must begin with _service._protocol [${$args{host}}]")
     621        unless ${$args{host}} =~ /^_[A-Za-z]+\._[A-Za-z]+\.[a-zA-Z0-9-]+/;
     622  return ('FAIL',"Port and weight are required for SRV records")
     623        unless defined(${$args{weight}}) && defined(${$args{port}});
     624  ${$args{weight}} =~ s/\s*//g;
     625  ${$args{port}} =~ s/\s*//g;
     626
     627  return ('FAIL',"Port and weight are required, and must be numeric")
     628        unless ${$args{weight}} =~ /^\d+$/ && ${$args{port}} =~ /^\d+$/;
     629
     630  ${$args{fields}} = "distance,weight,port,";
     631  push @{$args{vallist}}, (${$args{dist}}, ${$args{weight}}, ${$args{port}});
     632
     633  # Coerce all hostnames to end in ".DOMAIN" for group/default records,
     634  # or the intended parent domain for live records.
     635  my $pname = ($args{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$args{id}));
     636  ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
     637
     638  return ('OK','OK');
     639} # done SRV record
     640
     641# Now the custom types
     642
     643# A+PTR record.  With a very little bit of magic we can also use this sub to validate AAAA+PTR.  Whee!
     644sub _validate_65280 {
     645  my $dbh = shift;
     646
     647  my %args = @_;
     648
     649  my $code = 'OK';
     650  my $msg = 'OK';
     651
     652  if ($args{defrec} eq 'n') {
     653    # live record;  revrec determines whether we validate the PTR or A component first.
     654
     655    if ($args{revrec} eq 'y') {
     656      ($code,$msg) = _validate_12($dbh, %args);
     657      return ($code,$msg) if $code eq 'FAIL';
     658
     659      # Check if the reqested domain exists.  If not, coerce the type down to PTR and warn.
     660      if (!(${$args{domid}} = _hostparent($dbh, ${$args{host}}))) {
     661        my $addmsg = "Record ".($args{update} ? 'updated' : 'added').
     662                " as PTR instead of $typemap{${$args{rectype}}};  domain not found for ${$args{host}}";
     663        $msg .= "\n$addmsg" if $code eq 'WARN';
     664        $msg = $addmsg if $code eq 'OK';
     665        ${$args{rectype}} = $reverse_typemap{PTR};
     666        return ('WARN', $msg);
     667      }
     668
     669      # Add domain ID to field list and values
     670      ${$args{fields}} .= "domain_id,";
     671      push @{$args{vallist}}, ${$args{domid}};
     672
     673    } else {
     674      ($code,$msg) = _validate_1($dbh, %args) if ${$args{rectype}} == 65280;
     675      ($code,$msg) = _validate_28($dbh, %args) if ${$args{rectype}} == 65281;
     676      return ($code,$msg) if $code eq 'FAIL';
     677
     678      # Check if the requested reverse zone exists - note, an IP fragment won't
     679      # work here since we don't *know* which parent to put it in.
     680      # ${$args{val}} has been validated as a valid IP by now, in one of the above calls.
     681      my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?".
     682        " ORDER BY masklen(revnet) DESC", undef, (${$args{val}}));
     683      if (!$revid) {
     684        $msg = "Record ".($args{update} ? 'updated' : 'added')." as ".(${$args{rectype}} == 65280 ? 'A' : 'AAAA').
     685                " instead of $typemap{${$args{rectype}}};  reverse zone not found for ${$args{val}}";
     686        ${$args{rectype}} = (${$args{rectype}} == 65280 ? $reverse_typemap{A} : $reverse_typemap{AAAA});
     687        return ('WARN', $msg);
     688      }
     689
     690      # Check for duplicate PTRs.  Note we don't have to play games with $code and $msg, because
     691      # by definition there can't be duplicate PTRs if the reverse zone isn't managed here.
     692      if ($args{update}) {
     693        # Record update.  There should usually be an existing PTR (the record being updated)
     694        my @ptrs = @{ $dbh->selectcol_arrayref("SELECT record_id FROM "._rectable($args{defrec},$args{revrec}).
     695                " WHERE val = ?", undef, (${$args{val}})) };
     696        if (@ptrs && (!grep /^$args{update}$/, @ptrs)) {
     697          $msg = "PTR record for ${$args{val}} already exists;  adding another will probably not do what you want";
     698          $code = 'WARN';
     699        }
     700      } else {
     701        # New record.  Always warn if a PTR exists
     702        my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}).
     703                " WHERE val = ?", undef, (${$args{val}}));
     704        $msg = "PTR record for ${$args{val}} already exists;  adding another will probably not do what you want"
     705                if $ptrcount;
     706        $code = 'WARN' if $ptrcount;
     707      }
     708
     709#      my ($ptrcount) = $dbh->selectrow_array("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec}).
     710#       " WHERE val = ?", undef, ${$args{val}});
     711#      if ($ptrcount) {
     712#        my $curid = $dbh->selectrow_array("SELECT record_id FROM "._rectable($args{defrec},$args{revrec}).
     713#               " WHERE val = ?
     714#       $msg = "PTR record for ${$args{val}} already exists;  adding another will probably not do what you want";
     715#       $code = 'WARN';
     716#      }
     717
     718      ${$args{fields}} .= "rdns_id,";
     719      push @{$args{vallist}}, $revid;
     720    }
     721
     722  } else {      # defrec eq 'y'
     723    if ($args{revrec} eq 'y') {
     724      ($code,$msg) = _validate_12($dbh, %args);
     725      return ($code,$msg) if $code eq 'FAIL';
     726      if (${$args{rectype}} == 65280) {
     727        return ('FAIL',"A+PTR record must be a valid IPv4 address or fragment")
     728                if ${$args{val}} =~ /:/;
     729        ${$args{val}} =~ s/^ZONE,/ZONE./;       # Clean up after uncertain IP-fragment-type from _validate_12
     730      } elsif (${$args{rectype}} == 65281) {
     731        return ('FAIL',"AAAA+PTR record must be a valid IPv6 address or fragment")
     732                if ${$args{val}} =~ /\./;
     733        ${$args{val}} =~ s/^ZONE,/ZONE::/;      # Clean up after uncertain IP-fragment-type from _validate_12
     734      }
     735    } else {
     736      # This is easy.  I also can't see a real use-case for A/AAAA+PTR in *all* forward
     737      # domains, since you wouldn't be able to substitute both domain and reverse zone
     738      # sanely, and you'd end up with guaranteed over-replicated PTR records that would
     739      # confuse the hell out of pretty much anything that uses them.
     740##fixme: make this a config flag?
     741      return ('FAIL', "$typemap{${$args{rectype}}} records not allowed in default domains");
     742    }
     743  }
     744
     745  return ($code, $msg);
     746} # done A+PTR record
     747
     748# AAAA+PTR record
     749# A+PTR above has been magicked to handle AAAA+PTR as well.
     750sub _validate_65281 {
     751  return _validate_65280(@_);
     752} # done AAAA+PTR record
     753
     754# PTR template record
     755sub _validate_65282 {
     756  my $dbh = shift;
     757
     758  my %args = @_;
     759
     760  # we're *this* >.< close to being able to just call _validate_12... unfortunately we can't, quite.
     761  if ($args{revrec} eq 'y') {
     762    if ($args{defrec} eq 'n') {
     763      return ('FAIL', "Template block ${$args{val}} is not within ".revName($dbh, $args{id}))
     764        unless _ipparent($dbh, $args{defrec}, $args{revrec}, $args{val}, $args{id}, \$args{addr});
     765##fixme:  warn if $args{val} is not /31 or larger block?
     766      ${$args{val}} = "$args{addr}";
     767    } else {
     768      if (${$args{val}} =~ /\./) {
     769        # looks like a v4 or fragment
     770        if (${$args{val}} =~ m|^\d+\.\d+\.\d+\.\d+(?:/\d+)?$|) {
     771          # woo!  a complete IP!  validate it and normalize, or fail.
     772          $args{addr} = NetAddr::IP->new(${$args{val}})
     773                or return ('FAIL', "IP/value looks like IPv4 but isn't valid");
     774          ${$args{val}} = "$args{addr}";
     775        } else {
     776          ${$args{val}} =~ s/^\.*/ZONE./ unless ${$args{val}} =~ /^ZONE/;
     777        }
     778      } elsif (${$args{val}} =~ /[a-f:]/) {
     779        # looks like a v6 or fragment
     780        ${$args{val}} =~ s/^:*/ZONE::/ if !$args{addr} && ${$args{val}} !~ /^ZONE/;
     781        if ($args{addr}) {
     782          if ($args{addr}->addr =~ /^0/) {
     783            ${$args{val}} =~ s/^:*/ZONE::/ unless ${$args{val}} =~ /^ZONE/;
     784          } else {
     785            ${$args{val}} = "$args{addr}";
     786          }
     787        }
     788      } else {
     789        # bare number (probably).  These could be v4 or v6, so we'll
     790        # expand on these on creation of a reverse zone.
     791        ${$args{val}} = "ZONE,${$args{val}}" unless ${$args{val}} =~ /^ZONE/;
     792      }
     793    }
     794##fixme:  validate %-patterns?
     795
     796# Unlike single PTR records, there is absolutely no way to sanely support multiple
     797# PTR templates for the same block, since they expect to expand to all the individual
     798# IPs on export.  Nested templates should be supported though.
     799
     800    my @checkvals = (${$args{val}});
     801    if (${$args{val}} =~ /,/) {
     802      # push . and :: variants into checkvals if val has ,
     803      my $tmp;
     804      ($tmp = ${$args{val}}) =~ s/,/./;
     805      push @checkvals, $tmp;
     806      ($tmp = ${$args{val}}) =~ s/,/::/;
     807      push @checkvals, $tmp;
     808    }
     809##fixme:  this feels wrong still - need to restrict template pseudorecords to One Of Each
     810# Per Netblock such that they don't conflict on export
     811    my $typeck;
     812# type 65282 -> ptr template -> look for any of 65282, 65283, 65284
     813    $typeck = 'type=65283 OR type=65284' if ${$args{rectype}} == 65282;
     814# type 65283 -> a+ptr template -> v4 -> look for 65282 or 65283
     815    $typeck = 'type=65283' if ${$args{rectype}} == 65282;
     816# type 65284 -> aaaa+ptr template -> v6 -> look for 65282 or 65284
     817    $typeck = 'type=65284' if ${$args{rectype}} == 65282;
     818    my $pcsth = $dbh->prepare("SELECT count(*) FROM "._rectable($args{defrec},$args{revrec})." WHERE val = ? ".
     819        "AND (type=65282 OR $typeck)");
     820    foreach my $checkme (@checkvals) {
     821      $pcsth->execute($checkme);
     822      my ($rc) = $pcsth->fetchrow_array;
     823      return ('FAIL', "Only one template pseudorecord may exist for a given IP block") if $rc;
     824    }
     825
     826  } else {
     827    return ('FAIL', "Forward zones cannot contain PTR records");
     828  }
     829
     830  return ('OK','OK');
     831} # done PTR template record
     832
     833# A+PTR template record
     834sub _validate_65283 {
     835  my $dbh = shift;
     836
     837  my %args = @_;
     838
     839  my ($code,$msg) = ('OK','OK');
     840
     841##fixme:  need to fiddle things since A+PTR templates are acceptable in live
     842# forward zones but not default records
     843  if ($args{defrec} eq 'n') {
     844    if ($args{revrec} eq 'n') {
     845      ($code,$msg) = _validate_1($dbh, %args) if ${$args{rectype}} == 65280;
     846      ($code,$msg) = _validate_28($dbh, %args) if ${$args{rectype}} == 65281;
     847      return ($code,$msg) if $code eq 'FAIL';
     848
     849      # Check if the requested reverse zone exists - note, an IP fragment won't
     850      # work here since we don't *know* which parent to put it in.
     851      # ${$args{val}} has been validated as a valid IP by now, in one of the above calls.
     852      my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?".
     853        " ORDER BY masklen(revnet) DESC", undef, (${$args{val}}));
     854      # Fail if no match;  we can't coerce a PTR-template type down to not include the PTR bit currently.
     855      if (!$revid) {
     856        $msg = "Can't ".($args{update} ? 'update' : 'add')." ${$args{host}}/${$args{val}} as ".
     857                "$typemap{${$args{rectype}}}:  reverse zone not found for ${$args{val}}";
     858##fixme:  add A template, AAAA template types?
     859#       ${$args{rectype}} = (${$args{rectype}} == 65280 ? $reverse_typemap{A} : $reverse_typemap{AAAA});
     860        return ('FAIL', $msg);
     861      }
     862
     863      # Add reverse zone ID to field list and values
     864      ${$args{fields}} .= "rdns_id,";
     865      push @{$args{vallist}}, $revid;
     866
     867    } else {
     868      return ('FAIL', "IP or IP fragment ${$args{val}} is not within ".revName($dbh, $args{id}))
     869        unless _ipparent($dbh, $args{defrec}, $args{revrec}, $args{val}, $args{id}, \$args{addr});
     870      ${$args{val}} = "$args{addr}";
     871
     872      if (!(${$args{domid}} = _hostparent($dbh, ${$args{host}}))) {
     873        my $addmsg = "Record ".($args{update} ? 'updated' : 'added').
     874                " as PTR template instead of $typemap{${$args{rectype}}};  domain not found for ${$args{host}}";
     875        $msg .= "\n$addmsg" if $code eq 'WARN';
     876        $msg = $addmsg if $code eq 'OK';
     877        ${$args{rectype}} = 65282;
     878        return ('WARN', $msg);
     879      }
     880
     881      # Add domain ID to field list and values
     882      ${$args{fields}} .= "domain_id,";
     883      push @{$args{vallist}}, ${$args{domid}};
     884    }
     885
     886  } else {
     887    my ($code,$msg) = _validate_65282($dbh, %args);
     888    return ($code, $msg) if $code eq 'FAIL';
     889    # get domain, check against ${$args{name}}
     890  }
     891
     892  return ('OK','OK');
     893} # done AAAA+PTR template record
     894
     895# AAAA+PTR template record
     896sub _validate_65284 {
     897  return ('OK','OK');
     898} # done AAAA+PTR template record
     899
     900# Delegation record
     901# This is essentially a specialized clone of the NS record, primarily useful
     902# for delegating IPv4 sub-/24 reverse blocks
     903sub _validate_65285 {
     904  my $dbh = shift;
     905
     906  my %args = @_;
     907
     908# Almost, but not quite, identical to NS record validation.
     909
     910  # Check that the target of the record is within the parent.
     911  # Yes, host<->val are mixed up here;  can't see a way to avoid it.  :(
     912  if ($args{defrec} eq 'n') {
     913    # Check if IP/address/zone/"subzone" is within the parent
     914    if ($args{revrec} eq 'y') {
     915      my $tmpip = NetAddr::IP->new(${$args{val}});
     916      my $pname = revName($dbh,$args{id});
     917      return ('FAIL',"${$args{val}} not within $pname")
     918         unless _ipparent($dbh, $args{defrec}, $args{revrec}, $args{val}, $args{id}, \$tmpip);
     919      # Normalize
     920      ${$args{val}} = "$tmpip";
     921    } else {
     922      my $pname = domainName($dbh,$args{id});
     923      ${$args{host}} =~ s/\.*$/\.$pname/ if ${$args{host}} !~ /$pname$/;
     924    }
     925  } else {
     926    return ('FAIL',"Delegation records are not permitted in default record sets");
     927  }
     928  return ('OK','OK');
     929}
     930
     931
     932##
     933## Record data substitution subs
     934##
     935
     936# Replace ZONE in hostname, or create (most of) the actual proper zone name
     937sub _ZONE {
     938  my $zone = shift;
     939  my $string = shift;
     940  my $fr = shift || 'f';        # flag for forward/reverse order?  nb: ignored for IP
     941  my $sep = shift || '-';       # Separator character - unlikely we'll ever need more than . or -
     942
     943  my $prefix;
     944
     945  $string =~ s/,/./ if !$zone->{isv6};
     946  $string =~ s/,/::/ if $zone->{isv6};
     947
     948  # Subbing ZONE in the host.  We need to properly ID the netblock range
     949  # The subbed text should have "network IP with trailing zeros stripped" for
     950  # blocks lined up on octet (for v4) or hex-quad (for v6) boundaries
     951  # For blocks that do NOT line up on these boundaries, we take the most
     952  # significant octet or 16-bit chunk of the "broadcast" IP and append it
     953  # after a double-dash
     954  # ie:
     955  # 8.0.0.0/6 -> 8.0.0.0 -> 11.255.255.255;  sub should be 8--11
     956  # 10.0.0.0/12 -> 10.0.0.0 -> 10.0.0.0 -> 10.15.255.255;  sub should be 10-0--15
     957  # 192.168.4.0/22 -> 192.168.4.0 -> 192.168.7.255;  sub should be 192-168-4--7
     958  # 192.168.0.8/29 -> 192.168.0.8 -> 192.168.0.15;  sub should be 192-168-0-8--15
     959  # Similar for v6
     960
     961  if (!$zone->{isv6}) { # IPv4
     962
     963    $prefix = $zone->network->addr;     # Just In Case someone managed to slip in
     964                                        # a funky subnet that had host bits set.
     965    my $bc = $zone->broadcast->addr;
     966
     967    if ($zone->masklen > 24) {
     968      $bc =~ s/^\d+\.\d+\.\d+\.//;
     969    } elsif ($zone->masklen > 16) {
     970      $prefix =~ s/\.0$//;
     971      $bc =~ s/^\d+\.\d+\.//;
     972    } elsif ($zone->masklen > 8) {
     973      $bc =~ s/^\d+\.//;
     974      $prefix =~ s/\.0\.0$//;
     975    } else {
     976      $prefix =~ s/\.0\.0\.0$//;
     977    }
     978    if ($zone->masklen % 8) {
     979      $bc =~ s/(\.255)+$//;
     980      $prefix .= "--$bc";       #"--".zone->masklen;    # use range or mask length?
     981    }
     982    if ($fr eq 'f') {
     983      $prefix =~ s/\.+/$sep/g;
     984    } else {
     985      $prefix = join($sep, reverse(split(/\./, $prefix)));
     986    }
     987
     988  } else { # IPv6
     989
     990    if ($fr eq 'f') {
     991
     992      $prefix = $zone->network->addr;   # Just In Case someone managed to slip in
     993                                        # a funky subnet that had host bits set.
     994      my $bc = $zone->broadcast->addr;
     995      if (($zone->masklen % 16) != 0) {
     996        # Strip trailing :0 off $prefix, and :ffff off the broadcast IP
     997        for (my $i=0; $i<(7-int($zone->masklen / 16)); $i++) {
     998          $prefix =~ s/:0$//;
     999          $bc =~ s/:ffff$//;
     1000        }
     1001        # Strip the leading 16-bit chunks off the front of the broadcast IP
     1002        $bc =~ s/^([a-f0-9]+:)+//;
     1003        # Append the remaining 16-bit chunk to the prefix after "--"
     1004        $prefix .= "--$bc";
     1005      } else {
     1006        # Strip off :0 from the end until we reach the netblock length.
     1007        for (my $i=0; $i<(8-$zone->masklen / 16); $i++) {
     1008          $prefix =~ s/:0$//;
     1009        }
     1010      }
     1011      # Actually deal with the separator
     1012      $prefix =~ s/:/$sep/g;
     1013
     1014    } else {    # $fr eq 'f'
     1015
     1016      $prefix = $zone->network->full;   # Just In Case someone managed to slip in
     1017                                        # a funky subnet that had host bits set.
     1018      my $bc = $zone->broadcast->full;
     1019      $prefix =~ s/://g;        # clean these out since they're not spaced right for this case
     1020      $bc =~ s/://g;
     1021      # Strip trailing 0 off $prefix, and f off the broadcast IP, to match the mask length
     1022      for (my $i=0; $i<(31-int($zone->masklen / 4)); $i++) {
     1023        $prefix =~ s/0$//;
     1024        $bc =~ s/f$//;
     1025      }
     1026      # Split and reverse the order of the nibbles in the network/broadcast IPs
     1027      # trim another 0 for nibble-aligned blocks first, but only if we really have a block, not an IP
     1028      $prefix =~ s/0$// if $zone->masklen % 4 == 0 && $zone->masklen != 128;
     1029      my @nbits = reverse split //, $prefix;
     1030      my @bbits = reverse split //, $bc;
     1031      # Handle the sub-nibble case.  Eww.  I feel dirty supporting this...
     1032      $nbits[0] = "$nbits[0]-$bbits[0]" if ($zone->masklen % 4) != 0;
     1033      # Glue it back together
     1034      $prefix = join($sep, @nbits);
     1035
     1036    }   # $fr ne 'f'
     1037
     1038  } # $zone->{isv6}
     1039
     1040  # Do the substitution, finally
     1041  $string =~ s/ZONE/$prefix/;
     1042  $string =~ s/--/-/ if $sep ne '-';    # - as separator needs extra help for sub-octet v4 netblocks
     1043  return $string;
     1044} # done _ZONE()
     1045
     1046# Not quite a substitution sub, but placed here as it's basically the inverse of above;
     1047# given the .arpa zone name, return the CIDR netblock the zone is for.
     1048# Supports v4 non-octet/non-classful netblocks as per the method outlined in the Grasshopper Book (2nd Ed p217-218)
     1049# Does NOT support non-quad v6 netblocks via the same scheme;  it shouldn't ever be necessary.
     1050# Takes a nominal .arpa zone name, returns a success code and NetAddr::IP, or a fail code and message
     1051sub _zone2cidr {
     1052  my $zone = shift;
     1053
     1054  my $cidr;
     1055  my $tmpcidr;
     1056  my $warnmsg = '';
     1057
     1058  if ($zone =~ /\.in-addr\.arpa\.?$/) {
     1059    # v4 revzone, formal zone name type
     1060    my $tmpzone = $zone;
     1061    $tmpzone =~ s/\.in-addr\.arpa\.?//;
     1062    return ('FAIL', "Non-numerics in apparent IPv4 reverse zone name") if $tmpzone !~ /^(?:\d+-)?[\d\.]+$/;
     1063
     1064    # Snag the octet pieces
     1065    my @octs = split /\./, $tmpzone;
     1066
     1067    # Map result of a range manipulation to a mask length change.  Cheaper than finding the 2-root of $octets[0]+1.
     1068    # Note we will not support /31 blocks, mostly due to issues telling "24-31" -> .24/29 apart from
     1069    # "24-31" -> .24/31", with a litte bit of "/31 is icky".
     1070    my %maskmap = (  3 => 2,  7 => 3, 15 => 4, 31 => 5, 63 => 6, 127 => 7,
     1071                    30 => 2, 29 => 3, 28 => 4, 27 => 5, 26 => 6,  25 => 7
     1072        );
     1073
     1074    # Handle "range" blocks, eg, 80-83.168.192.in-addr.arpa (192.168.80.0/22)
     1075    # Need to take the size of the range to offset the basic octet-based mask length,
     1076    # and make sure the first number in the range gets used as the network address for the block
     1077    # Alternate form:  The second number is actually the real netmask, not the end of the range.
     1078    my $masklen = 0;
     1079    if ($octs[0] =~ /^((\d+)-(\d+))$/) {        # take the range...
     1080      if (24 < $3 && $3 < 31) {
     1081        # we have a real netmask
     1082        $masklen = -$maskmap{$3};
     1083      } else {
     1084        # we have a range.  NB:  only real CIDR ranges are supported
     1085        $masklen -= $maskmap{-(eval $1)};       # find the mask base...
     1086      }
     1087      $octs[0] = $2;    # set the base octet of the range...
     1088    }
     1089    @octs = reverse @octs;      # We can reverse the octet pieces now that we've extracted and munged any ranges
     1090
     1091# arguably we should only allow sub-octet range/mask in-addr.arpa
     1092# specifications in the least significant octet, but the code is
     1093# simpler if we deal with sub-octet delegations at any level.
     1094
     1095    # Now we find the "true" mask with the aid of the "base" calculated above
     1096    if ($#octs == 0) {
     1097      $masklen += 8;
     1098      $tmpcidr = "$octs[0].0.0.0/$masklen";     # really hope we don't see one of these very often.
     1099    } elsif ($#octs == 1) {
     1100      $masklen += 16;
     1101      $tmpcidr = "$octs[0].$octs[1].0.0/$masklen";
     1102    } elsif ($#octs == 2) {
     1103      $masklen += 24;
     1104      $tmpcidr = "$octs[0].$octs[1].$octs[2].0/$masklen";
     1105    } else {
     1106      $masklen += 32;
     1107      $tmpcidr = "$octs[0].$octs[1].$octs[2].$octs[3]/$masklen";
     1108    }
     1109
     1110  } elsif ($zone =~ /\.ip6\.arpa$/) {
     1111    # v6 revzone, formal zone name type
     1112    my $tmpzone = $zone;
     1113    $tmpzone =~ s/\.ip6\.arpa\.?//;
     1114##fixme:  if-n-when we decide we can support sub-nibble v6 zone names, we'll need to change this segment
     1115    return ('FAIL', "Non-hexadecimals in apparent IPv6 reverse zone name") if $tmpzone !~ /^[a-fA-F\d\.]+$/;
     1116    my @quads = reverse(split(/\./, $tmpzone));
     1117    $warnmsg .= "Apparent sub-/64 IPv6 reverse zone\n" if $#quads > 15;
     1118    my $nc;
     1119    foreach (@quads) {
     1120      $tmpcidr .= $_;
     1121      $tmpcidr .= ":" if ++$nc % 4 == 0;
     1122    }
     1123    my $nq = 1 if $nc % 4 != 0;
     1124    my $mask = $nc * 4; # need to do this here because we probably increment it below
     1125    while ($nc++ % 4 != 0) {
     1126      $tmpcidr .= "0";
     1127    }
     1128    $tmpcidr .= ($nq ? '::' : ':')."/$mask";
     1129  }
     1130
     1131  # Just to be sure, use NetAddr::IP to validate.  Saves a lot of nasty regex watching for valid octet values.
     1132  return ('FAIL', "Invalid zone $zone (apparent netblock $tmpcidr)")
     1133        unless $cidr = NetAddr::IP->new($tmpcidr);
     1134
     1135  if ($warnmsg) {
     1136    $errstr = $warnmsg;
     1137    return ('WARN', $cidr);
     1138  }
     1139  return ('OK', $cidr);
     1140} # done _zone2cidr()
     1141
     1142# Record template %-parameter expansion, IPv4.  Note that IPv6 doesn't
     1143# really have a sane way to handle this type of expansion at the moment
     1144# due to the size of the address space.
     1145# Takes a reference to a template string to be expanded, and an IP to use in the replacement.
     1146sub _template4_expand {
     1147  my $tmpl = shift;
     1148  my $ip = shift;
     1149
     1150  my @ipparts = split /\./, $ip;
     1151  my @iphex;
     1152  my @ippad;
     1153  for (@ipparts) {
     1154    push @iphex, sprintf("%x", $_);
     1155    push @ippad, sprintf("%u.3", $_);
     1156  }
     1157
     1158  # IP substitutions in template records:
     1159  #major patterns:
     1160  #dashed IP, forward and reverse
     1161  #dotted IP, forward and reverse (even if forward is... dumb)
     1162  # -> %r for reverse, %i for forward, leading - or . to indicate separator, defaults to -
     1163  # %r or %-r   => %4d-%3d-%2d-%1d
     1164  # %.r         => %4d.%3d.%2d.%1d
     1165  # %i or %-i   => %1d-%2d-%3d-%4d
     1166  # %.i         => %1d.%2d.%3d.%4d
     1167  $$tmpl =~ s/\%r/\%4d-\%3d-\%2d-\%1d/g;
     1168  $$tmpl =~ s/\%([-.])r/\%4d$1\%3d$1\%2d$1\%1d/g;
     1169  $$tmpl =~ s/\%i/\%1d-\%2d-\%3d-\%4d/g;
     1170  $$tmpl =~ s/\%([-.])i/\%1d$1\%2d$1\%3d$1\%4d/g;
     1171
     1172  #hex-coded IP
     1173  # %h
     1174  $$tmpl =~ s/\%h/$iphex[0]$iphex[1]$iphex[2]$iphex[3]/g;
     1175
     1176  #IP as decimal-coded 32-bit value
     1177  # %d
     1178  my $iptmp = $ipparts[0]*256*256*256 + $ipparts[1]*256*256 + $ipparts[2]*256 + $ipparts[3];
     1179  $$tmpl =~ s/\%d/$iptmp/g;
     1180
     1181  #minor patterns (per-octet)
     1182  # %[1234][dh0]
     1183  #octet
     1184  #hex-coded octet
     1185  #0-padded octet
     1186  $$tmpl =~ s/\%([1234])d/$ipparts[$1-1]/g;
     1187  $$tmpl =~ s/\%([1234])h/$iphex[$1-1]/g;
     1188  $$tmpl =~ s/\%([1234])h/$ippad[$1-1]/g;
     1189} # _template4_expand()
     1190
     1191
     1192##
     1193## Initialization and cleanup subs
     1194##
     1195
     1196
     1197## DNSDB::loadConfig()
     1198# Load the minimum required initial state (DB connect info) from a config file
     1199# Load misc other bits while we're at it.
     1200# Takes an optional hash that may contain:
     1201#  - basename and config path to look for
     1202#  - RPC flag (saves parsing the more complex RPC bits if not needed)
     1203# Populates the %config and %def hashes
     1204sub loadConfig {
     1205  my %args = @_;
     1206  $args{basename} = '' if !$args{basename};
     1207  $args{rpcflag} = '' if !$args{rpcflag};
     1208##fixme  $args{basename} isn't doing what I think I thought I was trying to do.
     1209
     1210  my $deferr = '';      # place to put error from default config file in case we can't find either one
     1211
     1212  my $configroot = "/etc/dnsdb";        ##CFG_LEAF##
     1213  $configroot = '' if $args{basename} =~ m|^/|;
     1214  $args{basename} .= ".conf" if $args{basename} !~ /\.conf$/;
     1215  my $defconfig = "$configroot/dnsdb.conf";
     1216  my $siteconfig = "$configroot/$args{basename}";
     1217
     1218  # System defaults
     1219  __cfgload("$defconfig", $args{rpcflag}) or $deferr = $errstr;
     1220
     1221  # Per-site-ish settings.
     1222  if ($args{basename} ne '.conf') {
     1223    unless (__cfgload("$siteconfig"), $args{rpcflag}) {
     1224      $errstr = ($deferr ? "Error opening default config file $defconfig: $deferr\n" : '').
     1225        "Error opening site config file $siteconfig";
     1226      return;
     1227    }
     1228  }
     1229
     1230  # Munge log_failures.
     1231  if ($config{log_failures} ne '1' && $config{log_failures} ne '0') {
     1232    # true/false, on/off, yes/no all valid.
     1233    if ($config{log_failures} =~ /^(?:true|false|on|off|yes|no)$/) {
     1234      if ($config{log_failures} =~ /(?:true|on|yes)/) {
     1235        $config{log_failures} = 1;
     1236      } else {
     1237        $config{log_failures} = 0;
     1238      }
     1239    } else {
     1240      $errstr = "Bad log_failures setting $config{log_failures}";
     1241      $config{log_failures} = 1;
     1242      # Bad setting shouldn't be fatal.
     1243      # return 2;
     1244    }
     1245  }
     1246
     1247  # All good, clear the error and go home.
     1248  $errstr = '';
     1249  return 1;
     1250} # end loadConfig()
     1251
     1252
     1253## DNSDB::__cfgload()
     1254# Private sub to parse a config file and load it into %config
     1255# Takes a file handle on an open config file
     1256sub __cfgload {
     1257  $errstr = '';
     1258  my $cfgfile = shift;
     1259  my $rpcflag = shift;
     1260
     1261  if (open CFG, "<$cfgfile") {
     1262    while (<CFG>) {
     1263      chomp;
     1264      s/^\s*//;
     1265      next if /^#/;
     1266      next if /^$/;
     1267# hmm.  more complex bits in this file might require [heading] headers, maybe?
     1268#    $mode = $1 if /^\[(a-z)+]/;
     1269    # DB connect info
     1270      $config{dbname}   = $1 if /^dbname\s*=\s*([a-z0-9_.-]+)/i;
     1271      $config{dbuser}   = $1 if /^dbuser\s*=\s*([a-z0-9_.-]+)/i;
     1272      $config{dbpass}   = $1 if /^dbpass\s*=\s*([a-z0-9_.-]+)/i;
     1273      $config{dbhost}   = $1 if /^dbhost\s*=\s*([a-z0-9_.-]+)/i;
     1274      # SOA defaults
     1275      $def{contact}     = $1 if /^contact\s*=\s*([a-z0-9_.-]+)/i;
     1276      $def{prins}       = $1 if /^prins\s*=\s*([a-z0-9_.-]+)/i;
     1277      $def{soattl}      = $1 if /^soattl\s*=\s*(\d+)/i;
     1278      $def{refresh}     = $1 if /^refresh\s*=\s*(\d+)/i;
     1279      $def{retry}       = $1 if /^retry\s*=\s*(\d+)/i;
     1280      $def{expire}      = $1 if /^expire\s*=\s*(\d+)/i;
     1281      $def{minttl}      = $1 if /^minttl\s*=\s*(\d+)/i;
     1282      $def{ttl}         = $1 if /^ttl\s*=\s*(\d+)/i;
     1283      # Mail settings
     1284      $config{mailhost}         = $1 if /^mailhost\s*=\s*([a-z0-9_.-]+)/i;
     1285      $config{mailnotify}       = $1 if /^mailnotify\s*=\s*([a-z0-9_.\@-]+)/i;
     1286      $config{mailsender}       = $1 if /^mailsender\s*=\s*([a-z0-9_.\@-]+)/i;
     1287      $config{mailname}         = $1 if /^mailname\s*=\s*([a-z0-9\s_.-]+)/i;
     1288      $config{orgname}          = $1 if /^orgname\s*=\s*([a-z0-9\s_.,'-]+)/i;
     1289      $config{domain}           = $1 if /^domain\s*=\s*([a-z0-9_.-]+)/i;
     1290      # session - note this is fed directly to CGI::Session
     1291      $config{timeout}          = $1 if /^[tT][iI][mM][eE][oO][uU][tT]\s*=\s*(\d+[smhdwMy]?)/;
     1292      $config{sessiondir}       = $1 if m{^sessiondir\s*=\s*([a-z0-9/_.-]+)}i;
     1293      # misc
     1294      $config{log_failures}     = $1 if /^log_failures\s*=\s*([a-z01]+)/i;
     1295      $config{perpage}          = $1 if /^perpage\s*=\s*(\d+)/i;
     1296      $config{exportcache}      = $1 if m{^exportcache\s*=\s*([a-z0-9/_.-]+)}i;
     1297      # RPC options
     1298      if ($rpcflag && /^rpc/) {
     1299        if (my ($tmp) = /^rpc_iplist\s*=\s*(.+)/i) {
     1300          my @ips = split /[,\s]+/, $tmp;
     1301          my $rpcsys = shift @ips;
     1302          push @{$config{rpcacl}{$rpcsys}}, @ips;
     1303        }
     1304      }
     1305    }
     1306    close CFG;
     1307  } else {
     1308    $errstr = $!;
     1309    return;
     1310  }
     1311  return 1;
     1312} # end __cfgload()
     1313
     1314
     1315## DNSDB::connectDB()
     1316# Creates connection to DNS database.
     1317# Requires the database name, username, and password.
     1318# Returns a handle to the db.
     1319# Set up for a PostgreSQL db;  could be any transactional DBMS with the
     1320# right changes.
     1321sub connectDB {
     1322  $errstr = '';
     1323  my $dbname = shift;
     1324  my $user = shift;
     1325  my $pass = shift;
     1326  my $dbh;
     1327  my $DSN = "DBI:Pg:dbname=$dbname";
     1328
     1329  my $host = shift;
     1330  $DSN .= ";host=$host" if $host;
     1331
     1332# Note that we want to autocommit by default, and we will turn it off locally as necessary.
     1333# We may not want to print gobbledygook errors;  YMMV.  Have to ponder that further.
     1334  $dbh = DBI->connect($DSN, $user, $pass, {
     1335        AutoCommit => 1,
     1336        PrintError => 0
     1337        })
     1338    or return (undef, $DBI::errstr) if(!$dbh);
     1339
     1340##fixme:  initialize the DB if we can't find the table (since, by definition, there's
     1341# nothing there if we can't select from it...)
     1342  my $tblsth = $dbh->prepare("SELECT count(*) FROM pg_catalog.pg_class WHERE relkind='r' AND relname=?");
     1343  my ($tblcount) = $dbh->selectrow_array($tblsth, undef, ('misc'));
     1344  return (undef,$DBI::errstr) if $dbh->err;
     1345
     1346#if ($tblcount == 0) {
     1347#  # create tables one at a time, checking for each.
     1348#  return (undef, "check table misc missing");
     1349#}
     1350
     1351
     1352# Return here if we can't select.
     1353# This should retrieve the dbversion key.
     1354  my $sth = $dbh->prepare("SELECT key,value FROM misc WHERE misc_id=1");
     1355  $sth->execute();
     1356  return (undef,$DBI::errstr) if ($sth->err);
     1357
     1358##fixme:  do stuff to the DB on version mismatch
     1359# x.y series should upgrade on $DNSDB::VERSION > misc(key=>version)
     1360# DB should be downward-compatible;  column defaults should give sane (if possibly
     1361# useless-and-needs-help) values in columns an older software stack doesn't know about.
     1362
     1363# See if the select returned anything (or null data).  This should
     1364# succeed if the select executed, but...
     1365  $sth->fetchrow();
     1366  return (undef,$DBI::errstr)  if ($sth->err);
     1367
     1368  $sth->finish;
     1369
     1370# If we get here, we should be OK.
     1371  return ($dbh,"DB connection OK");
     1372} # end connectDB
     1373
     1374
     1375## DNSDB::finish()
     1376# Cleans up after database handles and so on.
     1377# Requires a database handle
     1378sub finish {
     1379  my $dbh = $_[0];
     1380  $dbh->disconnect;
     1381} # end finish
     1382
     1383
     1384## DNSDB::initGlobals()
     1385# Initialize global variables
     1386# NB: this does NOT include web-specific session variables!
     1387# Requires a database handle
     1388sub initGlobals {
     1389  my $dbh = shift;
     1390
     1391# load record types from database
     1392  my $sth = $dbh->prepare("SELECT val,name,stdflag FROM rectypes");
     1393  $sth->execute;
     1394  while (my ($recval,$recname,$stdflag) = $sth->fetchrow_array()) {
     1395    $typemap{$recval} = $recname;
     1396    $reverse_typemap{$recname} = $recval;
     1397    # now we fill the record validation function hash
     1398    if ($stdflag < 5) {
     1399      my $fn = "_validate_$recval";
     1400      $validators{$recval} = \&$fn;
     1401    } else {
     1402      my $fn = "sub { return ('FAIL','Type $recval ($recname) not supported'); }";
     1403      $validators{$recval} = eval $fn;
     1404    }
     1405  }
     1406} # end initGlobals
     1407
     1408
     1409## DNSDB::initRPC()
     1410# Takes a database handle, remote username, and remote fullname.
     1411# Sets up the RPC logging-pseudouser if needed.
     1412# Sets the %userdata hash for logging.
     1413# Returns undef on failure
     1414sub initRPC {
     1415  my $dbh = shift;
     1416  my %args  = @_;
     1417
     1418  return if !$args{username};
     1419  return if !$args{fullname};
     1420
     1421  $args{username} = "$args{username}/$args{rpcsys}";
     1422
     1423  my $tmpuser = $dbh->selectrow_hashref("SELECT username,user_id AS userid,group_id,firstname,lastname,status".
     1424        " FROM users WHERE username=?", undef, ($args{username}) );
     1425  if (!$tmpuser) {
     1426    $dbh->do("INSERT INTO users (username,password,firstname,type) VALUES (?,'RPC',?,'R')", undef,
     1427        ($args{username}, $args{fullname}) );
     1428    $tmpuser = $dbh->selectrow_hashref("SELECT username,user_id AS userid,group_id,firstname,lastname,status".
     1429        " FROM users WHERE username=?", undef, ($args{username}) );
     1430  }
     1431  %userdata = %{$tmpuser};
     1432  $userdata{lastname} = '' if !$userdata{lastname};
     1433  $userdata{fullname} = "$userdata{firstname} $userdata{lastname} ($args{rpcsys})";
     1434  return 1 if $tmpuser;
     1435} # end initRPC()
     1436
     1437
     1438## DNSDB::login()
     1439# Takes a database handle, username and password
     1440# Returns a userdata hash (UID, GID, username, fullname parts) if username exists,
     1441# password matches the one on file, and account is not disabled
     1442# Returns undef otherwise
     1443sub login {
     1444  my $dbh = shift;
     1445  my $user = shift;
     1446  my $pass = shift;
     1447
     1448  my $userinfo = $dbh->selectrow_hashref("SELECT user_id,group_id,password,firstname,lastname,status".
     1449        " FROM users WHERE username=?",
     1450        undef, ($user) );
     1451  return if !$userinfo;
     1452  return if !$userinfo->{status};
     1453
     1454  if ($userinfo->{password} =~ m|^\$1\$([A-Za-z0-9/.]+)\$|) {
     1455    # native passwords (crypt-md5)
     1456    return if $userinfo->{password} ne unix_md5_crypt($pass,$1);
     1457  } elsif ($userinfo->{password} =~ /^[0-9a-f]{32}$/) {
     1458    # VegaDNS import (hex-coded MD5)
     1459    return if $userinfo->{password} ne md5_hex($pass);
     1460  } else {
     1461    # plaintext (convenient now and then)
     1462    return if $userinfo->{password} ne $pass;
     1463  }
     1464
     1465  return $userinfo;
     1466} # end login()
     1467
     1468
     1469## DNSDB::initActionLog()
     1470# Set up action logging.  Takes a database handle and user ID
     1471# Sets some internal globals and Does The Right Thing to set up a logging channel.
     1472# This sets up _log() to spew out log entries to the defined channel without worrying
     1473# about having to open a file or a syslog channel
     1474##fixme Need to call _initActionLog_blah() for various logging channels, configured
     1475# via dnsdb.conf, in $config{log_channel} or something
     1476# See https://secure.deepnet.cx/trac/dnsadmin/ticket/21
     1477sub initActionLog {
     1478  my $dbh = shift;
     1479  my $uid = shift;
     1480
     1481  return if !$uid;
     1482
     1483  # snag user info for logging.  there's got to be a way to not have to pass this back
     1484  # and forth from a caller, but web usage means no persistence we can rely on from
     1485  # the server side.
     1486  my ($username,$fullname) = $dbh->selectrow_array("SELECT username, firstname || ' ' || lastname".
     1487        " FROM users WHERE user_id=?", undef, ($uid));
     1488##fixme: errors are unpossible!
     1489
     1490  $userdata{username} = $username;
     1491  $userdata{userid} = $uid;
     1492  $userdata{fullname} = $fullname;
     1493
     1494  # convert to real check once we have other logging channels
     1495  # if ($config{log_channel} eq 'sql') {
     1496  #   Open Log, Sez Me!
     1497  # }
     1498
     1499} # end initActionLog
     1500
     1501
     1502## DNSDB::initPermissions()
     1503# Set up permissions global
     1504# Takes database handle and UID
     1505sub initPermissions {
     1506  my $dbh = shift;
     1507  my $uid = shift;
     1508
     1509#  %permissions = $(getPermissions($dbh,'user',$uid));
     1510  getPermissions($dbh, 'user', $uid, \%permissions);
     1511
     1512} # end initPermissions()
     1513
     1514
     1515## DNSDB::getPermissions()
     1516# Get permissions from DB
     1517# Requires DB handle, group or user flag, ID, and hashref.
     1518sub getPermissions {
     1519  my $dbh = shift;
     1520  my $type = shift;
     1521  my $id = shift;
     1522  my $hash = shift;
     1523
     1524  my $sql = qq(
     1525        SELECT
     1526        p.admin,p.self_edit,
     1527        p.group_create,p.group_edit,p.group_delete,
     1528        p.user_create,p.user_edit,p.user_delete,
     1529        p.domain_create,p.domain_edit,p.domain_delete,
     1530        p.record_create,p.record_edit,p.record_delete,p.record_locchg,
     1531        p.location_create,p.location_edit,p.location_delete,p.location_view
     1532        FROM permissions p
     1533        );
     1534  if ($type eq 'group') {
     1535    $sql .= qq(
     1536        JOIN groups g ON g.permission_id=p.permission_id
     1537        WHERE g.group_id=?
     1538        );
     1539  } else {
     1540    $sql .= qq(
     1541        JOIN users u ON u.permission_id=p.permission_id
     1542        WHERE u.user_id=?
     1543        );
     1544  }
     1545
     1546  my $sth = $dbh->prepare($sql);
     1547
     1548  $sth->execute($id) or die "argh: ".$sth->errstr;
     1549
     1550#  my $permref = $sth->fetchrow_hashref;
     1551#  return $permref;
     1552#  $hash = $permref;
     1553# Eww.  Need to learn how to forcibly drop a hashref onto an existing hash.
     1554  ($hash->{admin},$hash->{self_edit},
     1555        $hash->{group_create},$hash->{group_edit},$hash->{group_delete},
     1556        $hash->{user_create},$hash->{user_edit},$hash->{user_delete},
     1557        $hash->{domain_create},$hash->{domain_edit},$hash->{domain_delete},
     1558        $hash->{record_create},$hash->{record_edit},$hash->{record_delete},$hash->{record_locchg},
     1559        $hash->{location_create},$hash->{location_edit},$hash->{location_delete},$hash->{location_view}
     1560        ) = $sth->fetchrow_array;
     1561
     1562} # end getPermissions()
     1563
     1564
     1565## DNSDB::changePermissions()
     1566# Update an ACL entry
     1567# Takes a db handle, type, owner-id, and hashref for the changed permissions.
     1568sub changePermissions {
     1569  my $dbh = shift;
     1570  my $type = shift;
     1571  my $id = shift;
     1572  my $newperms = shift;
     1573  my $inherit = shift || 0;
     1574
     1575  my $resultmsg = '';
     1576
     1577  # see if we're switching from inherited to custom.  for bonus points,
     1578  # snag the permid and parent permid anyway, since we'll need the permid
     1579  # to set/alter custom perms, and both if we're switching from custom to
     1580  # inherited.
     1581  my $sth = $dbh->prepare("SELECT (u.permission_id=g.permission_id) AS was_inherited,u.permission_id,g.permission_id,".
     1582        ($type eq 'user' ? 'u.group_id,u.username' : 'u.parent_group_id,u.group_name').
     1583        " FROM ".($type eq 'user' ? 'users' : 'groups')." u ".
     1584        " JOIN groups g ON u.".($type eq 'user' ? '' : 'parent_')."group_id=g.group_id ".
     1585        " WHERE u.".($type eq 'user' ? 'user' : 'group')."_id=?");
     1586  $sth->execute($id);
     1587
     1588  my ($wasinherited,$permid,$parpermid,$parid,$name) = $sth->fetchrow_array;
     1589
     1590# hack phtoui
     1591# group id 1 is "special" in that it's it's own parent (err...  possibly.)
     1592# may make its parent id 0 which doesn't exist, and as a bonus is Perl-false.
     1593  $wasinherited = 0 if ($type eq 'group' && $id == 1);
     1594
     1595  local $dbh->{AutoCommit} = 0;
     1596  local $dbh->{RaiseError} = 1;
     1597
     1598  # Wrap all the SQL in a transaction
     1599  eval {
     1600    if ($inherit) {
     1601
     1602      $dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='t',permission_id=? ".
     1603        "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($parpermid, $id) );
     1604      $dbh->do("DELETE FROM permissions WHERE permission_id=?", undef, ($permid) );
     1605
     1606    } else {
     1607
     1608      if ($wasinherited) {      # munge new permission entry in if we're switching from inherited perms
     1609##fixme: need to add semirecursive bit to properly munge inherited permission ID on subgroups and users
     1610# ... if'n'when we have groups with fully inherited permissions.
     1611        # SQL is coo
     1612        $dbh->do("INSERT INTO permissions ($permlist,".($type eq 'user' ? 'user' : 'group')."_id) ".
     1613                "SELECT $permlist,? FROM permissions WHERE permission_id=?", undef, ($id,$permid) );
     1614        ($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions ".
     1615                "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($id) );
     1616        $dbh->do("UPDATE ".($type eq 'user' ? 'users' : 'groups')." SET inherit_perm='f',permission_id=? ".
     1617                "WHERE ".($type eq 'user' ? 'user' : 'group')."_id=?", undef, ($permid, $id) );
     1618      }
     1619
     1620      # and now set the permissions we were passed
     1621      foreach (@permtypes) {
     1622        if (defined ($newperms->{$_})) {
     1623          $dbh->do("UPDATE permissions SET $_=? WHERE permission_id=?", undef, ($newperms->{$_},$permid) );
     1624        }
     1625      }
     1626
     1627    } # (inherited->)? custom
     1628
     1629    if ($type eq 'user') {
     1630      $resultmsg = "Updated permissions for user $name";
     1631    } else {
     1632      $resultmsg = "Updated default permissions for group $name";
     1633    }
     1634    _log($dbh, (group_id => ($type eq 'user' ? $parid : $id), entry => $resultmsg));
     1635    $dbh->commit;
     1636  }; # end eval
     1637  if ($@) {
     1638    my $msg = $@;
     1639    eval { $dbh->rollback; };
     1640    return ('FAIL',"Error changing permissions: $msg");
     1641  }
     1642
     1643  return ('OK',$resultmsg);
     1644} # end changePermissions()
     1645
     1646
     1647## DNSDB::comparePermissions()
     1648# Compare two permission hashes
     1649# Returns '>', '<', '=', '!'
     1650sub comparePermissions {
     1651  my $p1 = shift;
     1652  my $p2 = shift;
     1653
     1654  my $retval = '=';     # assume equality until proven otherwise
     1655
     1656  no warnings "uninitialized";
     1657
     1658  foreach (@permtypes) {
     1659    next if $p1->{$_} == $p2->{$_};     # equal is good
     1660    if ($p1->{$_} && !$p2->{$_}) {
     1661      if ($retval eq '<') {     # if we've already found an unequal pair where
     1662        $retval = '!';          # $p2 has more access, and we now find a pair
     1663        last;                   # where $p1 has more access, the overall access
     1664      }                         # is neither greater or lesser, it's unequal.
     1665      $retval = '>';
     1666    }
     1667    if (!$p1->{$_} && $p2->{$_}) {
     1668      if ($retval eq '>') {     # if we've already found an unequal pair where
     1669        $retval = '!';          # $p1 has more access, and we now find a pair
     1670        last;                   # where $p2 has more access, the overall access
     1671      }                         # is neither greater or lesser, it's unequal.
     1672      $retval = '<';
     1673    }
     1674  }
     1675  return $retval;
     1676} # end comparePermissions()
     1677
     1678
     1679## DNSDB::changeGroup()
     1680# Change group ID of an entity
     1681# Takes a database handle, entity type, entity ID, and new group ID
     1682sub changeGroup {
     1683  my $dbh = shift;
     1684  my $type = shift;
     1685  my $id = shift;
     1686  my $newgrp = shift;
     1687
     1688##fixme:  fail on not enough args
     1689  #return ('FAIL', "Missing
     1690
     1691  return ('FAIL', "Can't change the group of a $type")
     1692        unless grep /^$type$/, ('domain','revzone','user','group');     # could be extended for defrecs?
     1693
     1694  # Collect some names for logging and messages
     1695  my $entname;
     1696  if ($type eq 'domain') {
     1697    $entname = domainName($dbh, $id);
     1698  } elsif ($type eq 'revzone') {
     1699    $entname = revName($dbh, $id);
     1700  } elsif ($type eq 'user') {
     1701    $entname = userFullName($dbh, $id, '%u');
     1702  } elsif ($type eq 'group') {
     1703    $entname = groupName($dbh, $id);
     1704  }
     1705
     1706  my ($oldgid) = $dbh->selectrow_array("SELECT group_id FROM $par_tbl{$type} WHERE $id_col{$type}=?",
     1707        undef, ($id));
     1708  my $oldgname = groupName($dbh, $oldgid);
     1709  my $newgname = groupName($dbh, $newgrp);
     1710
     1711  return ('FAIL', "Can't move things into a group that doesn't exist") if !$newgname;
     1712
     1713  return ('WARN', "Nothing to do, new group is the same as the old group") if $oldgid == $newgrp;
     1714
     1715  # Allow transactions, and raise an exception on errors so we can catch it later.
     1716  # Use local to make sure these get "reset" properly on exiting this block
     1717  local $dbh->{AutoCommit} = 0;
     1718  local $dbh->{RaiseError} = 1;
     1719
     1720  eval {
     1721    $dbh->do("UPDATE $par_tbl{$type} SET group_id=? WHERE $id_col{$type}=?", undef, ($newgrp, $id));
     1722    # Log the change in both the old and new groups
     1723    _log($dbh, (group_id => $oldgid, entry => "Moved $type $entname from $oldgname to $newgname"));
     1724    _log($dbh, (group_id => $newgrp, entry => "Moved $type $entname from $oldgname to $newgname"));
     1725    $dbh->commit;
     1726  };
     1727  if ($@) {
     1728    my $msg = $@;
     1729    eval { $dbh->rollback; };
     1730    if ($config{log_failures}) {
     1731      _log($dbh, (group_id => $oldgid, entry => "Error moving $type $entname to $newgname: $msg"));
     1732      $dbh->commit;     # since we enabled transactions earlier
     1733    }
     1734    return ('FAIL',"Error moving $type $entname to $newgname: $msg");
     1735  }
     1736
     1737  return ('OK',"Moved $type $entname from $oldgname to $newgname");
     1738} # end changeGroup()
     1739
     1740
     1741##
     1742## Processing subs
     1743##
     1744
     1745## DNSDB::addDomain()
     1746# Add a domain
     1747# Takes a database handle, domain name, numeric group, boolean(ish) state (active/inactive),
     1748# and user info hash (for logging).
     1749# Returns a status code and message
     1750sub addDomain {
     1751  $errstr = '';
     1752  my $dbh = shift;
     1753  return ('FAIL',"Need database handle") if !$dbh;
     1754  my $domain = shift;
     1755  return ('FAIL',"Domain must not be blank") if !$domain;
     1756  my $group = shift;
     1757  return ('FAIL',"Need group") if !defined($group);
     1758  my $state = shift;
     1759  return ('FAIL',"Need domain status") if !defined($state);
     1760
     1761  $state = 1 if $state =~ /^active$/;
     1762  $state = 1 if $state =~ /^on$/;
     1763  $state = 0 if $state =~ /^inactive$/;
     1764  $state = 0 if $state =~ /^off$/;
     1765
     1766  return ('FAIL',"Invalid domain status") if $state !~ /^\d+$/;
     1767
     1768  return ('FAIL', "Invalid characters in domain") if $domain !~ /^[a-zA-Z0-9_.-]+$/;
     1769
     1770  my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)");
     1771  my $dom_id;
     1772
     1773# quick check to start to see if we've already got one
     1774  $sth->execute($domain);
     1775  ($dom_id) = $sth->fetchrow_array;
     1776
     1777  return ('FAIL', "Domain already exists") if $dom_id;
     1778
     1779  # Allow transactions, and raise an exception on errors so we can catch it later.
     1780  # Use local to make sure these get "reset" properly on exiting this block
     1781  local $dbh->{AutoCommit} = 0;
     1782  local $dbh->{RaiseError} = 1;
     1783
     1784  # Wrap all the SQL in a transaction
     1785  eval {
     1786    # insert the domain...
     1787    $dbh->do("INSERT INTO domains (domain,group_id,status) VALUES (?,?,?)", undef, ($domain, $group, $state));
     1788
     1789    # get the ID...
     1790    ($dom_id) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)",
     1791        undef, ($domain));
     1792
     1793    _log($dbh, (domain_id => $dom_id, group_id => $group,
     1794        entry => "Added ".($state ? 'active' : 'inactive')." domain $domain"));
     1795
     1796    # ... and now we construct the standard records from the default set.  NB:  group should be variable.
     1797    my $sth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?");
     1798    my $sth_in = $dbh->prepare("INSERT INTO records (domain_id,host,type,val,distance,weight,port,ttl)".
     1799        " VALUES ($dom_id,?,?,?,?,?,?,?)");
     1800    $sth->execute($group);
     1801    while (my ($host,$type,$val,$dist,$weight,$port,$ttl) = $sth->fetchrow_array()) {
     1802      $host =~ s/DOMAIN/$domain/g;
     1803      $val =~ s/DOMAIN/$domain/g;
     1804      $sth_in->execute($host,$type,$val,$dist,$weight,$port,$ttl);
     1805      if ($typemap{$type} eq 'SOA') {
     1806        my @tmp1 = split /:/, $host;
     1807        my @tmp2 = split /:/, $val;
     1808        _log($dbh, (domain_id => $dom_id, group_id => $group,
     1809                entry => "[new $domain] Added SOA record [contact $tmp1[0]] [master $tmp1[1]] ".
     1810                "[refresh $tmp2[0]] [retry $tmp2[1]] [expire $tmp2[2]] [minttl $tmp2[3]], TTL $ttl"));
     1811      } else {
     1812        my $logentry = "[new $domain] Added record '$host $typemap{$type}";
     1813        $logentry .= " [distance $dist]" if $typemap{$type} eq 'MX';
     1814        $logentry .= " [priority $dist] [weight $weight] [port $port]" if $typemap{$type} eq 'SRV';
     1815        _log($dbh, (domain_id => $dom_id, group_id => $group,
     1816                entry => $logentry." $val', TTL $ttl"));
     1817      }
     1818    }
     1819
     1820    # once we get here, we should have suceeded.
     1821    $dbh->commit;
     1822  }; # end eval
     1823
     1824  if ($@) {
     1825    my $msg = $@;
     1826    eval { $dbh->rollback; };
     1827    _log($dbh, (group_id => $group, entry => "Failed adding domain $domain ($msg)"))
     1828        if $config{log_failures};
     1829    $dbh->commit;       # since we enabled transactions earlier
     1830    return ('FAIL',$msg);
     1831  } else {
     1832    return ('OK',$dom_id);
     1833  }
     1834} # end addDomain
     1835
     1836
     1837## DNSDB::delZone()
     1838# Delete a forward or reverse zone.
     1839# Takes a database handle, zone ID, and forward/reverse flag.
     1840# for now, just delete the records, then the domain.
     1841# later we may want to archive it in some way instead (status code 2, for example?)
     1842sub delZone {
     1843  my $dbh = shift;
     1844  my $zoneid = shift;
     1845  my $revrec = shift;
     1846
     1847  # Allow transactions, and raise an exception on errors so we can catch it later.
     1848  # Use local to make sure these get "reset" properly on exiting this block
     1849  local $dbh->{AutoCommit} = 0;
     1850  local $dbh->{RaiseError} = 1;
     1851
     1852  my $msg = '';
     1853  my $failmsg = '';
     1854  my $zone = ($revrec eq 'n' ? domainName($dbh, $zoneid) : revName($dbh, $zoneid));
     1855
     1856  return ('FAIL', ($revrec eq 'n' ? 'Domain' : 'Reverse zone')." ID $zoneid doesn't exist") if !$zone;
     1857
     1858  # Set this up here since we may use if if $config{log_failures} is enabled
     1859  my %loghash;
     1860  $loghash{domain_id} = $zoneid if $revrec eq 'n';
     1861  $loghash{rdns_id} = $zoneid if $revrec eq 'y';
     1862  $loghash{group_id} = parentID($dbh,
     1863        (id => $zoneid, type => ($revrec eq 'n' ? 'domain' : 'revzone'), revrec => $revrec) );
     1864
     1865  # Wrap all the SQL in a transaction
     1866  eval {
     1867    # Disentangle custom record types before removing the
     1868    # ones that are only in the zone to be deleted
     1869    if ($revrec eq 'n') {
     1870      my $sth = $dbh->prepare("UPDATE records SET type=?,domain_id=0 WHERE domain_id=? AND type=?");
     1871      $failmsg = "Failure converting multizone types to single-zone";
     1872      $sth->execute($reverse_typemap{PTR}, $zoneid, 65280);
     1873      $sth->execute($reverse_typemap{PTR}, $zoneid, 65281);
     1874      $sth->execute(65282, $zoneid, 65283);
     1875      $sth->execute(65282, $zoneid, 65284);
     1876      $failmsg = "Failure removing domain records";
     1877      $dbh->do("DELETE FROM records WHERE domain_id=?", undef, ($zoneid));
     1878      $failmsg = "Failure removing domain";
     1879      $dbh->do("DELETE FROM domains WHERE domain_id=?", undef, ($zoneid));
     1880    } else {
     1881      my $sth = $dbh->prepare("UPDATE records SET type=?,rdns_id=0 WHERE rdns_id=? AND type=?");
     1882      $failmsg = "Failure converting multizone types to single-zone";
     1883      $sth->execute($reverse_typemap{A}, $zoneid, 65280);
     1884      $sth->execute($reverse_typemap{AAAA}, $zoneid, 65281);
     1885# We don't have an "A template" or "AAAA template" type, although it might be useful for symmetry.
     1886#      $sth->execute(65286?, $zoneid, 65283);
     1887#      $sth->execute(65286?, $zoneid, 65284);
     1888      $failmsg = "Failure removing reverse records";
     1889      $dbh->do("DELETE FROM records WHERE rdns_id=?", undef, ($zoneid));
     1890      $failmsg = "Failure removing reverse zone";
     1891      $dbh->do("DELETE FROM revzones WHERE rdns_id=?", undef, ($zoneid));
     1892    }
     1893
     1894    $msg = "Deleted ".($revrec eq 'n' ? 'domain' : 'reverse zone')." $zone";
     1895    $loghash{entry} = $msg;
     1896    _log($dbh, %loghash);
     1897
     1898    # once we get here, we should have suceeded.
     1899    $dbh->commit;
     1900  }; # end eval
     1901
     1902  if ($@) {
     1903    $msg = $@;
     1904    eval { $dbh->rollback; };
     1905    $loghash{entry} = "Error deleting $zone: $msg ($failmsg)";
     1906    if ($config{log_failures}) {
     1907      _log($dbh, %loghash);
     1908      $dbh->commit;     # since we enabled transactions earlier
     1909    }
     1910    return ('FAIL', $loghash{entry});
     1911  } else {
     1912    return ('OK', $msg);
     1913  }
     1914
     1915} # end delZone()
     1916
     1917
     1918## DNSDB::domainName()
     1919# Return the domain name based on a domain ID
     1920# Takes a database handle and the domain ID
     1921# Returns the domain name or undef on failure
     1922sub domainName {
     1923  $errstr = '';
     1924  my $dbh = shift;
     1925  my $domid = shift;
     1926  my ($domname) = $dbh->selectrow_array("SELECT domain FROM domains WHERE domain_id=?", undef, ($domid) );
     1927  $errstr = $DBI::errstr if !$domname;
     1928  return $domname if $domname;
     1929} # end domainName()
     1930
     1931
     1932## DNSDB::revName()
     1933# Return the reverse zone name based on an rDNS ID
     1934# Takes a database handle and the rDNS ID
     1935# Returns the reverse zone name or undef on failure
     1936sub revName {
     1937  $errstr = '';
     1938  my $dbh = shift;
     1939  my $revid = shift;
     1940  my ($revname) = $dbh->selectrow_array("SELECT revnet FROM revzones WHERE rdns_id=?", undef, ($revid) );
     1941  $errstr = $DBI::errstr if !$revname;
     1942  return $revname if $revname;
     1943} # end revName()
     1944
     1945
     1946## DNSDB::domainID()
     1947# Takes a database handle and domain name
     1948# Returns the domain ID number
     1949sub domainID {
     1950  $errstr = '';
     1951  my $dbh = shift;
     1952  my $domain = shift;
     1953  my ($domid) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)",
     1954        undef, ($domain) );
     1955  $errstr = $DBI::errstr if !$domid;
     1956  return $domid if $domid;
     1957} # end domainID()
     1958
     1959
     1960## DNSDB::revID()
     1961# Takes a database handle and reverse zone name
     1962# Returns the rDNS ID number
     1963sub revID {
     1964  $errstr = '';
     1965  my $dbh = shift;
     1966  my $revzone = shift;
     1967  my ($revid) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet=?", undef, ($revzone) );
     1968  $errstr = $DBI::errstr if !$revid;
     1969  return $revid if $revid;
     1970} # end revID()
     1971
     1972
     1973## DNSDB::addRDNS
     1974# Adds a reverse DNS zone
     1975# Takes a database handle, CIDR block, reverse DNS pattern, numeric group,
     1976# and boolean(ish) state (active/inactive)
     1977# Returns a status code and message
     1978sub addRDNS {
     1979  my $dbh = shift;
     1980  my $zone = NetAddr::IP->new(shift);
     1981  return ('FAIL',"Zone name must be a valid CIDR netblock") unless ($zone && $zone->addr !~ /^0/);
     1982  my $revpatt = shift;  # construct a custom (A/AAAA+)? PTR template record
     1983  my $group = shift;
     1984  my $state = shift;
     1985
     1986  $state = 1 if $state =~ /^active$/;
     1987  $state = 1 if $state =~ /^on$/;
     1988  $state = 0 if $state =~ /^inactive$/;
     1989  $state = 0 if $state =~ /^off$/;
     1990
     1991  return ('FAIL',"Invalid zone status") if $state !~ /^\d+$/;
     1992
     1993# quick check to start to see if we've already got one
     1994  my ($rdns_id) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet=?", undef, ("$zone"));
     1995
     1996  return ('FAIL', "Zone already exists") if $rdns_id;
     1997
     1998  # Allow transactions, and raise an exception on errors so we can catch it later.
     1999  # Use local to make sure these get "reset" properly on exiting this block
     2000  local $dbh->{AutoCommit} = 0;
     2001  local $dbh->{RaiseError} = 1;
     2002
     2003  my $warnstr = '';
     2004  my $defttl = 3600;    # 1 hour should be reasonable.  And unless things have gone horribly
     2005                        # wrong, we should have a value to override this anyway.
     2006
     2007  # Wrap all the SQL in a transaction
     2008  eval {
     2009    # insert the domain...
     2010    $dbh->do("INSERT INTO revzones (revnet,group_id,status) VALUES (?,?,?)", undef, ($zone, $group, $state));
     2011
     2012    # get the ID...
     2013    ($rdns_id) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')");
     2014
     2015    _log($dbh, (rdns_id => $rdns_id, group_id => $group,
     2016        entry => "Added ".($state ? 'active' : 'inactive')." reverse zone $zone"));
     2017
     2018    # ... and now we construct the standard records from the default set.  NB:  group should be variable.
     2019    my $sth = $dbh->prepare("SELECT host,type,val,ttl FROM default_rev_records WHERE group_id=?");
     2020    my $sth_in = $dbh->prepare("INSERT INTO records (rdns_id,domain_id,host,type,val,ttl)".
     2021        " VALUES ($rdns_id,?,?,?,?,?)");
     2022    $sth->execute($group);
     2023    while (my ($host,$type,$val,$ttl) = $sth->fetchrow_array()) {
     2024      # Silently skip v4/v6 mismatches.  This is not an error, this is expected.
     2025      if ($zone->{isv6}) {
     2026        next if ($type == 65280 || $type == 65283);
     2027      } else {
     2028        next if ($type == 65281 || $type == 65284);
     2029      }
     2030
     2031      $host =~ s/ADMINDOMAIN/$config{domain}/g;
     2032
     2033      # Check to make sure the IP stubs will fit in the zone.  Under most usage failures here should be rare.
     2034      # On failure, tack a note on to a warning string and continue without adding this record.
     2035      # While we're at it, we substitute $zone for ZONE in the value.
     2036      if ($val eq 'ZONE') {
     2037        next if $revpatt;       # If we've got a pattern, we skip the default record version.
     2038##fixme?  do we care if we have multiple whole-zone templates?
     2039        $val = $zone->network;
     2040      } elsif ($val =~ /ZONE/) {
     2041        my $tmpval = $val;
     2042        $tmpval =~ s/ZONE//;
     2043        # Bend the rules and allow single-trailing-number PTR or PTR template records to be inserted
     2044        # as either v4 or v6.  May make this an off-by-default config flag
     2045        # Note that the origin records that may trigger this **SHOULD** already have ZONE,\d
     2046        if ($type == 12 || $type == 65282) {
     2047          $tmpval =~ s/[,.]/::/ if ($tmpval =~ /^[,.]\d+$/ && $zone->{isv6});
     2048          $tmpval =~ s/[,:]+/./ if ($tmpval =~ /^(?:,|::)\d+$/ && !$zone->{isv6});
     2049        }
     2050        my $addr;
     2051        if (_ipparent($dbh, 'n', 'y', \$tmpval, $rdns_id, \$addr)) {
     2052          $val = $addr->addr;
     2053        } else {
     2054          $warnstr .= "\nDefault record '$val $typemap{$type} $host' doesn't fit in $zone, skipping";
     2055          next;
     2056        }
     2057      }
     2058
     2059      # Substitute $zone for ZONE in the hostname, but only for non-NS records.
     2060      # NS records get this substitution on the value instead.
     2061      $host = _ZONE($zone, $host) if $type != 2;
     2062
     2063      # Fill in the forward domain ID if we can find it, otherwise:
     2064      # Coerce type down to PTR or PTR template if we can't
     2065      my $domid = 0;
     2066      if ($type >= 65280) {
     2067        if (!($domid = _hostparent($dbh, $host))) {
     2068          $warnstr .= "\nRecord added as PTR instead of $typemap{$type};  domain not found for $host";
     2069          $type = $reverse_typemap{PTR};
     2070          $domid = 0;   # just to be explicit.
     2071        }
     2072      }
     2073
     2074      $sth_in->execute($domid,$host,$type,$val,$ttl);
     2075
     2076      if ($typemap{$type} eq 'SOA') {
     2077        my @tmp1 = split /:/, $host;
     2078        my @tmp2 = split /:/, $val;
     2079        _log($dbh, (rdns_id => $rdns_id, group_id => $group,
     2080                entry => "[new $zone] Added SOA record [contact $tmp1[0]] [master $tmp1[1]] ".
     2081                "[refresh $tmp2[0]] [retry $tmp2[1]] [expire $tmp2[2]] [minttl $tmp2[3]], TTL $ttl"));
     2082        $defttl = $tmp2[3];
     2083      } else {
     2084        my $logentry = "[new $zone] Added record '$host $typemap{$type}";
     2085        _log($dbh, (rdns_id => $rdns_id, domain_id => $domid, group_id => $group,
     2086                entry => $logentry." $val', TTL $ttl"));
     2087      }
     2088    }
     2089
     2090    # Generate record based on provided pattern. 
     2091    if ($revpatt) {
     2092      my $host;
     2093      my $type = ($zone->{isv6} ? 65284 : 65283);
     2094      my $val = $zone->network;
     2095
     2096      # Substitute $zone for ZONE in the hostname.
     2097      $host = _ZONE($zone, $revpatt);
     2098
     2099      my $domid = 0;
     2100      if (!($domid = _hostparent($dbh, $host))) {
     2101        $warnstr .= "\nDefault pattern added as PTR template instead of $typemap{$type};  domain not found for $host";
     2102        $type = 65282;
     2103        $domid = 0;     # just to be explicit.
     2104      }
     2105
     2106      $sth_in->execute($domid,$host,$type,$val,$defttl);
     2107      my $logentry = "[new $zone] Added record '$host $typemap{$type}";
     2108      _log($dbh, (rdns_id => $rdns_id, domain_id => $domid, group_id => $group,
     2109        entry => $logentry." $val', TTL $defttl from pattern"));
     2110    }
     2111
     2112    # If there are warnings (presumably about default records skipped for cause) log them
     2113    _log($dbh, (rdns_id => $rdns_id, group_id => $group, entry => "Warning(s) adding $zone:$warnstr"))
     2114        if $warnstr;
     2115
     2116    # once we get here, we should have suceeded.
     2117    $dbh->commit;
     2118  }; # end eval
     2119
     2120  if ($@) {
     2121    my $msg = $@;
     2122    eval { $dbh->rollback; };
     2123    _log($dbh, (group_id => $group, entry => "Failed adding reverse zone $zone ($msg)"))
     2124        if $config{log_failures};
     2125    $dbh->commit;       # since we enabled transactions earlier
     2126    return ('FAIL',$msg);
     2127  } else {
     2128    my $retcode = 'OK';
     2129    if ($warnstr) {
     2130      $resultstr = $warnstr;
     2131      $retcode = 'WARN';
     2132    }
     2133    return ($retcode, $rdns_id);
     2134  }
     2135
     2136} # end addRDNS()
     2137
     2138
     2139## DNSDB::getZoneCount
     2140# Get count of zones in group or groups
     2141# Takes a database handle and hash containing:
     2142#  - the "current" group
     2143#  - an array of "acceptable" groups
     2144#  - a flag for forward/reverse zones
     2145#  - Optionally accept a "starts with" and/or "contains" filter argument
     2146# Returns an integer count of the resulting zone list.
     2147sub getZoneCount {
     2148  my $dbh = shift;
     2149
     2150  my %args = @_;
     2151
     2152  my @filterargs;
     2153  $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
     2154  push @filterargs, "^$args{startwith}" if $args{startwith};
     2155  $args{filter} =~ s/\./\[\.\]/g if $args{filter};      # only match literal dots, usually in reverse zones
     2156  push @filterargs, $args{filter} if $args{filter};
     2157
     2158  my $sql;
     2159  # Not as compact, and fix-me-twice if the common bits get wrong, but much easier to read
     2160  if ($args{revrec} eq 'n') {
     2161    $sql = "SELECT count(*) FROM domains".
     2162        " WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
     2163        ($args{startwith} ? " AND domain ~* ?" : '').
     2164        ($args{filter} ? " AND domain ~* ?" : '');
     2165  } else {
     2166    $sql = "SELECT count(*) FROM revzones".
     2167        " WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
     2168        ($args{startwith} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '').
     2169        ($args{filter} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '');
     2170  }
     2171  my ($count) = $dbh->selectrow_array($sql, undef, @filterargs);
     2172  return $count;
     2173} # end getZoneCount()
     2174
     2175
     2176## DNSDB::getZoneList()
     2177# Get a list of zones in the specified group(s)
     2178# Takes the same arguments as getZoneCount() above
     2179# Returns a reference to an array of hashrefs suitable for feeding to HTML::Template
     2180sub getZoneList {
     2181  my $dbh = shift;
     2182
     2183  my %args = @_;
     2184
     2185  my @zonelist;
     2186
     2187  $args{sortorder} = 'ASC' if !grep /^$args{sortorder}$/, ('ASC','DESC');
     2188  $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/;
     2189
     2190  my @filterargs;
     2191  $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
     2192  push @filterargs, "^$args{startwith}" if $args{startwith};
     2193  $args{filter} =~ s/\./\[\.\]/g if $args{filter};      # only match literal dots, usually in reverse zones
     2194  push @filterargs, $args{filter} if $args{filter};
     2195
     2196  my $sql;
     2197  # Not as compact, and fix-me-twice if the common bits get wrong, but much easier to read
     2198  if ($args{revrec} eq 'n') {
     2199    $args{sortby} = 'domain' if !grep /^$args{sortby}$/, ('domain','group','status');
     2200    $sql = "SELECT domain_id,domain,status,groups.group_name AS group FROM domains".
     2201        " INNER JOIN groups ON domains.group_id=groups.group_id".
     2202        " WHERE domains.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
     2203        ($args{startwith} ? " AND domain ~* ?" : '').
     2204        ($args{filter} ? " AND domain ~* ?" : '');
     2205  } else {
     2206##fixme:  arguably startwith here is irrelevant.  depends on the UI though.
     2207    $args{sortby} = 'revnet' if !grep /^$args{sortby}$/, ('revnet','group','status');
     2208    $sql = "SELECT rdns_id,revnet,status,groups.group_name AS group FROM revzones".
     2209        " INNER JOIN groups ON revzones.group_id=groups.group_id".
     2210        " WHERE revzones.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
     2211        ($args{startwith} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '').
     2212        ($args{filter} ? " AND CAST(revnet AS VARCHAR) ~* ?" : '');
     2213  }
     2214  # A common tail.
     2215  $sql .= " ORDER BY ".($args{sortby} eq 'group' ? 'groups.group_name' : $args{sortby})." $args{sortorder} ".
     2216        ($args{offset} eq 'all' ? '' : " LIMIT $config{perpage}".
     2217        " OFFSET ".$args{offset}*$config{perpage});
     2218  my $sth = $dbh->prepare($sql);
     2219  $sth->execute(@filterargs);
     2220  my $rownum = 0;
     2221
     2222  while (my @data = $sth->fetchrow_array) {
     2223    my %row;
     2224    $row{domain_id} = $data[0];
     2225    $row{domain} = $data[1];
     2226    $row{status} = $data[2];
     2227    $row{group} = $data[3];
     2228    push @zonelist, \%row;
     2229  }
     2230
     2231  return \@zonelist;
     2232} # end getZoneList()
     2233
     2234
     2235## DNSDB::getZoneLocation()
     2236# Retrieve the default location for a zone.
     2237# Takes a database handle, forward/reverse flag, and zone ID
     2238sub getZoneLocation {
     2239  my $dbh = shift;
     2240  my $revrec = shift;
     2241  my $zoneid = shift;
     2242
     2243  my ($loc) = $dbh->selectrow_array("SELECT default_location FROM ".
     2244        ($revrec eq 'n' ? 'domains WHERE domain_id = ?' : 'revzones WHERE rdns_id = ?'),
     2245        undef, ($zoneid));
     2246  return $loc;
     2247} # end getZoneLocation()
     2248
     2249
     2250## DNSDB::addGroup()
     2251# Add a group
     2252# Takes a database handle, group name, parent group, hashref for permissions,
     2253# and optional template-vs-cloneme flag for the default records
     2254# Returns a status code and message
     2255sub addGroup {
     2256  $errstr = '';
     2257  my $dbh = shift;
     2258  my $groupname = shift;
     2259  my $pargroup = shift;
     2260  my $permissions = shift;
     2261
     2262  # 0 indicates "custom", hardcoded.
     2263  # Any other value clones that group's default records, if it exists.
     2264  my $inherit = shift || 0;     
     2265##fixme:  need a flag to indicate clone records or <?> ?
     2266
     2267  # Allow transactions, and raise an exception on errors so we can catch it later.
     2268  # Use local to make sure these get "reset" properly on exiting this block
     2269  local $dbh->{AutoCommit} = 0;
     2270  local $dbh->{RaiseError} = 1;
     2271
     2272  my ($group_id) = $dbh->selectrow_array("SELECT group_id FROM groups WHERE group_name=?", undef, ($groupname));
     2273
     2274  return ('FAIL', "Group already exists") if $group_id;
     2275
     2276  # Wrap all the SQL in a transaction
     2277  eval {
     2278    $dbh->do("INSERT INTO groups (parent_group_id,group_name) VALUES (?,?)", undef, ($pargroup, $groupname) );
     2279
     2280    my ($groupid) = $dbh->selectrow_array("SELECT currval('groups_group_id_seq')");
     2281
     2282    # We work through the whole set of permissions instead of specifying them so
     2283    # that when we add a new permission, we don't have to change the code anywhere
     2284    # that doesn't explicitly deal with that specific permission.
     2285    my @permvals;
     2286    foreach (@permtypes) {
     2287      if (!defined ($permissions->{$_})) {
     2288        push @permvals, 0;
     2289      } else {
     2290        push @permvals, $permissions->{$_};
     2291      }
     2292    }
     2293    $dbh->do("INSERT INTO permissions (group_id,$permlist) values (?".',?'x($#permtypes+1).")",
     2294        undef, ($groupid, @permvals) );
     2295    my ($permid) = $dbh->selectrow_array("SELECT currval('permissions_permission_id_seq')");
     2296    $dbh->do("UPDATE groups SET permission_id=$permid WHERE group_id=$groupid");
     2297
     2298    # Default records
     2299    my $sthf = $dbh->prepare("INSERT INTO default_records (group_id,host,type,val,distance,weight,port,ttl) ".
     2300        "VALUES ($groupid,?,?,?,?,?,?,?)");
     2301    my $sthr = $dbh->prepare("INSERT INTO default_rev_records (group_id,host,type,val,ttl) ".
     2302        "VALUES ($groupid,?,?,?,?)");
     2303    if ($inherit) {
     2304      # Duplicate records from parent.  Actually relying on inherited records feels
     2305      # very fragile, and it would be problematic to roll over at a later time.
     2306      my $sth2 = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl FROM default_records WHERE group_id=?");
     2307      $sth2->execute($pargroup);
     2308      while (my @clonedata = $sth2->fetchrow_array) {
     2309        $sthf->execute(@clonedata);
     2310      }
     2311      # And now the reverse records
     2312      $sth2 = $dbh->prepare("SELECT host,type,val,ttl FROM default_rev_records WHERE group_id=?");
     2313      $sth2->execute($pargroup);
     2314      while (my @clonedata = $sth2->fetchrow_array) {
     2315        $sthr->execute(@clonedata);
     2316      }
     2317    } else {
     2318##fixme: Hardcoding is Bad, mmmmkaaaay?
     2319      # reasonable basic defaults for SOA, MX, NS, and minimal hosting
     2320      # could load from a config file, but somewhere along the line we need hardcoded bits.
     2321      $sthf->execute('ns1.example.com:hostmaster.example.com', 6, '10800:3600:604800:10800', 0, 0, 0, 86400);
     2322      $sthf->execute('DOMAIN', 1, '192.168.4.2', 0, 0, 0, 7200);
     2323      $sthf->execute('DOMAIN', 15, 'mx.example.com', 10, 0, 0, 7200);
     2324      $sthf->execute('DOMAIN', 2, 'ns1.example.com', 0, 0, 0, 7200);
     2325      $sthf->execute('DOMAIN', 2, 'ns2.example.com', 0, 0, 0, 7200);
     2326      $sthf->execute('www.DOMAIN', 5, 'DOMAIN', 0, 0, 0, 7200);
     2327      # reasonable basic defaults for generic reverse zone.  Same as initial SQL tabledef.
     2328      $sthr->execute('hostmaster.ADMINDOMAIN:ns1.ADMINDOMAIN', 6, '10800:3600:604800:10800', 86400);
     2329      $sthr->execute('unused-%r.ADMINDOMAIN', 65283, 'ZONE', 3600);
     2330    }
     2331
     2332    _log($dbh, (group_id => $pargroup, entry => "Added group $groupname") );
     2333
     2334    # once we get here, we should have suceeded.
     2335    $dbh->commit;
     2336  }; # end eval
     2337
     2338  if ($@) {
     2339    my $msg = $@;
     2340    eval { $dbh->rollback; };
     2341    if ($config{log_failures}) {
     2342      _log($dbh, (group_id => $pargroup, entry => "Failed to add group $groupname: $msg") );
     2343      $dbh->commit;
     2344    }
     2345    return ('FAIL',$msg);
     2346  }
     2347
     2348  return ('OK','OK');
     2349} # end addGroup()
     2350
     2351
     2352## DNSDB::delGroup()
     2353# Delete a group.
     2354# Takes a group ID
     2355# Returns a status code and message
     2356sub delGroup {
     2357  my $dbh = shift;
     2358  my $groupid = shift;
     2359
     2360  # Allow transactions, and raise an exception on errors so we can catch it later.
     2361  # Use local to make sure these get "reset" properly on exiting this block
     2362  local $dbh->{AutoCommit} = 0;
     2363  local $dbh->{RaiseError} = 1;
     2364
     2365##fixme:  locate "knowable" error conditions and deal with them before the eval
     2366# ... or inside, whatever.
     2367# -> domains still exist in group
     2368# -> ...
     2369  my $failmsg = '';
     2370  my $resultmsg = '';
     2371
     2372  # collect some pieces for logging and error messages
     2373  my $groupname = groupName($dbh,$groupid);
     2374  my $parid = parentID($dbh, (id => $groupid, type => 'group'));
     2375
     2376  # Wrap all the SQL in a transaction
     2377  eval {
     2378    # Check for Things in the group
     2379    $failmsg = "Can't remove group $groupname";
     2380    my ($grpcnt) = $dbh->selectrow_array("SELECT count(*) FROM groups WHERE parent_group_id=?", undef, ($groupid));
     2381    die "$grpcnt groups still in group\n" if $grpcnt;
     2382    my ($domcnt) = $dbh->selectrow_array("SELECT count(*) FROM domains WHERE group_id=?", undef, ($groupid));
     2383    die "$domcnt domains still in group\n" if $domcnt;
     2384    my ($usercnt) = $dbh->selectrow_array("SELECT count(*) FROM users WHERE group_id=?", undef, ($groupid));
     2385    die "$usercnt users still in group\n" if $usercnt;
     2386
     2387    $failmsg = "Failed to delete default records for $groupname";
     2388    $dbh->do("DELETE from default_records WHERE group_id=?", undef, ($groupid));
     2389    $failmsg = "Failed to delete default reverse records for $groupname";
     2390    $dbh->do("DELETE from default_rev_records WHERE group_id=?", undef, ($groupid));
     2391    $failmsg = "Failed to remove group $groupname";
     2392    $dbh->do("DELETE from groups WHERE group_id=?", undef, ($groupid));
     2393
     2394    _log($dbh, (group_id => $parid, entry => "Deleted group $groupname"));
     2395    $resultmsg = "Deleted group $groupname";
     2396
     2397    # once we get here, we should have suceeded.
     2398    $dbh->commit;
     2399  }; # end eval
     2400
     2401  if ($@) {
     2402    my $msg = $@;
     2403    eval { $dbh->rollback; };
     2404    if ($config{log_failures}) {
     2405      _log($dbh, (group_id => $parid, entry => "$failmsg: $msg"));
     2406      $dbh->commit;     # since we enabled transactions earlier
     2407    }
     2408    return ('FAIL',"$failmsg: $msg");
     2409  }
     2410
     2411  return ('OK',$resultmsg);
     2412} # end delGroup()
     2413
     2414
     2415## DNSDB::getChildren()
     2416# Get a list of all groups whose parent^n is group <n>
     2417# Takes a database handle, group ID, reference to an array to put the group IDs in,
     2418# and an optional flag to return only immediate children or all children-of-children
     2419# default to returning all children
     2420# Calls itself
     2421sub getChildren {
     2422  $errstr = '';
     2423  my $dbh = shift;
     2424  my $rootgroup = shift;
     2425  my $groupdest = shift;
     2426  my $immed = shift || 'all';
     2427
     2428  # special break for default group;  otherwise we get stuck.
     2429  if ($rootgroup == 1) {
     2430    # by definition, group 1 is the Root Of All Groups
     2431    my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE NOT (group_id=1)".
     2432        ($immed ne 'all' ? " AND parent_group_id=1" : '')." ORDER BY group_name");
     2433    $sth->execute;
     2434    while (my @this = $sth->fetchrow_array) {
     2435      push @$groupdest, @this;
     2436    }
     2437  } else {
     2438    my $sth = $dbh->prepare("SELECT group_id FROM groups WHERE parent_group_id=? ORDER BY group_name");
     2439    $sth->execute($rootgroup);
     2440    return if $sth->rows == 0;
     2441    my @grouplist;
     2442    while (my ($group) = $sth->fetchrow_array) {
     2443      push @$groupdest, $group;
     2444      getChildren($dbh,$group,$groupdest) if $immed eq 'all';
     2445    }
     2446  }
     2447} # end getChildren()
     2448
     2449
     2450## DNSDB::groupName()
     2451# Return the group name based on a group ID
     2452# Takes a database handle and the group ID
     2453# Returns the group name or undef on failure
     2454sub groupName {
     2455  $errstr = '';
     2456  my $dbh = shift;
     2457  my $groupid = shift;
     2458  my $sth = $dbh->prepare("SELECT group_name FROM groups WHERE group_id=?");
     2459  $sth->execute($groupid);
     2460  my ($groupname) = $sth->fetchrow_array();
     2461  $errstr = $DBI::errstr if !$groupname;
     2462  return $groupname if $groupname;
     2463} # end groupName
     2464
     2465
     2466## DNSDB::getGroupCount()
     2467# Get count of subgroups in group or groups
     2468# Takes a database handle and hash containing:
     2469#  - the "current" group
     2470#  - an array of "acceptable" groups
     2471#  - Optionally accept a "starts with" and/or "contains" filter argument
     2472# Returns an integer count of the resulting group list.
     2473sub getGroupCount {
     2474  my $dbh = shift;
     2475
     2476  my %args = @_;
     2477
     2478  my @filterargs;
     2479
     2480  $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
     2481  push @filterargs, "^$args{startwith}" if $args{startwith};
     2482  push @filterargs, $args{filter} if $args{filter};
     2483
     2484  my $sql = "SELECT count(*) FROM groups ".
     2485        "WHERE parent_group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
     2486        ($args{startwith} ? " AND group_name ~* ?" : '').
     2487        ($args{filter} ? " AND group_name ~* ?" : '');
     2488  my ($count) = $dbh->selectrow_array($sql, undef, (@filterargs) );
     2489  $errstr = $dbh->errstr if !$count;
     2490  return $count;
     2491} # end getGroupCount
     2492
     2493
     2494## DNSDB::getGroupList()
     2495# Get a list of sub^n-groups in the specified group(s)
     2496# Takes the same arguments as getGroupCount() above
     2497# Returns an arrayref containing hashrefs suitable for feeding straight to HTML::Template
     2498sub getGroupList {
     2499  my $dbh = shift;
     2500
     2501  my %args = @_;
     2502
     2503  my @filterargs;
     2504
     2505  $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
     2506  push @filterargs, "^$args{startwith}" if $args{startwith};
     2507  push @filterargs, $args{filter} if $args{filter};
     2508
     2509  # protection against bad or missing arguments
     2510  $args{sortorder} = 'ASC' if !$args{sortorder};
     2511  $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/;
     2512
     2513  # munge sortby for columns in database
     2514  $args{sortby} = 'g.group_name' if $args{sortby} eq 'group';
     2515  $args{sortby} = 'g2.group_name' if $args{sortby} eq 'parent';
     2516
     2517  my $sql = q(SELECT g.group_id AS groupid, g.group_name AS groupname, g2.group_name AS pgroup
     2518        FROM groups g
     2519        INNER JOIN groups g2 ON g2.group_id=g.parent_group_id
     2520        ).
     2521        " WHERE g.parent_group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
     2522        ($args{startwith} ? " AND g.group_name ~* ?" : '').
     2523        ($args{filter} ? " AND g.group_name ~* ?" : '').
     2524        " GROUP BY g.group_id, g.group_name, g2.group_name ".
     2525        " ORDER BY $args{sortby} $args{sortorder} ".
     2526        ($args{offset} eq 'all' ? '' : " LIMIT $config{perpage} OFFSET ".$args{offset}*$config{perpage});
     2527  my $glist = $dbh->selectall_arrayref($sql, { Slice => {} }, (@filterargs) );
     2528  $errstr = $dbh->errstr if !$glist;
     2529
     2530  # LEFT JOINs make the result set balloon beyond sanity just to include counts;
     2531  # this means there's lots of crunching needed to trim the result set back down.
     2532  # So instead we track the order of the groups, and push the counts into the
     2533  # arrayref result separately.
     2534##fixme:  put this whole sub in a transaction?  might be
     2535# needed for accurate results on very busy systems.
     2536##fixme:  large group lists need prepared statements?
     2537#my $ucsth = $dbh->prepare("SELECT count(*) FROM users WHERE group_id=?");
     2538#my $dcsth = $dbh->prepare("SELECT count(*) FROM domains WHERE group_id=?");
     2539#my $rcsth = $dbh->prepare("SELECT count(*) FROM revzones WHERE group_id=?");
     2540  foreach (@{$glist}) {
     2541    my ($ucnt) = $dbh->selectrow_array("SELECT count(*) FROM users WHERE group_id=?", undef, ($$_{groupid}));
     2542    $$_{nusers} = $ucnt;
     2543    my ($dcnt) = $dbh->selectrow_array("SELECT count(*) FROM domains WHERE group_id=?", undef, ($$_{groupid}));
     2544    $$_{ndomains} = $dcnt;
     2545    my ($rcnt) = $dbh->selectrow_array("SELECT count(*) FROM revzones WHERE group_id=?", undef, ($$_{groupid}));
     2546    $$_{nrevzones} = $rcnt;
     2547  }
     2548
     2549  return $glist;
     2550} # end getGroupList
     2551
     2552
     2553## DNSDB::groupID()
     2554# Return the group ID based on the group name
     2555# Takes a database handle and the group name
     2556# Returns the group ID or undef on failure
     2557sub groupID {
     2558  $errstr = '';
     2559  my $dbh = shift;
     2560  my $group = shift;
     2561  my ($grpid) = $dbh->selectrow_array("SELECT group_id FROM groups WHERE group_name=?", undef, ($group) );
     2562  $errstr = $DBI::errstr if !$grpid;
     2563  return $grpid if $grpid;
     2564} # end groupID()
     2565
     2566
     2567## DNSDB::addUser()
     2568# Add a user.
     2569# Takes a DB handle, username, group ID, password, state (active/inactive).
     2570# Optionally accepts:
     2571#   user type (user/admin)      - defaults to user
     2572#   permissions string          - defaults to inherit from group
     2573#      three valid forms:
     2574#       i                    - Inherit permissions
     2575#       c:<user_id>          - Clone permissions from <user_id>
     2576#       C:<permission list>  - Set these specific permissions
     2577#   first name                  - defaults to username
     2578#   last name                   - defaults to blank
     2579#   phone                       - defaults to blank (could put other data within column def)
     2580# Returns (OK,<uid>) on success, (FAIL,<message>) on failure
     2581sub addUser {
     2582  $errstr = '';
     2583  my $dbh = shift;
     2584  my $username = shift;
     2585  my $group = shift;
     2586  my $pass = shift;
     2587  my $state = shift;
     2588
     2589  return ('FAIL', "Missing one or more required entries") if !defined($state);
     2590  return ('FAIL', "Username must not be blank") if !$username;
     2591
     2592  # Munge in some alternate state values
     2593  $state = 1 if $state =~ /^active$/;
     2594  $state = 1 if $state =~ /^on$/;
     2595  $state = 0 if $state =~ /^inactive$/;
     2596  $state = 0 if $state =~ /^off$/;
     2597
     2598  my $type = shift || 'u';      # create limited users by default - fwiw, not sure yet how this will interact with ACLs
     2599 
     2600  my $permstring = shift || 'i';        # default is to inhert permissions from group
     2601
     2602  my $fname = shift || $username;
     2603  my $lname = shift || '';
     2604  my $phone = shift || '';      # not going format-check
     2605
     2606  my $sth = $dbh->prepare("SELECT user_id FROM users WHERE username=?");
     2607  my $user_id;
     2608
     2609# quick check to start to see if we've already got one
     2610  $sth->execute($username);
     2611  ($user_id) = $sth->fetchrow_array;
     2612
     2613  return ('FAIL', "User already exists") if $user_id;
     2614
     2615  # Allow transactions, and raise an exception on errors so we can catch it later.
     2616  # Use local to make sure these get "reset" properly on exiting this block
     2617  local $dbh->{AutoCommit} = 0;
     2618  local $dbh->{RaiseError} = 1;
     2619
     2620  # Wrap all the SQL in a transaction
     2621  eval {
     2622    # insert the user...  note we set inherited perms by default since
     2623    # it's simple and cleans up some other bits of state
     2624    my $sth = $dbh->prepare("INSERT INTO users ".
     2625        "(group_id,username,password,firstname,lastname,phone,type,status,permission_id,inherit_perm) ".
     2626        "VALUES (?,?,?,?,?,?,?,?,(SELECT permission_id FROM permissions WHERE group_id=?),'t')");
     2627    $sth->execute($group,$username,unix_md5_crypt($pass),$fname,$lname,$phone,$type,$state,$group);
     2628
     2629    # get the ID...
     2630    ($user_id) = $dbh->selectrow_array("SELECT currval('users_user_id_seq')");
     2631
     2632# Permissions!  Gotta set'em all!
     2633    die "Invalid permission string $permstring\n"
     2634        if $permstring !~ /^(?:
     2635                i       # inherit
     2636                |c:\d+  # clone
     2637                        # custom.  no, the leading , is not a typo
     2638                |C:(?:,(?:group|user|domain|record|location|self)_(?:edit|create|delete|locchg|view))*
     2639                )$/x;
     2640# bleh.  I'd call another function to do my dirty work, but we're in the middle of a transaction already.
     2641    if ($permstring ne 'i') {
     2642      # for cloned or custom permissions, we have to create a new permissions entry.
     2643      my $clonesrc = $group;
     2644      if ($permstring =~ /^c:(\d+)/) { $clonesrc = $1; }
     2645      $dbh->do("INSERT INTO permissions ($permlist,user_id) ".
     2646        "SELECT $permlist,? FROM permissions WHERE permission_id=".
     2647        "(SELECT permission_id FROM permissions WHERE ".($permstring =~ /^c:/ ? 'user' : 'group')."_id=?)",
     2648        undef, ($user_id,$clonesrc) );
     2649      $dbh->do("UPDATE users SET permission_id=".
     2650        "(SELECT permission_id FROM permissions WHERE user_id=?) ".
     2651        "WHERE user_id=?", undef, ($user_id, $user_id) );
     2652    }
     2653    if ($permstring =~ /^C:/) {
     2654      # finally for custom permissions, we set the passed-in permissions (and unset
     2655      # any that might have been brought in by the clone operation above)
     2656      my ($permid) = $dbh->selectrow_array("SELECT permission_id FROM permissions WHERE user_id=?",
     2657        undef, ($user_id) );
     2658      foreach (@permtypes) {
     2659        if ($permstring =~ /,$_/) {
     2660          $dbh->do("UPDATE permissions SET $_='t' WHERE permission_id=?", undef, ($permid) );
     2661        } else {
     2662          $dbh->do("UPDATE permissions SET $_='f' WHERE permission_id=?", undef, ($permid) );
     2663        }
     2664      }
     2665    }
     2666
     2667    $dbh->do("UPDATE users SET inherit_perm='n' WHERE user_id=?", undef, ($user_id) );
     2668
     2669##fixme: add another table to hold name/email for log table?
     2670
     2671    _log($dbh, (group_id => $group, entry => "Added user $username ($fname $lname)"));
     2672    # once we get here, we should have suceeded.
     2673    $dbh->commit;
     2674  }; # end eval
     2675
     2676  if ($@) {
     2677    my $msg = $@;
     2678    eval { $dbh->rollback; };
     2679    if ($config{log_failures}) {
     2680      _log($dbh, (group_id => $group, entry => "Error adding user $username: $msg"));
     2681      $dbh->commit;     # since we enabled transactions earlier
     2682    }
     2683    return ('FAIL',"Error adding user $username: $msg");
     2684  }
     2685
     2686  return ('OK',"User $username ($fname $lname) added");
     2687} # end addUser
     2688
     2689
     2690## DNSDB::getUserCount()
     2691# Get count of users in group
     2692# Takes a database handle and hash containing at least the current group, and optionally:
     2693# - a reference list of secondary groups
     2694# - a filter string
     2695# - a "Starts with" string
     2696sub getUserCount {
     2697  my $dbh = shift;
     2698
     2699  my %args = @_;
     2700
     2701  my @filterargs;
     2702
     2703  $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
     2704  push @filterargs, "^$args{startwith}" if $args{startwith};
     2705  push @filterargs, $args{filter} if $args{filter};
     2706
     2707
     2708  my $sql = "SELECT count(*) FROM users ".
     2709        "WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
     2710        ($args{startwith} ? " AND username ~* ?" : '').
     2711        ($args{filter} ? " AND username ~* ?" : '');
     2712  my ($count) = $dbh->selectrow_array($sql, undef, (@filterargs) );
     2713  $errstr = $dbh->errstr if !$count;
     2714  return $count;
     2715} # end getUserCount()
     2716
     2717
     2718## DNSDB::getUserList()
     2719# Get list of users
     2720# Takes the same arguments as getUserCount() above, plus optional:
     2721# - sort field
     2722# - sort order
     2723# - offset/return-all-everything flag (defaults to $perpage records)
     2724sub getUserList {
     2725  my $dbh = shift;
     2726
     2727  my %args = @_;
     2728
     2729  my @filterargs;
     2730
     2731  $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
     2732  push @filterargs, "^$args{startwith}" if $args{startwith};
     2733  push @filterargs, $args{filter} if $args{filter};
     2734
     2735  # better to request sorts on "simple" names, but it means we need to map it to real columns
     2736  my %sortmap = (user => 'u.username', type => 'u.type', group => 'g.group_name', status => 'u.status',
     2737        fname => 'fname');
     2738  $args{sortby} = $sortmap{$args{sortby}};
     2739
     2740  # protection against bad or missing arguments
     2741  $args{sortorder} = 'ASC' if !$args{sortorder};
     2742  $args{sortby} = 'u.username' if !$args{sortby};
     2743  $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/;
     2744
     2745  my $sql = "SELECT u.user_id, u.username, u.firstname || ' ' || u.lastname AS fname, u.type, g.group_name, u.status ".
     2746        "FROM users u ".
     2747        "INNER JOIN groups g ON u.group_id=g.group_id ".
     2748        "WHERE u.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
     2749        ($args{startwith} ? " AND u.username ~* ?" : '').
     2750        ($args{filter} ? " AND u.username ~* ?" : '').
     2751        " AND NOT u.type = 'R' ".
     2752        " ORDER BY $args{sortby} $args{sortorder} ".
     2753        ($args{offset} eq 'all' ? '' : " LIMIT $config{perpage} OFFSET ".$args{offset}*$config{perpage});
     2754  my $ulist = $dbh->selectall_arrayref($sql, { Slice => {} }, (@filterargs) );
     2755  $errstr = $dbh->errstr if !$ulist;
     2756  return $ulist;
     2757} # end getUserList()
     2758
     2759
     2760## DNSDB::getUserDropdown()
     2761# Get a list of usernames for use in a dropdown menu.
     2762# Takes a database handle, current group, and optional "tag this as selected" flag.
     2763# Returns a reference to a list of hashrefs suitable to feeding to HTML::Template
     2764sub getUserDropdown {
     2765  my $dbh = shift;
     2766  my $grp = shift;
     2767  my $sel = shift || 0;
     2768
     2769  my $sth = $dbh->prepare("SELECT username,user_id FROM users WHERE group_id=?");
     2770  $sth->execute($grp);
     2771
     2772  my @userlist;
     2773  while (my ($username,$uid) = $sth->fetchrow_array) {
     2774    my %row = (
     2775        username => $username,
     2776        uid => $uid,
     2777        selected => ($sel == $uid ? 1 : 0)
     2778        );
     2779    push @userlist, \%row;
     2780  }
     2781  return \@userlist;
     2782} # end getUserDropdown()
     2783
     2784
     2785## DNSDB::checkUser()
     2786# Check user/pass combo on login
     2787sub checkUser {
     2788  my $dbh = shift;
     2789  my $user = shift;
     2790  my $inpass = shift;
     2791
     2792  my $sth = $dbh->prepare("SELECT user_id,group_id,password,firstname,lastname FROM users WHERE username=?");
     2793  $sth->execute($user);
     2794  my ($uid,$gid,$pass,$fname,$lname) = $sth->fetchrow_array;
     2795  my $loginfailed = 1 if !defined($uid);
     2796
     2797  if ($pass =~ m|^\$1\$([A-Za-z0-9/.]+)\$|) {
     2798    $loginfailed = 1 if $pass ne unix_md5_crypt($inpass,$1);
     2799  } else {
     2800    $loginfailed = 1 if $pass ne $inpass;
     2801  }
     2802
     2803  # nnnngggg
     2804  return ($uid, $gid);
     2805} # end checkUser
     2806
     2807
     2808## DNSDB:: updateUser()
     2809# Update general data about user
     2810sub updateUser {
     2811  my $dbh = shift;
     2812
     2813##fixme:  tweak calling convention so that we can update any given bit of data
     2814  my $uid = shift;
     2815  my $username = shift;
     2816  my $group = shift;
     2817  my $pass = shift;
     2818  my $state = shift;
     2819  my $type = shift || 'u';
     2820  my $fname = shift || $username;
     2821  my $lname = shift || '';
     2822  my $phone = shift || '';      # not going format-check
     2823
     2824  my $resultmsg = '';
     2825
     2826  # Munge in some alternate state values
     2827  $state = 1 if $state =~ /^active$/;
     2828  $state = 1 if $state =~ /^on$/;
     2829  $state = 0 if $state =~ /^inactive$/;
     2830  $state = 0 if $state =~ /^off$/;
     2831
     2832  # Allow transactions, and raise an exception on errors so we can catch it later.
     2833  # Use local to make sure these get "reset" properly on exiting this block
     2834  local $dbh->{AutoCommit} = 0;
     2835  local $dbh->{RaiseError} = 1;
     2836
     2837  my $sth;
     2838
     2839  # Password can be left blank;  if so we assume there's one on file.
     2840  # Actual blank passwords are bad, mm'kay?
     2841  if (!$pass) {
     2842    ($pass) = $dbh->selectrow_array("SELECT password FROM users WHERE user_id=?", undef, ($uid));
     2843  } else {
     2844    $pass = unix_md5_crypt($pass);
     2845  }
     2846
     2847  eval {
     2848    $dbh->do("UPDATE users SET username=?, password=?, firstname=?, lastname=?, phone=?, type=?, status=?".
     2849        " WHERE user_id=?", undef, ($username, $pass, $fname, $lname, $phone, $type, $state, $uid));
     2850    $resultmsg = "Updated user info for $username ($fname $lname)";
     2851    _log($dbh, group_id => $group, entry => $resultmsg);
     2852    $dbh->commit;
     2853  };
     2854  if ($@) {
     2855    my $msg = $@;
     2856    eval { $dbh->rollback; };
     2857    if ($config{log_failures}) {
     2858      _log($dbh, (group_id => $group, entry => "Error updating user $username: $msg"));
     2859      $dbh->commit;     # since we enabled transactions earlier
     2860    }
     2861    return ('FAIL',"Error updating user $username: $msg");
     2862  }
     2863
     2864  return ('OK',$resultmsg);
     2865} # end updateUser()
     2866
     2867
     2868## DNSDB::delUser()
     2869# Delete a user.
     2870# Takes a database handle and user ID
     2871# Returns a success/failure code and matching message
     2872sub delUser {
     2873  my $dbh = shift;
     2874  my $userid = shift;
     2875
     2876  return ('FAIL',"Bad userid") if !defined($userid);
     2877
     2878  my $userdata = getUserData($dbh, $userid);
     2879
     2880  # Allow transactions, and raise an exception on errors so we can catch it later.
     2881  # Use local to make sure these get "reset" properly on exiting this block
     2882  local $dbh->{AutoCommit} = 0;
     2883  local $dbh->{RaiseError} = 1;
     2884
     2885  eval {
     2886    $dbh->do("DELETE FROM users WHERE user_id=?", undef, ($userid));
     2887    _log($dbh, (group_id => $userdata->{group_id},
     2888        entry => "Deleted user ID $userid/".$userdata->{username}.
     2889                " (".$userdata->{firstname}." ".$userdata->{lastname}.")") );
     2890    $dbh->commit;
     2891  };
     2892  if ($@) {
     2893    my $msg = $@;
     2894    eval { $dbh->rollback; };
     2895    if ($config{log_failures}) {
     2896      _log($dbh, (group_id => $userdata->{group_id}, entry => "Error deleting user ID ".
     2897        "$userid/".$userdata->{username}.": $msg") );
     2898      $dbh->commit;
     2899    }
     2900    return ('FAIL',"Error deleting user $userid/".$userdata->{username}.": $msg");
     2901  }
     2902
     2903  return ('OK',"Deleted user ".$userdata->{username}." (".$userdata->{firstname}." ".$userdata->{lastname}.")");
     2904} # end delUser
     2905
     2906
     2907## DNSDB::userFullName()
     2908# Return a pretty string!
     2909# Takes a user_id and optional printf-ish string to indicate which pieces where:
     2910# %u for the username
     2911# %f for the first name
     2912# %l for the last name
     2913# All other text in the passed string will be left as-is.
     2914##fixme:  need a "smart" option too, so that missing/null/blank first/last names don't give funky output
     2915sub userFullName {
     2916  $errstr = '';
     2917  my $dbh = shift;
     2918  my $userid = shift;
     2919  my $fullformat = shift || '%f %l (%u)';
     2920  my $sth = $dbh->prepare("select username,firstname,lastname from users where user_id=?");
     2921  $sth->execute($userid);
     2922  my ($uname,$fname,$lname) = $sth->fetchrow_array();
     2923  $errstr = $DBI::errstr if !$uname;
     2924
     2925  $fullformat =~ s/\%u/$uname/g;
     2926  $fullformat =~ s/\%f/$fname/g;
     2927  $fullformat =~ s/\%l/$lname/g;
     2928
     2929  return $fullformat;
     2930} # end userFullName
     2931
     2932
     2933## DNSDB::userStatus()
     2934# Sets and/or returns a user's status
     2935# Takes a database handle, user ID and optionally a status argument
     2936# Returns undef on errors.
     2937sub userStatus {
     2938  my $dbh = shift;
     2939  my $id = shift;
     2940  my $newstatus = shift || 'mu';
     2941
     2942  return undef if $id !~ /^\d+$/;
     2943
     2944  my $userdata = getUserData($dbh, $id);
     2945
     2946  # Allow transactions, and raise an exception on errors so we can catch it later.
     2947  # Use local to make sure these get "reset" properly on exiting this block
     2948  local $dbh->{AutoCommit} = 0;
     2949  local $dbh->{RaiseError} = 1;
     2950
     2951  if ($newstatus ne 'mu') {
     2952    # ooo, fun!  let's see what we were passed for status
     2953    eval {
     2954      $newstatus = 0 if $newstatus eq 'useroff';
     2955      $newstatus = 1 if $newstatus eq 'useron';
     2956      $dbh->do("UPDATE users SET status=? WHERE user_id=?", undef, ($newstatus, $id));
     2957
     2958      $resultstr = ($newstatus ? 'Enabled' : 'Disabled')." user ".$userdata->{username}.
     2959        " (".$userdata->{firstname}." ".$userdata->{lastname}.")";
     2960
     2961      my %loghash;
     2962      $loghash{group_id} = parentID($dbh, (id => $id, type => 'user'));
     2963      $loghash{entry} = $resultstr;
     2964      _log($dbh, %loghash);
     2965
     2966      $dbh->commit;
     2967    };
     2968    if ($@) {
     2969      my $msg = $@;
     2970      eval { $dbh->rollback; };
     2971      $resultstr = '';
     2972      $errstr = $msg;
     2973##fixme: failure logging?
     2974      return;
     2975    }
     2976  }
     2977
     2978  my ($status) = $dbh->selectrow_array("SELECT status FROM users WHERE user_id=?", undef, ($id));
     2979  return $status;
     2980} # end userStatus()
     2981
     2982
     2983## DNSDB::getUserData()
     2984# Get misc user data for display
     2985sub getUserData {
     2986  my $dbh = shift;
     2987  my $uid = shift;
     2988
     2989  my $sth = $dbh->prepare("SELECT group_id,username,firstname,lastname,phone,type,status,inherit_perm ".
     2990        "FROM users WHERE user_id=?");
     2991  $sth->execute($uid);
     2992  return $sth->fetchrow_hashref();
     2993} # end getUserData()
     2994
     2995
     2996## DNSDB::addLoc()
     2997# Add a new location.
     2998# Takes a database handle, group ID, short and long description, and a comma-separated
     2999# list of IP addresses.
     3000# Returns ('OK',<location>) on success, ('FAIL',<failmsg>) on failure
     3001sub addLoc {
     3002  my $dbh = shift;
     3003  my $grp = shift;
     3004  my $shdesc = shift;
     3005  my $comments = shift;
     3006  my $iplist = shift;
     3007
     3008  # $shdesc gets set to the generated location ID if possible, but these can be de-undefined here.
     3009  $comments = '' if !$comments;
     3010  $iplist = '' if !$iplist;
     3011
     3012  my $loc;
     3013
     3014  # Generate a location ID.  This is, by spec, a two-character widget.  We'll use [a-z][a-z]
     3015  # for now;  676 locations should satisfy all but the largest of the huge networks.
     3016  # Not sure whether these are case-sensitive, or what other rules might apply - in any case
     3017  # the absolute maximum is 16K (256*256) since it's parsed by tinydns as a two-character field.
     3018
     3019# add just after "my $origloc = $loc;":
     3020#    # These expand the possible space from 26^2 to 52^2 [* note in testing only 2052 were achieved],
     3021#    # and wrap it around.
     3022#    # Yes, they skip a couple of possibles.  No, I don't care.
     3023#    $loc = 'aA' if $loc eq 'zz';
     3024#    $loc = 'Aa' if $loc eq 'zZ';
     3025#    $loc = 'ZA' if $loc eq 'Zz';
     3026#    $loc = 'aa' if $loc eq 'ZZ';
     3027
     3028  # Allow transactions, and raise an exception on errors so we can catch it later.
     3029  # Use local to make sure these get "reset" properly on exiting this block
     3030  local $dbh->{AutoCommit} = 0;
     3031  local $dbh->{RaiseError} = 1;
     3032
     3033##fixme:  There is probably a far better way to do this.  Sequential increments
     3034# are marginally less stupid that pure random generation though, and the existence
     3035# check makes sure we don't stomp on an imported one.
     3036
     3037  eval {
     3038    # Get the "last" location.  Note this is the only use for loc_id, because selecting on location Does Funky Things
     3039    ($loc) = $dbh->selectrow_array("SELECT location FROM locations ORDER BY loc_id DESC LIMIT 1");
     3040    ($loc) = ($loc =~ /^(..)/);
     3041    my $origloc = $loc;
     3042    # Make a change...
     3043    $loc++;
     3044    # ... and keep changing if it exists
     3045    while ($dbh->selectrow_array("SELECT count(*) FROM locations WHERE location LIKE ?", undef, ($loc.'%'))) {
     3046      $loc++;
     3047      ($loc) = ($loc =~ /^(..)/);
     3048      die "too many locations in use, can't add another one\n" if $loc eq $origloc;
     3049##fixme: really need to handle this case faster somehow
     3050#if $loc eq $origloc die "<thwap> bad admin:  all locations used, your network is too fragmented";
     3051    }
     3052    # And now we should have a unique location.  tinydns fundamentally limits the
     3053    # number of these but there's no doc on what characters are valid.
     3054    $shdesc = $loc if !$shdesc;
     3055    $dbh->do("INSERT INTO locations (location, group_id, iplist, description, comments) VALUES (?,?,?,?,?)",
     3056        undef, ($loc, $grp, $iplist, $shdesc, $comments) );
     3057    _log($dbh, entry => "Added location ($shdesc, '$iplist')");
     3058    $dbh->commit;
     3059  };
     3060  if ($@) {
     3061    my $msg = $@;
     3062    eval { $dbh->rollback; };
     3063    if ($config{log_failures}) {
     3064      $shdesc = $loc if !$shdesc;
     3065      _log($dbh, (entry => "Failed adding location ($shdesc, '$iplist'): $msg"));
     3066      $dbh->commit;
     3067    }
     3068    return ('FAIL',$msg);
     3069  }
     3070
     3071  return ('OK',$loc);
     3072} # end addLoc()
     3073
     3074
     3075## DNSDB::updateLoc()
     3076sub updateLoc {
     3077  my $dbh = shift;
     3078  my $loc = shift;
     3079  my $grp = shift;
     3080  my $shdesc = shift;
     3081  my $comments = shift;
     3082  my $iplist = shift;
     3083
     3084  $shdesc = '' if !$shdesc;
     3085  $comments = '' if !$comments;
     3086  $iplist = '' if !$iplist;
     3087
     3088  # Allow transactions, and raise an exception on errors so we can catch it later.
     3089  # Use local to make sure these get "reset" properly on exiting this block
     3090  local $dbh->{AutoCommit} = 0;
     3091  local $dbh->{RaiseError} = 1;
     3092
     3093  my $oldloc = getLoc($dbh, $loc);
     3094  my $okmsg = "Updated location (".$oldloc->{description}.", '".$oldloc->{iplist}."') to ($shdesc, '$iplist')";
     3095
     3096  eval {
     3097    $dbh->do("UPDATE locations SET group_id=?,iplist=?,description=?,comments=? WHERE location=?",
     3098        undef, ($grp, $iplist, $shdesc, $comments, $loc) );
     3099    _log($dbh, entry => $okmsg);
     3100    $dbh->commit;
     3101  };
     3102  if ($@) {
     3103    my $msg = $@;
     3104    eval { $dbh->rollback; };
     3105    if ($config{log_failures}) {
     3106      $shdesc = $loc if !$shdesc;
     3107      _log($dbh, (entry => "Failed updating location ($shdesc, '$iplist'): $msg"));
     3108      $dbh->commit;
     3109    }
     3110    return ('FAIL',$msg);
     3111  }
     3112
     3113  return ('OK',$okmsg);
     3114} # end updateLoc()
     3115
     3116
     3117## DNSDB::delLoc()
     3118sub delLoc {}
     3119
     3120
     3121## DNSDB::getLoc()
     3122sub getLoc {
     3123  my $dbh = shift;
     3124  my $loc = shift;
     3125
     3126  my $sth = $dbh->prepare("SELECT group_id,iplist,description,comments FROM locations WHERE location=?");
     3127  $sth->execute($loc);
     3128  return $sth->fetchrow_hashref();
     3129} # end getLoc()
     3130
     3131
     3132## DNSDB::getLocCount()
     3133# Get count of locations/views
     3134# Takes a database handle and hash containing at least the current group, and optionally:
     3135# - a reference list of secondary groups
     3136# - a filter string
     3137# - a "Starts with" string
     3138sub getLocCount {
     3139  my $dbh = shift;
     3140
     3141  my %args = @_;
     3142
     3143  my @filterargs;
     3144
     3145  $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
     3146  push @filterargs, "^$args{startwith}" if $args{startwith};
     3147  push @filterargs, $args{filter} if $args{filter};
     3148
     3149
     3150  my $sql = "SELECT count(*) FROM locations ".
     3151        "WHERE group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
     3152        ($args{startwith} ? " AND description ~* ?" : '').
     3153        ($args{filter} ? " AND description ~* ?" : '');
     3154  my ($count) = $dbh->selectrow_array($sql, undef, (@filterargs) );
     3155  $errstr = $dbh->errstr if !$count;
     3156  return $count;
     3157} # end getLocCount()
     3158
     3159
     3160## DNSDB::getLocList()
     3161sub getLocList {
     3162  my $dbh = shift;
     3163
     3164  my %args = @_;
     3165
     3166  my @filterargs;
     3167
     3168  $args{startwith} = undef if $args{startwith} && $args{startwith} !~ /^(?:[a-z]|0-9)$/;
     3169  push @filterargs, "^$args{startwith}" if $args{startwith};
     3170  push @filterargs, $args{filter} if $args{filter};
     3171
     3172  # better to request sorts on "simple" names, but it means we need to map it to real columns
     3173#  my %sortmap = (user => 'u.username', type => 'u.type', group => 'g.group_name', status => 'u.status',
     3174#       fname => 'fname');
     3175#  $args{sortby} = $sortmap{$args{sortby}};
     3176
     3177  # protection against bad or missing arguments
     3178  $args{sortorder} = 'ASC' if !$args{sortorder};
     3179  $args{sortby} = 'l.description' if !$args{sortby};
     3180  $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/;
     3181
     3182  my $sql = "SELECT l.location, l.description, l.iplist, g.group_name ".
     3183        "FROM locations l ".
     3184        "INNER JOIN groups g ON l.group_id=g.group_id ".
     3185        "WHERE l.group_id IN ($args{curgroup}".($args{childlist} ? ",$args{childlist}" : '').")".
     3186        ($args{startwith} ? " AND l.description ~* ?" : '').
     3187        ($args{filter} ? " AND l.description ~* ?" : '').
     3188        " ORDER BY $args{sortby} $args{sortorder} ".
     3189        ($args{offset} eq 'all' ? '' : " LIMIT $config{perpage} OFFSET ".$args{offset}*$config{perpage});
     3190  my $ulist = $dbh->selectall_arrayref($sql, { Slice => {} }, (@filterargs) );
     3191  $errstr = $dbh->errstr if !$ulist;
     3192  return $ulist;
     3193} # end getLocList()
     3194
     3195
     3196## DNSDB::getLocDropdown()
     3197# Get a list of location names for use in a dropdown menu.
     3198# Takes a database handle, current group, and optional "tag this as selected" flag.
     3199# Returns a reference to a list of hashrefs suitable to feeding to HTML::Template
     3200sub getLocDropdown {
     3201  my $dbh = shift;
     3202  my $grp = shift;
     3203  my $sel = shift || '';
     3204
     3205  my $sth = $dbh->prepare(qq(
     3206        SELECT description,location FROM locations
     3207        WHERE group_id=?
     3208        ORDER BY description
     3209        ) );
     3210  $sth->execute($grp);
     3211
     3212  my @loclist;
     3213  push @loclist, { locname => "(None/public)", loc => '', selected => ($sel ? 0 : ($sel eq '' ? 1 : 0)) };
     3214  while (my ($locname, $loc) = $sth->fetchrow_array) {
     3215    my %row = (
     3216        locname => $locname,
     3217        loc => $loc,
     3218        selected => ($sel eq $loc ? 1 : 0)
     3219        );
     3220    push @loclist, \%row;
     3221  }
     3222  return \@loclist;
     3223} # end getLocDropdown()
     3224
     3225
     3226## DNSDB::getSOA()
     3227# Return all suitable fields from an SOA record in separate elements of a hash
     3228# Takes a database handle, default/live flag, domain/reverse flag, and parent ID
     3229sub getSOA {
     3230  $errstr = '';
     3231  my $dbh = shift;
     3232  my $def = shift;
     3233  my $rev = shift;
     3234  my $id = shift;
     3235
     3236  # (ab)use distance and weight columns to store SOA data?  can't for default_rev_records...
     3237  # - should really attach serial to the zone parent somewhere
     3238
     3239  my $sql = "SELECT record_id,host,val,ttl from "._rectable($def,$rev).
     3240        " WHERE "._recparent($def,$rev)." = ? AND type=$reverse_typemap{SOA}";
     3241  my $ret = $dbh->selectrow_hashref($sql, undef, ($id) );
     3242  return if !$ret;
     3243##fixme:  stick a flag somewhere if the record doesn't exist.  by the API, this is an impossible case, but...
     3244
     3245  ($ret->{contact},$ret->{prins}) = split /:/, $ret->{host};
     3246  delete $ret->{host};
     3247  ($ret->{refresh},$ret->{retry},$ret->{expire},$ret->{minttl}) = split /:/, $ret->{val};
     3248  delete $ret->{val};
     3249
     3250  return $ret;
     3251} # end getSOA()
     3252
     3253
     3254## DNSDB::updateSOA()
     3255# Update the specified SOA record
     3256# Takes a database handle, default/live flag, forward/reverse flag, and SOA data hash
     3257# Returns a two-element list with a result code and message
     3258sub updateSOA {
     3259  my $dbh = shift;
     3260  my $defrec = shift;
     3261  my $revrec = shift;
     3262
     3263  my %soa = @_;
     3264
     3265  my $oldsoa = getSOA($dbh, $defrec, $revrec, $soa{id});
     3266
     3267  my $msg;
     3268  my %logdata;
     3269  if ($defrec eq 'n') {
     3270    $logdata{domain_id} = $soa{id} if $revrec eq 'n';
     3271    $logdata{rdns_id} = $soa{id} if $revrec eq 'y';
     3272    $logdata{group_id} = parentID($dbh, (id => $soa{id}, revrec => $revrec,
     3273        type => ($revrec eq 'n' ? 'domain' : 'revzone') ) );
     3274  } else {
     3275    $logdata{group_id} = $soa{id};
     3276  }
     3277  my $parname = ($defrec eq 'y' ? groupName($dbh, $soa{id}) :
     3278                ($revrec eq 'n' ? domainName($dbh, $soa{id}) : revName($dbh, $soa{id})) );
     3279
     3280  # Allow transactions, and raise an exception on errors so we can catch it later.
     3281  # Use local to make sure these get "reset" properly on exiting this block
     3282  local $dbh->{AutoCommit} = 0;
     3283  local $dbh->{RaiseError} = 1;
     3284
     3285  eval {
     3286    my $sql = "UPDATE "._rectable($defrec, $revrec)." SET host=?, val=?, ttl=? WHERE record_id=? AND type=6";
     3287    $dbh->do($sql, undef, ("$soa{contact}:$soa{prins}", "$soa{refresh}:$soa{retry}:$soa{expire}:$soa{minttl}",
     3288        $soa{ttl}, $oldsoa->{record_id}) );
     3289    $msg = "Updated ".($defrec eq 'y' ? ($revrec eq 'y' ? 'default reverse ' : 'default ') : '').
     3290        "SOA for $parname: ".
     3291        "(ns $oldsoa->{prins}, contact $oldsoa->{contact}, refresh $oldsoa->{refresh},".
     3292        " retry $oldsoa->{retry}, expire $oldsoa->{expire}, minTTL $oldsoa->{minttl}, TTL $oldsoa->{ttl}) to ".
     3293        "(ns $soa{prins}, contact $soa{contact}, refresh $soa{refresh},".
     3294        " retry $soa{retry}, expire $soa{expire}, minTTL $soa{minttl}, TTL $soa{ttl})";
     3295
     3296    $logdata{entry} = $msg;
     3297    _log($dbh, %logdata);
     3298
     3299    $dbh->commit;
     3300  };
     3301  if ($@) {
     3302    $msg = $@;
     3303    eval { $dbh->rollback; };
     3304    $logdata{entry} = "Error updating ".($defrec eq 'y' ? ($revrec eq 'y' ? 'default reverse zone ' : 'default ') : '').
     3305        "SOA record for $parname: $msg";
     3306    if ($config{log_failures}) {
     3307      _log($dbh, %logdata);
     3308      $dbh->commit;
     3309    }
     3310    return ('FAIL', $logdata{entry});
     3311  } else {
     3312    return ('OK', $msg);
     3313  }
     3314} # end updateSOA()
     3315
     3316
     3317## DNSDB::getRecLine()
     3318# Return all data fields for a zone record in separate elements of a hash
     3319# Takes a database handle, default/live flag, forward/reverse flag, and record ID
     3320sub getRecLine {
     3321  $errstr = '';
     3322  my $dbh = shift;
     3323  my $defrec = shift;
     3324  my $revrec = shift;
     3325  my $id = shift;
     3326
     3327  my $sql = "SELECT record_id,host,type,val,ttl,location".($revrec eq 'n' ? ',distance,weight,port' : '').
     3328        (($defrec eq 'y') ? ',group_id FROM ' : ',domain_id,rdns_id FROM ').
     3329        _rectable($defrec,$revrec)." WHERE record_id=?";
     3330  my $ret = $dbh->selectrow_hashref($sql, undef, ($id) );
     3331
     3332  if ($dbh->err) {
     3333    $errstr = $DBI::errstr;
     3334    return undef;
     3335  }
     3336
     3337  if (!$ret) {
     3338    $errstr = "No such record";
     3339    return undef;
     3340  }
     3341
     3342  # explicitly set a parent id
     3343  if ($defrec eq 'y') {
     3344    $ret->{parid} = $ret->{group_id};
     3345  } else {
     3346    $ret->{parid} = (($revrec eq 'n') ? $ret->{domain_id} : $ret->{rdns_id});
     3347    # and a secondary if we have a custom type that lives in both a forward and reverse zone
     3348    $ret->{secid} = (($revrec eq 'y') ? $ret->{domain_id} : $ret->{rdns_id}) if $ret->{type} > 65279;
     3349  }
     3350
     3351  return $ret;
     3352}
     3353
     3354
     3355##fixme: should use above (getRecLine()) to get lines for below?
     3356## DNSDB::getDomRecs()
     3357# Return records for a domain
     3358# Takes a database handle, default/live flag, group/domain ID, start,
     3359# number of records, sort field, and sort order
     3360# Returns a reference to an array of hashes
     3361sub getDomRecs {
     3362  $errstr = '';
     3363  my $dbh = shift;
     3364
     3365  my %args = @_;
     3366
     3367  my @filterargs;
     3368
     3369  push @filterargs, $args{filter} if $args{filter};
     3370
     3371  # protection against bad or missing arguments
     3372  $args{sortorder} = 'ASC' if !$args{sortorder};
     3373  $args{sortby} = 'host' if !$args{sortby} && $args{revrec} eq 'n';     # default sort by host on domain record list
     3374  $args{sortby} = 'val' if !$args{sortby} && $args{revrec} eq 'y';      # default sort by IP on revzone record list
     3375  $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/; 
     3376
     3377  # sort reverse zones on IP, correctly
     3378  # do other fiddling with $args{sortby} while we're at it.
     3379  $args{sortby} = "r.$args{sortby}";
     3380  $args{sortby} = 'CAST (r.val AS inet)'
     3381        if $args{revrec} eq 'y' && $args{defrec} eq 'n' && $args{sortby} eq 'r.val';
     3382  $args{sortby} = 't.alphaorder' if $args{sortby} eq 'r.type';
     3383
     3384  my $sql = "SELECT r.record_id,r.host,r.type,r.val,r.ttl";
     3385  $sql .= ",l.description AS locname" if $args{defrec} eq 'n';
     3386  $sql .= ",r.distance,r.weight,r.port" if $args{revrec} eq 'n';
     3387  $sql .= " FROM "._rectable($args{defrec},$args{revrec})." r ";
     3388
     3389  # whee!  multisort means just passing comma-separated fields in sortby!
     3390  my $newsort = '';
     3391  foreach my $sf (split /,/, $order) {
     3392    $sf = "r.$sf";
     3393    $sf =~ s/r\.type/t.alphaorder/;
     3394    $newsort .= ",$sf";
     3395  }
     3396  $newsort =~ s/^,//;
     3397
     3398  $sql .= "INNER JOIN rectypes t ON r.type=t.val ";     # for sorting by type alphabetically
     3399  $sql .= "LEFT JOIN locations l ON r.location=l.location " if $args{defrec} eq 'n';
     3400  $sql .= "WHERE "._recparent($args{defrec},$args{revrec})." = ?";
     3401  $sql .= " AND NOT r.type=$reverse_typemap{SOA}";
     3402  $sql .= " AND host ~* ?" if $args{filter};
     3403  $sql .= " ORDER BY $args{sortby} $args{sortorder}";
     3404  # ensure consistent ordering by sorting on record_id too
     3405  $sql .= ", record_id $args{sortorder}";
     3406  $sql .= ($args{offset} eq 'all' ? '' : " LIMIT $config{perpage} OFFSET ".$args{offset}*$config{perpage});
     3407
     3408  my @bindvars = ($args{id});
     3409  push @bindvars, $args{filter} if $args{filter};
     3410
     3411  my $ret = $dbh->selectall_arrayref($sql, { Slice => {} }, (@bindvars) );
     3412  return $ret;
     3413} # end getDomRecs()
     3414
     3415
     3416## DNSDB::getRecCount()
     3417# Return count of non-SOA records in zone (or default records in a group)
     3418# Takes a database handle, default/live flag, reverse/forward flag, group/domain ID,
     3419# and optional filtering modifier
     3420# Returns the count
     3421sub getRecCount {
     3422  my $dbh = shift;
     3423  my $defrec = shift;
     3424  my $revrec = shift;
     3425  my $id = shift;
     3426  my $filter = shift || '';
     3427
     3428  # keep the nasties down, since we can't ?-sub this bit.  :/
     3429  # note this is chars allowed in DNS hostnames
     3430  $filter =~ s/[^a-zA-Z0-9_.:-]//g;
     3431
     3432  my @bindvars = ($id);
     3433  push @bindvars, $filter if $filter;
     3434  my $sql = "SELECT count(*) FROM ".
     3435        _rectable($defrec,$revrec).
     3436        " WHERE "._recparent($defrec,$revrec)."=? ".
     3437        "AND NOT type=$reverse_typemap{SOA}".
     3438        ($filter ? " AND host ~* ?" : '');
     3439  my ($count) = $dbh->selectrow_array($sql, undef, (@bindvars) );
     3440
     3441  return $count;
     3442
     3443} # end getRecCount()
     3444
     3445
     3446## DNSDB::addRec()
     3447# Add a new record to a domain or a group's default records
     3448# Takes a database handle, default/live flag, group/domain ID,
     3449# host, type, value, and TTL
     3450# Some types require additional detail: "distance" for MX and SRV,
     3451# and weight/port for SRV
     3452# Returns a status code and detail message in case of error
     3453##fixme:  pass a hash with the record data, not a series of separate values
     3454sub addRec {
     3455  $errstr = '';
     3456  my $dbh = shift;
     3457  my $defrec = shift;
     3458  my $revrec = shift;
     3459  my $id = shift;       # parent (group_id for defrecs, rdns_id for reverse records,
     3460                        # domain_id for domain records)
     3461
     3462  my $host = shift;
     3463  my $rectype = shift;  # reference so we can coerce it if "+"-types can't find both zones
     3464  my $val = shift;
     3465  my $ttl = shift;
     3466  my $location = shift;
     3467  $location  = '' if !$location;
     3468
     3469  # Spaces are evil.
     3470  $host =~ s/^\s+//;
     3471  $host =~ s/\s+$//;
     3472  if ($typemap{$rectype} ne 'TXT') {
     3473    # Leading or trailng spaces could be legit in TXT records.
     3474    $val =~ s/^\s+//;
     3475    $val =~ s/\s+$//;
     3476  }
     3477
     3478  # Validation
     3479  my $addr = NetAddr::IP->new($val);
     3480  if ($rectype == $reverse_typemap{A}) {
     3481    return ('FAIL',$typemap{$rectype}." record must be a valid IPv4 address")
     3482        unless $addr && !$addr->{isv6};
     3483  }
     3484  if ($rectype == $reverse_typemap{AAAA}) {
     3485    return ('FAIL',$typemap{$rectype}." record must be a valid IPv6 address")
     3486        unless $addr && $addr->{isv6};
     3487  }
     3488
     3489  my $domid = 0;
     3490  my $revid = 0;
     3491
     3492  my $retcode = 'OK';   # assume everything will go OK
     3493  my $retmsg = '';
     3494
     3495  # do simple validation first
     3496  return ('FAIL', "TTL must be numeric") unless $ttl =~ /^\d+$/;
     3497
     3498  # Quick check on hostname parts.  Note the regex is more forgiving than the error message;
     3499  # domain names technically are case-insensitive, and we use printf-like % codes for a couple
     3500  # of types.  Other things may also be added to validate default records of several flavours.
     3501  return ('FAIL', "Hostnames may not contain anything other than (0-9 a-z . _)")
     3502        if $defrec eq 'n' && ($revrec eq 'y' ? $$rectype != $reverse_typemap{TXT} : 1) &&
     3503                $$host !~ /^[0-9a-z_%.-]+$/i;
     3504
     3505  # Collect these even if we're only doing a simple A record so we can call *any* validation sub
     3506  my $dist = shift;
     3507  my $weight = shift;
     3508  my $port = shift;
     3509
     3510  my $fields;
     3511  my @vallist;
     3512
     3513  # Call the validation sub for the type requested.
     3514  ($retcode,$retmsg) = $validators{$$rectype}($dbh, (defrec => $defrec, revrec => $revrec, id => $id,
     3515        host => $host, rectype => $rectype, val => $val, addr => $addr,
     3516        dist => \$dist, port => \$port, weight => \$weight,
     3517        fields => \$fields, vallist => \@vallist) );
     3518
     3519  return ($retcode,$retmsg) if $retcode eq 'FAIL';
     3520
     3521  # Set up database fields and bind parameters
     3522  $fields .= "host,type,val,ttl,location,"._recparent($defrec,$revrec);
     3523  push @vallist, ($$host,$$rectype,$$val,$ttl,$location,$id);
     3524  my $vallen = '?'.(',?'x$#vallist);
     3525
     3526  # Put together the success log entry.  We have to use this horrible kludge
     3527  # because domain_id and rdns_id may or may not be present, and if they are,
     3528  # they're not at a guaranteed consistent index in the array.  wheee!
     3529  my %logdata;
     3530  my @ftmp = split /,/, $fields;
     3531  for (my $i=0; $i <= $#vallist; $i++) {
     3532    $logdata{domain_id} = $vallist[$i] if $ftmp[$i] eq 'domain_id';
     3533    $logdata{rdns_id} = $vallist[$i] if $ftmp[$i] eq 'rdns_id';
     3534  }
     3535  $logdata{group_id} = $id if $defrec eq 'y';
     3536  $logdata{group_id} = parentID($dbh,
     3537                (id => $id, type => ($revrec eq 'n' ? 'domain' : 'revzone'), revrec => $revrec) )
     3538        if $defrec eq 'n';
     3539  $logdata{entry} = "Added ".($defrec eq 'y' ? 'default record' : 'record');
     3540  # NS records for revzones get special treatment
     3541  if ($revrec eq 'y' && $$rectype == 2) {
     3542    $logdata{entry} .= " '$$val $typemap{$$rectype} $$host";
     3543  } else {
     3544    $logdata{entry} .= " '$$host $typemap{$$rectype} $$val";
     3545  }
     3546
     3547  $logdata{entry} .= " [distance $dist]" if $typemap{$$rectype} eq 'MX';
     3548  $logdata{entry} .= " [priority $dist] [weight $weight] [port $port]"
     3549        if $typemap{$$rectype} eq 'SRV';
     3550  $logdata{entry} .= "', TTL $ttl, location $location";
     3551
     3552  # Allow transactions, and raise an exception on errors so we can catch it later.
     3553  # Use local to make sure these get "reset" properly on exiting this block
     3554  local $dbh->{AutoCommit} = 0;
     3555  local $dbh->{RaiseError} = 1;
     3556
     3557  eval {
     3558    $dbh->do("INSERT INTO "._rectable($defrec, $revrec)." ($fields) VALUES ($vallen)",
     3559        undef, @vallist);
     3560    _log($dbh, %logdata);
     3561    $dbh->commit;
     3562  };
     3563  if ($@) {
     3564    my $msg = $@;
     3565    eval { $dbh->rollback; };
     3566    if ($config{log_failures}) {
     3567      $logdata{entry} = "Failed adding ".($defrec eq 'y' ? 'default ' : '').
     3568        "record '$$host $typemap{$$rectype} $$val', TTL $ttl ($msg)";
     3569      _log($dbh, %logdata);
     3570      $dbh->commit;
     3571    }
     3572    return ('FAIL',$msg);
     3573  }
     3574
     3575  $resultstr = $logdata{entry};
     3576  return ($retcode, $retmsg);
     3577
     3578} # end addRec()
     3579
     3580
     3581## DNSDB::updateRec()
     3582# Update a record
     3583# Takes a database handle, default and reverse flags, record ID, immediate parent ID, and new record data.
     3584# Returns a status code and message
     3585sub updateRec {
     3586  $errstr = '';
     3587
     3588  my $dbh = shift;
     3589  my $defrec = shift;
     3590  my $revrec = shift;
     3591  my $id = shift;
     3592  my $parid = shift;    # immediate parent entity that we're descending from to update the record
     3593
     3594  # all records have these
     3595  my $host = shift;
     3596  my $hostbk = $$host;  # Keep a backup copy of the original, so we can WARN if the update mangles the domain
     3597  my $rectype = shift;
     3598  my $val = shift;
     3599  my $ttl = shift;
     3600  my $location = shift; # may be empty/null/undef depending on caller
     3601  $location  = '' if !$location;
     3602
     3603  # prep for validation
     3604  my $addr = NetAddr::IP->new($$val);
     3605  $$host =~ s/\.+$//;   # FQDNs ending in . are an internal detail, and really shouldn't be exposed in the UI.
     3606
     3607  # Spaces are evil.
     3608  $host =~ s/^\s+//;
     3609  $host =~ s/\s+$//;
     3610  if ($typemap{$type} ne 'TXT') {
     3611    # Leading or trailng spaces could be legit in TXT records.
     3612    $val =~ s/^\s+//;
     3613    $val =~ s/\s+$//;
     3614  }
     3615
     3616  my $domid = 0;
     3617  my $revid = 0;
     3618
     3619  my $retcode = 'OK';   # assume everything will go OK
     3620  my $retmsg = '';
     3621
     3622  # do simple validation first
     3623  return ('FAIL', "TTL must be numeric") unless $ttl =~ /^\d+$/;
     3624
     3625  # Quick check on hostname parts.  Note the regex is more forgiving than the error message;
     3626  # domain names technically are case-insensitive, and we use printf-like % codes for a couple
     3627  # of types.  Other things may also be added to validate default records of several flavours.
     3628  return ('FAIL', "Hostnames may not contain anything other than (0-9 a-z - . _)")
     3629        if $defrec eq 'n' && ($revrec eq 'y' ? $$rectype != $reverse_typemap{TXT} : 1) &&
     3630                $$host !~ /^[0-9a-z_%.-]+$/i;
     3631
     3632  # only MX and SRV will use these
     3633  my $dist = shift || 0;
     3634  my $weight = shift || 0;
     3635  my $port = shift || 0;
     3636
     3637  my $fields;
     3638  my @vallist;
     3639
     3640  # get old record data so we have the right parent ID
     3641  # and for logging (eventually)
     3642  my $oldrec = getRecLine($dbh, $defrec, $revrec, $id);
     3643
     3644  # Call the validation sub for the type requested.
     3645  # Note the ID to pass here is the *parent*, not the record
     3646  ($retcode,$retmsg) = $validators{$$rectype}($dbh, (defrec => $defrec, revrec => $revrec,
     3647        id => ($defrec eq 'y' ? $oldrec->{group_id} : ($revrec eq 'n' ? $oldrec->{domain_id} : $oldrec->{rdns_id})),
     3648        host => $host, rectype => $rectype, val => $val, addr => $addr,
     3649        dist => \$dist, port => \$port, weight => \$weight,
     3650        fields => \$fields, vallist => \@vallist,
     3651        update => $id) );
     3652
     3653  return ($retcode,$retmsg) if $retcode eq 'FAIL';
     3654
     3655  # Set up database fields and bind parameters.  Note only the optional fields
     3656  # (distance, weight, port, secondary parent ID) are added in the validation call above
     3657  $fields .= "host,type,val,ttl,location,"._recparent($defrec,$revrec);
     3658  push @vallist, ($$host,$$rectype,$$val,$ttl,$location,
     3659        ($defrec eq 'y' ? $oldrec->{group_id} : ($revrec eq 'n' ? $oldrec->{domain_id} : $oldrec->{rdns_id})) );
     3660
     3661  # hack hack PTHUI
     3662  # need to forcibly make sure we disassociate a record with a parent it's no longer related to.
     3663  # eg, PTR records may not have a domain parent, or A/AAAA records may not have a revzone parent.
     3664  # mainly needed for crossover types that got coerced down to "standard" types
     3665  if ($defrec eq 'n') {
     3666    if ($$rectype == $reverse_typemap{PTR}) {
     3667      $fields .= ",domain_id";
     3668      push @vallist, 0;
     3669    }
     3670    if ($$rectype == $reverse_typemap{A} || $$rectype == $reverse_typemap{AAAA}) {
     3671      $fields .= ",rdns_id";
     3672      push @vallist, 0;
     3673    }
     3674  }
     3675  # fix fat-finger-originated record type changes
     3676  if ($$rectype == 65285) {
     3677    $fields .= ",rdns_id" if $revrec eq 'n';
     3678    $fields .= ",domain_id" if $revrec eq 'y';
     3679    push @vallist, 0;
     3680  }
     3681  if ($defrec eq 'n') {
     3682    $domid = $parid if $revrec eq 'n';
     3683    $revid = $parid if $revrec eq 'y';
     3684  }
     3685
     3686  # Put together the success log entry.  Horrible kludge from addRec() copied as-is since
     3687  # we don't know whether the passed arguments or retrieved values for domain_id and rdns_id
     3688  # will be maintained (due to "not-in-zone" validation changes)
     3689  my %logdata;
     3690  $logdata{domain_id} = $domid;
     3691  $logdata{rdns_id} = $revid;
     3692  my @ftmp = split /,/, $fields;
     3693  for (my $i=0; $i <= $#vallist; $i++) {
     3694    $logdata{domain_id} = $vallist[$i] if $ftmp[$i] eq 'domain_id';
     3695    $logdata{rdns_id} = $vallist[$i] if $ftmp[$i] eq 'rdns_id';
     3696  }
     3697  $logdata{group_id} = $parid if $defrec eq 'y';
     3698  $logdata{group_id} = parentID($dbh,
     3699                (id => $parid, type => ($revrec eq 'n' ? 'domain' : 'revzone'), revrec => $revrec) )
     3700        if $defrec eq 'n';
     3701  $logdata{entry} = "Updated ".($defrec eq 'y' ? 'default record' : 'record')." from\n";
     3702  # NS records for revzones get special treatment
     3703  if ($revrec eq 'y' && $$rectype == 2) {
     3704    $logdata{entry} .= " '$oldrec->{val} $typemap{$oldrec->{type}} $oldrec->{host}";
     3705  } else {
     3706    $logdata{entry} .= " '$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}";
     3707  }
     3708  $logdata{entry} .= " [distance $oldrec->{distance}]" if $typemap{$oldrec->{type}} eq 'MX';
     3709  $logdata{entry} .= " [priority $oldrec->{distance}] [weight $oldrec->{weight}] [port $oldrec->{port}]"
     3710        if $typemap{$oldrec->{type}} eq 'SRV';
     3711  $logdata{entry} .= "', TTL $oldrec->{ttl}, location $oldrec->{location}\nto\n";
     3712  # More NS special
     3713  if ($revrec eq 'y' && $$rectype == 2) {
     3714    $logdata{entry} .= "'$$val $typemap{$$rectype} $$host";
     3715  } else {
     3716    $logdata{entry} .= "'$$host $typemap{$$rectype} $$val";
     3717  }
     3718  $logdata{entry} .= " [distance $dist]" if $typemap{$$rectype} eq 'MX';
     3719  $logdata{entry} .= " [priority $dist] [weight $weight] [port $port]" if $typemap{$$rectype} eq 'SRV';
     3720  $logdata{entry} .= "', TTL $ttl, location $location";
     3721
     3722  local $dbh->{AutoCommit} = 0;
     3723  local $dbh->{RaiseError} = 1;
     3724
     3725  # Fiddle the field list into something suitable for updates
     3726  $fields =~ s/,/=?,/g;
     3727  $fields .= "=?";
     3728
     3729  eval {
     3730    $dbh->do("UPDATE "._rectable($defrec,$revrec)." SET $fields WHERE record_id=?", undef, (@vallist, $id) );
     3731    _log($dbh, %logdata);
     3732    $dbh->commit;
     3733  };
     3734  if ($@) {
     3735    my $msg = $@;
     3736    eval { $dbh->rollback; };
     3737    if ($config{log_failures}) {
     3738      $logdata{entry} = "Failed updating ".($defrec eq 'y' ? 'default ' : '').
     3739        "record '$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}', TTL $oldrec->{ttl} ($msg)";
     3740      _log($dbh, %logdata);
     3741      $dbh->commit;
     3742    }
     3743    return ('FAIL', $msg);
     3744  }
     3745
     3746  $resultstr = $logdata{entry};
     3747  return ($retcode, $retmsg);
     3748} # end updateRec()
     3749
     3750
     3751## DNSDB::delRec()
     3752# Delete a record. 
     3753sub delRec {
     3754  $errstr = '';
     3755  my $dbh = shift;
     3756  my $defrec = shift;
     3757  my $revrec = shift;
     3758  my $id = shift;
     3759
     3760  my $oldrec = getRecLine($dbh, $defrec, $revrec, $id);
     3761
     3762  # Allow transactions, and raise an exception on errors so we can catch it later.
     3763  # Use local to make sure these get "reset" properly on exiting this block
     3764  local $dbh->{AutoCommit} = 0;
     3765  local $dbh->{RaiseError} = 1;
     3766
     3767  # Put together the log entry
     3768  my %logdata;
     3769  $logdata{domain_id} = $oldrec->{domain_id};
     3770  $logdata{rdns_id} = $oldrec->{rdns_id};
     3771  $logdata{group_id} = $oldrec->{group_id} if $defrec eq 'y';
     3772  $logdata{group_id} = parentID($dbh,
     3773                (id => $oldrec->{domain_id}, type => ($revrec eq 'n' ? 'domain' : 'revzone'), revrec => $revrec) )
     3774        if $defrec eq 'n';
     3775  $logdata{entry} = "Deleted ".($defrec eq 'y' ? 'default record ' : 'record ').
     3776        "'$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}";
     3777  $logdata{entry} .= " [distance $oldrec->{distance}]" if $typemap{$oldrec->{type}} eq 'MX';
     3778  $logdata{entry} .= " [priority $oldrec->{distance}] [weight $oldrec->{weight}] [port $oldrec->{port}]"
     3779        if $typemap{$oldrec->{type}} eq 'SRV';
     3780  $logdata{entry} .= "', TTL $oldrec->{ttl}\n";
     3781
     3782  eval {
     3783    my $sth = $dbh->do("DELETE FROM "._rectable($defrec,$revrec)." WHERE record_id=?", undef, ($id));
     3784    _log($dbh, %logdata);
     3785    $dbh->commit;
     3786  };
     3787  if ($@) {
     3788    my $msg = $@;
     3789    eval { $dbh->rollback; };
     3790    if ($config{log_failures}) {
     3791      $logdata{entry} = "Error deleting ".($defrec eq 'y' ? 'default record' : 'record').
     3792        " '$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}', TTL $oldrec->{ttl} ($msg)";
     3793      _log($dbh, %logdata);
     3794      $dbh->commit;
     3795    }
     3796    return ('FAIL', $msg);
     3797  }
     3798
     3799  return ('OK',$logdata{entry});
     3800} # end delRec()
     3801
     3802
     3803## DNSDB::getLogCount()
     3804# Get a count of log entries
     3805# Takes a database handle and a hash containing at least:
     3806# - Entity ID and entity type as the primary log "slice"
     3807sub getLogCount {
     3808  my $dbh = shift;
     3809
     3810  my %args = @_;
     3811
     3812  my @filterargs;
     3813##fixme:  which fields do we want to filter on?
     3814# push @filterargs,
     3815
     3816  $errstr = 'Missing primary parent ID and/or type';
     3817  # fail early if we don't have a "prime" ID to look for log entries for
     3818  return if !$args{id};
     3819
     3820  # or if the prime id type is missing or invalid
     3821  return if !$args{logtype};
     3822  $args{logtype} = 'revzone' if $args{logtype} eq 'rdns';       # hack pthui
     3823  $args{logtype} = 'domain' if $args{logtype} eq 'dom';         # hack pthui
     3824  return if !grep /^$args{logtype}$/, ('group', 'domain', 'revzone', 'user');
     3825
     3826  $args{logtype} = 'revzone' if $args{logtype} eq 'rdns';       # hack pthui
     3827
     3828  my $sql = "SELECT count(*) FROM log ".
     3829        "WHERE $id_col{$args{logtype}}=?".
     3830        ($args{filter} ? " AND entry ~* ?" : '');
     3831  my ($count) = $dbh->selectrow_array($sql, undef, ($args{id}, @filterargs) );
     3832  $errstr = $dbh->errstr if !$count;
     3833  return $count;
     3834} # end getLogCount()
     3835
     3836
     3837## DNSDB::getLogEntries()
     3838# Get a list of log entries
     3839# Takes arguments as with getLogCount() above, plus optional:
     3840# - sort field
     3841# - sort order
     3842# - offset for pagination
     3843sub getLogEntries {
     3844  my $dbh = shift;
     3845
     3846  my %args = @_;
     3847
     3848  my @filterargs;
     3849
     3850  # fail early if we don't have a "prime" ID to look for log entries for
     3851  return if !$args{id};
     3852
     3853  # or if the prime id type is missing or invalid
     3854  return if !$args{logtype};
     3855  $args{logtype} = 'revzone' if $args{logtype} eq 'rdns';       # hack pthui
     3856  $args{logtype} = 'domain' if $args{logtype} eq 'dom';         # hack pthui
     3857  return if !grep /^$args{logtype}$/, ('group', 'domain', 'revzone', 'user');
     3858
     3859  # Sorting defaults
     3860  $args{sortby} = 'stamp' if !$args{sortby};
     3861  $args{sortorder} = 'DESC' if !$args{sortorder};
     3862  $args{offset} = 0 if !$args{offset} || $args{offset} !~ /^(?:all|\d+)$/;
     3863
     3864  my %sortmap = (fname => 'name', username => 'email', entry => 'entry', stamp => 'stamp');
     3865  $args{sortby} = $sortmap{$args{sortby}};
     3866
     3867  my $sql = "SELECT user_id AS userid, email AS useremail, name AS userfname, entry AS logentry, ".
     3868        "date_trunc('second',stamp) AS logtime ".
     3869        "FROM log ".
     3870        "WHERE $id_col{$args{logtype}}=?".
     3871        ($args{filter} ? " AND entry ~* ?" : '').
     3872        " ORDER BY $args{sortby} $args{sortorder}, log_id $args{sortorder}".
     3873        ($args{offset} eq 'all' ? '' : " LIMIT $config{perpage} OFFSET ".$args{offset}*$config{perpage});
     3874  my $loglist = $dbh->selectall_arrayref($sql, { Slice => {} }, ($args{id}, @filterargs) );
     3875  $errstr = $dbh->errstr if !$loglist;
     3876  return $loglist;
     3877} # end getLogEntries()
     3878
    23443879
    23453880## DNSDB::getTypelist()
    … …  
    25174052
    25184053
    2519 ## DNSDB::domStatus()
    2520 # Sets and/or returns a domain's status
    2521 # Takes a database handle, domain ID and optionally a status argument
    2522 # Returns undef on errors.
    2523 sub domStatus {
     4054## DNSDB::zoneStatus()
     4055# Returns and optionally sets a zone's status
     4056# Takes a database handle, domain/revzone ID, forward/reverse flag, and optionally a status argument
     4057# Returns status, or undef on errors.
     4058sub zoneStatus {
    25244059  my $dbh = shift;
    25254060  my $id = shift;
    2526   my $newstatus = shift;
     4061  my $revrec = shift;
     4062  my $newstatus = shift || 'mu';
    25274063
    25284064  return undef if $id !~ /^\d+$/;
    25294065
    2530   my $sth;
    2531 
    2532 # ooo, fun!  let's see what we were passed for status
    2533   if ($newstatus) {
    2534     $sth = $dbh->prepare("update domains set status=? where domain_id=?");
    2535     # ass-u-me caller knows what's going on in full
    2536     if ($newstatus =~ /^[01]$/) {       # only two valid for now.
    2537       $sth->execute($newstatus,$id);
    2538     } elsif ($newstatus =~ /^domo(?:n|ff)$/) {
    2539       $sth->execute(($newstatus eq 'domon' ? 1 : 0),$id);
    2540     }
    2541   }
    2542 
    2543   $sth = $dbh->prepare("select status from domains where domain_id=?");
    2544   $sth->execute($id);
    2545   my ($status) = $sth->fetchrow_array;
     4066  # Allow transactions, and raise an exception on errors so we can catch it later.
     4067  # Use local to make sure these get "reset" properly on exiting this block
     4068  local $dbh->{AutoCommit} = 0;
     4069  local $dbh->{RaiseError} = 1;
     4070
     4071  if ($newstatus ne 'mu') {
     4072    # ooo, fun!  let's see what we were passed for status
     4073    eval {
     4074      $newstatus = 0 if $newstatus eq 'domoff';
     4075      $newstatus = 1 if $newstatus eq 'domon';
     4076      $dbh->do("UPDATE ".($revrec eq 'n' ? 'domains' : 'revzones')." SET status=? WHERE ".
     4077        ($revrec eq 'n' ? 'domain_id' : 'rdns_id')."=?", undef, ($newstatus,$id) );
     4078
     4079##fixme  switch to more consise "Enabled <domain"/"Disabled <domain>" as with users?
     4080      $resultstr = "Changed ".($revrec eq 'n' ? domainName($dbh, $id) : revName($dbh, $id)).
     4081        " state to ".($newstatus ? 'active' : 'inactive');
     4082
     4083      my %loghash;
     4084      $loghash{domain_id} = $id if $revrec eq 'n';
     4085      $loghash{rdns_id} = $id if $revrec eq 'y';
     4086      $loghash{group_id} = parentID($dbh,
     4087        (id => $id, type => ($revrec eq 'n' ? 'domain' : 'revzone'), revrec => $revrec) );
     4088      $loghash{entry} = $resultstr;
     4089      _log($dbh, %loghash);
     4090
     4091      $dbh->commit;
     4092    };
     4093    if ($@) {
     4094      my $msg = $@;
     4095      eval { $dbh->rollback; };
     4096      $resultstr = '';
     4097      $errstr = $msg;
     4098      return;
     4099    }
     4100  }
     4101
     4102  my ($status) = $dbh->selectrow_array("SELECT status FROM ".
     4103        ($revrec eq 'n' ? "domains WHERE domain_id=?" : "revzones WHERE rdns_id=?"),
     4104        undef, ($id) );
    25464105  return $status;
    2547 } # end domStatus()
     4106} # end zoneStatus()
    25484107
    25494108
    … …  
    25614120  my $dbh = shift;
    25624121  my $ifrom_in = shift;
    2563   my $domain = shift;
     4122  my $zone = shift;
    25644123  my $group = shift;
    25654124  my $status = shift;
    … …  
    25694128  my $newttl = shift;
    25704129
     4130  my $merge = shift || 0;       # do we attempt to merge A/AAAA and PTR records whenever possible?
     4131                                # do we overload this with the fixme below?
    25714132##fixme:  add mode to delete&replace, merge+overwrite, merge new?
    25724133
    … …  
    25774138  my $ifrom;
    25784139
     4140  my $rev = 'n';
     4141  my $code = 'OK';
     4142  my $msg = 'foobar?';
     4143
    25794144  # choke on possible bad setting in ifrom
    25804145  # IPv4 and v6, and valid hostnames!
    … …  
    25834148        unless ($ifrom) = ($ifrom_in =~ /^([0-9a-f\:.]+|[0-9a-z_.-]+)$/i);
    25844149
     4150  my $errmsg;
     4151
     4152  my $zone_id;
     4153  my $domain_id = 0;
     4154  my $rdns_id = 0;
     4155  my $cidr;
     4156
     4157# magic happens!  detect if we're importing a domain or a reverse zone
     4158# while we're at it, figure out what the CIDR netblock is (if we got a .arpa)
     4159# or what the formal .arpa zone is (if we got a CIDR netblock)
     4160# Handles sub-octet v4 zones in the format specified in the Cricket Book, 2nd Ed, p217-218
     4161
     4162  if ($zone =~ m{(?:\.arpa\.?|/\d+)$}) {
     4163    # we seem to have a reverse zone
     4164    $rev = 'y';
     4165
     4166    if ($zone =~ /\.arpa\.?$/) {
     4167      # we have a formal reverse zone.  call _zone2cidr and get the CIDR block.
     4168      ($code,$msg) = _zone2cidr($zone);
     4169      return ($code, $msg) if $code eq 'FAIL';
     4170      $cidr = $msg;
     4171    } elsif ($zone =~ m|^[\d.]+/\d+$|) {
     4172      # v4 revzone, CIDR netblock
     4173      $cidr = NetAddr::IP->new($zone) or return ('FAIL',"$zone is not a valid CIDR block");
     4174      $zone = _ZONE($cidr, 'ZONE.in-addr.arpa', 'r', '.');
     4175    } elsif ($zone =~ m|^[a-fA-F\d:]+/\d+$|) {
     4176      # v6 revzone, CIDR netblock
     4177      $cidr = NetAddr::IP->new($zone) or return ('FAIL',"$zone is not a valid CIDR block");
     4178      return ('FAIL', "$zone is not a nibble-aligned block") if $cidr->masklen % 4 != 0;
     4179      $zone = _ZONE($cidr, 'ZONE.ip6.arpa', 'r', '.');
     4180    } else {
     4181      # there is. no. else!
     4182      return ('FAIL', "Unknown zone name format");
     4183    }
     4184
     4185    # quick check to start to see if we've already got one
     4186
     4187    ($zone_id) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet=?",
     4188        undef, ("$cidr"));
     4189    $rdns_id = $zone_id;
     4190  } else {
     4191    # default to domain
     4192    ($zone_id) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)",
     4193        undef, ($zone));
     4194    $domain_id = $zone_id;
     4195  }
     4196
     4197  return ('FAIL', ($rev eq 'n' ? 'Domain' : 'Reverse zone')." already exists") if $zone_id;
     4198
     4199  # little local utility sub to swap $val and $host for revzone records.
     4200  sub _revswap {
     4201    my $rechost = shift;
     4202    my $recdata = shift;
     4203
     4204    if ($rechost =~ /\.in-addr\.arpa\.?$/) {
     4205      $rechost =~ s/\.in-addr\.arpa\.?$//;
     4206      $rechost = join '.', reverse split /\./, $rechost;
     4207    } else {
     4208      $rechost =~ s/\.ip6\.arpa\.?$//;
     4209      my @nibs = reverse split /\./, $rechost;
     4210      $rechost = '';
     4211      my $nc;
     4212      foreach (@nibs) {
     4213        $rechost.= $_;
     4214        $rechost .= ":" if ++$nc % 4 == 0 && $nc < 32;
     4215      }
     4216      $rechost .= ":" if $nc < 32 && $rechost !~ /\*$/; # close netblock records?
     4217##fixme:  there's a case that ends up with a partial entry here:
     4218# ip:add:re:ss::
     4219# can't reproduce after letting it sit overnight after discovery.  :(
     4220#print "$rechost\n";
     4221      # canonicalize with NetAddr::IP
     4222      $rechost = NetAddr::IP->new($rechost)->addr unless $rechost =~ /\*$/;
     4223    }
     4224    return ($recdata,$rechost)
     4225  }
     4226
     4227
    25854228  # Allow transactions, and raise an exception on errors so we can catch it later.
    25864229  # Use local to make sure these get "reset" properly on exiting this block
    … …  
    25884231  local $dbh->{RaiseError} = 1;
    25894232
    2590   my $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
    2591   my $dom_id;
    2592 
    2593 # quick check to start to see if we've already got one
    2594   $sth->execute($domain);
    2595   ($dom_id) = $sth->fetchrow_array;
    2596 
    2597   return ('FAIL', "Domain already exists") if $dom_id;
    2598 
     4233  my $sth;
    25994234  eval {
    2600     # can't do this, can't nest transactions.  sigh.
    2601     #my ($dcode, $dmsg) = addDomain(dbh, domain, group, status);
    2602 
     4235
     4236    if ($rev eq 'n') {
    26034237##fixme:  serial
    2604     my $sth = $dbh->prepare("INSERT INTO domains (domain,group_id,status) VALUES (?,?,?)");
    2605     $sth->execute($domain,$group,$status);
     4238      $dbh->do("INSERT INTO domains (domain,group_id,status) VALUES (?,?,?)", undef, ($zone,$group,$status) );
     4239      # get domain id so we can do the records
     4240      ($zone_id) = $dbh->selectrow_array("SELECT currval('domains_domain_id_seq')");
     4241      $domain_id = $zone_id;
     4242      _log($dbh, (group_id => $group, domain_id => $domain_id,
     4243                entry => "[Added ".($status ? 'active' : 'inactive')." domain $zone via AXFR]") );
     4244    } else {
     4245##fixme:  serial
     4246      $dbh->do("INSERT INTO revzones (revnet,group_id,status) VALUES (?,?,?)", undef, ($cidr,$group,$status) );
     4247      # get revzone id so we can do the records
     4248      ($zone_id) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')");
     4249      $rdns_id = $zone_id;
     4250      _log($dbh, (group_id => $group, rdns_id => $rdns_id,
     4251                entry => "[Added ".($status ? 'active' : 'inactive')." reverse zone $cidr via AXFR]") );
     4252    }
    26064253
    26074254## bizarre DBI<->Net::DNS interaction bug:
    … …  
    26104257## caused a commit instead of barfing
    26114258
    2612     # get domain id so we can do the records
    2613     $sth = $dbh->prepare("SELECT domain_id FROM domains WHERE domain=?");
    2614     $sth->execute($domain);
    2615     ($dom_id) = $sth->fetchrow_array();
    2616 
    26174259    my $res = Net::DNS::Resolver->new;
    26184260    $res->nameservers($ifrom);
    2619     $res->axfr_start($domain)
     4261    $res->axfr_start($zone)
    26204262        or die "Couldn't begin AXFR\n";
    26214263
     4264    $sth = $dbh->prepare("INSERT INTO records (domain_id,rdns_id,host,type,val,distance,weight,port,ttl)".
     4265        " VALUES (?,?,?,?,?,?,?,?,?)");
     4266
     4267    # Stash info about sub-octet v4 revzones here so we don't have
     4268    # to store the CNAMEs used to delegate a suboctet zone
     4269    # $suboct{zone}{ns}[] -> array of nameservers
     4270    # $suboct{zone}{cname}[] -> array of extant CNAMEs (Just In Case someone did something bizarre)
     4271## commented pending actual use of this data.  for now, we'll just
     4272## auto-(re)create the CNAMEs in revzones on export
     4273#    my %suboct;
     4274
    26224275    while (my $rr = $res->axfr_next()) {
     4276
     4277      my $val;
     4278      my $distance = 0;
     4279      my $weight = 0;
     4280      my $port = 0;
     4281      my $logfrag = '';
     4282
    26234283      my $type = $rr->type;
    26244284      my $ttl = ($newttl ? $newttl : $rr->ttl); # allow force-override TTLs
    2625 
    2626       my $sql = "INSERT INTO records (domain_id,host,type,ttl,val";
    2627       my $vallen = "?,?,?,?,?";
     4285      my $host = $rr->name;
    26284286
    26294287      $soaflag = 1 if $type eq 'SOA';
    26304288      $nsflag = 1 if $type eq 'NS';
    2631 
    2632       my @vallist = ($dom_id, $rr->name, $reverse_typemap{$type}, $ttl);
    26334289
    26344290# "Primary" types:
    … …  
    26364292# maybe KEY
    26374293
     4294# BIND supports:
     4295# [standard]
     4296# A AAAA CNAME MX NS PTR SOA TXT
     4297# [variously experimental, obsolete, or obscure]
     4298# 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
     4299# ... if one can ever find the right magic to format them correctly
     4300
     4301# Net::DNS supports:
     4302# RRSIG SIG NSAP NS NIMLOC NAPTR MX MR MINFO MG MB LOC ISDN IPSECKEY HINFO
     4303# EID DNAME CNAME CERT APL AFSDB AAAA A DS NXT NSEC3PARAM NSEC3 NSEC KEY
     4304# DNSKEY DLV X25 TXT TSIG TKEY SSHFP SRV SPF SOA RT RP PX PTR NULL APL::AplItem
     4305
    26384306# nasty big ugly case-like thing here, since we have to do *some* different
    26394307# processing depending on the record.  le sigh.
    … …  
    26424310
    26434311      if ($type eq 'A') {
    2644         push @vallist, $rr->address;
     4312        $val = $rr->address;
    26454313      } elsif ($type eq 'NS') {
    26464314# hmm.  should we warn here if subdomain NS'es are left alone?
    2647         next if ($rwns && ($rr->name eq $domain));
    2648         push @vallist, $rr->nsdname;
     4315        next if ($rwns && ($rr->name eq $zone));
     4316        if ($rev eq 'y') {
     4317          # revzones have records more or less reversed from forward zones.
     4318          my ($tmpcode,$tmpmsg) = _zone2cidr($host);
     4319          die "Error converting NS record: $tmpmsg\n" if $tmpcode eq 'FAIL';    # hmm.  may not make sense...
     4320          $val = "$tmpmsg";
     4321          $host = $rr->nsdname;
     4322          $logfrag = "Added record '$val $type $host', TTL $ttl";
     4323# Tag and preserve.  For now this is commented for a no-op, but we have Ideas for
     4324# another custom storage type ("DELEGATE") that will use these subzone-delegation records
     4325#if ($val ne "$cidr") {
     4326#  push @{$suboct{$val}{ns}}, $host;
     4327#}
     4328        } else {
     4329          $val = $rr->nsdname;
     4330        }
    26494331        $nsflag = 1;
    26504332      } elsif ($type eq 'CNAME') {
    2651         push @vallist, $rr->cname;
     4333        if ($rev eq 'y') {
     4334          # hmm.  do we even want to bother with storing these at this level?  Sub-octet delegation
     4335          # by CNAME is essentially a record-publication hack, and we want to just represent the
     4336          # "true" logical intentions as far down the stack as we can from the UI.
     4337          ($host,$val) = _revswap($host,$rr->cname);
     4338          $logfrag = "Added record '$val $type $host', TTL $ttl";
     4339# Tag and preserve in case we want to commit them as-is later, but mostly we don't care.
     4340# Commented pending actually doing something with possibly new type DELEGATE
     4341#my $tmprev = $host;
     4342#$tmprev =~ s/^\d+\.//;
     4343#($code,$tmprev) = _zone2cidr($tmprev);
     4344#push @{$suboct{"$tmprev"}{cname}}, $val;
     4345          # Silently skip CNAMEs in revzones.
     4346          next;
     4347        } else {
     4348          $val = $rr->cname;
     4349        }
    26524350      } elsif ($type eq 'SOA') {
    26534351        next if $rwsoa;
    2654         $vallist[1] = $rr->mname.":".$rr->rname;
    2655         push @vallist, ($rr->refresh.":".$rr->retry.":".$rr->expire.":".$rr->minimum);
     4352        $host = $rr->rname.":".$rr->mname;
     4353        $val = $rr->refresh.":".$rr->retry.":".$rr->expire.":".$rr->minimum;
    26564354        $soaflag = 1;
    26574355      } elsif ($type eq 'PTR') {
    2658         push @vallist, $rr->ptrdname;
     4356        ($host,$val) = _revswap($host,$rr->ptrdname);
     4357        $logfrag = "Added record '$val $type $host', TTL $ttl";
    26594358        # hmm.  PTR records should not be in forward zones.
    26604359      } elsif ($type eq 'MX') {
    2661         $sql .= ",distance";
    2662         $vallen .= ",?";
    2663         push @vallist, $rr->exchange;
    2664         push @vallist, $rr->preference;
     4360        $val = $rr->exchange;
     4361        $distance = $rr->preference;
    26654362      } elsif ($type eq 'TXT') {
    26664363##fixme:  Net::DNS docs say this should be deprecated for rdatastr() or char_str_list(),
    26674364## but don't really seem enthusiastic about it.
    2668         my $rrdata = $rr->txtdata;
    2669         push @vallist, $rrdata;
     4365#print "should use rdatastr:\n\t".$rr->rdatastr."\n  or char_str_list:\n\t".join(' ',$rr->char_str_list())."\n";
     4366# rdatastr returns a BIND-targetted logical string, including opening and closing quotes
     4367# char_str_list returns a list of the individual string fragments in the record
     4368# txtdata returns the more useful all-in-one form (since we want to push such protocol
     4369# details as far down the stack as we can)
     4370# NB:  this may turn out to be more troublesome if we ever have need of >512-byte TXT records.
     4371        if ($rev eq 'y') {
     4372          ($host,$val) = _revswap($host,$rr->txtdata);
     4373          $logfrag = "Added record '$val $type $host', TTL $ttl";
     4374        } else {
     4375          $val = $rr->txtdata;
     4376        }
    26704377      } elsif ($type eq 'SPF') {
    26714378##fixme: and the same caveat here, since it is apparently a clone of ::TXT
    2672         my $rrdata = $rr->txtdata;
    2673         push @vallist, $rrdata;
     4379        $val = $rr->txtdata;
    26744380      } elsif ($type eq 'AAAA') {
    2675         push @vallist, $rr->address;
     4381        $val = $rr->address;
    26764382      } elsif ($type eq 'SRV') {
    2677         $sql .= ",distance,weight,port" if $type eq 'SRV';
    2678         $vallen .= ",?,?,?" if $type eq 'SRV';
    2679         push @vallist, $rr->target;
    2680         push @vallist, $rr->priority;
    2681         push @vallist, $rr->weight;
    2682         push @vallist, $rr->port;
     4383        $val = $rr->target;
     4384        $distance = $rr->priority;
     4385        $weight = $rr->weight;
     4386        $port = $rr->port;
    26834387      } elsif ($type eq 'KEY') {
    26844388        # we don't actually know what to do with these...
    2685         push @vallist, ($rr->flags.":".$rr->protocol.":".$rr->algorithm.":".$rr->key.":".$rr->keytag.":".$rr->privatekeyname);
     4389        $val = $rr->flags.":".$rr->protocol.":".$rr->algorithm.":".$rr->key.":".$rr->keytag.":".$rr->privatekeyname;
    26864390      } else {
    2687         my $rrdata = $rr->rdatastr;
    2688         push @vallist, $rrdata;
     4391        $val = $rr->rdatastr;
    26894392        # Finding a different record type is not fatal.... just problematic.
    26904393        # We may not be able to export it correctly.
    … …  
    26924395      }
    26934396
    2694 # BIND supports:
    2695 # A CNAME HINFO MB(ex) MD(ob) MF(ob) MG(ex) MINFO(ex) MR(ex) MX NS NULL
    2696 # PTR SOA TXT WKS AFSDB(ex) ISDN(ex) RP(ex) RT(ex) X25(ex) PX
    2697 # ... if one can ever find the right magic to format them correctly
    2698 
    2699 # Net::DNS supports:
    2700 # RRSIG SIG NSAP NS NIMLOC NAPTR MX MR MINFO MG MB LOC ISDN IPSECKEY HINFO
    2701 # EID DNAME CNAME CERT APL AFSDB AAAA A DS NXT NSEC3PARAM NSEC3 NSEC KEY
    2702 # DNSKEY DLV X25 TXT TSIG TKEY SSHFP SRV SPF SOA RT RP PX PTR NULL APL::AplItem
    2703 
    2704       $sth = $dbh->prepare($sql.") VALUES (".$vallen.")") or die "problem preparing record insert SQL\n";
    2705       $sth->execute(@vallist) or die "failed to insert ".$rr->string.": ".$sth->errstr."\n";
     4397      my $logentry = "[AXFR ".($rev eq 'n' ? $zone : $cidr)."] ";
     4398
     4399      if ($merge) {
     4400        if ($rev eq 'n') {
     4401          # importing a domain;  we have A and AAAA records that could be merged with matching PTR records
     4402          my $etype;
     4403          my ($erdns,$erid,$ettl) = $dbh->selectrow_array("SELECT rdns_id,record_id,ttl FROM records ".
     4404                "WHERE host=? AND val=? AND type=12",
     4405                undef, ($host, $val) );
     4406          if ($erid) {
     4407            if ($type eq 'A') { # PTR -> A+PTR
     4408              $etype = 65280;
     4409              $logentry .= "Merged A record with existing PTR record '$host A+PTR $val', TTL $ettl";
     4410            }
     4411            if ($type eq 'AAAA') {      # PTR -> AAAA+PTR
     4412              $etype = 65281;
     4413              $logentry .= "Merged AAAA record with existing PTR record '$host AAAA+PTR $val', TTL $ettl";
     4414            }
     4415            $ettl = ($ettl < $ttl ? $ettl : $ttl);    # use lower TTL
     4416            $dbh->do("UPDATE records SET domain_id=?,ttl=?,type=? WHERE record_id=?", undef,
     4417                ($domain_id, $ettl, $etype, $erid));
     4418            $nrecs++;
     4419            _log($dbh, (group_id => $group, domain_id => $domain_id, rdns_id => $erdns, entry => $logentry) );
     4420            next;       # while axfr_next
     4421          }
     4422        } # $rev eq 'n'
     4423        else {
     4424          # importing a revzone, we have PTR records that could be merged with matching A/AAAA records
     4425          my ($domid,$erid,$ettl,$etype) = $dbh->selectrow_array("SELECT domain_id,record_id,ttl,type FROM records ".
     4426                "WHERE host=? AND val=? AND (type=1 OR type=28)",
     4427                undef, ($host, $val) );
     4428          if ($erid) {
     4429            if ($etype == 1) {  # A -> A+PTR
     4430              $etype = 65280;
     4431              $logentry .= "Merged PTR record with existing matching A record '$host A+PTR $val', TTL $ettl";
     4432            }
     4433            if ($etype == 28) { # AAAA -> AAAA+PTR
     4434              $etype = 65281;
     4435              $logentry .= "Merged PTR record with existing matching AAAA record '$host AAAA+PTR $val', TTL $ettl";
     4436            }
     4437            $ettl = ($ettl < $ttl ? $ettl : $ttl);    # use lower TTL
     4438            $dbh->do("UPDATE records SET rdns_id=?,ttl=?,type=? WHERE record_id=?", undef,
     4439                ($rdns_id, $ettl, $etype, $erid));
     4440            $nrecs++;
     4441            _log($dbh, (group_id => $group, domain_id => $domid, rdns_id => $rdns_id, entry => $logentry) );
     4442            next;       # while axfr_next
     4443          }
     4444        } # $rev eq 'y'
     4445      } # if $merge
     4446
     4447      # Insert the new record
     4448      $sth->execute($domain_id, $rdns_id, $host, $reverse_typemap{$type}, $val,
     4449        $distance, $weight, $port, $ttl);
    27064450
    27074451      $nrecs++;
    27084452
     4453      if ($type eq 'SOA') {
     4454        # also !$rwsoa, but if that's set, it should be impossible to get here.
     4455        my @tmp1 = split /:/, $host;
     4456        my @tmp2 = split /:/, $val;
     4457        $logentry .= "Added SOA record [contact $tmp1[0]] [master $tmp1[1]] ".
     4458                "[refresh $tmp2[0]] [retry $tmp2[1]] [expire $tmp2[2]] [minttl $tmp2[3]], TTL $ttl";
     4459      } elsif ($logfrag) {
     4460        # special case for log entries we need to meddle with a little.
     4461        $logentry .= $logfrag;
     4462      } else {
     4463        $logentry .= "Added record '$host $type";
     4464        $logentry .= " [distance $distance]" if $type eq 'MX';
     4465        $logentry .= " [priority $distance] [weight $weight] [port $port]" if $type eq 'SRV';
     4466        $logentry .= " $val', TTL $ttl";
     4467      }
     4468      _log($dbh, (group_id => $group, domain_id => $domain_id, rdns_id => $rdns_id, entry => $logentry) );
     4469
    27094470    } # while axfr_next
     4471
     4472# Detect and handle delegated subzones
     4473# Placeholder for when we decide what to actually do with this, see previous comments in NS and CNAME handling.
     4474#foreach (keys %suboct) {
     4475#  print "found ".($suboct{$_}{ns} ? @{$suboct{$_}{ns}} : '0')." NS records and ".
     4476#       ($suboct{$_}{cname} ? @{$suboct{$_}{cname}} : '0')." CNAMEs for $_\n";
     4477#}
    27104478
    27114479    # Overwrite SOA record
    … …  
    27164484      $sthgetsoa->execute($group,$reverse_typemap{SOA});
    27174485      while (my ($host,$val,$ttl) = $sthgetsoa->fetchrow_array()) {
    2718         $host =~ s/DOMAIN/$domain/g;
    2719         $val =~ s/DOMAIN/$domain/g;
    2720         $sthputsoa->execute($dom_id,$host,$reverse_typemap{SOA},$val,$ttl);
     4486        $host =~ s/DOMAIN/$zone/g;
     4487        $val =~ s/DOMAIN/$zone/g;
     4488        $sthputsoa->execute($zone_id,$host,$reverse_typemap{SOA},$val,$ttl);
    27214489      }
    27224490    }
    … …  
    27294497      $sthgetns->execute($group,$reverse_typemap{NS});
    27304498      while (my ($host,$val,$ttl) = $sthgetns->fetchrow_array()) {
    2731         $host =~ s/DOMAIN/$domain/g;
    2732         $val =~ s/DOMAIN/$domain/g;
    2733         $sthputns->execute($dom_id,$host,$reverse_typemap{NS},$val,$ttl);
     4499        $host =~ s/DOMAIN/$zone/g;
     4500        $val =~ s/DOMAIN/$zone/g;
     4501        $sthputns->execute($zone_id,$host,$reverse_typemap{NS},$val,$ttl);
    27344502      }
    27354503    }
    … …  
    27574525
    27584526
     4527## DNSDB::importBIND()
     4528sub importBIND {
     4529} # end importBIND()
     4530
     4531
     4532## DNSDB::import_tinydns()
     4533sub import_tinydns {
     4534} # end import_tinydns()
     4535
     4536
    27594537## DNSDB::export()
    27604538# Export the DNS database, or a part of it
    … …  
    27854563
    27864564##fixme: slurp up further options to specify particular zone(s) to export
     4565
     4566##fixme: fail if $datafile isn't an open, writable file
     4567
     4568  # easy case - export all evarything
     4569  # not-so-easy case - export item(s) specified
     4570  # todo:  figure out what kind of list we use to export items
     4571
     4572# raw packet in unknown format:  first byte indicates length
     4573# of remaining data, allows up to 255 raw bytes
     4574
     4575  # Locations/views - worth including in the caching setup?
     4576  my $lochash = $dbh->selectall_hashref("SELECT location,iplist FROM locations", 'location');
     4577  foreach my $location (keys %$lochash) {
     4578    foreach my $ipprefix (split /[,\s]+/, $lochash->{$location}{iplist}) {
     4579      $ipprefix =~ s/\s+//g;
     4580      print $datafile "%$location:$ipprefix\n";
     4581    }
     4582    print $datafile "%$location\n" if !$lochash->{$location}{iplist};
     4583  }
     4584
     4585  # tracking hash so we don't double-export A+PTR or AAAA+PTR records.
     4586  my %recflags;
     4587
     4588  my $domsth = $dbh->prepare("SELECT domain_id,domain,status,changed FROM domains WHERE status=1");
     4589  my $recsth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl,record_id,location ".
     4590        "FROM records WHERE domain_id=? AND type < 65280");     # Just exclude all types relating to rDNS
     4591  my $zonesth = $dbh->prepare("UPDATE domains SET changed='n' WHERE domain_id=?");
     4592  $domsth->execute();
     4593  while (my ($domid,$dom,$domstat,$changed) = $domsth->fetchrow_array) {
     4594##fixme: need to find a way to block opening symlinked files without introducing a race.
     4595#       O_NOFOLLOW
     4596#              If  pathname  is a symbolic link, then the open fails.  This is a FreeBSD extension, which was
     4597#              added to Linux in version 2.1.126.  Symbolic links in earlier components of the pathname  will
     4598#              still be followed.
     4599# but that doesn't help other platforms.  :/
     4600    sysopen(ZONECACHE, "$config{exportcache}/$dom", O_RDWR|O_CREAT);
     4601    flock(ZONECACHE, LOCK_EX);
     4602    if ($changed || -s "$config{exportcache}/$dom" == 0) {
     4603      $recsth->execute($domid);
     4604      while (my ($host,$type,$val,$dist,$weight,$port,$ttl,$recid,$loc) = $recsth->fetchrow_array) {
     4605        next if $recflags{$recid};
     4606
     4607        $loc = '' if !$loc;     # de-nullify - just in case
     4608##fixme:  handle case of record-with-location-that-doesn't-exist better.
     4609# note this currently fails safe (tested) - records with a location that
     4610# doesn't exist will not be sent to any client
     4611#       $loc = '' if !$lochash->{$loc};
     4612
     4613##fixme:  record validity timestamp. tinydns supports fiddling with timestamps.
     4614# note $ttl must be set to 0 if we want to use tinydns's auto-expiring timestamps.
     4615# timestamps are TAI64
     4616# ~~ 2^62 + time()
     4617        my $stamp = '';
     4618
     4619        # support tinydns' auto-TTL
     4620        $ttl = '' if $ttl == '0';
     4621
     4622        _printrec_tiny($datafile, 'n', \%recflags,
     4623                $dom, $host, $type, $val, $dist, $weight, $port, $ttl, $loc, $stamp);
     4624
     4625        _printrec_tiny(*ZONECACHE, 'n', \%recflags,
     4626                $dom, $host, $type, $val, $dist, $weight, $port, $ttl, $loc, $stamp)
     4627                if *ZONECACHE;
     4628        # in case the zone shrunk, get rid of garbage at the end of the file.
     4629        truncate(ZONECACHE, tell(ZONECACHE));
     4630
     4631        $recflags{$recid} = 1;
     4632      } # while ($recsth)
     4633    } else {
     4634      # domain not changed, stream from cache
     4635      print $datafile $_ while <ZONECACHE>;
     4636    }
     4637    close ZONECACHE;
     4638    # mark domain as unmodified
     4639    $zonesth->execute($domid);
     4640  } # while ($domsth)
     4641
     4642  my $revsth = $dbh->prepare("SELECT rdns_id,revnet,status,changed FROM revzones WHERE status=1 ".
     4643        "ORDER BY masklen(revnet) DESC");
     4644
     4645# For reasons unknown, we can't sanely UNION these statements.  Feh.
     4646# Supposedly it should work though (note last 3 lines):
     4647## PG manual
     4648#UNION Clause
     4649#
     4650#The UNION clause has this general form:
     4651#
     4652#    select_statement UNION [ ALL ] select_statement
     4653#
     4654#select_statement is any SELECT statement without an ORDER BY, LIMIT, FOR UPDATE, or FOR SHARE clause. (ORDER BY
     4655#and LIMIT can be attached to a subexpression if it is enclosed in parentheses. Without parentheses, these
     4656#clauses will be taken to apply to the result of the UNION, not to its right-hand input expression.)
     4657  my $soasth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl,record_id,location ".
     4658        "FROM records WHERE rdns_id=? AND type=6");
     4659  $recsth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl,record_id,location ".
     4660        "FROM records WHERE rdns_id=? AND not type=6 ".
     4661        "ORDER BY masklen(CAST(val AS inet)) DESC, CAST(val AS inet)");
     4662  $zonesth = $dbh->prepare("UPDATE revzones SET changed='n' WHERE rdns_id=?");
     4663  $revsth->execute();
     4664  while (my ($revid,$revzone,$revstat,$changed) = $revsth->fetchrow_array) {
     4665##fixme: need to find a way to block opening symlinked files without introducing a race.
     4666#       O_NOFOLLOW
     4667#              If  pathname  is a symbolic link, then the open fails.  This is a FreeBSD extension, which was
     4668#              added to Linux in version 2.1.126.  Symbolic links in earlier components of the pathname  will
     4669#              still be followed.
     4670# but that doesn't help other platforms.  :/
     4671    my $tmpzone = NetAddr::IP->new($revzone);
     4672    sysopen(ZONECACHE, "$config{exportcache}/".$tmpzone->network->addr, O_RDWR|O_CREAT);
     4673    flock(ZONECACHE, LOCK_EX);
     4674    if ($changed || -s "$config{exportcache}/".$tmpzone->network->addr == 0) {
     4675      # need to fetch this separately since the rest of the records all (should) have real IPs in val
     4676      $soasth->execute($revid);
     4677      my (@zsoa) = $soasth->fetchrow_array();
     4678      _printrec_tiny($datafile,'y',\%recflags,$revzone,
     4679        $zsoa[0],$zsoa[1],$zsoa[2],$zsoa[3],$zsoa[4],$zsoa[5],$zsoa[6],$zsoa[8],'');
     4680
     4681      $recsth->execute($revid);
     4682      while (my ($host,$type,$val,$dist,$weight,$port,$ttl,$recid,$loc) = $recsth->fetchrow_array) {
     4683        next if $recflags{$recid};
     4684
     4685        $loc = '' if !$loc;     # de-nullify - just in case
     4686##fixme:  handle case of record-with-location-that-doesn't-exist better.
     4687# note this currently fails safe (tested) - records with a location that
     4688# doesn't exist will not be sent to any client
     4689#       $loc = '' if !$lochash->{$loc};
     4690
     4691##fixme:  record validity timestamp. tinydns supports fiddling with timestamps.
     4692# note $ttl must be set to 0 if we want to use tinydns's auto-expiring timestamps.
     4693# timestamps are TAI64
     4694# ~~ 2^62 + time()
     4695        my $stamp = '';
     4696
     4697        # support tinydns' auto-TTL
     4698        $ttl = '' if $ttl == '0';
     4699
     4700        _printrec_tiny($datafile, 'y', \%recflags, $revzone,
     4701                $host, $type, $val, $dist, $weight, $port, $ttl, $loc, $stamp);
     4702        _printrec_tiny(*ZONECACHE, 'y', \%recflags, $revzone,
     4703                $host, $type, $val, $dist, $weight, $port, $ttl, $loc, $stamp)
     4704                if *ZONECACHE;
     4705        # in case the zone shrunk, get rid of garbage at the end of the file.
     4706        truncate(ZONECACHE, tell(ZONECACHE));
     4707
     4708        $recflags{$recid} = 1;
     4709      } # while ($recsth)
     4710    } else {
     4711      # zone not changed, stream from cache
     4712      print $datafile $_ while <ZONECACHE>;
     4713    }
     4714    close ZONECACHE;
     4715    # mark domain as unmodified
     4716    $zonesth->execute($revid);
     4717  } # while ($domsth)
     4718
     4719} # end __export_tiny()
     4720
     4721
     4722# Utility sub for __export_tiny above
     4723sub _printrec_tiny {
     4724  my ($datafile,$revrec,$recflags,$zone,$host,$type,$val,$dist,$weight,$port,$ttl,$loc,$stamp) = @_;
    27874725
    27884726  ## Convert a bare number into an octal-coded pair of octets.
    … …  
    27974735  }
    27984736
    2799 ##fixme: fail if $datafile isn't an open, writable file
    2800 
    2801   # easy case - export all evarything
    2802   # not-so-easy case - export item(s) specified
    2803   # todo:  figure out what kind of list we use to export items
    2804 
    2805   my $domsth = $dbh->prepare("SELECT domain_id,domain,status FROM domains WHERE status=1");
    2806   my $recsth = $dbh->prepare("SELECT host,type,val,distance,weight,port,ttl ".
    2807         "FROM records WHERE domain_id=?");
    2808   $domsth->execute();
    2809   while (my ($domid,$dom,$domstat) = $domsth->fetchrow_array) {
    2810     $recsth->execute($domid);
    2811     while (my ($host,$type,$val,$dist,$weight,$port,$ttl) = $recsth->fetchrow_array) {
    2812 ##fixme:  need to store location in the db, and retrieve it here.
    2813 # temporarily hardcoded to empty so we can include it further down.
    2814 my $loc = '';
    2815 
    2816 ##fixme:  record validity timestamp. tinydns supports fiddling with timestamps.
    2817 # note $ttl must be set to 0 if we want to use tinydns's auto-expiring timestamps.
    2818 # timestamps are TAI64
    2819 # ~~ 2^62 + time()
    2820 my $stamp = '';
    2821 
    2822 # raw packet in unknown format:  first byte indicates length
    2823 # of remaining data, allows up to 255 raw bytes
    2824 
    2825         # Spaces are evil.
    2826         $host =~ s/^\s+//;
    2827         $host =~ s/\s+$//;
    2828         if ($typemap{$type} ne 'TXT') {
    2829           # Leading or trailng spaces could be legit in TXT records.
    2830           $val =~ s/^\s+//;
    2831           $val =~ s/\s+$//;
    2832         }
     4737## WARNING:  This works to export even the whole Internet's worth of IP space...
     4738##  if you have the disk/RAM to handle the dataset, and you call this sub based on /16-sized chunks
     4739##  A /16 took ~3 seconds with a handful of separate records;  adding a /8 pushed export time out to ~13m:40s
     4740##  0/0 is estimated to take ~54 hours and ~256G of disk
     4741##  RAM usage depends on how many non-template entries you have in the set.
     4742##  This should probably be done on record addition rather than export;  large blocks may need to be done in a
     4743##  forked process
     4744  sub __publish_subnet {
     4745    my $sub = shift;
     4746    my $recflags = shift;
     4747    my $hpat = shift;
     4748    my $fh = shift;
     4749    my $ttl = shift;
     4750    my $stamp = shift;
     4751    my $loc = shift;
     4752    my $ptronly = shift || 0;
     4753
     4754    my $iplist = $sub->splitref(32);
     4755    foreach (@$iplist) {
     4756      my $ip = $_->addr;
     4757      # make as if we split the non-octet-aligned block into octet-aligned blocks as with SOA
     4758      next if $ip =~ /\.(0|255)$/;
     4759      next if $$recflags{$ip};
     4760      $$recflags{$ip}++;
     4761      my $rec = $hpat;  # start fresh with the template for each IP
     4762      _template4_expand(\$rec, $ip);
     4763      print $fh ($ptronly ? "^"._ZONE($_, 'ZONE.in-addr.arpa', 'r', '.').":$rec" : "=$rec:$ip").
     4764        ":$ttl:$stamp:$loc\n";
     4765    }
     4766  }
    28334767
    28344768##fixme?  append . to all host/val hostnames
    … …  
    28414775        my ($email, $primary) = (split /:/, $host)[0,1];
    28424776        my ($refresh, $retry, $expire, $min_ttl) = (split /:/, $val)[0,1,2,3];
    2843         print $datafile "Z$dom:$primary:$email"."::$refresh:$retry:$expire:$min_ttl:$ttl:$stamp:$loc\n";
     4777        if ($revrec eq 'y') {
     4778##fixme:  have to publish SOA records for each v4 /24 in sub-/16, and each /16 in sub-/8
     4779# what about v6?
     4780# -> only need SOA for local chunks offset from reverse delegation boundaries, so v6 is fine
     4781          $zone = NetAddr::IP->new($zone);
     4782          # handle split-n-multiply SOA for off-octet (8 < mask < 16) or (16 < mask < 24) v4 zones
     4783          if (!$zone->{isv6} && ($zone->masklen < 24) && ($zone->masklen % 8 != 0)) {
     4784            foreach my $szone ($zone->split($zone->masklen + (8 - $zone->masklen % 8))) {
     4785              $szone = _ZONE($szone, 'ZONE.in-addr.arpa', 'r', '.');
     4786              print $datafile "Z$szone:$primary:$email"."::$refresh:$retry:$expire:$min_ttl:$ttl:$stamp:$loc\n";
     4787            }
     4788            return; # skips "default" bits just below
     4789          }
     4790          $zone = _ZONE($zone, 'ZONE', 'r', '.').($zone->{isv6} ? '.ip6.arpa' : '.in-addr.arpa');
     4791        }
     4792        print $datafile "Z$zone:$primary:$email"."::$refresh:$retry:$expire:$min_ttl:$ttl:$stamp:$loc\n";
    28444793
    28454794      } elsif ($typemap{$type} eq 'A') {
    … …  
    28494798      } elsif ($typemap{$type} eq 'NS') {
    28504799
    2851         print $datafile "\&$host"."::$val:$ttl:$stamp:$loc\n";
     4800        if ($revrec eq 'y') {
     4801          $val = NetAddr::IP->new($val);
     4802          # handle split-n-multiply SOA for off-octet (8 < mask < 16) or (16 < mask < 24) v4 zones
     4803          if (!$val->{isv6} && ($val->masklen < 24) && ($val->masklen % 8 != 0)) {
     4804            foreach my $szone ($val->split($val->masklen + (8 - $val->masklen % 8))) {
     4805              my $szone2 = _ZONE($szone, 'ZONE.in-addr.arpa', 'r', '.');
     4806              next if $$recflags{$szone2} && $$recflags{$szone2} > $val->masklen;
     4807              print $datafile "\&$szone2"."::$host:$ttl:$stamp:$loc\n";
     4808              $$recflags{$szone2} = $val->masklen;
     4809            }
     4810          } elsif ($val->{isv6} && ($val->masklen < 64) && ($val->masklen % 4 !=0)) {
     4811            foreach my $szone ($val->split($val->masklen + (4 - $val->masklen % 4))) {
     4812              my $szone2 = _ZONE($szone, 'ZONE.ip6.arpa', 'r', '.');
     4813              next if $$recflags{$szone2} && $$recflags{$szone2} > $val->masklen;
     4814              print $datafile "\&$szone2"."::$host:$ttl:$stamp:$loc\n";
     4815              $$recflags{$szone2} = $val->masklen;
     4816            }
     4817          } else {
     4818            my $val2 = _ZONE($val, 'ZONE', 'r', '.').($val->{isv6} ? '.ip6.arpa' : '.in-addr.arpa');
     4819            print $datafile "\&$val2"."::$host:$ttl:$stamp:$loc\n";
     4820            $$recflags{$val2} = $val->masklen;
     4821          }
     4822        } else {
     4823          print $datafile "\&$host"."::$val:$ttl:$stamp:$loc\n";
     4824        }
    28524825
    28534826      } elsif ($typemap{$type} eq 'AAAA') {
    … …  
    28814854
    28824855##fixme:  split v-e-r-y long TXT strings?  will need to do so for BIND export, at least
    2883         $val =~ s/:/\\072/g;    # may need to replace other symbols
    2884         print $datafile "'$host:$val:$ttl:$stamp:$loc\n";
     4856        if ($revrec eq 'n') {
     4857          $val =~ s/:/\\072/g;  # may need to replace other symbols
     4858          print $datafile "'$host:$val:$ttl:$stamp:$loc\n";
     4859        } else {
     4860          $host =~ s/:/\\072/g; # may need to replace other symbols
     4861          my $val2 = NetAddr::IP->new($val);
     4862          print $datafile "'"._ZONE($val2, 'ZONE', 'r', '.').($val2->{isv6} ? '.ip6.arpa' : '.in-addr.arpa').
     4863                ":$host:$ttl:$stamp:$loc\n";
     4864        }
    28854865
    28864866# by-hand TXT
    … …  
    29034883      } elsif ($typemap{$type} eq 'CNAME') {
    29044884
    2905         print $datafile "C$host:$val:$ttl:$stamp:$loc\n";
     4885        if ($revrec eq 'n') {
     4886          print $datafile "C$host:$val:$ttl:$stamp:$loc\n";
     4887        } else {
     4888          my $val2 = NetAddr::IP->new($val);
     4889          print $datafile "C"._ZONE($val2, 'ZONE', 'r', '.').($val2->{isv6} ? '.ip6.arpa' : '.in-addr.arpa').
     4890                ":$host:$ttl:$stamp:$loc\n";
     4891        }
    29064892
    29074893      } elsif ($typemap{$type} eq 'SRV') {
    … …  
    29364922      } elsif ($typemap{$type} eq 'PTR') {
    29374923
    2938         # must handle both IPv4 and IPv6
    2939 ##work
    2940         # data should already be in suitable reverse order.
    2941         print $datafile "^$host:$val:$ttl:$stamp:$loc\n";
     4924        $zone = NetAddr::IP->new($zone);
     4925        $$recflags{$val}++;
     4926        if (!$zone->{isv6} && $zone->masklen > 24) {
     4927          ($val) = ($val =~ /\.(\d+)$/);
     4928          print $datafile "^$val."._ZONE($zone, 'ZONE', 'r', '.').'.in-addr.arpa'.
     4929                ":$host:ttl:$stamp:$loc\n";
     4930        } else {
     4931          $val = NetAddr::IP->new($val);
     4932          print $datafile "^".
     4933                _ZONE($val, 'ZONE', 'r', '.').($val->{isv6} ? '.ip6.arpa' : '.in-addr.arpa').
     4934                ":$host:$ttl:$stamp:$loc\n";
     4935        }
     4936
     4937      } elsif ($type == 65280) { # A+PTR
     4938
     4939        $$recflags{$val}++;
     4940        print $datafile "=$host:$val:$ttl:$stamp:$loc\n";
     4941
     4942      } elsif ($type == 65281) { # AAAA+PTR
     4943
     4944#$$recflags{$val}++;
     4945        # treat these as two separate records.  since tinydns doesn't have
     4946        # a native combined type, we have to create them separately anyway.
     4947        if ($revrec eq 'n') {
     4948          $type = 28;
     4949        } else {
     4950          $type = 12;
     4951        }
     4952        _printrec_tiny($datafile,$revrec,$recflags,$zone,$host,$type,$val,$dist,$weight,$port,$ttl,$loc,$stamp);
     4953##fixme: add a config flag to indicate use of the patch from http://www.fefe.de/dns/
     4954# type 6 is for AAAA+PTR, type 3 is for AAAA
     4955
     4956      } elsif ($type == 65282) { # PTR template
     4957
     4958        # only useful for v4 with standard DNS software, since this expands all
     4959        # IPs in $zone (or possibly $val?) with autogenerated records
     4960        $val = NetAddr::IP->new($val);
     4961        return if $val->{isv6};
     4962
     4963        if ($val->masklen <= 16) {
     4964          foreach my $sub ($val->split(16)) {
     4965            __publish_subnet($sub, $recflags, $host, $datafile, $ttl, $stamp, $loc, 1);
     4966          }
     4967        } else {
     4968          __publish_subnet($val, $recflags, $host, $datafile, $ttl, $stamp, $loc, 1);
     4969        }
     4970
     4971      } elsif ($type == 65283) { # A+PTR template
     4972
     4973        $val = NetAddr::IP->new($val);
     4974        # Just In Case.  An A+PTR should be impossible to add to a v6 revzone via API.
     4975        return if $val->{isv6};
     4976
     4977        if ($val->masklen <= 16) {
     4978          foreach my $sub ($val->split(16)) {
     4979            __publish_subnet($sub, $recflags, $host, $datafile, $ttl, $stamp, $loc, 0);
     4980          }
     4981        } else {
     4982          __publish_subnet($val, $recflags, $host, $datafile, $ttl, $stamp, $loc, 0);
     4983        }
     4984
     4985      } elsif ($type == 65284) { # AAAA+PTR template
     4986        # Stub for completeness.  Could be exported to DNS software that supports
     4987        # some degree of internal automagic in generic-record-creation
     4988        # (eg http://search.cpan.org/dist/AllKnowingDNS/ )
     4989
     4990      } elsif ($type == 65285) { # Delegation
     4991        # This is intended for reverse zones, but may prove useful in forward zones.
     4992
     4993        # All delegations need to create one or more NS records.  The NS record handler knows what to do.
     4994        _printrec_tiny($datafile,$revrec,$recflags,$zone,$host,$reverse_typemap{'NS'},
     4995                $val,$dist,$weight,$port,$ttl,$loc,$stamp);
     4996        if ($revrec eq 'y') {
     4997          # In the case of a sub-/24 v4 reverse delegation, we need to generate CNAMEs
     4998          # to redirect all of the individual IP lookups as well.
     4999          # Not sure how this would actually resolve if a /24 or larger was delegated
     5000          # one way, and a sub-/24 in that >=/24 was delegated elsewhere...
     5001          my $dblock = NetAddr::IP->new($val);
     5002          if (!$dblock->{isv6} && $dblock->masklen > 24) {
     5003            my @subs = $dblock->split;
     5004            foreach (@subs) {
     5005              next if $$recflags{"$_"};
     5006              my ($oct) = ($_->addr =~ /(\d+)$/);
     5007              print $datafile "C"._ZONE($_, 'ZONE.in-addr.arpa', 'r', '.').":$oct.".
     5008                _ZONE($dblock, 'ZONE.in-addr.arpa', 'r', '.').":$ttl:$stamp:$loc\n";
     5009              $$recflags{"$_"}++;
     5010            }
     5011          }
     5012        }
     5013
     5014##
     5015## Uncommon types.  These will need better UI support Any Day Sometime Maybe(TM).
     5016##
     5017
     5018      } elsif ($type == 44) { # SSHFP
     5019        my ($algo,$fpt,$fp) = split /\s+/, $val;
     5020
     5021        my $rec = sprintf ":$host:44:\\%0.3o\\%0.3o", $algo, $fpt;
     5022        while (my ($byte) = ($fp =~ /^(..)/) ) {
     5023          $rec .= sprintf "\\%0.3o", hex($byte);
     5024          $fp =~ s/^..//;
     5025        }
     5026        print $datafile "$rec:$ttl:$stamp:$loc\n";
    29425027
    29435028      } else {
    … …  
    29545039      } # record type if-else
    29555040
    2956     } # while ($recsth)
    2957   } # while ($domsth)
    2958 } # end __export_tiny()
     5041} # end _printrec_tiny()
    29595042
    29605043
    29615044## DNSDB::mailNotify()
    2962 # Sends notification mail to recipients regarding an IPDB operation
     5045# Sends notification mail to recipients regarding a DNSDB operation
    29635046sub mailNotify {
    29645047  my $dbh = shift;

  • branches/stable/dns-1.0-1.2.sql

    r365 r545  
    11-- SQL table/record type upgrade file for dnsadmin 1.0 to 1.2 migration
     2
     3-- need this before we add any other bits
     4CREATE TABLE locations (
     5    location character varying (4) PRIMARY KEY,
     6    loc_id serial UNIQUE,
     7    group_id integer NOT NULL DEFAULT 1,
     8    iplist text NOT NULL DEFAULT '',
     9    description character varying(40) NOT NULL DEFAULT '',
     10    comments text NOT NULL DEFAULT ''
     11);
     12
     13ALTER TABLE ONLY locations
     14    ADD CONSTRAINT "locations_group_id_fkey" FOREIGN KEY (group_id) REFERENCES groups(group_id);
     15
     16ALTER TABLE permissions ADD COLUMN record_locchg boolean DEFAULT false NOT NULL;
     17ALTER TABLE permissions ADD COLUMN location_create boolean DEFAULT false NOT NULL;
     18ALTER TABLE permissions ADD COLUMN location_edit boolean DEFAULT false NOT NULL;
     19ALTER TABLE permissions ADD COLUMN location_delete boolean DEFAULT false NOT NULL;
     20ALTER TABLE permissions ADD COLUMN location_view boolean DEFAULT false NOT NULL;
    221
    322-- Minor buglet;  domains must be unique
    … …  
    2342SELECT pg_catalog.setval('default_rev_records_record_id_seq', 5, false);
    2443
     44ALTER TABLE domains ADD COLUMN changed boolean DEFAULT true NOT NULL;
     45ALTER TABLE domains ADD COLUMN default_location character varying (4) DEFAULT '' NOT NULL;
     46-- ~2x performance boost iff most zones are fed to output from the cache
     47CREATE INDEX dom_status_index ON domains (status);
     48
    2549CREATE TABLE revzones (
    2650    rdns_id serial NOT NULL,
    … …  
    3054    status integer DEFAULT 1 NOT NULL,
    3155    zserial integer,
    32     sertype character(1) DEFAULT 'D'::bpchar
     56    sertype character(1) DEFAULT 'D'::bpchar,
     57    changed boolean DEFAULT true NOT NULL,
     58    default_location character varying (4) DEFAULT '' NOT NULL
    3359);
     60CREATE INDEX rev_status_index ON revzones (status);
     61
     62ALTER TABLE ONLY revzones
     63    ADD CONSTRAINT "$1" FOREIGN KEY (group_id) REFERENCES groups(group_id);
    3464
    3565ALTER TABLE log ADD COLUMN rdns_id INTEGER;
    … …  
    4070ALTER TABLE records DROP CONSTRAINT "$1";
    4171ALTER TABLE records ALTER COLUMN domain_id SET DEFAULT 0;
    42 ALTER TABLE records ADD COLUMN rdns_id INTEGER DEFAULT 0;
    43 UPDATE records SET rdns_id=0;
    44 ALTER TABLE records ALTER COLUMN rdns_id SET NOT NULL;
     72ALTER TABLE records ADD COLUMN rdns_id INTEGER DEFAULT 0 NOT NULL;
     73ALTER TABLE records ADD COLUMN location character varying (4) DEFAULT '' NOT NULL;
     74
     75-- ~120s -> 75s performance boost on 100K records when always exporting all records
     76CREATE INDEX rec_types_index ON records (type);
     77-- Further ~1/3 performance gain, same dataset
     78CREATE INDEX rec_domain_index ON records (domain_id);
     79CREATE INDEX rec_revzone_index ON records (rdns_id);
    4580
    4681-- May as well drop and recreate;  this is nominally static and loaded from the

  • branches/stable/dns-rpc.cgi

    r263 r545  
    33##
    44# $Id$
    5 # Copyright 2011 Kris Deugau <kdeugau@deepnet.cx>
     5# Copyright 2012 Kris Deugau <kdeugau@deepnet.cx>
    66#
    77#    This program is free software: you can redistribute it and/or modify
    … …  
    3939#package main;
    4040
    41 loadConfig();
     41DNSDB::loadConfig(rpcflag => 1);
    4242
    4343# need to create a DNSDB object too
    … …  
    4949my $methods = {
    5050        'dnsdb.addDomain'       => \&addDomain,
    51         'dnsdb.delDomain'       => \&delDomain,
     51        'dnsdb.delZone'         => \&delZone,
     52        'dnsdb.addRDNS'         => \&addRDNS,
    5253        'dnsdb.addGroup'        => \&addGroup,
    5354        'dnsdb.delGroup'        => \&delGroup,
    … …  
    6061        'dnsdb.getRecCount'     => \&getRecCount,
    6162        'dnsdb.addRec'          => \&addRec,
     63        'dnsdb.updateRec'       => \&updateRec,
    6264        'dnsdb.delRec'          => \&delRec,
    63         'dnsdb.domStatus'       => \&domStatus,
     65        'dnsdb.zoneStatus'      => \&zoneStatus,
    6466
    6567        'dnsdb.getMethods'      => \&get_method_list
    … …  
    7173
    7274# "Can't do that" errors
    73 ##fixme:  this MUST be loaded from a config file!  Also must support multiple IPs
    74 if ($ENV{REMOTE_ADDR} ne '192.168.2.116') {
    75   print "Content-type: text/xml\n\n".$res->{_decode}->encode_fault(5, "Access denied");
    76   exit;
    77 }
    7875if (!$dbh) {
    7976  print "Content-type: text/xml\n\n".$res->{_decode}->encode_fault(5, $msg);
    … …  
    8986## Subs below here
    9087##
     88
     89# Utility subs
     90sub _aclcheck {
     91  my $subsys = shift;
     92  return 1 if grep /$ENV{REMOTE_ADDR}/, @{$DNSDB::config{rpcacl}{$subsys}};
     93  return 0;
     94}
     95
     96# Let's see if we can factor these out of the RPC method subs
     97sub _commoncheck {
     98  my $argref = shift;
     99  my $needslog = shift;
     100
     101  die "Missing remote system name\n" if !$argref->{rpcsystem};
     102  die "Access denied\n" if !_aclcheck($argref->{rpcsystem});
     103  if ($needslog) {
     104    die "Missing remote username\n" if !$argref->{rpcuser};
     105    die "Couldn't set userdata for logging\n"
     106        unless DNSDB::initRPC($dbh, (username => $argref->{rpcuser}, rpcsys => $argref->{rpcsystem},
     107                fullname => ($argref->{fullname} ? $argref->{fullname} : $argref->{rpcuser}) ) );
     108  }
     109}
    91110
    92111#sub connectDB {
    … …  
    103122  my %args = @_;
    104123
    105   # Make sure we've got all the local bits we need
    106   die "Missing remote username" if !$args{rpcuser};             # for logging
    107   die "Missing remote system name" if !$args{rpcsystem};        # for logging
     124  _commoncheck(\%args, 'y');
    108125
    109126  my ($code, $msg) = DNSDB::addDomain($dbh, $args{domain}, $args{group}, $args{state});
    … …  
    112129}
    113130
    114 sub delDomain {
    115   my %args = @_;
    116 
    117   # Make sure we've got all the local bits we need
    118   die "Missing remote username" if !$args{rpcuser};             # for logging
    119   die "Missing remote system name" if !$args{rpcsystem};        # for logging
     131sub delZone {
     132  my %args = @_;
     133
     134  _commoncheck(\%args, 'y');
     135  die "Need forward/reverse zone flag\n" if !$args{revrec};
    120136
    121137  my ($code,$msg);
    122   # Let's be nice;  delete based on domid OR domain name.  Saves an RPC call round-trip, maybe.
    123   if ($args{domain} =~ /^\d+$/) {
    124     ($code,$msg) = DNSDB::delDomain($dbh, $args{domain});
     138  # Let's be nice;  delete based on zone id OR zone name.  Saves an RPC call round-trip, maybe.
     139  if ($args{zone} =~ /^\d+$/) {
     140    ($code,$msg) = DNSDB::delZone($dbh, $args{zone}, $args{revrec});
    125141  } else {
    126     my $domid = DNSDB::domainID($dbh, $args{domain});
    127     die "Can't find domain" if !$domid;
    128     ($code,$msg) = DNSDB::delDomain($dbh, $domid);
    129   }
    130   die $msg if $code eq 'FAIL';
    131 }
    132 
    133 #sub domainName {
    134 #sub domainID {
     142    my $zoneid;
     143    $zoneid = DNSDB::domainID($dbh, $args{zone}) if $args{revrec} eq 'n';
     144    $zoneid = DNSDB::revID($dbh, $args{zone}) if $args{revrec} eq 'y';
     145    die "Can't find zone: $DNSDB::errstr\n" if !$zoneid;
     146    ($code,$msg) = DNSDB::delZone($dbh, $zoneid, $args{revrec});
     147  }
     148  die $msg if $code eq 'FAIL';
     149  return $msg;
     150}
     151
     152#sub domainName {}
     153#sub revName {}
     154#sub domainID {}
     155#sub revID {}
     156
     157sub addRDNS {
     158  my %args = @_;
     159
     160  _commoncheck(\%args, 'y');
     161
     162  my ($code, $msg) = DNSDB::addRDNS($dbh, $args{revzone}, $args{revpatt}, $args{group}, $args{state});
     163  die $msg if $code eq 'FAIL';
     164  return $msg;  # domain ID
     165}
     166
     167#sub getZoneCount {}
     168#sub getZoneList {}
     169#sub getZoneLocation {}
    135170
    136171sub addGroup {
    137172  my %args = @_;
    138173
    139   # Make sure we've got all the local bits we need
    140   die "Missing remote username" if !$args{rpcuser};             # for logging
    141   die "Missing remote system name" if !$args{rpcsystem};        # for logging
    142 
    143 # not sure how to usefully represent permissions from any further out from DNSDB.pm :/
     174  _commoncheck(\%args, 'y');
     175  die "Missing new group name\n" if !$args{groupname};
     176  die "Missing parent group ID\n" if !$args{parent_id};
     177
     178# not sure how to usefully represent permissions via RPC. :/
    144179# not to mention, permissions are checked at the UI layer, not the DB layer.
    145180  my $perms = {domain_edit => 1, domain_create => 1, domain_delete => 1,
    … …  
    155190  my %args = @_;
    156191
    157   # Make sure we've got all the local bits we need
    158   die "Missing remote username" if !$args{rpcuser};             # for logging
    159   die "Missing remote system name" if !$args{rpcsystem};        # for logging
     192  _commoncheck(\%args, 'y');
     193  die "Missing group ID or name to remove\n" if !$args{group};
    160194
    161195  my ($code,$msg);
    … …  
    165199  } else {
    166200    my $grpid = DNSDB::groupID($dbh, $args{group});
    167     die "Can't find group" if !$grpid;
     201    die "Can't find group\n" if !$grpid;
    168202    ($code,$msg) = DNSDB::delGroup($dbh, $grpid);
    169203  }
    170204  die $msg if $code eq 'FAIL';
    171 }
    172 
    173 #sub getChildren {
    174 #sub groupName {
    175 #sub groupID {
     205  return $msg;
     206}
     207
     208#sub getChildren {}
     209#sub groupName {}
     210#sub getGroupCount {}
     211#sub getGroupList {}
     212#sub groupID {}
    176213
    177214sub addUser {
    178215  my %args = @_;
    179216
    180   # Make sure we've got all the local bits we need
    181   die "Missing remote username" if !$args{rpcuser};             # for logging
    182   die "Missing remote system name" if !$args{rpcsystem};        # for logging
    183 
    184 # not sure how to usefully represent permissions from any further out from DNSDB.pm :/
     217  _commoncheck(\%args, 'y');
     218
     219# not sure how to usefully represent permissions via RPC.  :/
    185220# not to mention, permissions are checked at the UI layer, not the DB layer.
    186   my $perms = {domain_edit => 1, domain_create => 1, domain_delete => 1,
    187         record_edit => 1, record_create => 1, record_delete => 1
    188         };
    189221  # bend and twist;  get those arguments in in the right order!
    190222  $args{type} = 'u' if !$args{type};
    … …  
    200232}
    201233
    202 #sub checkUser {
     234#sub getUserCount {}
     235#sub getUserList {}
     236#sub getUserDropdown {}
     237#sub checkUser {}
    203238
    204239sub updateUser {
    205240  my %args = @_;
    206241
    207   # Make sure we've got all the local bits we need
    208   die "Missing remote username" if !$args{rpcuser};             # for logging
    209   die "Missing remote system name" if !$args{rpcsystem};        # for logging
    210 
    211   die "Missing UID" if !$args{uid};
    212 
    213 # not sure how to usefully represent permissions from any further out from DNSDB.pm :/
    214 # not to mention, permissions are checked at the UI layer, not the DB layer.
    215   my $perms = {domain_edit => 1, domain_create => 1, domain_delete => 1,
    216         record_edit => 1, record_create => 1, record_delete => 1
    217         };
     242  _commoncheck(\%args, 'y');
     243
     244  die "Missing UID\n" if !$args{uid};
     245
    218246  # bend and twist;  get those arguments in in the right order!
     247  $args{type} = 'u' if !$args{type};
    219248  my @userargs = ($args{uid}, $args{username}, $args{group}, $args{pass}, $args{state}, $args{type});
    220249  for my $argname ('fname','lname','phone') {
    … …  
    224253##fixme:  also underlying in DNSDB::updateUser():  no way to just update this or that attribute;
    225254#         have to pass them all in to be overwritten
    226   my ($code,$msg) = DNSDB::addUser($dbh, @userargs);
    227   die $msg if $code eq 'FAIL';
     255  my ($code,$msg) = DNSDB::updateUser($dbh, @userargs);
     256  die $msg if $code eq 'FAIL';
     257  return $msg;
    228258}
    229259
    … …  
    231261  my %args = @_;
    232262
    233   # Make sure we've got all the local bits we need
    234   die "Missing remote username" if !$args{rpcuser};             # for logging
    235   die "Missing remote system name" if !$args{rpcsystem};        # for logging
    236 
    237   die "Missing UID" if !$args{uid};
     263  _commoncheck(\%args, 'y');
     264
     265  die "Missing UID\n" if !$args{uid};
    238266  my ($code,$msg) = DNSDB::delUser($dbh, $args{uid});
    239267  die $msg if $code eq 'FAIL';
    240 }
    241 
    242 #sub userFullName {
    243 #sub userStatus {
    244 #sub getUserData {
     268  return $msg;
     269}
     270
     271#sub userFullName {}
     272#sub userStatus {}
     273#sub getUserData {}
     274
     275#sub addLoc {}
     276#sub updateLoc {}
     277#sub delLoc {}
     278#sub getLoc {}
     279#sub getLocCount {}
     280#sub getLocList {}
     281#sub getLocDropdown {}
    245282
    246283sub getSOA {
    247284  my %args = @_;
    248285
    249   # Make sure we've got all the local bits we need
    250   die "Missing remote username" if !$args{rpcuser};             # for logging
    251   die "Missing remote system name" if !$args{rpcsystem};        # for logging
    252 
    253   my %ret = DNSDB::getSOA($dbh, $args{def}, $args{id});
    254   if (!$ret{recid}) {
    255     if ($args{def} eq 'y') {
    256       die "No default SOA record in group";
     286  _commoncheck(\%args);
     287
     288  my $ret = DNSDB::getSOA($dbh, $args{defrec}, $args{revrec}, $args{id});
     289  if (!$ret) {
     290    if ($args{defrec} eq 'y') {
     291      die "No default SOA record in group\n";
    257292    } else {
    258       die "No SOA record in domain";
     293      die "No SOA record in zone\n";
    259294    }
    260295  }
    261   return \%ret;
    262 }
     296  return $ret;
     297}
     298
     299#sub updateSOA {}
    263300
    264301sub getRecLine {
    265302  my %args = @_;
    266303
    267   # Make sure we've got all the local bits we need
    268   die "Missing remote username" if !$args{rpcuser};             # for logging
    269   die "Missing remote system name" if !$args{rpcsystem};        # for logging
    270 
    271   my $ret = DNSDB::getRecLine($dbh, $args{def}, $args{id});
     304  _commoncheck(\%args);
     305
     306  my $ret = DNSDB::getRecLine($dbh, $args{defrec}, $args{revrec}, $args{id});
    272307
    273308  die $DNSDB::errstr if !$ret;
    … …  
    279314  my %args = @_;
    280315
    281   # Make sure we've got all the local bits we need
    282   die "Missing remote username" if !$args{rpcuser};             # for logging
    283   die "Missing remote system name" if !$args{rpcsystem};        # for logging
    284 
    285 #bleh
     316  _commoncheck(\%args);
     317
     318  # set some optional args
    286319  $args{nrecs} = 'all' if !$args{nrecs};
    287320  $args{nstart} = 0 if !$args{nstart};
    … …  
    290323  $args{direction} = 'ASC' if !$args{direction};
    291324
    292   my $ret = DNSDB::getDomRecs($dbh, $args{def}, $args{id}, $args{nrecs}, $args{nstart}, $args{order}, $args{direction});
     325  my $ret = DNSDB::getDomRecs($dbh, (defrec => $args{defrec}, revrec => $args{revrec}, id => $args{id},
     326        offset => $args{offset}, sortby => $args{sortby}, sortorder => $args{sortorder},
     327        filter => $args{filter}) );
    293328
    294329  die $DNSDB::errstr if !$ret;
    … …  
    300335  my %args = @_;
    301336
    302   # Make sure we've got all the local bits we need
    303   die "Missing remote username" if !$args{rpcuser};             # for logging
    304   die "Missing remote system name" if !$args{rpcsystem};        # for logging
    305 
    306   return DNSDB::getRecCount($dbh, $id);
     337  _commoncheck(\%args);
     338
     339  # set some optional args
     340  $args{nrecs} = 'all' if !$args{nrecs};
     341  $args{nstart} = 0 if !$args{nstart};
     342## for order, need to map input to column names
     343  $args{order} = 'host' if !$args{order};
     344  $args{direction} = 'ASC' if !$args{direction};
     345
     346  my $ret = DNSDB::getRecCount($dbh, $args{defrec}, $args{revrec}, $args{id}, $args{filter});
     347
     348  die $DNSDB::errstr if !$ret;
     349
     350  return $ret;
    307351}
    308352
    … …  
    310354  my %args = @_;
    311355
    312   # Make sure we've got all the local bits we need
    313   die "Missing remote username" if !$args{rpcuser};             # for logging
    314   die "Missing remote system name" if !$args{rpcsystem};        # for logging
    315 
    316   # note dist, weight, port are not reequired on all types;  will be ignored if not needed.
    317   my ($code, $msg) = DNSDB::addRec($dbh, $args{def}, $args{domid}, $args{host}, $typemap{$args{type}},
     356  _commoncheck(\%args, 'y');
     357
     358  # note dist, weight, port are not required on all types;  will be ignored if not needed.
     359  my ($code, $msg) = DNSDB::addRec($dbh, $args{def}, $args{domid}, $args{host}, $DNSDB::typemap{$args{type}},
    318360        $args{val}, $args{ttl}, $args{dist}, $args{weight}, $args{port});
    319361
    … …  
    324366  my %args = @_;
    325367
    326   # Make sure we've got all the local bits we need
    327   die "Missing remote username" if !$args{rpcuser};             # for logging
    328   die "Missing remote system name" if !$args{rpcsystem};        # for logging
    329 
    330   # note dist, weight, port are not reequired on all types;  will be ignored if not needed.
    331   my ($code, $msg) = DNSDB::updateRec($dbh, $args{def}, $args{recid}, $args{host}, $typemap{$args{type}},
     368  _commoncheck(\%args, 'y');
     369
     370  # note dist, weight, port are not required on all types;  will be ignored if not needed.
     371  my ($code, $msg) = DNSDB::updateRec($dbh, $args{def}, $args{recid}, $args{host}, $DNSDB::typemap{$args{type}},
    332372        $args{val}, $args{ttl}, $args{dist}, $args{weight}, $args{port});
    333373
    … …  
    338378  my %args = @_;
    339379
    340   # Make sure we've got all the local bits we need
    341   die "Missing remote username" if !$args{rpcuser};             # for logging
    342   die "Missing remote system name" if !$args{rpcsystem};        # for logging
    343 
    344   # note dist, weight, port are not reequired on all types;  will be ignored if not needed.
     380  _commoncheck(\%args, 'y');
     381
    345382  my ($code, $msg) = DNSDB::delRec($dbh, $args{def}, $args{recid});
    346383
    … …  
    348385}
    349386
    350 #sub getParents {
    351 
    352 sub domStatus {
    353   my %args = @_;
    354 
    355   # Make sure we've got all the local bits we need
    356   die "Missing remote username" if !$args{rpcuser};             # for logging
    357   die "Missing remote system name" if !$args{rpcsystem};        # for logging
    358 
    359   my @arglist = ($dbh, $args{domid});
     387#sub getLogCount {}
     388#sub getLogEntries {}
     389#sub getTypelist {}
     390#sub parentID {}
     391#sub isParent {}
     392
     393sub zoneStatus {
     394  my %args = @_;
     395
     396  _commoncheck(\%args, 'y');
     397
     398  my @arglist = ($dbh, $args{zoneid});
    360399  push @arglist, $args{status} if defined($args{status});
    361400
    362   my $status = DNSDB::domStatus(@arglist);
    363 }
    364 
    365 #sub importAXFR {
    366 #sub export {
    367 #sub __export_tiny {
     401  my $status = DNSDB::zoneStatus(@arglist);
     402}
     403
     404#sub importAXFR {}
     405#sub importBIND {}
     406#sub import_tinydns {}
     407#sub export {}
     408#sub __export_tiny {}
     409#sub _printrec_tiny {}
     410#sub mailNotify {}
    368411
    369412sub get_method_list {

  • branches/stable/dns.cgi

    r544 r545  
    33##
    44# $Id$
    5 # Copyright 2008-2011 Kris Deugau <kdeugau@deepnet.cx>
     5# Copyright 2008-2012 Kris Deugau <kdeugau@deepnet.cx>
    66#
    77#    This program is free software: you can redistribute it and/or modify
    … …  
    9696  $session->param('reclistsortby','host');
    9797  $session->param('reclistorder','ASC');
     98  $session->param('loclistsortby','description');
     99  $session->param('loclistorder','ASC');
     100  $session->param('logsortby','stamp');
     101  $session->param('logorder','DESC');
    98102}
    99103
    … …  
    122126$webvar{startwith} =~ s/^(0-9|[a-z]).*/$1/ if $webvar{startwith};
    123127# not much call for chars not allowed in domain names
    124 $webvar{filter} =~ s/[^a-zA-Z0-9_.:@-]//g if $webvar{filter};
     128$webvar{filter} =~ s/[^a-zA-Z0-9_.:\@-]//g if $webvar{filter};
    125129## only set 'y' if box is checked, no other values legal
    126130## however, see https://secure.deepnet.cx/trac/dnsadmin/ticket/31
    … …  
    227231  if ($webvar{action} eq 'login') {
    228232    # Snag ACL/permissions here too
    229     my $sth = $dbh->prepare("SELECT user_id,group_id,password,firstname,lastname,status FROM users WHERE username=?");
    230     $sth->execute($webvar{username});
    231 
    232     if (my ($uid,$gid,$pass,$fname,$lname,$status) = $sth->fetchrow_array) {
    233       $webvar{password} = '' if !$webvar{password};
    234       if (!$status) {
    235         $webvar{loginfailed} = 1;
    236       } elsif ($pass =~ m|^\$1\$([A-Za-z0-9/.]+)\$|) {
    237         # native passwords (crypt-md5)
    238         $webvar{loginfailed} = 1 if $pass ne unix_md5_crypt($webvar{password},$1);
    239       } elsif ($pass =~ /^[0-9a-f]{32}$/) {
    240         # VegaDNS import (hex-coded MD5)
    241         $webvar{loginfailed} = 1 if $pass ne md5_hex($webvar{password});
    242       } else {
    243         # plaintext (convenient now and then)
    244         $webvar{loginfailed} = 1 if $pass ne $webvar{password};
    245       }
     233
     234    my $userdata = login($dbh, $webvar{username}, $webvar{password});
     235
     236    if ($userdata) {
    246237
    247238      # set session bits
    248       $session->param('logingroup',$gid);
    249       $session->param('curgroup',$gid);
    250       $session->param('uid',$uid);
     239      $session->param('logingroup',$userdata->{group_id});
     240      $session->param('curgroup',$userdata->{group_id});
     241      $session->param('uid',$userdata->{user_id});
    251242      $session->param('username',$webvar{username});
    252243
    253       changepage(page => "domlist") if !defined($webvar{loginfailed});
     244      changepage(page => "domlist");
    254245
    255246    } else {
    … …  
    299290} # handle global webvar{action}s
    300291
    301 initPermissions($dbh,$session->param('uid'));
     292# finally check if the user was disabled.  we could just leave this for logout/session expiry,
     293# but if they keep the session active they'll continue to have access long after being disabled.  :/
     294# Treat it as a session expiry.
     295if ($session->param('uid') && !userStatus($dbh, $session->param('uid')) ) {
     296  $sid = '';
     297  $session->delete;     # force expiry of the session Right Away
     298  $session->flush;      # make sure it hits storage
     299  changepage(page=> "login", sessexpired => 1);
     300}
     301
     302# Misc Things To Do on most pages
     303initPermissions($dbh, $session->param('uid'));
     304initActionLog($dbh, $session->param('uid'));
    302305
    303306$page->param(sid => $sid) unless $webvar{page} eq 'login';      # no session ID on the login page
    … …  
    307310  $page->param(loginfailed => 1) if $webvar{loginfailed};
    308311  $page->param(sessexpired => 1) if $webvar{sessexpired};
    309 #  $page->param(orgname => $config{orgname}) if $config{orgname} ne 'Example Corp';
    310312  $page->param(version => $DNSDB::VERSION);
    311313
    … …  
    316318# hmm.  seeing problems in some possibly-not-so-corner cases.
    317319# this currently only handles "domain on", "domain off"
    318   if (defined($webvar{domstatus})) {
     320  if (defined($webvar{zonestatus})) {
    319321    # security check - does the user have permission to access this entity?
    320322    my $flag = 0;
    … …  
    323325    }
    324326    if ($flag && ($permissions{admin} || $permissions{domain_edit})) {
    325       my $stat = domStatus($dbh,$webvar{id},$webvar{domstatus});
    326 ##fixme  switch to more consise "Enabled <domain"/"Disabled <domain>" as with users?
    327       logaction($webvar{id}, $session->param("username"),
    328         parentID($dbh, (id => $webvar{id}, type => 'domain', revrec => $webvar{revrec})),
    329         "Changed ".domainName($dbh, $webvar{id})." state to ".($stat ? 'active' : 'inactive'));
    330       $page->param(resultmsg => "Changed ".domainName($dbh, $webvar{id})." state to ".
    331         ($stat ? 'active' : 'inactive'));
     327      my $stat = zoneStatus($dbh,$webvar{id},'n',$webvar{zonestatus});
     328      $page->param(resultmsg => $DNSDB::resultstr);
    332329    } else {
    333330      $page->param(errmsg => "You are not permitted to view or change the requested domain");
    334331    }
    335     $uri_self =~ s/\&amp;domstatus=[^&]*//g;    # clean up URL for stuffing into templates
    336   }
    337 
    338   if ($session->param('resultmsg')) {
    339     $page->param(resultmsg => $session->param('resultmsg'));
    340     $session->clear('resultmsg');
    341   }
    342   if ($session->param('errmsg')) {
    343     $page->param(errmsg => $session->param('errmsg'));
    344     $session->clear('errmsg');
    345   }
     332    $uri_self =~ s/\&amp;zonestatus=[^&]*//g;   # clean up URL for stuffing into templates
     333  }
     334
     335  show_msgs();
    346336
    347337  $page->param(curpage => $webvar{page});
    … …  
    354344        unless ($permissions{admin} || $permissions{domain_create});
    355345
    356   fill_grouplist("grouplist");
     346  $webvar{group} = $curgroup if !$webvar{group};
     347  fill_grouplist("grouplist", $webvar{group});
     348  fill_loclist();
    357349
    358350  if ($session->param('add_failed')) {
    … …  
    362354    $session->clear('errmsg');
    363355    $page->param(domain => $webvar{domain});
     356    $page->param(addinactive => $webvar{makeactive} eq 'n');
    364357  }
    365358
    … …  
    379372  $webvar{makeactive} = 0 if !defined($webvar{makeactive});
    380373
    381   my ($code,$msg) = addDomain($dbh,$webvar{domain},$webvar{group},($webvar{makeactive} eq 'on' ? 1 : 0),
    382         (username => $session->param("username"), id => $session->param("uid")));
     374  my ($code,$msg) = addDomain($dbh,$webvar{domain},$webvar{group},($webvar{makeactive} eq 'on' ? 1 : 0));
    383375
    384376  if ($code eq 'OK') {
    … …  
    388380    changepage(page => "reclist", id => $msg);
    389381  } else {
    390     logaction(0, $session->param("username"), $webvar{group}, "Failed adding domain $webvar{domain} ($msg)")
    391         if $config{log_failures};
    392382    $session->param('add_failed', 1);
    393383##fixme:  domain a security risk for XSS?
    394 ##fixme:  keep active/inactive state, group selection
    395     changepage(page => "newdomain", domain => $webvar{domain}, errmsg => $msg);
     384    changepage(page => "newdomain", domain => $webvar{domain}, errmsg => $msg,
     385        makeactive => ($webvar{makeactive} ? 'y' : 'n'), group => $webvar{group});
    396386  }
    397387
    … …  
    416406  } elsif ($webvar{del} eq 'ok') {
    417407    my $pargroup = parentID($dbh, (id => $webvar{id}, type => 'domain', revrec => $webvar{revrec}));
    418     my $dom = domainName($dbh, $webvar{id});
    419     my ($code,$msg) = delDomain($dbh, $webvar{id});
     408    my ($code,$msg) = delZone($dbh, $webvar{id}, $webvar{revrec});
    420409    if ($code eq 'OK') {
    421       logaction($webvar{id}, $session->param("username"), $pargroup, "Deleted domain $dom");
    422       changepage(page => "domlist", resultmsg => "Deleted domain $dom");
     410      changepage(page => "domlist", resultmsg => $msg);
    423411    } else {
    424       logaction($webvar{id}, $session->param("username"), $pargroup, "Failed to delete domain $dom ($msg)")
    425         if $config{log_failures};
    426       changepage(page => "domlist", errmsg => "Error deleting domain $dom: $msg");
     412      changepage(page => "domlist", errmsg => $msg);
    427413    }
    428414
    … …  
    435421
    436422  $webvar{revrec} = 'y';
     423
     424  if (defined($webvar{zonestatus})) {
     425    # security check - does the user have permission to access this entity?
     426    my $flag = 0;
     427    foreach (@viewablegroups) {
     428      $flag = 1 if isParent($dbh, $_, 'group', $webvar{id}, 'revzone');
     429    }
     430    if ($flag && ($permissions{admin} || $permissions{domain_edit})) {
     431      my $stat = zoneStatus($dbh,$webvar{id},'y',$webvar{zonestatus});
     432      $page->param(resultmsg => $DNSDB::resultstr);
     433    } else {
     434      $page->param(errmsg => "You are not permitted to view or change the requested reverse zone");
     435    }
     436    $uri_self =~ s/\&amp;zonestatus=[^&]*//g;   # clean up URL for stuffing into templates
     437  }
     438
     439  show_msgs();
     440
    437441  $page->param(curpage => $webvar{page});
    438442  listzones();
    … …  
    446450  fill_grouplist("grouplist");
    447451
    448   if ($webvar{add_failed}) {
    449     $page->param(add_failed => 1);
    450     $page->param(errmsg => $webvar{errmsg});
     452  # prepopulate revpatt with the matching default record
     453# getRecByName($dbh, (revrec => $webvar{revrec}, defrec => $webvar{defrec}, host => 'string'));
     454
     455  if ($session->param('add_failed')) {
     456    $session->clear('add_failed');
     457    $page->param(errmsg => $session->param('errmsg'));
     458    $session->clear('errmsg');
    451459    $page->param(revzone => $webvar{revzone});
    452460    $page->param(revpatt => $webvar{revpatt});
    … …  
    465473
    466474  my ($code,$msg) = addRDNS($dbh, $webvar{revzone}, $webvar{revpatt}, $webvar{group},
    467         ($webvar{makeactive} eq 'on' ? 1 : 0),
    468         (username => $session->param("username"), id => $session->param("uid")) );
     475        ($webvar{makeactive} eq 'on' ? 1 : 0));
    469476
    470477  if ($code eq 'OK') {
    471     logaction(0, $session->param("username"), $webvar{group}, "Added reverse zone $webvar{revzone}", $msg);
    472478    changepage(page => "reclist", id => $msg, revrec => 'y');
     479  } elsif ($code eq 'WARN') {
     480    changepage(page => "reclist", id => $msg, revrec => 'y', warnmsg => $DNSDB::resultstr);
    473481  } else {
    474     logaction(0, $session->param("username"), $webvar{group}, "Failed adding reverse zone $webvar{revzone} ($msg)");
    475     changepage(page => "newrevzone", add_failed => 1, revzone => $webvar{revzone}, revpatt => $webvar{revpatt},
    476        errmsg => $msg);
    477   }
    478 
    479 #} elsif ($webvar{page} eq 'delrevzone') {
     482    $session->param('add_failed', 1);
     483    changepage(page => "newrevzone", revzone => $webvar{revzone}, revpatt => $webvar{revpatt}, errmsg => $msg);
     484  }
     485
     486} elsif ($webvar{page} eq 'delrevzone') {
     487
     488  changepage(page => "revzones", errmsg => "You are not permitted to delete reverse zones")
     489        unless ($permissions{admin} || $permissions{domain_delete});
     490
     491  # security check - does the user have permission to access this entity?
     492  if (!check_scope(id => $webvar{id}, type => 'revzone')) {
     493    changepage(page => "revzones", errmsg => "You do not have permission to delete the requested reverse zone");
     494  }
     495
     496  $page->param(id => $webvar{id});
     497
     498  # first pass = confirm y/n (sorta)
     499  if (!defined($webvar{del})) {
     500
     501    $page->param(del_getconf => 1);
     502    $page->param(revzone => revName($dbh,$webvar{id}));
     503
     504  } elsif ($webvar{del} eq 'ok') {
     505    my $pargroup = parentID($dbh, (id => $webvar{id}, type => 'revzone', revrec => $webvar{revrec}));
     506    my $zone = revName($dbh, $webvar{id});
     507    my ($code,$msg) = delZone($dbh, $webvar{id}, 'y');
     508    if ($code eq 'OK') {
     509      changepage(page => "revzones", resultmsg => $msg);
     510    } else {
     511      changepage(page => "revzones", errmsg => $msg);
     512    }
     513
     514  } else {
     515    # cancelled.  whee!
     516    changepage(page => "revzones");
     517  }
    480518
    481519} elsif ($webvar{page} eq 'reclist') {
    … …  
    531569        distance => 'Distance', weight => 'Weight', port => 'Port', ttl => 'TTL');
    532570    } else {
    533       @cols = ('host', 'type', 'val', 'ttl');
    534       %colheads = (host => 'IP Address', type => 'Type', val => 'Hostname', ttl => 'TTL');
     571      @cols = ('val', 'type', 'host', 'ttl');
     572      %colheads = (val => 'IP Address', type => 'Type', host => 'Hostname', ttl => 'TTL');
    535573    }
    536574    my %custom = (id => $webvar{id}, defrec => $webvar{defrec}, revrec => $webvar{revrec});
    … …  
    547585    showzone($webvar{defrec}, $webvar{revrec}, $webvar{id});
    548586    if ($webvar{defrec} eq 'n') {
    549 #      showzone('n',$webvar{id});
    550 ##fixme:  permission for viewing logs?
    551 ##fixme:  determine which slice of the log we view (group, domain, revzone)
    552587      if ($webvar{revrec} eq 'n') {
    553588        $page->param(logdom => 1);
    … …  
    557592    }
    558593
    559     if ($session->param('resultmsg')) {
    560       $page->param(resultmsg => $session->param('resultmsg'));
    561       $session->clear('resultmsg');
    562     }
    563     if ($session->param('warnmsg')) {
    564       $page->param(warnmsg => $session->param('warnmsg'));
    565       $session->clear('warnmsg');
    566     }
    567     if ($session->param('errmsg')) {
    568       $page->param(errmsg => $session->param('errmsg'));
    569       $session->clear('errmsg');
    570     }
     594    show_msgs();
    571595
    572596  } # close "you can't edit default records" check
    … …  
    608632    fill_recdata();
    609633
     634    if ($webvar{defrec} eq 'n') {
     635      my $defloc = getZoneLocation($dbh, $webvar{revrec}, $webvar{parentid});
     636      fill_loclist($curgroup, $defloc);
     637    }
     638
    610639  } elsif ($webvar{recact} eq 'add') {
    611640
    … …  
    613642        unless ($permissions{admin} || $permissions{record_create});
    614643
     644    # location check - if user does not have record_locchg, set $webvar{location} to default location for zone
     645    my $parloc = getZoneLocation($dbh, $webvar{revrec}, $webvar{parentid});
     646    $webvar{location} = $parloc unless ($permissions{admin} || $permissions{record_locchg});
     647
    615648    my @recargs = ($dbh,$webvar{defrec},$webvar{revrec},$webvar{parentid},
    616         \$webvar{name},\$webvar{type},\$webvar{address},$webvar{ttl});
     649        \$webvar{name},\$webvar{type},\$webvar{address},$webvar{ttl},$webvar{location});
    617650    if ($webvar{type} == $reverse_typemap{MX} or $webvar{type} == $reverse_typemap{SRV}) {
    618651      push @recargs, $webvar{distance};
    … …  
    626659
    627660    if ($code eq 'OK' || $code eq 'WARN') {
    628       my $restr;
    629       if ($webvar{defrec} eq 'y') {
    630         $restr = "Added default record '$webvar{name} $typemap{$webvar{type}}";
    631         $restr .= " [distance $webvar{distance}]" if $typemap{$webvar{type}} eq 'MX';
    632         $restr .= " [priority $webvar{distance}] [weight $webvar{weight}] [port $webvar{port}]"
    633                 if $typemap{$webvar{type}} eq 'SRV';
    634         $restr .= " $webvar{address}', TTL $webvar{ttl}";
    635         logaction(0, $session->param("username"), $webvar{parentid}, $restr);
    636       } else {
    637         $restr = "Added record '$webvar{name} $typemap{$webvar{type}}";
    638         $restr .= " [distance $webvar{distance}]" if $typemap{$webvar{type}} eq 'MX';
    639         $restr .= " [priority $webvar{distance}] [weight $webvar{weight}] [port $webvar{port}]"
    640                 if $typemap{$webvar{type}} eq 'SRV';
    641         $restr .= " $webvar{address}', TTL $webvar{ttl}";
    642         logaction($webvar{parentid}, $session->param("username"),
    643                 parentID($dbh, (id => $webvar{parentid}, type => 'domain', revrec => $webvar{revrec})), $restr);
    644       }
    645661      my %pageparams = (page => "reclist", id => $webvar{parentid},
    646662        defrec => $webvar{defrec}, revrec => $webvar{revrec});
    647       $pageparams{warnmsg} = $msg."<br><br>\n".$restr if $code eq 'WARN';
    648       $pageparams{resultmsg} = $restr if $code eq 'OK';
     663      $pageparams{warnmsg} = $msg."<br><br>\n".$DNSDB::resultstr if $code eq 'WARN';
     664      $pageparams{resultmsg} = $DNSDB::resultstr if $code eq 'OK';
    649665      changepage(%pageparams);
    650666    } else {
    … …  
    657673      $page->param(id           => $webvar{id});
    658674      fill_recdata();   # populate the form... er, mostly.
    659       if ($config{log_failures}) {
    660         if ($webvar{defrec} eq 'y') {
    661           logaction(0, $session->param("username"), $webvar{parentid},
    662                 "Failed adding default record '$webvar{name} $typemap{$webvar{type}} $webvar{address}', TTL $webvar{ttl} ($msg)");
    663         } else {
    664           logaction($webvar{parentid}, $session->param("username"),
    665                 parentID($dbh, (id => $webvar{parentid}, type => 'domain', revrec => $webvar{revrec})),
    666                 "Failed adding record '$webvar{name} $typemap{$webvar{type}} $webvar{address}', TTL $webvar{ttl} ($msg)");
    667         }
     675      if ($webvar{defrec} eq 'n') {
     676        fill_loclist($curgroup, $webvar{location});
    668677      }
    669678    }
    … …  
    685694    $page->param(port           => $recdata->{port});
    686695    $page->param(ttl            => $recdata->{ttl});
    687     $page->param(typelist       => getTypelist($dbh, $webvar{revrec}, $webvar{type}));
     696    $page->param(typelist       => getTypelist($dbh, $webvar{revrec}, $recdata->{type}));
     697
     698    if ($webvar{defrec} eq 'n') {
     699      fill_loclist($curgroup, $recdata->{location});
     700    }
    688701
    689702  } elsif ($webvar{recact} eq 'update') {
    … …  
    692705        unless ($permissions{admin} || $permissions{record_edit});
    693706
    694     # prevent out-of-domain records from getting added by appending the domain, or DOMAIN for default records
    695     my $pname = ($webvar{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$webvar{parentid}));
    696     $webvar{name} =~ s/\s+$//;
    697     $webvar{name} =~ s/\.*$/\.$pname/ if $webvar{name} !~ /$pname$/;
    698 
    699     # get current/previous record info so we can log "updated 'foo A 1.2.3.4' to 'foo A 2.3.4.5'"
     707    # retain old location if user doesn't have permission to fiddle locations
    700708    my $oldrec = getRecLine($dbh, $webvar{defrec}, $webvar{revrec}, $webvar{id});
    701 
    702     my ($code,$msg) = updateRec($dbh,$webvar{defrec},$webvar{id},
    703         $webvar{name},$webvar{type},$webvar{address},$webvar{ttl},
     709    $webvar{location} = $oldrec->{location} unless ($permissions{admin} || $permissions{record_locchg});
     710
     711    my ($code,$msg) = updateRec($dbh,$webvar{defrec},$webvar{revrec},$webvar{id},$webvar{parentid},
     712        \$webvar{name},\$webvar{type},\$webvar{address},$webvar{ttl},$webvar{location},
    704713        $webvar{distance},$webvar{weight},$webvar{port});
    705714
    706     if ($code eq 'OK') {
    707 ##fixme: retrieve old record info for full logging of change
    708       if ($webvar{defrec} eq 'y') {
    709         my $restr = "Updated default record from '$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}', TTL $oldrec->{ttl}\n".
    710                 "to '$webvar{name} $typemap{$webvar{type}} $webvar{address}', TTL $webvar{ttl}";
    711         logaction(0, $session->param("username"), $webvar{parentid}, $restr);
    712         changepage(page => "reclist", id => $webvar{parentid}, defrec => $webvar{defrec}, resultmsg => $restr);
    713       } else {
    714         my $restr = "Updated record from '$oldrec->{host} $typemap{$oldrec->{type}} $oldrec->{val}', TTL $oldrec->{ttl}\n".
    715                 "to '$webvar{name} $typemap{$webvar{type}} $webvar{address}', TTL $webvar{ttl}";
    716         logaction($webvar{parentid}, $session->param("username"),
    717                 parentID($dbh, (id => $webvar{id}, type => 'record', defrec => $webvar{defrec},
    718                         revrec => $webvar{revrec}, partype => 'group')),
    719                 $restr);
    720         changepage(page => "reclist", id => $webvar{parentid}, defrec => $webvar{defrec}, resultmsg => $restr);
    721       }
     715    if ($code eq 'OK' || $code eq 'WARN') {
     716      my %pageparams = (page => "reclist", id => $webvar{parentid},
     717        defrec => $webvar{defrec}, revrec => $webvar{revrec});
     718      $pageparams{warnmsg} = $msg."<br><br>\n".$DNSDB::resultstr if $code eq 'WARN';
     719      $pageparams{resultmsg} = $DNSDB::resultstr if $code eq 'OK';
     720      changepage(%pageparams);
    722721    } else {
    723722      $page->param(failed       => 1);
    … …  
    729728      $page->param(id           => $webvar{id});
    730729      fill_recdata();
    731       if ($config{log_failures}) {
    732         if ($webvar{defrec} eq 'y') {
    733           logaction(0, $session->param("username"), $webvar{parentid},
    734                 "Failed updating default record '$typemap{$webvar{type}} $webvar{name} $webvar{address}', TTL $webvar{ttl} ($msg)");
    735         } else {
    736           logaction($webvar{parentid}, $session->param("username"),
    737                 parentID($dbh, (id => $webvar{parentid}, type => 'domain', revrec => $webvar{revrec})),
    738                 "Failed updating record '$typemap{$webvar{type}} $webvar{name} $webvar{address}', TTL $webvar{ttl} ($msg)");
    739         }
    740       }
    741730    }
    742731  }
    … …  
    745734    $page->param(dohere => "default records in group ".groupName($dbh,$webvar{parentid}));
    746735  } else {
    747     $page->param(parentid => $webvar{parentid});
    748736    $page->param(dohere => domainName($dbh,$webvar{parentid})) if $webvar{revrec} eq 'n';
    749737    $page->param(dohere => revName($dbh,$webvar{parentid})) if $webvar{revrec} eq 'y';
    … …  
    781769    $page->param(recval => $rec->{val});
    782770  } elsif ($webvar{del} eq 'ok') {
    783 # get rec data before we try to delete it
    784     my $rec = getRecLine($dbh, $webvar{defrec}, $webvar{revrec}, $webvar{id});
    785771    my ($code,$msg) = delRec($dbh, $webvar{defrec}, $webvar{revrec}, $webvar{id});
    786772    if ($code eq 'OK') {
    787       if ($webvar{defrec} eq 'y') {
    788         my $recclass = ($webvar{revrec} eq 'n' ? 'default record' : 'default reverse record');
    789 ##fixme:  log distance for MX;  log port/weight/distance for SRV
    790         my $restr = "Deleted $recclass '$rec->{host} $typemap{$rec->{type}} $rec->{val}', TTL $rec->{ttl}";
    791         logaction(0, $session->param("username"), $rec->{parid}, $restr);
    792         changepage(page => "reclist", id => $webvar{parentid}, defrec => $webvar{defrec},
    793                 revrec => $webvar{revrec}, resultmsg => $restr);
    794       } else {
    795         my $recclass = ($webvar{revrec} eq 'n' ? 'record' : 'reverse record');
    796         my $restr = "Deleted $recclass '$rec->{host} $typemap{$rec->{type}} $rec->{val}', TTL $rec->{ttl}";
    797         logaction($rec->{parid}, $session->param("username"),
    798                 parentID($dbh, (id => $rec->{parid}, type => 'domain', revrec => $webvar{revrec})),
    799                 $restr);
    800         changepage(page => "reclist", id => $webvar{parentid}, defrec => $webvar{defrec},
    801                 revrec => $webvar{revrec}, resultmsg => $restr);
    802       }
     773      changepage(page => "reclist", id => $webvar{parentid}, defrec => $webvar{defrec},
     774                revrec => $webvar{revrec}, resultmsg => $msg);
    803775    } else {
    804776## need to find failure mode
    805       if ($config{log_failures}) {
    806         if ($webvar{defrec} eq 'y') {
    807           logaction(0, $session->param("username"), $rec->{parid},
    808                 "Failed deleting default record '$rec->{host} $typemap{$rec->{type}} $rec->{val}',".
    809                 " TTL $rec->{ttl} ($msg)");
    810         } else {
    811           logaction($rec->{parid}, $session->param("username"),
    812                 parentID($dbh, (id => $rec->{parid}, type => 'domain', revrec => $webvar{revrec})),
    813                 "Failed deleting record '$rec->{host} $typemap{$rec->{type}} $rec->{val}', TTL $rec->{ttl} ($msg)");
    814         }
    815       }
    816777      changepage(page => "reclist", id => $webvar{parentid}, defrec => $webvar{defrec},
    817                 revrec => $webvar{revrec}, errmsg => "Error deleting record: $msg");
     778                revrec => $webvar{revrec}, errmsg => $msg);
    818779    }
    819780  } else {
    … …  
    840801  }
    841802
    842   fillsoa($webvar{defrec},$webvar{id});
     803  fillsoa($webvar{defrec},$webvar{revrec},$webvar{id});
    843804
    844805} elsif ($webvar{page} eq 'updatesoa') {
    … …  
    848809  if (!check_scope(id => $webvar{recid}, type =>
    849810        ($webvar{defrec} eq 'y' ? ($webvar{revrec} eq 'y' ? 'defrevrec' : 'defrec') : 'record'))) {
     811##fixme:  should we redirect to the requested record list page instead of the domain list?
    850812    changepage(page => 'domlist', errmsg => "You do not have permission to edit the requested SOA record");
    851813  }
    … …  
    853815  if (!check_scope(id => $webvar{id}, type =>
    854816        ($webvar{defrec} eq 'y' ? 'group' : ($webvar{revrec} eq 'y' ? 'revzone' : 'domain')))) {
    855     changepage(page => 'domlist', errmsg => "You do not have permission to edit the ".
     817    changepage(page => ($webvar{revrec} eq 'y' ? 'revzones' : 'domlist'),
     818        errmsg => "You do not have permission to edit the ".
    856819        ($webvar{defrec} eq 'y' ? 'default ' : '')."SOA record for the requested ".
    857         ($webvar{defrec} eq 'y' ? 'group' : 'domain'));
     820        ($webvar{defrec} eq 'y' ? 'group' : ($webvar{revrec} eq 'y' ? 'reverse zone' : 'domain')) );
    858821  }
    859822
    … …  
    861824        unless ($permissions{admin} || $permissions{domain_edit});
    862825
    863   # get old SOA for log
    864   my %soa = getSOA($dbh,$webvar{defrec},$webvar{id});
    865 
    866   my $sth;
    867 ##fixme:  push SQL into DNSDB.pm
    868 ##fixme: data validation: make sure {recid} is really the SOA for {id}
    869   # no domain ID, so we're editing the default SOA for a group (we don't care which one here)
    870   # plus a bit of magic to update the appropriate table
    871   my $sql = "UPDATE ".($webvar{defrec} eq 'y' ? "default_records" : "records").
    872         " SET host=?, val=?, ttl=? WHERE record_id=?";
    873   $sth = $dbh->prepare($sql);
    874   $sth->execute("$webvar{contact}:$webvar{prins}",
    875         "$webvar{refresh}:$webvar{retry}:$webvar{expire}:$webvar{minttl}",
    876         $webvar{ttl},
    877         $webvar{recid});
    878 
    879   if ($sth->err) {
     826  my ($code, $msg) = updateSOA($dbh, $webvar{defrec}, $webvar{revrec},
     827        (contact => $webvar{contact}, prins => $webvar{prins}, refresh => $webvar{refresh},
     828        retry => $webvar{retry}, expire => $webvar{expire}, minttl => $webvar{minttl},
     829        ttl => $webvar{ttl}, id => $webvar{id}) );
     830  if ($code eq 'OK') {
     831    changepage(page => "reclist", id => $webvar{id}, defrec => $webvar{defrec}, revrec => $webvar{revrec},
     832        resultmsg => "SOA record updated");
     833  } else {
    880834    $page->param(update_failed => 1);
    881     $page->param(msg => $DBI::errstr);
    882     fillsoa($webvar{defrec},$webvar{id});
    883 ##fixme: faillog
    884   } else {
    885 
    886     # do this in the order of "default to most common case"
    887     my $loggroup;
    888     my $logdomain = $webvar{id};
    889     if ($webvar{defrec} eq 'y') {
    890       $loggroup = $webvar{id};
    891       $logdomain = 0;
    892     } else {
    893       $loggroup = parentID($dbh, (id => $logdomain, type => 'domain', revrec => $webvar{revrec}));
    894     }
    895 
    896     logaction($logdomain, $session->param("username"), $loggroup,
    897         "Updated ".($webvar{defrec} eq 'y' ? 'default ' : '')."SOA for ".
    898         ($webvar{defrec} eq 'y' ? groupName($dbh, $webvar{id}) : domainName($dbh, $webvar{id}) ).
    899         ": (ns $soa{prins}, contact $soa{contact}, refresh $soa{refresh},".
    900         " retry $soa{retry}, expire $soa{expire}, minTTL $soa{minttl}, TTL $soa{ttl}) to ".
    901         "(ns $webvar{prins}, contact $webvar{contact}, refresh $webvar{refresh},".
    902         " retry $webvar{retry}, expire $webvar{expire}, minTTL $webvar{minttl}, TTL $webvar{ttl})");
    903     changepage(page => "reclist", id => $webvar{id}, defrec => $webvar{defrec},
    904         resultmsg => "SOA record updated");
     835    $page->param(msg => $msg);
     836    fillsoa($webvar{defrec}, $webvar{revrec}, $webvar{id}, 'w');
    905837  }
    906838
    … …  
    914846  $page->param(delgrp => $permissions{admin} || $permissions{group_delete});
    915847
    916   if ($session->param('resultmsg')) {
    917     $page->param(resultmsg => $session->param('resultmsg'));
    918     $session->clear('resultmsg');
    919   }
    920   if ($session->param('warnmsg')) {
    921     $page->param(warnmsg => $session->param('warnmsg'));
    922     $session->clear('warnmsg');
    923   }
    924   if ($session->param('errmsg')) {
    925     $page->param(errmsg => $session->param('errmsg'));
    926     $session->clear('errmsg');
    927   }
     848  show_msgs();
    928849  $page->param(curpage => $webvar{page});
    929850
    … …  
    951872      }
    952873    }
    953     # force inheritance of parent group's default records with inherit flag,
    954     # otherwise we end up with the hardcoded defaults from DNSDB.pm.  See
    955     # https://secure.deepnet.cx/trac/dnsadmin/ticket/8 for the UI enhancement
    956     # that will make this variable.
    957     my ($code,$msg) = addGroup($dbh, $webvar{newgroup}, $webvar{pargroup}, \%newperms, 1);
     874    # "Chained" permissions.  Some permissions imply others;  make sure they get set.
     875    foreach (keys %permchains) {
     876      if ($newperms{$_} && !$newperms{$permchains{$_}}) {
     877        $newperms{$permchains{$_}} = 1;
     878      }
     879    }
     880    # not gonna provide the 4th param: template-or-clone flag, just yet
     881    my ($code,$msg) = addGroup($dbh, $webvar{newgroup}, $webvar{pargroup}, \%newperms);
    958882    if ($code eq 'OK') {
    959       logaction(0, $session->param("username"), $webvar{pargroup}, "Added group $webvar{newgroup}");
    960883      if ($alterperms) {
    961884        changepage(page => "grpman", warnmsg =>
    … …  
    965888      }
    966889    } # fallthrough else
    967     logaction(0, $session->param("username"), $webvar{pargroup}, "Failed to add group $webvar{newgroup}: $msg")
    968         if $config{log_failures};
    969890    # no point in doing extra work
    970891    fill_permissions($page, \%newperms);
    … …  
    1001922
    1002923  } elsif ($webvar{del} eq 'ok') {
    1003     my $deleteme = groupName($dbh,$webvar{id}); # get this before we delete it...
    1004     my $delparent = parentID($dbh, (id => $webvar{id}, type => 'group'));
    1005924    my ($code,$msg) = delGroup($dbh, $webvar{id});
    1006925    if ($code eq 'OK') {
    1007926##fixme: need to clean up log when deleting a major container
    1008       logaction(0, $session->param("username"), $delparent, "Deleted group $deleteme");
    1009       changepage(page => "grpman", resultmsg => "Deleted group $deleteme");
     927      changepage(page => "grpman", resultmsg => $msg);
    1010928    } else {
    1011929# need to find failure mode
    1012       logaction(0, $session->param("username"), $delparent, "Failed to delete group $deleteme: $msg")
    1013         if $config{log_failures};
    1014       changepage(page => "grpman", errmsg => "Error deleting group $deleteme: $msg");
     930      changepage(page => "grpman", errmsg => $msg);
    1015931    }
    1016932  } else {
    … …  
    1030946  }
    1031947
    1032   if ($webvar{grpaction} eq 'updperms') {
     948  if ($webvar{grpaction} && $webvar{grpaction} eq 'updperms') {
    1033949    # extra safety check;  make sure user can't construct a URL to bypass ACLs
    1034950    my %curperms;
    … …  
    1046962      }
    1047963    }
     964    # "Chained" permissions.  Some permissions imply others;  make sure they get set.
     965    foreach (keys %permchains) {
     966      if ($chperms{$_} && !$chperms{$permchains{$_}}) {
     967        $chperms{$permchains{$_}} = 1;
     968      }
     969    }
    1048970    my ($code,$msg) = changePermissions($dbh, 'group', $webvar{gid}, \%chperms);
    1049971    if ($code eq 'OK') {
    1050       logaction(0, $session->param("username"), $webvar{gid},
    1051         "Updated default permissions in group $webvar{gid} (".groupName($dbh, $webvar{gid}).")");
    1052972      if ($alterperms) {
    1053973        changepage(page => "grpman", warnmsg =>
    … …  
    1055975                groupName($dbh, $webvar{gid})." updated with reduced access");
    1056976      } else {
    1057         changepage(page => "grpman", resultmsg =>
    1058                 "Updated default permissions in group ".groupName($dbh, $webvar{gid}));
     977        changepage(page => "grpman", resultmsg => $msg);
    1059978      }
    1060979    } # fallthrough else
    1061     logaction(0, $session->param("username"), $webvar{gid}, "Failed to update default permissions in group ".
    1062         groupName($dbh, $webvar{gid}).": $msg")
    1063         if $config{log_failures};
    1064980    # no point in doing extra work
    1065981    fill_permissions($page, \%chperms);
    … …  
    1074990} elsif ($webvar{page} eq 'bulkdomain') {
    1075991  # Bulk operations on domains.  Note all but group move are available on the domain list.
     992##fixme:  do we care about bulk operations on revzones?  Move-to-group, activate, deactivate,
     993# and delete should all be much rarer for revzones than for domains.
    1076994
    1077995  changepage(page => "domlist", errmsg => "You are not permitted to make bulk domain changes")
    … …  
    1080998  fill_grouplist("grouplist");
    1081999
    1082 ##fixme
    1083 ##fixme  push the SQL and direct database fiddling off into a sub in DNSDB.pm
    1084 ##fixme
    1085 
    1086   my $sth = $dbh->prepare("SELECT count(*) FROM domains WHERE group_id=?");
    1087   $sth->execute($curgroup);
    1088   my ($count) = ($sth->fetchrow_array);
     1000  my $count = getZoneCount($dbh, (revrec => 'n', curgroup => $curgroup) );
    10891001
    10901002  $page->param(curpage => $webvar{page});
    … …  
    10931005  $page->param(perpage => $perpage);
    10941006
    1095   my @domlist;
    1096   my $sql = "SELECT domain_id,domain FROM domains".
    1097         " WHERE group_id=?".
    1098         " ORDER BY domain".
    1099         ($offset eq 'all' ? '' : " LIMIT $perpage OFFSET ".$offset*$perpage);
    1100   $sth = $dbh->prepare($sql);
    1101   $sth->execute($curgroup);
     1007  my $domlist = getZoneList($dbh, (revrec => 'n', curgroup => $curgroup) );
    11021008  my $rownum = 0;
    1103   while (my @data = $sth->fetchrow_array) {
    1104     my %row;
    1105     $row{domid} = $data[0];
    1106     $row{domain} = $data[1];
    1107     $rownum++;  # putting this in the expression below causes failures.  *eyeroll*
    1108     $row{newrow} = $rownum % 5 == 0;
    1109     push @domlist, \%row;
    1110   }
    1111   $page->param(domtable => \@domlist);
     1009  foreach my $dom (@{$domlist}) {
     1010    delete $dom->{status};
     1011    delete $dom->{group};
     1012    $dom->{newrow} = (++$rownum) % 5 == 0;
     1013  }
     1014
     1015  $page->param(domtable => $domlist);
    11121016  # ACLs
    11131017  $page->param(maymove => ($permissions{admin} || ($permissions{domain_edit} && $permissions{domain_create} && $permissions{domain_delete})));
    … …  
    11231027  }
    11241028
     1029  # per-action scope checks
    11251030  if ($webvar{bulkaction} eq 'move') {
    11261031    changepage(page => "domlist", errmsg => "You are not permitted to bulk-move domains")
    … …  
    11281033    my $newgname = groupName($dbh,$webvar{destgroup});
    11291034    $page->param(action => "Move to group $newgname");
    1130     my @bulkresults;
    1131     # nngh.  due to alpha-sorting on the previous page, we can't use domid-numeric
    1132     # order here, and since we don't have the domain names until we go around this
    1133     # loop, we can't alpha-sort them here.  :(
    1134     foreach (keys %webvar) {
    1135       my %row;
    1136       next unless $_ =~ /^dom_\d+$/;
    1137       # second security check - does the user have permission to meddle with this domain?
    1138       if (!check_scope(id => $webvar{$_}, type => 'domain')) {
    1139         $row{domerr} = "You are not permitted to make changes to the requested domain";
    1140         $row{domain} = $webvar{$_};
    1141         push @bulkresults, \%row;
    1142         next;
    1143       }
    1144       $row{domain} = domainName($dbh,$webvar{$_});
    1145       my ($code, $msg) = changeGroup($dbh, 'domain', $webvar{$_}, $webvar{destgroup});
    1146       if ($code eq 'OK') {
    1147         logaction($webvar{$_}, $session->param("username"),
    1148                 parentID($dbh, (id => $webvar{$_}, type => 'domain', revrec => $webvar{revrec})),
    1149                 "Moved domain ".domainName($dbh, $webvar{$_})." to group $newgname");
    1150         $row{domok} = ($code eq 'OK');
    1151       } else {
    1152         logaction($webvar{$_}, $session->param("username"),
    1153                 parentID($dbh, (id => $webvar{$_}, type => 'domain', revrec => $webvar{revrec})),
    1154                 "Failed to move domain ".domainName($dbh, $webvar{$_})." to group $newgname: $msg")
    1155                 if $config{log_failures};
    1156       }
    1157       $row{domerr} = $msg;
    1158       push @bulkresults, \%row;
    1159     }
    1160     $page->param(bulkresults => \@bulkresults);
    1161 
    11621035  } elsif ($webvar{bulkaction} eq 'deactivate' || $webvar{bulkaction} eq 'activate') {
    11631036    changepage(page => "domlist", errmsg => "You are not permitted to bulk-$webvar{bulkaction} domains")
    11641037        unless ($permissions{admin} || $permissions{domain_edit});
    11651038    $page->param(action => "$webvar{bulkaction} domains");
    1166     my @bulkresults;
    1167     foreach (keys %webvar) {
    1168       my %row;
    1169       next unless $_ =~ /^dom_\d+$/;
    1170       # second security check - does the user have permission to meddle with this domain?
    1171       if (!check_scope(id => $webvar{$_}, type => 'domain')) {
    1172         $row{domerr} = "You are not permitted to make changes to the requested domain";
    1173         $row{domain} = $webvar{$_};
    1174         push @bulkresults, \%row;
    1175         next;
    1176       }
    1177       $row{domain} = domainName($dbh,$webvar{$_});
    1178 ##fixme:  error handling on status change
    1179       my $stat = domStatus($dbh,$webvar{$_},($webvar{bulkaction} eq 'activate' ? 'domon' : 'domoff'));
    1180       logaction($webvar{$_}, $session->param("username"),
    1181         parentID($dbh, (id => $webvar{$_}, type => 'domain', revrec => $webvar{revrec})),
    1182         "Changed domain ".domainName($dbh, $webvar{$_})." state to ".($stat ? 'active' : 'inactive'));
    1183       $row{domok} = 1;
    1184 #      $row{domok} = ($code eq 'OK');
    1185 #      $row{domerr} = $msg;
    1186       push @bulkresults, \%row;
    1187     }
    1188     $page->param(bulkresults => \@bulkresults);
    1189 
    11901039  } elsif ($webvar{bulkaction} eq 'delete') {
    11911040    changepage(page => "domlist", errmsg => "You are not permitted to bulk-delete domains")
    11921041        unless ($permissions{admin} || $permissions{domain_delete});
    11931042    $page->param(action => "$webvar{bulkaction} domains");
    1194     my @bulkresults;
    1195     foreach (keys %webvar) {
    1196       my %row;
    1197       next unless $_ =~ /^dom_\d+$/;
    1198       # second security check - does the user have permission to meddle with this domain?
    1199       if (!check_scope(id => $webvar{$_}, type => 'domain')) {
    1200         $row{domerr} = "You are not permitted to make changes to the requested domain";
    1201         $row{domain} = $webvar{$_};
    1202         push @bulkresults, \%row;
    1203         next;
    1204       }
    1205       $row{domain} = domainName($dbh,$webvar{$_});
    1206       my $pargroup = parentID($dbh, (id => $webvar{$_}, type => 'domain', revrec => $webvar{revrec}));
    1207       my $dom = domainName($dbh, $webvar{$_});
    1208       my ($code, $msg) = delDomain($dbh, $webvar{$_});
    1209       if ($code eq 'OK') {
    1210         logaction($webvar{$_}, $session->param("username"), $pargroup, "Deleted domain $dom");
    1211         $row{domok} = ($code eq 'OK');
    1212       } else {
    1213         logaction($webvar{$_}, $session->param("username"), $pargroup, "Failed to delete domain $dom: $msg")
    1214                 if $config{log_failures};
    1215       }
     1043  } else {
     1044    # unknown action, bypass actually doing anything.  it should not be possible in
     1045    # normal operations, and anyone who meddles with the URL gets what they deserve.
     1046    goto DONEBULK;
     1047  } # move/(de)activate/delete if()
     1048
     1049  my @bulkresults;
     1050  # nngh.  due to alpha-sorting on the previous page, we can't use domid-numeric
     1051  # order here, and since we don't have the domain names until we go around this
     1052  # loop, we can't alpha-sort them here.  :(
     1053  foreach (keys %webvar) {
     1054    my %row;
     1055    next unless $_ =~ /^dom_\d+$/;
     1056    # second security check - does the user have permission to meddle with this domain?
     1057    if (!check_scope(id => $webvar{$_}, type => 'domain')) {
     1058      $row{domerr} = "You are not permitted to make changes to the requested domain";
     1059      $row{domain} = $webvar{$_};
     1060      push @bulkresults, \%row;
     1061      next;
     1062    }
     1063    $row{domain} = domainName($dbh,$webvar{$_});
     1064
     1065    # Do the $webvar{bulkaction}
     1066    my ($code, $msg);
     1067    ($code, $msg) = changeGroup($dbh, 'domain', $webvar{$_}, $webvar{destgroup})
     1068        if $webvar{bulkaction} eq 'move';
     1069    if ($webvar{bulkaction} eq 'deactivate' || $webvar{bulkaction} eq 'activate') {
     1070      my $stat = zoneStatus($dbh,$webvar{$_},'n',($webvar{bulkaction} eq 'activate' ? 'domon' : 'domoff'));
     1071      $code = (defined($stat) ? 'OK' : 'FAIL');
     1072      $msg = (defined($stat) ? $DNSDB::resultstr : $DNSDB::errstr);
     1073    }
     1074    ($code, $msg) = delZone($dbh, $webvar{$_}, 'n')
     1075        if $webvar{bulkaction} eq 'delete';
     1076
     1077    # Set the result output from the action
     1078    if ($code eq 'OK') {
     1079      $row{domok} = $msg;
     1080    } elsif ($code eq 'WARN') {
     1081      $row{domwarn} = $msg;
     1082    } else {
    12161083      $row{domerr} = $msg;
    1217       push @bulkresults, \%row;
    1218     }
    1219     $page->param(bulkresults => \@bulkresults);
    1220 
    1221   } # move/(de)activate/delete if()
    1222 
    1223   # not going to handle the unknown $webvar{action} else;  it should not be possible in normal
    1224   # operations, and anyone who meddles with the URL gets what they deserve.
     1084    }
     1085    push @bulkresults, \%row;
     1086
     1087  } # foreach (keys %webvar)
     1088  $page->param(bulkresults => \@bulkresults);
    12251089
    12261090  # Yes, this is a GOTO target.  PTHBTTT.
    … …  
    12351099      $flag = 1 if isParent($dbh, $_, 'group', $webvar{id}, 'user');
    12361100    }
    1237     if ($flag && ($permissions{admin} || $permissions{user_edit})) {
     1101    if ($flag && ($permissions{admin} || $permissions{user_edit} ||
     1102        ($permissions{self_edit} && $webvar{id} == $session->param('uid')) )) {
    12381103      my $stat = userStatus($dbh,$webvar{id},$webvar{userstatus});
    1239       logaction(0, $session->param("username"), parentID($dbh, (id => $webvar{id}, type => 'user')),
    1240         ($stat ? 'Enabled' : 'Disabled')." ".userFullName($dbh, $webvar{id}, '%u'));
    1241       $page->param(resultmsg => ($stat ? 'Enabled' : 'Disabled')." ".userFullName($dbh, $webvar{id}, '%u'));
     1104      $page->param(resultmsg => $DNSDB::resultstr);
    12421105    } else {
    12431106      $page->param(errmsg => "You are not permitted to view or change the requested user");
    … …  
    12551118  $page->param(deluser => $permissions{admin} || $permissions{user_delete});
    12561119
    1257   if ($session->param('resultmsg')) {
    1258     $page->param(resultmsg => $session->param('resultmsg'));
    1259     $session->clear('resultmsg');
    1260   }
    1261   if ($session->param('warnmsg')) {
    1262     $page->param(warnmsg => $session->param('warnmsg'));
    1263     $session->clear('warnmsg');
    1264   }
    1265   if ($session->param('errmsg')) {
    1266     $page->param(errmsg => $session->param('errmsg'));
    1267     $session->clear('errmsg');
    1268   }
     1120  show_msgs();
    12691121  $page->param(curpage => $webvar{page});
    12701122
    … …  
    12931145    $page->param(add => 1) if $webvar{useraction} eq 'add';
    12941146
    1295     my ($code,$msg);
     1147    # can't re-use $code and $msg for update if we want to be able to identify separate failure states
     1148    my ($code,$code2,$msg,$msg2) = ('OK','OK','OK','OK');
    12961149
    12971150    my $alterperms = 0; # flag iff we need to force custom permissions due to user's current access limits
    … …  
    13401193        $permstring = 'i';
    13411194      }
     1195      # "Chained" permissions.  Some permissions imply others;  make sure they get set.
     1196      foreach (keys %permchains) {
     1197        if ($newperms{$_} && !$newperms{$permchains{$_}}) {
     1198          $newperms{$permchains{$_}} = 1;
     1199          $permstring .= ",$permchains{$_}";
     1200        }
     1201      }
    13421202      if ($webvar{useraction} eq 'add') {
    13431203        changepage(page => "useradmin", errmsg => "You do not have permission to add new users")
    … …  
    13471207                ($webvar{makeactive} eq 'on' ? 1 : 0), $webvar{accttype}, $permstring,
    13481208                $webvar{fname}, $webvar{lname}, $webvar{phone});
    1349         logaction(0, $session->param("username"), $curgroup, "Added user $webvar{uname} (uid $msg)")
    1350                 if $code eq 'OK';
    13511209      } else {
    13521210        changepage(page => "useradmin", errmsg => "You do not have permission to edit users")
    1353                 unless $permissions{admin} || $permissions{user_edit};
     1211                unless $permissions{admin} || $permissions{user_edit} ||
     1212                        ($permissions{self_edit} && $session->param('uid') == $webvar{uid});
    13541213        # security check - does the user have permission to access this entity?
    13551214        if (!check_scope(id => $webvar{user}, type => 'user')) {
    13561215          changepage(page => "useradmin", errmsg => "You do not have permission to edit the requested user");
    13571216        }
    1358 # User update is icky.  I'd really like to do this in one atomic
    1359 # operation, but that would duplicate a **lot** of code in DNSDB.pm
     1217# User update is icky.  I'd really like to do this in one atomic operation,
     1218# but that gets hairy by either duplicating a **lot** of code in DNSDB.pm
     1219# or self-torture trying to not commit the transaction until we're really done.
    13601220        # Allowing for changing group, but not coding web support just yet.
    13611221        ($code,$msg) = updateUser($dbh, $webvar{uid}, $webvar{uname}, $webvar{gid}, $webvar{pass1},
    … …  
    13641224        if ($code eq 'OK') {
    13651225          $newperms{admin} = 1 if $webvar{accttype} eq 'S';
    1366           ($code,$msg) = changePermissions($dbh, 'user', $webvar{uid}, \%newperms, ($permstring eq 'i'));
    1367           logaction(0, $session->param("username"), $curgroup,
    1368                 "Updated uid $webvar{uid}, user $webvar{uname} ($webvar{fname} $webvar{lname})");
     1226          ($code2,$msg2) = changePermissions($dbh, 'user', $webvar{uid}, \%newperms, ($permstring eq 'i'));
    13691227        }
    13701228      }
    13711229    }
    13721230
    1373     if ($code eq 'OK') {
    1374 
     1231    if ($code eq 'OK' && $code2 eq 'OK') {
     1232      my %pageparams = (page => "useradmin");
    13751233      if ($alterperms) {
    1376         changepage(page => "useradmin", warnmsg =>
    1377                 "You can only grant permissions you hold.  $webvar{uname} ".
    1378                 ($webvar{useraction} eq 'add' ? 'added' : 'updated')." with reduced access.");
     1234        $pageparams{warnmsg} = "You can only grant permissions you hold.\nUser ".
     1235                ($webvar{useraction} eq 'add' ? "$webvar{uname} added" : "info updated for $webvar{uname}").
     1236                ".\nPermissions ".($webvar{useraction} eq 'add' ? 'added' : 'updated')." with reduced access.";
    13791237      } else {
    1380         changepage(page => "useradmin", resultmsg => "Successfully ".
    1381                 ($webvar{useraction} eq 'add' ? 'added' : 'updated')." user $webvar{uname}");
     1238        $pageparams{resultmsg} = "$msg".($webvar{useraction} eq 'add' ? '' : "\n$msg2");
    13821239      }
     1240      changepage(%pageparams);
    13831241
    13841242    # add/update failed:
    … …  
    13991257      $page->param(pass1 => $webvar{pass1});
    14001258      $page->param(pass2 => $webvar{pass2});
    1401       $page->param(errmsg => $msg);
     1259      $page->param(errmsg => "User info updated but permissions update failed: $msg2") if $code eq 'OK';
     1260      $page->param(errmsg => $msg) if $code ne 'OK';
    14021261      fill_permissions($page, \%newperms);
    14031262      fill_actypelist($webvar{accttype});
    14041263      fill_clonemelist();
    1405       logaction(0, $session->param("username"), $curgroup, "Failed to $webvar{useraction} user ".
    1406         "$webvar{uname}: $msg")
    1407         if $config{log_failures};
    14081264    }
    14091265
    … …  
    14111267
    14121268    changepage(page => "useradmin", errmsg => "You do not have permission to edit users")
    1413         unless $permissions{admin} || $permissions{user_edit};
     1269        unless $permissions{admin} || $permissions{user_edit} ||
     1270                ($permissions{self_edit} && $session->param('uid') == $webvar{user});
    14141271
    14151272    # security check - does the user have permission to access this entity?
    … …  
    14261283    fill_actypelist($userinfo->{type});
    14271284    # not using this yet, but adding it now means we can *much* more easily do so later.
    1428     $page->param(gid => $webvar{group_id});
     1285    $page->param(gid => $userinfo->{group_id});
    14291286
    14301287    my %curperms;
    … …  
    14671324    $page->param(user => userFullName($dbh,$webvar{id}));
    14681325  } elsif ($webvar{del} eq 'ok') {
    1469 ##fixme: find group id user is in (for logging) *before* we delete the user
    1470 ##fixme: get other user data too for log
    1471     my $userref = getUserData($dbh, $webvar{id});
    14721326    my ($code,$msg) = delUser($dbh, $webvar{id});
    14731327    if ($code eq 'OK') {
    14741328      # success.  go back to the user list, do not pass "GO"
    1475       # actions on users have a domain id of 0, always
    1476       logaction(0, $session->param("username"), $curgroup, "Deleted user $webvar{id}/".$userref->{username}.
    1477         " (".$userref->{lastname}.", ".$userref->{firstname}.")");
    1478       changepage(page => "useradmin", resultmsg => "Deleted user ".$userref->{username}.
    1479         " (".$userref->{lastname}.", ".$userref->{firstname}.")");
     1329      changepage(page => "useradmin", resultmsg => $msg);
    14801330    } else {
    1481 # need to find failure mode
    1482       $page->param(del_failed => 1);
    1483       $page->param(errmsg => $msg);
    1484       list_users($curgroup);
    1485       logaction(0, $session->param("username"), $curgroup, "Failed to delete user ".
    1486         "$webvar{id}/".$userref->{username}.": $msg")
    1487         if $config{log_failures};
     1331      changepage(page => "useradmin", errmsg => $msg);
    14881332    }
    14891333  } else {
    14901334    # cancelled.  whee!
    14911335    changepage(page => "useradmin");
     1336  }
     1337
     1338} elsif ($webvar{page} eq 'loclist') {
     1339
     1340  changepage(page => "domlist", errmsg => "You are not allowed access to this function")
     1341        unless $permissions{admin} || $permissions{location_view};
     1342
     1343  # security check - does the user have permission to access this entity?
     1344#  if (!check_scope(id => $webvar{id}, type => 'loc')) {
     1345#    changepage(page => "loclist", errmsg => "You are not permitted to <foo> the requested location/view");
     1346#  }
     1347  list_locations();
     1348  show_msgs();
     1349
     1350# Permissions!
     1351  $page->param(addloc => $permissions{admin} || $permissions{location_create});
     1352  $page->param(delloc => $permissions{admin} || $permissions{location_delete});
     1353
     1354} elsif ($webvar{page} eq 'location') {
     1355
     1356  changepage(page => "domlist", errmsg => "You are not allowed access to this function")
     1357        unless $permissions{admin} || $permissions{location_view};
     1358
     1359  # security check - does the user have permission to access this entity?
     1360#  if (!check_scope(id => $webvar{id}, type => 'loc')) {
     1361#    changepage(page => "loclist", errmsg => "You are not permitted to <foo> the requested location/view");
     1362#  }
     1363
     1364  if ($webvar{locact} eq 'new') {
     1365    # uuhhmm....
     1366  } elsif ($webvar{locact} eq 'add') {
     1367    changepage(page => "loclist", errmsg => "You are not permitted to add locations/views", id => $webvar{parentid})
     1368        unless ($permissions{admin} || $permissions{location_create});
     1369
     1370    my ($code,$msg) = addLoc($dbh, $curgroup, $webvar{locname}, $webvar{comments}, $webvar{iplist});
     1371
     1372    if ($code eq 'OK' || $code eq 'WARN') {
     1373      my %pageparams = (page => "loclist", id => $webvar{parentid},
     1374        defrec => $webvar{defrec}, revrec => $webvar{revrec});
     1375      $pageparams{warnmsg} = $msg."<br><br>\n".$DNSDB::resultstr if $code eq 'WARN';
     1376      $pageparams{resultmsg} = $DNSDB::resultstr if $code eq 'OK';
     1377      changepage(%pageparams);
     1378    } else {
     1379      $page->param(failed       => 1);
     1380      $page->param(errmsg       => $msg);
     1381      $page->param(wastrying    => "adding");
     1382      $page->param(todo         => "Add location/view");
     1383      $page->param(locact       => "add");
     1384      $page->param(id           => $webvar{id});
     1385      $page->param(locname      => $webvar{locname});
     1386      $page->param(comments     => $webvar{comments});
     1387      $page->param(iplist       => $webvar{iplist});
     1388    }
     1389
     1390  } elsif ($webvar{locact} eq 'edit') {
     1391    changepage(page => "loclist", errmsg => "You are not permitted to edit locations/views", id => $webvar{parentid})
     1392        unless ($permissions{admin} || $permissions{location_edit});
     1393
     1394    my $loc = getLoc($dbh, $webvar{loc});
     1395    $page->param(wastrying      => "editing");
     1396    $page->param(todo           => "Edit location/view");
     1397    $page->param(locact         => "update");
     1398    $page->param(id             => $webvar{loc});
     1399    $page->param(locname        => $loc->{description});
     1400    $page->param(comments       => $loc->{comments});
     1401    $page->param(iplist         => $loc->{iplist});
     1402
     1403  } elsif ($webvar{locact} eq 'update') {
     1404    changepage(page => "loclist", errmsg => "You are not permitted to edit locations/views", id => $webvar{parentid})
     1405        unless ($permissions{admin} || $permissions{location_edit});
     1406
     1407    my ($code,$msg) = updateLoc($dbh, $webvar{id}, $curgroup, $webvar{locname}, $webvar{comments}, $webvar{iplist});
     1408
     1409    if ($code eq 'OK') {
     1410      changepage(page => "loclist", resultmsg => $msg);
     1411    } else {
     1412      $page->param(failed       => 1);
     1413      $page->param(errmsg       => $msg);
     1414      $page->param(wastrying    => "editing");
     1415      $page->param(todo         => "Edit location/view");
     1416      $page->param(locact       => "update");
     1417      $page->param(id           => $webvar{loc});
     1418      $page->param(locname      => $webvar{locname});
     1419      $page->param(comments     => $webvar{comments});
     1420      $page->param(iplist       => $webvar{iplist});
     1421    }
     1422  } else {
     1423    changepage(page => "loclist", errmsg => "You are not permitted to add locations/views", id => $webvar{parentid})
     1424        unless ($permissions{admin} || $permissions{location_create});
     1425
     1426    $page->param(todo => "Add location/view");
     1427    $page->param(locact => "add");
     1428    $page->param(locname => ($webvar{locname} ? $webvar{locname} : ''));
     1429    $page->param(iplist => ($webvar{iplist} ? $webvar{iplist} : ''));
     1430
     1431    show_msgs();
    14921432  }
    14931433
    … …  
    15711511  $page->param(forcettl => $webvar{forcettl}) if $webvar{forcettl};
    15721512  $page->param(newttl => $webvar{newttl}) if $webvar{newttl};
     1513  # This next one is arguably better on by default, but Breaking Things Is Bad, Mmmkay?
     1514  $page->param(mergematching => $webvar{mergematching}) if $webvar{mergematching};
    15731515  $page->param(dominactive => 1) if (!$webvar{domactive} && $webvar{doit});     # eww.
    15741516  $page->param(importdoms => $webvar{importdoms}) if $webvar{importdoms};
    … …  
    15891531    }
    15901532
     1533    # Bizarre Things Happen when you AXFR a null-named zone.
     1534    $webvar{importdoms} =~ s/^\s+//;
    15911535    my @domlist = split /\s+/, $webvar{importdoms};
    15921536    my @results;
    … …  
    15941538      my %row;
    15951539      my ($code,$msg) = importAXFR($dbh, $webvar{ifrom}, $domain, $webvar{group},
    1596         $webvar{domstatus}, $webvar{rwsoa}, $webvar{rwns}, ($webvar{forcettl} ? $webvar{newttl} : 0) );
     1540        $webvar{domstatus}, $webvar{rwsoa}, $webvar{rwns}, ($webvar{forcettl} ? $webvar{newttl} : 0),
     1541        $webvar{mergematching});
    15971542      $row{domok} = $msg if $code eq 'OK';
    15981543      if ($code eq 'WARN') {
    … …  
    16051550      }
    16061551      $msg = "<br />\n".$msg if $msg =~ m|<br />|;
    1607       logaction(domainID($dbh, $domain), $session->param("username"), $webvar{group},
    1608         "AXFR import $domain from $webvar{ifrom} ($code): $msg");
    16091552      $row{domain} = $domain;
    16101553      push @results, \%row;
    … …  
    16491592} elsif ($webvar{page} eq 'log') {
    16501593
    1651 ##fixme put in some real log-munching stuff
    1652   my $sql = "SELECT user_id, email, name, entry, date_trunc('second',stamp) FROM log WHERE ";
    16531594  my $id = $curgroup;  # we do this because the group log may be called from (almost) any page,
    16541595                       # but the others are much more limited.  this is probably non-optimal.
    16551596
    16561597  if ($webvar{ltype} && $webvar{ltype} eq 'user') {
    1657     $sql .= "user_id=?";
     1598##fixme:  where should we call this from?
    16581599    $id = $webvar{id};
    16591600    if (!check_scope(id => $id, type => 'user')) {
    … …  
    16631604    $page->param(logfor => 'user '.userFullName($dbh,$id));
    16641605  } elsif ($webvar{ltype} && $webvar{ltype} eq 'dom') {
    1665     $sql .= "domain_id=?";
    16661606    $id = $webvar{id};
    16671607    if (!check_scope(id => $id, type => 'domain')) {
    … …  
    16711611    $page->param(logfor => 'domain '.domainName($dbh,$id));
    16721612  } elsif ($webvar{ltype} && $webvar{ltype} eq 'rdns') {
    1673     $sql .= "rdns_id=?";
    16741613    $id = $webvar{id};
    16751614    if (!check_scope(id => $id, type => 'revzone')) {
    … …  
    16801619  } else {
    16811620    # Default to listing curgroup log
    1682     $sql .= "group_id=?";
    16831621    $page->param(logfor => 'group '.groupName($dbh,$id));
    16841622    # note that scope limitations are applied via the change-group check;
    16851623    # group log is always for the "current" group
    16861624  }
     1625  $webvar{ltype} = 'group' if !$webvar{ltype};
     1626  my $lcount = getLogCount($dbh, (id => $id, logtype => $webvar{ltype})) or push @debugbits, $DNSDB::errstr;
     1627
     1628  $page->param(id => $id);
     1629  $page->param(ltype => $webvar{ltype});
     1630
     1631  fill_fpnla($lcount);
     1632  fill_pgcount($lcount, "log entries", '');
     1633  $page->param(curpage => $webvar{page}.($webvar{ltype} ? "&amp;ltype=$webvar{ltype}" : ''));
     1634
     1635  $sortby = 'stamp';
     1636  $sortorder = 'DESC';  # newest-first;  although filtering is probably going to be more useful than sorting
     1637# sort/order
     1638  $session->param($webvar{page}.'sortby', $webvar{sortby}) if $webvar{sortby};
     1639  $session->param($webvar{page}.'order', $webvar{order}) if $webvar{order};
     1640
     1641  $sortby = $session->param($webvar{page}.'sortby') if $session->param($webvar{page}.'sortby');
     1642  $sortorder = $session->param($webvar{page}.'order') if $session->param($webvar{page}.'order');
     1643
     1644  # Set up the column headings with the sort info
     1645  my @cols = ('fname','username','entry','stamp');
     1646  my %colnames = (fname => 'Name', username => 'Username/Email', entry => 'Log Entry', stamp => 'Date/Time');
     1647  fill_colheads($sortby, $sortorder, \@cols, \%colnames);
     1648
     1649##fixme:  increase per-page limit or use separate limit for log?  some ops give *lots* of entries...
     1650  my $logentries = getLogEntries($dbh, (id => $id, logtype => $webvar{ltype},
     1651        offset => $webvar{offset}, sortby => $sortby, sortorder => $sortorder));
     1652  $page->param(logentries => $logentries);
     1653
    16871654##fixme:
    16881655# - filtering
    16891656# - show reverse zone column?
    1690 # - pagination/limiting number of records - put newest-first so user
    1691 #   doesn't always need to go to the last page for recent activity?
    1692   my $sth = $dbh->prepare($sql);
    1693   $sth->execute($id);
    1694   my @logbits;
    1695   while (my ($uid, $email, $name, $entry, $stamp) = $sth->fetchrow_array) {
    1696     my %row;
    1697     $row{userfname} = $name;
    1698     $row{userid} = $uid;
    1699     $row{useremail} = $email;
    1700     $row{logentry} = $entry;
    1701     ($row{logtime}) = ($stamp =~ /^(.+)-\d\d$/);
    1702     push @logbits, \%row;
    1703   }
    1704   $page->param(logentries => \@logbits);
     1657# - on log record creation, bundle "parented" log actions (eg, "AXFR record blah for domain foo",
     1658#   or "Add record bar for new domain baz") into one entry (eg, "AXFR domain foo", "Add domain baz")?
     1659#   need a way to expand this into the complete list, and to exclude "child" entries
    17051660
    17061661  # scope check fail target
    … …  
    17141669
    17151670##common bits
     1671# mostly things in the menu
    17161672if ($webvar{page} ne 'login' && $webvar{page} ne 'badpage') {
    17171673  $page->param(username => $session->param("username"));
    … …  
    17241680##fixme
    17251681  $page->param(mayrdns => 1);
     1682
     1683  $page->param(mayloc => ($permissions{admin} || $permissions{location_view}));
    17261684
    17271685  $page->param(maydefrec => $permissions{admin});
    … …  
    18111769  # than set them locally everywhere.
    18121770  foreach my $sessme ('resultmsg','warnmsg','errmsg') {
    1813     if ($params{$sessme}) {
    1814       $session->param($sessme, $params{$sessme});
     1771    if (my $tmp = $params{$sessme}) {
     1772      $tmp =~ s/^\n//;
     1773      $tmp =~ s|\n|<br />\n|g;
     1774      $session->param($sessme, $tmp);
    18151775      delete $params{$sessme};
    18161776    }
    … …  
    18301790} # end changepage
    18311791
     1792# wrap up the usual suspects for result, warning, or error messages to be displayed
     1793sub show_msgs {
     1794  if ($session->param('resultmsg')) {
     1795    $page->param(resultmsg => $session->param('resultmsg'));
     1796    $session->clear('resultmsg');
     1797  }
     1798  if ($session->param('warnmsg')) {
     1799    $page->param(warnmsg => $session->param('warnmsg'));
     1800    $session->clear('warnmsg');
     1801  }
     1802  if ($session->param('errmsg')) {
     1803    $page->param(errmsg => $session->param('errmsg'));
     1804    $session->clear('errmsg');
     1805  }
     1806} # end show_msgs
     1807
    18321808sub fillsoa {
    1833   my $def = shift;
     1809  my $defrec = shift;
     1810  my $revrec = shift;
    18341811  my $id = shift;
    1835   my $domname = ($def eq 'y' ? '' : "DOMAIN");
    1836 
    1837   $page->param(defrec   => $def);
     1812  my $preserve = shift || 'd';  # Flag to use webvar fields or retrieve from database
     1813
     1814  my $domname = ($defrec eq 'y' ? '' : "DOMAIN");
     1815
     1816  $page->param(defrec   => $defrec);
     1817  $page->param(revrec   => $revrec);
    18381818
    18391819# i had a good reason to do this when I wrote it...
    18401820#  $page->param(domain  => $domname);
    18411821#  $page->param(group   => $DNSDB::group);
    1842   $page->param(isgrp => 1) if $def eq 'y';
    1843   $page->param(parent => ($def eq 'y' ? groupName($dbh, $DNSDB::group) : domainName($dbh, $id)) );
     1822  $page->param(isgrp => 1) if $defrec eq 'y';
     1823  $page->param(parent => ($defrec eq 'y' ? groupName($dbh, $id) :
     1824        ($revrec eq 'n' ? domainName($dbh, $id) : revName($dbh, $id)) ) );
    18441825
    18451826# defaults
    … …  
    18521833  $page->param(defminttl        => $DNSDB::def{minttl});
    18531834
    1854   # there are probably better ways to do this.  TMTOWTDI.
    1855   my %soa = getSOA($dbh,$def,$id);
    1856 
    18571835  $page->param(id       => $id);
    1858   $page->param(recid    => $soa{recid});
    1859   $page->param(prins    => ($soa{prins} ? $soa{prins} : $DNSDB::def{prins}));
    1860   $page->param(contact  => ($soa{contact} ? $soa{contact} : $DNSDB::def{contact}));
    1861   $page->param(refresh  => ($soa{refresh} ? $soa{refresh} : $DNSDB::def{refresh}));
    1862   $page->param(retry    => ($soa{retry} ? $soa{retry} : $DNSDB::def{retry}));
    1863   $page->param(expire   => ($soa{expire} ? $soa{expire} : $DNSDB::def{expire}));
    1864   $page->param(minttl   => ($soa{minttl} ? $soa{minttl} : $DNSDB::def{minttl}));
    1865   $page->param(ttl      => ($soa{ttl} ? $soa{ttl} : $DNSDB::def{soattl}));
     1836
     1837  if ($preserve eq 'd') {
     1838    # there are probably better ways to do this.  TMTOWTDI.
     1839    my $soa = getSOA($dbh,$defrec,$revrec,$id);
     1840
     1841    $page->param(prins  => ($soa->{prins} ? $soa->{prins} : $DNSDB::def{prins}));
     1842    $page->param(contact        => ($soa->{contact} ? $soa->{contact} : $DNSDB::def{contact}));
     1843    $page->param(refresh        => ($soa->{refresh} ? $soa->{refresh} : $DNSDB::def{refresh}));
     1844    $page->param(retry  => ($soa->{retry} ? $soa->{retry} : $DNSDB::def{retry}));
     1845    $page->param(expire => ($soa->{expire} ? $soa->{expire} : $DNSDB::def{expire}));
     1846    $page->param(minttl => ($soa->{minttl} ? $soa->{minttl} : $DNSDB::def{minttl}));
     1847    $page->param(ttl    => ($soa->{ttl} ? $soa->{ttl} : $DNSDB::def{soattl}));
     1848  } else {
     1849    $page->param(prins  => ($webvar{prins} ? $webvar{prins} : $DNSDB::def{prins}));
     1850    $page->param(contact        => ($webvar{contact} ? $webvar{contact} : $DNSDB::def{contact}));
     1851    $page->param(refresh        => ($webvar{refresh} ? $webvar{refresh} : $DNSDB::def{refresh}));
     1852    $page->param(retry  => ($webvar{retry} ? $webvar{retry} : $DNSDB::def{retry}));
     1853    $page->param(expire => ($webvar{expire} ? $webvar{expire} : $DNSDB::def{expire}));
     1854    $page->param(minttl => ($webvar{minttl} ? $webvar{minttl} : $DNSDB::def{minttl}));
     1855    $page->param(ttl    => ($webvar{ttl} ? $webvar{ttl} : $DNSDB::def{soattl}));
     1856  }
    18661857}
    18671858
    … …  
    18721863
    18731864  # get the SOA first
    1874   my %soa = getSOA($dbh,$def,$rev,$id);
    1875 
    1876   $page->param(contact  => $soa{contact});
    1877   $page->param(prins    => $soa{prins});
    1878   $page->param(refresh  => $soa{refresh});
    1879   $page->param(retry    => $soa{retry});
    1880   $page->param(expire   => $soa{expire});
    1881   $page->param(minttl   => $soa{minttl});
    1882   $page->param(ttl      => $soa{ttl});
    1883 
    1884   my $foo2 = getDomRecs($dbh,$def,$rev,$id,$perpage,$webvar{offset},$sortby,$sortorder,$filter);
    1885 
    1886   my $row = 0;
     1865  my $soa = getSOA($dbh,$def,$rev,$id);
     1866
     1867  $page->param(contact  => $soa->{contact});
     1868  $page->param(prins    => $soa->{prins});
     1869  $page->param(refresh  => $soa->{refresh});
     1870  $page->param(retry    => $soa->{retry});
     1871  $page->param(expire   => $soa->{expire});
     1872  $page->param(minttl   => $soa->{minttl});
     1873  $page->param(ttl      => $soa->{ttl});
     1874
     1875  my $foo2 = getDomRecs($dbh,(defrec => $def, revrec => $rev, id => $id, offset => $webvar{offset},
     1876        sortby => $sortby, sortorder => $sortorder, filter => $filter));
     1877
    18871878  foreach my $rec (@$foo2) {
    18881879    $rec->{type} = $typemap{$rec->{type}};
    1889     $rec->{row} = $row % 2;
    1890     $rec->{defrec} = $def;
    1891     $rec->{revrec} = $rev;
    18921880    $rec->{sid} = $webvar{sid};
    1893     $rec->{id} = $id;
    18941881    $rec->{fwdzone} = $rev eq 'n';
    18951882    $rec->{distance} = 'n/a' unless ($rec->{type} eq 'MX' || $rec->{type} eq 'SRV');
    18961883    $rec->{weight} = 'n/a' unless ($rec->{type} eq 'SRV');
    18971884    $rec->{port} = 'n/a' unless ($rec->{type} eq 'SRV');
    1898     $row++;
    18991885# ACLs
    19001886    $rec->{record_edit} = ($permissions{admin} || $permissions{record_edit});
    19011887    $rec->{record_delete} = ($permissions{admin} || $permissions{record_delete});
     1888    $rec->{locname} = '' unless ($permissions{admin} || $permissions{location_view});
    19021889  }
    19031890  $page->param(reclist => $foo2);
    … …  
    19141901  if ($webvar{revrec} eq 'n') {
    19151902    my $domroot = ($webvar{defrec} eq 'y' ? 'DOMAIN' : domainName($dbh,$webvar{parentid}));
    1916     $page->param(name   => $domroot);
     1903    $page->param(name   => ($webvar{name} ? $webvar{name} : $domroot));
    19171904    $page->param(address        => $webvar{address});
    19181905    $page->param(distance       => $webvar{distance})
    … …  
    19281915  }
    19291916# retrieve the right ttl instead of falling (way) back to the hardcoded system default
    1930   my %soa = getSOA($dbh,$webvar{defrec},$webvar{revrec},$webvar{parentid});
    1931   $page->param(ttl      => ($webvar{ttl} ? $webvar{ttl} : $soa{minttl}));
     1917  my $soa = getSOA($dbh,$webvar{defrec},$webvar{revrec},$webvar{parentid});
     1918  $page->param(ttl      => ($webvar{ttl} ? $webvar{ttl} : $soa->{minttl}));
    19321919}
    19331920
    … …  
    19491936
    19501937sub fill_clonemelist {
    1951   my $sth = $dbh->prepare("SELECT username,user_id FROM users WHERE group_id=$curgroup");
    1952   $sth->execute;
    1953 
    19541938  # shut up some warnings, but don't stomp on caller's state
    19551939  local $webvar{clonesrc} = 0 if !defined($webvar{clonesrc});
    19561940
    1957   my @clonesrc;
    1958   while (my ($username,$uid) = $sth->fetchrow_array) {
    1959     my %row = (
    1960         username => $username,
    1961         uid => $uid,
    1962         selected => ($webvar{clonesrc} == $uid ? 1 : 0)
    1963         );
    1964     push @clonesrc, \%row;
    1965   }
    1966   $page->param(clonesrc => \@clonesrc);
     1941  my $clones = getUserDropdown($dbh, $curgroup, $webvar{clonesrc});
     1942  $page->param(clonesrc => $clones);
    19671943}
    19681944
    … …  
    20912067  my $childlist = join(',',@childgroups);
    20922068
    2093   my $sql = "SELECT count(*) FROM groups WHERE parent_group_id IN ($curgroup".($childlist ? ",$childlist" : '').")".
    2094         ($startwith ? " AND group_name ~* ?" : '').
    2095         ($filter ? " AND group_name ~* ?" : '');
    2096   my $sth = $dbh->prepare($sql);
    2097   $sth->execute(@filterargs);
    2098   my ($count) = ($sth->fetchrow_array);
     2069  my ($count) = getGroupCount($dbh, (childlist => $childlist, curgroup => $curgroup,
     2070        filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef) ) );
    20992071
    21002072# fill page count and first-previous-next-last-all bits
    … …  
    21132085
    21142086# set up the headers
    2115   my @cols = ('group','parent','nusers','ndomains');
    2116   my %colnames = (group => 'Group', parent => 'Parent Group', nusers => 'Users', ndomains => 'Domains');
     2087  my @cols = ('group','parent','nusers','ndomains','nrevzones');
     2088  my %colnames = (group => 'Group', parent => 'Parent Group', nusers => 'Users', ndomains => 'Domains', nrevzones => 'Reverse Zones');
    21172089  fill_colheads($sortby, $sortorder, \@cols, \%colnames);
    21182090
    … …  
    21272099  $sortby = 'g2.group_name' if $sortby eq 'parent';
    21282100
    2129   my @grouplist;
    2130   $sql = "SELECT g.group_id, g.group_name, g2.group_name, ".
    2131         "count(distinct(u.username)) AS nusers, count(distinct(d.domain)) AS ndomains ".
    2132         "FROM groups g ".
    2133         "INNER JOIN groups g2 ON g2.group_id=g.parent_group_id ".
    2134         "LEFT OUTER JOIN users u ON u.group_id=g.group_id ".
    2135         "LEFT OUTER JOIN domains d ON d.group_id=g.group_id ".
    2136         "WHERE g.parent_group_id IN ($curgroup".($childlist ? ",$childlist" : '').") ".
    2137         ($startwith ? " AND g.group_name ~* ?" : '').
    2138         ($filter ? " AND g.group_name ~* ?" : '').
    2139         " GROUP BY g.group_id, g.group_name, g2.group_name ".
    2140         " ORDER BY $sortby $sortorder ".
    2141         ($offset eq 'all' ? '' : " LIMIT $perpage OFFSET ".$offset*$perpage);
    2142   $sth = $dbh->prepare($sql);
    2143   $sth->execute(@filterargs);
    2144 
    2145   my $rownum = 0;
    2146   while (my @data = $sth->fetchrow_array) {
    2147     my %row;
    2148     $row{groupid} = $data[0];
    2149     $row{groupname} = $data[1];
    2150     $row{pgroup} = $data[2];
    2151     $row{nusers} = $data[3];
    2152     $row{ndomains} = $data[4];
    2153     $row{bg} = ($rownum++)%2;
    2154     $row{sid} = $sid;
    2155     $row{edgrp} = ($permissions{admin} || $permissions{group_edit});
    2156     $row{delgrp} = ($permissions{admin} || $permissions{group_delete});
    2157     push @grouplist, \%row;
    2158   }
    2159   $page->param(grouptable => \@grouplist);
     2101  my $glist = getGroupList($dbh, (childlist => $childlist, curgroup => $curgroup,
     2102        filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef),
     2103        offset => $webvar{offset}, sortby => $sortby, sortorder => $sortorder) );
     2104
     2105  $page->param(grouptable => $glist);
    21602106} # end listgroups()
    21612107
    … …  
    21652111  my $cur = shift || $curgroup;
    21662112
    2167   my @childgroups;
    2168   getChildren($dbh, $logingroup, \@childgroups, 'all');
    2169   my $childlist = join(',',@childgroups);
    2170 
    2171 ##fixme:  need to reorder list so that we can display a pseudotree in group dropdowns
    2172 
    2173   # weesa gonna discard parent_group_id for now
    2174   my $sth = $dbh->prepare("SELECT group_id,parent_group_id,group_name FROM groups ".
    2175         "WHERE group_id IN ($logingroup".($childlist ? ",$childlist" : '').")".
    2176         "ORDER BY group_id");
    2177   $sth->execute;
     2113  # little recursive utility sub-sub
     2114  sub getgroupdrop {
     2115    my $root = shift;
     2116    my $cur = shift;    # to tag the selected group
     2117    my $grplist = shift;
     2118    my $indent = shift || '&nbsp;&nbsp;&nbsp;&nbsp;';
     2119
     2120    my @childlist;
     2121    getChildren($dbh,$root,\@childlist,'immediate');
     2122    return if $#childlist == -1;
     2123    foreach (@childlist) {
     2124      my %row;
     2125      $row{groupval} = $_;
     2126      $row{groupactive} = ($_ == $cur);
     2127      $row{groupname} = $indent.groupName($dbh, $_);
     2128      push @{$grplist}, \%row;
     2129      getgroupdrop($_, $cur, $grplist, $indent.'&nbsp;&nbsp;&nbsp;&nbsp;');
     2130    }
     2131  }
     2132
    21782133  my @grouplist;
    2179   while (my ($groupid,$pargroup,$groupname) = $sth->fetchrow_array()) {
    2180     my %row;
    2181     $row{groupname} = $groupname;
    2182     $row{groupval} = $groupid;
    2183 ##fixme: need magic
    2184 ## ... WTF?
    2185 #    $row{defgroup} = '';
    2186     $row{groupactive} = 1 if $groupid == $cur;
    2187     push @grouplist, \%row;
    2188   }
     2134  push @grouplist, { groupval => $logingroup, groupactive => $logingroup == $curgroup,
     2135        groupname => groupName($dbh, $logingroup) };
     2136  getgroupdrop($logingroup, $curgroup, \@grouplist);
    21892137
    21902138  $page->param("$template_var" => \@grouplist);
    2191 
    21922139} # end fill_grouplist()
     2140
     2141
     2142sub fill_loclist {
     2143  my $cur = shift || $curgroup;
     2144  my $defloc = shift || '';
     2145
     2146  return unless ($permissions{admin} || $permissions{location_view});
     2147
     2148  $page->param(location_view => ($permissions{admin} || $permissions{location_view}));
     2149
     2150  if ($permissions{admin} || $permissions{record_locchg}) {
     2151    my $loclist = getLocDropdown($dbh, $cur, $defloc);
     2152    $page->param(record_locchg => 1);
     2153    $page->param(loclist => $loclist);
     2154  } else {
     2155    my $loc = getLoc($dbh, $defloc);
     2156    $page->param(loc_name => $loc->{description});
     2157  }
     2158} # end fill_loclist()
    21932159
    21942160
    … …  
    21992165  my $childlist = join(',',@childgroups);
    22002166
    2201   my $sql = "SELECT count(*) FROM users WHERE group_id IN ($curgroup".($childlist ? ",$childlist" : '').")".
    2202         ($startwith ? " AND username ~* ?" : '').
    2203         ($filter ? " AND username ~* ?" : '');
    2204   my $sth = $dbh->prepare($sql);
    2205   $sth->execute(@filterargs);
    2206   my ($count) = ($sth->fetchrow_array);
     2167  my $count = getUserCount($dbh, (childlist => $childlist, curgroup => $curgroup,
     2168        filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef) ) );
    22072169
    22082170# fill page count and first-previous-next-last-all bits
    … …  
    22292191  $page->param(searchsubs => $searchsubs) if $searchsubs;
    22302192
    2231 # munge sortby for columns in database
    2232   $sortby = 'u.username' if $sortby eq 'user';
    2233   $sortby = 'u.type' if $sortby eq 'type';
    2234   $sortby = 'g.group_name' if $sortby eq 'group';
    2235   $sortby = 'u.status' if $sortby eq 'status';
    2236 
    2237   my @userlist;
    2238   $sql = "SELECT u.user_id, u.username, u.firstname || ' ' || u.lastname AS fname, u.type, g.group_name, u.status ".
    2239         "FROM users u ".
    2240         "INNER JOIN groups g ON u.group_id=g.group_id ".
    2241         "WHERE u.group_id IN ($curgroup".($childlist ? ",$childlist" : '').")".
    2242         ($startwith ? " AND u.username ~* ?" : '').
    2243         ($filter ? " AND u.username ~* ?" : '').
    2244         " ORDER BY $sortby $sortorder ".
    2245         ($offset eq 'all' ? '' : " LIMIT $perpage OFFSET ".$offset*$perpage);
    2246 
    2247   $sth = $dbh->prepare($sql);
    2248   $sth->execute(@filterargs);
    2249 
    2250   my $rownum = 0;
    2251   while (my @data = $sth->fetchrow_array) {
    2252     no warnings "uninitialized";        # Just In Case something stupid happens and a user gets no first or last name
    2253     my %row;
    2254     $row{userid} = $data[0];
    2255     $row{username} = $data[1];
    2256     $row{userfull} = $data[2];
    2257     $row{usertype} = ($data[3] eq 'S' ? 'superuser' : "user");
    2258     $row{usergroup} = $data[4];
    2259     $row{active} = $data[5];
    2260     $row{bg} = ($rownum++)%2;
    2261     $row{sid} = $sid;
    2262     $row{eduser} = ($permissions{admin} || $permissions{user_edit});
    2263     $row{deluser} = ($permissions{admin} || $permissions{user_delete});
    2264     push @userlist, \%row;
    2265   }
    2266   $page->param(usertable => \@userlist);
     2193  my $ulist = getUserList($dbh, (childlist => $childlist, curgroup => $curgroup,
     2194        filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef),
     2195        offset => $webvar{offset}, sortby => $sortby, sortorder => $sortorder) );
     2196  # Some UI things need to be done to the list (unlike other lists)
     2197  foreach my $u (@{$ulist}) {
     2198    $u->{eduser} = ($permissions{admin} ||
     2199        ($permissions{user_edit} && $u->{type} ne 'S') ||
     2200        ($permissions{self_edit} && $u->{user_id} == $session->param('uid')) );
     2201    $u->{deluser} = ($permissions{admin} || ($permissions{user_delete} && $u->{type} ne 'S'));
     2202    $u->{type} = ($u->{type} eq 'S' ? 'superuser' : 'user');
     2203  }
     2204  $page->param(usertable => $ulist);
    22672205} # end list_users()
     2206
     2207
     2208sub list_locations {
     2209
     2210  my @childgroups;
     2211  getChildren($dbh, $curgroup, \@childgroups, 'all') if $searchsubs;
     2212  my $childlist = join(',',@childgroups);
     2213
     2214  my $count = getLocCount($dbh, (childlist => $childlist, curgroup => $curgroup,
     2215        filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef) ) );
     2216
     2217# fill page count and first-previous-next-last-all bits
     2218  fill_pgcount($count,"locations/views",'');
     2219  fill_fpnla($count);
     2220
     2221  $sortby = 'user';
     2222# sort/order
     2223  $session->param($webvar{page}.'sortby', $webvar{sortby}) if $webvar{sortby};
     2224  $session->param($webvar{page}.'order', $webvar{order}) if $webvar{order};
     2225
     2226  $sortby = $session->param($webvar{page}.'sortby') if $session->param($webvar{page}.'sortby');
     2227  $sortorder = $session->param($webvar{page}.'order') if $session->param($webvar{page}.'order');
     2228
     2229# set up the headers
     2230  my @cols = ('description', 'iplist', 'group');
     2231  my %colnames = (description => 'Location/View Name', iplist => 'Permitted IPs/Ranges', group => 'Group');
     2232  fill_colheads($sortby, $sortorder, \@cols, \%colnames);
     2233
     2234# waffle, waffle - keep state on these as well as sortby, sortorder?
     2235  $page->param("start$startwith" => 1) if $startwith && $startwith =~ /^(?:[a-z]|0-9)$/;
     2236
     2237  $page->param(filter => $filter) if $filter;
     2238  $page->param(searchsubs => $searchsubs) if $searchsubs;
     2239
     2240  my $loclist = getLocList($dbh, (childlist => $childlist, curgroup => $curgroup,
     2241        filter => ($filter ? $filter : undef), startwith => ($startwith ? $startwith : undef),
     2242        offset => $webvar{offset}, sortby => $sortby, sortorder => $sortorder) );
     2243  # Some UI things need to be done to the list
     2244  foreach my $l (@{$loclist}) {
     2245    $l->{iplist} = "(All IPs)" if !$l->{iplist};
     2246    $l->{edloc} = ($permissions{admin} || $permissions{loc_edit});
     2247    $l->{delloc} = ($permissions{admin} || $permissions{loc_delete});
     2248  }
     2249  $page->param(loctable => $loclist);
     2250} # end list_locations()
    22682251
    22692252
    … …  
    22822265  foreach my $col (@$cols) {
    22832266    my %coldata;
    2284     $coldata{firstcol} = 1 if $col eq $cols->[0];
    22852267    $coldata{sid} = $sid;
    22862268    $coldata{page} = $webvar{page};
    … …  
    23072289
    23082290
    2309 sub logaction {
    2310   my $domid = shift;
    2311   my $username = shift;
    2312   my $groupid = shift;
    2313   my $entry = shift;
    2314   my $revid = shift || 0;
    2315 
    2316 ##fixme: push SQL into DNSDB.pm
    2317 ##fixme: add bits to retrieve group/domain name info to retain after entity is deleted?
    2318   my $sth = $dbh->prepare("SELECT user_id, firstname || ' ' || lastname FROM users WHERE username=?");
    2319   $sth->execute($username);
    2320   my ($user_id, $fullname) = $sth->fetchrow_array;
    2321 
    2322   $sth = $dbh->prepare("INSERT INTO log (domain_id,user_id,group_id,email,name,entry,rdns_id) ".
    2323         "VALUES (?,?,?,?,?,?,?)") or warn $dbh->errstr;
    2324   $sth->execute($domid,$user_id,$groupid,$username,$fullname,$entry,$revid) or warn $sth->errstr;
    2325 } # end logaction()
    2326 
    2327 
    23282291# we have to do this in a variety of places;  let's make it consistent
    23292292sub fill_permissions {

  • branches/stable/dns.sql

    r544 r545  
    1414
    1515COPY misc (misc_id, key, value) FROM stdin;
    16 1       dbversion       1.0
    17 \.
     161       dbversion       1.2
     17\.
     18
     19CREATE TABLE locations (
     20    location character varying (4) PRIMARY KEY,
     21    loc_id serial UNIQUE,
     22    group_id integer NOT NULL DEFAULT 1,
     23    iplist text NOT NULL DEFAULT '',
     24    description character varying(40) NOT NULL DEFAULT '',
     25    comments text NOT NULL DEFAULT ''
     26);
    1827
    1928CREATE TABLE default_records (
    … …  
    54631       1       hostmaster.ADMINDOMAIN:ns1.ADMINDOMAIN  6       3600:900:1048576:2560   3600   
    55642       1       unused-%r.ADMINDOMAIN   65283   ZONE    3600   
     653       1       ns2.example.com 2       ZONE    7200    \N
     664       1       ns1.example.com 2       ZONE    7200    \N
    5667\.
    5768
    5869CREATE TABLE domains (
    5970    domain_id serial NOT NULL,
    60     "domain" character varying(80) NOT NULL,
     71    "domain" character varying(80) NOT NULL PRIMARY KEY,
    6172    group_id integer DEFAULT 1 NOT NULL,
    6273    description character varying(255) DEFAULT ''::character varying NOT NULL,
    6374    status integer DEFAULT 1 NOT NULL,
    6475    zserial integer,
    65     sertype character(1) DEFAULT 'D'::bpchar
     76    sertype character(1) DEFAULT 'D'::bpchar,
     77    changed boolean DEFAULT true NOT NULL,
     78    default_location character varying (4) DEFAULT '' NOT NULL
    6679);
    6780
    6881CREATE TABLE revzones (
    6982    rdns_id serial NOT NULL,
    70     revnet cidr NOT NULL,
     83    revnet cidr NOT NULL PRIMARY KEY,
    7184    group_id integer DEFAULT 1 NOT NULL,
    7285    description character varying(255) DEFAULT ''::character varying NOT NULL,
    7386    status integer DEFAULT 1 NOT NULL,
    7487    zserial integer,
    75     sertype character(1) DEFAULT 'D'::bpchar
     88    sertype character(1) DEFAULT 'D'::bpchar,
     89    changed boolean DEFAULT true NOT NULL,
     90    default_location character varying (4) DEFAULT '' NOT NULL
    7691);
    7792
    … …  
    119134    record_edit boolean DEFAULT false NOT NULL,
    120135    record_delete boolean DEFAULT false NOT NULL,
     136    record_locchg boolean DEFAULT false NOT NULL,
     137    location_create boolean DEFAULT false NOT NULL,
     138    location_edit boolean DEFAULT false NOT NULL,
     139    location_delete boolean DEFAULT false NOT NULL,
     140    location_view boolean DEFAULT false NOT NULL,
    121141    user_id integer UNIQUE,
    122142    group_id integer UNIQUE
    … …  
    124144
    125145-- Need *two* basic permissions;  one for the initial group, one for the default admin user
    126 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) FROM stdin;
    127 1       f       f       f       f       f       f       f       f       t       t       t       t       t       t       \N      1
    128 2       t       f       f       f       f       f       f       f       f       f       f       f       f       f       1       \N
     146COPY 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, record_locchg, location_create, location_edit, location_delete, location_view, user_id, group_id) FROM stdin;
     1471       f       f       f       f       f       f       f       f       t       t       t       t       t       t       f       f       f       f       f       \N      1
     1482       t       f       f       f       f       f       f       f       f       f       f       f       f       f       f       f       f       f       f       1       \N
    129149\.
    130150
    … …  
    141161    port integer DEFAULT 0 NOT NULL,
    142162    ttl integer DEFAULT 7200 NOT NULL,
    143     description text
     163    description text,
     164    location character varying (4) DEFAULT '' NOT NULL
    144165);
    145166
    … …  
    156177COPY rectypes (val, name, stdflag, listorder, alphaorder) FROM stdin;
    1571781       A       1       1       1
    158 2       NS      1       5       37
     1792       NS      2       9       37
    1591803       MD      5       255     29
    1601814       MF      5       255     30
    161 5       CNAME   1       7       9
     1825       CNAME   2       11      9
    1621836       SOA     0       0       53
    1631847       MB      5       255     28
    … …  
    16618710      NULL    5       255     43
    16718811      WKS     5       255     64
    168 12      PTR     3       10      46
     18912      PTR     3       5       46
    16919013      HINFO   5       255     18
    17019114      MINFO   5       255     32
    171 15      MX      1       6       34
    172 16      TXT     1       8       60
     19215      MX      1       10      34
     19316      TXT     2       12      60
    17319417      RP      4       255     48
    17419518      AFSDB   5       255     4
    … …  
    18720831      EID     5       255     15
    18820932      NIMLOC  5       255     36
    189 33      SRV     1       9       55
     21033      SRV     1       13      55
    19021134      ATMA    5       255     6
    19121235      NAPTR   5       255     35
    … …  
    22624765280   A+PTR   2       2       2
    22724865281   AAAA+PTR        2       4       4
    228 65282   PTR template    3       11      2
    229 65283   A+PTR template  3       12      2
    230 65284   AAAA+PTR template       3       13      2
     24965282   PTR template    3       6       2
     25065283   A+PTR template  2       7       2
     25165284   AAAA+PTR template       8       13      2
     25265285   Delegation      2       8       2
    231253\.
    232254
    … …  
    262284
    263285ALTER TABLE ONLY domains
    264     ADD CONSTRAINT domains_pkey PRIMARY KEY ("domain");
    265 
    266 ALTER TABLE ONLY domains
    267286    ADD CONSTRAINT domains_domain_id_key UNIQUE (domain_id);
    268287
    … …  
    284303-- foreign keys
    285304-- fixme: permissions FK refs
     305ALTER TABLE ONLY locations
     306    ADD CONSTRAINT "locations_group_id_fkey" FOREIGN KEY (group_id) REFERENCES groups(group_id);
     307
    286308ALTER TABLE ONLY domains
     309    ADD CONSTRAINT "$1" FOREIGN KEY (group_id) REFERENCES groups(group_id);
     310
     311ALTER TABLE ONLY revzones
    287312    ADD CONSTRAINT "$1" FOREIGN KEY (group_id) REFERENCES groups(group_id);
    288313
    … …  
    299324SELECT pg_catalog.setval('misc_misc_id_seq', 2, false);
    300325SELECT pg_catalog.setval('default_records_record_id_seq', 8, false);
    301 SELECT pg_catalog.setval('default_rev_records_record_id_seq', 3, false);
     326SELECT pg_catalog.setval('default_rev_records_record_id_seq', 5, false);
    302327SELECT pg_catalog.setval('domains_domain_id_seq', 1, false);
    303328SELECT pg_catalog.setval('groups_group_id_seq', 2, false);

  • branches/stable/notes

    r81 r545  
    309309#define LOG_INFO        6       /* informational */
    310310#define LOG_DEBUG       7       /* debug-level messages */
     311
     312
     313
     314another web-UI for DNS record maintenance:
     315http://www.henriknordstrom.net/code/webdns/
     316
     317
     318sub-octet delegation for v4 nets:
     319p 216-218 in cricket^Wgrasshopper book
     320
     321Also see new draft spec, applies to both v4 and v6:
     322http://tools.ietf.org/html/draft-gersch-dnsop-revdns-cidr-01
     323
     324new custom types "Forward delegation" and "Reverse delegation"?
     325 - forward creates NS records in parent for <sub>.parent
     326 - reverse creates NS records plus CNAMEs for sub-octet zones
     327-> would solve the conundrum of what to do with the unsightly CNAME
     328   records presented in the UI to indicate sub-octet zone delegation

  • branches/stable/templates/axfr.tmpl

    r437 r545  
    3939</tr>
    4040<tr class="datalinelight">
     41        <td>Merge records on A+PTR or AAAA+PTR match?</td>
     42        <td><input type="checkbox" name="mergematching"<TMPL_IF mergematching> checked="checked"</TMPL_IF> /></td>
     43</tr>
     44<tr class="datalinelight">
    4145        <td>Import as active?</td>
    4246        <td><input type="checkbox" name="domactive"<TMPL_UNLESS dominactive> checked="checked"</TMPL_UNLESS> /></td>
    … …  
    4448<tr class="datalinelight">
    4549        <td valign="top">Domains to import:<br />(one per line)</td>
    46         <td><textarea name="importdoms" rows="10" cols="25"><TMPL_IF importdoms><TMPL_VAR NAME=importdoms></TMPL_IF></textarea></td>
     50        <td><textarea name="importdoms" rows="10" cols="45"><TMPL_IF importdoms><TMPL_VAR NAME=importdoms></TMPL_IF></textarea></td>
    4751</tr>
    4852<tr class="datalinelight">

  • branches/stable/templates/bulkchange.tmpl

    r113 r545  
    1010<tr class="datalinelight">
    1111        <td><TMPL_VAR NAME=domain></td>
    12 <TMPL_IF domok> <td>OK</td>
    13 <TMPL_ELSE><TMPL_IF domwarn>    <td class="warn">Import OK but:<br />
    14 <TMPL_VAR NAME=domwarn></td>
    15 <TMPL_ELSE>     <td class="err">Failed: <TMPL_VAR NAME=domerr></td>
     12<TMPL_IF domok> <td><TMPL_VAR NAME=domok></td>
     13<TMPL_ELSE><TMPL_IF domwarn>    <td class="warn"><TMPL_VAR NAME=domwarn></td>
     14<TMPL_ELSE>     <td class="err"><TMPL_VAR NAME=domerr></td>
    1615</TMPL_IF></TMPL_IF>
    1716</tr>
    1817</TMPL_LOOP>
    1918</table>
    20 <TMPL_VAR NAME=foobar>
    2119</td>
    2220</tr>

  • branches/stable/templates/bulkdomain.tmpl

    r207 r545  
    4040<table>
    4141<tr>
    42 <TMPL_LOOP NAME=domtable><td><input type="checkbox" name="dom_<TMPL_VAR NAME=domid>" value="<TMPL_VAR NAME=domid>" /> <TMPL_VAR NAME=domain></td>
     42<TMPL_LOOP NAME=domtable><td><input type="checkbox" name="dom_<TMPL_VAR NAME=domainid>" value="<TMPL_VAR NAME=domainid>" /> <TMPL_VAR NAME=domain></td>
    4343<TMPL_IF newrow></tr>
    4444<tr>

  • branches/stable/templates/domlist.tmpl

    r544 r545  
    55<td align="center" valign="top">
    66
    7 <TMPL_IF resultmsg>
    8 <div class="result"><TMPL_VAR NAME=resultmsg></div>
    9 </TMPL_IF>
    10 <TMPL_IF errmsg>
    11 <div class="errmsg"><TMPL_VAR NAME=errmsg></div>
    12 </TMPL_IF>
     7<TMPL_INCLUDE NAME="msgblock.tmpl">
    138
    149<table width="98%">
    … …  
    3328<table width="98%" border="0" cellspacing="4" cellpadding="3">
    3429<tr>
    35 <TMPL_LOOP NAME=colheads>
    36 <td class="datahead_<TMPL_IF firstcol>l<TMPL_ELSE>s</TMPL_IF>"><a href="dns.cgi?sid=<TMPL_VAR
    37 NAME=sid>&amp;page=<TMPL_VAR NAME=page><TMPL_IF NAME=offset>&amp;offset=<TMPL_VAR
    38 NAME=offset></TMPL_IF>&amp;sortby=<TMPL_VAR NAME=sortby>&amp;order=<TMPL_VAR NAME=order>"><TMPL_VAR
    39 NAME=colname></a><TMPL_IF NAME=sortorder>&nbsp;<img alt="<TMPL_VAR NAME=sortorder>"
    40 src="images/<TMPL_VAR NAME=sortorder>.png" /></TMPL_IF></td>
     30<TMPL_LOOP NAME=colheads>       <td class="datahead_<TMPL_IF __first__>l<TMPL_ELSE>s</TMPL_IF>"><a href="dns.cgi?sid=<TMPL_VAR
     31 NAME=sid>&amp;page=<TMPL_VAR NAME=page><TMPL_IF NAME=offset>&amp;offset=<TMPL_VAR
     32 NAME=offset></TMPL_IF>&amp;sortby=<TMPL_VAR NAME=sortby>&amp;order=<TMPL_VAR NAME=order>"><TMPL_VAR
     33 NAME=colname></a><TMPL_IF NAME=sortorder>&nbsp;<img alt="<TMPL_VAR NAME=sortorder>" src="images/<TMPL_VAR
     34 NAME=sortorder>.png" /></TMPL_IF></td>
    4135</TMPL_LOOP>
    4236<TMPL_IF domain_edit>   <td class="datahead_s">Change Status</td></TMPL_IF>
    … …  
    4539<TMPL_IF name=domtable>
    4640<TMPL_LOOP name=domtable>
    47 <tr class="row<TMPL_IF __odd__>1<TMPL_ELSE>0</TMPL_IF>">
    48         <td align="left"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=reclist&amp;id=<TMPL_VAR NAME=domainid>&amp;defrec=n<TMPL_UNLESS domlist>&amp;revrec=y</TMPL_UNLESS>"><TMPL_VAR NAME=domain></a></td>
     41<tr class="row<TMPL_IF __odd__>0<TMPL_ELSE>1</TMPL_IF>">
     42        <td align="left"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=reclist&amp;id=<TMPL_VAR NAME=domain_id>&amp;defrec=n<TMPL_UNLESS domlist>&amp;revrec=y</TMPL_UNLESS>"><TMPL_VAR NAME=domain></a></td>
    4943        <td><TMPL_IF status>Active<TMPL_ELSE>Inactive</TMPL_IF></td>
    5044        <td><TMPL_VAR name=group></td>
    51 <TMPL_IF domain_edit>   <td align="center"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=<TMPL_VAR NAME=curpage><TMPL_IF NAME=offset>&amp;offset=<TMPL_VAR NAME=offset></TMPL_IF>&amp;id=<TMPL_VAR NAME=domainid>&amp;domstatus=<TMPL_IF status>domoff<TMPL_ELSE>domon</TMPL_IF>"><TMPL_IF status>deactivate<TMPL_ELSE>activate</TMPL_IF></a></td></TMPL_IF>
    52 <TMPL_IF domain_delete> <td align="center"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=<TMPL_IF domlist>deldom<TMPL_ELSE>delrevzone</TMPL_IF>&amp;id=<TMPL_VAR NAME=domainid>"><img src="images/trash2.png" alt="[ Delete ]" /></a></td></TMPL_IF>
     45<TMPL_IF domain_edit>   <td align="center"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=<TMPL_VAR NAME=curpage><TMPL_IF NAME=offset>&amp;offset=<TMPL_VAR NAME=offset></TMPL_IF>&amp;id=<TMPL_VAR NAME=domainid>&amp;zonestatus=<TMPL_IF status>domoff<TMPL_ELSE>domon</TMPL_IF>"><TMPL_IF status>deactivate<TMPL_ELSE>activate</TMPL_IF></a></td></TMPL_IF>
     46<TMPL_IF domain_delete> <td align="center"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=<TMPL_IF domlist>deldom<TMPL_ELSE>delrevzone</TMPL_IF>&amp;id=<TMPL_VAR NAME=domain_id>"><img src="images/trash2.png" alt="[ Delete ]" /></a></td></TMPL_IF>
    5347</tr>
    5448</TMPL_LOOP>

  • branches/stable/templates/editsoa.tmpl

    r100 r545  
    1616<input type="hidden" name="page" value="updatesoa" />
    1717<input type="hidden" name="id" value="<TMPL_VAR NAME=id>" />
    18 <input type="hidden" name="recid" value="<TMPL_VAR NAME=recid>" />
    1918<input type="hidden" name="defrec" value="<TMPL_VAR NAME=defrec>" />
     19<input type="hidden" name="revrec" value="<TMPL_VAR NAME=revrec>" />
    2020
    2121<table border="0" cellspacing="2" cellpadding="1" width="100%">
    2222<tr class="darkrowheader">
    2323        <td colspan="2" class="title"><TMPL_IF NAME=isgrp>Edit default SOA record for group <TMPL_ELSE>Edit SOA record for </TMPL_IF><TMPL_VAR NAME=parent></td>
    24         <td class="title">Defaults:</td>
     24        <td class="title">System defaults:</td>
    2525</tr>
    2626<tr class="datalinelight">

  • branches/stable/templates/grpman.tmpl

    r178 r545  
    55<td align="center" valign="top">
    66
    7 <TMPL_IF resultmsg>
    8 <div class="result"><TMPL_VAR NAME=resultmsg></div>
    9 </TMPL_IF>
    10 <TMPL_IF warnmsg>
    11 <div class="warning">Warning: <TMPL_VAR NAME=warnmsg></div>
    12 </TMPL_IF>
    13 <TMPL_IF errmsg>
    14 <div class="errmsg"><TMPL_VAR NAME=errmsg></div>
    15 </TMPL_IF>
     7<TMPL_INCLUDE NAME="msgblock.tmpl">
    168
    179<table width="98%">
    … …  
    3224<table width="98%" border="0" cellspacing="4" cellpadding="3">
    3325<tr>
    34 <TMPL_LOOP NAME=colheads>
    35         <td class="datahead_<TMPL_IF firstcol>l<TMPL_ELSE>s</TMPL_IF>"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=<TMPL_VAR NAME=page><TMPL_IF NAME=offset>&amp;offset=<TMPL_VAR NAME=offset></TMPL_IF>&amp;sortby=<TMPL_VAR NAME=sortby>&amp;order=<TMPL_VAR NAME=order>"><TMPL_VAR NAME=colname></a><TMPL_IF NAME=sortorder>&nbsp;<img alt="<TMPL_VAR NAME=sortorder>" src="images/<TMPL_VAR NAME=sortorder>.png" /></TMPL_IF></td></TMPL_LOOP>
     26<TMPL_LOOP NAME=colheads>       <td class="datahead_<TMPL_IF __first__>l<TMPL_ELSE>s</TMPL_IF>"><a href="dns.cgi?sid=<TMPL_VAR
     27 NAME=sid>&amp;page=<TMPL_VAR NAME=page><TMPL_IF NAME=offset>&amp;offset=<TMPL_VAR
     28 NAME=offset></TMPL_IF>&amp;sortby=<TMPL_VAR NAME=sortby>&amp;order=<TMPL_VAR NAME=order>"><TMPL_VAR
     29 NAME=colname></a><TMPL_IF NAME=sortorder>&nbsp;<img alt="<TMPL_VAR NAME=sortorder>" src="images/<TMPL_VAR
     30 NAME=sortorder>.png" /></TMPL_IF></td>
     31</TMPL_LOOP>
    3632<TMPL_IF delgrp>
    3733        <td class="datahead_s">Delete</td>
    … …  
    4036<TMPL_IF name=grouptable>
    4137<TMPL_LOOP name=grouptable>
    42 <tr class="row<TMPL_VAR name=bg>">
     38<tr class="row<TMPL_IF __odd__>0<TMPL_ELSE>1</TMPL_IF>">
    4339        <td align="left"><TMPL_IF edgrp><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=edgroup&amp;gid=<TMPL_VAR NAME=groupid>"><TMPL_VAR NAME=groupname></a><TMPL_ELSE><TMPL_VAR NAME=groupname></TMPL_IF></td>
    4440        <td><TMPL_VAR name=pgroup></td>
    4541        <td><TMPL_VAR name=nusers></td>
    4642        <td><TMPL_VAR name=ndomains></td>
     43        <td><TMPL_VAR NAME=nrevzones></td>
    4744<TMPL_IF delgrp>
    4845        <td align="center"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=delgrp&amp;id=<TMPL_VAR NAME=groupid>"><img src="images/trash2.png" alt="[ Delete ]" /></a></td>

  • branches/stable/templates/location.tmpl

    r374 r545  
    1414<input type="hidden" name="page" value="location" />
    1515<input type="hidden" name="sid" value="<TMPL_VAR NAME=sid>" />
    16 <input type="hidden" name="parentid" value="<TMPL_VAR NAME=parentid>" />
    17 <input type="hidden" name="id" value="<TMPL_VAR NAME=id>" />
     16<TMPL_IF id><input type="hidden" name="id" value="<TMPL_VAR NAME=id>" /></TMPL_IF>
    1817<input type="hidden" name="locact" value="<TMPL_VAR NAME=locact>" />
    1918
    … …  
    2625        <tr class="datalinelight">
    2726                <td>Location name/description</td>
    28                 <td><input type="text" name="locname" value="<TMPL_VAR ESCAPE=HTML NAME=locname>" size="30" /></td>
     27                <td><input type="text" name="locname" value="<TMPL_VAR ESCAPE=HTML NAME=locname>" size="30" maxlength="40" /></td>
    2928        </tr>
    3029        <tr class="datalinelight">
    3130                <td>IP list</td>
    3231                <td><input type="text" name="iplist" value="<TMPL_VAR ESCAPE=HTML NAME=iplist>" size="30" /></td>
     32        </tr>
     33        <tr class="datalinelight">
     34                <td>Comments</td>
     35                <td><textarea name="comments" cols="50" rows="5"><TMPL_VAR ESCAPE=HTML NAME=comments></textarea></td>
    3336        </tr>
    3437        <tr class="datalinelight">

  • branches/stable/templates/loclist.tmpl

    r370 r545  
    55<td align="center" valign="top">
    66
    7 <TMPL_IF resultmsg>
    8 <div class="result"><TMPL_VAR NAME=resultmsg></div>
    9 </TMPL_IF>
    10 <TMPL_IF warnmsg>
    11 <div class="warning">Warning: <TMPL_VAR NAME=warnmsg></div>
    12 </TMPL_IF>
    13 <TMPL_IF errmsg>
    14 <div class="errmsg"><TMPL_VAR NAME=errmsg></div>
    15 </TMPL_IF>
     7<TMPL_INCLUDE NAME="msgblock.tmpl">
    168
    179<table width="98%" class="csubtable">
    … …  
    2214<td class="rightthird"><TMPL_INCLUDE NAME="sbox.tmpl"></td>
    2315</tr>
    24 <tr><td colspan="3" align="center"><TMPL_INCLUDE NAME="lettsearch.tmpl"></td></tr>
    2516<TMPL_IF addloc>
    26 <tr><td colspan="3" align="right"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=loc">New Location/View</a></td></tr>
     17<tr><td colspan="3" align="right"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=location">New Location/View</a></td></tr>
    2718</TMPL_IF>
    2819</table>
    … …  
    3021<table width="98%" border="0" cellspacing="4" cellpadding="3" class="csubtable">
    3122<tr>
    32 <TMPL_LOOP NAME=colheads>
    33         <td class="datahead_<TMPL_IF firstcol>l<TMPL_ELSE>s</TMPL_IF>"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=<TMPL_VAR NAME=page><TMPL_IF NAME=offset>&amp;offset=<TMPL_VAR NAME=offset></TMPL_IF>&amp;sortby=<TMPL_VAR NAME=sortby>&amp;order=<TMPL_VAR NAME=order>"><TMPL_VAR NAME=colname></a><TMPL_IF NAME=sortorder>&nbsp;<img alt="<TMPL_VAR NAME=sortorder>" src="images/<TMPL_VAR NAME=sortorder>.png" /></TMPL_IF></td></TMPL_LOOP>
     23<TMPL_LOOP NAME=colheads>       <td class="datahead_s"><a href="dns.cgi?sid=<TMPL_VAR
     24 NAME=sid>&amp;page=<TMPL_VAR NAME=page><TMPL_IF NAME=offset>&amp;offset=<TMPL_VAR
     25 NAME=offset></TMPL_IF>&amp;sortby=<TMPL_VAR NAME=sortby>&amp;order=<TMPL_VAR NAME=order>"><TMPL_VAR
     26 NAME=colname></a><TMPL_IF NAME=sortorder>&nbsp;<img alt="<TMPL_VAR NAME=sortorder>" src="images/<TMPL_VAR
     27 NAME=sortorder>.png" /></TMPL_IF></td>
     28</TMPL_LOOP>
    3429<TMPL_IF delloc>        <td class="datahead_s">Delete</td></TMPL_IF>
    3530</tr>
    … …  
    3732<TMPL_LOOP name=loctable>
    3833<tr class="row<TMPL_IF __odd__>0<TMPL_ELSE>1</TMPL_IF>">
    39         <td align="left"><TMPL_IF edloc><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=location&amp;loc_action=edit&amp;loc=<TMPL_VAR NAME=loc>"><TMPL_VAR NAME=description></a><TMPL_ELSE><TMPL_VAR NAME=description></TMPL_IF></td>
     34        <td align="left"><TMPL_IF edloc><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=location&amp;locact=edit&amp;loc=<TMPL_VAR NAME=location>"><TMPL_VAR NAME=description></a><TMPL_ELSE><TMPL_VAR NAME=description></TMPL_IF></td>
    4035        <td><TMPL_VAR name=iplist></td>
    4136        <td><TMPL_VAR name=group_name></td>

  • branches/stable/templates/log.tmpl

    r180 r545  
    1010
    1111<table border="0" width="90%">
    12 <tr><th colspan="5"><div class="center maintitle">Log entries for <TMPL_VAR NAME=logfor></div></th></tr>
    13   <tr class="darkrowheader">
    14       <td>Name</td>
     12<tr><th colspan="3"><div class="center maintitle">Log entries for <TMPL_VAR NAME=logfor></div></th></tr>
     13<tr>
     14<td class="leftthird"><TMPL_INCLUDE NAME="pgcount.tmpl"></td>
     15<td align="center"><TMPL_INCLUDE NAME="fpnla.tmpl"></td>
     16<td class="rightthird">&nbsp;</td>
     17</tr>
     18</table>
     19<table border="0" width="90%">
    1520      <!-- Not sure "Customer ID" (filled with uid) is of any use... -->
    1621      <!-- td>Customer ID</td -->
    17       <td>Username/Email</td>
    18       <td>Log Entry</td>
    19       <td>Date / Time</td>
    20   </tr>
     22<tr class="darkrowheader">
     23<TMPL_LOOP NAME=colheads>       <td><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=<TMPL_VAR NAME=page><TMPL_IF
     24 NAME=offset>&amp;offset=<TMPL_VAR NAME=offset></TMPL_IF>&amp;sortby=<TMPL_VAR
     25 NAME=sortby>&amp;order=<TMPL_VAR NAME=order>&amp;id=<TMPL_VAR NAME=id>&amp;ltype=<TMPL_VAR
     26 NAME=ltype>"><TMPL_VAR NAME=colname></a><TMPL_IF
     27 NAME=sortorder>&nbsp;<img alt="<TMPL_VAR NAME=sortorder>" src="images/<TMPL_VAR
     28 NAME=sortorder>.png" /></TMPL_IF></td>
     29</TMPL_LOOP>
     30</tr>
     31
    2132<TMPL_IF logentries>
    2233<TMPL_LOOP NAME=logentries>

  • branches/stable/templates/menu.tmpl

    r544 r545  
    99<TMPL_IF maydefrec><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=reclist&amp;id=<TMPL_VAR NAME=group>&amp;defrec=y">Default Records</a><br />
    1010<TMPL_IF mayrdns><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=reclist&amp;id=<TMPL_VAR NAME=group>&amp;defrec=y&amp;revrec=y">Default Reverse Records</a><br /></TMPL_IF></TMPL_IF>
     11<TMPL_IF mayloc><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=loclist&amp;id=<TMPL_VAR NAME=group>">Locations/Views</a><br /></TMPL_IF>
    1112<TMPL_IF mayimport><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=axfr">AXFR Import</a><br /></TMPL_IF>
    1213<TMPL_IF maybulk><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=bulkdomain">Bulk Domain Operations</a><br /></TMPL_IF>

  • branches/stable/templates/newdomain.tmpl

    r205 r545  
    3030        </tr>
    3131        <tr class="datalinelight">
    32                 <td>Make domain active on next DNS propagation</td><td><input type="checkbox" name="makeactive" checked="checked" /></td>
     32                <td>Make domain active on next DNS propagation</td><td><input type="checkbox" name="makeactive"<TMPL_UNLESS addinactive> checked="checked"</TMPL_UNLESS> /></td>
    3333        </tr>
     34<TMPL_IF location_view>
     35        <tr class="datalinelight">
     36                <td>Default location/view:</td>
     37                <td><select name="defloc">
     38                <option value="">(None/public)</option>
     39<TMPL_LOOP name=loclist>                <option value="<TMPL_VAR NAME=loc>"<TMPL_IF selected> selected="selected"</TMPL_IF>><TMPL_VAR NAME=locname></option>
     40</TMPL_LOOP>
     41                </select></td>
     42        </tr>
     43</TMPL_IF>
    3444        <tr><td colspan="2" class="tblsubmit"><input type="submit" value="Add domain" /></td></tr>
    3545    </table>

  • branches/stable/templates/newgrp.tmpl

    r207 r545  
    1515<tr><td>
    1616    <table border="0" cellspacing="2" cellpadding="2" width="100%">
    17 <TMPL_IF add_failed>    <tr><td class="errhead" colspan="4">Error adding group <TMPL_VAR NAME=newgroup>: <TMPL_VAR NAME=errmsg></td></tr></TMPL_IF>
    18         <tr class="darkrowheader"><td colspan="4" align="center">Add Group</td></tr>
     17<TMPL_IF add_failed>    <tr><td class="errhead" colspan="2">Error adding group <TMPL_VAR NAME=newgroup>: <TMPL_VAR NAME=errmsg></td></tr></TMPL_IF>
     18        <tr class="darkrowheader"><td colspan="2" align="center">Add Group</td></tr>
    1919
    2020        <tr class="datalinelight">
    21                 <td colspan=2>Group Name:</td>
    22                 <td align="left" colspan=2><input type="text" name="newgroup" value="<TMPL_VAR NAME=newgroup>" /></td>
     21                <td>Group Name:</td>
     22                <td align="left"><input type="text" name="newgroup" value="<TMPL_VAR NAME=newgroup>" /></td>
    2323        </tr>
    2424        <tr class="datalinelight">
    25                 <td colspan=2>Add as subgroup of:</td>
    26                 <td colspan=2><select name="pargroup">
     25                <td>Add as subgroup of:</td>
     26                <td><select name="pargroup">
    2727<TMPL_LOOP name=pargroup>               <option value="<TMPL_VAR NAME=groupval>"<TMPL_IF groupactive> selected="selected"</TMPL_IF>><TMPL_VAR name=groupname></option>
    2828</TMPL_LOOP>
    … …  
    3030        </tr>
    3131        <tr class="darkrowheader border">
    32                 <td colspan="4" align="center">Default permissions for users created in this group:</td>
     32                <td colspan="2" align="center">Default permissions for users created in this group:</td>
    3333        </tr>
     34        <tr><td colspan="2"><table>
    3435<TMPL_INCLUDE name="permlist.tmpl">
     36        </table></td></tr>
    3537        <tr class="darkrowheader">
    36                 <td colspan="4" align="center"><input type="submit" value="Add group" /></td>
     38                <td colspan="2" align="center"><input type="submit" value="Add group" /></td>
    3739        </tr>
    3840    </table>

  • branches/stable/templates/newrevzone.tmpl

    r544 r545  
    1515<tr><td>
    1616    <table border="0" cellspacing="2" cellpadding="2" width="100%">
    17 <TMPL_IF add_failed>    <tr><td class="errhead" colspan="2">Error adding reverse zone <TMPL_VAR NAME=revzone>:
     17<TMPL_IF errmsg>        <tr><td class="errhead" colspan="2">Error adding reverse zone <TMPL_VAR NAME=revzone>:
    1818<TMPL_VAR NAME=errmsg></td></tr></TMPL_IF>
    1919        <tr class="darkrowheader"><td colspan="2" align="center">Add Reverse Zone</td></tr>

  • branches/stable/templates/permlist.tmpl

    r67 r545  
    2222        <td<TMPL_UNLESS may_record_create> class="<TMPL_UNLESS info>noaccess<TMPL_ELSE>info</TMPL_UNLESS>"</TMPL_UNLESS>><input type="checkbox"<TMPL_UNLESS info> name="record_create"</TMPL_UNLESS><TMPL_IF record_create> checked="checked"</TMPL_IF><TMPL_UNLESS may_record_create> disabled="disabled"</TMPL_UNLESS> /> Create</td>
    2323        <td<TMPL_UNLESS may_record_delete> class="<TMPL_UNLESS info>noaccess<TMPL_ELSE>info</TMPL_UNLESS>"</TMPL_UNLESS>><input type="checkbox"<TMPL_UNLESS info> name="record_delete"</TMPL_UNLESS><TMPL_IF record_delete> checked="checked"</TMPL_IF><TMPL_UNLESS may_record_delete> disabled="disabled"</TMPL_UNLESS> /> Delete</td>
     24        <td<TMPL_UNLESS may_record_locchg> class="<TMPL_UNLESS info>noaccess<TMPL_ELSE>info</TMPL_UNLESS>"</TMPL_UNLESS>><input type="checkbox"<TMPL_UNLESS info> name="record_locchg"</TMPL_UNLESS><TMPL_IF record_locchg> checked="checked"</TMPL_IF><TMPL_UNLESS may_record_locchg> disabled="disabled"</TMPL_UNLESS> /> Change location</td>
    2425        <!-- td class="noaccess"> - Delegate</td -->
     26</tr>
     27<tr>
     28        <td align="right">Location/View:</td>
     29        <td<TMPL_UNLESS may_location_edit> class="<TMPL_UNLESS info>noaccess<TMPL_ELSE>info</TMPL_UNLESS>"</TMPL_UNLESS>><input type="checkbox"<TMPL_UNLESS info> name="location_edit"</TMPL_UNLESS><TMPL_IF location_edit> checked="checked"</TMPL_IF><TMPL_UNLESS may_location_edit>disabled="disabled"</TMPL_UNLESS> /> Edit</td>
     30        <td<TMPL_UNLESS may_location_create> class="<TMPL_UNLESS info>noaccess<TMPL_ELSE>info</TMPL_UNLESS>"</TMPL_UNLESS>><input type="checkbox"<TMPL_UNLESS info> name="location_create"</TMPL_UNLESS><TMPL_IF location_create> checked="checked"</TMPL_IF><TMPL_UNLESS may_location_create> disabled="disabled"</TMPL_UNLESS> /> Create</td>
     31        <td<TMPL_UNLESS may_location_delete> class="<TMPL_UNLESS info>noaccess<TMPL_ELSE>info</TMPL_UNLESS>"</TMPL_UNLESS>><input type="checkbox"<TMPL_UNLESS info> name="location_delete"</TMPL_UNLESS><TMPL_IF location_delete> checked="checked"</TMPL_IF><TMPL_UNLESS may_location_delete> disabled="disabled"</TMPL_UNLESS> /> Delete</td>
     32        <td<TMPL_UNLESS may_location_view> class="<TMPL_UNLESS info>noaccess<TMPL_ELSE>info</TMPL_UNLESS>"</TMPL_UNLESS>><input type="checkbox"<TMPL_UNLESS info> name="location_view"</TMPL_UNLESS><TMPL_IF location_view> checked="checked"</TMPL_IF><TMPL_UNLESS may_location_view> disabled="disabled"</TMPL_UNLESS> /> View</td>
    2533</tr>
    2634<tr>

  • branches/stable/templates/reclist.tmpl

    r544 r545  
    55<td align="center" valign="top">
    66
    7 <TMPL_IF resultmsg>
    8 <div class="result"><TMPL_VAR NAME=resultmsg></div>
    9 </TMPL_IF>
    10 <TMPL_IF warnmsg>
    11 <div class="warning"><TMPL_VAR NAME=warnmsg></div>
    12 </TMPL_IF>
    13 <TMPL_IF errmsg>
    14 <div class="errmsg"><TMPL_VAR NAME=errmsg></div>
    15 </TMPL_IF>
     7<TMPL_INCLUDE NAME="msgblock.tmpl">
    168
    179<TMPL_UNLESS perm_err>
    … …  
    5951<TMPL_IF reclist>
    6052<tr class="darkrowheader">
    61 <TMPL_LOOP NAME=colheads><TMPL_IF firstcol></TMPL_IF>
    62         <td><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=<TMPL_VAR NAME=page><TMPL_IF
     53<TMPL_LOOP NAME=colheads>       <td><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=<TMPL_VAR NAME=page><TMPL_IF
    6354 NAME=offset>&amp;offset=<TMPL_VAR NAME=offset></TMPL_IF>&amp;sortby=<TMPL_VAR
    6455 NAME=sortby>&amp;order=<TMPL_VAR NAME=order>&amp;id=<TMPL_VAR NAME=id>&amp;defrec=<TMPL_VAR
    6556 NAME=defrec>&amp;revrec=<TMPL_VAR NAME=revrec>"><TMPL_VAR NAME=colname></a><TMPL_IF
    66  NAME=sortorder>&nbsp;<img alt="<TMPL_VAR NAME=sortorder>" src="images/<TMPL_VAR NAME=sortorder>.png"
    67  /></TMPL_IF></td></TMPL_LOOP>
     57 NAME=sortorder>&nbsp;<img alt="<TMPL_VAR NAME=sortorder>" src="images/<TMPL_VAR
     58 NAME=sortorder>.png" /></TMPL_IF></td>
     59</TMPL_LOOP>
    6860<TMPL_IF record_delete> <td>Delete</td></TMPL_IF>
    6961</tr>
    7062<TMPL_LOOP NAME=reclist>
    71 <tr class="row<TMPL_VAR NAME=row>">
     63<tr class="row<TMPL_IF __odd__>0<TMPL_ELSE>1</TMPL_IF>">
    7264<TMPL_IF fwdzone>
    73         <td><TMPL_IF record_edit><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=record&amp;parentid=<TMPL_VAR NAME=id>&amp;defrec=<TMPL_VAR NAME=defrec>&amp;revrec=<TMPL_VAR NAME=revrec>&amp;recact=edit&amp;id=<TMPL_VAR NAME=record_id>"><TMPL_VAR NAME=host></a><TMPL_ELSE><TMPL_VAR NAME=host></TMPL_IF></td>
     65        <td><TMPL_IF record_edit><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=record&amp;parentid=<TMPL_VAR NAME=id>&amp;defrec=<TMPL_VAR NAME=defrec>&amp;revrec=<TMPL_VAR NAME=revrec>&amp;recact=edit&amp;id=<TMPL_VAR NAME=record_id>"><TMPL_VAR NAME=host></a><TMPL_IF locname> (<TMPL_VAR NAME=locname>)</TMPL_IF><TMPL_ELSE><TMPL_VAR NAME=host><TMPL_IF locname> (<TMPL_VAR NAME=locname>)</TMPL_IF></TMPL_IF></td>
    7466        <td><TMPL_VAR NAME=type></td>
    7567        <td><TMPL_VAR NAME=val></td>
    … …  
    7870        <td><TMPL_VAR NAME=port></td>
    7971<TMPL_ELSE>
    80         <td><TMPL_IF record_edit><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=record&amp;parentid=<TMPL_VAR NAME=id>&amp;defrec=<TMPL_VAR NAME=defrec>&amp;revrec=<TMPL_VAR NAME=revrec>&amp;recact=edit&amp;id=<TMPL_VAR NAME=record_id>"><TMPL_VAR NAME=val></a><TMPL_ELSE><TMPL_VAR NAME=val></TMPL_IF></td>
     72        <td><TMPL_IF record_edit><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=record&amp;parentid=<TMPL_VAR NAME=id>&amp;defrec=<TMPL_VAR NAME=defrec>&amp;revrec=<TMPL_VAR NAME=revrec>&amp;recact=edit&amp;id=<TMPL_VAR NAME=record_id>"><TMPL_VAR NAME=val></a><TMPL_IF locname> (<TMPL_VAR NAME=locname>)</TMPL_IF><TMPL_ELSE><TMPL_VAR NAME=val><TMPL_IF locname> (<TMPL_VAR NAME=locname>)</TMPL_IF></TMPL_IF></td>
    8173        <td><TMPL_VAR NAME=type></td>
    8274        <td><TMPL_VAR NAME=host></td>

  • branches/stable/templates/record.tmpl

    r544 r545  
    2929<TMPL_IF fwdzone>
    3030                <td>Hostname</td>
    31                 <td><input type="text" name="name" value="<TMPL_VAR NAME=name>" /></td>
     31                <td><input type="text" name="name" value="<TMPL_VAR NAME=name>" size="30" /></td>
    3232<TMPL_ELSE>
    3333                <td>IP Address</td>
    34                 <td><input type="text" name="address" value="<TMPL_VAR ESCAPE=HTML NAME=address>" /></td>
     34                <td><input type="text" name="address" value="<TMPL_VAR ESCAPE=HTML NAME=address>" size="30" /></td>
    3535</TMPL_IF>
    3636        </tr>
    … …  
    4646<TMPL_IF fwdzone>
    4747                <td>Address</td>
    48                 <td><input type="text" name="address" value="<TMPL_VAR ESCAPE=HTML NAME=address>" /></td>
     48                <td><input type="text" name="address" value="<TMPL_VAR ESCAPE=HTML NAME=address>" size="30" /></td>
    4949<TMPL_ELSE>
    5050                <td>Hostname</td>
    51                 <td><input type="text" name="name" value="<TMPL_VAR NAME=name>" /></td>
     51                <td><input type="text" name="name" value="<TMPL_VAR NAME=name>" size="30" /></td>
    5252</TMPL_IF>
    5353        </tr>
    … …  
    7070                <td><input size="7" maxlength="20" type="text" name="ttl" value="<TMPL_VAR NAME=ttl>" /></td>
    7171        </tr>
     72<TMPL_IF location_view>
     73        <tr class="datalinelight">
     74                <td>Location/view</td>
     75<TMPL_IF record_locchg>
     76                <td><select name="location">
     77<TMPL_LOOP name=loclist>                <option value="<TMPL_VAR NAME=loc>"<TMPL_IF selected> selected="selected"</TMPL_IF>><TMPL_VAR NAME=locname></option>
     78</TMPL_LOOP>
     79                </select></td>
     80<TMPL_ELSE>
     81                <td><TMPL_VAR NAME=loc_name></td>
     82</TMPL_IF>
     83        </tr>
     84</TMPL_IF>
    7285        <tr class="datalinelight">
    7386                <td colspan="2" align="center"><input type="submit" value=" <TMPL_VAR NAME=todo> " /></td>

  • branches/stable/templates/soadata.tmpl

    r162 r545  
    33        <td align="left">SOA:</td>
    44<TMPL_IF mayeditsoa>
    5         <td align="right"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=editsoa&amp;id=<TMPL_VAR NAME=id>&amp;defrec=<TMPL_VAR NAME=defrec>">edit</a></td></TMPL_IF>
     5        <td align="right"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=editsoa&amp;id=<TMPL_VAR NAME=id>&amp;defrec=<TMPL_VAR NAME=defrec>&amp;revrec=<TMPL_VAR NAME=revrec>">edit</a></td></TMPL_IF>
    66</tr>
    77</table>

  • branches/stable/templates/user.tmpl

    r207 r545  
    1616<table border="0" cellspacing="2" cellpadding="2" width="450">
    1717<TMPL_IF add_failed>    <tr>
    18                 <td class="errhead" colspan="2">Error <TMPL_IF add>adding<TMPL_ELSE>updating</TMPL_IF> user <TMPL_VAR NAME=uname>: <TMPL_VAR NAME=errmsg></td>
     18                <td class="errhead" colspan="2"><TMPL_VAR NAME=errmsg></td>
    1919        </tr></TMPL_IF>
    2020        <tr class="darkrowheader"><td colspan="2" align="center"><TMPL_IF add>Add<TMPL_ELSE>Edit</TMPL_IF> User</td></tr>

  • branches/stable/templates/useradmin.tmpl

    r207 r545  
    55<td align="center" valign="top">
    66
    7 <TMPL_IF resultmsg>
    8 <div class="result"><TMPL_VAR NAME=resultmsg></div>
    9 </TMPL_IF>
    10 <TMPL_IF warnmsg>
    11 <div class="warning">Warning: <TMPL_VAR NAME=warnmsg></div>
    12 </TMPL_IF>
    13 <TMPL_IF errmsg>
    14 <div class="errmsg"><TMPL_VAR NAME=errmsg></div>
    15 </TMPL_IF>
     7<TMPL_INCLUDE NAME="msgblock.tmpl">
    168
    179<table width="98%" class="csubtable">
    … …  
    3022<table width="98%" border="0" cellspacing="4" cellpadding="3" class="csubtable">
    3123<tr>
    32 <TMPL_LOOP NAME=colheads>
    33         <td class="datahead_<TMPL_IF firstcol>l<TMPL_ELSE>s</TMPL_IF>"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=<TMPL_VAR NAME=page><TMPL_IF NAME=offset>&amp;offset=<TMPL_VAR NAME=offset></TMPL_IF>&amp;sortby=<TMPL_VAR NAME=sortby>&amp;order=<TMPL_VAR NAME=order>"><TMPL_VAR NAME=colname></a><TMPL_IF NAME=sortorder>&nbsp;<img alt="<TMPL_VAR NAME=sortorder>" src="images/<TMPL_VAR NAME=sortorder>.png" /></TMPL_IF></td></TMPL_LOOP>
     24<TMPL_LOOP NAME=colheads>       <td class="datahead_<TMPL_IF __first__>l<TMPL_ELSE>s</TMPL_IF>"><a href="dns.cgi?sid=<TMPL_VAR
     25 NAME=sid>&amp;page=<TMPL_VAR NAME=page><TMPL_IF NAME=offset>&amp;offset=<TMPL_VAR
     26 NAME=offset></TMPL_IF>&amp;sortby=<TMPL_VAR NAME=sortby>&amp;order=<TMPL_VAR NAME=order>"><TMPL_VAR
     27 NAME=colname></a><TMPL_IF NAME=sortorder>&nbsp;<img alt="<TMPL_VAR NAME=sortorder>" src="images/<TMPL_VAR
     28 NAME=sortorder>.png" /></TMPL_IF></td>
     29</TMPL_LOOP>
    3430<TMPL_IF deluser>       <td class="datahead_s">Delete</td></TMPL_IF>
    3531</tr>
    3632<TMPL_IF name=usertable>
    3733<TMPL_LOOP name=usertable>
    38 <tr class="row<TMPL_VAR name=bg>">
    39         <td align="left"><TMPL_IF eduser><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=user&amp;useraction=edit&amp;user=<TMPL_VAR NAME=userid>"><TMPL_VAR NAME=username></a><TMPL_ELSE><TMPL_VAR NAME=username></TMPL_IF></td>
    40         <td class="data_nowrap"><TMPL_VAR name=userfull></td>
    41         <td><TMPL_VAR name=usertype></td>
    42         <td><TMPL_VAR name=usergroup></td>
     34<tr class="row<TMPL_IF __odd__>0<TMPL_ELSE>1</TMPL_IF>">
     35        <td align="left"><TMPL_IF eduser><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=user&amp;useraction=edit&amp;user=<TMPL_VAR NAME=user_id>"><TMPL_VAR NAME=username></a><TMPL_ELSE><TMPL_VAR NAME=username></TMPL_IF></td>
     36        <td class="data_nowrap"><TMPL_VAR name=fname></td>
     37        <td><TMPL_VAR name=type></td>
     38        <td><TMPL_VAR name=group_name></td>
    4339        <td align="center">
    4440<TMPL_IF eduser>
    45                 <a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=useradmin<TMPL_IF NAME=offset>&amp;offset=<TMPL_VAR NAME=offset></TMPL_IF>&amp;id=<TMPL_VAR NAME=userid>&amp;userstatus=<TMPL_IF active>useroff<TMPL_ELSE>useron</TMPL_IF>"><TMPL_IF active>enabled<TMPL_ELSE>disabled</TMPL_IF></a>
     41                <a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=useradmin<TMPL_IF NAME=offset>&amp;offset=<TMPL_VAR NAME=offset></TMPL_IF>&amp;id=<TMPL_VAR NAME=user_id>&amp;userstatus=<TMPL_IF status>useroff<TMPL_ELSE>useron</TMPL_IF>"><TMPL_IF status>enabled<TMPL_ELSE>disabled</TMPL_IF></a>
    4642<TMPL_ELSE>
    47                 <TMPL_IF active>enabled<TMPL_ELSE>disabled</TMPL_IF>
     43                <TMPL_IF status>enabled<TMPL_ELSE>disabled</TMPL_IF>
    4844</TMPL_IF>
    4945</td>
    5046<TMPL_IF deluser>
    51         <td align="center"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=deluser&amp;id=<TMPL_VAR NAME=userid>"><img src="images/trash2.png" alt="[ Delete ]" /></a></td>
     47        <td align="center"><a href="dns.cgi?sid=<TMPL_VAR NAME=sid>&amp;page=deluser&amp;id=<TMPL_VAR NAME=user_id>"><img src="images/trash2.png" alt="[ Delete ]" /></a></td>
    5248</TMPL_IF>
    5349</tr>

  • branches/stable/tiny-import.pl

    r348 r545  
    1919##
    2020
     21# WARNING:  This is NOT a heavy-duty validator;  it is assumed that the data
     22# being imported is more or less sane.  Only minor structural validation will
     23# be done to weed out the most broken records.
     24
    2125use strict;
    2226use warnings;
    … …  
    2933}
    3034
     35usage() if !@ARGV;
     36
     37my %importcfg = (
     38        rw      => 0,
     39        conv    => 0,
     40        trial   => 0,
     41        );
     42# Handle some command-line arguments
     43while ($ARGV[0] =~ /^-/) {
     44  my $arg = shift @ARGV;
     45  usage() if $arg !~ /^-[rct]+$/;
     46  # -r  rewrite imported files to comment imported records
     47  # -c  coerce/downconvert A+PTR = records to PTR
     48  # -t  trial mode;  don't commit to DB or actually rewrite flatfile (disables -r)
     49  $arg =~ s/^-//;
     50  my @tmp = split //, $arg;
     51  foreach (@tmp) {
     52    $importcfg{rw} = 1 if $_ eq 'r';
     53    $importcfg{conv} = 1 if $_ eq 'c';
     54    $importcfg{trial} = 1 if $_ eq 't';
     55  }
     56}
     57$importcfg{rw} = 0 if $importcfg{trial};
     58
     59sub usage {
     60  die q(usage:  tiny-import.pl [-r] [-c] datafile1 datafile2 ... datafileN ...
     61        -r  Rewrite all specified data files with a warning header indicating the
     62            records are now managed by web, and commenting out all imported records.
     63            The directory containing any given datafile must be writable.
     64        -c  Convert any A+PTR (=) record to a bare PTR if the forward domain is
     65            not present in the database.  Note this does NOT look forward through
     66            a single file, nor across multiple files handled in the same run.
     67            Multiple passes may be necessary if SOA and = records are heavily
     68            intermixed and not clustered together.
     69        -t  Trial run mode;  spits out records that would be left unimported.
     70            Disables -r if set.
     71
     72        -r and -c may be combined (-rc)
     73
     74        datafileN is any tinydns record data file.
     75);
     76}
     77
    3178my $code;
    3279my ($dbh,$msg) = connectDB($config{dbname}, $config{dbuser}, $config{dbpass}, $config{dbhost});
    … …  
    3885my %cnt;
    3986my @deferred;
     87my $errstr = '';
    4088
    4189foreach my $file (@ARGV) {
    … …  
    4391    import(file => $file);
    4492#    import(file => $file, nosoa => 1);
    45     $dbh->rollback;
    46 #    $dbh->commit;
     93    $dbh->rollback if $importcfg{trial};
     94    $dbh->commit unless $importcfg{trial};
    4795  };
    4896  if ($@) {
    49     print "bleh: $@\n";
    50 die "die harder\n";
     97    print "Failure trying to import $file: $@\n $errstr\n";
     98    unlink ".$file.$$" if $importcfg{rw};       # cleanup
     99    $dbh->rollback;
    51100  }
    52101}
    53102
    54   foreach (keys %cnt) {
    55     print " $_  $cnt{$_}\n";
    56   }
     103# print summary count of record types encountered
     104foreach (keys %cnt) {
     105  print " $_    $cnt{$_}\n";
     106}
    57107
    58108exit 0;
    … …  
    61111  our %args = @_;
    62112  my $flatfile = $args{file};
     113  my @fpath = split '/', $flatfile;
     114  $fpath[$#fpath] = ".$fpath[$#fpath]";
     115  my $rwfile = join('/', @fpath);#.".$$";
     116
    63117  open FLAT, "<$flatfile";
    64118
    65   our $recsth = $dbh->prepare("INSERT INTO records (domain_id,rdns_id,host,type,val,distance,weight,port,ttl) ".
    66         " VALUES (?,?,?,?,?,?,?,?,?)");
    67 
     119  if ($importcfg{rw}) {
     120    open RWFLAT, ">$rwfile" or die "Couldn't open tempfile $rwfile for rewriting: $!\n";
     121    print RWFLAT "# WARNING:  Records in this file have been imported to the web UI.\n#\n";
     122  }
     123
     124  our $recsth = $dbh->prepare("INSERT INTO records (domain_id,rdns_id,host,type,val,distance,weight,port,ttl,location) ".
     125        " VALUES (?,?,?,?,?,?,?,?,?,?)");
     126
     127  my %deleg;
     128
     129  my $ok = 0;
    68130  while (<FLAT>) {
    69     next if /^#/;
    70     next if /^\s*$/;
     131    if (/^#/ || /^\s*$/) {
     132      print RWFLAT "#$_" if $importcfg{rw};
     133      next;
     134    }
    71135    chomp;
    72     recslurp($_);
    73   }
    74 
    75   # Try the deferred records again, once.
     136    s/\s*$//;
     137    my $recstat = recslurp($_);
     138    $ok++ if $recstat;
     139    if ($importcfg{rw}) {
     140      if ($recstat) {
     141        print RWFLAT "#$_\n";
     142      } else {
     143        print RWFLAT "$_\n";
     144      }
     145    }
     146  }
     147
     148  # Move the rewritten flatfile in place of the original, so that any
     149  # external export processing will pick up any remaining records.
     150  if ($importcfg{rw}) {
     151    close RWFLAT;
     152    rename "$rwfile", $flatfile;
     153  }
     154
     155  # Show the failed records
    76156  foreach (@deferred) {
    77   #  print "trying $_ again\n";
    78     recslurp($_, 1);
    79   }
     157    print "failed to import $_\n";
     158  }
     159
     160##fixme:  hmm.  can't write the record back to the flatfile in the
     161# main while above, then come down here and import it anyway, can we?
     162#   # Try the deferred records again, once.
     163#  foreach (@deferred) {
     164#    print "trying $_ again\n";
     165#    recslurp($_, 1);
     166#  }
     167
     168  # .. but we can at least say how many records weren't imported.
     169  print "$ok OK, ".scalar(@deferred)." deferred records in $flatfile\n";
     170  $#deferred = -1;
     171
    80172
    81173  # Sub for various nonstandard types with lots of pure bytes expressed in octal
    82   # Takes a tinydns rdata string and count, returns a lis of $count bytes as well
     174  # Takes a tinydns rdata string and count, returns a list of $count bytes as well
    83175  # as trimming those logical bytes off the front of the rdata string.
    84176  sub _byteparse {
    … …  
    103195  }
    104196
     197  # Convert octal-coded bytes back to something resembling normal characters, general case
     198  sub _deoctal {
     199    my $targ = shift;
     200    while ($$targ =~ /\\(\d{3})/) {
     201      my $sub = chr(oct($1));
     202      $$targ =~ s/\\$1/$sub/g;
     203    }
     204  }
     205
     206  sub _rdata2string {
     207    my $rdata = shift;
     208    my $tmpout = '';
     209    while ($rdata) {
     210      my $bytecount = 0;
     211      if ($rdata =~ /^\\/) {
     212        ($bytecount) = ($rdata =~ /^(\\\d{3})/);
     213        $bytecount =~ s/\\/0/;
     214        $bytecount = oct($bytecount);
     215        $rdata =~ s/^\\\d{3}//;
     216      } else {
     217        ($bytecount) = ($rdata =~ /^(.)/);
     218        $bytecount = ord($bytecount);
     219        $rdata =~ s/^.//;
     220      }
     221      my @tmp = _byteparse(\$rdata, $bytecount);
     222      foreach (@tmp) { $tmpout .= chr($_); }
     223##fixme:  warn or fail on long (>256?  >512?  >321?) strings
     224    }
     225    return $tmpout;
     226  }
     227
     228  sub _rdata2hex {
     229    my $rdata = shift;
     230    my $tmpout = '';
     231    while ($rdata) {
     232      my $byte = '';
     233      if ($rdata =~ /^\\/) {
     234        ($byte) = ($rdata =~ /^(\\\d{3})/);
     235        $byte =~ s/\\/0/;
     236        $tmpout .= sprintf("%0.2x", oct($byte));
     237        $rdata =~ s/^\\\d{3}//;
     238      } else {
     239        ($byte) = ($rdata =~ /^(.)/);
     240        $tmpout .= sprintf("%0.2x", ord($byte));
     241        $rdata =~ s/^.//;
     242      }
     243    }
     244    return $tmpout;
     245  }
     246
     247
    105248  sub recslurp {
    106249    my $rec = shift;
    107250    my $nodefer = shift || 0;
     251    my $impok = 1;
     252
     253    $errstr = $rec;  # this way at least we have some idea what went <splat>
    108254
    109255    if ($rec =~ /^=/) {
    110256      $cnt{APTR}++;
    111 if ($rec !~ /^=(?:\*|\\052)?[a-z0-9\._-]+:[\d\.]+:\d*/i) {
    112   print "bad A+PTR $rec\n";
    113   return;
    114 #=sud-rr-iGi0-1_sud-gw1-iGi4-2.vianet.ca::10.10.10.13:900::in
    115 }
    116       my ($host,$ip,$ttl,$time,$loc) = split /:/, $rec;
     257
     258##fixme:  do checks like this for all types
     259      if ($rec !~ /^=(?:\*|\\052)?[a-z0-9\._-]+:[\d\.]+:\d*/i) {
     260        print "bad A+PTR $rec\n";
     261        return;
     262      }
     263      my ($host,$ip,$ttl,$stamp,$loc) = split /:/, $rec, 5;
    117264      $host =~ s/^=//;
    118265      $host =~ s/\.$//;
    119       $time = '' if !$time;
    120       $loc = '' if !$loc;
    121       print "bleh, bad A+PTR!  $rec\n" if $loc =~ /:/;
     266      $ttl = 0 if !$ttl;
     267      $stamp = '' if !$stamp;
     268      $loc = '' if !$loc;
     269      $loc = '' if $loc =~ /^:+$/;
    122270      my $fparent = DNSDB::_hostparent($dbh, $host);
    123271      my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($ip));
    124272      if ($fparent && $rparent) {
    125         $dbh->do("INSERT INTO records (domain_id,rdns_id,host,type,val,ttl) VALUES (?,?,?,?,?,?)", undef,
    126                 ($fparent, $rparent, $host, 65280, $ip, $ttl));
     273        $recsth->execute($fparent, $rparent, $host, 65280, $ip, 0, 0, 0, $ttl, $loc);
    127274      } else {
    128275        push @deferred, $rec unless $nodefer;
     276        $impok = 0;
    129277        #  print "$tmporig deferred;  can't find both forward and reverse zone parents\n";
    130278      }
    … …  
    132280    } elsif ($rec =~ /^C/) {
    133281      $cnt{CNAME}++;
    134       my ($host,$targ,$ttl,$time,$loc) = split /:/, $rec;
     282
     283      my ($host,$targ,$ttl,$stamp,$loc) = split /:/, $rec, 5;
    135284      $host =~ s/^C//;
    136285      $host =~ s/\.$//;
    137       $time = '' if !$time;
    138       $loc = '' if !$loc;
    139       my $fparent = DNSDB::_hostparent($dbh, $host);
    140       if ($fparent) {
    141 
    142       } else {
    143         push @deferred, $rec unless $nodefer;
    144         #  print "$tmporig deferred;  can't find parent zone\n";
     286      $host =~ s/^\\052/*/;
     287      $ttl = 0 if !$ttl;
     288      $stamp = '' if !$stamp;
     289      $loc = '' if !$loc;
     290      $loc = '' if $loc =~ /^:+$/;
     291      if ($host =~ /\.arpa$/) {
     292        ($code,$msg) = DNSDB::_zone2cidr($host);
     293        my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($msg));
     294        $recsth->execute(0, $rparent, $targ, 5, $msg->addr, 0, 0, 0, $ttl, $loc);
     295
     296##fixme:  automagically convert manually maintained sub-/24 delegations
     297#       my ($subip, $zone) = split /\./, $targ, 2;
     298#       ($code, $msg) = DNSDB::_zone2cidr($zone);
     299#       push @{$deleg{"$msg"}{iplist}}, $subip;
     300#print "$msg $subip\n";
     301
     302      } else {
     303        my $fparent = DNSDB::_hostparent($dbh, $host);
     304        if ($fparent) {
     305          $recsth->execute($fparent, 0, $host, 5, $targ, 0, 0, 0, $ttl, $loc);
     306        } else {
     307          push @deferred, $rec unless $nodefer;
     308          $impok = 0;
     309          #  print "$tmporig deferred;  can't find parent zone\n";
     310        }
    145311      }
    146312
    147313    } elsif ($rec =~ /^\&/) {
    148314      $cnt{NS}++;
     315
     316      my ($zone,$ip,$ns,$ttl,$stamp,$loc) = split /:/, $rec, 6;
     317      $zone =~ s/^\&//;
     318      $zone =~ s/\.$//;
     319      $ns =~ s/\.$//;
     320      $ns = "$ns.ns.$zone" if $ns !~ /\./;
     321      $ttl = 0 if !$ttl;
     322      $stamp = '' if !$stamp;
     323      $loc = '' if !$loc;
     324      $loc = '' if $loc =~ /^:+$/;
     325      if ($zone =~ /\.arpa$/) {
     326        ($code,$msg) = DNSDB::_zone2cidr($zone);
     327        my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >>= ?", undef, ("$msg"));
     328##fixme, in concert with the CNAME check for same;  automagically
     329# create "delegate" record instead for subzone NSes:  convert above to use = instead of >>=
     330#  ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ("$msg"))
     331#       if !$rparent;
     332        if ($rparent) {
     333          $recsth->execute(0, $rparent, $ns, 2, $msg, 0, 0, 0, $ttl, $loc);
     334        } else {
     335          push @deferred, $rec unless $nodefer;
     336          $impok = 0;
     337        }
     338      } else {
     339        my $fparent = DNSDB::_hostparent($dbh, $zone);
     340        if ($fparent) {
     341          $recsth->execute($fparent, 0, $zone, 2, $ns, 0, 0, 0, $ttl, $loc);
     342          $recsth->execute($fparent, 0, $ns, 2, $ip, 0, 0, 0, $ttl, $loc) if $ip;
     343        } else {
     344          push @deferred, $rec unless $nodefer;
     345          $impok = 0;
     346        }
     347      }
     348
    149349    } elsif ($rec =~ /^\^/) {
    150350      $cnt{PTR}++;
     351
     352      my ($rip,$host,$ttl,$stamp,$loc) = split /:/, $rec, 5;
     353      $rip =~ s/^\^//;
     354      $rip =~ s/\.$//;
     355      $ttl = 0 if !$ttl;
     356      $stamp = '' if !$stamp;
     357      $loc = '' if !$loc;
     358      $loc = '' if $loc =~ /^:+$/;
     359      my $rparent;
     360      if (my ($i, $z) = ($rip =~ /^(\d+)\.(\d+-(?:\d+\.){4}in-addr.arpa)$/) ) {
     361        ($code,$msg) = DNSDB::_zone2cidr($z);
     362        # Exact matches only, because we're in a sub-/24 delegation
     363##fixme:  flag the type of delegation (range, subnet-with-dash, subnet-with-slash)
     364# somewhere so we can recover it on export.  probably best to do that in the revzone data.
     365        ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet = ?", undef, ("$msg"));
     366        $z =~ s/^[\d-]+//;
     367        ($code,$msg) = DNSDB::_zone2cidr("$i.$z");      # Get the actual IP and normalize
     368      } else {
     369        ($code,$msg) = DNSDB::_zone2cidr($rip);
     370        ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ("$msg"));
     371      }
     372      if ($rparent) {
     373        $recsth->execute(0, $rparent, $host, 12, $msg->addr, 0, 0, 0, $ttl, $loc);
     374      } else {
     375        push @deferred, $rec unless $nodefer;
     376        $impok = 0;
     377      }
     378
    151379    } elsif ($rec =~ /^\+/) {
    152380      $cnt{A}++;
     381
     382      my ($host,$ip,$ttl,$stamp,$loc) = split /:/, $rec, 5;
     383      $host =~ s/^\+//;
     384      $host =~ s/\.$//;
     385      $host =~ s/^\\052/*/;
     386      $ttl = 0 if !$ttl;
     387      $stamp = '' if !$stamp;
     388      $loc = '' if !$loc;
     389      $loc = '' if $loc =~ /^:+$/;
     390
     391      my $domid = DNSDB::_hostparent($dbh, $host);
     392      if ($domid) {
     393        $recsth->execute($domid, 0, $host, 1, $ip, 0, 0, 0, $ttl, $loc);
     394      } else {
     395        push @deferred, $rec unless $nodefer;
     396        $impok = 0;
     397      }
     398
    153399    } elsif ($rec =~ /^Z/) {
    154400      $cnt{SOA}++;
    155 #Z128.91.209.in-addr.arpa:ns1.vianet.ca.:dnsadmin.vianet.ca.::1209600:1209600:900:900:900:
    156       my ($zone,$master,$contact,$serial,$refresh,$retry,$expire,$minttl,$ttl,$time,$loc) = split /:/, $rec;
     401
     402      my ($zone,$master,$contact,$serial,$refresh,$retry,$expire,$minttl,$ttl,$stamp,$loc) = split /:/, $rec, 11;
    157403      $zone =~ s/^Z//;
    158404      $zone =~ s/\.$//;
    159405      $master =~ s/\.$//;
    160406      $contact =~ s/\.$//;
    161       $time = '' if !$time;
    162       $loc = '' if !$loc;
     407      $ttl = 0 if !$ttl;
     408      $stamp = '' if !$stamp;
     409      $loc = '' if !$loc;
     410      $loc = '' if $loc =~ /^:+$/;
    163411      if ($zone =~ /\.arpa$/) {
    164412        ($code,$msg) = DNSDB::_zone2cidr($zone);
    165         $dbh->do("INSERT INTO revzones (revnet,group_id,status) VALUES (?,1,1)", undef, ($msg));
     413        $dbh->do("INSERT INTO revzones (revnet,group_id,status,default_location) VALUES (?,1,1,?)",
     414                undef, ($msg, $loc));
    166415        my ($rdns) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')");
    167         $dbh->do("INSERT INTO records (rdns_id,host,type,val,ttl) VALUES (?,?,6,?,?)", undef,
    168                 ($rdns, "$contact:$master", "$refresh:$retry:$expire:$minttl", $ttl));
    169       } else {
    170         $dbh->do("INSERT INTO domains (domain,group_id,status) VALUES (?,1,1)", undef, ($zone));
     416        $recsth->execute(0, $rdns, "$contact:$master", 6, "$refresh:$retry:$expire:$minttl", 0, 0, 0, $ttl, $loc);
     417      } else {
     418        $dbh->do("INSERT INTO domains (domain,group_id,status,default_location) VALUES (?,1,1,?)",
     419                undef, ($zone, $loc));
    171420        my ($domid) = $dbh->selectrow_array("SELECT currval('domains_domain_id_seq')");
    172         $dbh->do("INSERT INTO records (rdns_id,host,type,val,ttl) VALUES (?,?,6,?,?)", undef,
    173                 ($domid, "$contact:$master", "$refresh:$retry:$expire:$minttl", $ttl));
     421        $recsth->execute($domid, 0, "$contact:$master", 6, "$refresh:$retry:$expire:$minttl", 0, 0, 0, $ttl, $loc);
    174422      }
    175423
    176424    } elsif ($rec =~ /^\@/) {
    177425      $cnt{MX}++;
     426
     427      my ($zone,$ip,$host,$dist,$ttl,$stamp,$loc) = split /:/, $rec, 7;
     428      $zone =~ s/^\@//;
     429      $zone =~ s/\.$//;
     430      $zone =~ s/^\\052/*/;
     431      $host =~ s/\.$//;
     432      $host = "$host.mx.$zone" if $host !~ /\./;
     433      $ttl = 0 if !$ttl;
     434      $stamp = '' if !$stamp;
     435      $loc = '' if !$loc;
     436      $loc = '' if $loc =~ /^:+$/;
     437
     438# note we don't check for reverse domains here, because MX records don't make any sense in reverse zones.
     439# if this really ever becomes an issue for someone it can be expanded to handle those weirdos
     440
     441      # allow for subzone MXes, since it's perfectly legitimate to simply stuff it all in a single parent zone
     442      my $domid = DNSDB::_hostparent($dbh, $zone);
     443      if ($domid) {
     444        $recsth->execute($domid, 0, $zone, 15, $host, $dist, 0, 0, $ttl, $loc);
     445        $recsth->execute($domid, 0, $host, 1, $ip, 0, 0, 0, $ttl, $loc) if $ip;
     446      } else {
     447        push @deferred, $rec unless $nodefer;
     448        $impok = 0;
     449      }
     450
    178451    } elsif ($rec =~ /^'/) {
    179452      $cnt{TXT}++;
    180453
    181 sub _deoctal {
    182   my $targ = shift;
    183   while ($$targ =~ /\\(\d{3})/) {
    184     my $sub = chr(oct($1));
    185     $$targ =~ s/\\$1/$sub/g;
    186   }
    187 }
    188 
    189       my ($fqdn, $rdata, $ttl, $time, $loc) = split /:/, $rec;
     454      my ($fqdn, $rdata, $ttl, $stamp, $loc) = split /:/, $rec, 5;
    190455      $fqdn =~ s/^'//;
     456      $fqdn =~ s/^\\052/*/;
    191457      _deoctal(\$rdata);
    192 
    193 print "$fqdn TXT '$rdata'\n" if $fqdn =~ /^\*/;
    194       my $domid = DNSDB::_hostparent($dbh, $fqdn);
    195       if ($domid) {
    196         $recsth->execute($domid, 0, $fqdn, 16, $rdata, 0, 0, 0, $ttl);
    197       } else {
    198         push @deferred, $rec unless $nodefer;
     458      $ttl = 0 if !$ttl;
     459      $stamp = '' if !$stamp;
     460      $loc = '' if !$loc;
     461      $loc = '' if $loc =~ /^:+$/;
     462
     463      if ($fqdn =~ /\.arpa$/) {
     464        ($code,$msg) = DNSDB::_zone2cidr($fqdn);
     465        my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($msg));
     466        $recsth->execute(0, $rparent, $rdata, 16, "$msg", 0, 0, 0, $ttl, $loc);
     467      } else {
     468        my $domid = DNSDB::_hostparent($dbh, $fqdn);
     469        if ($domid) {
     470          $recsth->execute($domid, 0, $fqdn, 16, $rdata, 0, 0, 0, $ttl, $loc);
     471        } else {
     472          push @deferred, $rec unless $nodefer;
     473          $impok = 0;
     474        }
    199475      }
    200476
    201477    } elsif ($rec =~ /^\./) {
    202478      $cnt{NSASOA}++;
     479
     480      my ($fqdn, $ip, $ns, $ttl, $stamp, $loc) = split /:/, $rec, 6;
     481      $fqdn =~ s/^\.//;
     482      $fqdn =~ s/\.$//;
     483      $ns =~ s/\.$//;
     484      $ns = "$ns.ns.$fqdn" if $ns !~ /\./;
     485      $ttl = 0 if !$ttl;
     486      $stamp = '' if !$stamp;
     487      $loc = '' if !$loc;
     488      $loc = '' if $loc =~ /^:+$/;
     489
     490      if ($fqdn =~ /\.arpa$/) {
     491        ($code,$msg) = DNSDB::_zone2cidr($fqdn);
     492        my ($rdns) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet = ?", undef, ($msg));
     493        if (!$rdns) {
     494          $errstr = "adding revzone $msg";
     495          $dbh->do("INSERT INTO revzones (revnet,group_id,status,default_location) VALUES (?,1,1,?)",
     496                undef, ($msg, $loc));
     497          ($rdns) = $dbh->selectrow_array("SELECT currval('revzones_rdns_id_seq')");
     498# this would probably make a lot more sense to do hostmaster.$config{admindomain}
     499          $recsth->execute(0, $rdns, "hostmaster.$fqdn:$ns", 6, "16384:2048:1048576:2560", 0, 0, 0, "2560", $loc);
     500        }
     501        $recsth->execute(0, $rdns, $ns, 2, "$msg", 0, 0, 0, $ttl, $loc);
     502##fixme:  (?)  implement full conversion of tinydns . records?
     503# -> problem:  A record for NS must be added to the appropriate *forward* zone, not the reverse
     504#$recsth->execute(0, $rdns, $ns, 1, $ip, 0, 0, 0, $ttl)
     505# ...  auto-A-record simply does not make sense in reverse zones.  Functionally
     506# I think it would work, sort of, but it's a nasty mess and anyone hosting reverse
     507# zones has names for their nameservers already.
     508# Even the auto-nameserver-fqdn comes out...  ugly.
     509
     510      } else {
     511        my ($domid) = $dbh->selectrow_array("SELECT domain_id FROM domains WHERE lower(domain) = lower(?)",
     512                undef, ($fqdn));
     513        if (!$domid) {
     514          $errstr = "adding domain $fqdn";
     515          $dbh->do("INSERT INTO domains (domain,group_id,status,default_location) VALUES (?,1,1,?)",
     516                undef, ($fqdn, $loc));
     517          ($domid) = $dbh->selectrow_array("SELECT currval('domains_domain_id_seq')");
     518          $recsth->execute($domid, 0, "hostmaster.$fqdn:$ns", 6, "16384:2048:1048576:2560", 0, 0, 0, "2560", $loc);
     519        }
     520        $recsth->execute($domid, 0, $fqdn, 2, $ns, 0, 0, 0, $ttl, $loc);
     521        $recsth->execute($domid, 0, $ns, 1, $ip, 0, 0, 0, $ttl, $loc) if $ip;
     522      }
     523
     524
     525    } elsif ($rec =~ /^\%/) {
     526      $cnt{VIEWS}++;
     527
     528      # unfortunate that we don't have a guaranteed way to get a description on these.  :/
     529      my ($loc,$cnet) = split /:/, $rec, 2;
     530      $loc =~ s/^\%//;
     531      if (my ($iplist) = $dbh->selectrow_array("SELECT iplist FROM locations WHERE location = ?", undef, ($loc))) {
     532        if ($cnet) {
     533          $iplist .= ", $cnet";
     534          $dbh->do("UPDATE locations SET iplist = ? WHERE location = ?", undef, ($iplist, $loc));
     535        } else {
     536          # hmm.  spit out a warning?  if we already have entries for $loc, adding a null
     537          # entry will almost certainly Do The Wrong Thing(TM)
     538        }
     539      } else {
     540        $cnet = '' if !$cnet;   # de-nullify
     541        $dbh->do("INSERT INTO locations (location,iplist,description) VALUES (?,?,?)", undef, ($loc, $cnet, $loc));
     542      }
     543
    203544    } elsif ($rec =~ /^:/) {
    204545      $cnt{NCUST}++;
    … …  
    206547# recognition and handling for the core common types, this must deal with the leftovers.
    207548# :fqdn:type:rdata:ttl:time:loc
    208 #:mx2.sys.vianet.ca:44:\001\001\215\272\152\152\123\142\120\071\320\106\160\364\107\372\153\116\036\111\247\135:900::sys
    209 #:_sipfederationtls._tcp.ncstechnology.com:33:\000\144\000\001\023\305\006sipfed\006online\004lync\003com\000:3600::
    210 
    211 my (undef, $fqdn, $type, $rdata, $ttl, $time, $loc) = split /:/, $rec;
    212 
    213 if ($type == 33) {
    214   # SRV
    215   my ($prio, $weight, $port, $target) = (0,0,0,0);
    216 
    217   my @tmp = _byteparse(\$rdata, 2);
    218   $prio = $tmp[0] * 256 + $tmp[1];
    219   @tmp = _byteparse(\$rdata, 2);
    220   $weight = $tmp[0] * 256 + $tmp[1];
    221   @tmp = _byteparse(\$rdata, 2);
    222   $port = $tmp[0] * 256 + $tmp[1];
    223 
    224   $rdata =~ s/\\\d{3}/./g;
    225   ($target) = ($rdata =~ /^\.(.+)\.$/);
     549
     550      my (undef, $fqdn, $type, $rdata, $ttl, $stamp, $loc) = split /:/, $rec, 7;
     551      $fqdn =~ s/\.$//;
     552      $fqdn =~ s/^\\052/*/;
     553      $ttl = 0 if !$ttl;
     554      $stamp = '' if !$stamp;
     555      $loc = '' if !$loc;
     556      $loc = '' if $loc =~ /^:+$/;
     557
     558      if ($type == 33) {
     559        # SRV
     560        my ($prio, $weight, $port, $target) = (0,0,0,0);
     561
     562        my @tmp = _byteparse(\$rdata, 2);
     563        $prio = $tmp[0] * 256 + $tmp[1];
     564        @tmp = _byteparse(\$rdata, 2);
     565        $weight = $tmp[0] * 256 + $tmp[1];
     566        @tmp = _byteparse(\$rdata, 2);
     567        $port = $tmp[0] * 256 + $tmp[1];
     568
     569        $rdata =~ s/\\\d{3}/./g;
     570        ($target) = ($rdata =~ /^\.(.+)\.$/);
    226571# hmm.  the above *should* work, but What If(TM) we have ASCII-range bytes
    227572# representing the target's fqdn part length(s)?  axfr-get doesn't seem to,
    … …  
    236581#  }
    237582
    238   my $domid = DNSDB::_hostparent($dbh, $fqdn);
    239   if ($domid) {
    240     $recsth->execute($domid, 0, $fqdn, $type, $target, $prio, $weight, $port, $ttl) if $domid;
    241   } else {
    242     push @deferred, $rec unless $nodefer;
    243   }
    244 
    245 } elsif ($type == 28) {
    246   # AAAA
    247 
    248   my @v6;
    249 
    250   for (my $i=0; $i < 8; $i++) {
    251     my @tmp = _byteparse(\$rdata, 2);
    252     push @v6, sprintf("%0.4x", $tmp[0] * 256 + $tmp[1]);
    253   }
    254   my $val = NetAddr::IP->new(join(':', @v6));
    255 
    256   my $domid = DNSDB::_hostparent($dbh, $fqdn);
    257   if ($domid) {
    258     $recsth->execute($domid, 0, $fqdn, $type, $val->addr, 0, 0, 0, $ttl) if $domid;
    259   } else {
    260     push @deferred, $rec unless $nodefer;
    261   }
    262 
    263 } else {
    264   # ... uhhh, dunno
    265 }
     583        my $domid = DNSDB::_hostparent($dbh, $fqdn);
     584        if ($domid) {
     585          $recsth->execute($domid, 0, $fqdn, 33, $target, $prio, $weight, $port, $ttl, $loc) if $domid;
     586        } else {
     587          push @deferred, $rec unless $nodefer;
     588          $impok = 0;
     589        }
     590
     591      } elsif ($type == 28) {
     592        # AAAA
     593        my @v6;
     594
     595        for (my $i=0; $i < 8; $i++) {
     596          my @tmp = _byteparse(\$rdata, 2);
     597          push @v6, sprintf("%0.4x", $tmp[0] * 256 + $tmp[1]);
     598        }
     599        my $val = NetAddr::IP->new(join(':', @v6));
     600
     601        my $fparent = DNSDB::_hostparent($dbh, $fqdn);
     602        if ($fparent) {
     603          $recsth->execute($fparent, 0, $fqdn, 28, $val->addr, 0, 0, 0, $ttl, $loc);
     604        } else {
     605          push @deferred, $rec unless $nodefer;
     606          $impok = 0;
     607        }
     608
     609      } elsif ($type == 16) {
     610        # TXT
     611        my $txtstring = _rdata2string($rdata);
     612
     613        if ($fqdn =~ /\.arpa$/) {
     614          ($code,$msg) = DNSDB::_zone2cidr($fqdn);
     615          my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($msg));
     616          if ($rparent) {
     617            $recsth->execute(0, $rparent, $txtstring, 16, "$msg", 0, 0, 0, $ttl, $loc);
     618          } else {
     619            push @deferred, $rec unless $nodefer;
     620            $impok = 0;
     621          }
     622        } else {
     623          my $domid = DNSDB::_hostparent($dbh, $fqdn);
     624          if ($domid) {
     625            $recsth->execute($domid, 0, $fqdn, 16, $txtstring, 0, 0, 0, $ttl, $loc);
     626          } else {
     627            push @deferred, $rec unless $nodefer;
     628            $impok = 0;
     629          }
     630        }
     631
     632      } elsif ($type == 17) {
     633        # RP
     634        my ($email, $txtrec) = split /\\000/, $rdata;
     635        $email =~ s/\\\d{3}/./g;
     636        $email =~ s/^\.//;
     637        $txtrec =~ s/\\\d{3}/./g;
     638        $txtrec =~ s/^\.//;
     639
     640        # these might actually make sense in a reverse zone...  sort of.
     641        if ($fqdn =~ /\.arpa$/) {
     642          ($code,$msg) = DNSDB::_zone2cidr($fqdn);
     643          my ($rparent) = $dbh->selectrow_array("SELECT rdns_id FROM revzones WHERE revnet >> ?", undef, ($msg));
     644          if ($rparent) {
     645            $recsth->execute(0, $rparent, "$email $txtrec", 17, "$msg", 0, 0, 0, $ttl, $loc);
     646          } else {
     647            push @deferred, $rec unless $nodefer;
     648            $impok = 0;
     649          }
     650        } else {
     651          my $domid = DNSDB::_hostparent($dbh, $fqdn);
     652          if ($domid) {
     653            $recsth->execute($domid, 0, $fqdn, 17, "$email $txtrec", 0, 0, 0, $ttl, $loc);
     654          } else {
     655            push @deferred, $rec unless $nodefer;
     656            $impok = 0;
     657          }
     658        }
     659
     660      } elsif ($type == 44) {
     661        # SSHFP
     662        my $sshfp = _byteparse(\$rdata, 1);
     663        $sshfp .= " "._byteparse(\$rdata, 1);
     664        $sshfp .= " "._rdata2hex($rdata);
     665
     666        # these do not make sense in a reverse zone, since they're logically attached to an A record
     667        my $domid = DNSDB::_hostparent($dbh, $fqdn);
     668        if ($domid) {
     669          $recsth->execute($domid, 0, $fqdn, 44, $sshfp, 0, 0, 0, $ttl, $loc);
     670        } else {
     671          push @deferred, $rec unless $nodefer;
     672          $impok = 0;
     673        }
     674
     675      } else {
     676        print "unhandled rec $rec\n";
     677        $impok = 0;
     678        # ... uhhh, dunno
     679      }
    266680
    267681    } else {
    268682      $cnt{other}++;
    269   print " $_\n";
     683      print " $_\n";
    270684    }
    271   }
     685
     686    return $impok;      # just to make sure
     687  } # recslurp()
    272688
    273689  close FLAT;

  • branches/stable/vega-import.pl

    r263 r545  
    33##
    44# $Id$
    5 # Copyright 2008-2011 Kris Deugau <kdeugau@deepnet.cx>
     5# Copyright 2011,2012 Kris Deugau <kdeugau@deepnet.cx>
    66#
    77#    This program is free software: you can redistribute it and/or modify
Note: See TracChangeset for help on using the changeset viewer.