API REST pour le conteneur DNS

This commit is contained in:
Marc van der Wal 2023-10-25 15:50:22 +02:00
parent 5e965712bd
commit 31f08bb329
17 changed files with 569 additions and 0 deletions

View File

@ -11,10 +11,60 @@ RUN apk add \
s6-overlay \
vim
# Dependencies for REST API
RUN apk add \
gcc \
libc-dev \
make \
perl-app-cpanminus \
perl-clone \
perl-config-any \
perl-data-optlist \
perl-dev \
perl-exporter-tiny \
perl-extutils-config \
perl-extutils-helpers \
perl-extutils-installpaths \
perl-file-sharedir \
perl-file-sharedir-install \
perl-file-slurp \
perl-file-which \
perl-hash-merge-simple \
perl-hash-multivalue \
perl-http-date \
perl-http-headers-fast \
perl-import-into \
perl-json-maybexs \
perl-module-build \
perl-module-build-tiny \
perl-module-implementation \
perl-module-runtime \
perl-moo \
perl-params-util \
perl-params-validate \
perl-path-tiny \
perl-plack \
perl-readonly \
perl-ref-util \
perl-role-tiny \
perl-safe-isa \
perl-sub-exporter \
perl-sub-install \
perl-sub-quote \
perl-template-toolkit \
perl-type-tiny \
perl-yaml
RUN cpanm -n -v \
Dancer2 \
Module::Pluggable::Object
RUN install -o named -g root -m 0755 -d /var/db/bind
COPY --chown=named:root etc/bind/named.conf /etc/bind/named.conf
COPY --chown=named:root zones /etc/bind/zones
COPY web-api /src/api
COPY etc/s6-overlay /etc/s6-overlay
ENTRYPOINT ["/init"]

View File

@ -0,0 +1,2 @@
#!/bin/execlineb -P
/usr/bin/env perl /src/api/bin/app.psgi

View File

@ -0,0 +1 @@
longrun

0
dns/web-api/.dancer Normal file
View File

24
dns/web-api/MANIFEST Normal file
View File

@ -0,0 +1,24 @@
MANIFEST
MANIFEST.SKIP
.dancer
Makefile.PL
config.yml
cpanfile
views/index.tt
views/layouts/main.tt
lib/Email/SpoofingDemo/API/DNS.pm
t/002_index_route.t
t/001_base.t
environments/production.yml
environments/development.yml
bin/app.psgi
public/500.html
public/dispatch.cgi
public/dispatch.fcgi
public/favicon.ico
public/404.html
public/javascripts/jquery.js
public/css/error.css
public/css/style.css
public/images/perldancer-bg.jpg
public/images/perldancer.jpg

17
dns/web-api/MANIFEST.SKIP Normal file
View File

@ -0,0 +1,17 @@
^\.git\/
maint
^tags$
.last_cover_stats
Makefile$
^blib
^pm_to_blib
^.*.bak
^.*.old
^t.*sessions
^cover_db
^.*\.log
^.*\.swp$
MYMETA.*
^.gitignore
^.svn\/
^Email-SpoofingDemo-API-DNS-

26
dns/web-api/Makefile.PL Normal file
View File

@ -0,0 +1,26 @@
use strict;
use warnings;
use ExtUtils::MakeMaker;
# Normalize version strings like 6.30_02 to 6.3002,
# so that we can do numerical comparisons on it.
my $eumm_version = $ExtUtils::MakeMaker::VERSION;
$eumm_version =~ s/_//;
WriteMakefile(
NAME => 'Email::SpoofingDemo::API::DNS',
AUTHOR => q{Marc van der Wal <marc.vanderwal@afnic.fr>},
VERSION_FROM => 'lib/Email/SpoofingDemo/API/DNS.pm',
ABSTRACT => 'Email spoofing demo: REST API for DNS',
($eumm_version >= 6.3001
? ('LICENSE'=> 'all-rights-reserved')
: ()),
PL_FILES => {},
PREREQ_PM => {
'Test::More' => 0,
'YAML' => 0,
'Dancer2' => 0.300000,
},
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
clean => { FILES => 'Email-SpoofingDemo-API-DNS-*' },
);

