view release on metacpan or  search on metacpan

lib/App/KGB/Client/ServerRef.pm  view on Meta::CPAN

        author     => $commit_author,
        branch     => $branch,
        module     => $module,
        extra      => $extra,
    };

    my $meth;
    if ( $protocol_ver eq 'auto' ) {
        $meth = 'send_changes_v4';
    }
    else {
        $meth = "send_changes_v$protocol_ver";
        die "Unsupported protocol version requested ($protocol_ver)\n"
            unless $self->can($meth);
    }

    $self->$meth($info);
}

sub relay_message {
    my ( $self, $client, $message, $opts ) = @_;

    $self->send_changes_json( $client->repo_id,
        { method => 'relay_message', params => [$message, $opts] } );
}

sub send_changes_soap {
    my ( $self, $message ) = @_;

    require SOAP::Lite;

    if ( $self->verbose ) {
        printf "SOAP call: %s/%s\n", $self->uri, $self->proxy;
        print "Message:\n", YAML::Dump($message);
    }
    if ( $self->dry_run ) {
        return;
    }

    my $s = SOAP::Lite->new( uri => $self->uri, proxy => $self->proxy );
    $s->transport->proxy->timeout( $self->timeout // 15 );

    my $res = $s->commit($message);

    # SOAP error?
    if ( $res->fault ) {
        die 'SOAP FAULT while talking to '
            . $self->uri . "\n"
            . 'FAULT MESSAGE: ', $res->fault->{faultstring}, "\n"
            . (
            $res->fault->{detail}
            ? 'FAULT DETAILS: ' . $res->fault->{detail}
            : ''
            );
    }
}

sub send_changes_json {
    my ( $self, $repo_id, $message ) = @_;

    require JSON::XS;
    require JSON::RPC::Client::Any;
    my $rpc = JSON::RPC::Client::Any->new();

    $rpc->ua->timeout($self->timeout // 15);
    $message->{id} = 1;
    $message->{version} = '1.1';
    my $json = eval { JSON::XS::encode_json($message); };
    unless ($json) {
        my $dump;
        if ( require Devel::PartialDump ) {
            $dump = Devel::PartialDump->new->dump($message);
        }
        elsif ( require Data::Dumper ) {
            $dump = Data::Dumper::Dump($message);
        }
        else {
            $dump = '(Neither Devel::PartialDump nor Data::Dumper available)';
        }

        confess "Unable to encode message structure as JSON\n" . $dump . "\n"
            . $@;
    }

    my $hash = sha1_hex( $self->password, $repo_id, $json );

    $rpc->ua->default_header( 'X-KGB-Auth', $hash );
    $rpc->ua->default_header( 'X-KGB-Project', $repo_id );

    if ( $self->verbose ) {
        printf "JSON/RPC call: %s/json-rpc\n", $self->uri;
        print "Headers:\n", $rpc->ua->default_headers->as_string;
        print "Message:\n", YAML::Dump($message);
    }
    if ( $self->dry_run ) {
        return;
    }

    my $res = $rpc->call( $self->uri . '/json-rpc', $message );

    die "Transport error: " . $rpc->status_line . "\n" unless $res;
    die "Server returned error: " . $res->error_message . "\n"
        if $res->is_error;
}

sub send_changes_v2 {
    my ( $self, $info ) = @_;

    my $message = join( "",
        $info->{repo_id},
        $info->{commit_id} // (),
        map( "$_", @{ $info->{changes} } ),
        $info->{commit_log},
        $info->{author} // (),
        $info->{branch} // (),
        $info->{module} // (),
        $self->password );
    utf8::encode($message);
    my $checksum = sha1_hex($message);
    # SOAP::Transport::HTTP tries to convert all characters to byte sequences,
    # but fails. See around line 204
    my @message = (
        2,
        (   map {
                SOAP::Data->type(
                    string => Encode::encode( 'UTF-8', $_ ) )
            } ( $info->{repo_id}, $checksum, $info->{rev_prefix}, $info->{commit_id} )
        ),