aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/MGA/Mirrors.pm5
-rw-r--r--lib/MGA/Mirrors/Controller/New.pm125
-rw-r--r--lib/MGA/Mirrors/Controller/Root.pm2
-rw-r--r--lib/MGA/Mirrors/DB.pm364
-rw-r--r--lib/MGA/Mirrors/Model/Mirrors.pm33
-rw-r--r--lib/MGA/Mirrors/View/TT.pm43
-rw-r--r--lib/MGA/Mirrors/View/TTBlock.pm40
7 files changed, 611 insertions, 1 deletions
diff --git a/lib/MGA/Mirrors.pm b/lib/MGA/Mirrors.pm
index 03de5c6..dce921a 100644
--- a/lib/MGA/Mirrors.pm
+++ b/lib/MGA/Mirrors.pm
@@ -16,6 +16,10 @@ use Catalyst qw/
-Debug
ConfigLoader
Static::Simple
+ Prototype
+ Session
+ Session::State::Cookie
+ Session::Store::FastMmap
/;
extends 'Catalyst';
@@ -36,6 +40,7 @@ __PACKAGE__->config(
name => 'MGA::Mirrors',
# Disable deprecated behavior needed by old applications
disable_component_resolution_regex_fallback => 1,
+ default_view => 'TT',
);
# Start the application
diff --git a/lib/MGA/Mirrors/Controller/New.pm b/lib/MGA/Mirrors/Controller/New.pm
new file mode 100644
index 0000000..fbb1fbe
--- /dev/null
+++ b/lib/MGA/Mirrors/Controller/New.pm
@@ -0,0 +1,125 @@
+package MGA::Mirrors::Controller::New;
+use Moose;
+use namespace::autoclean;
+use URI;
+
+BEGIN {extends 'Catalyst::Controller'; }
+
+=head1 NAME
+
+MGA::Mirrors::Controller::New - Catalyst Controller
+
+=head1 DESCRIPTION
+
+Catalyst Controller.
+
+=head1 METHODS
+
+=cut
+
+
+=head2 index
+
+=cut
+
+sub index :Path :Args(0) {
+ my ( $self, $c ) = @_;
+
+ if ($c->req->param('url')) {
+ my $uri = URI->new($c->req->param('url'));
+ $c->stash->{uri} = $uri;
+
+ if (!($uri->can('host') && $uri->can('scheme'))) {
+ $c->stash->{subtemplate} = 'new/invalid_uri.tt';
+ return;
+ }
+
+ if (!$c->model('Mirrors')->get_protocol_info($uri->scheme)) {
+ $c->stash->{subtemplate} = 'new/unsupported_protocol.tt';
+ return;
+ }
+
+ my $urls = $c->model('Mirrors')->find_urls(
+ { protocol => $uri->scheme,
+ hostname => $uri->host, });
+ if (@{$urls || []}) {
+ $c->stash->{exists_url} = $urls;
+ $c->stash->{subtemplate} = 'new/mirror_exists.tt';
+ return;
+ }
+
+ if (!$c->model('Mirrors')->mirror_validity($uri)) {
+ $c->stash->{subtemplate} = 'new/invalid_mirror.tt';
+ return;
+ }
+
+ if (my @overlap_hosts = $c->model('Mirrors')->find_host_ip_overlap($uri->host)) {
+ $c->stash->{overlap_hosts} = \@overlap_hosts;
+ $c->stash->{subtemplate} = 'new/overlap_hosts.tt';
+ return;
+ }
+
+ my @ips = $c->model('Mirrors')->host_ips($uri->host);
+
+ $c->stash->{location} = $c->model('Mirrors')->locate_ips(@ips);
+
+ my $mirror = $c->model('Mirrors')->find_mirrors(
+ { hostname => $uri->host, });
+ if (@{ $mirror || []}) {
+ $c->stash->{mirror} = $mirror->[0];
+ } elsif ($c->req->param('hostinfo')) {
+ foreach (qw(city country)) {
+ $c->session->{hostinfo}{$_} = $c->req->param($_);
+ }
+ } else {
+ $c->stash->{subtemplate} = 'new/host_information.tt';
+ return;
+ }
+
+ $c->session->{new_uri} = $uri;
+ $c->stash->{template} = 'new/confirm.tt';
+ }
+}
+
+sub confirm :Path :Args(1) {
+ my ( $self, $c ) = @_;
+ $c->stash->{current_view} = 'TTBlock';
+ if ($c->session->{new_uri} && $c->req->param('confirm')) {
+ my $uri = URI->new($c->session->{new_uri});
+ my $mirror = $c->model('Mirrors')->find_mirrors(
+ { hostname => $uri->host, });
+ if (!@{$mirror || []}) {
+ if ($c->session->{hostinfo}) {
+ $c->model->add_or_update_host(
+ $uri->host,
+ city => $c->session->{hostinfo}{city},
+ country => $c->session->{hostinfo}{country},
+ );
+ } else {
+ return;
+ }
+ }
+ if ($c->model('Mirrors')->add_or_update_url($uri)) {
+ $c->session->{hostinfo} = undef;
+ $c->session->{new_uri} = undef;
+ $c->stash->{template} = 'new/success.tt';
+ $c->model('Mirrors')->db->commit;
+ return;
+ }
+ }
+}
+
+=head1 AUTHOR
+
+Olivier Thauvin
+
+=head1 LICENSE
+
+This library is free software. You can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+__PACKAGE__->meta->make_immutable;
+
+1;
diff --git a/lib/MGA/Mirrors/Controller/Root.pm b/lib/MGA/Mirrors/Controller/Root.pm
index 5decc3a..bbc4d4d 100644
--- a/lib/MGA/Mirrors/Controller/Root.pm
+++ b/lib/MGA/Mirrors/Controller/Root.pm
@@ -30,7 +30,7 @@ sub index :Path :Args(0) {
my ( $self, $c ) = @_;
# Hello World
- $c->response->body( $c->welcome_message );
+ #$c->response->body( $c->welcome_message );
}
=head2 default
diff --git a/lib/MGA/Mirrors/DB.pm b/lib/MGA/Mirrors/DB.pm
new file mode 100644
index 0000000..78b6862
--- /dev/null
+++ b/lib/MGA/Mirrors/DB.pm
@@ -0,0 +1,364 @@
+package MGA::Mirrors::DB;
+
+# $Id$
+
+use strict;
+use warnings;
+use Config::IniFiles;
+use URI;
+use DBI;
+use File::Temp qw(tempfile);
+use Net::DNS;
+
+sub configfile { '/etc/mga-mirror.ini' }
+
+sub new {
+ my ($class) = @_;
+
+ my $conf = (-f './mga-mirror.ini')
+ ? Config::IniFiles->new(-file => './mga-mirror.ini')
+ : Config::IniFiles->new(-file => configfile())
+ or return;
+
+ my $db = DBI->connect(
+ 'dbi:Pg:' . $conf->val('db', 'pgconn', ''),
+ $conf->val('db', 'user') || undef,
+ $conf->val('db', 'password') || undef,
+ {
+ AutoCommit => 0,
+ PrintError => 1,
+ }
+ ) or return;
+
+ bless {
+ db => $db,
+ conf => $conf,
+ }, $class;
+}
+
+sub host_ips {
+ my ($self, $hostname) = @_;
+
+ my $resolver = Net::DNS::Resolver->new;
+ my @addresses;
+ foreach my $type (qw'A AAAA') {
+ my $packet = $resolver->search($hostname, $type) or next;
+ foreach ($packet->answer) {
+ $_->type eq $type or next;
+ push(@addresses, $_->address);
+ }
+ }
+ @addresses;
+}
+
+sub db { $_[0]->{db} }
+
+sub locate_ips {
+ my ($self, @ips) = @_;
+
+ my $find = $self->db->prepare(q{
+ select countries.* from geoip
+ join countries on geoip.code = countries.code
+ where ipmin <= $1 and ipmax >= $1
+ });
+
+ foreach (@ips) {
+ $find->execute($_);
+ my $res = $find->fetchrow_hashref;
+ if ($res) {
+ $find->finish;
+ return $res;
+ }
+ }
+
+ return;
+}
+
+sub country_list {
+ my ($self) = @_;
+ my $list = $self->db->prepare(q{
+ select * from countries order by name
+ });
+ $list->execute;
+ return $list->fetchall_arrayref({});
+}
+
+sub mirror_validity {
+ my ($self, $uri) = @_;
+ my $listf = $self->db->prepare(q{
+ select * from global_files
+ });
+ $listf->execute;
+ while (my $res = $listf->fetchrow_hashref) {
+ my $furi = URI->new($uri . $res->{relpath});
+ $self->_check_url($furi) or return;
+ }
+
+ 1;
+}
+
+sub check_distributions {
+ my ($self) = @_;
+
+ my $uneeded_check = $self->db->prepare(q{
+ select * from mirrors_distributions where
+ lastcheck > now() - '6 hours'::interval
+ });
+ $uneeded_check->execute();
+ my $uch = $uneeded_check->fetchall_hashref([ qw(urlskey distributionkey) ]);
+
+ my $listd = $self->db->prepare(q{
+ select * from urls, distributions
+ where urls.valid = true
+ });
+
+ my $addstatus = $self->db->prepare(q{
+ insert into mirrors_distributions (urlskey, distributionkey, exists)
+ values (?,?,?)
+ });
+
+ my $updstatus = $self->db->prepare(q{
+ update mirrors_distributions set lastcheck = now(), exists = ?
+ where urlskey = ? and distributionkey = ?
+ });
+
+ my %urls_status = ();
+
+ my $updurl = $self->db->prepare(q{
+ update urls set lastcheck = now(), valid = ?
+ where key = ?
+ });
+
+ $listd->execute();
+ while (my $res = $listd->fetchrow_hashref) {
+ $uch->{$res->{key}}{$res->{dkey}} and next;
+ my $url = $self->fmt_url($res);
+ if (!exists($urls_status{$res->{key}})) {
+ my $ok = $self->mirror_validity($url);
+ $updurl->execute($ok ? 1 : 0, $res->{key});
+ $urls_status{$res->{key}} = $ok;
+ }
+ $urls_status{$res->{key}} or next;
+ my $furi = URI->new(join('/', $url, $res->{relpath}, $res->{relfile}));
+ my $exists = $self->_check_url($furi);
+ if ($updstatus->execute($exists, $res->{key}, $res->{dkey}) == 0) {
+ $addstatus->execute($res->{key}, $res->{dkey}, $exists);
+ }
+ $self->db->commit;
+ }
+}
+
+sub _check_url {
+ my ($self, $furi) = @_;
+ my ($fh, $filename) = tempfile();
+ close($fh);
+ my $cmd =
+ $furi->scheme =~ /^http|ftp$/ ? "wget -nv -t 1 -T 4 -O $filename " . $furi->as_string :
+ $furi->scheme eq 'rsync' ? "rsync --timeout 4 -q " . $furi->as_string . " $filename" : '';
+ my $ok = (system($cmd) == 0);
+ unlink($filename);
+ return $ok
+}
+
+sub get_protocol_info {
+ my ($self, $protocol) = @_;
+ my $get = $self->db->prepare(q{
+ select * from protocol where name = ?
+ });
+ $get->execute($protocol);
+ my $res = $get->fetchrow_hashref;
+ $get->finish;
+ $res;
+}
+
+sub find_mirrors {
+ my ($self, $filters, $key) = @_;
+
+ my $query = q{
+ select * from hosts
+ left join countries on countries.code = hosts.country
+ where hosts.hostname in (select hostname from urls %s)
+ %s
+ };
+
+ my (@mvals, @uvals);
+ my (@mw, @uw);
+ if (keys %{ $filters || {}}) {
+ foreach (keys %$filters) {
+ $filters->{$_} or next;
+ if (my $field = {
+ hostname => 'hosts.hostname',
+ country => 'countries.code',
+ continent => 'countries.contienent_code',
+ }->{$_}) {
+ push(@mw, sprintf('%s = ?', $field));
+ push(@mvals, $filters->{$_});
+ }
+ if (my $field = {
+ protocol => 'protocol',
+ }->{$_}) {
+ push(@uw, sprintf('%s = ?', $field));
+ push(@uvals, $filters->{$_});
+ }
+ }
+ }
+ my $list = $self->db->prepare(sprintf(
+ $query,
+ (@uw ? 'where ' . join(' and ', @uw) : ''),
+ (@mw ? 'and ' . join(' and ', @mw) : ''),
+ ));
+ $list->execute(@uvals, @mvals);
+ return $list->fetchall_arrayref({});
+}
+
+sub _find_urls {
+ my ($self, $filters, $key) = @_;
+
+ my $query = q{
+ select urls.* from urls join
+ hosts on hosts.hostname = urls.hostname
+ };
+ my @vals;
+ if (keys %{ $filters || {} }) {
+ $query .= ' where ';
+ my @w;
+ foreach (keys %$filters) {
+ my $field = {
+ hostname => 'hosts.hostname',
+ protocol => 'urls.protocol',
+ }->{$_} or next;
+
+ push(@w, sprintf('%s = ?', $field));
+ push(@vals, $filters->{$_});
+ }
+ $query .= join(' and ', @w);
+ }
+ my $list = $self->db->prepare($query);
+ $list->execute(@vals);
+ return $list->fetchall_arrayref({});
+}
+
+sub find_host_ip_overlap {
+ my ($self, $hostname) = @_;
+
+ my @addresses = $self->host_ips($hostname);
+
+ my $list = $self->db->prepare(q{
+ select * from ips where ip = any(?)
+ and hostname != ?
+ });
+ $list->execute(\@addresses, $hostname);
+ my $res = $list->fetchall_hashref('hostname');
+ return keys %{ $res };
+}
+
+sub add_or_update_host {
+ my ($self, $hostname, %info) = @_;
+
+ my (@fields, @vals);
+ while (my ($field, $val) = each(%info)) {
+ push(@fields, $field);
+ push(@vals, $val);
+ }
+ if (keys %info) {
+ my $upd = $self->db->prepare(sprintf(q{
+ update hosts set %s where hostname = ?
+ }, join(', ', map { "$_ = ?" } @fields)));
+ if ($upd->execute(@vals, $hostname) == 0) {
+ my $add = $self->db->prepare(sprintf(q{
+ insert into hosts (%s) values (%s)
+ }, join(', ', (@fields, 'hostname')),
+ join(',', ('?') x (scalar(@fields)+1))
+ ));
+ $add->execute(@vals, $hostname) or do {
+ $self->db->rollback;
+ return;
+ };
+ }
+ }
+
+ $self->update_host_ips($hostname);
+
+ 1;
+}
+
+sub add_or_update_url {
+ my ($self, $uri) = @_;
+ if (!ref $uri) {
+ $uri = URI->new($uri);
+ }
+
+ my $update = $self->db->prepare(q{
+ update urls set path = ?, port = ?
+ where hostname = ? and protocol = ?
+ });
+
+ if ($update->execute(
+ $uri->path, $uri->port == $uri->default_port ? undef : $uri->port,
+ $uri->host, $uri->scheme
+ ) == 0) {
+ my $add = $self->db->prepare(q{
+ insert into urls (path, port, hostname, protocol)
+ values (?,?,?,?)
+ });
+ $add->execute($uri->path, $uri->port == $uri->default_port ? undef : $uri->port,
+ $uri->host, $uri->scheme) or do {
+ $self->db->rollback;
+ return;
+ }
+ }
+
+ 1;
+}
+
+sub update_host_ips {
+ my ($self, $hostname) = @_;
+
+ my @addresses = $self->host_ips($hostname);
+ my $delete = $self->db->prepare(
+ q{delete from ips where hostname = ?
+ and ip != any(?)
+ }
+ );
+
+ $delete->execute($hostname, [ @addresses ]);
+
+ my $getip = $self->db->prepare(q{
+ select 1 from ips where hostname = ? and ip = ?
+ });
+ my $addip = $self->db->prepare(q{
+ insert into ips (hostname, ip) values (?,?)
+ });
+ foreach (@addresses) {
+ if ($getip->execute($hostname, $_) == 0) {
+ $addip->execute($hostname, $_);
+ }
+ $getip->finish;
+ }
+
+ 1;
+}
+
+sub find_urls {
+ my ($self, $filters, $key) = @_;
+ return [
+ map { $_->{url} = $self->fmt_url($_); $_ }
+ @{ $self->_find_urls($filters) || []}]
+}
+
+sub fmt_url {
+ my ($self, $dburl) = @_;
+
+ my $uri = URI->new(
+ sprintf('%s://%s%s',
+ $dburl->{protocol},
+ $dburl->{hostname},
+ $dburl->{path} || '/',
+ )
+ );
+ $uri->port($dburl->{port});
+
+ return $uri->as_string;
+}
+
+1;
diff --git a/lib/MGA/Mirrors/Model/Mirrors.pm b/lib/MGA/Mirrors/Model/Mirrors.pm
new file mode 100644
index 0000000..c1e1852
--- /dev/null
+++ b/lib/MGA/Mirrors/Model/Mirrors.pm
@@ -0,0 +1,33 @@
+package MGA::Mirrors::Model::Mirrors;
+use Moose;
+use namespace::autoclean;
+
+extends 'MGA::Mirrors::DB', 'Catalyst::Model';
+
+=head1 NAME
+
+MGA::Mirrors::Model::Mirrors - Catalyst Model
+
+=head1 DESCRIPTION
+
+Catalyst Model.
+
+=head1 AUTHOR
+
+Olivier Thauvin
+
+=head1 LICENSE
+
+This library is free software. You can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+sub new {
+ my ($class) = @_;
+ return bless(MGA::Mirrors::DB->new(), $class);
+}
+
+__PACKAGE__->meta->make_immutable(inline_constructor => 0);
+
+1;
diff --git a/lib/MGA/Mirrors/View/TT.pm b/lib/MGA/Mirrors/View/TT.pm
new file mode 100644
index 0000000..f5e2a50
--- /dev/null
+++ b/lib/MGA/Mirrors/View/TT.pm
@@ -0,0 +1,43 @@
+package MGA::Mirrors::View::TT;
+
+use strict;
+use warnings;
+use MGA::Mirrors;
+
+use base 'Catalyst::View::TT';
+
+__PACKAGE__->config(
+ TEMPLATE_EXTENSION => '.tt',
+ render_die => 1,
+ INCLUDE_PATH => [
+ MGA::Mirrors->path_to( 'root', 'html', 'includes' ),
+ MGA::Mirrors->path_to( 'root', 'html', 'pages' ),
+ ],
+ PRE_PROCESS => 'header.tt',
+ POST_PROCESS => 'footer.tt',
+);
+
+=head1 NAME
+
+MGA::Mirrors::View::TT - TT View for MGA::Mirrors
+
+=head1 DESCRIPTION
+
+TT View for MGA::Mirrors.
+
+=head1 SEE ALSO
+
+L<MGA::Mirrors>
+
+=head1 AUTHOR
+
+Olivier Thauvin
+
+=head1 LICENSE
+
+This library is free software. You can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/lib/MGA/Mirrors/View/TTBlock.pm b/lib/MGA/Mirrors/View/TTBlock.pm
new file mode 100644
index 0000000..468a063
--- /dev/null
+++ b/lib/MGA/Mirrors/View/TTBlock.pm
@@ -0,0 +1,40 @@
+package MGA::Mirrors::View::TTBlock;
+
+use strict;
+use warnings;
+use MGA::Mirrors;
+
+use base 'Catalyst::View::TT';
+
+__PACKAGE__->config(
+ TEMPLATE_EXTENSION => '.tt',
+ render_die => 1,
+ INCLUDE_PATH => [
+ MGA::Mirrors->path_to( 'root', 'html', 'includes' ),
+ ],
+);
+
+=head1 NAME
+
+MGA::Mirrors::View::TT - TT View for MGA::Mirrors
+
+=head1 DESCRIPTION
+
+TT View for MGA::Mirrors.
+
+=head1 SEE ALSO
+
+L<MGA::Mirrors>
+
+=head1 AUTHOR
+
+Olivier Thauvin
+
+=head1 LICENSE
+
+This library is free software. You can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;