9
dns/web-api/bin/app.psgi Normal file
View File

@ -0,0 +1,9 @@
#!/usr/bin/perl
use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../lib";
use Email::SpoofingDemo::API::DNS;
Email::SpoofingDemo::API::DNS->to_app;

13
dns/web-api/config.yml Normal file
View File

@ -0,0 +1,13 @@
appname: "Email::SpoofingDemo::API::DNS"
charset: "UTF-8"
serializer: JSON
# App-specific configuration
# Directory in where zone files reside
zone_directory: "/etc/bind/zones"
# List of dynamic zones, requiring special treatment
dynamic_zones:
- "expediteur.example"

11
dns/web-api/cpanfile Normal file
View File

@ -0,0 +1,11 @@
requires "Dancer2" => "0.300000";
recommends "YAML" => "0";
recommends "URL::Encode::XS" => "0";
recommends "CGI::Deurl::XS" => "0";
recommends "HTTP::Parser::XS" => "0";
on "test" => sub {
requires "Test::More" => "0";
requires "HTTP::Request::Common" => "0";
};

View File

@ -0,0 +1,15 @@
# configuration file for development environment
logger: "console"
log: "core"
# should Dancer2 consider warnings as critical errors?
warnings: 1
# should Dancer2 show a stacktrace when an 5xx error is caught?
# if set to yes, public/500.html will be ignored and either
# views/500.tt, 'error_template' template, or a default error template will be used.
show_errors: 1
# print the banner
startup_info: 1

View File

@ -0,0 +1,16 @@
# configuration file for production environment
# only log warning and error messsages
log: "warning"
# log message to a file in logs/
logger: "file"
# don't consider warnings critical
warnings: 0
# hide errors
show_errors: 0
# disable server tokens in production environments
no_server_tokens: 1

View File

@ -0,0 +1,112 @@
package Email::SpoofingDemo::API::DNS;
use Dancer2;
use Email::SpoofingDemo::DNS::ZoneFile
qw(get_txt get_zone_file import_zone_file remove_txt set_txt
zone_file_path);
our $VERSION = '0.1';
my $base_dir = config->{'zone_directory'};
my $dynamic_zones = config->{'dynamic_zones'};
get '/' => sub { return "Welcome"; };
prefix '/zone/:zone' => sub {
get '/file' => sub {
my $zone = route_parameters->get('zone');
if (zone_file_path($zone, $base_dir)) {
my $contents = get_zone_file($zone, $base_dir, $dynamic_zones);
return { contents => $contents };
}
else {
status 'not_found';
return "$zone: not found";
}
};
put '/file' => sub {
my $zone = route_parameters->get('zone');
my $contents = body_parameters->get("contents");
if (not defined $contents) {
status 'bad_request';
return "missing zone file contents";
}
my $result = import_zone_file($zone, $base_dir, $contents, $dynamic_zones);
if ($result) {
return;
}
else {
status 'bad_request';
return "bad zone file";
}
};
get '/spf' => sub {
my $zone = route_parameters->get('zone');
my @spfs = get_txt($zone, "", qr/v=spf1(\s+|\Z)/i, 1);
my %result;
for my $rec (@spfs) {
$result{$rec->{owner}} = $rec->{txt};
}
return \%result;
};
put '/spf' => sub {
my $zone = route_parameters->get('zone');
my $spf = body_parameters->get('spf');
status (set_txt($zone, "", $spf) ? 'ok' : 'forbidden');
};
del '/spf' => sub {
my $zone = route_parameters->get('zone');
status (remove_txt($zone, "") ? 'ok' : 'not_found');
};
get '/domainkey' => sub {
my $zone = route_parameters->get('zone');
my @dkims = get_txt($zone, "", qr/^v=DKIM1/, 1);
my %domainkeys;
for my $rec (@dkims) {
if ($rec->{owner} =~ /^(.+)\._domainkey\.(.*)$/i) {
my $selector = $1;
my $subzone = $2;
$domainkeys{$subzone}{$selector} = $rec->{txt};
}
}
return \%domainkeys;
};
get '/dmarc' => sub {
my $zone = route_parameters->get('zone');
my @dmarcs = get_txt($zone, "", qr/^v=DMARC1/, 1);
my %result;
for my $rec (@dmarcs) {
if ($rec->{owner} =~ /^_dmarc\.(.*)$/) {
my $domain = $1;
$result{$domain} = $rec->{txt};
}
}
return \%result;
};
};
any qr{.*} => sub { status 'not_found'; return "Invalid route" };
dance;
true;

