diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/MGA/Mirrors.pm | 5 | ||||
| -rw-r--r-- | lib/MGA/Mirrors/Controller/New.pm | 125 | ||||
| -rw-r--r-- | lib/MGA/Mirrors/Controller/Root.pm | 2 | ||||
| -rw-r--r-- | lib/MGA/Mirrors/DB.pm | 364 | ||||
| -rw-r--r-- | lib/MGA/Mirrors/Model/Mirrors.pm | 33 | ||||
| -rw-r--r-- | lib/MGA/Mirrors/View/TT.pm | 43 | ||||
| -rw-r--r-- | lib/MGA/Mirrors/View/TTBlock.pm | 40 |
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; |