The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#
# This file is part of App-CPAN2Pkg
#
# This software is copyright (c) 2009 by Jerome Quelin.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use 5.010;
use strict;
use warnings;

package App::CPAN2Pkg::Worker::Mageia;
# ABSTRACT: worker dedicated to Mageia distribution
$App::CPAN2Pkg::Worker::Mageia::VERSION = '3.003';
use HTML::TreeBuilder;
use HTTP::Request;
use Moose;
use MooseX::ClassAttribute;
use MooseX::Has::Sugar;
use MooseX::POE;
use POE;
use POE::Component::Client::HTTP;
use Readonly;

extends 'App::CPAN2Pkg::Worker::RPM';

Readonly my $K => $poe_kernel;

# -- class attribute

class_has _urpm_ok => (
    rw,
    traits  => ['Counter'],
    isa     => 'Int',
    default => 2,
    handles => {
        _urpm_release => "inc",
        _urpm_grab    => "dec",
    },
);
class_has cpanplus_lock => ( ro, isa=>'App::CPAN2Pkg::Lock', default=>sub{ App::CPAN2Pkg::Lock->new } );


class_has _ua => ( ro, isa=>'Str', builder=>"_build__ua" );

sub _build__ua {
    my $ua = "mageia-bswait";
    POE::Component::Client::HTTP->spawn( Alias => $ua );
    return $ua;
}


# -- public methods

override cpan2dist_flavour => sub { "CPANPLUS::Dist::Mageia" };


# -- cpan2pkg logic implementation

{   # check_upstream_availability
    override check_upstream_availability => sub {
        my $self = shift;
        my $modname = $self->module->name;
        $K->post( main => log_step    => $modname => "Checking if module is packaged upstream");
        $K->post( main => log_comment => $modname => "waiting for semaphore before running urpm");
        $K->yield( "_check_upstream_availability_wait4lock" );
    };

    event _check_upstream_availability_wait4lock => sub {
        my $self = shift;
        if ( $self->_urpm_ok ) {
            $self->_urpm_grab;
            $K->yield( "_check_upstream_availability_lock_acquired" );
            return;
        }
        $K->delay( _check_upstream_availability_wait4lock => 0.1 );
    };

    event _check_upstream_availability_lock_acquired => sub {
        my $self = shift;
        my $modname = $self->module->name;
        $K->post( main => log_comment => $modname => "urpm semaphore acquired");
        my $cmd = "urpmq --whatprovides 'perl($modname)'";
        $self->run_command( $cmd => "_check_upstream_availability_done" );
    };

    event _check_upstream_availability_done => sub {
        my ($self, @args) = @_[OBJECT, ARG0 .. $#_];
        my $modname = $self->module->name;
        $self->_urpm_release;
        $K->post( main => log_comment => $modname => "urpm semaphore released");
        $K->yield( _check_upstream_availability_result => @args );
    };
}

{   # install_from_upstream
    override install_from_upstream => sub {
        super();
        $K->yield( get_rpm_lock => "_install_from_upstream_with_rpm_lock" );
    };

    #
    # _install_from_upstream_with_rpm_lock( )
    #
    # really install module from distribution, now that we have a lock
    # on rpm operations.
    #
    event _install_from_upstream_with_rpm_lock => sub {
        my $self = shift;
        my $modname = $self->module->name;
        my $cmd = "sudo urpmi --auto 'perl($modname)'";
        $self->run_command( $cmd => "_install_from_upstream_result" );
    };
}

{ # upstream_import_package
    override upstream_import_package => sub {
        super();
        my $self = shift;
        my $srpm = $self->srpm;
        my $cmd = "mgarepo import $srpm";
        $self->run_command( $cmd => "_upstream_import_package_result" );
    };
}

{ # upstream_build_package
    override upstream_build_package => sub {
        super();
        my $self = shift;
        my $pkgname = $self->pkgname;
        my $cmd = "mgarepo submit $pkgname";
        $self->run_command( $cmd => "_upstream_build_package_result" );
    };

    override _upstream_build_wait => sub {
        my $self = shift;
        $self->yield( "_upstream_build_wait_request" );
    };

    event _upstream_build_wait_request => sub {
        my $self = shift;
        my $pkgname = $self->pkgname;
        my $url = "http://pkgsubmit.mageia.org/?package=$pkgname&last";
        my $request = HTTP::Request->new(HEAD => $url);
        $K->post( $self->_ua => request => _upstream_build_wait_answer => $request );
    };

    event _upstream_build_wait_answer => sub {
        my ($self, $requests, $answers) = @_[OBJECT, ARG0, ARG1];
        my $answer = $answers->[0];
        my $status = $answer->header( 'x-bs-package-status' ) // "?";
        my $modname = $self->module->name;
        if ($status eq "uploaded") {
            # nice, we finally made it!
            my $min = 1;
            $K->post( main => log_comment => $modname =>
                "module successfully built, waiting $min minutes to index it" );
            # wait some time to be sure package has been indexed
            $K->delay( _upstream_build_package_ready => $min * 60 );
        }
        elsif ($status eq "failure" ) {
            my $url = "http://pkgsubmit.mageia.org/";
            $self->yield( _upstream_build_package_failed => $url );
        }
        else {
            # no definitive result, wait a bit before checking again
            $K->post( main => log_comment => $modname =>
                "still not ready (current status: $status), waiting 1 more minute" );
            $K->delay( _upstream_build_wait_request => 60 );
        }

    };
}


no Moose;
__PACKAGE__->meta->make_immutable;
1;

__END__

=pod

=head1 NAME

App::CPAN2Pkg::Worker::Mageia - worker dedicated to Mageia distribution

=head1 VERSION

version 3.003

=head1 DESCRIPTION

This class implements Mageia specificities that a general worker doesn't
know how to handle. It inherits from L<App::CPAN2Pkg::Worker::RPM>.

=head1 AUTHOR

Jerome Quelin <jquelin@gmail.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2009 by Jerome Quelin.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut