diff options
Diffstat (limited to 'contrib/dlz/modules/perl/dlz_perl_driver.c')
| -rw-r--r-- | contrib/dlz/modules/perl/dlz_perl_driver.c | 715 |
1 files changed, 715 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..b99b296 --- /dev/null +++ b/contrib/dlz/modules/perl/dlz_perl_driver.c @@ -0,0 +1,715 @@ +/* + * Copyright (C) Internet Systems Consortium, Inc. ("ISC") + * + * SPDX-License-Identifier: MPL-2.0 and 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 https://mozilla.org/MPL/2.0/. + */ + +/* + * Copyright (C) Stichting NLnet, Netherlands, stichting@nlnet.nl. + * Copyright (C) John Eaglesham + * + * 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 THE AUTHOR DISCLAIMS ALL WARRANTIES WITH + * REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS. IN NO EVENT SHALL THE AUTHOR 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 "dlz_perl_driver.h" +#include <EXTERN.h> +#include <perl.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> + +#include <dlz_minimal.h> + +#define BUF_LEN 64 /* Should be big enough, right? hah */ + +/* Enable debug logging? */ +#if 0 +#define carp(...) cd->log(ISC_LOG_INFO, __VA_ARGS__); +#else /* if 0 */ +#define carp(...) +#endif /* if 0 */ + +#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 /* ifndef MULTIPLICITY */ + +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) { + const 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) { + UNUSED(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 /* ifdef MULTIPLICITY */ + 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)) { + (void)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 /* ifdef MULTIPLICITY */ + 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. + */ + (void)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 /* if DLZ_DLOPEN_VERSION < 3 */ +isc_result_t +dlz_findzonedb(void *dbdata, const char *name, dns_clientinfomethods_t *methods, + dns_clientinfo_t *clientinfo) +#endif /* if DLZ_DLOPEN_VERSION < 3 */ +{ + config_data_t *cd = (config_data_t *)dbdata; + int r; + isc_result_t retval; +#ifdef MULTIPLICITY + PerlInterpreter *my_perl = cd->perl; +#endif /* ifdef MULTIPLICITY */ + +#if DLZ_DLOPEN_VERSION >= 3 + UNUSED(methods); + UNUSED(clientinfo); +#endif /* if DLZ_DLOPEN_VERSION >= 3 */ + + 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. + */ + (void)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 /* if DLZ_DLOPEN_VERSION == 1 */ +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 /* if DLZ_DLOPEN_VERSION == 1 */ +{ + 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 /* ifdef MULTIPLICITY */ + +#if DLZ_DLOPEN_VERSION >= 2 + UNUSED(methods); + UNUSED(clientinfo); +#endif /* if DLZ_DLOPEN_VERSION >= 2 */ + + 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)) { + (void)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); +} + +static const char * +#ifdef MULTIPLICITY +missing_perl_method(const char *perl_class_name, PerlInterpreter *my_perl) +#else /* ifdef MULTIPLICITY */ +missing_perl_method(const char *perl_class_name) +#endif /* ifdef MULTIPLICITY */ +{ + 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 *perlrun[] = { (char *)"", NULL, (char *)"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 /* ifdef MULTIPLICITY */ + + 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 /* ifndef MULTIPLICITY */ + + cd->perl = perl_alloc(); + if (cd->perl == NULL) { + free(cd); + return (ISC_R_FAILURE); + } +#ifdef MULTIPLICITY + my_perl = cd->perl; +#endif /* ifdef MULTIPLICITY */ + 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 /* ifdef MULTIPLICITY */ + if ((missing_method_name = missing_perl_method(perl_class_name))) +#endif /* ifdef MULTIPLICITY */ + { + 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)) { + (void)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 /* ifndef MULTIPLICITY */ + 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 /* ifdef MULTIPLICITY */ + + cd->log(ISC_LOG_INFO, "DLZ Perl: Unloading driver."); + +#ifndef MULTIPLICITY + if (!global_perl_dont_free) { +#endif /* ifndef MULTIPLICITY */ + 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 /* ifndef MULTIPLICITY */ + + free(cd->perl_source); + free(cd); +} |