/* $NetBSD: dlz_perl_driver.c,v 1.4.2.1 2023/08/11 13:43:31 martin Exp $ */ /* * 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 #include #include #include #include #include #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); }