diff options
Diffstat (limited to 'contrib/dlz/modules/perl/dlz_perl_driver.c')
| -rw-r--r-- | contrib/dlz/modules/perl/dlz_perl_driver.c | 738 |
1 files changed, 738 insertions, 0 deletions
diff --git a/contrib/dlz/modules/perl/dlz_perl_driver.c b/contrib/dlz/modules/perl/dlz_perl_driver.c new file mode 100644 index 0000000..2a9a44f --- /dev/null +++ b/contrib/dlz/modules/perl/dlz_perl_driver.c @@ -0,0 +1,738 @@ +/* + * Copyright (C) 2002 Stichting NLnet, Netherlands, stichting@nlnet.nl. + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the + * above copyright notice and this permission notice appear in all + * copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND STICHTING NLNET + * DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL + * STICHTING NLNET BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR + * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS + * OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE + * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE + * USE OR PERFORMANCE OF THIS SOFTWARE. + * + * The development of Dynamically Loadable Zones (DLZ) for Bind 9 was + * conceived and contributed by Rob Butler. + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the + * above copyright notice and this permission notice appear in all + * copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND ROB BUTLER + * DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL + * ROB BUTLER BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR + * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS + * OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE + * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE + * USE OR PERFORMANCE OF THIS SOFTWARE. + */ + +/* + * Copyright (C) 1999-2001, 2016 Internet Systems Consortium, Inc. ("ISC") + * + * This Source Code Form is subject to the terms of the Mozilla Public + * License, v. 2.0. If a copy of the MPL was not distributed with this + * file, You can obtain one at http://mozilla.org/MPL/2.0/. + */ + +/* + * Copyright (C) 2009-2012 John Eaglesham + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND JOHN EAGLESHAM + * DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL + * JOHN EAGLESHAM BE LIABLE FOR ANY SPECIAL, DIRECT, + * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING + * FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, + * NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION + * WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + */ + +#include <config.h> +#include <stdio.h> +#include <string.h> +#include <stdlib.h> + +#include <EXTERN.h> +#include <perl.h> + +#include <dlz_minimal.h> + +#include "dlz_perl_driver.h" + +/* Enable debug logging? */ +#if 0 +#define carp(...) cd->log(ISC_LOG_INFO, __VA_ARGS__); +#else +#define carp(...) +#endif + +#ifndef MULTIPLICITY +/* This is a pretty terrible work-around for handling HUP/rndc reconfig, but + * the way BIND/DLZ handles reloads causes it to create a second back end + * before removing the first. In the case of a single global interpreter, + * serious problems arise. We can hack around this, but it's much better to do + * it properly and link against a perl compiled with multiplicity. */ +static PerlInterpreter *global_perl = NULL; +static int global_perl_dont_free = 0; +#endif + +typedef struct config_data { + PerlInterpreter *perl; + char *perl_source; + SV *perl_class; + + /* Functions given to us by bind9 */ + log_t *log; + dns_sdlz_putrr_t *putrr; + dns_sdlz_putnamedrr_t *putnamedrr; + dns_dlz_writeablezone_t *writeable_zone; +} config_data_t; + +/* Note, this code generates warnings due to lost type qualifiers. This code + * is (almost) verbatim from perlembed, and is known to work correctly despite + * the warnings. + */ +EXTERN_C void xs_init (pTHX); +EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); +EXTERN_C void boot_DLZ_Perl__clientinfo (pTHX_ CV* cv); +EXTERN_C void boot_DLZ_Perl (pTHX_ CV* cv); +EXTERN_C void +xs_init(pTHX) +{ + char *file = __FILE__; + dXSUB_SYS; + + /* DynaLoader is a special case */ + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); + newXS("DLZ_Perl::clientinfo::bootstrap", boot_DLZ_Perl__clientinfo, file); + newXS("DLZ_Perl::bootstrap", boot_DLZ_Perl, file); +} + +/* + * methods + */ + +/* + * remember a helper function, from the bind9 dlz_dlopen driver + */ +static void b9_add_helper(config_data_t *state, + const char *helper_name, void *ptr) +{ + if (strcmp(helper_name, "log") == 0) + state->log = ptr; + if (strcmp(helper_name, "putrr") == 0) + state->putrr = ptr; + if (strcmp(helper_name, "putnamedrr") == 0) + state->putnamedrr = ptr; + if (strcmp(helper_name, "writeable_zone") == 0) + state->writeable_zone = ptr; +} + +int dlz_version(unsigned int *flags) { + return DLZ_DLOPEN_VERSION; +} + +isc_result_t dlz_allnodes(const char *zone, void *dbdata, + dns_sdlzallnodes_t *allnodes) +{ + config_data_t *cd = (config_data_t *) dbdata; + isc_result_t retval; + int rrcount, r; + SV *record_ref; + SV **rr_name; + SV **rr_type; + SV **rr_ttl; + SV **rr_data; +#ifdef MULTIPLICITY + PerlInterpreter *my_perl = cd->perl; +#endif + dSP; + + PERL_SET_CONTEXT(cd->perl); + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(cd->perl_class); + XPUSHs(sv_2mortal(newSVpv(zone, 0))); + PUTBACK; + + carp("DLZ Perl: Calling allnodes for zone %s", zone); + rrcount = call_method("allnodes", G_ARRAY|G_EVAL); + carp("DLZ Perl: Call to allnodes returned rrcount of %i", rrcount); + + SPAGAIN; + + if (SvTRUE(ERRSV)) { + POPs; + cd->log(ISC_LOG_ERROR, "DLZ Perl: allnodes for zone %s died in eval: %s", zone, SvPV_nolen(ERRSV)); + retval = ISC_R_FAILURE; + goto CLEAN_UP_AND_RETURN; + } + + if (!rrcount) { + retval = ISC_R_NOTFOUND; + goto CLEAN_UP_AND_RETURN; + } + + retval = ISC_R_SUCCESS; + r = 0; + while (r++ < rrcount) { + record_ref = POPs; + if ( + (!SvROK(record_ref)) || + (SvTYPE(SvRV(record_ref)) != SVt_PVAV) + ) { + cd->log(ISC_LOG_ERROR, + "DLZ Perl: allnodes for zone %s " + "returned an invalid value " + "(expected array of arrayrefs)", + zone); + retval = ISC_R_FAILURE; + break; + } + + record_ref = SvRV(record_ref); + + rr_name = av_fetch((AV *) record_ref, 0, 0); + rr_type = av_fetch((AV *) record_ref, 1, 0); + rr_ttl = av_fetch((AV *) record_ref, 2, 0); + rr_data = av_fetch((AV *) record_ref, 3, 0); + + if (rr_name == NULL || rr_type == NULL || + rr_ttl == NULL || rr_data == NULL) + { + cd->log(ISC_LOG_ERROR, + "DLZ Perl: allnodes for zone %s " + "returned an array that was missing data", + zone); + retval = ISC_R_FAILURE; + break; + } + + carp("DLZ Perl: Got record %s/%s = %s", + SvPV_nolen(*rr_name), SvPV_nolen(*rr_type), + SvPV_nolen(*rr_data)); + retval = cd->putnamedrr(allnodes, + SvPV_nolen(*rr_name), + SvPV_nolen(*rr_type), + SvIV(*rr_ttl), SvPV_nolen(*rr_data)); + if (retval != ISC_R_SUCCESS) { + cd->log(ISC_LOG_ERROR, + "DLZ Perl: putnamedrr in allnodes " + "for zone %s failed with code %i " + "(did lookup return invalid record data?)", + zone, retval); + break; + } + } + +CLEAN_UP_AND_RETURN: + PUTBACK; + FREETMPS; + LEAVE; + + carp("DLZ Perl: Returning from allnodes, r = %i, retval = %i", + r, retval); + + return (retval); +} + +isc_result_t +dlz_allowzonexfr(void *dbdata, const char *name, const char *client) { + config_data_t *cd = (config_data_t *) dbdata; + int r; + isc_result_t retval; +#ifdef MULTIPLICITY + PerlInterpreter *my_perl = cd->perl; +#endif + dSP; + + PERL_SET_CONTEXT(cd->perl); + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(cd->perl_class); + XPUSHs(sv_2mortal(newSVpv(name, 0))); + XPUSHs(sv_2mortal(newSVpv(client, 0))); + PUTBACK; + + r = call_method("allowzonexfr", G_SCALAR|G_EVAL); + SPAGAIN; + + if (SvTRUE(ERRSV)) { + /* + * On error there's an undef at the top of the stack. Pop + * it away so we don't leave junk on the stack for the next + * caller. + */ + POPs; + cd->log(ISC_LOG_ERROR, + "DLZ Perl: allowzonexfr died in eval: %s", + SvPV_nolen(ERRSV)); + retval = ISC_R_FAILURE; + } else if (r == 0) { + /* Client returned nothing -- zone not found. */ + retval = ISC_R_NOTFOUND; + } else if (r > 1) { + /* Once again, clean out the stack when possible. */ + while (r--) POPi; + cd->log(ISC_LOG_ERROR, + "DLZ Perl: allowzonexfr returned too many parameters!"); + retval = ISC_R_FAILURE; + } else { + /* + * Client returned true/false -- we're authoritative for + * the zone. + */ + r = POPi; + if (r) + retval = ISC_R_SUCCESS; + else + retval = ISC_R_NOPERM; + } + + PUTBACK; + FREETMPS; + LEAVE; + return (retval); +} + +#if DLZ_DLOPEN_VERSION < 3 +isc_result_t +dlz_findzonedb(void *dbdata, const char *name) +#else +isc_result_t +dlz_findzonedb(void *dbdata, const char *name, + dns_clientinfomethods_t *methods, + dns_clientinfo_t *clientinfo) +#endif +{ + config_data_t *cd = (config_data_t *) dbdata; + int r; + isc_result_t retval; +#ifdef MULTIPLICITY + PerlInterpreter *my_perl = cd->perl; +#endif + +#if DLZ_DLOPEN_VERSION >= 3 + UNUSED(methods); + UNUSED(clientinfo); +#endif + + dSP; + carp("DLZ Perl: findzone looking for '%s'", name); + + PERL_SET_CONTEXT(cd->perl); + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(cd->perl_class); + XPUSHs(sv_2mortal(newSVpv(name, 0))); + PUTBACK; + + r = call_method("findzone", G_SCALAR|G_EVAL); + SPAGAIN; + + if (SvTRUE(ERRSV)) { + /* + * On error there's an undef at the top of the stack. Pop + * it away so we don't leave junk on the stack for the next + * caller. + */ + POPs; + cd->log(ISC_LOG_ERROR, + "DLZ Perl: findzone died in eval: %s", + SvPV_nolen(ERRSV)); + retval = ISC_R_FAILURE; + } else if (r == 0) { + retval = ISC_R_FAILURE; + } else if (r > 1) { + /* Once again, clean out the stack when possible. */ + while (r--) POPi; + cd->log(ISC_LOG_ERROR, + "DLZ Perl: findzone returned too many parameters!"); + retval = ISC_R_FAILURE; + } else { + r = POPi; + if (r) + retval = ISC_R_SUCCESS; + else + retval = ISC_R_NOTFOUND; + } + + PUTBACK; + FREETMPS; + LEAVE; + return (retval); +} + + +#if DLZ_DLOPEN_VERSION == 1 +isc_result_t +dlz_lookup(const char *zone, const char *name, + void *dbdata, dns_sdlzlookup_t *lookup) +#else +isc_result_t +dlz_lookup(const char *zone, const char *name, + void *dbdata, dns_sdlzlookup_t *lookup, + dns_clientinfomethods_t *methods, + dns_clientinfo_t *clientinfo) +#endif +{ + isc_result_t retval; + config_data_t *cd = (config_data_t *) dbdata; + int rrcount, r; + dlz_perl_clientinfo_opaque opaque; + SV *record_ref; + SV **rr_type; + SV **rr_ttl; + SV **rr_data; +#ifdef MULTIPLICITY + PerlInterpreter *my_perl = cd->perl; +#endif + +#if DLZ_DLOPEN_VERSION >= 2 + UNUSED(methods); + UNUSED(clientinfo); +#endif + + dSP; + PERL_SET_CONTEXT(cd->perl); + ENTER; + SAVETMPS; + + opaque.methods = methods; + opaque.clientinfo = clientinfo; + + PUSHMARK(SP); + XPUSHs(cd->perl_class); + XPUSHs(sv_2mortal(newSVpv(name, 0))); + XPUSHs(sv_2mortal(newSVpv(zone, 0))); + XPUSHs(sv_2mortal(newSViv((IV)&opaque))); + PUTBACK; + + carp("DLZ Perl: Searching for name %s in zone %s", name, zone); + rrcount = call_method("lookup", G_ARRAY|G_EVAL); + carp("DLZ Perl: Call to lookup returned %i", rrcount); + + SPAGAIN; + + if (SvTRUE(ERRSV)) { + POPs; + cd->log(ISC_LOG_ERROR, "DLZ Perl: lookup died in eval: %s", + SvPV_nolen(ERRSV)); + retval = ISC_R_FAILURE; + goto CLEAN_UP_AND_RETURN; + } + + if (!rrcount) { + retval = ISC_R_NOTFOUND; + goto CLEAN_UP_AND_RETURN; + } + + retval = ISC_R_SUCCESS; + r = 0; + while (r++ < rrcount) { + record_ref = POPs; + if ((!SvROK(record_ref)) || + (SvTYPE(SvRV(record_ref)) != SVt_PVAV)) + { + cd->log(ISC_LOG_ERROR, + "DLZ Perl: lookup returned an " + "invalid value (expected array of arrayrefs)!"); + retval = ISC_R_FAILURE; + break; + } + + record_ref = SvRV(record_ref); + + rr_type = av_fetch((AV *) record_ref, 0, 0); + rr_ttl = av_fetch((AV *) record_ref, 1, 0); + rr_data = av_fetch((AV *) record_ref, 2, 0); + + if (rr_type == NULL || rr_ttl == NULL || rr_data == NULL) { + cd->log(ISC_LOG_ERROR, + "DLZ Perl: lookup for record %s in " + "zone %s returned an array that was " + "missing data", name, zone); + retval = ISC_R_FAILURE; + break; + } + + carp("DLZ Perl: Got record %s = %s", + SvPV_nolen(*rr_type), SvPV_nolen(*rr_data)); + retval = cd->putrr(lookup, SvPV_nolen(*rr_type), + SvIV(*rr_ttl), SvPV_nolen(*rr_data)); + + if (retval != ISC_R_SUCCESS) { + cd->log(ISC_LOG_ERROR, + "DLZ Perl: putrr for lookup of %s in " + "zone %s failed with code %i " + "(did lookup return invalid record data?)", + name, zone, retval); + break; + } + } + +CLEAN_UP_AND_RETURN: + PUTBACK; + FREETMPS; + LEAVE; + + carp("DLZ Perl: Returning from lookup, r = %i, retval = %i", r, retval); + + return (retval); +} + +const char * +#ifdef MULTIPLICITY +missing_perl_method(const char *perl_class_name, PerlInterpreter *my_perl) +#else +missing_perl_method(const char *perl_class_name) +#endif +{ + const int BUF_LEN = 64; /* Should be big enough, right? hah */ + char full_name[BUF_LEN]; + const char *methods[] = { "new", "findzone", "lookup", NULL }; + int i = 0; + + while( methods[i] != NULL ) { + snprintf(full_name, BUF_LEN, "%s::%s", + perl_class_name, methods[i]); + + if (get_cv(full_name, 0) == NULL) { + return methods[i]; + } + i++; + } + + return (NULL); +} + +isc_result_t +dlz_create(const char *dlzname, unsigned int argc, char *argv[], + void **dbdata, ...) +{ + config_data_t *cd; + char *init_args[] = { NULL, NULL }; + char *perlrun[] = { "", NULL, "dlz perl", NULL }; + char *perl_class_name; + int r; + va_list ap; + const char *helper_name; + const char *missing_method_name; + char *call_argv_args = NULL; +#ifdef MULTIPLICITY + PerlInterpreter *my_perl; +#endif + + cd = malloc(sizeof(config_data_t)); + if (cd == NULL) + return (ISC_R_NOMEMORY); + + memset(cd, 0, sizeof(config_data_t)); + + /* fill in the helper functions */ + va_start(ap, dbdata); + while ((helper_name = va_arg(ap, const char *)) != NULL) { + b9_add_helper(cd, helper_name, va_arg(ap, void*)); + } + va_end(ap); + + if (argc < 2) { + cd->log(ISC_LOG_ERROR, + "DLZ Perl '%s': Missing script argument.", + dlzname); + free(cd); + return (ISC_R_FAILURE); + } + + if (argc < 3) { + cd->log(ISC_LOG_ERROR, + "DLZ Perl '%s': Missing class name argument.", + dlzname); + free(cd); + return (ISC_R_FAILURE); + } + perl_class_name = argv[2]; + + cd->log(ISC_LOG_INFO, "DLZ Perl '%s': Loading '%s' from location '%s'", + dlzname, perl_class_name, argv[1], argc); + +#ifndef MULTIPLICITY + if (global_perl) { + /* + * PERL_SET_CONTEXT not needed here as we're guaranteed to + * have an implicit context thanks to an undefined + * MULTIPLICITY. + */ + PL_perl_destruct_level = 1; + perl_destruct(global_perl); + perl_free(global_perl); + global_perl = NULL; + global_perl_dont_free = 1; + } +#endif + + cd->perl = perl_alloc(); + if (cd->perl == NULL) { + free(cd); + return (ISC_R_FAILURE); + } +#ifdef MULTIPLICITY + my_perl = cd->perl; +#endif + PERL_SET_CONTEXT(cd->perl); + + /* + * We will re-create the interpreter during an rndc reconfig, so we + * must set this variable per perlembed in order to insure we can + * clean up Perl at a later time. + */ + PL_perl_destruct_level = 1; + perl_construct(cd->perl); + PL_exit_flags |= PERL_EXIT_DESTRUCT_END; + /* Prevent crashes from clients writing to $0 */ + PL_origalen = 1; + + cd->perl_source = strdup(argv[1]); + if (cd->perl_source == NULL) { + free(cd); + return (ISC_R_NOMEMORY); + } + + perlrun[1] = cd->perl_source; + if (perl_parse(cd->perl, xs_init, 3, perlrun, (char **)NULL)) { + cd->log(ISC_LOG_ERROR, + "DLZ Perl '%s': Failed to parse Perl script, aborting", + dlzname); + goto CLEAN_UP_PERL_AND_FAIL; + } + + /* Let Perl know about our callbacks. */ + call_argv("DLZ_Perl::clientinfo::bootstrap", + G_DISCARD|G_NOARGS, &call_argv_args); + call_argv("DLZ_Perl::bootstrap", + G_DISCARD|G_NOARGS, &call_argv_args); + + /* + * Run the script. We don't really need to do this since we have + * the init callback, but there's not really a downside either. + */ + if (perl_run(cd->perl)) { + cd->log(ISC_LOG_ERROR, + "DLZ Perl '%s': Script exited with an error, aborting", + dlzname); + goto CLEAN_UP_PERL_AND_FAIL; + } + +#ifdef MULTIPLICITY + if (missing_method_name = missing_perl_method(perl_class_name, my_perl)) +#else + if (missing_method_name = missing_perl_method(perl_class_name)) +#endif + { + cd->log(ISC_LOG_ERROR, + "DLZ Perl '%s': Missing required function '%s', " + "aborting", dlzname, missing_method_name); + goto CLEAN_UP_PERL_AND_FAIL; + } + + dSP; + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVpv(perl_class_name, 0))); + + /* Build flattened hash of config info. */ + XPUSHs(sv_2mortal(newSVpv("log_context", 0))); + XPUSHs(sv_2mortal(newSViv((IV)cd->log))); + + /* Argument to pass to new? */ + if (argc == 4) { + XPUSHs(sv_2mortal(newSVpv("argv", 0))); + XPUSHs(sv_2mortal(newSVpv(argv[3], 0))); + } + + PUTBACK; + + r = call_method("new", G_EVAL|G_SCALAR); + + SPAGAIN; + + if (r) cd->perl_class = SvREFCNT_inc(POPs); + + PUTBACK; + FREETMPS; + LEAVE; + + if (SvTRUE(ERRSV)) { + POPs; + cd->log(ISC_LOG_ERROR, + "DLZ Perl '%s': new died in eval: %s", + dlzname, SvPV_nolen(ERRSV)); + goto CLEAN_UP_PERL_AND_FAIL; + } + + if (!r || !sv_isobject(cd->perl_class)) { + cd->log(ISC_LOG_ERROR, + "DLZ Perl '%s': new failed to return a blessed object", + dlzname); + goto CLEAN_UP_PERL_AND_FAIL; + } + + *dbdata = cd; + +#ifndef MULTIPLICITY + global_perl = cd->perl; +#endif + return (ISC_R_SUCCESS); + +CLEAN_UP_PERL_AND_FAIL: + PL_perl_destruct_level = 1; + perl_destruct(cd->perl); + perl_free(cd->perl); + free(cd->perl_source); + free(cd); + return (ISC_R_FAILURE); +} + +void dlz_destroy(void *dbdata) { + config_data_t *cd = (config_data_t *) dbdata; +#ifdef MULTIPLICITY + PerlInterpreter *my_perl = cd->perl; +#endif + + cd->log(ISC_LOG_INFO, "DLZ Perl: Unloading driver."); + +#ifndef MULTIPLICITY + if (!global_perl_dont_free) { +#endif + PERL_SET_CONTEXT(cd->perl); + PL_perl_destruct_level = 1; + perl_destruct(cd->perl); + perl_free(cd->perl); +#ifndef MULTIPLICITY + global_perl_dont_free = 0; + global_perl = NULL; + } +#endif + + free(cd->perl_source); + free(cd); +} |