aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/MGA/Mirrors/Controller/Distrib.pm48
-rw-r--r--lib/MGA/Mirrors/Controller/Mirrors.pm66
-rw-r--r--lib/MGA/Mirrors/Controller/New.pm13
-rw-r--r--lib/MGA/Mirrors/DB.pm102
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},