diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/MGA/Mirrors/Controller/Distrib.pm | 48 | ||||
| -rw-r--r-- | lib/MGA/Mirrors/Controller/Mirrors.pm | 66 | ||||
| -rw-r--r-- | lib/MGA/Mirrors/Controller/New.pm | 13 | ||||
| -rw-r--r-- | lib/MGA/Mirrors/DB.pm | 102 |
4 files changed, 221 insertions, 8 deletions
diff --git a/lib/MGA/Mirrors/Controller/Distrib.pm b/lib/MGA/Mirrors/Controller/Distrib.pm new file mode 100644 index 0000000..0d49e55 --- /dev/null +++ b/lib/MGA/Mirrors/Controller/Distrib.pm @@ -0,0 +1,48 @@ +package MGA::Mirrors::Controller::Distrib; +use Moose; +use namespace::autoclean; + +BEGIN {extends 'Catalyst::Controller'; } + +=head1 NAME + +MGA::Mirrors::Controller::Distrib - Catalyst Controller + +=head1 DESCRIPTION + +Catalyst Controller. + +=head1 METHODS + +=cut + + +=head2 index + +=cut + +sub index :Path :Args(0) { + my ( $self, $c ) = @_; + +} + +sub list :Path :Args(1) { + my ( $self, $c ) = @_; + $c->stash->{current_view} = 'TTBlock'; + $c->stash->{template} = 'distrib/distrib.tt'; +} + +=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/Mirrors.pm b/lib/MGA/Mirrors/Controller/Mirrors.pm new file mode 100644 index 0000000..5d07ca5 --- /dev/null +++ b/lib/MGA/Mirrors/Controller/Mirrors.pm @@ -0,0 +1,66 @@ +package MGA::Mirrors::Controller::Mirrors; +use Moose; +use namespace::autoclean; + +BEGIN {extends 'Catalyst::Controller'; } + +=head1 NAME + +MGA::Mirrors::Controller::Mirrors - Catalyst Controller + +=head1 DESCRIPTION + +Catalyst Controller. + +=head1 METHODS + +=cut + + +=head2 index + +=cut + +sub index :Path :Args(0) { + my ( $self, $c ) = @_; + + $c->response->body('Matched MGA::Mirrors::Controller::Mirrors in Mirrors.'); +} + +sub mirror :Path :Args(1) { + my ( $self, $c, $host ) = @_; + $c->stash->{hostname} = $host; + + if ($c->req->param('hostinfo')) { + my $hinfo = $c->model('Mirrors')->find_mirrors({ + hostname => $host, + })->[0]; + if (! $hinfo->{readonly}) { + $c->model('Mirrors')->add_or_update_host($host, + bandwidth => $c->req->param('bandwidth'), + city => $c->req->param('city'), + country => $c->req->param('country'), + syncfrom=> $c->req->param('syncfrom'), + ); + } + } + + $c->stash->{host} = $c->model('Mirrors')->find_mirrors({ + hostname => $host, + })->[0]; +} + +=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/New.pm b/lib/MGA/Mirrors/Controller/New.pm index fbb1fbe..d3ec38c 100644 --- a/lib/MGA/Mirrors/Controller/New.pm +++ b/lib/MGA/Mirrors/Controller/New.pm @@ -44,8 +44,10 @@ sub index :Path :Args(0) { hostname => $uri->host, }); if (@{$urls || []}) { $c->stash->{exists_url} = $urls; - $c->stash->{subtemplate} = 'new/mirror_exists.tt'; - return; + if ($urls->[0]->{valid}) { + $c->stash->{subtemplate} = 'new/mirror_exists.tt'; + return; + } } if (!$c->model('Mirrors')->mirror_validity($uri)) { @@ -62,17 +64,18 @@ sub index :Path :Args(0) { my @ips = $c->model('Mirrors')->host_ips($uri->host); $c->stash->{location} = $c->model('Mirrors')->locate_ips(@ips); + $c->stash->{host}{country} = $c->stash->{location}{code}; 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)) { + foreach (qw(city country syncfrom bandwidth)) { $c->session->{hostinfo}{$_} = $c->req->param($_); } } else { - $c->stash->{subtemplate} = 'new/host_information.tt'; + $c->stash->{subtemplate} = 'new/new_host.tt'; return; } @@ -94,6 +97,8 @@ sub confirm :Path :Args(1) { $uri->host, city => $c->session->{hostinfo}{city}, country => $c->session->{hostinfo}{country}, + bandwidth => $c->session->{hostinfo}{bandwidth}, + syncfrom => $c->session->{hostinfo}{syncfrom}, ); } else { return; diff --git a/lib/MGA/Mirrors/DB.pm b/lib/MGA/Mirrors/DB.pm index 5ff0649..31eb4cc 100644 --- a/lib/MGA/Mirrors/DB.pm +++ b/lib/MGA/Mirrors/DB.pm @@ -74,6 +74,35 @@ sub locate_ips { return; } +sub protocol_list { + my ($self) = @_; + my $select = $self->db->prepare(q{ + select name from protocol order by name + }); + $select->execute; + return keys %{ $select->fetchall_hashref([ 'name' ]) } +} + +sub bandwidth_name { + my ($self, $value) = @_; + my $select = $self->db->prepare(q{ + select name from bandwidth where value = ? + }); + $select->execute($value); + my $res = $select->fetchrow_hashref; + $select->finish; + $res->{name} +} + +sub bandwidth_list { + my ($self) = @_; + my $list = $self->db->prepare(q{ + select * from bandwidth order by value + }); + $list->execute; + return $list->fetchall_arrayref({}); +} + sub country_list { my ($self) = @_; my $list = $self->db->prepare(q{ @@ -83,6 +112,27 @@ sub country_list { return $list->fetchall_arrayref({}); } +sub version_list { + my ($self) = @_; + my $list = $self->db->prepare(q{ + select * from distributions + }); + $list->execute; + return $list->fetchall_hashref([qw(version)]); +} + +sub arch_list { + my ($self, $version) = @_; + my $list = $self->db->prepare(q{ + select * from distributions + } . ($version + ? q{ where version = ? } + : q{}) + ); + $list->execute($version ? $version : ()); + return $list->fetchall_hashref([qw(arch)]); +} + sub mirror_validity { my ($self, $uri) = @_; my $listf = $self->db->prepare(q{ @@ -153,7 +203,7 @@ sub _check_url { 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 =~ /^http|ftp$/ ? "wget --no-check-certificate -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); @@ -196,6 +246,7 @@ sub find_mirrors { } if (my $field = { protocol => 'protocol', + valid => 'url.valid', }->{$_}) { push(@uw, sprintf('%s = any(?)', $field)); push(@uvals, ref $filters->{$_} ? $filters->{$_} : [ $filters->{$_} ]); @@ -220,17 +271,59 @@ sub _find_urls { }; my @vals; if (keys %{ $filters || {} }) { - $query .= ' where '; my @w; foreach (keys %$filters) { + $filters->{$_} or next; + my $field = { + hostname => 'hosts.hostname', + protocol => 'urls.protocol', + }->{$_} or next; + + push(@w, sprintf('%s = any(?)', $field)); + push(@vals, ref $filters->{$_} ? $filters->{$_} : [ $filters->{$_} ]); + } + $query .= ' where ' if (@w); + $query .= join(' and ', @w); + } + my $list = $self->db->prepare($query); + $list->execute(@vals); + return $list->fetchall_arrayref({}); +} + +sub find_distributions { + my ($self, $filters, $key) = @_; + return [ + map { $_->{url} = $self->fmt_url($_); $_ } + @{ $self->_find_distributions($filters) || []}] +} + +sub _find_distributions { + my ($self, $filters, $key) = @_; + + my $query = q{ + select *, urls.path || distributions.relpath as path from hosts + join urls on urls.hostname = hosts.hostname + join mirrors_distributions on urls.key = mirrors_distributions.urlskey + join distributions on distributions.dkey = mirrors_distributions.distributionkey + }; + + my @vals; + if (keys %{ $filters || {} }) { + my @w; + foreach (keys %$filters) { + $filters->{$_} or next; my $field = { hostname => 'hosts.hostname', protocol => 'urls.protocol', + version => 'distributions.version', + arch => 'distributions.arch', + country => 'mirrors.country', }->{$_} or next; push(@w, sprintf('%s = any(?)', $field)); push(@vals, ref $filters->{$_} ? $filters->{$_} : [ $filters->{$_} ]); } + $query .= ' where ' if (@w); $query .= join(' and ', @w); } my $list = $self->db->prepare($query); @@ -258,7 +351,7 @@ sub add_or_update_host { my (@fields, @vals); while (my ($field, $val) = each(%info)) { push(@fields, $field); - push(@vals, $val); + push(@vals, $val || undef); } if (keys %info) { my $upd = $self->db->prepare(sprintf(q{ @@ -289,7 +382,7 @@ sub add_or_update_url { } my $update = $self->db->prepare(q{ - update urls set path = ?, port = ? + update urls set path = ?, port = ?, valid = true where hostname = ? and protocol = ? }); @@ -349,6 +442,7 @@ sub find_urls { sub fmt_url { my ($self, $dburl) = @_; + $dburl->{path} =~ s:/+:/:g; my $uri = URI->new( sprintf('%s://%s%s', $dburl->{protocol}, |