simplification du code, gestion plus claire des erreurs
Le code a été simplifié de plusieurs manières :
du code plus générique, dans la gestion des utilisateurs et des
routes, mais aussi côté gestion des zones et serveurs de zones
ajout de commandes en cli pour gérer les zones et utilisateurs, et
faire des tests du code plus simplement qu'en passant par
l'interface web
Le projet est passé à Dancer2.
Le dépôt est désormais moins éparpillé également, ce qui est visible est
directement le projet Dancer.
Le code concernant l'init reste pas top, idem pour la gestion de
dépendances (un simple script), il faudrait utiliser les outils du cpan.
This commit is contained in:
parent
5f627aa47c
commit
527313614c
2
.gitignore
vendored
2
.gitignore
vendored
@ -1,2 +1,4 @@
|
||||
*.swp
|
||||
sessions
|
||||
init/bind9.cfg.tar.gz
|
||||
init/varnamed.tar.gz
|
||||
|
||||
@ -1,19 +1,23 @@
|
||||
MANIFEST
|
||||
bin/app.pl
|
||||
cpanfile
|
||||
Makefile.PL
|
||||
config.yml
|
||||
MANIFEST.SKIP
|
||||
environments/development.yml
|
||||
environments/production.yml
|
||||
views/index.tt
|
||||
views/layouts/main.tt
|
||||
MANIFEST.SKIP
|
||||
lib/DNSManager.pm
|
||||
public/css/style.css
|
||||
public/css/error.css
|
||||
t/001_base.t
|
||||
t/002_index_route.t
|
||||
public/500.html
|
||||
public/favicon.ico
|
||||
public/dispatch.cgi
|
||||
public/404.html
|
||||
public/dispatch.fcgi
|
||||
public/js/jquery.min.js
|
||||
public/dispatch.cgi
|
||||
public/500.html
|
||||
t/002_index_route.t
|
||||
t/001_base.t
|
||||
Makefile.PL
|
||||
public/images/perldancer-bg.jpg
|
||||
public/images/perldancer.jpg
|
||||
public/javascripts/jquery.js
|
||||
public/css/error.css
|
||||
public/css/style.css
|
||||
bin/app.psgi
|
||||
views/index.tt
|
||||
views/layouts/main.tt
|
||||
lib/MyWeb/App.pm
|
||||
@ -11,3 +11,7 @@ Makefile$
|
||||
^cover_db
|
||||
^.*\.log
|
||||
^.*\.swp$
|
||||
MYMETA.*
|
||||
^.gitignore
|
||||
^.svn\/
|
||||
^MyWeb-App-
|
||||
@ -2,20 +2,25 @@ 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 => 'DNSManager',
|
||||
NAME => 'MyWeb::App',
|
||||
AUTHOR => q{YOUR NAME <youremail@example.com>},
|
||||
VERSION_FROM => 'lib/DNSManager.pm',
|
||||
VERSION_FROM => 'lib/MyWeb/App.pm',
|
||||
ABSTRACT => 'YOUR APPLICATION ABSTRACT',
|
||||
($ExtUtils::MakeMaker::VERSION >= 6.3002
|
||||
($eumm_version >= 6.3001
|
||||
? ('LICENSE'=> 'perl')
|
||||
: ()),
|
||||
PL_FILES => {},
|
||||
PREREQ_PM => {
|
||||
'Test::More' => 0,
|
||||
'YAML' => 0,
|
||||
'Dancer' => 1.311,
|
||||
'Dancer2' => 0.161000,
|
||||
},
|
||||
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
|
||||
clean => { FILES => 'DNSManager-*' },
|
||||
clean => { FILES => 'MyWeb-App-*' },
|
||||
);
|
||||
271
app/app.pm
271
app/app.pm
@ -1,271 +0,0 @@
|
||||
#!/usr/bin/env perl
|
||||
|
||||
use v5.14;
|
||||
use DBI;
|
||||
|
||||
use lib '../';
|
||||
use app::zone::interface;
|
||||
use app::zone::edit;
|
||||
use app::zone::rndc_interface;
|
||||
use app::bdd::management;
|
||||
use app::bdd::admin;
|
||||
use app::bdd::lambda;
|
||||
|
||||
package app;
|
||||
use Moose;
|
||||
|
||||
has dbh => ( is => 'rw', builder => '_void');
|
||||
has dnsi => ( is => 'rw', builder => '_void');
|
||||
has dnsisec => ( is => 'rw', builder => '_void');
|
||||
has um => ( is => 'rw', builder => '_void');
|
||||
has [ qw/zdir dbname dbhost dbport dbuser dbpass sgbd dnsapp dnsappsec sshhost sshhostsec sshuser sshusersec sshport sshportsec nsmasterv4 nsmasterv6 nsslavev4 nsslavev6 dnsslavekey/ ] => qw/is ro required 1/;
|
||||
sub _void { my $x = ''; \$x; }
|
||||
|
||||
### users
|
||||
|
||||
sub init {
|
||||
my ($self) = @_;
|
||||
|
||||
my $success;
|
||||
|
||||
my $dsn = 'dbi:' . $self->sgbd
|
||||
. ':database=' . $self->dbname
|
||||
. ';host=' . $self->dbhost
|
||||
. ';port=' . $self->dbport;
|
||||
|
||||
${$self->dbh} = DBI->connect($dsn
|
||||
, $self->dbuser
|
||||
, $self->dbpass)
|
||||
|| die "Could not connect to database: $DBI::errstr";
|
||||
|
||||
($success, ${$self->dnsi}) = app::zone::interface ->new()
|
||||
->get_interface($self->dnsapp, $self);
|
||||
|
||||
die("zone interface") unless $success;
|
||||
|
||||
($success, ${$self->dnsisec}) = app::zone::interface ->new()
|
||||
->get_interface($self->dnsappsec, $self);
|
||||
|
||||
die("zone interface (secondary ns)") unless $success;
|
||||
|
||||
${$self->um} = app::bdd::management->new(dbh => ${$self->dbh});
|
||||
}
|
||||
|
||||
sub auth {
|
||||
my ($self, $login, $passwd) = @_;
|
||||
${$self->um}->auth($login, $passwd);
|
||||
}
|
||||
|
||||
sub register_user {
|
||||
my ($self, $login, $passwd) = @_;
|
||||
${$self->um}->register_user($login, $passwd);
|
||||
}
|
||||
|
||||
sub set_admin {
|
||||
my ($self, $login, $val) = @_;
|
||||
${$self->um}->set_admin($login, $val);
|
||||
}
|
||||
|
||||
sub update_passwd {
|
||||
my ($self, $login, $new) = @_;
|
||||
my ($success, $user, $isadmin) = ${$self->um}->get_user($login);
|
||||
$user->passwd($new);
|
||||
}
|
||||
|
||||
sub delete_user {
|
||||
my ($self, $login) = @_;
|
||||
my ($success, @domains) = $self->get_domains($login);
|
||||
|
||||
if($success) {
|
||||
$self->delete_domain($login, $_) foreach(@domains);
|
||||
${$self->um}->delete_user($login);
|
||||
}
|
||||
}
|
||||
|
||||
### domains
|
||||
|
||||
sub _get_zone_edit {
|
||||
my ($self, $domain) = @_;
|
||||
|
||||
return app::zone::edit->new(
|
||||
zname => $domain
|
||||
, data => $self );
|
||||
}
|
||||
|
||||
# return yes or no
|
||||
sub add_domain {
|
||||
my ($self, $login, $domain) = @_;
|
||||
my ($success, $user, $isadmin) = ${$self->um}->get_user($login);
|
||||
|
||||
unless($success) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
unless ($user->add_domain($domain)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $ze = $self->_get_zone_edit($domain);
|
||||
$ze->addzone();
|
||||
}
|
||||
|
||||
sub delete_domain {
|
||||
my ($self, $login, $domain) = @_;
|
||||
|
||||
my ($success, $user, $isadmin) = ${$self->um}->get_user($login);
|
||||
|
||||
return 0 unless $success;
|
||||
return 0 unless $user->delete_domain($domain);
|
||||
|
||||
my $ze = $self->_get_zone_edit($domain);
|
||||
$ze->del();
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
sub update_domain_raw {
|
||||
my ($self, $zone, $domain) = @_;
|
||||
|
||||
my $ze = $self->_get_zone_edit($domain);
|
||||
$ze->update_raw($zone);
|
||||
}
|
||||
|
||||
sub update_domain {
|
||||
my ($self, $zone, $domain) = @_;
|
||||
my $ze = $self->_get_zone_edit($domain);
|
||||
$ze->update($zone);
|
||||
}
|
||||
|
||||
sub get_domain {
|
||||
my ($self, $domain) = @_;
|
||||
my $ze = $self->_get_zone_edit($domain);
|
||||
$ze->get();
|
||||
}
|
||||
|
||||
sub get_domains {
|
||||
my ($self, $login) = @_;
|
||||
${$self->um}->get_domains($login);
|
||||
}
|
||||
|
||||
sub get_all_domains {
|
||||
my ($self) = @_;
|
||||
# % domain login
|
||||
${$self->um}->get_all_domains;
|
||||
}
|
||||
|
||||
sub get_all_users {
|
||||
my ($self) = @_;
|
||||
# % login admin
|
||||
${$self->um}->get_all_users;
|
||||
}
|
||||
|
||||
sub new_tmp {
|
||||
my ($self, $domain) = @_;
|
||||
my $ze = $self->_get_zone_edit($domain);
|
||||
$ze->new_tmp();
|
||||
}
|
||||
|
||||
sub _mod_entry {
|
||||
my ($self, $domain, $entryToDelete, $action, $newEntry) = @_;
|
||||
|
||||
my $name = $entryToDelete->{'name'};
|
||||
my $type = $entryToDelete->{'type'};
|
||||
my $ttl = $entryToDelete->{'ttl'};
|
||||
my $host = $entryToDelete->{'host'};
|
||||
my $priority = $entryToDelete->{'priority'};
|
||||
|
||||
my $new_name = $newEntry->{'newname'};
|
||||
my $new_type = $newEntry->{'newtype'};
|
||||
my $new_ttl = $newEntry->{'newttl'};
|
||||
my $new_host = $newEntry->{'newhost'};
|
||||
my $new_priority = $newEntry->{'newpriority'};
|
||||
|
||||
# say "in _mod_entry : $action";
|
||||
# say "in _mod_entry : $new_name";
|
||||
my $zone = $self->get_domain($domain);
|
||||
my $dump = $zone->dump;
|
||||
|
||||
my $record;
|
||||
my $found = 0;
|
||||
|
||||
given( lc $type )
|
||||
{
|
||||
when ('a')
|
||||
{
|
||||
$record = $zone->a;
|
||||
$found = 1;
|
||||
}
|
||||
when ('aaaa')
|
||||
{
|
||||
$record = $zone->aaaa;
|
||||
$found = 1;
|
||||
}
|
||||
when ('cname')
|
||||
{
|
||||
$record = $zone->cname;
|
||||
$found = 1;
|
||||
}
|
||||
when ('ns')
|
||||
{
|
||||
$record = $zone->ns;
|
||||
$found = 1;
|
||||
}
|
||||
when ('mx')
|
||||
{
|
||||
$record = $zone->mx;
|
||||
$found = 1;
|
||||
}
|
||||
when ('ptr')
|
||||
{
|
||||
$record = $zone->ptr;
|
||||
$found = 1;
|
||||
}
|
||||
}
|
||||
|
||||
if( $found )
|
||||
{
|
||||
|
||||
foreach my $i ( 0 .. scalar @{$record}-1 )
|
||||
{
|
||||
|
||||
if( $action eq 'del' )
|
||||
{
|
||||
delete $record->[$i]
|
||||
if( $record->[$i]->{'name'} eq $name &&
|
||||
$record->[$i]->{'host'} eq $host &&
|
||||
$record->[$i]->{'ttl'} == $ttl );
|
||||
}
|
||||
if ( $action eq 'mod' )
|
||||
{
|
||||
if( $record->[$i]->{'name'} eq $name &&
|
||||
$record->[$i]->{'host'} eq $host &&
|
||||
$record->[$i]->{'ttl'} == $ttl )
|
||||
{
|
||||
$record->[$i]->{'name'} = $new_name;
|
||||
$record->[$i]->{'host'} = $new_host;
|
||||
$record->[$i]->{'ttl'} = $new_ttl;
|
||||
if( defined $new_priority )
|
||||
{
|
||||
$record->[$i]->{'priority'} = $new_priority
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
$self->update_domain( $zone, $domain );
|
||||
}
|
||||
|
||||
sub delete_entry {
|
||||
my ($self, $domain, $entryToDelete) = @_;
|
||||
$self->_mod_entry( $domain, $entryToDelete, 'del' );
|
||||
}
|
||||
|
||||
sub modify_entry {
|
||||
my ($self, $domain, $entryToDelete, $newEntry) = @_;
|
||||
$self->_mod_entry( $domain, $entryToDelete, 'mod', $newEntry );
|
||||
}
|
||||
|
||||
1;
|
||||
@ -1,33 +0,0 @@
|
||||
package app::bdd::admin;
|
||||
use Moose;
|
||||
extends 'app::bdd::lambda';
|
||||
|
||||
# ($success) activate_zone($domain)
|
||||
sub activate_zone {
|
||||
my ($self, $domain) = @_;
|
||||
}
|
||||
|
||||
# ($success) delete_zone($file_path)
|
||||
sub delete_zone {
|
||||
my ($self, $domain) = @_;
|
||||
}
|
||||
|
||||
# $success delete_domain
|
||||
sub delete_domain {
|
||||
my ($self, $domain) = @_;
|
||||
my $sth;
|
||||
|
||||
$sth = $self->dbh->prepare('delete from domain where domain=?');
|
||||
unless ( $sth->execute($domain) ) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
# delete the domain from our domains
|
||||
@{ $self->domains } = grep { $_ ne $domain } @{ $self->domains };
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
@ -1,78 +0,0 @@
|
||||
use autodie;
|
||||
use v5.14;
|
||||
use DBI;
|
||||
|
||||
use Data::Dump "dump";
|
||||
|
||||
use lib '../../';
|
||||
package app::bdd::lambda;
|
||||
use Moose;
|
||||
|
||||
has qw/domains is rw/;
|
||||
has [ qw/login dbh/ ] => qw/is ro required 1/;
|
||||
has passwd => (is => 'rw', trigger => \&_update_passwd );
|
||||
#has qw/dbh is ro required 1/; # database handler
|
||||
|
||||
# $success delete_domain
|
||||
sub delete_domain {
|
||||
my ($self, $domain) = @_;
|
||||
my $sth;
|
||||
|
||||
# check if we are the owner then delete
|
||||
return 0 if (grep { $domain eq $_ } @{ $self->domains }) == 0;
|
||||
|
||||
$sth = $self->dbh->prepare('delete from domain where domain=?');
|
||||
unless ( $sth->execute($domain) ) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
# delete the domain from our domains
|
||||
@{ $self->domains } = grep { $_ ne $domain } @{ $self->domains };
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
# $success add_domain
|
||||
sub add_domain {
|
||||
my ($self, $domain) = @_;
|
||||
my ($sth);
|
||||
|
||||
$sth = $self->dbh->prepare('select domain from domain where domain=?');
|
||||
unless ( $sth->execute($domain) ) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
|
||||
# if the domain already exists
|
||||
if (my $ref = $sth->fetchrow_arrayref) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
|
||||
$sth = $self->dbh->prepare('insert into domain VALUES(?,?,?)');
|
||||
unless ( $sth->execute($domain, $self->login, 0) ) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
push @{ $self->domains }, $domain;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _update_passwd {
|
||||
my ($self, $new) = @_;
|
||||
my $sth;
|
||||
|
||||
$sth = $self->dbh->prepare('update user set passwd=? where login=?');
|
||||
unless ( $sth->execute($new, $self->login) ) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
$sth->finish();
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
@ -1,194 +0,0 @@
|
||||
use Modern::Perl;
|
||||
use autodie;
|
||||
use v5.14;
|
||||
use DBI;
|
||||
|
||||
use lib '../';
|
||||
use app::bdd::lambda;
|
||||
use app::bdd::admin;
|
||||
use app::zone::interface;
|
||||
|
||||
package app::bdd::management;
|
||||
use Moose;
|
||||
|
||||
has [qw/dbh/] => qw/is rw required 1/;
|
||||
|
||||
# ($success, $user, $admin) auth_user($login, $passwd)
|
||||
sub auth {
|
||||
my ($self, $login, $passwd) = @_;
|
||||
my ($sth, $success, $user, $isadmin);
|
||||
|
||||
$sth = $self->dbh->prepare('SELECT * FROM user WHERE login=? and passwd=?');
|
||||
unless ($sth->execute($login, $passwd)) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
|
||||
if (my $ref = $sth->fetchrow_arrayref) {
|
||||
# if this user exists and is auth
|
||||
($success, $user, $isadmin) = $self->get_user($login);
|
||||
}
|
||||
else {
|
||||
$success = 0;
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
return ($success, $user, $isadmin);
|
||||
}
|
||||
|
||||
# ($success) register_user
|
||||
sub register_user {
|
||||
my ($self, $login, $pass) = @_;
|
||||
|
||||
my $sth = $self->dbh->prepare('select * from user where login=?');
|
||||
unless ( $sth->execute($login) ) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
|
||||
# if an user already exists
|
||||
if (my $ref = $sth->fetchrow_arrayref) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
|
||||
# if not
|
||||
$sth = $self->dbh->prepare('insert into user VALUES(?,?,?)');
|
||||
unless ($sth->execute($login, $pass, 0)) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
$sth->finish();
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
# ($success) delete_user
|
||||
sub delete_user {
|
||||
my ($self, $login) = @_;
|
||||
my $sth;
|
||||
|
||||
# TODO : vérifier que ça renvoie la bonne valeur
|
||||
$sth = $self->dbh->prepare('delete from user where login=?');
|
||||
unless ( $sth->execute($login) ) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
$sth->finish();
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub get_user {
|
||||
my ($self, $login) = @_;
|
||||
my ($sth, $user, @domains);
|
||||
|
||||
$sth = $self->dbh->prepare('SELECT * FROM user WHERE login=?');
|
||||
unless ( $sth->execute($login)) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
|
||||
if (my $ref = $sth->fetchrow_arrayref) {
|
||||
$sth = $self->dbh->prepare('SELECT domain FROM domain WHERE login=?');
|
||||
unless ( $sth->execute($login)) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
|
||||
while(my $ref2 = $sth->fetchrow_arrayref) {
|
||||
push @domains, @$ref2[0];
|
||||
}
|
||||
|
||||
# si admin
|
||||
if(@$ref[2]) {
|
||||
$user = app::bdd::admin->new(login => @$ref[0]
|
||||
, passwd => @$ref[1]
|
||||
, dbh => $self->dbh
|
||||
, domains => [@domains]);
|
||||
|
||||
}
|
||||
else {
|
||||
$user = app::bdd::lambda->new(login => @$ref[0]
|
||||
, passwd => @$ref[1]
|
||||
, dbh => $self->dbh
|
||||
, domains => [@domains]);
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
return (1, $user, @$ref[2]);
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub get_domains {
|
||||
my ($self, $login) = @_;
|
||||
my ($sth, @domains);
|
||||
|
||||
$sth = $self->dbh->prepare('SELECT domain FROM domain where login=?');
|
||||
unless ($sth->execute($login)) {
|
||||
$sth->finish();
|
||||
return (0, @domains);
|
||||
}
|
||||
|
||||
while(my $ref = $sth->fetchrow_arrayref) {
|
||||
push @domains, @$ref[0];
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
|
||||
return (1, @domains);
|
||||
}
|
||||
|
||||
sub get_all_domains {
|
||||
my ($self) = @_;
|
||||
my ($sth, %domains);
|
||||
|
||||
$sth = $self->dbh->prepare('SELECT domain, login FROM domain');
|
||||
unless ( $sth->execute()) {
|
||||
$sth->finish();
|
||||
undef;
|
||||
}
|
||||
|
||||
while( my $ref = $sth->fetchrow_arrayref) {
|
||||
$domains{@$ref[0]} = @$ref[1];
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
%domains;
|
||||
}
|
||||
|
||||
sub get_all_users {
|
||||
my ($self) = @_;
|
||||
my ($sth, %users);
|
||||
|
||||
$sth = $self->dbh->prepare('SELECT login, admin FROM user');
|
||||
unless ( $sth->execute()) {
|
||||
$sth->finish();
|
||||
undef;
|
||||
}
|
||||
|
||||
while( my $ref = $sth->fetchrow_arrayref) {
|
||||
$users{@$ref[0]} = @$ref[1];
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
%users;
|
||||
}
|
||||
|
||||
sub set_admin {
|
||||
my ($self, $login, $val) = @_;
|
||||
|
||||
my $sth = $self->dbh->prepare('update user set admin=? where login=?');
|
||||
unless ( $sth->execute( $val, $login) ) {
|
||||
$sth->finish();
|
||||
return 0;
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
196
app/zone/edit.pm
196
app/zone/edit.pm
@ -1,196 +0,0 @@
|
||||
use Modern::Perl;
|
||||
use Data::Dump "dump";
|
||||
use DNS::ZoneParse;
|
||||
use File::Copy;
|
||||
use Net::OpenSSH;
|
||||
use Net::SSH q<sshopen2>;
|
||||
use v5.14;
|
||||
|
||||
use lib '../../';
|
||||
use app::zone::interface;
|
||||
package app::zone::edit;
|
||||
use Moose;
|
||||
|
||||
has [ qw/zname data/ ] => qw/is ro required 1/;
|
||||
|
||||
sub get {
|
||||
my ($self) = @_;
|
||||
my $dest = '/tmp/' . $self->zname;
|
||||
my $file = $self->data->zdir.'/'.$self->zname;
|
||||
|
||||
$self->_scp_get($file, $dest);
|
||||
DNS::ZoneParse->new($dest, $self->zname);
|
||||
}
|
||||
|
||||
=pod
|
||||
copie du template pour créer une nouvelle zone
|
||||
update du serial
|
||||
ajout de la zone via dnsapp (rndc, knot…)
|
||||
retourne la zone + le nom de la zone
|
||||
=cut
|
||||
|
||||
sub addzone {
|
||||
my ($self) = @_;
|
||||
|
||||
my $tpl = $self->data->zdir."/tpl.zone";
|
||||
my $tmpfile = '/tmp/'.$self->zname;
|
||||
|
||||
$self->_scp_get($tpl, $tmpfile); # get the template
|
||||
$self->_sed($tmpfile); # sed CHANGEMEORIGIN by the real origin
|
||||
|
||||
my $zonefile = DNS::ZoneParse->new($tmpfile, $self->zname);
|
||||
$zonefile->new_serial(); # update the serial number
|
||||
|
||||
# write the new zone tmpfile to disk
|
||||
my $newzone;
|
||||
open($newzone, '>', $tmpfile) or die "error";
|
||||
print $newzone $zonefile->output();
|
||||
close $newzone;
|
||||
|
||||
my $file = $self->data->zdir.'/'.$self->zname;
|
||||
$self->_scp_put($tmpfile, $file); # put the final zone on the server
|
||||
unlink($tmpfile); # del the temporary file
|
||||
|
||||
# add new zone on the primary ns
|
||||
my $prim = app::zone::interface->new()
|
||||
->get_interface($self->data->dnsapp, $self->data);
|
||||
$prim->addzone($self->data->zdir, $self->zname);
|
||||
|
||||
# add new zone on the secondary ns
|
||||
my $sec = app::zone::interface->new()
|
||||
->get_interface($self->data->dnsappsec, $self->data);
|
||||
$sec->reload_sec();
|
||||
|
||||
return $zonefile;
|
||||
}
|
||||
|
||||
=pod
|
||||
màj du serial
|
||||
push reload de la conf
|
||||
=cut
|
||||
|
||||
sub update {
|
||||
my ($self, $zonefile) = @_;
|
||||
|
||||
# update the serial number
|
||||
$zonefile->new_serial();
|
||||
|
||||
my $tmpfile = '/tmp/' . $self->zname;
|
||||
|
||||
# write the new zone tmpfile to disk
|
||||
my $newzone;
|
||||
open($newzone, '>', $tmpfile) or die "error";
|
||||
print $newzone $zonefile->output();
|
||||
close $newzone;
|
||||
|
||||
my $file = $self->data->zdir.'/'.$self->zname;
|
||||
$self->_scp_put($tmpfile, $file); # put the final zone on the server
|
||||
unlink($tmpfile); # del the temporary file
|
||||
|
||||
my $prim = app::zone::interface->new()
|
||||
->get_interface($self->data->dnsapp, $self->data);
|
||||
$prim->reload($self->zname);
|
||||
1;
|
||||
}
|
||||
|
||||
=pod
|
||||
udpate via the raw content of the zonefile
|
||||
=cut
|
||||
|
||||
sub update_raw {
|
||||
my ($self, $zonetext) = @_;
|
||||
|
||||
my $zonefile;
|
||||
my $file = '/tmp/'.$self->zname;
|
||||
|
||||
# write the updated zone file to disk
|
||||
my $newzone;
|
||||
open($newzone, '>', $file) or die "error";
|
||||
print $newzone $zonetext;
|
||||
close $newzone;
|
||||
|
||||
eval { $zonefile = DNS::ZoneParse->new($file, $self->zname); };
|
||||
|
||||
if( $@ ) {
|
||||
unlink($file);
|
||||
0;
|
||||
}
|
||||
|
||||
unlink($file);
|
||||
|
||||
$self->update($zonefile);
|
||||
}
|
||||
|
||||
# sera utile plus tard, pour l'interface
|
||||
sub new_tmp {
|
||||
my ($self) = @_;
|
||||
|
||||
my $tpl = $self->data->zdir."/tpl.zone";
|
||||
my $file = '/tmp/'.$self->zname;
|
||||
|
||||
$self->_scp($tpl, $file);
|
||||
$self->_sed($file);
|
||||
|
||||
my $zonefile = DNS::ZoneParse->new($file, $self->zname);
|
||||
$zonefile->new_serial(); # update the serial number
|
||||
|
||||
unlink($file);
|
||||
|
||||
return $zonefile;
|
||||
}
|
||||
|
||||
sub _cp {
|
||||
my ($self, $src, $dest) = @_;
|
||||
|
||||
File::Copy::copy($src, $dest) or die "Copy failed: $! ($src -> $dest)";
|
||||
}
|
||||
|
||||
sub _scp_put {
|
||||
my ($self, $src, $dest) = @_;
|
||||
|
||||
my $co = $self->data->sshuser . '@' . $self->data->sshhost . ':' . $self->data->sshport;
|
||||
my $ssh = Net::OpenSSH->new($co);
|
||||
$ssh->scp_put($src, $dest) or die "scp failed: " . $ssh->error;
|
||||
}
|
||||
|
||||
sub _scp_get {
|
||||
my ($self, $src, $dest) = @_;
|
||||
|
||||
my $co = $self->data->sshuser . '@' . $self->data->sshhost . ':' . $self->data->sshport;
|
||||
my $ssh = Net::OpenSSH->new($co);
|
||||
$ssh->scp_get($src, $dest) or die "scp failed: " . $ssh->error;
|
||||
}
|
||||
|
||||
sub _sed {
|
||||
my ($self, $file) = @_;
|
||||
my $orig = $self->zname;
|
||||
my $cmd = qq[sed -i "s/CHANGEMEORIGIN/$orig/" $file 2>/dev/null 1>/dev/null];
|
||||
|
||||
system($cmd);
|
||||
}
|
||||
|
||||
sub del {
|
||||
my ($self) = @_;
|
||||
my $prim = app::zone::interface->new()
|
||||
->get_interface($self->data->dnsapp, $self->data);
|
||||
$prim->delzone($self->data->zdir, $self->zname);
|
||||
$prim->reconfig();
|
||||
|
||||
my $sec = app::zone::interface->new()
|
||||
->get_interface($self->data->dnsappsec, $self->data);
|
||||
$sec->reload_sec();
|
||||
|
||||
my $file = $self->data->zdir.'/'.$self->zname;
|
||||
my $host = $self->data->sshhost;
|
||||
my $user = $self->data->sshuser;
|
||||
my $cmd = "rm $file";
|
||||
|
||||
Net::SSH::sshopen2("$user\@$host", *READER, *WRITER, "$cmd") || die "ssh: $!";
|
||||
|
||||
close(READER);
|
||||
close(WRITER);
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
1;
|
||||
@ -1,16 +0,0 @@
|
||||
use lib '../../';
|
||||
use app::zone::rndc_interface;
|
||||
use app::zone::knot_interface;
|
||||
use app::zone::nsdc_interface;
|
||||
package app::zone::interface;
|
||||
use Moose;
|
||||
|
||||
sub get_interface {
|
||||
my ($self, $type, $data) = @_;
|
||||
return 1, app::zone::rndc_interface->new(data => $data) if $type eq 'rndc';
|
||||
return 1, app::zone::knot_interface->new(data => $data) if $type eq 'knot';
|
||||
return 1, app::zone::nsdc_interface->new(data => $data) if $type eq 'nsdc';
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
@ -1,117 +0,0 @@
|
||||
use v5.14;
|
||||
package app::zone::nsdc_interface;
|
||||
use Moose;
|
||||
|
||||
has [ qw/data/ ] => qw/is ro required 1/;
|
||||
|
||||
# on suppose que tout est déjà mis à jour dans le fichier
|
||||
sub reload_sec {
|
||||
my ($self) = @_;
|
||||
|
||||
$self->_reload_conf();
|
||||
|
||||
system('ssh -p ' . $self->data->sshportsec . ' '
|
||||
. $self->data->sshusersec . '@' . $self->data->sshhostsec
|
||||
. ' "sudo nsdc rebuild 2>/dev/null 1>/dev/null && sudo nsdc restart 2>/dev/null 1>/dev/null "');
|
||||
}
|
||||
|
||||
sub _reload_conf {
|
||||
my ($self) = @_;
|
||||
|
||||
# get the file
|
||||
# modify the file
|
||||
# push the file
|
||||
my $f = "/tmp/nsd.conf";
|
||||
|
||||
_scp_get($self->data->sshusersec
|
||||
, $self->data->sshhostsec
|
||||
, $self->data->sshportsec
|
||||
, "/etc/nsd3/nsd.conf"
|
||||
, $f);
|
||||
|
||||
my %slavedzones = $self->data->get_all_domains();
|
||||
|
||||
my $data = read_file($f);
|
||||
my $debut = "## BEGIN_GENERATED";
|
||||
my $nouveau = '';
|
||||
|
||||
for(keys %slavedzones) {
|
||||
$nouveau .= "zone:\n\n\tname: \"$_\"\n"
|
||||
. "\tzonefile: \"slave/$_\"\n\n";
|
||||
|
||||
# allow notify & request xfr, v4 & v6
|
||||
$nouveau .=
|
||||
"\tallow-notify: " . $self->data->nsmasterv4 . ' ' . $self->data->dnsslavekey . "\n"
|
||||
. "\trequest-xfr: " . $self->data->nsmasterv4 . ' ' . $self->data->dnsslavekey . "\n\n";
|
||||
|
||||
$nouveau .=
|
||||
"\tallow-notify: " . $self->data->nsmasterv6. ' ' . $self->data->dnsslavekey . "\n"
|
||||
. "\trequest-xfr: " . $self->data->nsmasterv6. ' ' . $self->data->dnsslavekey . "\n\n";
|
||||
}
|
||||
|
||||
$data =~ s/$debut.*/$debut\n$nouveau/gsm;
|
||||
|
||||
write_file($f, $data);
|
||||
|
||||
system('ssh -p ' . $self->data->sshportsec . ' '
|
||||
. $self->data->sshusersec . '@' . $self->data->sshhostsec
|
||||
. ' "sudo nsdc patch 2>/dev/null 1>/dev/null && sudo rm /var/nsd3/ixfr.db"');
|
||||
|
||||
_scp_put($self->data->sshusersec
|
||||
, $self->data->sshhostsec
|
||||
, $self->data->sshportsec
|
||||
, $f
|
||||
, "/etc/nsd3/");
|
||||
}
|
||||
|
||||
sub _scp_get {
|
||||
my ($user, $host, $port, $src, $dest) = @_;
|
||||
|
||||
my $co = $user . '@' . $host . ':' . $port;
|
||||
my $ssh = Net::OpenSSH->new($co);
|
||||
$ssh->scp_get($src, $dest) or die "scp failed: " . $ssh->error;
|
||||
}
|
||||
|
||||
sub _scp_put {
|
||||
my ($user, $host, $port, $src, $dest) = @_;
|
||||
|
||||
my $co = $user . '@' . $host . ':' . $port;
|
||||
my $ssh = Net::OpenSSH->new($co);
|
||||
$ssh->scp_put($src, $dest) or die "scp failed: " . $ssh->error;
|
||||
}
|
||||
|
||||
sub reconfig {
|
||||
my ($self, $zname) = @_;
|
||||
die "not implemented";
|
||||
#system("nsdc reconfig 2>/dev/null 1>/dev/null");
|
||||
}
|
||||
|
||||
sub delzone {
|
||||
my ($self) = @_;
|
||||
die "not implemented";
|
||||
#system("nsdc delzone $zname 2>/dev/null 1>/dev/null");
|
||||
}
|
||||
|
||||
sub read_file {
|
||||
my ($filename) = @_;
|
||||
|
||||
open my $entree, '<:encoding(UTF-8)', $filename or
|
||||
die "Impossible d'ouvrir '$filename' en lecture : $!";
|
||||
local $/ = undef;
|
||||
my $tout = <$entree>;
|
||||
close $entree;
|
||||
|
||||
return $tout;
|
||||
}
|
||||
|
||||
sub write_file {
|
||||
my ($filename, $data) = @_;
|
||||
|
||||
open my $sortie, '>:encoding(UTF-8)', $filename or die "Impossible d'ouvrir '$filename' en écriture : $!";
|
||||
print $sortie $data;
|
||||
close $sortie;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
@ -1,41 +0,0 @@
|
||||
use v5.14;
|
||||
package app::zone::rndc_interface;
|
||||
use Moose;
|
||||
|
||||
has [ qw/data/ ] => qw/is ro required 1/;
|
||||
|
||||
# on suppose que tout est déjà mis à jour dans le fichier
|
||||
sub reload {
|
||||
my ($self, $zname) = @_;
|
||||
system("rndc reload $zname 2>/dev/null 1>/dev/null");
|
||||
system("rndc notify $zname 2>/dev/null 1>/dev/null");
|
||||
}
|
||||
|
||||
sub addzone {
|
||||
my ($self, $zdir, $zname, $opt) = @_;
|
||||
|
||||
my $command = "rndc addzone $zname ";
|
||||
|
||||
if(defined $opt) {
|
||||
$command .= "'$opt'";
|
||||
}
|
||||
else {
|
||||
$command .= "'{ type master; file \"$zdir/$zname\"; allow-transfer { ". $self->data->nsslavev4 . '; '. $self->data->nsslavev6 . "; }; notify yes; };'";
|
||||
}
|
||||
|
||||
$command .= " 2>/dev/null 1>/dev/null";
|
||||
system($command);
|
||||
|
||||
}
|
||||
|
||||
sub reconfig {
|
||||
my ($self, $zname) = @_;
|
||||
system("rndc reconfig 2>/dev/null 1>/dev/null");
|
||||
}
|
||||
|
||||
sub delzone {
|
||||
my ($self, $zdir, $zname) = @_;
|
||||
system("rndc delzone $zname 2>/dev/null 1>/dev/null");
|
||||
}
|
||||
|
||||
1;
|
||||
8
bin/app.psgi
Executable file
8
bin/app.psgi
Executable file
@ -0,0 +1,8 @@
|
||||
#!/usr/bin/env perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use FindBin;
|
||||
use lib "$FindBin::Bin/../lib";
|
||||
use MyWeb::App;
|
||||
MyWeb::App->to_app;
|
||||
31
cli/daemon/ca.cert
Normal file
31
cli/daemon/ca.cert
Normal file
@ -0,0 +1,31 @@
|
||||
-----BEGIN CERTIFICATE-----
|
||||
MIIFUDCCAzgCCQDV/QJQr9sX7DANBgkqhkiG9w0BAQsFADBqMQswCQYDVQQGEwJG
|
||||
UjEPMA0GA1UECAwGQWxzYWNlMRMwEQYDVQQHDApTdHJhc2JvdXJnMRIwEAYDVQQD
|
||||
DAluZXRsaWIucmUxITAfBgkqhkiG9w0BCQEWEmthcmNobnVAa2FyY2hudS5mcjAe
|
||||
Fw0xNDA4MjMwODAwNThaFw0xNTA4MjMwODAwNThaMGoxCzAJBgNVBAYTAkZSMQ8w
|
||||
DQYDVQQIDAZBbHNhY2UxEzARBgNVBAcMClN0cmFzYm91cmcxEjAQBgNVBAMMCW5l
|
||||
dGxpYi5yZTEhMB8GCSqGSIb3DQEJARYSa2FyY2hudUBrYXJjaG51LmZyMIICIjAN
|
||||
BgkqhkiG9w0BAQEFAAOCAg8AMIICCgKCAgEAxaqx8ToKV4lxqOJa+h7WA9qh7ygk
|
||||
3JGOx6EEquL29YUfZXvKHjA3fNUIAXzlUJZXferLO/w62t4M9Lha0beOuM3gQvXz
|
||||
RzeGAgzeEAfDN892+GIYwf7e4a6VQFU99Bb6/cetnqFSw9PiFIC1XpG/lCSR4INd
|
||||
8msGuW6YIJ30AYE2PWNhn8C44szpe4xzQrv5omJsRC4+DXe9yLAdurbvUXzEijE3
|
||||
3rii+vlj52awfsCwxGDh8oblm/ir0ISBqTpq6V/xsCD8S4L9c80HeqGzmcF1LpEl
|
||||
dpcSDKLCXLszwKJz/aNiUxPq4m7IWe0av87hUGunzDT9+NUwWcsqHBdAuACQ6xK+
|
||||
j3ZtzoiZtPDKLyfdKc4kgx1heiWLn6KCSqgHmfYLQiT7o0kYpOMM7wCjfkMAFI7G
|
||||
LCv5Vx3hgx2erjwnWKXCt+QiUISvzNs9kP3DhcOKtKr4bzEwW8CCML+qnftCjb4w
|
||||
+TLKIQNTUlp2I+To2VCnywylFyqOGxR7NKapSjoUUKyCkjcUpNUojy3sLsc1/QeM
|
||||
YRYvOyQpU+xxCGrAQjf+AE0G8QEPPry2MOLGJvg2BUJstgn2IEoYPL7uwtRSwh8b
|
||||
VtXdXX5kAdKj00XBEKOEJ0rRq/ahVTsJaC5ndvcicnp5oMbb5xx0Uvhr+SjqbOo1
|
||||
VU1qXIbGq87lMu0CAwEAATANBgkqhkiG9w0BAQsFAAOCAgEAhiIHGcruJ6kZLuFD
|
||||
wmi+ZMu3V8v0MlN6v4+VhqHbu5NGsNqXVKKo+JXs9oGlgVgSYN/OaKHc56Xs0/8m
|
||||
5mOzxm42IbMs8bj1twGAdngOo+HeXHmJMU87WaD7Igv4IG6bgE5pkhnrvsBxsvyn
|
||||
tnbRvbX582RC40OIw1uVMmYmQGNYBpl4+i94oIEjTDZys6t8MfOsJj1yAuJdYfzn
|
||||
oKZfsxfLy1Ze68u6ZOkxdNhvVmyddMGOEhhC2KgWEsFbC9aRmfPKWHS2x8pmyiwz
|
||||
eUgwDVKeuLTuPn8XzYk9BW8TFGnhEfj1wrTb3jdY9NSBBsc2o4bgb8nYQfqsRv8y
|
||||
F0yqzWbBiYKPhITf2n8qdUV3k5FE+uVLlqRERQOa07+kS5kUrpPHurhhgIXN2c2p
|
||||
Xutz+EmDyWyLyDCXAk4kKGldiqUpIozs4faYJOxtlZmNKXmokmalSl9eN/S8tIXQ
|
||||
JQ/dJnvYW9L0hvHWxF03LJ5Pee88nZfIRyN0R6olLcI3oSWCOJAfFeqklnJj5YHs
|
||||
G43BeSW4DGPKCRz6x3i7Y2S5mbfqHFzg1OloU2ybbvCSJhuxyEiSxPkWv5Tl867x
|
||||
ltju9/n8caTlMRAxskGhYnlmg7xsMrr474YAWxelo1OAEbwA+8mWKlbOFa40BHMt
|
||||
Ih5Vwu3gN7dmX293gXRYTSnYBgs=
|
||||
-----END CERTIFICATE-----
|
||||
29
cli/get_domain.pl
Normal file
29
cli/get_domain.pl
Normal file
@ -0,0 +1,29 @@
|
||||
#!/usr/bin/perl -w
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use lib './lib/';
|
||||
use configuration ':all';
|
||||
use encryption ':all';
|
||||
use app;
|
||||
use utf8;
|
||||
|
||||
if( @ARGV != 1 ) {
|
||||
say "usage : ./$0 domain";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my $dom = $ARGV[0];
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
my $domain = $app->get_domain($dom);
|
||||
dump($domain);
|
||||
};
|
||||
|
||||
if( $@ ) {
|
||||
say q{Une erreur est survenue. } . $@;
|
||||
}
|
||||
28
cli/get_domains.pl
Normal file
28
cli/get_domains.pl
Normal file
@ -0,0 +1,28 @@
|
||||
#!/usr/bin/perl -w
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
|
||||
#use DNS::ZoneParse;
|
||||
#use Config::Simple;
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use lib './lib/';
|
||||
use configuration ':all';
|
||||
use app;
|
||||
use utf8;
|
||||
|
||||
if( @ARGV != 0 ) {
|
||||
say "usage : ./$0";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
my $domains = $app->get_all_domains();
|
||||
dump($domains);
|
||||
};
|
||||
|
||||
if( $@ ) {
|
||||
say q{Une erreur est survenue. } . $@;
|
||||
}
|
||||
27
cli/get_users.pl
Normal file
27
cli/get_users.pl
Normal file
@ -0,0 +1,27 @@
|
||||
#!/usr/bin/perl -w
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use utf8;
|
||||
use Modern::Perl;
|
||||
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use lib './lib/';
|
||||
use configuration ':all';
|
||||
use app;
|
||||
|
||||
if( @ARGV != 0 ) {
|
||||
say "usage : ./$0";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
my $users = $app->get_all_users();
|
||||
dump($users);
|
||||
};
|
||||
|
||||
|
||||
if( $@ ) {
|
||||
say q{Une erreur est survenue. } . $@;
|
||||
}
|
||||
28
cli/toggle_admin.pl
Normal file
28
cli/toggle_admin.pl
Normal file
@ -0,0 +1,28 @@
|
||||
#!/usr/bin/perl -w
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use lib './lib/';
|
||||
use configuration ':all';
|
||||
use encryption ':all';
|
||||
use app;
|
||||
use utf8;
|
||||
|
||||
if( @ARGV != 1 ) {
|
||||
say "usage : ./$0 login";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my $login = $ARGV[0];
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
$app->toggle_admin($login);
|
||||
};
|
||||
|
||||
if( $@ ) {
|
||||
say q{Une erreur est survenue. } . $@;
|
||||
}
|
||||
28
cli/user_add.pl
Normal file
28
cli/user_add.pl
Normal file
@ -0,0 +1,28 @@
|
||||
#!/usr/bin/perl -w
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use lib './lib/';
|
||||
use configuration ':all';
|
||||
use encryption ':all';
|
||||
use app;
|
||||
use utf8;
|
||||
|
||||
if( @ARGV != 2 ) {
|
||||
say "usage : ./$0 login passwd";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my ($login, $passwd) = ($ARGV[0], $ARGV[1]);
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
$app->register_user($login, encrypt($passwd));
|
||||
};
|
||||
|
||||
if( $@ ) {
|
||||
say q{Une erreur est survenue. } . $@;
|
||||
}
|
||||
32
cli/user_auth.pl
Normal file
32
cli/user_auth.pl
Normal file
@ -0,0 +1,32 @@
|
||||
#!/usr/bin/perl -w
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use lib './lib/';
|
||||
use configuration ':all';
|
||||
use encryption ':all';
|
||||
use app;
|
||||
use utf8;
|
||||
|
||||
if( @ARGV != 0 && @ARGV != 2 ) {
|
||||
say "usage : ./$0 [ login passwd ]";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my ($login, $passwd) = qw/test test/;
|
||||
($login, $passwd) = ($ARGV[0], $ARGV[1]) if ( @ARGV == 2 );
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
my $user = $app->auth($login, encrypt($passwd));
|
||||
dump($user);
|
||||
if($$user{admin}) { say "ADMIN" }
|
||||
else { say "NOT ADMIN" }
|
||||
};
|
||||
|
||||
if( $@ ) {
|
||||
say q{Une erreur est survenue. } . $@;
|
||||
}
|
||||
27
cli/user_del.pl
Normal file
27
cli/user_del.pl
Normal file
@ -0,0 +1,27 @@
|
||||
#!/usr/bin/perl -w
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use lib './lib/';
|
||||
use configuration ':all';
|
||||
use app;
|
||||
use utf8;
|
||||
|
||||
if( @ARGV != 1 ) {
|
||||
say "usage : ./$0 user";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my $login = $ARGV[0];
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
$app->delete_user($login);
|
||||
};
|
||||
|
||||
if( $@ ) {
|
||||
say q{Une erreur est survenue. } . $@;
|
||||
}
|
||||
27
cli/user_update_passwd.pl
Normal file
27
cli/user_update_passwd.pl
Normal file
@ -0,0 +1,27 @@
|
||||
#!/usr/bin/perl -w
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use lib './lib/';
|
||||
use configuration ':all';
|
||||
use encryption ':all';
|
||||
use app;
|
||||
|
||||
if( @ARGV != 2 ) {
|
||||
say "usage : ./$0 userid newpasswd";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my ($login, $passwd) = ($ARGV[0], $ARGV[1]);
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
$app->update_passwd($login, encrypt($passwd));
|
||||
};
|
||||
|
||||
if( $@ ) {
|
||||
say q{Une erreur est survenue. } . $@;
|
||||
}
|
||||
28
cli/zone_add.pl
Normal file
28
cli/zone_add.pl
Normal file
@ -0,0 +1,28 @@
|
||||
#!/usr/bin/perl -w
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
|
||||
use lib './lib/';
|
||||
use configuration ':all';
|
||||
use encryption ':all';
|
||||
use app;
|
||||
use utf8;
|
||||
|
||||
if( @ARGV != 2 ) {
|
||||
say "usage : ./$0 login ndd ";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my ($login, $dom) = ($ARGV[0], $ARGV[1]);
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
$app->add_domain( $login, $dom );
|
||||
my $zone = $app->get_domain($dom);
|
||||
say $zone->output();
|
||||
};
|
||||
|
||||
if( $@ ) {
|
||||
say q{Une erreur est survenue. } . $@;
|
||||
}
|
||||
26
cli/zone_del.pl
Normal file
26
cli/zone_del.pl
Normal file
@ -0,0 +1,26 @@
|
||||
#!/usr/bin/perl -w
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
|
||||
use lib './lib/';
|
||||
use configuration ':all';
|
||||
use encryption ':all';
|
||||
use app;
|
||||
use utf8;
|
||||
|
||||
if( @ARGV != 1 ) {
|
||||
say "usage : ./$0 ndd ";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my $dom = $ARGV[0];
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
$app->delete_domain( $dom );
|
||||
};
|
||||
|
||||
if( $@ ) {
|
||||
say q{Une erreur est survenue. } . $@;
|
||||
}
|
||||
44
conf/config.yml
Normal file
44
conf/config.yml
Normal file
@ -0,0 +1,44 @@
|
||||
# TLD
|
||||
# Must contains the first "."
|
||||
tld:
|
||||
- '.netlib.re'
|
||||
- '.autre.tld'
|
||||
- '.codelib.re'
|
||||
|
||||
tmpdir: file:///media/fast/
|
||||
|
||||
database:
|
||||
sgbd: mysql # other options : see DBI module
|
||||
name: dnsmanager
|
||||
host: localhost
|
||||
port: 3306
|
||||
user: dnsmanageruser
|
||||
passwd: "my-not-so-dummy-password"
|
||||
|
||||
primarydnsserver:
|
||||
app: bind9
|
||||
dnsslavekey: demokey
|
||||
zonedir: ssh://root@localhost:22/var/named/zones/rndczones/
|
||||
domain:
|
||||
user: root
|
||||
port: 22
|
||||
host: web.loc
|
||||
name: web.loc
|
||||
v4: 192.168.0.60 # optional
|
||||
#v6: ::1 # optional
|
||||
|
||||
secondarydnsserver:
|
||||
- app: nsd
|
||||
cfg: ssh://root@nsdl:22/etc/nsd/nsd.conf
|
||||
zonedir: ssh://root@nsdl:22/etc/nsd/
|
||||
domain:
|
||||
name: nsdl
|
||||
v4: 192.168.0.61 # optional
|
||||
#v6: ::1 # optional
|
||||
|
||||
# - app: nsd
|
||||
# cfg: ssh://dnsmanager@host3:2222/etc/nsd3/nsd.conf
|
||||
# domain:
|
||||
# name: third.example.com
|
||||
# v4: 192.0.2.3 # optional
|
||||
# v6: 2001:db8::3 # optional
|
||||
@ -1,15 +1,15 @@
|
||||
# This is the main configuration file of your Dancer app
|
||||
# This is the main configuration file of your Dancer2 app
|
||||
# env-related settings should go to environments/$env.yml
|
||||
# all the settings in this file will be loaded at Dancer's startup.
|
||||
|
||||
# Your application's name
|
||||
appname: "DNSManager"
|
||||
appname: "MyWeb::App"
|
||||
|
||||
# The default layout to use for your application (located in
|
||||
# views/layouts/main.tt)
|
||||
layout: "main"
|
||||
|
||||
# when the charset is set to UTF-8 Dancer will handle for you
|
||||
# when the charset is set to UTF-8 Dancer2 will handle for you
|
||||
# all the magic of encoding and decoding. You should not care
|
||||
# about unicode within your app when this setting is set (recommended).
|
||||
charset: "UTF-8"
|
||||
@ -18,13 +18,17 @@ charset: "UTF-8"
|
||||
# simple: default and very basic template engine
|
||||
# template_toolkit: TT
|
||||
|
||||
# template: "simple"
|
||||
#template: "simple"
|
||||
|
||||
template: "template_toolkit"
|
||||
engines:
|
||||
template_toolkit:
|
||||
encoding: 'utf8'
|
||||
start_tag: '<%'
|
||||
end_tag: '%>'
|
||||
template:
|
||||
template_toolkit:
|
||||
start_tag: '<%'
|
||||
end_tag: '%>'
|
||||
|
||||
session: "Storable"
|
||||
#session: "Storable"
|
||||
session: "YAML"
|
||||
|
||||
|
||||
logging: "console"
|
||||
11
cpanfile
Normal file
11
cpanfile
Normal file
@ -0,0 +1,11 @@
|
||||
requires "Dancer2" => "0.161000";
|
||||
|
||||
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";
|
||||
};
|
||||
23
environments/development.yml
Normal file
23
environments/development.yml
Normal file
@ -0,0 +1,23 @@
|
||||
# configuration file for development environment
|
||||
|
||||
# the logger engine to use
|
||||
# console: log messages to STDOUT (your console where you started the
|
||||
# application server)
|
||||
# file: log message to a file in log/
|
||||
logger: "console"
|
||||
|
||||
# the log level for this environment
|
||||
# core is the lowest, it shows Dancer2's core log messages as well as yours
|
||||
# (debug, info, warning and error)
|
||||
log: "core"
|
||||
|
||||
# should Dancer2 consider warnings as critical errors?
|
||||
warnings: 1
|
||||
|
||||
# should Dancer2 show a stacktrace when an 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
|
||||
@ -9,9 +9,8 @@ logger: "file"
|
||||
# don't consider warnings critical
|
||||
warnings: 0
|
||||
|
||||
# hide errors
|
||||
# hide errors
|
||||
show_errors: 0
|
||||
|
||||
# cache route resolution for maximum performance
|
||||
route_cache: 1
|
||||
|
||||
# disable server tokens in production environments
|
||||
no_server_tokens: 1
|
||||
13
init/deploiement.sh
Executable file
13
init/deploiement.sh
Executable file
@ -0,0 +1,13 @@
|
||||
#!/bin/bash
|
||||
|
||||
# install applications
|
||||
sudo apt-get install mysql-server # bind9
|
||||
|
||||
# Get libs
|
||||
bash ./get_libs.sh
|
||||
|
||||
# db install
|
||||
mysql -u root --password="${PASS}" < init-create-user.sql
|
||||
mysql -u root --password="${PASS}" < init-create-db.sql
|
||||
mysql -u root --password="${PASS}" < init-grant-user.sql
|
||||
mysql -u root --password="${PASS}" < init-tables.sql
|
||||
@ -1,11 +1,20 @@
|
||||
#!/bin/bash
|
||||
|
||||
sudo apt-get update
|
||||
sudo apt-get install libssl1.0.0 libssl-dev cpanminus make gcc
|
||||
|
||||
## En attendant de faire de vrais paquets pour l'application
|
||||
|
||||
cpanm YAML
|
||||
sudo apt-get update
|
||||
|
||||
sudo apt-get install libssl1.0.0 libssl-dev cpanminus make gcc \
|
||||
libdbi-perl libdbd-mysql-perl
|
||||
|
||||
# sudo apt-get install bind9
|
||||
|
||||
cpanm --local-lib=~/perl5 local::lib && eval $(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)
|
||||
|
||||
cpanm Dancer2
|
||||
cpanm Dancer2::Plugin::Deferred
|
||||
#cpanm Dancer::Plugin::FlashMessage
|
||||
cpanm YAML::XS
|
||||
cpanm Data::Dump
|
||||
cpanm File::Basename
|
||||
cpanm Find::Lib
|
||||
@ -16,17 +25,13 @@ cpanm Modern::Perl
|
||||
cpanm Config::Simple
|
||||
cpanm Crypt::Digest::SHA256
|
||||
cpanm Dancer::Session::Storable
|
||||
|
||||
cpanm Moose
|
||||
cpanm Template
|
||||
cpanm Template::Toolkit
|
||||
cpanm Dancer
|
||||
cpanm Dancer::Test
|
||||
|
||||
cpanm ExtUtils::MakeMaker
|
||||
cpanm Storable
|
||||
|
||||
cpanm Plack::Handler::FCGI
|
||||
cpanm Plack::Runner
|
||||
cpanm DNS::ZoneParse
|
||||
cpanm Net::OpenSSH
|
||||
cpanm Template
|
||||
cpanm Net::SSH
|
||||
cpanm Date::Calc
|
||||
# cpanm Template::Toolkit non trouvé
|
||||
1
init/init-create-db.sql
Normal file
1
init/init-create-db.sql
Normal file
@ -0,0 +1 @@
|
||||
CREATE DATABASE IF NOT EXISTS dnsmanager;
|
||||
2
init/init-create-user.sql
Normal file
2
init/init-create-user.sql
Normal file
@ -0,0 +1,2 @@
|
||||
CREATE USER "dnsmanageruser"@'localhost';
|
||||
set password for "dnsmanageruser"@'localhost' = password('my-not-so-dummy-password');
|
||||
1
init/init-grant-user.sql
Normal file
1
init/init-grant-user.sql
Normal file
@ -0,0 +1 @@
|
||||
grant all on dnsmanager.* to "dnsmanageruser"@'localhost';
|
||||
21
init/init-tables.sql
Normal file
21
init/init-tables.sql
Normal file
@ -0,0 +1,21 @@
|
||||
USE dnsmanager;
|
||||
|
||||
CREATE TABLE IF NOT EXISTS user (
|
||||
login varchar(50) NOT NULL,
|
||||
passwd varchar(100) DEFAULT NULL,
|
||||
admin tinyint(1) DEFAULT 0,
|
||||
PRIMARY KEY (login)
|
||||
) ENGINE=InnoDB;
|
||||
|
||||
CREATE TABLE IF NOT EXISTS domain (
|
||||
domain varchar(100) NOT NULL,
|
||||
login varchar(50) NOT NULL,
|
||||
activated tinyint(1) NOT NULL DEFAULT 0,
|
||||
PRIMARY KEY (domain)
|
||||
) ENGINE=InnoDB;
|
||||
|
||||
CREATE TABLE IF NOT EXISTS tld (
|
||||
tld varchar(50) NOT NULL,
|
||||
activated tinyint(1) NOT NULL DEFAULT 0,
|
||||
PRIMARY KEY (tld)
|
||||
) ENGINE=InnoDB;
|
||||
10
init/recreate.sh
Executable file
10
init/recreate.sh
Executable file
@ -0,0 +1,10 @@
|
||||
#!/bin/bash
|
||||
|
||||
PASS="not-so-dummy"
|
||||
|
||||
mysql -u root --password=${PASS} < remove-db.sql
|
||||
mysql -u root --password=${PASS} < remove-user.sql
|
||||
mysql -u root --password=${PASS} < init-create-db.sql
|
||||
mysql -u root --password=${PASS} < init-create-user.sql
|
||||
mysql -u root --password=${PASS} < init-grant-user.sql
|
||||
mysql -u root --password=${PASS} < init-tables.sql
|
||||
1
init/remove-db.sql
Normal file
1
init/remove-db.sql
Normal file
@ -0,0 +1 @@
|
||||
DROP DATABASE dnsmanager;
|
||||
1
init/remove-user.sql
Normal file
1
init/remove-user.sql
Normal file
@ -0,0 +1 @@
|
||||
DROP USER "dnsmanageruser"@'localhost';
|
||||
@ -1,5 +1,5 @@
|
||||
;
|
||||
; Database file tpl.zone for tpl.zone. zone.
|
||||
; Database file CHANGEMEORIGIN for CHANGEMEORIGIN. zone.
|
||||
; Zone version: 2014030200
|
||||
;
|
||||
|
||||
196
lib/MyWeb/App.pm
Normal file
196
lib/MyWeb/App.pm
Normal file
@ -0,0 +1,196 @@
|
||||
package MyWeb::App;
|
||||
|
||||
use v5.14;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Dancer2;
|
||||
use Dancer2::Plugin::Deferred;
|
||||
use File::Basename;
|
||||
#use Storable qw( freeze thaw );
|
||||
#$Storable::Deparse = true;
|
||||
#$Storable::Eval=true;
|
||||
use utf8;
|
||||
|
||||
use YAML::XS;
|
||||
use configuration ':all';
|
||||
use util ':all';
|
||||
use rt::root ':all';
|
||||
use rt::domain ':all';
|
||||
use rt::user ':all';
|
||||
use rt::admin ':all';
|
||||
use app;
|
||||
|
||||
our $VERSION = '0.1';
|
||||
|
||||
sub what_is_next {
|
||||
my ($res) = @_;
|
||||
|
||||
if($$res{sessiondestroy}) {
|
||||
app->destroy_session;
|
||||
}
|
||||
|
||||
for(keys %{$$res{deferred}}) {
|
||||
deferred $_ => $$res{deferred}{$_};
|
||||
}
|
||||
|
||||
for(keys %{$$res{addsession}}) {
|
||||
session $_ => $$res{addsession}{$_};
|
||||
}
|
||||
|
||||
for(keys %{$$res{delsession}}) {
|
||||
session $_ => undef;
|
||||
}
|
||||
|
||||
if(exists $$res{route}) {
|
||||
redirect $$res{route};
|
||||
}
|
||||
elsif(exists $$res{template}) {
|
||||
template $$res{template} => $$res{params};
|
||||
} else {
|
||||
redirect '/';
|
||||
}
|
||||
}
|
||||
|
||||
sub get_param {
|
||||
my $param_values;
|
||||
for(@_) {
|
||||
$$param_values{$_} = param "$_";
|
||||
}
|
||||
$param_values;
|
||||
}
|
||||
|
||||
sub get_request {
|
||||
my $request_values;
|
||||
for(@_) {
|
||||
if(/^address$/) { $$request_values{$_} = request->address; }
|
||||
elsif(/^referer$/) { $$request_values{$_} = request->referer; }
|
||||
}
|
||||
$request_values;
|
||||
}
|
||||
|
||||
sub get_session {
|
||||
my $session_values;
|
||||
for(@_) {
|
||||
$$session_values{$_} = session "$_";
|
||||
}
|
||||
$session_values;
|
||||
}
|
||||
|
||||
get '/' => sub {
|
||||
what_is_next rt_root
|
||||
get_session( qw/login passwd/ );
|
||||
};
|
||||
|
||||
prefix '/domain' => sub {
|
||||
|
||||
any ['post', 'get'] => '/updateraw/:domain' => sub {
|
||||
what_is_next rt_dom_updateraw
|
||||
get_session( qw/login passwd/ )
|
||||
, get_param( qw/domain zoneupdated/)
|
||||
, get_request( qw/address referer/ );
|
||||
};
|
||||
|
||||
any ['post', 'get'] => '/update/:domain' => sub {
|
||||
what_is_next rt_dom_update
|
||||
get_session( qw/login passwd/ )
|
||||
, get_param( qw/type name value ttl priority domain/ );
|
||||
};
|
||||
|
||||
get '/details/:domain' => sub {
|
||||
what_is_next rt_dom_details
|
||||
get_session( qw/login passwd/ )
|
||||
, get_param( qw/domain expert/ )
|
||||
, get_request( qw/address referer/ );
|
||||
};
|
||||
|
||||
post '/add/' => sub {
|
||||
what_is_next rt_dom_add
|
||||
get_session( qw/login passwd/ )
|
||||
, get_param( qw/domain tld/ );
|
||||
};
|
||||
|
||||
get '/del/:domain' => sub {
|
||||
what_is_next rt_dom_del
|
||||
get_session( qw/login passwd/ )
|
||||
, get_param( qw/domain/ )
|
||||
, get_request( qw/address referer/ );
|
||||
};
|
||||
|
||||
get '/del/:domain/:name/:type/:host/:ttl' => sub {
|
||||
what_is_next rt_dom_del_entry
|
||||
get_session( qw/login passwd/ )
|
||||
, get_param( qw/domain name type host ttl/ )
|
||||
, get_request( qw/address referer/ );
|
||||
};
|
||||
|
||||
get '/mod/:domain/:name/:type/:host/:ttl' => sub {
|
||||
what_is_next rt_dom_mod_entry
|
||||
get_session( qw/login passwd/ )
|
||||
, get_param( qw/type name ttl domain name type host ttl
|
||||
newpriority newtype newhost newname newttl / )
|
||||
, get_request( qw/address referer/ );
|
||||
};
|
||||
|
||||
get '/cli/:login/:pass/:domain/:name/:type/:host/:ttl/:ip' => sub {
|
||||
what_is_next rt_dom_cli_mod_entry
|
||||
get_session( qw/login/ )
|
||||
, get_param( qw/passwd domain name type host ttl ip/ );
|
||||
};
|
||||
};
|
||||
|
||||
any ['get', 'post'] => '/admin' => sub {
|
||||
what_is_next rt_admin
|
||||
get_session( qw/login passwd/ );
|
||||
};
|
||||
|
||||
prefix '/user' => sub {
|
||||
|
||||
get '/home' => sub {
|
||||
what_is_next rt_user_home
|
||||
get_session( qw/login passwd/ )
|
||||
, get_param( qw// )
|
||||
, get_request( qw// );
|
||||
};
|
||||
|
||||
get '/logout' => sub {
|
||||
app->destroy_session;
|
||||
redirect '/';
|
||||
};
|
||||
|
||||
get '/del/:user' => sub {
|
||||
what_is_next rt_user_del
|
||||
get_session( qw/login passwd/ )
|
||||
, get_param( qw/user/ )
|
||||
, get_request( qw/referer/ );
|
||||
};
|
||||
|
||||
# add a user => registration
|
||||
post '/add/' => sub {
|
||||
what_is_next rt_user_add
|
||||
get_session( qw// )
|
||||
, get_param( qw/login password password2/ )
|
||||
, get_request( qw// );
|
||||
};
|
||||
|
||||
get '/subscribe' => sub {
|
||||
what_is_next rt_user_subscribe
|
||||
get_session( qw/login/ );
|
||||
};
|
||||
|
||||
get '/toggleadmin/:user' => sub {
|
||||
what_is_next rt_user_toggleadmin
|
||||
get_session( qw/login passwd/ )
|
||||
, get_param( qw/user/ )
|
||||
, get_request( qw/referer/ );
|
||||
};
|
||||
|
||||
post '/login' => sub {
|
||||
what_is_next rt_user_login
|
||||
get_session( qw/login/ )
|
||||
, get_param( qw/login password/ )
|
||||
, get_request( qw/referer/ );
|
||||
};
|
||||
};
|
||||
|
||||
true;
|
||||
7
lib/README.markdown
Normal file
7
lib/README.markdown
Normal file
@ -0,0 +1,7 @@
|
||||
# TODO
|
||||
|
||||
* redesign zone.pm
|
||||
* moar testz !!! Kitten will die !!!
|
||||
* décider de la procédure d'init de app, pas besoin de tout charger à chaque fois
|
||||
* comment passer des informations à chaque interface ?
|
||||
* est-ce que ce qui est fait est pertinent ?
|
||||
144
lib/app.pm
Normal file
144
lib/app.pm
Normal file
@ -0,0 +1,144 @@
|
||||
package app;
|
||||
use v5.14;
|
||||
use Moo;
|
||||
|
||||
use db;
|
||||
use zone;
|
||||
|
||||
has db => ( is => 'rw', builder => '_void');
|
||||
|
||||
has [qw/tld tmpdir database primarydnsserver secondarydnsserver/]
|
||||
=> qw/is ro required 1/;
|
||||
|
||||
sub _void { my $x = ''; \$x; }
|
||||
|
||||
sub BUILD {
|
||||
my ($self) = @_;
|
||||
$$self{db} = db->new(data => $self);
|
||||
|
||||
my $db = $$self{database};
|
||||
unless(exists $$db{sgbd} && exists $$db{name}
|
||||
&& exists $$db{host} && exists $$db{port}
|
||||
&& exists $$db{user} && exists $$db{passwd})
|
||||
{
|
||||
die "Unable to connect to the database.\n"
|
||||
. "Check the existance of theses parameters in the config file :\n"
|
||||
. "\tsgbd name host port user passwd";
|
||||
}
|
||||
}
|
||||
|
||||
# USER
|
||||
|
||||
sub auth {
|
||||
my ($self, $login, $passwd) = @_;
|
||||
$self->db->auth($login, $passwd)
|
||||
}
|
||||
|
||||
sub update_passwd {
|
||||
my ($self, $login, $newpass) = @_;
|
||||
$self->db->update_passwd($login, $newpass)
|
||||
}
|
||||
|
||||
sub register_user {
|
||||
my ($self, $login, $passwd) = @_;
|
||||
$self->db->register_user($login, $passwd)
|
||||
}
|
||||
|
||||
sub toggle_admin {
|
||||
my ($self, $login) = @_;
|
||||
$self->db->toggle_admin($login)
|
||||
}
|
||||
|
||||
sub delete_user {
|
||||
my ($self, $login) = @_;
|
||||
$self->db->delete_user($login)
|
||||
}
|
||||
|
||||
sub get_all_users {
|
||||
my ($self) = @_;
|
||||
$self->db->get_all_users
|
||||
}
|
||||
|
||||
sub is_owning_domain {
|
||||
my ($self, $login, $domain) = @_;
|
||||
$self->db->is_owning_domain($login, $domain)
|
||||
}
|
||||
|
||||
# DOMAIN
|
||||
|
||||
sub _get_zone {
|
||||
my ($self, $domain) = @_;
|
||||
|
||||
# say "";
|
||||
# say "GET ZONE";
|
||||
# say "";
|
||||
# say "";
|
||||
# say "domain $domain";
|
||||
# say "tmpdir $$self{tmpdir}";
|
||||
# say "tld $$self{tld}";
|
||||
|
||||
zone->new( domain => $domain
|
||||
, tmpdir => $$self{tmpdir}
|
||||
, tld => $$self{tld}
|
||||
, primarydnsserver => $$self{primarydnsserver}
|
||||
, secondarydnsserver => $$self{secondarydnsserver}
|
||||
, slavedzones => $self->get_all_domains()
|
||||
)
|
||||
}
|
||||
|
||||
sub add_domain {
|
||||
my ($self, $login, $domain) = @_;
|
||||
$self->db->add_domain($login, $domain);
|
||||
$self->_get_zone($domain)->addzone()
|
||||
}
|
||||
|
||||
sub delete_domain {
|
||||
my ($self, $domain) = @_;
|
||||
$self->db->delete_domain($domain);
|
||||
$self->_get_zone($domain)->del()
|
||||
}
|
||||
|
||||
sub modify_entry {
|
||||
my ($self, $domain, $entryToModify, $newEntry) = @_;
|
||||
my $zone = $self->_get_zone($domain)->modify_entry(
|
||||
$entryToModify, $newEntry );
|
||||
$self->update_domain($zone, $domain)
|
||||
}
|
||||
|
||||
sub delete_entry {
|
||||
my ($self, $domain, $entryToDelete) = @_;
|
||||
my $zone = $self->_get_zone($domain)->delete_entry( $entryToDelete );
|
||||
$self->update_domain($zone, $domain)
|
||||
}
|
||||
|
||||
sub update_domain_raw {
|
||||
my ($self, $zone, $domain) = @_;
|
||||
$self->_get_zone($domain)->update_raw($zone)
|
||||
}
|
||||
|
||||
sub update_domain {
|
||||
my ($self, $zone, $domain) = @_;
|
||||
$self->_get_zone($domain)->update($zone)
|
||||
}
|
||||
|
||||
sub get_domain {
|
||||
my ($self, $domain) = @_;
|
||||
$self->_get_zone($domain)->get()
|
||||
}
|
||||
|
||||
sub get_domains {
|
||||
my ($self, $login) = @_;
|
||||
$self->db->get_domains($login)
|
||||
}
|
||||
|
||||
sub get_all_domains {
|
||||
my ($self) = @_;
|
||||
$self->db->get_all_domains
|
||||
}
|
||||
|
||||
sub disconnect {
|
||||
my ($self) = @_;
|
||||
$self->db->disconnect
|
||||
}
|
||||
|
||||
1;
|
||||
166
lib/configuration.pm
Normal file
166
lib/configuration.pm
Normal file
@ -0,0 +1,166 @@
|
||||
package configuration;
|
||||
use YAML::XS;
|
||||
use URI;
|
||||
|
||||
use fileutil ':all';
|
||||
use Exporter 'import';
|
||||
# what we want to export eventually
|
||||
our @EXPORT_OK = qw/
|
||||
get_cfg is_reserved
|
||||
get_zonedir_from_cfg
|
||||
get_dnsslavekey_from_cfg
|
||||
get_v4_from_name
|
||||
get_v6_from_name
|
||||
get_v4_from_cfg
|
||||
get_v6_from_cfg
|
||||
get_host_from_cfg
|
||||
get_user_from_cfg
|
||||
get_port_from_cfg
|
||||
/;
|
||||
|
||||
# bundle of exports (tags)
|
||||
our %EXPORT_TAGS = ( all => [qw/
|
||||
get_cfg is_reserved
|
||||
get_zonedir_from_cfg
|
||||
get_dnsslavekey_from_cfg
|
||||
get_v4_from_name
|
||||
get_v6_from_name
|
||||
get_v4_from_cfg
|
||||
get_v6_from_cfg
|
||||
get_host_from_cfg
|
||||
get_user_from_cfg
|
||||
get_port_from_cfg
|
||||
/] );
|
||||
|
||||
sub is_conf_file {
|
||||
my $f = shift;
|
||||
|
||||
unless(-f $f) {
|
||||
die "$f : not a file";
|
||||
}
|
||||
|
||||
unless(-r $f) {
|
||||
die "$f : not readable";
|
||||
}
|
||||
|
||||
unless(-T $f) {
|
||||
die "$f : not plain text";
|
||||
}
|
||||
}
|
||||
|
||||
sub get_cfg {
|
||||
my ($cfgdir) = @_;
|
||||
|
||||
$cfgdir //= './conf/';
|
||||
my $f = "$cfgdir/config.yml";
|
||||
|
||||
is_conf_file $f;
|
||||
YAML::XS::LoadFile($f)
|
||||
}
|
||||
|
||||
sub is_reserved {
|
||||
my ($domain) = @_;
|
||||
|
||||
my $filename = 'conf/reserved.zone';
|
||||
is_conf_file $filename;
|
||||
|
||||
my $data = read_file $filename;
|
||||
$data =~ /^$domain$/m;
|
||||
}
|
||||
|
||||
# TODO : tests
|
||||
sub get_v6_from_name {
|
||||
my $name = shift;
|
||||
|
||||
my $val = qx/host -t AAAA $name | grep -oE '[^[:space:]]+\$'/;
|
||||
chomp $val;
|
||||
|
||||
#die q{There is no available v6. TODO.} if($val =~ 'NXDOMAIN');
|
||||
return undef if($val =~ 'NXDOMAIN');
|
||||
|
||||
$val
|
||||
}
|
||||
|
||||
sub get_v4_from_name {
|
||||
my $name = shift;
|
||||
|
||||
my $val = qx/host -t A $name | grep -oE '[^[:space:]]+\$'/;
|
||||
chomp $val;
|
||||
|
||||
die q{There is no available v4. TODO.} if($val =~ 'NXDOMAIN');
|
||||
|
||||
$val
|
||||
}
|
||||
|
||||
sub get_v6_from_cfg {
|
||||
my $cfg = shift;
|
||||
$$cfg{domain}{v6} // get_v6_from_name($$cfg{domain}{name})
|
||||
}
|
||||
|
||||
sub get_v4_from_cfg {
|
||||
my $cfg = shift;
|
||||
$$cfg{domain}{v4} // get_v4_from_name($$cfg{domain}{name})
|
||||
}
|
||||
|
||||
sub get_zonedir_from_cfg {
|
||||
my $cfg = shift;
|
||||
unless($$cfg{zonedir}) {
|
||||
die 'For now, the only way to get the zone path is to setup zonedir '
|
||||
. 'in the primaryserver configuration in config.yml.';
|
||||
}
|
||||
URI->new($$cfg{zonedir})->path;
|
||||
}
|
||||
|
||||
sub get_host_from_cfg {
|
||||
my $cfg = shift;
|
||||
|
||||
if($$cfg{zonedir}) {
|
||||
my $u = URI->new($$cfg{zonedir});
|
||||
return $u->host;
|
||||
}
|
||||
elsif($$cfg{domain}{name}) {
|
||||
return $$cfg{domain}{name};
|
||||
}
|
||||
|
||||
die "Impossible to get the host from the configuration."
|
||||
}
|
||||
|
||||
sub get_dnsslavekey_from_cfg {
|
||||
my $cfg = shift;
|
||||
|
||||
if($$cfg{dnsslavekey}) {
|
||||
return $$cfg{dnsslavekey};
|
||||
}
|
||||
|
||||
die "Impossible to get the dns slave key from the configuration."
|
||||
}
|
||||
|
||||
sub get_user_from_cfg {
|
||||
my $cfg = shift;
|
||||
|
||||
if($$cfg{zonedir}) {
|
||||
my $u = URI->new($$cfg{zonedir});
|
||||
return $u->user;
|
||||
}
|
||||
elsif($$cfg{domain}{user}) {
|
||||
return $$cfg{domain}{user};
|
||||
}
|
||||
|
||||
die "Impossible to get the user from the configuration."
|
||||
}
|
||||
|
||||
sub get_port_from_cfg {
|
||||
my $cfg = shift;
|
||||
|
||||
if($$cfg{zonedir}) {
|
||||
my $u = URI->new($$cfg{zonedir});
|
||||
return $u->port;
|
||||
}
|
||||
elsif($$cfg{domain}{port}) {
|
||||
return $$cfg{domain}{port};
|
||||
}
|
||||
|
||||
die "Impossible to get the port from the configuration."
|
||||
}
|
||||
|
||||
1;
|
||||
72
lib/copycat.pm
Normal file
72
lib/copycat.pm
Normal file
@ -0,0 +1,72 @@
|
||||
package copycat;
|
||||
use v5.14;
|
||||
|
||||
use File::Copy;
|
||||
use URI;
|
||||
use Net::OpenSSH;
|
||||
|
||||
use Exporter 'import';
|
||||
# what we want to export eventually
|
||||
our @EXPORT_OK = qw/copycat/;
|
||||
|
||||
# bundle of exports (tags)
|
||||
our %EXPORT_TAGS = ( all => [qw/copycat/] );
|
||||
|
||||
sub _cp {
|
||||
my ($src, $dest) = @_;
|
||||
say "cp $src $dest";
|
||||
File::Copy::copy($src, $dest) or die "Copy failed: $! ($src -> $dest)";
|
||||
}
|
||||
|
||||
sub _scp_put {
|
||||
my ($co, $src, $dest) = @_;
|
||||
|
||||
my $ssh = Net::OpenSSH->new($co);
|
||||
say "scp put $src $dest";
|
||||
$ssh->scp_put($src, $dest) or die "scp failed: " . $ssh->error;
|
||||
}
|
||||
|
||||
sub _scp_get {
|
||||
my ($co, $src, $dest) = @_;
|
||||
|
||||
my $ssh = Net::OpenSSH->new($co);
|
||||
say "scp get $src $dest";
|
||||
$ssh->scp_get($src, $dest) or die "scp failed: " . $ssh->error;
|
||||
}
|
||||
|
||||
# SUPPORT
|
||||
# local to local
|
||||
# distant to local
|
||||
# local to distant
|
||||
|
||||
sub copycat {
|
||||
my ($source, $destination) = @_;
|
||||
|
||||
# TODO if it's not URI
|
||||
|
||||
my $src = URI->new($source);
|
||||
my $dest = URI->new($destination);
|
||||
|
||||
if($src->scheme eq 'file' && $dest->scheme eq 'file') {
|
||||
_cp $src->path, $dest->path;
|
||||
}
|
||||
elsif($src->scheme eq 'ssh' && $dest->scheme eq 'file') {
|
||||
|
||||
my $co = $src->userinfo . '@' . $src->host . ':' . $src->port;
|
||||
_scp_get $co, $src->path, $dest->path;
|
||||
|
||||
}
|
||||
elsif($src->scheme eq 'file' && $dest->scheme eq 'ssh') {
|
||||
|
||||
my $co = $dest->userinfo . '@' . $dest->host . ':' . $dest->port;
|
||||
_scp_put $co, $src->path, $dest->path;
|
||||
|
||||
}
|
||||
else {
|
||||
|
||||
die "CopyCat : wrong arguments";
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
269
lib/db.pm
Normal file
269
lib/db.pm
Normal file
@ -0,0 +1,269 @@
|
||||
package db;
|
||||
use v5.14;
|
||||
use Moo;
|
||||
|
||||
use Modern::Perl;
|
||||
use autodie;
|
||||
use DBI;
|
||||
|
||||
use getiface ':all';
|
||||
|
||||
# db handler
|
||||
has dbh => ( is => 'rw', builder => '_void');
|
||||
|
||||
sub _void { my $x = ''; \$x; }
|
||||
|
||||
# reference to the application
|
||||
has data => qw/is ro required 1/;
|
||||
|
||||
sub BUILD {
|
||||
my $self = shift;
|
||||
|
||||
my $db = $$self{data}{database};
|
||||
|
||||
my $dsn = "DBI:$$db{sgbd}:database=$$db{name};"
|
||||
. "host=$$db{host};port=$$db{port}";
|
||||
|
||||
$$self{dbh} = DBI->connect($dsn, $$db{user}, $$db{passwd})
|
||||
|| die "Could not connect to database: $DBI::errstr";
|
||||
$$self{dbh}->{mysql_enable_utf8} = 1;
|
||||
$$self{dbh}->do('SET NAMES \'utf8\';') || die;
|
||||
|
||||
}
|
||||
|
||||
# USER
|
||||
|
||||
sub auth {
|
||||
my ($self, $login, $passwd) = @_;
|
||||
my $sth;
|
||||
|
||||
$sth = $self->dbh->prepare('SELECT * FROM user WHERE login=? and passwd=?');
|
||||
unless ($sth->execute($login, $passwd)) {
|
||||
$sth->finish();
|
||||
die q{Can't authenticate.};
|
||||
}
|
||||
|
||||
# if we can't find the user with this password
|
||||
unless (my $ref = $sth->fetchrow_arrayref) {
|
||||
$sth->finish();
|
||||
die q{The user can't be authenticated.};
|
||||
}
|
||||
$sth->finish();
|
||||
|
||||
# if this user exists and is auth
|
||||
$self->get_user($login)
|
||||
}
|
||||
|
||||
sub register_user {
|
||||
my ($self, $login, $pass) = @_;
|
||||
|
||||
my $sth = $self->dbh->prepare('select * from user where login=?');
|
||||
unless ( $sth->execute($login) ) {
|
||||
$sth->finish();
|
||||
die "Impossible to check if the user $login exists.";
|
||||
}
|
||||
|
||||
# if an user already exists
|
||||
if (my $ref = $sth->fetchrow_arrayref) {
|
||||
$sth->finish();
|
||||
die "The user $login already exists.";
|
||||
}
|
||||
|
||||
# if not
|
||||
$sth = $self->dbh->prepare('insert into user VALUES(?,?,?)');
|
||||
unless ($sth->execute($login, $pass, 0)) {
|
||||
$sth->finish();
|
||||
die "Impossible to register the user $login.";
|
||||
}
|
||||
$sth->finish();
|
||||
}
|
||||
|
||||
sub delete_user {
|
||||
my ($self, $login) = @_;
|
||||
my $sth;
|
||||
# TODO : vérifier que ça renvoie la bonne valeur
|
||||
$sth = $self->dbh->prepare('delete from user where login=?');
|
||||
unless ( $sth->execute($login) ) {
|
||||
$sth->finish();
|
||||
die "Impossible to delete the user $login.";
|
||||
}
|
||||
$sth->finish();
|
||||
$self->delete_domains_from_user($login)
|
||||
}
|
||||
|
||||
sub get_user {
|
||||
my ($self, $login) = @_;
|
||||
my ($sth, $user);
|
||||
|
||||
$sth = $self->dbh->prepare('SELECT * FROM user WHERE login=?');
|
||||
unless ( $sth->execute($login)) {
|
||||
$sth->finish();
|
||||
die "Impossible to check if the user $login exists.";
|
||||
}
|
||||
|
||||
unless ($user = $sth->fetchrow_hashref) {
|
||||
$sth->finish();
|
||||
die "User $login doesn't exist.";
|
||||
}
|
||||
$sth->finish();
|
||||
|
||||
# the user gets all his domains
|
||||
$$user{domains} = $self->get_domains($login);
|
||||
$user
|
||||
}
|
||||
|
||||
sub get_all_users {
|
||||
my ($self) = @_;
|
||||
my ($sth, $users);
|
||||
|
||||
$sth = $self->dbh->prepare('SELECT * FROM user');
|
||||
unless ( $sth->execute()) {
|
||||
$sth->finish();
|
||||
die q{Impossible to list the users.};
|
||||
}
|
||||
|
||||
while( my $ref = $sth->fetchrow_hashref) {
|
||||
push @$users, $ref;
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
$users
|
||||
}
|
||||
|
||||
sub toggle_admin {
|
||||
my ($self, $login) = @_;
|
||||
|
||||
my $user = $self->get_user($login);
|
||||
my $val = ($$user{admin}) ? 0 : 1;
|
||||
|
||||
my $sth = $self->dbh->prepare('update user set admin=? where login=?');
|
||||
unless ( $sth->execute( $val, $login ) ) {
|
||||
$sth->finish();
|
||||
die "Impossible to toggle admin the user $login.";
|
||||
}
|
||||
|
||||
$sth->finish()
|
||||
}
|
||||
|
||||
sub update_passwd {
|
||||
my ($self, $login, $new) = @_;
|
||||
my $sth;
|
||||
$sth = $self->dbh->prepare('update user set passwd=? where login=?');
|
||||
unless ( $sth->execute($new, $login) ) {
|
||||
$sth->finish();
|
||||
die q{The password can't be updated.};
|
||||
}
|
||||
$sth->finish()
|
||||
}
|
||||
|
||||
# DOMAIN
|
||||
|
||||
sub get_domains {
|
||||
my ($self, $login) = @_;
|
||||
my ($sth);
|
||||
my $domains = [];
|
||||
|
||||
$sth = $self->dbh->prepare('SELECT * FROM domain where login=?');
|
||||
unless ($sth->execute($login)) {
|
||||
$sth->finish();
|
||||
die "Impossible to check if the user $login has domains.";
|
||||
}
|
||||
|
||||
while(my $ref = $sth->fetchrow_hashref) {
|
||||
push @$domains, $ref;
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
$domains
|
||||
}
|
||||
|
||||
sub delete_domain {
|
||||
my ($self, $domain) = @_;
|
||||
my $sth;
|
||||
$sth = $self->dbh->prepare('delete from domain where domain=?');
|
||||
unless ( $sth->execute($domain) ) {
|
||||
$sth->finish();
|
||||
die "Impossible to delete the $domain.";
|
||||
}
|
||||
$sth->finish()
|
||||
}
|
||||
|
||||
sub delete_domains_from_user {
|
||||
my ($self, $login) = @_;
|
||||
my $sth;
|
||||
$sth = $self->dbh->prepare('delete from domain where login=?');
|
||||
unless ( $sth->execute($login) ) {
|
||||
$sth->finish();
|
||||
die "Impossible to delete the domains of the user $login.";
|
||||
}
|
||||
$sth->finish()
|
||||
}
|
||||
|
||||
# TODO check if the domain is reserved
|
||||
sub add_domain {
|
||||
my ($self, $login, $domain) = @_;
|
||||
my ($sth);
|
||||
|
||||
$sth = $self->dbh->prepare('select domain from domain where domain=?');
|
||||
unless ( $sth->execute($domain) ) {
|
||||
$sth->finish();
|
||||
die 'Impossible to search if the domain already exists.';
|
||||
}
|
||||
|
||||
# if the domain already exists
|
||||
if (my $ref = $sth->fetchrow_arrayref) {
|
||||
$sth->finish();
|
||||
die 'The domain already exists.';
|
||||
}
|
||||
|
||||
$sth = $self->dbh->prepare('insert into domain VALUES(?,?,?)');
|
||||
unless ( $sth->execute($domain, $login, 0) ) {
|
||||
$sth->finish();
|
||||
die 'Impossible to add a domain.';
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
}
|
||||
|
||||
sub get_all_domains {
|
||||
my ($self) = @_;
|
||||
my ($sth, $domains);
|
||||
|
||||
$sth = $self->dbh->prepare('SELECT * FROM domain');
|
||||
unless ( $sth->execute()) {
|
||||
$sth->finish();
|
||||
die q{Impossible to list the domains.};
|
||||
}
|
||||
|
||||
while( my $ref = $sth->fetchrow_hashref) {
|
||||
push @$domains, $ref;
|
||||
}
|
||||
|
||||
$sth->finish();
|
||||
$domains
|
||||
}
|
||||
|
||||
sub disconnect {
|
||||
my ($self) = @_;
|
||||
$$self{dbh}->disconnect()
|
||||
}
|
||||
|
||||
sub is_owning_domain {
|
||||
my ($self, $login, $domain) = @_;
|
||||
|
||||
my $sth =
|
||||
$self->dbh->prepare('SELECT * FROM domain where login=? and domain=?');
|
||||
unless ($sth->execute($login, $domain)) {
|
||||
$sth->finish();
|
||||
die "Impossible to check if the user $login has domains.";
|
||||
}
|
||||
|
||||
unless($sth->fetchrow_hashref) {
|
||||
$sth->finish();
|
||||
return 0
|
||||
}
|
||||
|
||||
1
|
||||
}
|
||||
|
||||
1;
|
||||
16
lib/encryption.pm
Normal file
16
lib/encryption.pm
Normal file
@ -0,0 +1,16 @@
|
||||
package encryption;
|
||||
use Crypt::Digest::SHA256 qw( sha256_hex ) ;
|
||||
|
||||
use Exporter 'import';
|
||||
# what we want to export eventually
|
||||
our @EXPORT_OK = qw/encrypt/;
|
||||
|
||||
# bundle of exports (tags)
|
||||
our %EXPORT_TAGS = ( all => [qw/encrypt/] );
|
||||
|
||||
sub encrypt {
|
||||
my ($x) = @_;
|
||||
sha256_hex($x)
|
||||
}
|
||||
|
||||
1;
|
||||
46
lib/fileutil.pm
Normal file
46
lib/fileutil.pm
Normal file
@ -0,0 +1,46 @@
|
||||
package fileutil;
|
||||
use v5.14;
|
||||
|
||||
use URI;
|
||||
|
||||
use Exporter 'import';
|
||||
# what we want to export eventually
|
||||
our @EXPORT_OK = qw/read_file write_file/;
|
||||
|
||||
# bundle of exports (tags)
|
||||
our %EXPORT_TAGS = ( all => [qw/read_file write_file/] );
|
||||
|
||||
sub read_file {
|
||||
my ($filename) = @_;
|
||||
|
||||
if($filename =~ "://")
|
||||
{
|
||||
my $fileuri = URI->new($filename);
|
||||
$filename = $fileuri->path;
|
||||
}
|
||||
|
||||
open my $entry, '<:encoding(UTF-8)', $filename or
|
||||
die "Impossible d'ouvrir '$filename' en lecture : $!";
|
||||
local $/ = undef;
|
||||
my $all = <$entry>;
|
||||
close $entry;
|
||||
|
||||
return $all;
|
||||
}
|
||||
|
||||
sub write_file {
|
||||
my ($filename, $data) = @_;
|
||||
|
||||
if($filename =~ "://")
|
||||
{
|
||||
my $fileuri = URI->new($filename);
|
||||
$filename = $fileuri->path;
|
||||
}
|
||||
|
||||
open my $sortie, '>:encoding(UTF-8)', $filename or
|
||||
die "Impossible d'ouvrir '$filename' en écriture : $!";
|
||||
print $sortie $data;
|
||||
close $sortie;
|
||||
}
|
||||
|
||||
1;
|
||||
27
lib/getiface.pm
Normal file
27
lib/getiface.pm
Normal file
@ -0,0 +1,27 @@
|
||||
package getiface;
|
||||
use v5.14;
|
||||
|
||||
use Exporter 'import';
|
||||
# what we want to export eventually
|
||||
our @EXPORT_OK = qw/getiface/;
|
||||
|
||||
# bundle of exports (tags)
|
||||
our %EXPORT_TAGS = ( all => [qw/getiface/] );
|
||||
|
||||
use interface::bind9;
|
||||
use interface::knot;
|
||||
use interface::nsd3;
|
||||
use interface::nsd4;
|
||||
|
||||
sub getiface {
|
||||
my ($type, $params) = @_;
|
||||
for($type) {
|
||||
if (/bind9/) { return interface::bind9->new($params) }
|
||||
elsif (/knot/) { return interface::knot->new($params) }
|
||||
elsif (/nsd3/) { return interface::nsd3->new($params) }
|
||||
elsif (/nsd/) { return interface::nsd4->new($params) }
|
||||
else { die "Interface for the $_ dns type not found."; }
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
85
lib/interface/bind9.pm
Normal file
85
lib/interface/bind9.pm
Normal file
@ -0,0 +1,85 @@
|
||||
package interface::bind9;
|
||||
use v5.14;
|
||||
use Moo;
|
||||
use configuration ':all';
|
||||
use remotecmd ':all';
|
||||
|
||||
has [ qw/mycfg tmpdir primarydnsserver secondarydnsserver/ ] => qw/is ro required 1/;
|
||||
|
||||
sub reload {
|
||||
my ($self, $domain) = @_;
|
||||
|
||||
my $cmd = "rndc reload $domain ";
|
||||
|
||||
my $user = get_user_from_cfg($$self{mycfg});
|
||||
my $host = get_host_from_cfg($$self{mycfg});
|
||||
my $port = get_port_from_cfg($$self{mycfg});
|
||||
|
||||
remotecmd $user, $host, $port, $cmd;
|
||||
|
||||
$cmd = "rndc notify $domain ";
|
||||
remotecmd $user, $host, $port, $cmd;
|
||||
}
|
||||
|
||||
sub primary_addzone {
|
||||
my ($self, $domain, $opt) = @_;
|
||||
|
||||
my $cmd = "rndc addzone $domain ";
|
||||
|
||||
if(defined $opt) {
|
||||
$cmd .= "'$opt'";
|
||||
}
|
||||
else {
|
||||
my $dir = get_zonedir_from_cfg($$self{mycfg});
|
||||
$cmd .= "\"{ type master; file \\\"$dir/$domain\\\"; allow-transfer { ";
|
||||
|
||||
my $sec = $$self{secondarydnsserver};
|
||||
for(@$sec) {
|
||||
my $v4 = get_v4_from_cfg($_);
|
||||
my $v6 = get_v6_from_cfg($_);
|
||||
|
||||
$cmd .= $v4 . '; ' if $v4;
|
||||
$cmd .= $v6 . '; ' if $v6;
|
||||
}
|
||||
$cmd .= " }; notify yes; };\"";
|
||||
}
|
||||
|
||||
my $user = get_user_from_cfg($$self{mycfg});
|
||||
my $host = get_host_from_cfg($$self{mycfg});
|
||||
my $port = get_port_from_cfg($$self{mycfg});
|
||||
|
||||
remotecmd $user, $host, $port, $cmd;
|
||||
}
|
||||
|
||||
sub reconfig {
|
||||
my ($self, $domain) = @_;
|
||||
|
||||
my $cmd = "rndc reconfig ";
|
||||
|
||||
my $user = get_user_from_cfg($$self{mycfg});
|
||||
my $host = get_host_from_cfg($$self{mycfg});
|
||||
my $port = get_port_from_cfg($$self{mycfg});
|
||||
|
||||
remotecmd $user, $host, $port, $cmd;
|
||||
}
|
||||
|
||||
sub delzone {
|
||||
my ($self, $domain) = @_;
|
||||
|
||||
my $cmd = "rndc delzone $domain ";
|
||||
|
||||
my $user = get_user_from_cfg($$self{mycfg});
|
||||
my $host = get_host_from_cfg($$self{mycfg});
|
||||
my $port = get_port_from_cfg($$self{mycfg});
|
||||
|
||||
remotecmd $user, $host, $port, $cmd;
|
||||
|
||||
my $file = get_zonedir_from_cfg($$self{mycfg});
|
||||
$file .= "/$domain";
|
||||
|
||||
$cmd = "rm $file";
|
||||
|
||||
remotecmd $user, $host, $port, $cmd
|
||||
}
|
||||
|
||||
1;
|
||||
@ -1,6 +1,6 @@
|
||||
package app::interface::knot;
|
||||
use v5.14;
|
||||
package app::zone::knot_interface;
|
||||
use Moose;
|
||||
use Moo;
|
||||
|
||||
# on suppose que tout est déjà mis à jour dans le fichier
|
||||
sub reload {
|
||||
90
lib/interface/nsd3.pm
Normal file
90
lib/interface/nsd3.pm
Normal file
@ -0,0 +1,90 @@
|
||||
package interface::nsd3;
|
||||
use v5.14;
|
||||
use Moo;
|
||||
use URI;
|
||||
use fileutil ':all';
|
||||
use remotecmd ':all';
|
||||
use copycat ':all';
|
||||
use configuration ':all';
|
||||
|
||||
has [ qw/mycfg tmpdir primarydnsserver secondarydnsserver/ ] => qw/is ro required 1/;
|
||||
|
||||
# on suppose que tout est déjà mis à jour dans le fichier
|
||||
sub reload_sec {
|
||||
my ($self, $slavedzones) = @_;
|
||||
|
||||
$self->_reload_conf($slavedzones);
|
||||
|
||||
my $cmd = "sudo nsdc rebuild && "
|
||||
. " sudo nsdc restart ";
|
||||
|
||||
my $user = get_user_from_cfg($$self{mycfg});
|
||||
my $host = get_host_from_cfg($$self{mycfg});
|
||||
my $port = get_port_from_cfg($$self{mycfg});
|
||||
|
||||
remotecmd $user, $host, $port, $cmd
|
||||
}
|
||||
|
||||
# get, modify, push the file
|
||||
|
||||
sub _reload_conf {
|
||||
my ($self, $slavedzones) = @_;
|
||||
|
||||
my $f = "file://$$self{tmpdir}/nsd.conf";
|
||||
my $remote = ($$self{mycfg}{cfg}) ? $$self{mycfg}{cfg} : undef;
|
||||
|
||||
my $user = get_user_from_cfg($$self{mycfg});
|
||||
my $host = get_host_from_cfg($$self{mycfg});
|
||||
my $port = get_port_from_cfg($$self{mycfg});
|
||||
|
||||
$remote //= "ssh://$user". '@' . "$host/etc/nsd/nsd.conf";
|
||||
|
||||
copycat $remote, $f;
|
||||
|
||||
my $data = read_file $f;
|
||||
my $debut = "## BEGIN_GENERATED";
|
||||
my $nouveau = '';
|
||||
my $dnsslavekey = get_dnsslavekey_from_cfg($$self{primarydnsserver});
|
||||
|
||||
for(@{$slavedzones}) {
|
||||
|
||||
$nouveau .= "zone:\n\n\tname: \"$_\"\n"
|
||||
. "\tzonefile: \"slave/$_\"\n\n";
|
||||
|
||||
my $v4 = get_v4_from_cfg($$self{primarydnsserver});
|
||||
my $v6 = get_v6_from_cfg($$self{primarydnsserver});
|
||||
|
||||
if($v4) {
|
||||
# allow notify & request xfr, v4 & v6
|
||||
$nouveau .= "\tallow-notify: $v4 $dnsslavekey \n"
|
||||
. "\trequest-xfr: $v4 $dnsslavekey \n\n";
|
||||
}
|
||||
|
||||
if($v6) {
|
||||
$nouveau .= "\tallow-notify: $v6 $dnsslavekey \n"
|
||||
. "\trequest-xfr: $v6 $dnsslavekey \n\n";
|
||||
}
|
||||
}
|
||||
|
||||
$data =~ s/$debut.*/$debut\n$nouveau/gsm;
|
||||
|
||||
write_file $f, $data;
|
||||
copycat $f, $remote;
|
||||
|
||||
my $cmd = "sudo nsdc patch && "
|
||||
. " sudo rm /var/nsd3/ixfr.db";
|
||||
|
||||
remotecmd $user, $host, $port, $cmd;
|
||||
}
|
||||
|
||||
sub reconfig {
|
||||
my ($self, $zname) = @_;
|
||||
die "nsd3 reconfig not implemented.";
|
||||
}
|
||||
|
||||
sub delzone {
|
||||
my ($self) = @_;
|
||||
die "nsd3 delzone not implemented.";
|
||||
}
|
||||
|
||||
1;
|
||||
125
lib/interface/nsd4.pm
Normal file
125
lib/interface/nsd4.pm
Normal file
@ -0,0 +1,125 @@
|
||||
package interface::nsd4;
|
||||
use v5.14;
|
||||
use Moo;
|
||||
use URI;
|
||||
use fileutil ':all';
|
||||
use remotecmd ':all';
|
||||
use copycat ':all';
|
||||
use configuration ':all';
|
||||
|
||||
has [ qw/mycfg tmpdir primarydnsserver secondarydnsserver/ ] => qw/is ro required 1/;
|
||||
|
||||
# on suppose que tout est déjà mis à jour dans le fichier
|
||||
sub reload_sec {
|
||||
my ($self, $slavedzones) = @_;
|
||||
|
||||
$self->_reload_conf($slavedzones);
|
||||
|
||||
my $cmd = "sudo nsd-control reconfig";
|
||||
|
||||
my $user = get_user_from_cfg($$self{mycfg});
|
||||
my $host = get_host_from_cfg($$self{mycfg});
|
||||
my $port = get_port_from_cfg($$self{mycfg});
|
||||
|
||||
remotecmd $user, $host, $port, $cmd
|
||||
}
|
||||
|
||||
# get, modify, push the file
|
||||
|
||||
sub _reload_conf {
|
||||
my ($self, $slavedzones) = @_;
|
||||
|
||||
my $f = "file://$$self{tmpdir}/nsd.conf";
|
||||
my $remote = ($$self{mycfg}{cfg}) ? $$self{mycfg}{cfg} : undef;
|
||||
|
||||
my $user = get_user_from_cfg($$self{mycfg});
|
||||
my $host = get_host_from_cfg($$self{mycfg});
|
||||
my $port = get_port_from_cfg($$self{mycfg});
|
||||
|
||||
$remote //= "ssh://$user". '@' . "$host/etc/nsd/nsd.conf";
|
||||
|
||||
copycat $remote, $f;
|
||||
|
||||
my $data = read_file $f;
|
||||
|
||||
# if it's the first time we get the configuration, fresh start
|
||||
$data .= "\n## BEGIN_GENERATED" if( $data !~ /BEGIN_GENERATED/);
|
||||
|
||||
my $v4 = get_v4_from_cfg($$self{primarydnsserver});
|
||||
my $v6 = get_v6_from_cfg($$self{primarydnsserver});
|
||||
|
||||
my $debut = "## BEGIN_GENERATED";
|
||||
|
||||
my $nouveau = '';
|
||||
my $dnsslavekey = get_dnsslavekey_from_cfg($$self{primarydnsserver});
|
||||
|
||||
# $nouveau .= "
|
||||
#remote-control:
|
||||
# control-enable: yes
|
||||
# control-interface: 127.0.0.1
|
||||
# control-port: 8952
|
||||
# server-key-file: '/etc/nsd/nsd_server.key'
|
||||
# server-cert-file: '/etc/nsd/nsd_server.pem'
|
||||
# control-key-file: '/etc/nsd/nsd_control.key'
|
||||
# control-cert-file: '/etc/nsd/nsd_control.pem'
|
||||
#
|
||||
#key:
|
||||
#
|
||||
## pattern : configuration to reproduce on every slaves
|
||||
$nouveau .= "
|
||||
pattern:
|
||||
\tname: 'slavepattern'
|
||||
";
|
||||
|
||||
if($v4) {
|
||||
# allow notify & request xfr, v4 & v6
|
||||
$nouveau .= "\tallow-notify: $v4 \"$dnsslavekey\" \n"
|
||||
. "\trequest-xfr: $v4 \"$dnsslavekey\" \n";
|
||||
}
|
||||
|
||||
if($v6) {
|
||||
$nouveau .= "\tallow-notify: $v6 \"$dnsslavekey\" \n"
|
||||
. "\trequest-xfr: $v6 \"$dnsslavekey\" \n";
|
||||
}
|
||||
|
||||
$nouveau .= "\n";
|
||||
|
||||
for(@{$slavedzones}) {
|
||||
|
||||
$nouveau .= "zone:\n\tname: \"$$_{domain}\"\n"
|
||||
. "\tzonefile: \"slave/$$_{domain}\"\n";
|
||||
$nouveau .= "\tinclude-pattern: 'slavepattern'\n\n";
|
||||
}
|
||||
|
||||
$data =~ s/$debut.*/$debut\n$nouveau/gsm;
|
||||
|
||||
write_file $f, $data;
|
||||
copycat $f, $remote;
|
||||
|
||||
my $cmd = "sudo nsd-control reconfig";
|
||||
|
||||
remotecmd $user, $host, $port, $cmd
|
||||
}
|
||||
|
||||
sub reconfig {
|
||||
my ($self, $zname) = @_;
|
||||
|
||||
my $user = get_user_from_cfg($$self{mycfg});
|
||||
my $host = get_host_from_cfg($$self{mycfg});
|
||||
my $port = get_port_from_cfg($$self{mycfg});
|
||||
my $cmd = "sudo nsd-control reconfig";
|
||||
remotecmd $user, $host, $port, $cmd
|
||||
}
|
||||
|
||||
sub delzone {
|
||||
my ($self) = @_;
|
||||
|
||||
my $user = get_user_from_cfg($$self{mycfg});
|
||||
my $host = get_host_from_cfg($$self{mycfg});
|
||||
my $port = get_port_from_cfg($$self{mycfg});
|
||||
my $cmd = "sudo nsd-control reconfig";
|
||||
remotecmd $user, $host, $port, $cmd;
|
||||
#die "nsd4 delzone not implemented.";
|
||||
}
|
||||
|
||||
1;
|
||||
35
lib/remotecmd.pm
Normal file
35
lib/remotecmd.pm
Normal file
@ -0,0 +1,35 @@
|
||||
package remotecmd;
|
||||
use v5.14;
|
||||
|
||||
use Net::OpenSSH;
|
||||
use Net::SSH q<sshopen2>;
|
||||
|
||||
use Exporter 'import';
|
||||
# what we want to export eventually
|
||||
our @EXPORT_OK = qw/remotecmd/;
|
||||
|
||||
# bundle of exports (tags)
|
||||
our %EXPORT_TAGS = ( all => [qw/remotecmd/] );
|
||||
|
||||
sub remotecmd {
|
||||
my ($user, $host, $port, $cmd) = @_;
|
||||
|
||||
#sshopen2("-p '$port' $user\@$host", *READER, *WRITER, "$cmd")
|
||||
#|| die "ssh: $!";
|
||||
|
||||
#system("ssh -p '$port' '$user". '@'. "$host' '$cmd'");
|
||||
|
||||
#my $ret = '';
|
||||
#$ret .= $_ while(<READER>);
|
||||
|
||||
#close(READER);
|
||||
#close(WRITER);
|
||||
|
||||
my $str = "ssh -p $port $user". '@' . "$host '$cmd'";
|
||||
say "";
|
||||
say "CMD : $str";
|
||||
say "";
|
||||
qx/$str/;
|
||||
}
|
||||
|
||||
1;
|
||||
46
lib/rt/admin.pm
Normal file
46
lib/rt/admin.pm
Normal file
@ -0,0 +1,46 @@
|
||||
package rt::admin;
|
||||
|
||||
use configuration ':all';
|
||||
use app;
|
||||
use utf8;
|
||||
|
||||
use Exporter 'import';
|
||||
# what we want to export eventually
|
||||
our @EXPORT_OK = qw/rt_admin/;
|
||||
|
||||
# bundle of exports (tags)
|
||||
our %EXPORT_TAGS = ( all => [qw/rt_admin/] );
|
||||
|
||||
sub rt_admin {
|
||||
my ($session, $param, $request) = @_;
|
||||
my $res;
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
my $user = $app->auth($$session{login}, $$session{passwd});
|
||||
|
||||
unless ($user && $$user{admin}) {
|
||||
$$res{deferred}{errmsg} = q{Donnée privée, petit coquin. ;) };
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
my $alldomains = $app->get_all_domains;
|
||||
my $allusers = $app->get_all_users;
|
||||
my $domains = $app->get_domains($$session{login});
|
||||
|
||||
$$res{template} = 'administration';
|
||||
$$res{params} = {
|
||||
login => $$session{login}
|
||||
, admin => 1 # we know it, or we couldn't reach this
|
||||
, domains => $domains
|
||||
, alldomains => $alldomains
|
||||
, allusers => $allusers
|
||||
};
|
||||
$app->disconnect();
|
||||
};
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
1;
|
||||
502
lib/rt/domain.pm
Normal file
502
lib/rt/domain.pm
Normal file
@ -0,0 +1,502 @@
|
||||
package rt::domain;
|
||||
|
||||
use v5.14;
|
||||
use configuration ':all';
|
||||
use encryption ':all';
|
||||
use util ':all';
|
||||
use app;
|
||||
use utf8;
|
||||
use Dancer ':syntax';
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use Exporter 'import';
|
||||
# what we want to export eventually
|
||||
our @EXPORT_OK = qw/
|
||||
rt_dom_cli_mod_entry
|
||||
rt_dom_mod_entry
|
||||
rt_dom_del_entry
|
||||
rt_dom_del
|
||||
rt_dom_add
|
||||
rt_dom_details
|
||||
rt_dom_update
|
||||
rt_dom_updateraw
|
||||
/;
|
||||
|
||||
# bundle of exports (tags)
|
||||
our %EXPORT_TAGS = ( all => [qw/
|
||||
rt_dom_cli_mod_entry
|
||||
rt_dom_mod_entry
|
||||
rt_dom_del_entry
|
||||
rt_dom_del
|
||||
rt_dom_add
|
||||
rt_dom_details
|
||||
rt_dom_update
|
||||
rt_dom_updateraw
|
||||
/] );
|
||||
|
||||
sub rt_dom_cli_mod_entry {
|
||||
my ($session, $param, $request) = @_;
|
||||
my $res;
|
||||
|
||||
eval {
|
||||
my $pass = encrypt($$param{pass});
|
||||
my $app = app->new(get_cfg());
|
||||
|
||||
my $user = $app->auth($$session{login}, $pass);
|
||||
|
||||
unless ( $user && ( $$user{admin} ||
|
||||
$app->is_owning_domain($$user{login}, $$param{domain}))) {
|
||||
$app->disconnect();
|
||||
$$res{deferred}{errmsg} = q{Donnée privée, petit coquin. ;) };
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
$app->modify_entry( $$param{domain}
|
||||
, {
|
||||
type => $$param{type}
|
||||
, name => $$param{name}
|
||||
, host => $$param{host}
|
||||
, ttl => $$param{ttl}
|
||||
}
|
||||
, {
|
||||
newtype => $$param{type}
|
||||
, newname => $$param{name}
|
||||
, newhost => $$param{ip}
|
||||
, newttl => $$param{ttl}
|
||||
, newpriority => ''
|
||||
});
|
||||
|
||||
$app->disconnect();
|
||||
};
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
sub rt_dom_mod_entry {
|
||||
my ($session, $param, $request) = @_;
|
||||
my $res;
|
||||
|
||||
$$res{route} = '/domain/details/'. $$param{domain};
|
||||
|
||||
# check if user is logged
|
||||
unless( $$session{login}) {
|
||||
$$res{deferred}{errmsg} = q{Vous n'êtes pas enregistré. };
|
||||
$$res{sessiondestroy} = 1;
|
||||
return $res;
|
||||
}
|
||||
|
||||
my @missingitems;
|
||||
|
||||
for(qw/type name ttl domain name type host ttl
|
||||
newtype newhost newname newttl/) {
|
||||
push @missingitems, $_ unless($$param{$_});
|
||||
}
|
||||
|
||||
if($$param{type} eq 'MX' && ! $$param{newpriority}) {
|
||||
push @missingitems, "newpriority";
|
||||
}
|
||||
|
||||
if(@missingitems != 0) {
|
||||
$$res{deferred}{errmsg} = "Il manque : " . join ', ', @missingitems;
|
||||
return $res;
|
||||
}
|
||||
|
||||
for(qw/type name ttl domain name type host ttl
|
||||
newpriority newtype newhost newname newttl/) {
|
||||
say "$_ : $$param{$_}" if $$param{$_};
|
||||
}
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
my $user = $app->auth($$session{login}, $$session{passwd});
|
||||
|
||||
unless ( $user && ( $$user{admin} ||
|
||||
$app->is_owning_domain($$user{login}, $$param{domain}))) {
|
||||
$app->disconnect();
|
||||
$$res{deferred}{errmsg} = q{Donnée privée, petit coquin. ;) };
|
||||
return $res;
|
||||
}
|
||||
|
||||
unless( $$param{domain} ) {
|
||||
$$res{deferred}{errmsg} = q<Domaine non renseigné.>;
|
||||
$$res{route} = ($$request{referer}) ? $$request{referer} : '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
$app->modify_entry( $$param{domain}
|
||||
, {
|
||||
type => $$param{type}
|
||||
, name => $$param{name}
|
||||
, host => $$param{host}
|
||||
, ttl => $$param{ttl}
|
||||
}
|
||||
, {
|
||||
newtype => $$param{newtype}
|
||||
, newname => $$param{newname}
|
||||
, newhost => $$param{newhost}
|
||||
, newttl => $$param{newttl}
|
||||
, newpriority => $$param{newpriority}
|
||||
});
|
||||
$app->disconnect();
|
||||
};
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
sub rt_dom_del_entry {
|
||||
my ($session, $param, $request) = @_;
|
||||
my $res;
|
||||
|
||||
eval {
|
||||
# Load :domain and search for corresponding data
|
||||
my $app = app->new(get_cfg());
|
||||
|
||||
my $user = $app->auth($$session{login}, $$session{passwd});
|
||||
|
||||
unless ( $user && ( $$user{admin} ||
|
||||
$app->is_owning_domain($$user{login}, $$param{domain}))) {
|
||||
$app->disconnect();
|
||||
$$res{deferred}{errmsg} = q{Donnée privée, petit coquin. ;) };
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
unless( $$param{domain} ) {
|
||||
$$res{deferred}{errmsg} = q{Domaine non renseigné.};
|
||||
$$res{route} = ($$request{referer}) ? $$request{referer} : '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
$app->delete_entry( $$param{domain}, {
|
||||
type => $$param{type},
|
||||
name => $$param{name},
|
||||
host => $$param{host},
|
||||
ttl => $$param{ttl}
|
||||
});
|
||||
$app->disconnect();
|
||||
};
|
||||
|
||||
$$res{route} = '/domain/details/'. $$param{domain};
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
sub rt_dom_del {
|
||||
my ($session, $param, $request) = @_;
|
||||
my $res;
|
||||
|
||||
unless( $$param{domain} ) {
|
||||
$$res{deferred}{errmsg} = q<Domaine non renseigné.>;
|
||||
$$res{route} = ($$request{referer}) ? $$request{referer} : '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
if( ! is_domain_name($$param{domain})) {
|
||||
$$res{deferred}{errmsg} = q<Domaine non conforme.>;
|
||||
$$res{route} = ($$request{referer}) ? $$request{referer} : '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
my $user = $app->auth($$session{login}, $$session{passwd});
|
||||
|
||||
unless ( $user && ( $$user{admin} ||
|
||||
$app->is_owning_domain($$user{login}, $$param{domain}))) {
|
||||
$app->disconnect();
|
||||
$$res{deferred}{errmsg} = q{Donnée privée, petit coquin. ;) };
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
$app->delete_domain($$param{domain});
|
||||
$app->disconnect();
|
||||
};
|
||||
|
||||
if($@) {
|
||||
$$res{deferred}{errmsg} = q{Impossible de supprimer le domaine. } . $@;
|
||||
$$res{route} = ($$request{referer}) ? $$request{referer} : '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
if( $$request{referer} =~ "/domain/details" ) {
|
||||
$$res{route} = '/user/home';
|
||||
}
|
||||
else {
|
||||
$$res{route} = $$request{referer};
|
||||
}
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
sub rt_dom_add {
|
||||
my ($session, $param) = @_;
|
||||
my $res;
|
||||
|
||||
$$res{route} = '/user/home';
|
||||
|
||||
# check if user is logged
|
||||
unless( $$session{login}) {
|
||||
$$res{deferred}{errmsg} = q{Vous n'êtes pas enregistré. };
|
||||
$$res{sessiondestroy} = 1;
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
# check if domain parameter is set
|
||||
unless( $$param{domain} && length $$param{domain} > 0) {
|
||||
$$res{deferred}{errmsg} =
|
||||
q{Domaine personnel non renseigné correctement. };
|
||||
return $res;
|
||||
}
|
||||
|
||||
# check if tld parameter is set
|
||||
unless( $$param{tld} && length $$param{tld} > 0) {
|
||||
$$res{deferred}{errmsg} = q{Choix du domaine non fait. };
|
||||
return $res;
|
||||
}
|
||||
|
||||
if(is_reserved($$param{domain})) {
|
||||
$$res{deferred}{errmsg} = q{Nom de domaine réservé. };
|
||||
}
|
||||
elsif ( ! is_domain_name($$param{domain}) ) {
|
||||
$$res{deferred}{errmsg} =
|
||||
q{Nom de domaine choisi comportant des caractères invalides. };
|
||||
}
|
||||
elsif ( ! is_valid_tld($$param{tld}) ) {
|
||||
$$res{deferred}{errmsg} =
|
||||
q{Mauvais choix de domaine. };
|
||||
}
|
||||
else {
|
||||
|
||||
my $domain = $$param{domain} . $$param{tld};
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
my $user = $app->auth($$session{login}, $$session{passwd});
|
||||
$app->add_domain( $$user{login}, $domain );
|
||||
|
||||
$$res{addsession}{domainName} = $$param{domain};
|
||||
$$res{deferred}{succmsg} =
|
||||
q{Le nom de domaine a bien été réservé ! };
|
||||
|
||||
$app->disconnect();
|
||||
};
|
||||
|
||||
if( $@ ) {
|
||||
$$res{deferred}{errmsg} = q{Une erreur est survenue. } . $@;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
sub rt_dom_details {
|
||||
my ($session, $param, $request) = @_;
|
||||
my $res;
|
||||
|
||||
# check if user is logged & if domain parameter is set
|
||||
unless($$session{login}) {
|
||||
$$res{deferred}{errmsg} = q{Session inactive.};
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
unless($$param{domain}) {
|
||||
$$res{deferred}{errmsg} = q{Domaine non renseigné.};
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
my $app;
|
||||
eval {
|
||||
$app = app->new(get_cfg());
|
||||
|
||||
my $user = $app->auth($$session{login}, $$session{passwd});
|
||||
|
||||
unless ( $user && ( $$user{admin} ||
|
||||
$app->is_owning_domain($$user{login}, $$param{domain}))) {
|
||||
$app->disconnect();
|
||||
$$res{deferred}{errmsg} = q{Donnée privée, petit coquin. ;) };
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
my $zone = $app->get_domain($$param{domain});
|
||||
|
||||
$app->disconnect();
|
||||
|
||||
$$res{template} = 'details';
|
||||
$$res{params} = {
|
||||
login => $$session{login}
|
||||
, admin => $$user{admin}
|
||||
, domain => $$param{domain}
|
||||
, domain_zone => $zone->output()
|
||||
, user_ip => $$request{address}
|
||||
};
|
||||
|
||||
if($$param{expert}) {
|
||||
$$res{params}{expert} = 1;
|
||||
}
|
||||
else {
|
||||
$$res{params}{a} = $zone->a();
|
||||
$$res{params}{aaaa} = $zone->aaaa();
|
||||
$$res{params}{cname} = $zone->cname();
|
||||
$$res{params}{ptr} = $zone->ptr();
|
||||
$$res{params}{mx} = $zone->mx();
|
||||
$$res{params}{ns} = $zone->ns();
|
||||
|
||||
for(qw/a aaaa cname ptr mx ns/) {
|
||||
my $t = $_;
|
||||
map { $$_{type} = uc $t } @{$$res{params}{$t}};
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
if($@) {
|
||||
$app->disconnect() if $app;
|
||||
$$res{deferred}{errmsg} = $@;
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
sub rt_dom_update {
|
||||
my ($session, $param) = @_;
|
||||
my $res;
|
||||
|
||||
unless( $$session{login} && $$param{domain} ) {
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
$$res{route} = '/domain/details/'. $$param{domain};
|
||||
|
||||
my @missingitems;
|
||||
|
||||
for(qw/type name value ttl domain/) {
|
||||
push @missingitems, $_ unless($$param{$_});
|
||||
}
|
||||
|
||||
if($$param{type} eq 'MX' && ! $$param{priority}) {
|
||||
push @missingitems, "priority";
|
||||
}
|
||||
|
||||
if(@missingitems != 0) {
|
||||
$$res{deferred}{errmsg} = "Il manque : " . join ', ', @missingitems;
|
||||
return $res;
|
||||
}
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
my $user = $app->auth($$session{login}, $$session{passwd});
|
||||
|
||||
unless ( $user && ( $$user{admin} ||
|
||||
$app->is_owning_domain($$user{login}, $$param{domain}))) {
|
||||
$app->disconnect();
|
||||
$$res{deferred}{errmsg} = q{Donnée privée, petit coquin. ;) };
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
my $zone = $app->get_domain( $$param{domain} );
|
||||
|
||||
# TODO better naming convention
|
||||
my $entries;
|
||||
for( $$param{type} ) {
|
||||
if($_ eq 'A') { $entries = $zone->a }
|
||||
elsif( $_ eq 'AAAA') { $entries = $zone->aaaa }
|
||||
elsif( $_ eq 'CNAME') { $entries = $zone->cname }
|
||||
elsif( $_ eq 'MX') { $entries = $zone->mx }
|
||||
elsif( $_ eq 'PTR') { $entries = $zone->ptr }
|
||||
elsif( $_ eq 'NS') { $entries = $zone->ns }
|
||||
elsif( $_ eq 'TXT') { $entries = $zone->txt } # TODO verify this
|
||||
}
|
||||
|
||||
my $new_entry = {
|
||||
name => $$param{name}
|
||||
, class => "IN"
|
||||
, host => $$param{value}
|
||||
, ttl => $$param{ttl}
|
||||
, ORIGIN => $zone->origin
|
||||
};
|
||||
|
||||
$$new_entry{priority} = $$param{priority} if $$param{type} eq 'MX';
|
||||
push @$entries, $new_entry;
|
||||
|
||||
$zone->new_serial();
|
||||
|
||||
$app->update_domain( $zone , $$param{domain} );
|
||||
$app->disconnect();
|
||||
};
|
||||
|
||||
if ( $@ ) {
|
||||
$$res{deferred}{errmsg} = q{Problème de mise à jour du domaine. }. $@;
|
||||
}
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
sub rt_dom_updateraw {
|
||||
my ($session, $param, $request) = @_;
|
||||
my $res;
|
||||
|
||||
# check if user is logged & if domain parameter is set
|
||||
unless($$session{login} && $$param{domain}) {
|
||||
$$res{sessiondestroy} = 1;
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
my @missingitems;
|
||||
|
||||
for(qw/domain zoneupdated/) {
|
||||
push @missingitems, $_ unless($$param{$_});
|
||||
}
|
||||
|
||||
if(@missingitems != 0) {
|
||||
$$res{deferred}{errmsg} = "Il manque : " . join ', ', @missingitems;
|
||||
$$res{route} = '/user/home';
|
||||
return $res;
|
||||
}
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
my $user = $app->auth($$session{login}, $$session{passwd});
|
||||
|
||||
# if the user exists and if
|
||||
# he is admin or he owns the requested domain
|
||||
unless ( $user && ( $$user{admin} ||
|
||||
$app->is_owning_domain($$user{login}, $$param{domain}))) {
|
||||
$app->disconnect();
|
||||
$$res{deferred}{errmsg} = q{Donnée privée, petit coquin. ;) };
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
else {
|
||||
my $success =
|
||||
$app->update_domain_raw($$param{zoneupdated}, $$param{domain});
|
||||
|
||||
unless($success) {
|
||||
$$res{deferred}{errmsg} = q{Problème de mise à jour du domaine.};
|
||||
}
|
||||
|
||||
$$res{route} = '/domain/details/' . $$param{domain};
|
||||
}
|
||||
|
||||
$app->disconnect();
|
||||
};
|
||||
|
||||
if($@) {
|
||||
$$res{deferred}{errmsg} = $@;
|
||||
$$res{route} = '/user/home';
|
||||
}
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
1;
|
||||
45
lib/rt/root.pm
Normal file
45
lib/rt/root.pm
Normal file
@ -0,0 +1,45 @@
|
||||
package rt::root;
|
||||
|
||||
use configuration ':all';
|
||||
use app;
|
||||
use utf8;
|
||||
|
||||
use Exporter 'import';
|
||||
# what we want to export eventually
|
||||
our @EXPORT_OK = qw/rt_root/;
|
||||
|
||||
# bundle of exports (tags)
|
||||
our %EXPORT_TAGS = ( all => [qw/rt_root/] );
|
||||
|
||||
sub rt_root {
|
||||
my ($session) = @_;
|
||||
my $res;
|
||||
|
||||
$$res{template} = 'index';
|
||||
|
||||
if( exists $$session{login} && length $$session{login} > 0) {
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
my $user = $app->auth($$session{login}, $$session{passwd});
|
||||
|
||||
if( $user ) {
|
||||
$$res{params} = {
|
||||
login => $$session{login}
|
||||
, admin => $$user{admin}
|
||||
, domains => $$user{domains}
|
||||
};
|
||||
}
|
||||
$app->disconnect();
|
||||
};
|
||||
|
||||
if( $@ ) {
|
||||
$$res{deferred}{errmsg} = q{Une erreur est survenue. } . $@;
|
||||
$$res{sessiondestroy} = 1;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
1;
|
||||
255
lib/rt/user.pm
Normal file
255
lib/rt/user.pm
Normal file
@ -0,0 +1,255 @@
|
||||
package rt::user;
|
||||
|
||||
use v5.14;
|
||||
use configuration ':all';
|
||||
use encryption ':all';
|
||||
use app;
|
||||
use utf8;
|
||||
|
||||
use YAML::XS;
|
||||
|
||||
use Exporter 'import';
|
||||
# what we want to export eventually
|
||||
our @EXPORT_OK = qw/
|
||||
rt_user_login
|
||||
rt_user_del
|
||||
rt_user_toggleadmin
|
||||
rt_user_subscribe
|
||||
rt_user_add
|
||||
rt_user_home
|
||||
/;
|
||||
|
||||
# bundle of exports (tags)
|
||||
our %EXPORT_TAGS = ( all => [qw/
|
||||
rt_user_login
|
||||
rt_user_del
|
||||
rt_user_toggleadmin
|
||||
rt_user_subscribe
|
||||
rt_user_add
|
||||
rt_user_home
|
||||
/] );
|
||||
|
||||
sub rt_user_login {
|
||||
my ($session, $param, $request) = @_;
|
||||
my $res;
|
||||
|
||||
# Check if user is already logged
|
||||
if ( exists $$session{login} && length $$session{login} > 0 ) {
|
||||
$$res{deferred}{errmsg} = q{Vous êtes déjà connecté.};
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
# Check user login and password
|
||||
unless ( exists $$param{login}
|
||||
&& exists $$param{password}
|
||||
&& length $$param{login} > 0
|
||||
&& length $$param{password} > 0 ) {
|
||||
$$res{deferred}{errmsg} = q{Vous n'avez pas renseigné tous les paramètres.};
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
my $pass = encrypt($$param{password});
|
||||
my $user = $app->auth($$param{login}, $pass);
|
||||
|
||||
unless( $user ) {
|
||||
$$res{deferred}{errmsg} =
|
||||
q{Impossible de se connecter (login ou mot de passe incorrect).};
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
$$res{addsession}{login} = $$param{login};
|
||||
$$res{addsession}{passwd} = $pass;
|
||||
# TODO adds a freeze feature, not used for now
|
||||
# $$res{addsession}{user} = freeze( $user );
|
||||
|
||||
if( $$user{admin} ) {
|
||||
$$res{route} = '/admin';
|
||||
}
|
||||
else {
|
||||
$$res{route} = '/user/home';
|
||||
}
|
||||
|
||||
$app->disconnect();
|
||||
};
|
||||
|
||||
if( $@ ) {
|
||||
$$res{deferred}{errmsg} = q{Impossible de se connecter ! } . $@;
|
||||
$$res{sessiondestroy} = 1;
|
||||
$$res{route} = '/';
|
||||
}
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
sub rt_user_del {
|
||||
my ($session, $param, $request) = @_;
|
||||
my $res;
|
||||
|
||||
unless ( $$param{user} ) {
|
||||
$$res{deferred}{errmsg} = q{Le nom d'utilisateur n'est pas renseigné.};
|
||||
return $res;
|
||||
}
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
|
||||
my $user = $app->auth($$session{login}, $$session{passwd});
|
||||
|
||||
if ( $user && $$user{admin} || $$session{login} eq $$param{user} ) {
|
||||
$app->delete_user($$param{user});
|
||||
}
|
||||
$app->disconnect();
|
||||
};
|
||||
|
||||
if ( $@ ) {
|
||||
$$res{deferred}{errmsg} =
|
||||
"L'utilisateur $$res{user} n'a pas pu être supprimé. $@";
|
||||
}
|
||||
|
||||
if( $$request{referer} ) {
|
||||
$$res{route} = $$request{referer};
|
||||
}
|
||||
else {
|
||||
$$res{route} = '/';
|
||||
}
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
sub rt_user_toggleadmin {
|
||||
my ($session, $param, $request) = @_;
|
||||
my $res;
|
||||
|
||||
unless( $$param{user} ) {
|
||||
$$res{deferred}{errmsg} = q{L'utilisateur n'est pas défini.};
|
||||
$$res{route} = $$request{referer};
|
||||
return $res;
|
||||
}
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
|
||||
my $user = $app->auth($$session{login}, $$session{passwd});
|
||||
|
||||
unless ( $user && $$user{admin} ) {
|
||||
$$res{deferred}{errmsg} = q{Vous n'êtes pas administrateur.};
|
||||
return $res;
|
||||
}
|
||||
|
||||
$app->toggle_admin($$param{user});
|
||||
$app->disconnect();
|
||||
};
|
||||
|
||||
if( $$request{referer} =~ '/admin' ) {
|
||||
$$res{route} = $$request{referer};
|
||||
}
|
||||
else {
|
||||
$$res{route} = '/';
|
||||
}
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
sub rt_user_subscribe {
|
||||
my ($session, $param, $request) = @_;
|
||||
my $res;
|
||||
|
||||
if( $$session{login} ) {
|
||||
$$res{route} = '/user/home';
|
||||
}
|
||||
else {
|
||||
$$res{template} = 'subscribe';
|
||||
}
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
sub rt_user_add {
|
||||
my ($session, $param, $request) = @_;
|
||||
my $res;
|
||||
|
||||
unless ( $$param{login} && $$param{password} && $$param{password2} ) {
|
||||
$$res{deferred}{errmsg} = q{Identifiant ou mot de passe non renseigné.};
|
||||
$$res{route} = '/user/subscribe';
|
||||
return $res;
|
||||
}
|
||||
|
||||
unless ( $$param{password} eq $$param{password2} ) {
|
||||
$$res{deferred}{errmsg} = q{Les mots de passes ne sont pas identiques.};
|
||||
$$res{route} = '/user/subscribe';
|
||||
return $res;
|
||||
}
|
||||
|
||||
|
||||
eval {
|
||||
my $pass = encrypt($$param{password});
|
||||
|
||||
my $app = app->new(get_cfg());
|
||||
|
||||
$app->register_user($$param{login}, $pass);
|
||||
$app->disconnect();
|
||||
|
||||
$$res{addsession}{login} = $$param{login};
|
||||
$$res{addsession}{passwd} = $pass;
|
||||
$$res{route} = '/user/home';
|
||||
};
|
||||
|
||||
if($@) {
|
||||
$$res{deferred}{errmsg} = q{Ce pseudo est déjà pris.} . $@;
|
||||
$$res{route} = '/user/subscribe';
|
||||
return $res;
|
||||
}
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
sub rt_user_home {
|
||||
my ($session, $param, $request) = @_;
|
||||
my $res;
|
||||
|
||||
$$res{template} = 'home';
|
||||
|
||||
eval {
|
||||
my $app = app->new(get_cfg());
|
||||
|
||||
my $user = $app->auth($$session{login}, $$session{passwd});
|
||||
|
||||
unless( $user ) {
|
||||
$$res{deferred}{errmsg} = q{Problème de connexion à votre compte.};
|
||||
$$res{sessiondestroy} = 1;
|
||||
$$res{route} = '/';
|
||||
return $res;
|
||||
}
|
||||
|
||||
my $domains = $app->get_domains($$session{login});
|
||||
|
||||
my $dn = $$session{domainName};
|
||||
|
||||
#$$res{delsession}{domainName};
|
||||
|
||||
$$res{params} = {
|
||||
login => $$session{login}
|
||||
, admin => $$user{admin}
|
||||
, domains => $domains
|
||||
, provideddomains => $$app{tld}
|
||||
, domainName => $dn
|
||||
};
|
||||
|
||||
$app->disconnect();
|
||||
};
|
||||
|
||||
if( $@ ) {
|
||||
$$res{sessiondestroy} = 1;
|
||||
$$res{deferred}{errmsg} = q{On a chié quelque-part.} . $@;
|
||||
$$res{route} = '/';
|
||||
}
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
1;
|
||||
113
lib/testapp.pl
Normal file
113
lib/testapp.pl
Normal file
@ -0,0 +1,113 @@
|
||||
#!/usr/bin/perl -w
|
||||
use v5.14;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use File::Basename;
|
||||
use utf8;
|
||||
use YAML::XS;
|
||||
use configuration ':all';
|
||||
use util ':all';
|
||||
use app;
|
||||
|
||||
use rt::root ':all';
|
||||
use rt::domain ':all';
|
||||
use rt::user ':all';
|
||||
use rt::admin ':all';
|
||||
|
||||
#my $test_updateraw = sub {
|
||||
# rt_dom_updateraw
|
||||
# get_session( qw/login passwd/ )
|
||||
# , get_param( qw/domain zoneupdated/ ); # TODO verify this
|
||||
#};
|
||||
|
||||
my $test_update = sub {
|
||||
rt_dom_update
|
||||
{ qw/login test passwd test/ }
|
||||
, { qw/type A
|
||||
name www
|
||||
value 10.0.0.1
|
||||
ttl 100
|
||||
priority 1
|
||||
domain test.netlib.re./ };
|
||||
};
|
||||
|
||||
#my $test_detail = sub {
|
||||
# rt_dom_details
|
||||
# get_session( qw/login passwd/ )
|
||||
# , get_param( qw/domain expert/ )
|
||||
# , get_request( qw/address referer/ );
|
||||
#};
|
||||
|
||||
my $test_add_domain = sub {
|
||||
rt_dom_add
|
||||
{ qw/login test passwd test/}
|
||||
, { qw/domain test tld .netlib.re./ };
|
||||
};
|
||||
|
||||
my $test_del_domain = sub {
|
||||
rt_dom_del
|
||||
{ qw/login test passwd test/ }
|
||||
, { qw/domain test.netlib.re./ }
|
||||
, { qw/address referer/ }; # TODO
|
||||
};
|
||||
|
||||
#my $test_del_entry = sub {
|
||||
# rt_dom_del_entry
|
||||
# get_session( qw/login passwd/ )
|
||||
# , get_param( qw/domain name type host ttl/ )
|
||||
# , get_request( qw/address referer/ );
|
||||
#};
|
||||
|
||||
#my $test_mod_entry = sub {
|
||||
# rt_dom_mod_entry
|
||||
# get_session( qw/login passwd/ )
|
||||
# , get_param( qw/domain name type host ttl/ )
|
||||
# , get_request( qw/address referer/ );
|
||||
#};
|
||||
|
||||
my $test_cli_mod_entry = sub {
|
||||
rt_dom_cli_mod_entry
|
||||
get_session( qw/login/ )
|
||||
, get_param( qw/passwd domain name type host ttl ip/ );
|
||||
};
|
||||
|
||||
#any ['get', 'post'] => '/admin' => sub {
|
||||
# rt_admin
|
||||
# get_session( qw/login passwd/ );
|
||||
#};
|
||||
|
||||
#get '/home' => sub {
|
||||
# rt_user_home
|
||||
# get_session( qw/login passwd/ )
|
||||
# , get_param( qw// )
|
||||
# , get_request( qw// );
|
||||
#};
|
||||
|
||||
my $test_del_user = sub {
|
||||
rt_user_del
|
||||
get_session( qw/login passwd/ )
|
||||
, { qw/user test/ }
|
||||
, { qw/referer/ };
|
||||
};
|
||||
|
||||
my $test_add_user = sub {
|
||||
rt_user_add
|
||||
{ qw// }
|
||||
, { qw/login test password test password2 test/ }
|
||||
, { qw// };
|
||||
};
|
||||
|
||||
say "Tests - ";
|
||||
|
||||
# get '/subscribe' => sub {
|
||||
# rt_user_subscribe
|
||||
# get_session( qw/login/ );
|
||||
# };
|
||||
|
||||
#my $test_toggle_admin = sub {
|
||||
# rt_user_toggleadmin
|
||||
# { qw/login passwd/ }
|
||||
# , get_param( qw/user/ )
|
||||
# , get_request( qw/referer/ );
|
||||
#};
|
||||
31
lib/util.pm
Normal file
31
lib/util.pm
Normal file
@ -0,0 +1,31 @@
|
||||
package util;
|
||||
use v5.10;
|
||||
|
||||
use configuration ':all';
|
||||
use YAML::XS;
|
||||
use Exporter 'import';
|
||||
# what we want to export eventually
|
||||
our @EXPORT_OK = qw/is_domain_name is_valid_tld/;
|
||||
|
||||
# bundle of exports (tags)
|
||||
our %EXPORT_TAGS = ( all => [qw/is_domain_name is_valid_tld/] );
|
||||
|
||||
# TODO we can check if dn matches our domain name
|
||||
sub is_domain_name {
|
||||
my ($dn) = @_;
|
||||
my $ndd = qr/^
|
||||
([a-zA-Z0-9]+[a-zA-Z0-9-]*[a-zA-Z0-9]*[.])*
|
||||
[a-zA-Z0-9]+[a-zA-Z0-9-]*[a-zA-Z0-9]([.])?
|
||||
$/x;
|
||||
return $dn =~ $ndd;
|
||||
}
|
||||
|
||||
sub is_valid_tld {
|
||||
my ($tld) = @_;
|
||||
|
||||
my $cfg = get_cfg;
|
||||
|
||||
grep { $_ eq $tld } @{$$cfg{tld}};
|
||||
}
|
||||
|
||||
1;
|
||||
284
lib/zone.pm
Normal file
284
lib/zone.pm
Normal file
@ -0,0 +1,284 @@
|
||||
package zone;
|
||||
use v5.14;
|
||||
use Moo;
|
||||
|
||||
use Modern::Perl;
|
||||
|
||||
# TODO all this file is to redesign
|
||||
|
||||
use getiface ':all';
|
||||
use copycat ':all';
|
||||
use fileutil ':all';
|
||||
use configuration ':all';
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use zonefile;
|
||||
|
||||
# primary dns interface
|
||||
has dnsi => ( is => 'rw', builder => '_void_arr');
|
||||
|
||||
# dns interface for secondary name servers
|
||||
has dnsisec => ( is => 'rw', builder => '_void');
|
||||
|
||||
has [ qw/tld tmpdir domain primarydnsserver secondarydnsserver slavedzones/ ]
|
||||
=> qw/is ro required 1/;
|
||||
|
||||
sub _void { my $x = ''; \$x; }
|
||||
sub _void_arr { [] }
|
||||
|
||||
sub get_ztmp_file_ {my $s = shift; "$$s{tmpdir}/$$s{domain}" }
|
||||
sub get_ztpl_dir_ {my $s = shift; "$$s{dnsi}{mycfg}{zonedir}" }
|
||||
sub get_ztpl_file_ {
|
||||
my $s = shift;
|
||||
|
||||
# for each TLD
|
||||
for(@{$$s{tld}}) {
|
||||
# if our domain is part of this TLD, get the right template
|
||||
if($$s{domain} =~ $_) {
|
||||
return $s->get_ztpl_dir_() . '/' . $_ . '.tpl';
|
||||
}
|
||||
}
|
||||
|
||||
die "There is no template for $$s{domain}.";
|
||||
}
|
||||
|
||||
sub get_dnsserver_interface {
|
||||
my ($self, $dnsserver) = @_;
|
||||
my $cfg = {
|
||||
mycfg => $dnsserver
|
||||
, primarydnsserver => $$self{primarydnsserver}
|
||||
, secondarydnsserver => $$self{secondarydnsserver}
|
||||
, tmpdir => $$self{tmpdir}
|
||||
};
|
||||
|
||||
getiface $$dnsserver{app}, $cfg
|
||||
}
|
||||
|
||||
sub get_dns_server_interfaces {
|
||||
my $self = shift;
|
||||
my $primary = $$self{primarydnsserver};
|
||||
my $s = $$self{secondarydnsserver};
|
||||
|
||||
my $prim = $self->get_dnsserver_interface($primary);
|
||||
|
||||
my @sec;
|
||||
for(@{$s}) {
|
||||
push @sec, $self->get_dnsserver_interface($_);
|
||||
}
|
||||
|
||||
($prim, [ @sec ])
|
||||
}
|
||||
|
||||
sub BUILD {
|
||||
my $self = shift;
|
||||
($$self{dnsi}, $$self{dnsisec}) = $self->get_dns_server_interfaces()
|
||||
}
|
||||
|
||||
# change the origin in a zone file template
|
||||
sub mod_orig_template {
|
||||
my ($file, $domain) = @_;
|
||||
say "s/CHANGEMEORIGIN/$domain/ on $file";
|
||||
qx[sed -i "s/CHANGEMEORIGIN/$domain/" $file];
|
||||
}
|
||||
|
||||
sub get_remote_zf_ {
|
||||
my $self = shift;
|
||||
"$$self{dnsi}{mycfg}{zonedir}/$$self{domain}"
|
||||
}
|
||||
|
||||
sub are_same_records_ {
|
||||
my ($a, $b) = @_;
|
||||
|
||||
#debug({ a => $a });
|
||||
#debug({ b => $b });
|
||||
|
||||
#$a->{priority} eq $b->{priority} &&
|
||||
( $$a{name} eq $$b{name} &&
|
||||
$$a{host} eq $$b{host} &&
|
||||
$$a{ttl} == $$b{ttl} )
|
||||
}
|
||||
|
||||
# returns the lists of domains of a certain type
|
||||
sub get_records_ {
|
||||
my ($zone, $entry) = @_;
|
||||
|
||||
for( lc $$entry{type} ) {
|
||||
if ($_ eq 'a') { return $zone->a }
|
||||
elsif ($_ eq 'aaaa') { return $zone->aaaa }
|
||||
elsif ($_ eq 'cname') { return $zone->cname }
|
||||
elsif ($_ eq 'ns') { return $zone->ns }
|
||||
elsif ($_ eq 'mx') { return $zone->mx }
|
||||
elsif ($_ eq 'ptr') { return $zone->ptr }
|
||||
}
|
||||
|
||||
die 'Impossible to get the entry type.'
|
||||
}
|
||||
|
||||
sub reload_secondary_dns_servers {
|
||||
my $self = shift;
|
||||
$_->reload_sec($$self{slavedzones}) for(@{$$self{dnsisec}})
|
||||
}
|
||||
|
||||
sub delete_entry {
|
||||
my ($self, $entryToDelete) = @_;
|
||||
|
||||
my $zone = $self->get();
|
||||
|
||||
my $records = get_records_ $zone, $entryToDelete;
|
||||
|
||||
if( defined $records ) {
|
||||
foreach my $i ( 0 .. scalar @{$records}-1 ) {
|
||||
if(are_same_records_($records->[$i], $entryToDelete)) {
|
||||
delete $records->[$i];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$zone
|
||||
}
|
||||
|
||||
sub modify_entry {
|
||||
my ($self, $entryToModify, $newEntry) = @_;
|
||||
|
||||
my $zone = $self->get();
|
||||
|
||||
my $records = get_records_ $zone, $entryToModify;
|
||||
|
||||
if( defined $records ) {
|
||||
|
||||
foreach my $i ( 0 .. scalar @{$records}-1 ) {
|
||||
|
||||
if(are_same_records_($records->[$i], $entryToModify)) {
|
||||
|
||||
say "ENTRY TO MODIFY";
|
||||
|
||||
say $records->[$i]->{name} . ' = ' . $newEntry->{newname};
|
||||
say $records->[$i]->{host} . ' = ' . $newEntry->{newhost};
|
||||
say $records->[$i]->{ttl} . ' = ' . $newEntry->{newttl};
|
||||
#say $records->[$i]->{type} . ' = ' . $newEntry->{newtype};
|
||||
|
||||
$records->[$i]->{name} = $newEntry->{newname};
|
||||
$records->[$i]->{host} = $newEntry->{newhost};
|
||||
$records->[$i]->{ttl} = $newEntry->{newttl};
|
||||
#$records->[$i]->{type} = $newEntry->{newtype};
|
||||
|
||||
if( $$newEntry{newtype} eq 'MX' ) {
|
||||
say
|
||||
$records->[$i]->{priority}.' = '.$newEntry->{newpriority};
|
||||
$records->[$i]->{priority} = $newEntry->{newpriority};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
dump($records);
|
||||
|
||||
$zone
|
||||
}
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
my $file = $self->get_remote_zf_();
|
||||
my $dest = $self->get_ztmp_file_();
|
||||
|
||||
copycat ($file, $dest);
|
||||
|
||||
zonefile->new(domain => $$self{domain}, zonefile => $dest);
|
||||
}
|
||||
|
||||
=pod
|
||||
copie du template pour créer une nouvelle zone
|
||||
update du serial
|
||||
ajout de la zone via dnsapp (rndc, knot…)
|
||||
retourne la zone + le nom de la zone
|
||||
=cut
|
||||
|
||||
sub addzone {
|
||||
my ($self) = @_;
|
||||
|
||||
my $tpl = $self->get_ztpl_file_();
|
||||
my $tmpfile = $self->get_ztmp_file_();
|
||||
|
||||
copycat ($tpl, $tmpfile); # get the template
|
||||
|
||||
# get the file path
|
||||
my $f = URI->new($tmpfile);
|
||||
|
||||
# sed CHANGEMEORIGIN by the real origin
|
||||
mod_orig_template ($f->path, $$self{domain});
|
||||
|
||||
my $zonefile = zonefile->new(zonefile => $f->path
|
||||
, domain => $$self{domain});
|
||||
$zonefile->new_serial(); # update the serial number
|
||||
|
||||
# write the new zone tmpfile to disk
|
||||
write_file $f->path, $zonefile->output();
|
||||
|
||||
my $file = $self->get_remote_zf_();
|
||||
copycat ($tmpfile, $file); # put the final zone on the server
|
||||
unlink($f->path); # del the temporary file
|
||||
|
||||
# add new zone on the primary ns
|
||||
$self->dnsi->primary_addzone($$self{domain});
|
||||
|
||||
# add new zone on secondary ns
|
||||
$self->reload_secondary_dns_servers()
|
||||
}
|
||||
|
||||
=pod
|
||||
màj du serial
|
||||
push reload de la conf
|
||||
=cut
|
||||
|
||||
sub update {
|
||||
my ($self, $zonefile) = @_;
|
||||
|
||||
# update the serial number
|
||||
$zonefile->new_serial();
|
||||
|
||||
my $tmpfile = $self->get_ztmp_file_();
|
||||
|
||||
# write the new zone tmpfile to disk
|
||||
write_file $tmpfile, $zonefile->output();
|
||||
|
||||
my $file = $self->get_remote_zf_();
|
||||
copycat ($tmpfile, $file); # put the final zone on the server
|
||||
unlink($tmpfile); # del the temporary file
|
||||
|
||||
$self->dnsi->reload($$self{domain});
|
||||
}
|
||||
|
||||
=pod
|
||||
udpate via the raw content of the zonefile
|
||||
=cut
|
||||
|
||||
sub update_raw {
|
||||
my ($self, $zonetext) = @_;
|
||||
|
||||
my $zonefile;
|
||||
my $file = $self->get_ztmp_file_();
|
||||
|
||||
# write the updated zone file to disk
|
||||
write_file $file, $zonetext;
|
||||
|
||||
eval { $zonefile = zonefile->new(zonefile => $file
|
||||
, domain => $$self{domain}); };
|
||||
|
||||
if( $@ ) {
|
||||
unlink($file);
|
||||
die 'zone update_raw, zonefile->new error. ' . $@;
|
||||
}
|
||||
|
||||
unlink($file);
|
||||
|
||||
$self->update($zonefile)
|
||||
}
|
||||
|
||||
sub del {
|
||||
my ($self) = @_;
|
||||
$self->dnsi->delzone($$self{domain});
|
||||
$self->dnsi->reconfig();
|
||||
$self->reload_secondary_dns_servers()
|
||||
}
|
||||
|
||||
1;
|
||||
52
lib/zonefile.pm
Normal file
52
lib/zonefile.pm
Normal file
@ -0,0 +1,52 @@
|
||||
package zonefile;
|
||||
use v5.14;
|
||||
use Moo;
|
||||
use DNS::ZoneParse;
|
||||
|
||||
has zone => qw/is rw/ ;
|
||||
has [ qw/domain/ ] => qw/ is ro required 1/;
|
||||
has [ qw/zonefile/ ] => qw/ is rw required 1/;
|
||||
|
||||
sub BUILD {
|
||||
my ($self) = @_;
|
||||
|
||||
my $filename = $$self{zonefile};
|
||||
if($filename =~ "://")
|
||||
{
|
||||
my $fileuri = URI->new($filename);
|
||||
$filename = $fileuri->path;
|
||||
}
|
||||
|
||||
$$self{zone} = DNS::ZoneParse->new($filename, $$self{domain});
|
||||
}
|
||||
|
||||
sub new_serial {
|
||||
my $self = shift;
|
||||
$self->zone->new_serial();
|
||||
}
|
||||
|
||||
sub origin {
|
||||
my $self = shift;
|
||||
$self->zone->origin();
|
||||
}
|
||||
|
||||
sub output {
|
||||
my $self = shift;
|
||||
$self->zone->output();
|
||||
}
|
||||
|
||||
sub dump {
|
||||
my $self = shift;
|
||||
$self->zone->dump();
|
||||
}
|
||||
|
||||
# better encapsulation
|
||||
sub a { my $self = shift; $self->zone->a }
|
||||
sub aaaa { my $self = shift; $self->zone->aaaa }
|
||||
sub cname { my $self = shift; $self->zone->cname }
|
||||
sub ns { my $self = shift; $self->zone->ns }
|
||||
sub mx { my $self = shift; $self->zone->mx }
|
||||
sub ptr { my $self = shift; $self->zone->ptr }
|
||||
sub txt { my $self = shift; $self->zone->txt } # TODO TEST THIS
|
||||
|
||||
1;
|
||||
@ -12,7 +12,7 @@
|
||||
<h2>Page Not Found</h2><p>Sorry, this is the void.</p>
|
||||
</div>
|
||||
<div id="footer">
|
||||
Powered by <a href="http://perldancer.org/">Dancer</a>.
|
||||
Powered by <a href="http://perldancer.org/">Dancer2</a>.
|
||||
</div>
|
||||
</body>
|
||||
</html>
|
||||
@ -12,7 +12,7 @@
|
||||
<h2>Internal Server Error</h2><p>Wooops, something went wrong</p>
|
||||
</div>
|
||||
<div id="footer">
|
||||
Powered by <a href="http://perldancer.org/">Dancer</a>.
|
||||
Powered by <a href="http://perldancer.org/">Dancer2</a>.
|
||||
</div>
|
||||
</body>
|
||||
</html>
|
||||
70
public/css/error.css
Normal file
70
public/css/error.css
Normal file
@ -0,0 +1,70 @@
|
||||
body {
|
||||
font-family: Lucida,sans-serif;
|
||||
}
|
||||
|
||||
h1 {
|
||||
color: #AA0000;
|
||||
border-bottom: 1px solid #444;
|
||||
}
|
||||
|
||||
h2 { color: #444; }
|
||||
|
||||
pre {
|
||||
font-family: "lucida console","monaco","andale mono","bitstream vera sans mono","consolas",monospace;
|
||||
font-size: 12px;
|
||||
border-left: 2px solid #777;
|
||||
padding-left: 1em;
|
||||
}
|
||||
|
||||
footer {
|
||||
font-size: 10px;
|
||||
}
|
||||
|
||||
span.key {
|
||||
color: #449;
|
||||
font-weight: bold;
|
||||
width: 120px;
|
||||
display: inline;
|
||||
}
|
||||
|
||||
span.value {
|
||||
color: #494;
|
||||
}
|
||||
|
||||
/* these are for the message boxes */
|
||||
|
||||
pre.content {
|
||||
background-color: #eee;
|
||||
color: #000;
|
||||
padding: 1em;
|
||||
margin: 0;
|
||||
border: 1px solid #aaa;
|
||||
border-top: 0;
|
||||
margin-bottom: 1em;
|
||||
}
|
||||
|
||||
div.title {
|
||||
font-family: "lucida console","monaco","andale mono","bitstream vera sans mono","consolas",monospace;
|
||||
font-size: 12px;
|
||||
background-color: #aaa;
|
||||
color: #444;
|
||||
font-weight: bold;
|
||||
padding: 3px;
|
||||
padding-left: 10px;
|
||||
}
|
||||
|
||||
pre.content span.nu {
|
||||
color: #889;
|
||||
margin-right: 10px;
|
||||
}
|
||||
|
||||
pre.error {
|
||||
background: #334;
|
||||
color: #ccd;
|
||||
padding: 1em;
|
||||
border-top: 1px solid #000;
|
||||
border-left: 1px solid #000;
|
||||
border-right: 1px solid #eee;
|
||||
border-bottom: 1px solid #eee;
|
||||
}
|
||||
|
||||
189
public/css/style.css
Normal file
189
public/css/style.css
Normal file
@ -0,0 +1,189 @@
|
||||
|
||||
body {
|
||||
margin: 0;
|
||||
margin-bottom: 25px;
|
||||
padding: 0;
|
||||
background-color: #ddd;
|
||||
background-image: url("/images/perldancer-bg.jpg");
|
||||
background-repeat: no-repeat;
|
||||
background-position: top left;
|
||||
|
||||
font-family: "Lucida Grande", "Bitstream Vera Sans", "Verdana";
|
||||
font-size: 13px;
|
||||
color: #333;
|
||||
}
|
||||
|
||||
h1 {
|
||||
font-size: 28px;
|
||||
color: #000;
|
||||
}
|
||||
|
||||
a {color: #03c}
|
||||
a:hover {
|
||||
background-color: #03c;
|
||||
color: white;
|
||||
text-decoration: none;
|
||||
}
|
||||
|
||||
#page {
|
||||
background-color: #ddd;
|
||||
width: 750px;
|
||||
margin: auto;
|
||||
margin-left: auto;
|
||||
padding-left: 0px;
|
||||
margin-right: auto;
|
||||
}
|
||||
|
||||
#content {
|
||||
background-color: white;
|
||||
border: 3px solid #aaa;
|
||||
border-top: none;
|
||||
padding: 25px;
|
||||
width: 500px;
|
||||
}
|
||||
|
||||
#sidebar {
|
||||
float: right;
|
||||
width: 175px;
|
||||
}
|
||||
|
||||
#header, #about, #getting-started {
|
||||
padding-left: 75px;
|
||||
padding-right: 30px;
|
||||
}
|
||||
|
||||
|
||||
#header {
|
||||
background-image: url("/images/perldancer.jpg");
|
||||
background-repeat: no-repeat;
|
||||
background-position: top left;
|
||||
height: 64px;
|
||||
}
|
||||
#header h1, #header h2 {margin: 0}
|
||||
#header h2 {
|
||||
color: #888;
|
||||
font-weight: normal;
|
||||
font-size: 16px;
|
||||
}
|
||||
|
||||
#about h3 {
|
||||
margin: 0;
|
||||
margin-bottom: 10px;
|
||||
font-size: 14px;
|
||||
}
|
||||
|
||||
#about-content {
|
||||
background-color: #ffd;
|
||||
border: 1px solid #fc0;
|
||||
margin-left: -11px;
|
||||
}
|
||||
#about-content table {
|
||||
margin-top: 10px;
|
||||
margin-bottom: 10px;
|
||||
font-size: 11px;
|
||||
border-collapse: collapse;
|
||||
}
|
||||
#about-content td {
|
||||
padding: 10px;
|
||||
padding-top: 3px;
|
||||
padding-bottom: 3px;
|
||||
}
|
||||
#about-content td.name {color: #555}
|
||||
#about-content td.value {color: #000}
|
||||
|
||||
#about-content.failure {
|
||||
background-color: #fcc;
|
||||
border: 1px solid #f00;
|
||||
}
|
||||
#about-content.failure p {
|
||||
margin: 0;
|
||||
padding: 10px;
|
||||
}
|
||||
|
||||
#getting-started {
|
||||
border-top: 1px solid #ccc;
|
||||
margin-top: 25px;
|
||||
padding-top: 15px;
|
||||
}
|
||||
#getting-started h1 {
|
||||
margin: 0;
|
||||
font-size: 20px;
|
||||
}
|
||||
#getting-started h2 {
|
||||
margin: 0;
|
||||
font-size: 14px;
|
||||
font-weight: normal;
|
||||
color: #333;
|
||||
margin-bottom: 25px;
|
||||
}
|
||||
#getting-started ol {
|
||||
margin-left: 0;
|
||||
padding-left: 0;
|
||||
}
|
||||
#getting-started li {
|
||||
font-size: 18px;
|
||||
color: #888;
|
||||
margin-bottom: 25px;
|
||||
}
|
||||
#getting-started li h2 {
|
||||
margin: 0;
|
||||
font-weight: normal;
|
||||
font-size: 18px;
|
||||
color: #333;
|
||||
}
|
||||
#getting-started li p {
|
||||
color: #555;
|
||||
font-size: 13px;
|
||||
}
|
||||
|
||||
#search {
|
||||
margin: 0;
|
||||
padding-top: 10px;
|
||||
padding-bottom: 10px;
|
||||
font-size: 11px;
|
||||
}
|
||||
#search input {
|
||||
font-size: 11px;
|
||||
margin: 2px;
|
||||
}
|
||||
#search-text {width: 170px}
|
||||
|
||||
#sidebar ul {
|
||||
margin-left: 0;
|
||||
padding-left: 0;
|
||||
}
|
||||
#sidebar ul h3 {
|
||||
margin-top: 25px;
|
||||
font-size: 16px;
|
||||
padding-bottom: 10px;
|
||||
border-bottom: 1px solid #ccc;
|
||||
}
|
||||
#sidebar li {
|
||||
list-style-type: none;
|
||||
}
|
||||
#sidebar ul.links li {
|
||||
margin-bottom: 5px;
|
||||
}
|
||||
|
||||
h1, h2, h3, h4, h5 {
|
||||
font-family: sans-serif;
|
||||
margin: 1.2em 0 0.6em 0;
|
||||
}
|
||||
|
||||
p {
|
||||
line-height: 1.5em;
|
||||
margin: 1.6em 0;
|
||||
}
|
||||
|
||||
code, tt {
|
||||
font-family: 'Andale Mono', Monaco, 'Liberation Mono', 'Bitstream Vera Sans Mono', 'DejaVu Sans Mono', monospace;
|
||||
}
|
||||
|
||||
#footer {
|
||||
clear: both;
|
||||
padding-top: 2em;
|
||||
text-align: center;
|
||||
padding-right: 160px;
|
||||
font-family: sans-serif;
|
||||
font-size: 10px;
|
||||
}
|
||||
@ -1,15 +1,16 @@
|
||||
#!/usr/bin/env perl
|
||||
use Dancer ':syntax';
|
||||
BEGIN { $ENV{DANCER_APPHANDLER} = 'PSGI';}
|
||||
use Dancer2;
|
||||
use FindBin '$RealBin';
|
||||
use Plack::Runner;
|
||||
|
||||
# For some reason Apache SetEnv directives dont propagate
|
||||
# correctly to the dispatchers, so forcing PSGI and env here
|
||||
# correctly to the dispatchers, so forcing PSGI and env here
|
||||
# is safer.
|
||||
set apphandler => 'PSGI';
|
||||
set environment => 'production';
|
||||
|
||||
my $psgi = path($RealBin, '..', 'bin', 'app.pl');
|
||||
my $psgi = path($RealBin, '..', 'bin', 'app.psgi');
|
||||
die "Unable to read startup script: $psgi" unless -r $psgi;
|
||||
|
||||
Plack::Runner->run($psgi);
|
||||
@ -1,15 +1,16 @@
|
||||
#!/usr/bin/env perl
|
||||
use Dancer ':syntax';
|
||||
BEGIN { $ENV{DANCER_APPHANDLER} = 'PSGI';}
|
||||
use Dancer2;
|
||||
use FindBin '$RealBin';
|
||||
use Plack::Handler::FCGI;
|
||||
|
||||
# For some reason Apache SetEnv directives dont propagate
|
||||
# correctly to the dispatchers, so forcing PSGI and env here
|
||||
# correctly to the dispatchers, so forcing PSGI and env here
|
||||
# is safer.
|
||||
set apphandler => 'PSGI';
|
||||
set environment => 'production';
|
||||
|
||||
my $psgi = path($RealBin, '..', 'bin', 'app.pl');
|
||||
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);
|
||||
BIN
public/favicon.ico
Normal file
BIN
public/favicon.ico
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.4 KiB |
|
Before Width: | Height: | Size: 61 KiB After Width: | Height: | Size: 61 KiB |
BIN
public/images/perldancer-bg.jpg
Normal file
BIN
public/images/perldancer-bg.jpg
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 7.0 KiB |
BIN
public/images/perldancer.jpg
Normal file
BIN
public/images/perldancer.jpg
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 2.2 KiB |
23
public/js/jquery.min.js
vendored
Normal file
23
public/js/jquery.min.js
vendored
Normal file
File diff suppressed because one or more lines are too long
@ -6,16 +6,17 @@ Ce qui permet d'être un remplaçant de DynDNS.
|
||||
|
||||
## Outils
|
||||
|
||||
* [Dancer](http://perldancer.org/)
|
||||
* [DNS::ZoneParse](http://search.cpan.org/~mschilli/DNS-ZoneParse-1.10/lib/DNS/ZoneParse.pm)
|
||||
* [Dancer2](http://perldancer.org/)
|
||||
* [DNS::ZoneParse](https://metacpan.org/pod/DNS::ZoneParse)
|
||||
* [Bootstrap](http://twitter.github.io/bootstrap/)
|
||||
* [DBD::mysql](https://metacpan.org/module/DBD::mysql)
|
||||
* [Moose](https://metacpan.org/module/ETHER/Moose-2.0802/lib/Moose.pm)
|
||||
* [Crypt::Digest::SHA256](http://search.cpan.org/~mik/CryptX-0.021/lib/Crypt/Digest/SHA256.pm)
|
||||
* [Moo](https://metacpan.org/pod/Moo)
|
||||
* [Crypt::Digest::SHA256](https://metacpan.org/pod/Crypt::Digest::SHA256)
|
||||
|
||||
## TODO
|
||||
|
||||
* captcha
|
||||
* demander confirmation avant suppression d'une zone
|
||||
* rajouter les types de RR manquants dans l'interface
|
||||
* rajouter les types de RR manquants dans l'interface (remplacement de
|
||||
DNS::ZoneParse, ou amélioration)
|
||||
* déléguer les zones
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
use Test::More tests => 1;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use_ok 'DNSManager';
|
||||
use Test::More tests => 1;
|
||||
use_ok 'MyWeb::App';
|
||||
15
t/002_index_route.t
Normal file
15
t/002_index_route.t
Normal file
@ -0,0 +1,15 @@
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use MyWeb::App;
|
||||
use Test::More tests => 2;
|
||||
use Plack::Test;
|
||||
use HTTP::Request::Common;
|
||||
|
||||
my $app = MyWeb::App->to_app;
|
||||
is( ref $app, 'CODE', 'Got app' );
|
||||
|
||||
my $test = Plack::Test->create($app);
|
||||
my $res = $test->request( GET '/' );
|
||||
|
||||
ok( $res->is_success, '[GET /] successful' );
|
||||
23
t/003_basic_functions.t
Normal file
23
t/003_basic_functions.t
Normal file
@ -0,0 +1,23 @@
|
||||
use Test::More;
|
||||
use Modern::Perl;
|
||||
use lib 'lib';
|
||||
use util ':all';
|
||||
|
||||
chdir 'lib'; # TODO hack at 2am
|
||||
|
||||
map {
|
||||
ok
|
||||
( ( is_domain_name $_ ), "is '$_' a domain name" )
|
||||
} qw( foo.bar bar localhost. localhost );
|
||||
|
||||
map {
|
||||
ok
|
||||
( ( is_valid_tld $_ ), "is '$_' a tld in the cfg file" )
|
||||
} qw( .netlib.re );
|
||||
|
||||
map {
|
||||
ok
|
||||
( ( ! is_valid_tld $_ ), "is '$_' a tld in the cfg file" )
|
||||
} qw( example.com );
|
||||
|
||||
done_testing;
|
||||
28
t/004_filutil.t
Normal file
28
t/004_filutil.t
Normal file
@ -0,0 +1,28 @@
|
||||
use Test::More;
|
||||
use Modern::Perl;
|
||||
use URI;
|
||||
use lib 'lib';
|
||||
use fileutil ':all';
|
||||
|
||||
my $f1 = "lib/fileutil.pm";
|
||||
my $p1 = "read_file";
|
||||
my $f2 = "/tmp/test";
|
||||
my $d2 = "DATA";
|
||||
|
||||
sub t_read_file {
|
||||
my ($f, $pattern) = @_;
|
||||
my $data = read_file $f;
|
||||
$data =~ /$pattern/;
|
||||
}
|
||||
|
||||
sub t_write_file {
|
||||
my ($f, $data) = @_;
|
||||
write_file $f, $data;
|
||||
my $d = read_file $f;
|
||||
$d =~ /$data/;
|
||||
}
|
||||
|
||||
ok ((t_read_file $f1, $p1) , "read_file avec $f1 / $p1" );
|
||||
ok ((t_write_file $f2, $d2) , "write_file" );
|
||||
|
||||
done_testing;
|
||||
22
t/005_copycat.t
Normal file
22
t/005_copycat.t
Normal file
@ -0,0 +1,22 @@
|
||||
use Test::More;
|
||||
use Modern::Perl;
|
||||
use URI;
|
||||
use lib 'lib';
|
||||
use fileutil ':all';
|
||||
use copycat ':all';
|
||||
|
||||
my $l1 = "file:///etc/hosts";
|
||||
my $l2 = "file:///tmp/truc";
|
||||
|
||||
sub t_local_local {
|
||||
my ($f1, $f2) = @_;
|
||||
copycat $f1, $f2;
|
||||
|
||||
my $file = URI->new($f2);
|
||||
my $d = read_file $file->path;
|
||||
$d =~ /localhost/;
|
||||
}
|
||||
|
||||
ok ((t_local_local $l1, $l2) , "copycat local local avec $l1 / $l2" );
|
||||
|
||||
done_testing;
|
||||
23
t/006_remotecmd.t
Normal file
23
t/006_remotecmd.t
Normal file
@ -0,0 +1,23 @@
|
||||
use Test::More;
|
||||
use Modern::Perl;
|
||||
use URI;
|
||||
use lib 'lib';
|
||||
use remotecmd ':all';
|
||||
|
||||
my $port = 22;
|
||||
my $user = 'karchnu';
|
||||
my $host = "karchnu.fr";
|
||||
my $cmd = "ls /";
|
||||
my $pattern = qr/etc/;
|
||||
|
||||
sub t_remotecmd {
|
||||
my ($user, $host, $port, $cmd, $pattern) = @_;
|
||||
|
||||
my $ret = remotecmd $user, $host, $port, $cmd;
|
||||
|
||||
$ret =~ $pattern;
|
||||
}
|
||||
|
||||
ok ((t_remotecmd $user, $host, $port, $cmd, $pattern) , "remote cmd" );
|
||||
|
||||
done_testing;
|
||||
9
t/007_get_iface.t
Normal file
9
t/007_get_iface.t
Normal file
@ -0,0 +1,9 @@
|
||||
use Test::More;
|
||||
use Modern::Perl;
|
||||
use YAML::XS;
|
||||
use URI;
|
||||
use lib 'lib';
|
||||
use getiface':all';
|
||||
|
||||
my $x = getiface("bind9", { mycfg => '', data => '' });
|
||||
say Dump $x;
|
||||
22
t/00x_dump_cfg_file.t
Normal file
22
t/00x_dump_cfg_file.t
Normal file
@ -0,0 +1,22 @@
|
||||
use Test::More;
|
||||
use Modern::Perl;
|
||||
use YAML::XS;
|
||||
use URI;
|
||||
use lib 'lib';
|
||||
use configuration ':all';
|
||||
|
||||
my $x = get_cfg();
|
||||
#say Dump $x;
|
||||
|
||||
say $$x{database}{host};
|
||||
|
||||
for($$x{secondarydnsserver})
|
||||
{
|
||||
for(@$_)
|
||||
{
|
||||
while( my ($k, $v) = each %$_)
|
||||
{
|
||||
say $k . ' ' . $v ;
|
||||
}
|
||||
}
|
||||
}
|
||||
40
t/auth.pl
40
t/auth.pl
@ -1,40 +0,0 @@
|
||||
#!/usr/bin/perl -w
|
||||
use strict;
|
||||
use warnings;
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
use DNS::ZoneParse;
|
||||
use Config::Simple;
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use lib '../';
|
||||
use app::app;
|
||||
|
||||
sub initco {
|
||||
|
||||
my $cfg = new Config::Simple('./config.ini');
|
||||
my $app = app->new( zdir => $cfg->param('zones_path'),
|
||||
dbname => $cfg->param('dbname'),
|
||||
dbhost => $cfg->param('host'),
|
||||
dbport => $cfg->param('port'),
|
||||
dbuser => $cfg->param('user'),
|
||||
dbpass => $cfg->param('passwd'),
|
||||
sgbd => $cfg->param('sgbd'),
|
||||
dnsapp => $cfg->param('dnsapp') );
|
||||
|
||||
$app->init();
|
||||
|
||||
return $app;
|
||||
}
|
||||
|
||||
if( @ARGV < 2) {
|
||||
say "usage : ./auth.pl login mdp";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my $app = initco();
|
||||
my ($auth_ok, $user, $isadmin) = $app->auth($ARGV[0], $ARGV[1]);
|
||||
|
||||
say "auth $auth_ok";
|
||||
say "isadmin $isadmin";
|
||||
13
t/config.ini
13
t/config.ini
@ -1,13 +0,0 @@
|
||||
dbname = dnsmanager
|
||||
host = localhost
|
||||
# other options : see DBI module
|
||||
sgbd = mysql
|
||||
# default port for mysql
|
||||
port = 3306
|
||||
user = bla
|
||||
passwd = HardPass4bla
|
||||
# possible options for dnsserver : bind rndc
|
||||
dnsapp = rndc
|
||||
zones_path = "/srv/named/"
|
||||
sshhost = pizza
|
||||
sshuser = karchnu
|
||||
@ -1,36 +0,0 @@
|
||||
#!/usr/bin/perl -w
|
||||
use strict;
|
||||
use warnings;
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
use DNS::ZoneParse;
|
||||
use Config::Simple;
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use lib '../';
|
||||
use app::app;
|
||||
use initco;
|
||||
|
||||
if( @ARGV != 0 ) {
|
||||
say "usage : ./get_all_domains.pl";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my $app = initco::initco();
|
||||
|
||||
my %domains = $app->get_all_domains();
|
||||
|
||||
dump(%domains);
|
||||
|
||||
#if( $domains ) {
|
||||
# if( scalar(@$domains) != 0) {
|
||||
# say join ", ", @{$domains};
|
||||
# }
|
||||
# else {
|
||||
# say "tableau vide";
|
||||
# }
|
||||
#}
|
||||
#else {
|
||||
# say "domains undef";
|
||||
#}
|
||||
@ -1,36 +0,0 @@
|
||||
#!/usr/bin/perl -w
|
||||
use strict;
|
||||
use warnings;
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
use DNS::ZoneParse;
|
||||
use Config::Simple;
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use lib '../';
|
||||
use app::app;
|
||||
use initco;
|
||||
|
||||
if( @ARGV != 0 ) {
|
||||
say "usage : ./get_all_domains.pl";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my $app = initco::initco();
|
||||
|
||||
my %users = $app->get_all_users();
|
||||
|
||||
dump(%users);
|
||||
|
||||
#if( $domains ) {
|
||||
# if( scalar(@$domains) != 0) {
|
||||
# say join ", ", @{$domains};
|
||||
# }
|
||||
# else {
|
||||
# say "tableau vide";
|
||||
# }
|
||||
#}
|
||||
#else {
|
||||
# say "domains undef";
|
||||
#}
|
||||
@ -1,43 +0,0 @@
|
||||
#!/usr/bin/perl -w
|
||||
use strict;
|
||||
use warnings;
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
use DNS::ZoneParse;
|
||||
use Config::Simple;
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use lib '../';
|
||||
use app::app;
|
||||
use initco;
|
||||
|
||||
if( @ARGV < 2) {
|
||||
say "usage : ./auth.pl login mdp";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my $app = initco::initco();
|
||||
my ($auth_ok, $user, $isadmin) = $app->auth($ARGV[0], $ARGV[1]);
|
||||
|
||||
if($auth_ok) {
|
||||
say "auth $auth_ok";
|
||||
say "isadmin $isadmin";
|
||||
}
|
||||
|
||||
my ($success, $domains) = $app->get_domains( $ARGV[0] );
|
||||
|
||||
say "success $success";
|
||||
dump($domains);
|
||||
|
||||
#if( $domains ) {
|
||||
# if( scalar(@$domains) != 0) {
|
||||
# say join ", ", @{$domains};
|
||||
# }
|
||||
# else {
|
||||
# say "tableau vide";
|
||||
# }
|
||||
#}
|
||||
#else {
|
||||
# say "domains undef";
|
||||
#}
|
||||
@ -1,29 +0,0 @@
|
||||
#!/usr/bin/perl -w
|
||||
use strict;
|
||||
use warnings;
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
use DNS::ZoneParse;
|
||||
use Config::Simple;
|
||||
use Data::Dump qw( dump );
|
||||
|
||||
use lib '../';
|
||||
use app::app;
|
||||
|
||||
use initco;
|
||||
|
||||
if( @ARGV != 0 ) {
|
||||
say "usage : ./get_all_domains.pl";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
my $app = initco::initco();
|
||||
|
||||
my ($success) = $app->register_user("bla", 'password');
|
||||
die "erreur de nom, déjà pris" unless $success;
|
||||
|
||||
($success) = $app->register_user("bla", 'password');
|
||||
die "erreur de nom, déjà pris" unless $success;
|
||||
|
||||
say "fin";
|
||||
32
t/initco.pm
32
t/initco.pm
@ -1,32 +0,0 @@
|
||||
use strict;
|
||||
use warnings;
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
use Config::Simple;
|
||||
|
||||
package initco;
|
||||
|
||||
sub initco {
|
||||
my ($cfgfile) = @_;
|
||||
|
||||
$cfgfile = defined $cfgfile ? $cfgfile : './config.ini';
|
||||
|
||||
my $cfg = new Config::Simple($cfgfile);
|
||||
my $app = app->new( zdir => $cfg->param('zones_path')
|
||||
, dbname => $cfg->param('dbname')
|
||||
, dbhost => $cfg->param('host')
|
||||
, dbport => $cfg->param('port')
|
||||
, dbuser => $cfg->param('user')
|
||||
, dbpass => $cfg->param('passwd')
|
||||
, sgbd => $cfg->param('sgbd')
|
||||
, sshhost => $cfg->param('sshhost')
|
||||
, sshuser => $cfg->param('sshuser')
|
||||
, dnsapp => $cfg->param('dnsapp') );
|
||||
|
||||
$app->init();
|
||||
|
||||
return $app;
|
||||
}
|
||||
|
||||
1;
|
||||
22
t/scp.pl
22
t/scp.pl
@ -1,22 +0,0 @@
|
||||
#!/usr/bin/perl -w
|
||||
use strict;
|
||||
use warnings;
|
||||
use v5.14;
|
||||
use autodie;
|
||||
use Modern::Perl;
|
||||
use Net::OpenSSH;
|
||||
|
||||
my $hostname = "ns0.arn-fai.net";
|
||||
my $username = "dnsmanager";
|
||||
|
||||
my $co = "$username\@$hostname:2222";
|
||||
|
||||
say $co;
|
||||
|
||||
my $ssh = Net::OpenSSH->new($co);
|
||||
$ssh->scp_put("tpl.zone", "/home/$username/") or die "scp failed: " . $ssh->error;
|
||||
|
||||
#use Net::SCP; # ne fonctionne pas avec des ports :/
|
||||
#my $scp = Net::SCP->new( { host => $hostname, user => $username, port => 2222} );
|
||||
#$scp->put("tpl.zone", "lolwat") or die $scp->{errstr};
|
||||
# $scp->put("filename") or die $scp->{errstr};
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user