From 45d6379135504814ab723b57f0eb8be23393a51d Mon Sep 17 00:00:00 2001 From: Daniel Baumann Date: Sat, 27 Apr 2024 09:24:22 +0200 Subject: Adding upstream version 1:9.16.44. Signed-off-by: Daniel Baumann --- contrib/dlz/modules/perl/Makefile | 63 ++ contrib/dlz/modules/perl/README | 38 ++ contrib/dlz/modules/perl/dlz_perl_callback.xs | 88 +++ .../modules/perl/dlz_perl_callback_clientinfo.xs | 94 +++ contrib/dlz/modules/perl/dlz_perl_driver.c | 715 +++++++++++++++++++++ contrib/dlz/modules/perl/dlz_perl_driver.h | 37 ++ .../dlz/modules/perl/testing/dlz_perl_example.pm | 185 ++++++ contrib/dlz/modules/perl/testing/named.conf | 26 + 8 files changed, 1246 insertions(+) create mode 100644 contrib/dlz/modules/perl/Makefile create mode 100644 contrib/dlz/modules/perl/README create mode 100644 contrib/dlz/modules/perl/dlz_perl_callback.xs create mode 100644 contrib/dlz/modules/perl/dlz_perl_callback_clientinfo.xs create mode 100644 contrib/dlz/modules/perl/dlz_perl_driver.c create mode 100644 contrib/dlz/modules/perl/dlz_perl_driver.h create mode 100644 contrib/dlz/modules/perl/testing/dlz_perl_example.pm create mode 100644 contrib/dlz/modules/perl/testing/named.conf (limited to 'contrib/dlz/modules/perl') diff --git a/contrib/dlz/modules/perl/Makefile b/contrib/dlz/modules/perl/Makefile new file mode 100644 index 0000000..ec99e00 --- /dev/null +++ b/contrib/dlz/modules/perl/Makefile @@ -0,0 +1,63 @@ +# Copyright 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 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. +# +# SPDX-License-Identifier: ISC and MPL-2.0 +# +# 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. + +# For building the dlz_perl_driver driver we don't use +# the bind9 build structure as the aim is to provide an +# perl_driver that is separable from the bind9 source tree + +CFLAGS += -fPIC -O2 -I../include +FLAGS_PERL ?= perl +LIBNAME = dlz_perl_driver.so + +all: $(LIBNAME) + +dlz_perl_driver.o: dlz_perl_driver.c + $(CC) $(CFLAGS) `${FLAGS_PERL} -MExtUtils::Embed -e ccopts` -c -o dlz_perl_driver.o dlz_perl_driver.c + + +dlz_perl_callback_clientinfo.c: dlz_perl_callback_clientinfo.xs + ${FLAGS_PERL} `${FLAGS_PERL} -MConfig -le 'print $$Config{privlibexp}'`/ExtUtils/xsubpp -prototypes -typemap `${FLAGS_PERL} -MConfig -le 'print $$Config{privlibexp}'`/ExtUtils/typemap dlz_perl_callback_clientinfo.xs > dlz_perl_callback_clientinfo.c + +dlz_perl_callback_clientinfo.o: dlz_perl_callback_clientinfo.c + $(CC) $(CFLAGS) `${FLAGS_PERL} -MExtUtils::Embed -e ccopts` -c -o dlz_perl_callback_clientinfo.o dlz_perl_callback_clientinfo.c + + +dlz_perl_callback.c: dlz_perl_callback.xs + ${FLAGS_PERL} `${FLAGS_PERL} -MConfig -le 'print $$Config{privlibexp}'`/ExtUtils/xsubpp -prototypes -typemap `${FLAGS_PERL} -MConfig -le 'print $$Config{privlibexp}'`/ExtUtils/typemap dlz_perl_callback.xs > dlz_perl_callback.c + +dlz_perl_callback.o: dlz_perl_callback.c + $(CC) $(CFLAGS) `${FLAGS_PERL} -MExtUtils::Embed -e ccopts` -c -o dlz_perl_callback.o dlz_perl_callback.c + + +$(LIBNAME): dlz_perl_driver.o dlz_perl_callback_clientinfo.o dlz_perl_callback.o + $(CC) $(LDFLAGS) -shared -o $(LIBNAME) dlz_perl_driver.o dlz_perl_callback_clientinfo.o dlz_perl_callback.o `${FLAGS_PERL} -MExtUtils::Embed -e ldopts` + +clean: + rm -f dlz_perl_driver.o dlz_perl_driver.so dlz_perl_callback_clientinfo.c dlz_perl_callback_clientinfo.o dlz_perl_callback.c dlz_perl_callback.o + +install: dlz_perl_driver.so + mkdir -p $(DESTDIR)$(libdir) + install dlz_perl_driver.so $(DESTDIR)$(libdir) diff --git a/contrib/dlz/modules/perl/README b/contrib/dlz/modules/perl/README new file mode 100644 index 0000000..324054a --- /dev/null +++ b/contrib/dlz/modules/perl/README @@ -0,0 +1,38 @@ + + + +BIND 9 DLZ Perl module (bind-dlz-tools) + +Written by John Eaglesham + +A dynamically loadable zone (DLZ) plugin embedding a Perl +interpreter in BIND, allowing Perl scripts to be written to +integrate with BIND and serve DNS data. + +More information/updates at http://bind-dlz-tools.sourceforge.net/ diff --git a/contrib/dlz/modules/perl/dlz_perl_callback.xs b/contrib/dlz/modules/perl/dlz_perl_callback.xs new file mode 100644 index 0000000..0b9f504 --- /dev/null +++ b/contrib/dlz/modules/perl/dlz_perl_callback.xs @@ -0,0 +1,88 @@ +/* + * 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 "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "dlz_perl_driver.h" + +#include + +/* And some XS code. */ +MODULE = DLZ_Perl PACKAGE = DLZ_Perl + +int +LOG_INFO() + CODE: + RETVAL = ISC_LOG_INFO; + OUTPUT: + RETVAL + +int +LOG_NOTICE() + CODE: + RETVAL = ISC_LOG_NOTICE; + OUTPUT: + RETVAL + +int +LOG_WARNING() + CODE: + RETVAL = ISC_LOG_WARNING; + OUTPUT: + RETVAL + +int +LOG_ERROR() + CODE: + RETVAL = ISC_LOG_ERROR; + OUTPUT: + RETVAL + +int +LOG_CRITICAL() + CODE: + RETVAL = ISC_LOG_CRITICAL; + OUTPUT: + RETVAL + + +void +log(opaque, level, msg) + IV opaque + int level + char *msg + + PREINIT: + log_t *log = (log_t *) opaque; + + CODE: + log( level, msg ); + diff --git a/contrib/dlz/modules/perl/dlz_perl_callback_clientinfo.xs b/contrib/dlz/modules/perl/dlz_perl_callback_clientinfo.xs new file mode 100644 index 0000000..22aec66 --- /dev/null +++ b/contrib/dlz/modules/perl/dlz_perl_callback_clientinfo.xs @@ -0,0 +1,94 @@ +/* + * 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. + */ + +#define ADDR_BUF_LEN INET6_ADDRSTRLEN + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "dlz_perl_driver.h" + +#include + +/* And some XS code. */ +MODULE = DLZ_Perl::clientinfo PACKAGE = DLZ_Perl::clientinfo + +PROTOTYPES: DISABLE + +void +sourceip(opaque) + SV *opaque + + PREINIT: + const char *ret; + char addr_buf[ADDR_BUF_LEN]; + int port; + isc_sockaddr_t *src; + dlz_perl_clientinfo_opaque *ci; + I32 wantarray = GIMME_V; + + PPCODE: + if (!SvTRUE(opaque) || !SvIOK(opaque)) XSRETURN_EMPTY; + + /* + * Safe, because Perl guarantees that an IV (the type we + * pass into DLZ functions who pass it here) is able to + * hold a pointer. + */ + ci = (dlz_perl_clientinfo_opaque *) SvIV(opaque); + if (wantarray == G_VOID || ci->methods == NULL || + ci->methods->version - ci->methods->age < + DNS_CLIENTINFOMETHODS_VERSION) + XSRETURN_EMPTY; + + ci->methods->sourceip(ci->clientinfo, &src); + + switch (src->type.sa.sa_family) { + case AF_INET: + port = ntohs(src->type.sin.sin_port); + ret = inet_ntop(AF_INET, + &src->type.sin.sin_addr, + addr_buf, ADDR_BUF_LEN); + break; + case AF_INET6: + port = ntohs(src->type.sin6.sin6_port); + ret = inet_ntop(AF_INET6, + &src->type.sin6.sin6_addr, + addr_buf, ADDR_BUF_LEN); + break; + default: + ret = NULL; + } + + if (ret == NULL) XSRETURN_EMPTY; + + XPUSHs(sv_2mortal(newSVpv(addr_buf, strlen(addr_buf)))); + if (wantarray == G_ARRAY) XPUSHs(sv_2mortal(newSViv(port))); + 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 +#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); +} diff --git a/contrib/dlz/modules/perl/dlz_perl_driver.h b/contrib/dlz/modules/perl/dlz_perl_driver.h new file mode 100644 index 0000000..2cfb24d --- /dev/null +++ b/contrib/dlz/modules/perl/dlz_perl_driver.h @@ -0,0 +1,37 @@ +/* + * 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 + +/* This is the only part that differs from dlz_minimal.h. */ +typedef struct dlz_perl_clientinfo_opaque { + dns_clientinfomethods_t *methods; + dns_clientinfo_t *clientinfo; +} dlz_perl_clientinfo_opaque; diff --git a/contrib/dlz/modules/perl/testing/dlz_perl_example.pm b/contrib/dlz/modules/perl/testing/dlz_perl_example.pm new file mode 100644 index 0000000..eafa87c --- /dev/null +++ b/contrib/dlz/modules/perl/testing/dlz_perl_example.pm @@ -0,0 +1,185 @@ +# Copyright 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 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. +# +# SPDX-License-Identifier: ISC and MPL-2.0 +# +# 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. +package dlz_perl_example; + +use warnings; +use strict; + +use Data::Dumper; +$Data::Dumper::Sortkeys = 1; + +# Constructor. Everything after the class name can be folded into a hash of +# various options and settings. Right now only log_context and argv are +# available. +sub new { + my ( $class, %config ) = @_; + my $self = {}; + bless $self, $class; + + $self->{log} = sub { + my ( $level, $msg ) = @_; + DLZ_Perl::log( $config{log_context}, $level, $msg ); + }; + + if ( $config{argv} ) { warn "Got argv: $config{argv}\n"; } + + $self->{zones} = { + 'example.com' => { + '@' => [ + { + type => 'SOA', + ttl => 86400, + data => + 'ns1.example.com. hostmaster.example.com. 12345 172800 900 1209600 3600', + } + ], + perlrr => [ + { + type => 'A', + ttl => 444, + data => '1.1.1.1', + }, + { + type => 'A', + ttl => 444, + data => '1.1.1.2', + } + ], + perltime => [ + { + code => sub { + return ['TXT', '1', time()]; + }, + }, + ], + sourceip => [ + { + code => sub { + my ( $opaque ) = @_; + # Passing anything other than the proper opaque value, + # 0, or undef to this function will cause a crash (at + # best!). + my ( $addr, $port ) = + DLZ_Perl::clientinfo::sourceip( $opaque ); + if ( !$addr ) { $addr = $port = 'unknown'; } + return ['TXT', '1', $addr], ['TXT', '1', $port]; + }, + }, + ], + }, + }; + + $self->{log}->( + DLZ_Perl::LOG_INFO(), + 'DLZ Perl Script: Called init. Loaded zone data: ' + . Dumper( $self->{zones} ) + ); + return $self; +} + +# Do we have data for this zone? Expects a simple true or false return value. +sub findzone { + my ( $self, $zone ) = @_; + $self->{log}->( + DLZ_Perl::LOG_INFO(), + "DLZ Perl Script: Called findzone, looking for zone $zone" + ); + + return exists $self->{zones}->{$zone}; +} + +# Return the data for a given record in a given zone. The final parameter is +# an opaque value that can be passed to DLZ_Perl::clientinfo::sourceip to +# retrieve the client source IP and port. Expected return value is an array +# of array refs, with each array ref representing one record and containing +# the type, ttl, and data in that order. Data is as it appears in a zone file. +sub lookup { + my ( $self, $name, $zone, $client_info ) = @_; + $self->{log}->( + DLZ_Perl::LOG_INFO(), + "DLZ Perl Script: Called lookup, looking for record $name in zone $zone" + ); + return unless $self->{zones}->{$zone}->{$name}; + + my @results; + foreach my $rr ( @{ $self->{zones}->{$zone}->{$name} } ) { + if ( $rr->{'code'} ) { + my @r = $rr->{'code'}->( $client_info ); + if ( @r ) { + push @results, @r; + } + } else { + push @results, [$rr->{'type'}, $rr->{'ttl'}, $rr->{'data'}]; + } + } + + return @results; +} + +# Will we allow zone transfer for this client? Expects a simple true or false +# return value. +sub allowzonexfr { + my ( $self, $zone, $client ) = @_; + $self->{log}->( + DLZ_Perl::LOG_INFO(), + "DLZ Perl Script: Called allowzonexfr, looking for zone $zone for " . + "client $client" + ); + if ( $client eq '127.0.0.1' ) { return 1; } + return 0; +} + +# Note the return AoA for this method differs from lookup in that it must +# return the name of the record as well as the other data. +sub allnodes { + my ( $self, $zone ) = @_; + my @results; + $self->{log}->( + DLZ_Perl::LOG_INFO(), + "DLZ Perl Script: Called allnodes, looking for zone $zone" + ); + + foreach my $name ( keys %{ $self->{zones}->{$zone} } ) { + foreach my $rr ( @{ $self->{zones}->{$zone}->{$name} } ) { + if ( $rr->{'code'} ) { + my @r = $rr->{'code'}->(); + # The code returns an array of array refs without the name. + # This makes things easy for lookup but hard here. We must + # iterate over each array ref and inject the name into it. + foreach my $a ( @r ) { + unshift @{$a}, $name; + } + push @results, @r; + } else { + push @results, + [$name, $rr->{'type'}, $rr->{'ttl'}, $rr->{'data'}]; + } + } + } + return @results; +} + +1; diff --git a/contrib/dlz/modules/perl/testing/named.conf b/contrib/dlz/modules/perl/testing/named.conf new file mode 100644 index 0000000..293d655 --- /dev/null +++ b/contrib/dlz/modules/perl/testing/named.conf @@ -0,0 +1,26 @@ +/* + * Copyright (C) Internet Systems Consortium, Inc. ("ISC") + * + * SPDX-License-Identifier: MPL-2.0 + * + * 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/. + * + * See the COPYRIGHT file distributed with this work for additional + * information regarding copyright ownership. + */ + +options { + port 5300; + pid-file "named.pid"; + session-keyfile "session.key"; + listen-on { 127.0.0.1; }; + listen-on-v6 { none; }; + recursion no; + notify no; +}; + +dlz "perl zone" { + database "dlopen ../dlz_perl_driver.so dlz_perl_example.pm dlz_perl_example"; +}; -- cgit v1.2.3