- code base

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;