View File

@ -0,0 +1,239 @@
package Email::SpoofingDemo::DNS::ZoneFile;
use strict;
use warnings;
use utf8;
use v5.10;
use Exporter qw(import);
use File::Slurp;
use Try::Tiny;
our @EXPORT_OK = qw(get_txt get_zone_file import_zone_file remove_txt set_txt
zone_file_path);
sub safe_system {
my @argv = @_;
my $retval = system @argv;
die $! if ($retval == -1);
if ($retval != 0) {
my $status = $retval >> 8;
die join(" ", @argv) . " exited with status $status\n";
};
return 1;
}
sub is_dynamic_zone {
my ($zone, $dynamic_zones) = @_;
return grep { $_ eq $zone } @$dynamic_zones;
}
sub rndc_freeze {
my ($zone) = @_;
safe_system('rndc', 'freeze', $zone);
}
sub rndc_thaw {
my ($zone) = @_;
safe_system('rndc', 'thaw', $zone);
}
sub rndc_reload {
my ($zone) = @_;
safe_system('rndc', 'reload', $zone);
}
sub encode_txt {
my ($text) = @_;
my $chunk_length = 255;
my $text_bytes = $text;
utf8::encode($text_bytes);
my @parts;
for (my $i = 0; $i < length($text_bytes); $i += $chunk_length) {
my $part = substr($text_bytes, $i, 255);
$part =~ s/[\x00-\x1f"\x7f-\xff]/sprintf('\\%03d', ord($0))/eg;
push @parts, qq{"$part"};
}
return join(" ", @parts);
}
sub relative_to_absolute {
my ($zone, $relative_owner) = @_;
if ($relative_owner eq '') {
return $zone;
}
else {
return "$relative_owner.$zone";
}
}
sub nsupdate {
my ($zone, @instructions) = @_;
open(my $pipe, '|-', 'nsupdate') or die "Cant fork: $!";
say $pipe qq{zone $zone};
say $pipe $_ foreach (@instructions);
close($pipe);
return (($? >> 8) == 0);
}
sub get_txt {
my ($zone, $relative_owner, $filter, $sublabels_ok) = @_;
$filter //= qr{.*};
$sublabels_ok //= 0;
my @dig_opts = qw(+nottlid +noclass +norecurse +noall +answer @127.0.0.1);
my $owner_suffix = relative_to_absolute($zone, $relative_owner);
my $qname = ($sublabels_ok ? $zone : $owner_suffix);
my $qtype = ($sublabels_ok ? 'AXFR' : 'TXT');
my $owner_match_re = ($sublabels_ok ? qr/^([^.]+\.)*$owner_suffix\.$/i : qr/^$qname\.$/i);
my @result;
open(my $pipe, '-|', 'dig', @dig_opts, $qtype, $qname) or die "Cant fork: $!";
while (<$pipe>) {
chomp;
next if /^;/;
next if /^\s*$/;
my ($owner, $type, $data) = split(" ", $_, 3);
unless ($type eq 'TXT') {
next;
}
unless ($owner =~ $owner_match_re) {
next;
}
my $concat_data = ($data =~ s/"((?:[^\\"]|\\"|\\\d{3})*)"\s*/$1/gr);
unless ($concat_data =~ $filter) {
next;
}
push @result, { owner => ($owner =~ s/\.$//r), txt => $concat_data };
}
close($pipe);
if (wantarray) {
return @result;
}
else {
return $result[0];
}
}
sub set_txt {
my ($zone, $relative_owner, $txt) = @_;
my $owner = relative_to_absolute($zone, $relative_owner);
my $txt_encoded = encode_txt($txt);
nsupdate(
$zone,
"update delete $owner 0 IN TXT",
"update add $owner IN TXT $txt_encoded",
"send");
}
sub remove_txt {
my ($zone, $relative_owner) = @_;
my $owner = relative_to_absolute($zone, $relative_owner);
nsupdate(
$zone,
"update delete $owner 0 IN TXT",
"send");
}
sub check_zone {
my ($zone_contents, $origin) = @_;
open(my $pipe, '|-', 'named-checkzone', $origin, '-') or die "Cant fork: $!";
print $pipe $zone_contents;
close($pipe);
return (($? >> 8) == 0);
}
sub zone_file_path {
my ($zone, $base_dir, $force) = @_;
my @components = reverse(split(/\./, $zone));
my $path = $base_dir . '/' . (join('/', @components)) . ".zone";
if (not -f $path and not $force) {
return undef;
}
return $path;
}
sub get_zone_file {
my ($zone, $base_dir, $dynamic_zones) = @_;
my $path = zone_file_path($zone, $base_dir);
return undef if not defined $path;
rndc_freeze($zone) if is_dynamic_zone($zone, $dynamic_zones);
my $contents;
try {
$contents = read_file($path);
}
finally {
rndc_thaw($zone) if is_dynamic_zone($zone, $dynamic_zones);
};
return $contents;
}
sub import_zone_file {
my ($zone, $base_dir, $contents, $dynamic_zones) = @_;
if ($contents =~ /^\s*$/) {
warn "Zone to import is empty";
return undef;
}
my $path = zone_file_path($zone, $base_dir);
if (not defined $path) {
warn "No zone file for $zone in $base_dir";
return undef;
}
if (not check_zone($contents, $zone)) {
warn "Zone file contents do not pass syntax check";
return undef;
}
rndc_freeze($zone) if is_dynamic_zone($zone, $dynamic_zones);
try {
write_file($path, $contents);
rndc_reload($zone) unless is_dynamic_zone($zone, $dynamic_zones);
}
catch {
die $_;
}
finally {
rndc_thaw($zone) if is_dynamic_zone($zone, $dynamic_zones);
};
return 1;
}
1;

View File

@ -0,0 +1,16 @@
#!/usr/bin/env perl
BEGIN { $ENV{DANCER_APPHANDLER} = 'PSGI';}
use Dancer2;
use FindBin '$RealBin';
use Plack::Runner;
# For some reason Apache SetEnv directives don't propagate
# correctly to the dispatchers, so forcing PSGI and env here
# is safer.
set apphandler => 'PSGI';
set environment => 'production';
my $psgi = path($RealBin, '..', 'bin', 'app.psgi');
die "Unable to read startup script: $psgi" unless -r $psgi;
Plack::Runner->run($psgi);

View File

@ -0,0 +1,18 @@
#!/usr/bin/env perl
BEGIN { $ENV{DANCER_APPHANDLER} = 'PSGI';}
use Dancer2;
use FindBin '$RealBin';
use Plack::Handler::FCGI;
# For some reason Apache SetEnv directives don't propagate
# correctly to the dispatchers, so forcing PSGI and env here
# is safer.
set apphandler => 'PSGI';
set environment => 'production';
my $psgi = path($RealBin, '..', 'bin', 'app.psgi');
my $app = do($psgi);
die "Unable to read startup script: $@" if $@;
my $server = Plack::Handler::FCGI->new(nproc => 5, detach => 1);
$server->run($app);